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

header{*Gauss Jordan algorithm over nested IArrays*}

theory Gauss_Jordan_IArrays
imports
  Matrix_To_IArray
  Gauss_Jordan
begin

subsection{*Definitions and functions to compute the Gauss-Jordan algorithm over matrices represented as nested iarrays*}

definition "least_non_zero_position_of_vector_from_index A i = the (List.find (\<lambda>x. A !! x \<noteq> 0) [i..<IArray.length A])"
definition "least_non_zero_position_of_vector A = least_non_zero_position_of_vector_from_index A 0"

definition vector_all_zero_from_index :: "(nat \<times> 'a::{zero} iarray) => bool"
  where "vector_all_zero_from_index A' = (let i=fst A'; A=(snd A') in IArray_Addenda.all (\<lambda>x. A!!x = 0) (IArray [i..<(IArray.length A)]))"

definition Gauss_Jordan_in_ij_iarrays :: "'a::{field} iarray iarray => nat => nat => 'a iarray iarray "
  where "Gauss_Jordan_in_ij_iarrays A i j = (let n = least_non_zero_position_of_vector_from_index (column_iarray j A) i;
  interchange_A = interchange_rows_iarray A i n;
  A' = mult_row_iarray interchange_A i (1/interchange_A!!i!!j)
  in IArray.of_fun (\<lambda>s. if s = i then A' !! s else row_add_iarray A' s i (- interchange_A !! s !! j) !! s) (nrows_iarray A))"

definition Gauss_Jordan_column_k_iarrays :: "(nat \<times> 'a::{field} iarray iarray) => nat => (nat \<times> 'a iarray iarray)"
  where "Gauss_Jordan_column_k_iarrays A' k=(let A=(snd A'); i=(fst A') in
  if ((vector_all_zero_from_index (i, (column_iarray k A)))) \<or> i = (nrows_iarray A) then (i,A) else (Suc i, (Gauss_Jordan_in_ij_iarrays A i k)))"

definition Gauss_Jordan_upt_k_iarrays :: "'a::{field} iarray iarray => nat => 'a::{field} iarray iarray"
  where "Gauss_Jordan_upt_k_iarrays A k = snd (foldl Gauss_Jordan_column_k_iarrays (0,A) [0..<Suc k])"

definition Gauss_Jordan_iarrays :: "'a::{field} iarray iarray => 'a::{field} iarray iarray"
  where "Gauss_Jordan_iarrays A = Gauss_Jordan_upt_k_iarrays A (ncols_iarray A - 1)"

subsection{*Proving the equivalence between Gauss-Jordan algorithm over nested iarrays and over nested vecs (abstract matrices).*}

lemma vector_all_zero_from_index_eq:
fixes A::"'a::{zero}^'n::{mod_type}"
shows "(\<forall>m\<ge>i. A $ m = 0) = (vector_all_zero_from_index (to_nat i, vec_to_iarray A))"
proof (auto simp add: vector_all_zero_from_index_def Let_def is_none_def find_None_iff)
  fix x
  assume zero: "\<forall>m\<ge>i. A $ m = 0"
    and x_length: "x<length (IArray.list_of (vec_to_iarray A))" and i_le_x: "to_nat i \<le> x"
  have x_le_card: "x < CARD('n)"  using x_length unfolding vec_to_iarray_def by auto
  have i_le_from_nat_x: "i \<le> from_nat x"  using from_nat_mono'[OF i_le_x x_le_card] unfolding from_nat_to_nat_id .
  hence Axk: "A $ (from_nat x) = 0" using zero by simp
  have "vec_to_iarray A !! x = vec_to_iarray A !! to_nat (from_nat x::'n)" unfolding to_nat_from_nat_id[OF x_le_card] ..
  also have "... = A $ (from_nat x)" unfolding vec_to_iarray_nth' ..
  also have "... = 0" unfolding Axk ..
  finally show" IArray.list_of (vec_to_iarray A) ! x = 0"
    unfolding IArray.sub_def .
next
  fix m::'n
  assume zero_assm: "\<forall>x\<in>{mod_type_class.to_nat i..<length (IArray.list_of (vec_to_iarray A))}. IArray.list_of (vec_to_iarray A) ! x = 0"
   and i_le_m: "i \<le> m"
  have zero: "\<forall>x<length (IArray.list_of (vec_to_iarray A)). mod_type_class.to_nat i \<le> x \<longrightarrow> IArray.list_of (vec_to_iarray A) ! x = 0"
    using zero_assm by auto
  have to_nat_i_le_m:"to_nat i \<le> to_nat m" using to_nat_mono'[OF i_le_m] .
  have m_le_length: "to_nat m < IArray.length (vec_to_iarray A)" unfolding vec_to_iarray_def using to_nat_less_card by auto
  have "A $ m = vec_to_iarray A !! (to_nat m)" unfolding vec_to_iarray_nth' ..
  also have "... = 0" using zero to_nat_i_le_m m_le_length unfolding nrows_iarray_def by (metis IArray.sub_def length_def)
  finally show "A $ m = 0" .
qed

lemma matrix_vector_all_zero_from_index:
  fixes A::"'a::{zero}^'columns::{mod_type}^'rows::{mod_type}"
  shows "(\<forall>m\<ge>i. A $ m $ k = 0) = (vector_all_zero_from_index (to_nat i, vec_to_iarray (column k A)))"
  unfolding vector_all_zero_from_index_eq[symmetric] column_def by simp

lemma vec_to_iarray_least_non_zero_position_of_vector_from_index:
fixes A::"'a::{zero}^'n::{mod_type}"
assumes not_all_zero: "\<not> (vector_all_zero_from_index (to_nat i,  vec_to_iarray A))"
shows "least_non_zero_position_of_vector_from_index (vec_to_iarray A) (to_nat i) = to_nat (LEAST n. A $ n \<noteq> 0 \<and> i \<le> n)"
proof -
  have "\<exists>a. List.find (\<lambda>x. vec_to_iarray A !! x \<noteq> 0) [to_nat i..<IArray.length (vec_to_iarray A)] = Some a"
    proof (rule ccontr, simp, unfold sub_def[symmetric] length_def[symmetric])
      assume "List.find (\<lambda>x. (vec_to_iarray A) !! x \<noteq> 0) [to_nat i..<IArray.length (vec_to_iarray A)] = None"
      hence "\<not> (\<exists>x. x \<in> set [mod_type_class.to_nat i..<IArray.length (vec_to_iarray A)] \<and> vec_to_iarray A !! x \<noteq> 0)"
        unfolding find_None_iff .
      thus False using not_all_zero unfolding vector_all_zero_from_index_eq[symmetric]
      by (simp del: length_def sub_def, unfold length_vec_to_iarray, metis to_nat_less_card to_nat_mono' vec_to_iarray_nth')
     qed
  from this obtain a where a: "List.find (\<lambda>x. vec_to_iarray A !! x \<noteq> 0) [to_nat i..<IArray.length (vec_to_iarray A)] = Some a"
    by blast
  from this obtain ia where
    ia_less_length: "ia<length [to_nat i..<IArray.length (vec_to_iarray A)]" and
    not_eq_zero: "vec_to_iarray A !! ([to_nat i..<IArray.length (vec_to_iarray A)] ! ia) \<noteq> 0" and
    a_eq: "a = [to_nat i..<IArray.length (vec_to_iarray A)] ! ia"
    and least: "(\<forall>ja<ia. \<not> vec_to_iarray A !! ([to_nat i..<IArray.length (vec_to_iarray A)] ! ja) \<noteq> 0)"
    unfolding find_Some_iff by blast
  have not_eq_zero': "vec_to_iarray A !! a \<noteq> 0" using not_eq_zero unfolding a_eq .
  have i_less_a: "to_nat i \<le> a" using  ia_less_length length_upt nth_upt a_eq by auto
  have a_less_card: "a<CARD('n)" using a_eq ia_less_length unfolding vec_to_iarray_def by auto
  have "(LEAST n. A $ n \<noteq> 0 \<and> i \<le> n) = from_nat a"
  proof (rule Least_equality, rule conjI)
    show "A $ from_nat a \<noteq> 0"  unfolding vec_to_iarray_nth'[symmetric] using not_eq_zero' unfolding to_nat_from_nat_id[OF a_less_card] .
    show "i \<le> from_nat a" using a_less_card from_nat_mono' from_nat_to_nat_id i_less_a by fastforce
    fix x assume "A $ x  \<noteq> 0 \<and> i \<le> x" hence Axj: "A $ x \<noteq> 0" and i_le_x: "i \<le> x" by fast+
    show "from_nat a \<le> x"
    proof (rule ccontr)
      assume "\<not> from_nat a \<le> x" hence x_less_from_nat_a: "x < from_nat a" by simp
      def ja\<equiv>"(to_nat x) - (to_nat i)"
      have to_nat_x_less_card: "to_nat x < CARD ('n)" using bij_to_nat[where ?'a='n] unfolding bij_betw_def by fastforce
      hence ja_less_length: "ja < IArray.length (vec_to_iarray A)" unfolding ja_def vec_to_iarray_def by auto
      have "[to_nat i..<IArray.length (vec_to_iarray A)] ! ja = to_nat i + ja"
      by (rule nth_upt, unfold vec_to_iarray_def,auto, metis add_diff_inverse diff_add_zero ja_def not_less_iff_gr_or_eq to_nat_less_card)
      also have i_plus_ja: "... = to_nat x" unfolding ja_def by (simp add: i_le_x to_nat_mono')
      finally have list_rw: "[to_nat i..<IArray.length (vec_to_iarray A)] ! ja = to_nat x" .
      moreover have "ja<ia"
      proof -
        have "a = to_nat i + ia" unfolding a_eq
          by (rule nth_upt, metis ia_less_length length_upt less_diff_conv add.commute)
        thus ?thesis by (metis i_plus_ja add_less_cancel_right add.commute to_nat_le x_less_from_nat_a)
      qed
      ultimately have "vec_to_iarray A !! (to_nat x) = 0" using least by auto
      hence "A $ x = 0" unfolding vec_to_iarray_nth' .
      thus False using Axj by contradiction
    qed
  qed
  hence "a = to_nat (LEAST n. A $ n \<noteq> 0 \<and> i \<le> n)" using to_nat_from_nat_id[OF a_less_card] by simp
  thus ?thesis unfolding least_non_zero_position_of_vector_from_index_def unfolding a by simp
qed

corollary vec_to_iarray_least_non_zero_position_of_vector_from_index':
fixes A::"'a::{zero}^'cols::{mod_type}^'rows::{mod_type}"
assumes not_all_zero: "\<not> (vector_all_zero_from_index (to_nat i, vec_to_iarray (column j A)))"
shows "least_non_zero_position_of_vector_from_index (vec_to_iarray (column j A)) (to_nat i) = to_nat (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)"
unfolding vec_to_iarray_least_non_zero_position_of_vector_from_index[OF not_all_zero]
unfolding column_def by fastforce

corollary vec_to_iarray_least_non_zero_position_of_vector_from_index'':
fixes A::"'a::{zero}^'cols::{mod_type}^'rows::{mod_type}"
assumes not_all_zero: "\<not> (vector_all_zero_from_index (to_nat j, vec_to_iarray (row i A)))"
shows "least_non_zero_position_of_vector_from_index (vec_to_iarray (row i A)) (to_nat j) = to_nat (LEAST n. A $ i $ n \<noteq> 0 \<and> j \<le> n)"
unfolding vec_to_iarray_least_non_zero_position_of_vector_from_index[OF not_all_zero]
unfolding row_def by fastforce

lemma matrix_to_iarray_Gauss_Jordan_in_ij[code_unfold]:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  assumes not_all_zero: "\<not> (vector_all_zero_from_index (to_nat i, vec_to_iarray (column j A)))"
  shows "matrix_to_iarray (Gauss_Jordan_in_ij A i j) = Gauss_Jordan_in_ij_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j)"
proof (unfold Gauss_Jordan_in_ij_def Gauss_Jordan_in_ij_iarrays_def Let_def, rule matrix_to_iarray_eq_of_fun, auto simp del: sub_def length_def)
  show "vec_to_iarray (mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j) $ i) =
    mult_row_iarray
     (interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
       (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)))
     (to_nat i) (1 / interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
           (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)) !! to_nat i !! to_nat j) !! to_nat i"
    unfolding vec_to_iarray_column[symmetric]
    unfolding vec_to_iarray_least_non_zero_position_of_vector_from_index'[OF not_all_zero]
    unfolding matrix_to_iarray_interchange_rows[symmetric]
    unfolding matrix_to_iarray_mult_row[symmetric]
    unfolding matrix_to_iarray_nth
    unfolding interchange_rows_i
    unfolding vec_matrix ..
next
  fix ia
  show "vec_to_iarray
          (row_add (mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / A $ (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ j)) ia i
            (- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ ia $ j) $ ia) =
         row_add_iarray
          (mult_row_iarray
            (interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
              (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)))
            (to_nat i)
            (1 / interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
                  (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)) !!
                 to_nat i !! to_nat j))
          (to_nat ia) (to_nat i)
          (- interchange_rows_iarray (matrix_to_iarray A) (to_nat i)
              (least_non_zero_position_of_vector_from_index (column_iarray (to_nat j) (matrix_to_iarray A)) (to_nat i)) !!
             to_nat ia !! to_nat j) !! to_nat ia"
    unfolding vec_to_iarray_column[symmetric]
    unfolding vec_to_iarray_least_non_zero_position_of_vector_from_index'[OF not_all_zero]
    unfolding matrix_to_iarray_interchange_rows[symmetric]
    unfolding matrix_to_iarray_mult_row[symmetric]
    unfolding matrix_to_iarray_nth
    unfolding interchange_rows_i
    unfolding matrix_to_iarray_row_add[symmetric]
    unfolding vec_matrix ..
next
  show "nrows_iarray (matrix_to_iarray A) =
    IArray.length (matrix_to_iarray
    (\<chi> s. if s = i then mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j) $ s
    else row_add (mult_row (interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)) i (1 / interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ i $ j)) s i
    (- interchange_rows A i (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n) $ s $ j) $ s))"
    unfolding length_eq_card_rows nrows_eq_card_rows ..
qed

lemma matrix_to_iarray_Gauss_Jordan_column_k_1:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  and i: "i\<le>nrows A"
  shows "(fst (Gauss_Jordan_column_k (i, A) k)) = fst (Gauss_Jordan_column_k_iarrays (i, matrix_to_iarray A) k)"
proof (cases "i<nrows A")
  case True
  show ?thesis
    unfolding Gauss_Jordan_column_k_def Let_def Gauss_Jordan_column_k_iarrays_def fst_conv snd_conv
    unfolding vec_to_iarray_column[of "from_nat k" A, unfolded to_nat_from_nat_id[OF k[unfolded ncols_def]], symmetric]
    using matrix_vector_all_zero_from_index[symmetric, of "from_nat i::'rows" "from_nat k::'columns"]
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]] to_nat_from_nat_id[OF k[unfolded ncols_def]]
    using matrix_to_iarray_Gauss_Jordan_in_ij
    unfolding matrix_to_iarray_nrows snd_conv by auto
next
  case False
  have "vector_all_zero_from_index (nrows A, column_iarray k (matrix_to_iarray A))" unfolding vector_all_zero_from_index_def unfolding Let_def  snd_conv fst_conv
  unfolding nrows_def column_iarray_def
  unfolding length_eq_card_rows by (simp add: is_none_code(1))
  thus ?thesis
    using i False
    unfolding Gauss_Jordan_column_k_iarrays_def Gauss_Jordan_column_k_def Let_def by auto
qed

lemma matrix_to_iarray_Gauss_Jordan_column_k_2:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  and i: "i\<le>nrows A"
  shows "matrix_to_iarray (snd (Gauss_Jordan_column_k (i, A) k)) = snd (Gauss_Jordan_column_k_iarrays (i, matrix_to_iarray A) k)"
proof (cases "i<nrows A")
  case True show ?thesis
    unfolding Gauss_Jordan_column_k_def Let_def Gauss_Jordan_column_k_iarrays_def fst_conv snd_conv
    unfolding vec_to_iarray_column[of "from_nat k" A, unfolded to_nat_from_nat_id[OF k[unfolded ncols_def]], symmetric]
    unfolding matrix_vector_all_zero_from_index[symmetric, of "from_nat i::'rows" "from_nat k::'columns", symmetric]
    using matrix_to_iarray_Gauss_Jordan_in_ij[of "from_nat i::'rows" "from_nat k::'columns"]
    unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]] to_nat_from_nat_id[OF k[unfolded ncols_def]]
    unfolding matrix_to_iarray_nrows by auto
next
  case False show ?thesis
    using assms False unfolding Gauss_Jordan_column_k_def Let_def Gauss_Jordan_column_k_iarrays_def
    by (auto simp add: matrix_to_iarray_nrows)
qed

text{*Due to the assumptions presented in @{thm "matrix_to_iarray_Gauss_Jordan_column_k_2"}, the following lemma must have three shows.
The proof style is similar to @{thm "rref_and_index_Gauss_Jordan_upt_k"}.*}

lemma foldl_Gauss_Jordan_column_k_eq:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  assumes k: "k<ncols A"
  shows matrix_to_iarray_Gauss_Jordan_upt_k[code_unfold]: "matrix_to_iarray (Gauss_Jordan_upt_k A k) = Gauss_Jordan_upt_k_iarrays (matrix_to_iarray A) k"
  and fst_foldl_Gauss_Jordan_column_k_eq: "fst (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc k]) = fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k])"
  and fst_foldl_Gauss_Jordan_column_k_less: "fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]) \<le> nrows A"
  using assms
proof (induct k)
  show "matrix_to_iarray (Gauss_Jordan_upt_k A 0) = Gauss_Jordan_upt_k_iarrays (matrix_to_iarray A) 0"
    unfolding Gauss_Jordan_upt_k_def Gauss_Jordan_upt_k_iarrays_def  by (auto, metis k le0 less_nat_zero_code matrix_to_iarray_Gauss_Jordan_column_k_2 neq0_conv)
  show "fst (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc 0]) = fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc 0])"
    unfolding Gauss_Jordan_upt_k_def Gauss_Jordan_upt_k_iarrays_def by (auto, metis gr_implies_not0 k le0 matrix_to_iarray_Gauss_Jordan_column_k_1 neq0_conv)
  show "fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc 0]) \<le> nrows A" unfolding Gauss_Jordan_upt_k_def by (simp add: Gauss_Jordan_column_k_def Let_def size1 nrows_def)
next
  fix k
  assume "(k < ncols A \<Longrightarrow> matrix_to_iarray (Gauss_Jordan_upt_k A k) = Gauss_Jordan_upt_k_iarrays (matrix_to_iarray A) k)" and
    "(k < ncols A \<Longrightarrow> fst (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc k]) = fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]))"
    and "(k < ncols A \<Longrightarrow> fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]) \<le> nrows A)"
    and Suc_k_less_card: "Suc k < ncols A"
  hence hyp1: "matrix_to_iarray (Gauss_Jordan_upt_k A k) = Gauss_Jordan_upt_k_iarrays (matrix_to_iarray A) k"
    and hyp2: "fst (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc k]) = fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k])"
    and hyp3: "fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]) \<le> nrows A"
    by auto
  hence hyp1_unfolded: "matrix_to_iarray (snd (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k])) = snd (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc k])"
    using hyp1 unfolding Gauss_Jordan_upt_k_def Gauss_Jordan_upt_k_iarrays_def by simp
  have upt_rw: "[0..<Suc (Suc k)] = [0..<Suc k] @ [(Suc k)]" by auto
  have fold_rw: "(foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc k])
    = (fst (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc k]), snd (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc k]))"
    by simp
  have fold_rw': "(foldl Gauss_Jordan_column_k (0, A) [0..<(Suc k)])
    = (fst (foldl Gauss_Jordan_column_k (0, A) [0..<(Suc k)]), snd (foldl Gauss_Jordan_column_k (0, A) [0..<(Suc k)]))" by simp
  show "fst (foldl Gauss_Jordan_column_k_iarrays (0, matrix_to_iarray A) [0..<Suc (Suc k)]) = fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc (Suc k)])"
    unfolding upt_rw foldl_append unfolding List.foldl.simps apply (subst fold_rw) apply (subst fold_rw') unfolding hyp2 unfolding hyp1_unfolded[symmetric]
  proof (rule matrix_to_iarray_Gauss_Jordan_column_k_1[symmetric, of "Suc k" "(snd (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]))"])
    show "Suc k < ncols (snd (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]))"  using Suc_k_less_card unfolding ncols_def .
    show " fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]) \<le> nrows (snd (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]))" using hyp3 unfolding nrows_def .
  qed
  show "matrix_to_iarray (Gauss_Jordan_upt_k A (Suc k)) = Gauss_Jordan_upt_k_iarrays (matrix_to_iarray A) (Suc k)"
    unfolding Gauss_Jordan_upt_k_def Gauss_Jordan_upt_k_iarrays_def  upt_rw foldl_append  List.foldl.simps
    apply (subst fold_rw) apply (subst fold_rw') unfolding hyp2 hyp1_unfolded[symmetric]
  proof (rule matrix_to_iarray_Gauss_Jordan_column_k_2, unfold ncols_def nrows_def)
    show "Suc k < CARD('columns)" using Suc_k_less_card unfolding ncols_def .
    show "fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc k]) \<le> CARD('rows)" using hyp3 unfolding nrows_def .
  qed
  show "fst (foldl Gauss_Jordan_column_k (0, A) [0..<Suc (Suc k)]) \<le> nrows A"
    unfolding upt_rw foldl_append unfolding List.foldl.simps apply (subst fold_rw')
    unfolding Gauss_Jordan_column_k_def Let_def
    using hyp3 le_antisym not_less_eq_eq unfolding nrows_def by fastforce
qed

lemma matrix_to_iarray_Gauss_Jordan[code_unfold]:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (Gauss_Jordan A) = Gauss_Jordan_iarrays (matrix_to_iarray A)"
  unfolding Gauss_Jordan_iarrays_def ncols_iarray_def unfolding length_eq_card_columns
  by (auto simp add: Gauss_Jordan_def matrix_to_iarray_Gauss_Jordan_upt_k ncols_def)

subsection{*Implementation over IArrays of the computation of the @{term "rank"} of a matrix*}

definition rank_iarray :: "'a::{field} iarray iarray => nat"
  where "rank_iarray A = (let A' = (Gauss_Jordan_iarrays A); nrows = (IArray.length A') in card {i. i<nrows \<and> \<not> is_zero_iarray (A' !! i)})"

subsubsection{*Proving the equivalence between @{term "rank"} and @{term "rank_iarray"}.*}

text{*First of all, some code equations are removed to allow the execution of Gauss-Jordan algorithm using iarrays*}
lemmas card'_code(2)[code del]
lemmas rank_Gauss_Jordan_code[code del]

lemma rank_eq_card_iarrays:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "rank A = card {vec_to_iarray (row i (Gauss_Jordan A)) |i. \<not> is_zero_iarray (vec_to_iarray (row i (Gauss_Jordan A)))}"
proof (unfold rank_Gauss_Jordan_eq Let_def, rule bij_betw_same_card[of "vec_to_iarray"], auto simp add: bij_betw_def)
  show "inj_on vec_to_iarray {row i (Gauss_Jordan A) |i. row i (Gauss_Jordan A) \<noteq> 0}" using inj_vec_to_iarray unfolding inj_on_def by blast
  fix i assume r: "row i (Gauss_Jordan A) \<noteq> 0"
  show "\<exists>ia. vec_to_iarray (row i (Gauss_Jordan A)) = vec_to_iarray (row ia (Gauss_Jordan A)) \<and> \<not> is_zero_iarray (vec_to_iarray (row ia (Gauss_Jordan A)))"
  proof (rule exI[of _ i], simp)
    show "\<not> is_zero_iarray (vec_to_iarray (row i (Gauss_Jordan A)))" using r unfolding is_zero_iarray_eq_iff .
  qed
next
  fix i
  assume not_zero_iarray: "\<not> is_zero_iarray (vec_to_iarray (row i (Gauss_Jordan A)))"
  show "vec_to_iarray (row i (Gauss_Jordan A)) \<in> vec_to_iarray ` {row i (Gauss_Jordan A) |i. row i (Gauss_Jordan A) \<noteq> 0}"
    by (rule imageI, auto simp add: not_zero_iarray  is_zero_iarray_eq_iff)
qed

lemma rank_eq_card_iarrays':
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "rank A = (let A' = (Gauss_Jordan_iarrays (matrix_to_iarray A)) in card {row_iarray (to_nat i) A' |i::'rows. \<not> is_zero_iarray (A' !! (to_nat i))})"
  unfolding Let_def unfolding rank_eq_card_iarrays vec_to_iarray_row'  matrix_to_iarray_Gauss_Jordan row_iarray_def ..

lemma rank_eq_card_iarrays_code:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "rank A = (let A' = (Gauss_Jordan_iarrays (matrix_to_iarray A)) in card {i::'rows. \<not> is_zero_iarray (A' !! (to_nat i))})"
proof (unfold rank_eq_card_iarrays' Let_def, rule bij_betw_same_card[symmetric, of "\<lambda>i. row_iarray (to_nat i) (Gauss_Jordan_iarrays (matrix_to_iarray A))"],
    unfold bij_betw_def inj_on_def, auto, unfold sub_def[symmetric])
  fix x y::'rows
  assume x: "\<not> is_zero_iarray (Gauss_Jordan_iarrays (matrix_to_iarray A) !! to_nat x)"
    and y: "\<not> is_zero_iarray (Gauss_Jordan_iarrays (matrix_to_iarray A) !! to_nat y)"
    and eq: "row_iarray (to_nat x) (Gauss_Jordan_iarrays (matrix_to_iarray A)) = row_iarray (to_nat y) (Gauss_Jordan_iarrays (matrix_to_iarray A))"
  have eq': "(Gauss_Jordan A) $ x = (Gauss_Jordan A) $ y" by (metis eq matrix_to_iarray_Gauss_Jordan row_iarray_def vec_matrix vec_to_iarray_morph)
  hence not_zero_x: "\<not> is_zero_row x (Gauss_Jordan A)" and not_zero_y: "\<not> is_zero_row y (Gauss_Jordan A)"
    by (metis  is_zero_iarray_eq_iff is_zero_row_def' matrix_to_iarray_Gauss_Jordan vec_eq_iff vec_matrix x zero_index)+
  hence x_in: "row x (Gauss_Jordan A) \<in> {row i (Gauss_Jordan A) |i::'rows. row i (Gauss_Jordan A) \<noteq> 0}"
    and y_in: "row y (Gauss_Jordan A) \<in> {row i (Gauss_Jordan A) |i::'rows. row i (Gauss_Jordan A) \<noteq> 0}"
    by (metis (lifting, mono_tags) is_zero_iarray_eq_iff matrix_to_iarray_Gauss_Jordan mem_Collect_eq vec_to_iarray_row' x y)+
  show "x = y" using inj_index_independent_rows[OF _ x_in eq'] rref_Gauss_Jordan by fast
qed

subsubsection{*Code equations for computing the rank over nested iarrays and the dimensions of the elementary subspaces*}

lemma rank_iarrays_code[code]:
  "rank_iarray A = length (filter (\<lambda>x. \<not> is_zero_iarray x) (IArray.list_of (Gauss_Jordan_iarrays A)))"
proof -
  obtain xs where A_eq_xs: "(Gauss_Jordan_iarrays A) = IArray xs" by (metis iarray.exhaust)
  have "rank_iarray A = card {i. i<(IArray.length (Gauss_Jordan_iarrays A)) \<and> \<not> is_zero_iarray ((Gauss_Jordan_iarrays A) !! i)}" unfolding rank_iarray_def Let_def ..
  also have "... = length (filter (\<lambda>x. \<not> is_zero_iarray x) (IArray.list_of (Gauss_Jordan_iarrays A)))"
    unfolding A_eq_xs using length_filter_conv_card[symmetric] by force
  finally show ?thesis .
qed

lemma matrix_to_iarray_rank[code_unfold]:
  shows "rank A = rank_iarray (matrix_to_iarray A)"
  unfolding rank_eq_card_iarrays_code rank_iarray_def Let_def
  apply (rule bij_betw_same_card[of "to_nat"])
  unfolding bij_betw_def
  apply auto
  unfolding length_def[symmetric] sub_def[symmetric] apply (metis inj_onI to_nat_eq)
  unfolding  matrix_to_iarray_Gauss_Jordan[symmetric] length_eq_card_rows
  using bij_to_nat[where ?'a='c] unfolding bij_betw_def by auto

lemma dim_null_space_iarray[code_unfold]:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "vec.dim (null_space A) = ncols_iarray (matrix_to_iarray A) - rank_iarray (matrix_to_iarray A)"
  unfolding dim_null_space ncols_eq_card_columns matrix_to_iarray_rank dimension_vector by simp

lemma dim_col_space_iarray[code_unfold]:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "vec.dim (col_space A) = rank_iarray (matrix_to_iarray A)"
  unfolding rank_eq_dim_col_space[of A, symmetric]  matrix_to_iarray_rank ..

lemma dim_row_space_iarray[code_unfold]:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "vec.dim (row_space A) = rank_iarray (matrix_to_iarray A)"
  unfolding row_rank_def[symmetric] rank_def[symmetric] matrix_to_iarray_rank ..

lemma dim_left_null_space_space_iarray[code_unfold]:
  fixes A::"'a::{field}^'columns::{mod_type}^'rows::{mod_type}"
  shows "vec.dim (left_null_space A) = nrows_iarray (matrix_to_iarray A) - rank_iarray (matrix_to_iarray A)"
  unfolding dim_left_null_space nrows_eq_card_rows matrix_to_iarray_rank dimension_vector by auto

end


(*  Title:      RSAPSS/Productdivides.thy
    Author:     Christina Lindenberg, Kai Wirt, Technische Universität Darmstadt
    Copyright:  2005 - Technische Universität Darmstadt
*)

section "Lemmata for modular arithmetic with primes"

theory Productdivides
imports Pdifference
begin

lemma productdivides: "\<lbrakk>x mod a = (0::nat); x mod b = 0; prime a; prime b; a \<noteq> b\<rbrakk> \<Longrightarrow> x mod (a*b) = 0"
  by (simp add: mod_eq_0_iff_dvd primes_coprime divides_mult)

lemma specializedtoprimes1:
  fixes p::nat
  shows "\<lbrakk>prime p; prime q; p \<noteq> q; a mod p = b mod p ; a mod q = b mod q\<rbrakk>
         \<Longrightarrow> a mod (p*q) = b mod (p*q)"
by (metis equalmodstrick1 equalmodstrick2 productdivides)

lemma specializedtoprimes1a:
  fixes p::nat
  shows "\<lbrakk>prime p; prime q; p \<noteq> q; a mod p = b mod p; a mod q = b mod q; b < p*q \<rbrakk>
    \<Longrightarrow> a mod (p*q) = b"
  by (simp add: specializedtoprimes1)

end


theory locales imports Main
begin

locale partial_order =
    fixes le:: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
    assumes refl [intro, simp]: "x\<sqsubseteq>x"
    and anti_sym [intro]: "\<lbrakk> x\<sqsubseteq>y; y\<sqsubseteq>x \<rbrakk> \<Longrightarrow> x = y"
    and trans [trans]: "\<lbrakk> x\<sqsubseteq>y; y\<sqsubseteq>z \<rbrakk> \<Longrightarrow> x\<sqsubseteq>z"

print_locale! partial_order

thm partial_order_def

print_statement partial_order.trans

definition (in partial_order)
 less:: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubset>" 50)
 where "x\<sqsubset>y = (x\<sqsubseteq>y \<and> x\<noteq>y)"

print_statement partial_order.less_def

context partial_order
begin

  definition
  is_inf where "is_inf x y i = (i\<sqsubseteq>x \<and> i\<sqsubseteq>y \<and> (\<forall> z. z\<sqsubseteq>x \<and> z\<sqsubseteq>y \<longrightarrow> z\<sqsubseteq>i))"

  definition
  is_sup where "is_sup x y s = (x\<sqsubseteq>s \<and> y\<sqsubseteq>s \<and> (\<forall> z. x\<sqsubseteq>z \<and> y\<sqsubseteq>z \<longrightarrow> s\<sqsubseteq>z))"

  theorem is_inf_uniq: "\<lbrakk>is_inf x y i; is_inf x y i'\<rbrakk> \<Longrightarrow> i=i'"
  by (simp add: anti_sym is_inf_def)

  theorem is_sup_uniq: "\<lbrakk>is_sup x y s; is_sup x y s'\<rbrakk> \<Longrightarrow> s=s'"
  by (simp add: anti_sym is_sup_def)

end

locale lattice = partial_order +
  assumes ex_inf: "\<exists> inf. is_inf x y inf"
      and ex_sup: "\<exists> sup. is_sup x y sup"
begin
  definition
  meet (infixl "\<sqinter>" 70) where "x\<sqinter>y = (THE inf. is_inf x y inf)"

  definition
  join (infixl "\<squnion>" 65) where "x\<squnion>y = (THE sup. is_sup x y sup)"

  lemma meet_left: "x\<sqinter>y\<sqsubseteq>x"
  by (metis is_inf_def is_inf_uniq lattice.ex_inf local.lattice_axioms meet_def the_equality)

  lemma join_right: "x\<sqsubseteq>(x\<squnion>y)"
  by (metis ex_sup is_sup_def is_sup_uniq join_def the_equality)

end

locale total_order = partial_order +
  assumes total: "x\<sqsubseteq>y \<or> y\<sqsubseteq>x"

lemma (in total_order) less_order: "x\<sqsubset>y \<or> y\<sqsubset>x \<or> x=y"
  using less_def total by auto

locale distrib_lattice = lattice +
  assumes meet_distr: "x\<sqinter>(y\<squnion>z) = (x\<sqinter>y)\<squnion>(x\<sqinter>z)"

lemma (in distrib_lattice) join_distr: "x\<squnion>(y\<sqinter>z) = (x\<squnion>y) \<sqinter> (x\<squnion>z)"
sorry

sublocale total_order \<subseteq> lattice
proof unfold_locales
fix x y
from total have "is_inf x y (if x\<sqsubseteq>y then x else y)" by (auto simp: is_inf_def)
then show "\<exists> inf. is_inf x y inf" ..
from total have "is_sup x y (if x\<sqsubseteq>y then y else x)" by (auto simp: is_sup_def)
then show "\<exists> sup. is_sup x y sup" ..
qed

sublocale total_order \<subseteq> distrib_lattice
sorry

interpretation int:partial_order "op\<le> :: int \<Rightarrow> int \<Rightarrow> bool"
rewrites "int.less x y = (x < y)"
proof -
show "partial_order (op \<le> :: int \<Rightarrow> int \<Rightarrow> bool)" by unfold_locales auto
then
show "partial_order.less op \<le> x y = (x < y)"
unfolding partial_order.less_def [OF \<open>partial_order op\<le>\<close>] by auto
qed

interpretation int:partial_order "op\<le> ::[int, int] \<Rightarrow> bool"
rewrites "int.less x y = (x < y)"
proof -
show "partial_order (op \<le> :: int \<Rightarrow> int \<Rightarrow> bool)"
by unfold_locales auto
then interpret int:partial_order "op\<le> :: [int, int] \<Rightarrow> bool" .
show "int.less x y = (x < y)"
unfolding int.less_def by auto
qed

interpretation int:lattice "op\<le> ::int \<Rightarrow> int \<Rightarrow> bool"
 rewrites int_min_eq: "int.meet x y = min x y" and int_max_eq: "int.join x y = max x y"
proof -
show "lattice (op \<le> :: int \<Rightarrow> int \<Rightarrow> bool)"
apply unfold_locales
apply (unfold int.is_inf_def int.is_sup_def)
by arith+
then interpret int: lattice "op\<le> :: int \<Rightarrow> int \<Rightarrow> bool" .
 show "int.meet x y = min x y"
  by (bestsimp simp: int.meet_def int.is_inf_def)
 show "int.join x y = max x y"
  by (bestsimp simp: int.join_def int.is_sup_def)
qed

interpretation int: total_order "op\<le> :: int \<Rightarrow> int \<Rightarrow> bool"
by unfold_locales arith

print_interps partial_order

end


(*  Title:      HOL/Isar_Examples/Cantor.thy
    Author:     Makarius
*)

section \<open>Cantor's Theorem\<close>

theory Cantor
  imports Main
begin

subsection \<open>Mathematical statement and proof\<close>

text \<open>
  Cantor's Theorem states that there is no surjection from
  a set to its powerset.  The proof works by diagonalization.  E.g.\ see
  \<^item> \<^url>\<open>http://mathworld.wolfram.com/CantorDiagonalMethod.html\<close>
  \<^item> \<^url>\<open>https://en.wikipedia.org/wiki/Cantor's_diagonal_argument\<close>
\<close>

theorem Cantor: "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a set" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "{x. x \<notin> f x}"
  from * obtain a where "?D = f a" by blast
  moreover have "a \<in> ?D \<longleftrightarrow> a \<notin> f a" by blast
  ultimately show False by blast
qed

subsection \<open>Automated proofs\<close>

text \<open>
  These automated proofs are much shorter, but lack information why and how it
  works.
\<close>

theorem "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. f x = A"
  by best

theorem "\<nexists>f :: 'a \<Rightarrow> 'a set. \<forall>A. \<exists>x. f x = A"
  by force

subsection \<open>Elementary version in higher-order predicate logic\<close>

text \<open>
  The subsequent formulation bypasses set notation of HOL; it uses elementary
  \<open>\<lambda>\<close>-calculus and predicate logic, with standard introduction and elimination
  rules. This also shows that the proof does not require classical reasoning.
\<close>

lemma iff_contradiction:
  assumes *: "\<not> A \<longleftrightarrow> A"
  shows False
proof (rule notE)
  show "\<not> A"
  proof
    assume A
    with * have "\<not> A" ..
    from this and \<open>A\<close> show False ..
  qed
  with * show A ..
qed

theorem Cantor': "\<nexists>f :: 'a \<Rightarrow> 'a \<Rightarrow> bool. \<forall>A. \<exists>x. A = f x"
proof
  assume "\<exists>f :: 'a \<Rightarrow> 'a \<Rightarrow> bool. \<forall>A. \<exists>x. A = f x"
  then obtain f :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where *: "\<forall>A. \<exists>x. A = f x" ..
  let ?D = "\<lambda>x. \<not> f x x"
  from * have "\<exists>x. ?D = f x" ..
  then obtain a where "?D = f a" ..
  then have "?D a \<longleftrightarrow> f a a" by (rule arg_cong)
  then have "\<not> f a a \<longleftrightarrow> f a a" .
  then show False by (rule iff_contradiction)
qed

subsection \<open>Classic Isabelle/HOL example\<close>

text \<open>
  The following treatment of Cantor's Theorem follows the classic example from
  the early 1990s, e.g.\ see the file @{verbatim "92/HOL/ex/set.ML"} in
  Isabelle92 or @{cite \<open>\S18.7\<close> "paulson-isa-book"}. The old tactic scripts
  synthesize key information of the proof by refinement of schematic goal
  states. In contrast, the Isar proof needs to say explicitly what is proven.

  \<^bigskip>
  Cantor's Theorem states that every set has more subsets than it has
  elements. It has become a favourite basic example in pure higher-order logic
  since it is so easily expressed:

  @{text [display]
  \<open>\<forall>f::\<alpha> \<Rightarrow> \<alpha> \<Rightarrow> bool. \<exists>S::\<alpha> \<Rightarrow> bool. \<forall>x::\<alpha>. f x \<noteq> S\<close>}

  Viewing types as sets, \<open>\<alpha> \<Rightarrow> bool\<close> represents the powerset of \<open>\<alpha>\<close>. This
  version of the theorem states that for every function from \<open>\<alpha>\<close> to its
  powerset, some subset is outside its range. The Isabelle/Isar proofs below
  uses HOL's set theory, with the type \<open>\<alpha> set\<close> and the operator \<open>range :: (\<alpha> \<Rightarrow>
  \<beta>) \<Rightarrow> \<beta> set\<close>.
\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
proof
  let ?S = "{x. x \<notin> f x}"
  show "?S \<notin> range f"
  proof
    assume "?S \<in> range f"
    then obtain y where "?S = f y" ..
    then show False
    proof (rule equalityCE)
      assume "y \<in> f y"
      assume "y \<in> ?S"
      then have "y \<notin> f y" ..
      with \<open>y \<in> f y\<close> show ?thesis by contradiction
    next
      assume "y \<notin> ?S"
      assume "y \<notin> f y"
      then have "y \<in> ?S" ..
      with \<open>y \<notin> ?S\<close> show ?thesis by contradiction
    qed
  qed
qed

text \<open>
  How much creativity is required? As it happens, Isabelle can prove this
  theorem automatically using best-first search. Depth-first search would
  diverge, but best-first search successfully navigates through the large
  search space. The context of Isabelle's classical prover contains rules for
  the relevant constructs of HOL's set theory.
\<close>

theorem "\<exists>S. S \<notin> range (f :: 'a \<Rightarrow> 'a set)"
  by best

end


(*  Title:      HOL/Hahn_Banach/Subspace.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Subspaces\<close>

theory Subspace
imports Vector_Space "~~/src/HOL/Library/Set_Algebras"
begin

subsection \<open>Definition\<close>

text \<open>
  A non-empty subset @{text U} of a vector space @{text V} is a
  \emph{subspace} of @{text V}, iff @{text U} is closed under addition
  and scalar multiplication.
\<close>

locale subspace =
  fixes U :: "'a\<Colon>{minus, plus, zero, uminus} set" and V
  assumes non_empty [iff, intro]: "U \<noteq> {}"
    and subset [iff]: "U \<subseteq> V"
    and add_closed [iff]: "x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x + y \<in> U"
    and mult_closed [iff]: "x \<in> U \<Longrightarrow> a \<cdot> x \<in> U"

notation (symbols)
  subspace  (infix "\<unlhd>" 50)

declare vectorspace.intro [intro?] subspace.intro [intro?]

lemma subspace_subset [elim]: "U \<unlhd> V \<Longrightarrow> U \<subseteq> V"
  by (rule subspace.subset)

lemma (in subspace) subsetD [iff]: "x \<in> U \<Longrightarrow> x \<in> V"
  using subset by blast

lemma subspaceD [elim]: "U \<unlhd> V \<Longrightarrow> x \<in> U \<Longrightarrow> x \<in> V"
  by (rule subspace.subsetD)

lemma rev_subspaceD [elim?]: "x \<in> U \<Longrightarrow> U \<unlhd> V \<Longrightarrow> x \<in> V"
  by (rule subspace.subsetD)

lemma (in subspace) diff_closed [iff]:
  assumes "vectorspace V"
  assumes x: "x \<in> U" and y: "y \<in> U"
  shows "x - y \<in> U"
proof -
  interpret vectorspace V by fact
  from x y show ?thesis by (simp add: diff_eq1 negate_eq1)
qed

text \<open>
  \medskip Similar as for linear spaces, the existence of the zero
  element in every subspace follows from the non-emptiness of the
  carrier set and by vector space laws.
\<close>

lemma (in subspace) zero [intro]:
  assumes "vectorspace V"
  shows "0 \<in> U"
proof -
  interpret V: vectorspace V by fact
  have "U \<noteq> {}" by (rule non_empty)
  then obtain x where x: "x \<in> U" by blast
  then have "x \<in> V" .. then have "0 = x - x" by simp
  also from \<open>vectorspace V\<close> x x have "\<dots> \<in> U" by (rule diff_closed)
  finally show ?thesis .
qed

lemma (in subspace) neg_closed [iff]:
  assumes "vectorspace V"
  assumes x: "x \<in> U"
  shows "- x \<in> U"
proof -
  interpret vectorspace V by fact
  from x show ?thesis by (simp add: negate_eq1)
qed

text \<open>\medskip Further derived laws: every subspace is a vector space.\<close>

lemma (in subspace) vectorspace [iff]:
  assumes "vectorspace V"
  shows "vectorspace U"
proof -
  interpret vectorspace V by fact
  show ?thesis
  proof
    show "U \<noteq> {}" ..
    fix x y z assume x: "x \<in> U" and y: "y \<in> U" and z: "z \<in> U"
    fix a b :: real
    from x y show "x + y \<in> U" by simp
    from x show "a \<cdot> x \<in> U" by simp
    from x y z show "(x + y) + z = x + (y + z)" by (simp add: add_ac)
    from x y show "x + y = y + x" by (simp add: add_ac)
    from x show "x - x = 0" by simp
    from x show "0 + x = x" by simp
    from x y show "a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y" by (simp add: distrib)
    from x show "(a + b) \<cdot> x = a \<cdot> x + b \<cdot> x" by (simp add: distrib)
    from x show "(a * b) \<cdot> x = a \<cdot> b \<cdot> x" by (simp add: mult_assoc)
    from x show "1 \<cdot> x = x" by simp
    from x show "- x = - 1 \<cdot> x" by (simp add: negate_eq1)
    from x y show "x - y = x + - y" by (simp add: diff_eq1)
  qed
qed

text \<open>The subspace relation is reflexive.\<close>

lemma (in vectorspace) subspace_refl [intro]: "V \<unlhd> V"
proof
  show "V \<noteq> {}" ..
  show "V \<subseteq> V" ..
next
  fix x y assume x: "x \<in> V" and y: "y \<in> V"
  fix a :: real
  from x y show "x + y \<in> V" by simp
  from x show "a \<cdot> x \<in> V" by simp
qed

text \<open>The subspace relation is transitive.\<close>

lemma (in vectorspace) subspace_trans [trans]:
  "U \<unlhd> V \<Longrightarrow> V \<unlhd> W \<Longrightarrow> U \<unlhd> W"
proof
  assume uv: "U \<unlhd> V" and vw: "V \<unlhd> W"
  from uv show "U \<noteq> {}" by (rule subspace.non_empty)
  show "U \<subseteq> W"
  proof -
    from uv have "U \<subseteq> V" by (rule subspace.subset)
    also from vw have "V \<subseteq> W" by (rule subspace.subset)
    finally show ?thesis .
  qed
  fix x y assume x: "x \<in> U" and y: "y \<in> U"
  from uv and x y show "x + y \<in> U" by (rule subspace.add_closed)
  from uv and x show "\<And>a. a \<cdot> x \<in> U" by (rule subspace.mult_closed)
qed

subsection \<open>Linear closure\<close>

text \<open>
  The \emph{linear closure} of a vector @{text x} is the set of all
  scalar multiples of @{text x}.
\<close>

definition lin :: "('a::{minus,plus,zero}) \<Rightarrow> 'a set"
  where "lin x = {a \<cdot> x | a. True}"

lemma linI [intro]: "y = a \<cdot> x \<Longrightarrow> y \<in> lin x"
  unfolding lin_def by blast

lemma linI' [iff]: "a \<cdot> x \<in> lin x"
  unfolding lin_def by blast

lemma linE [elim]: "x \<in> lin v \<Longrightarrow> (\<And>a::real. x = a \<cdot> v \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding lin_def by blast

text \<open>Every vector is contained in its linear closure.\<close>

lemma (in vectorspace) x_lin_x [iff]: "x \<in> V \<Longrightarrow> x \<in> lin x"
proof -
  assume "x \<in> V"
  then have "x = 1 \<cdot> x" by simp
  also have "\<dots> \<in> lin x" ..
  finally show ?thesis .
qed

lemma (in vectorspace) "0_lin_x" [iff]: "x \<in> V \<Longrightarrow> 0 \<in> lin x"
proof
  assume "x \<in> V"
  then show "0 = 0 \<cdot> x" by simp
qed

text \<open>Any linear closure is a subspace.\<close>

lemma (in vectorspace) lin_subspace [intro]:
  assumes x: "x \<in> V"
  shows "lin x \<unlhd> V"
proof
  from x show "lin x \<noteq> {}" by auto
next
  show "lin x \<subseteq> V"
  proof
    fix x' assume "x' \<in> lin x"
    then obtain a where "x' = a \<cdot> x" ..
    with x show "x' \<in> V" by simp
  qed
next
  fix x' x'' assume x': "x' \<in> lin x" and x'': "x'' \<in> lin x"
  show "x' + x'' \<in> lin x"
  proof -
    from x' obtain a' where "x' = a' \<cdot> x" ..
    moreover from x'' obtain a'' where "x'' = a'' \<cdot> x" ..
    ultimately have "x' + x'' = (a' + a'') \<cdot> x"
      using x by (simp add: distrib)
    also have "\<dots> \<in> lin x" ..
    finally show ?thesis .
  qed
  fix a :: real
  show "a \<cdot> x' \<in> lin x"
  proof -
    from x' obtain a' where "x' = a' \<cdot> x" ..
    with x have "a \<cdot> x' = (a * a') \<cdot> x" by (simp add: mult_assoc)
    also have "\<dots> \<in> lin x" ..
    finally show ?thesis .
  qed
qed

text \<open>Any linear closure is a vector space.\<close>

lemma (in vectorspace) lin_vectorspace [intro]:
  assumes "x \<in> V"
  shows "vectorspace (lin x)"
proof -
  from \<open>x \<in> V\<close> have "subspace (lin x) V"
    by (rule lin_subspace)
  from this and vectorspace_axioms show ?thesis
    by (rule subspace.vectorspace)
qed

subsection \<open>Sum of two vectorspaces\<close>

text \<open>
  The \emph{sum} of two vectorspaces @{text U} and @{text V} is the
  set of all sums of elements from @{text U} and @{text V}.
\<close>

lemma sum_def: "U + V = {u + v | u v. u \<in> U \<and> v \<in> V}"
  unfolding set_plus_def by auto

lemma sumE [elim]:
    "x \<in> U + V \<Longrightarrow> (\<And>u v. x = u + v \<Longrightarrow> u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> C) \<Longrightarrow> C"
  unfolding sum_def by blast

lemma sumI [intro]:
    "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> x = u + v \<Longrightarrow> x \<in> U + V"
  unfolding sum_def by blast

lemma sumI' [intro]:
    "u \<in> U \<Longrightarrow> v \<in> V \<Longrightarrow> u + v \<in> U + V"
  unfolding sum_def by blast

text \<open>@{text U} is a subspace of @{text "U + V"}.\<close>

lemma subspace_sum1 [iff]:
  assumes "vectorspace U" "vectorspace V"
  shows "U \<unlhd> U + V"
proof -
  interpret vectorspace U by fact
  interpret vectorspace V by fact
  show ?thesis
  proof
    show "U \<noteq> {}" ..
    show "U \<subseteq> U + V"
    proof
      fix x assume x: "x \<in> U"
      moreover have "0 \<in> V" ..
      ultimately have "x + 0 \<in> U + V" ..
      with x show "x \<in> U + V" by simp
    qed
    fix x y assume x: "x \<in> U" and "y \<in> U"
    then show "x + y \<in> U" by simp
    from x show "\<And>a. a \<cdot> x \<in> U" by simp
  qed
qed

text \<open>The sum of two subspaces is again a subspace.\<close>

lemma sum_subspace [intro?]:
  assumes "subspace U E" "vectorspace E" "subspace V E"
  shows "U + V \<unlhd> E"
proof -
  interpret subspace U E by fact
  interpret vectorspace E by fact
  interpret subspace V E by fact
  show ?thesis
  proof
    have "0 \<in> U + V"
    proof
      show "0 \<in> U" using \<open>vectorspace E\<close> ..
      show "0 \<in> V" using \<open>vectorspace E\<close> ..
      show "(0::'a) = 0 + 0" by simp
    qed
    then show "U + V \<noteq> {}" by blast
    show "U + V \<subseteq> E"
    proof
      fix x assume "x \<in> U + V"
      then obtain u v where "x = u + v" and
        "u \<in> U" and "v \<in> V" ..
      then show "x \<in> E" by simp
    qed
  next
    fix x y assume x: "x \<in> U + V" and y: "y \<in> U + V"
    show "x + y \<in> U + V"
    proof -
      from x obtain ux vx where "x = ux + vx" and "ux \<in> U" and "vx \<in> V" ..
      moreover
      from y obtain uy vy where "y = uy + vy" and "uy \<in> U" and "vy \<in> V" ..
      ultimately
      have "ux + uy \<in> U"
        and "vx + vy \<in> V"
        and "x + y = (ux + uy) + (vx + vy)"
        using x y by (simp_all add: add_ac)
      then show ?thesis ..
    qed
    fix a show "a \<cdot> x \<in> U + V"
    proof -
      from x obtain u v where "x = u + v" and "u \<in> U" and "v \<in> V" ..
      then have "a \<cdot> u \<in> U" and "a \<cdot> v \<in> V"
        and "a \<cdot> x = (a \<cdot> u) + (a \<cdot> v)" by (simp_all add: distrib)
      then show ?thesis ..
    qed
  qed
qed

text\<open>The sum of two subspaces is a vectorspace.\<close>

lemma sum_vs [intro?]:
    "U \<unlhd> E \<Longrightarrow> V \<unlhd> E \<Longrightarrow> vectorspace E \<Longrightarrow> vectorspace (U + V)"
  by (rule subspace.vectorspace) (rule sum_subspace)

subsection \<open>Direct sums\<close>

text \<open>
  The sum of @{text U} and @{text V} is called \emph{direct}, iff the
  zero element is the only common element of @{text U} and @{text
  V}. For every element @{text x} of the direct sum of @{text U} and
  @{text V} the decomposition in @{text "x = u + v"} with
  @{text "u \<in> U"} and @{text "v \<in> V"} is unique.
\<close>

lemma decomp:
  assumes "vectorspace E" "subspace U E" "subspace V E"
  assumes direct: "U \<inter> V = {0}"
    and u1: "u1 \<in> U" and u2: "u2 \<in> U"
    and v1: "v1 \<in> V" and v2: "v2 \<in> V"
    and sum: "u1 + v1 = u2 + v2"
  shows "u1 = u2 \<and> v1 = v2"
proof -
  interpret vectorspace E by fact
  interpret subspace U E by fact
  interpret subspace V E by fact
  show ?thesis
  proof
    have U: "vectorspace U"  (* FIXME: use interpret *)
      using \<open>subspace U E\<close> \<open>vectorspace E\<close> by (rule subspace.vectorspace)
    have V: "vectorspace V"
      using \<open>subspace V E\<close> \<open>vectorspace E\<close> by (rule subspace.vectorspace)
    from u1 u2 v1 v2 and sum have eq: "u1 - u2 = v2 - v1"
      by (simp add: add_diff_swap)
    from u1 u2 have u: "u1 - u2 \<in> U"
      by (rule vectorspace.diff_closed [OF U])
    with eq have v': "v2 - v1 \<in> U" by (simp only:)
    from v2 v1 have v: "v2 - v1 \<in> V"
      by (rule vectorspace.diff_closed [OF V])
    with eq have u': " u1 - u2 \<in> V" by (simp only:)

    show "u1 = u2"
    proof (rule add_minus_eq)
      from u1 show "u1 \<in> E" ..
      from u2 show "u2 \<in> E" ..
      from u u' and direct show "u1 - u2 = 0" by blast
    qed
    show "v1 = v2"
    proof (rule add_minus_eq [symmetric])
      from v1 show "v1 \<in> E" ..
      from v2 show "v2 \<in> E" ..
      from v v' and direct show "v2 - v1 = 0" by blast
    qed
  qed
qed

text \<open>
  An application of the previous lemma will be used in the proof of
  the Hahn-Banach Theorem (see page \pageref{decomp-H-use}): for any
  element @{text "y + a \<cdot> x\<^sub>0"} of the direct sum of a
  vectorspace @{text H} and the linear closure of @{text "x\<^sub>0"}
  the components @{text "y \<in> H"} and @{text a} are uniquely
  determined.
\<close>

lemma decomp_H':
  assumes "vectorspace E" "subspace H E"
  assumes y1: "y1 \<in> H" and y2: "y2 \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
    and eq: "y1 + a1 \<cdot> x' = y2 + a2 \<cdot> x'"
  shows "y1 = y2 \<and> a1 = a2"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  show ?thesis
  proof
    have c: "y1 = y2 \<and> a1 \<cdot> x' = a2 \<cdot> x'"
    proof (rule decomp)
      show "a1 \<cdot> x' \<in> lin x'" ..
      show "a2 \<cdot> x' \<in> lin x'" ..
      show "H \<inter> lin x' = {0}"
      proof
        show "H \<inter> lin x' \<subseteq> {0}"
        proof
          fix x assume x: "x \<in> H \<inter> lin x'"
          then obtain a where xx': "x = a \<cdot> x'"
            by blast
          have "x = 0"
          proof cases
            assume "a = 0"
            with xx' and x' show ?thesis by simp
          next
            assume a: "a \<noteq> 0"
            from x have "x \<in> H" ..
            with xx' have "inverse a \<cdot> a \<cdot> x' \<in> H" by simp
            with a and x' have "x' \<in> H" by (simp add: mult_assoc2)
            with \<open>x' \<notin> H\<close> show ?thesis by contradiction
          qed
          then show "x \<in> {0}" ..
        qed
        show "{0} \<subseteq> H \<inter> lin x'"
        proof -
          have "0 \<in> H" using \<open>vectorspace E\<close> ..
          moreover have "0 \<in> lin x'" using \<open>x' \<in> E\<close> ..
          ultimately show ?thesis by blast
        qed
      qed
      show "lin x' \<unlhd> E" using \<open>x' \<in> E\<close> ..
    qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, rule y1, rule y2, rule eq)
    then show "y1 = y2" ..
    from c have "a1 \<cdot> x' = a2 \<cdot> x'" ..
    with x' show "a1 = a2" by (simp add: mult_right_cancel)
  qed
qed

text \<open>
  Since for any element @{text "y + a \<cdot> x'"} of the direct sum of a
  vectorspace @{text H} and the linear closure of @{text x'} the
  components @{text "y \<in> H"} and @{text a} are unique, it follows from
  @{text "y \<in> H"} that @{text "a = 0"}.
\<close>

lemma decomp_H'_H:
  assumes "vectorspace E" "subspace H E"
  assumes t: "t \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
  shows "(SOME (y, a). t = y + a \<cdot> x' \<and> y \<in> H) = (t, 0)"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  show ?thesis
  proof (rule, simp_all only: split_paired_all split_conv)
    from t x' show "t = t + 0 \<cdot> x' \<and> t \<in> H" by simp
    fix y and a assume ya: "t = y + a \<cdot> x' \<and> y \<in> H"
    have "y = t \<and> a = 0"
    proof (rule decomp_H')
      from ya x' show "y + a \<cdot> x' = t + 0 \<cdot> x'" by simp
      from ya show "y \<in> H" ..
    qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, rule t, (rule x')+)
    with t x' show "(y, a) = (y + a \<cdot> x', 0)" by simp
  qed
qed

text \<open>
  The components @{text "y \<in> H"} and @{text a} in @{text "y + a \<cdot> x'"}
  are unique, so the function @{text h'} defined by
  @{text "h' (y + a \<cdot> x') = h y + a \<cdot> \<xi>"} is definite.
\<close>

lemma h'_definite:
  fixes H
  assumes h'_def:
    "h' \<equiv> \<lambda>x.
      let (y, a) = SOME (y, a). (x = y + a \<cdot> x' \<and> y \<in> H)
      in (h y) + a * xi"
    and x: "x = y + a \<cdot> x'"
  assumes "vectorspace E" "subspace H E"
  assumes y: "y \<in> H"
    and x': "x' \<notin> H"  "x' \<in> E"  "x' \<noteq> 0"
  shows "h' x = h y + a * xi"
proof -
  interpret vectorspace E by fact
  interpret subspace H E by fact
  from x y x' have "x \<in> H + lin x'" by auto
  have "\<exists>!p. (\<lambda>(y, a). x = y + a \<cdot> x' \<and> y \<in> H) p" (is "\<exists>!p. ?P p")
  proof (rule ex_ex1I)
    from x y show "\<exists>p. ?P p" by blast
    fix p q assume p: "?P p" and q: "?P q"
    show "p = q"
    proof -
      from p have xp: "x = fst p + snd p \<cdot> x' \<and> fst p \<in> H"
        by (cases p) simp
      from q have xq: "x = fst q + snd q \<cdot> x' \<and> fst q \<in> H"
        by (cases q) simp
      have "fst p = fst q \<and> snd p = snd q"
      proof (rule decomp_H')
        from xp show "fst p \<in> H" ..
        from xq show "fst q \<in> H" ..
        from xp and xq show "fst p + snd p \<cdot> x' = fst q + snd q \<cdot> x'"
          by simp
      qed (rule \<open>vectorspace E\<close>, rule \<open>subspace H E\<close>, (rule x')+)
      then show ?thesis by (cases p, cases q) simp
    qed
  qed
  then have eq: "(SOME (y, a). x = y + a \<cdot> x' \<and> y \<in> H) = (y, a)"
    by (rule some1_equality) (simp add: x y)
  with h'_def show "h' x = h y + a * xi" by (simp add: Let_def)
qed

end


theory Stuff
  imports "HOL-Algebra.Algebra"
begin

lemma inter_imp_subset: "A \<inter> B = A \<Longrightarrow> A \<subseteq> B"
  by blast

lemma card_inter_eq:
  assumes "finite A" "card (A \<inter> B) = card A"
  shows "A \<subseteq> B"
proof -
  have "A \<inter> B \<subseteq> A" by blast
  with assms have "A \<inter> B = A" using card_subset_eq by blast
  thus ?thesis by blast
qed

lemma coprime_eq_empty_prime_inter:
  assumes "(n::nat) \<noteq> 0" "m \<noteq> 0"
  shows "coprime n m \<longleftrightarrow> (prime_factors n) \<inter> (prime_factors m) = {}"
proof
  show "coprime n m \<Longrightarrow> prime_factors n \<inter> prime_factors m = {}"
  proof (rule ccontr)
    assume cp: "coprime n m"
    assume pf: "prime_factors n \<inter> prime_factors m \<noteq> {}"
    then obtain p where p: "p \<in> prime_factors n" "p \<in> prime_factors m" by blast
    then have p_dvd: "p dvd n" "p dvd m" by blast+
    moreover have "\<not>is_unit p" using p using not_prime_unit by blast
    ultimately show "False" using cp unfolding coprime_def by simp
  qed
  assume assm: "prime_factors n \<inter> prime_factors m = {}"
  show "coprime n m" unfolding coprime_def
  proof
    fix c
    show "c dvd n \<longrightarrow> c dvd m \<longrightarrow> is_unit c"
    proof(rule; rule)
      assume c: "c dvd n" "c dvd m"
      then have "prime_factors c \<subseteq> prime_factors n" "prime_factors c \<subseteq> prime_factors m"
        using assms dvd_prime_factors by blast+
      then have "prime_factors c = {}" using assm by blast
      thus "is_unit c" using assms c
        by (metis dvd_0_left_iff prime_factorization_empty_iff set_mset_eq_empty_iff)
    qed
  qed
qed

lemma prime_factors_Prod:
  assumes "finite S" "\<And>a. a \<in> S \<Longrightarrow> f a \<noteq> 0"
  shows "prime_factors (prod f S) = \<Union>(prime_factors ` f ` S)"
  using assms
proof(induction S rule: finite_induct)
  case empty
  then show ?case by simp
next
  case i: (insert x F)
  from i have x: "f x \<noteq> 0" by blast
  from i have F: "prod f F \<noteq> 0" by simp
  from i have "prime_factors(prod f F) = \<Union> (prime_factors ` f ` F)" by blast
  moreover have "prod f (insert x F) = (prod f F) * f x" using i mult.commute by force
  ultimately have "prime_factors (prod f (insert x F)) = (\<Union>(prime_factors ` f ` F)) \<union> prime_factors (f x)"
    using prime_factors_product[OF F x] by argo
  thus ?case by force
qed

lemma lcm_is_Min_multiple_nat:
  assumes "c \<noteq> 0" "(a::nat) dvd c" "(b::nat) dvd c"
  shows "c \<ge> lcm a b"
  using lcm_least[of a c b] assms by fastforce

lemma diff_prime_power_imp_coprime:
  assumes "p \<noteq> q" "Factorial_Ring.prime (p::nat)" "Factorial_Ring.prime q"
  shows "coprime (p ^ (n::nat)) (q ^ m)"
  using assms
  by (metis power_0 power_one_right prime_dvd_power prime_imp_power_coprime_nat prime_nat_iff prime_power_inj'')

lemma "finite (prime_factors x)"
  using finite_set_mset by blast

lemma card_ge_1_two_diff:
  assumes "card A > 1"
  obtains x y where "x \<in> A" "y \<in> A" "x \<noteq> y"
proof -
  have fA: "finite A" using assms by (metis card.infinite not_one_less_zero)
  from assms obtain x where x: "x \<in> A" by fastforce
  with assms fA have "card (A - {x}) > 0" by simp
  then obtain y where y: "y \<in> (A - {x})" by (metis card_gt_0_iff ex_in_conv)
  thus ?thesis using that[of x y] x by blast
qed

lemma infinite_two_diff:
  assumes "infinite A"
  obtains x y where "x \<in> A" "y \<in> A" "x \<noteq> y"
proof -
  from assms obtain x where x: "x \<in> A" by fastforce
  from assms have "infinite (A - {x})" by simp
  then obtain y where y: "y \<in> (A - {x})"
    by (metis ex_in_conv finite.emptyI)
  show ?thesis using that[of x y] using x y by blast
qed

lemma Inf_le:
  "Inf A \<le> x" if "x \<in> (A::nat set)" for x
proof (cases "A = {}")
  case True
  then show ?thesis using that by simp
next
  case False
  hence "Inf A \<le> Inf {x}" using that by (simp add: cInf_lower)
  also have "\<dots> = x" by simp
  finally show "Inf A \<le> x" by blast
qed

lemma switch_elem_card_le:
  assumes "a \<in> A"
  shows "card (A - {a} \<union> {b}) \<le> card A"
  using assms
  by (metis Diff_insert_absorb Set.set_insert Un_commute card.infinite card_insert_disjoint card_mono finite_insert insert_is_Un insert_subset order_refl)

lemma pairwise_coprime_dvd:
  assumes "finite A" "pairwise coprime A" "(n::nat) = prod id A" "\<forall>a\<in>A. a dvd j"
  shows "n dvd j"
  using assms
proof (induction A arbitrary: n)
  case i: (insert x F)
  have "prod id F dvd j" "x dvd j" using i unfolding pairwise_def by auto
  moreover have "coprime (prod id F) x"
    by (metis i(2, 4) id_apply pairwise_insert prod_coprime_left)
  ultimately show ?case using i(1, 2, 5) by (simp add: coprime_commute divides_mult)
qed simp

lemma pairwise_coprime_dvd':
  assumes "finite A" "\<And>i j. \<lbrakk>i \<in> A; j \<in> A; i \<noteq> j\<rbrakk> \<Longrightarrow> coprime (f i) (f j)" "(n::nat) = prod f A" "\<forall>a\<in>A. f a dvd j"
  shows "n dvd j"
  using assms
proof (induction A arbitrary: n)
  case i: (insert x F)
  have "prod f F dvd j" "f x dvd j" using i unfolding pairwise_def by auto
  moreover have "coprime (prod f F) (f x)" by(intro prod_coprime_left, use i in blast)
  ultimately show ?case using i by (simp add: coprime_commute divides_mult)
qed simp

lemma transp_successively_remove1:
  assumes "transp f" "successively f l"
  shows "successively f (remove1 a l)" using assms(2)
proof(induction l rule: induct_list012)
  case (3 x y zs)
  from 3(3)[unfolded successively.simps] have fs: "f x y" "successively f (y # zs)" by auto
  moreover from this(2) successively.simps have s: "successively f zs" by(cases zs, auto)
  ultimately have s2: "successively f (remove1 a zs)" "successively f (remove1 a (y # zs))" using 3 by auto
  consider (x) "x = a" | (y) "y = a \<and> x \<noteq> a" | (zs) "a \<noteq> x \<and> a \<noteq> y" by blast
  thus ?case
  proof (cases)
    case x
    then show ?thesis using 3 by simp
  next
    case y
    then show ?thesis
    proof (cases zs)
      case Nil
      then show ?thesis using fs by simp
    next
      case (Cons a list)
      hence "f y a" using fs by simp
      hence "f x a" using fs(1) assms(1)[unfolded transp_def] by blast
      then show ?thesis using Cons y s by auto
    qed
  next
    case zs
    then show ?thesis using s2 fs by auto
  qed
qed auto

lemma exp_one_2pi_iff:
  fixes x::real shows "exp (2 * of_real pi * \<i> * x) = 1 \<longleftrightarrow> x \<in> \<int>"
proof -
  have c: "cis (2 * x * pi) = 1 \<longleftrightarrow> x \<in> \<int>" by (auto simp: complex_eq_iff sin_times_pi_eq_0 cos_one_2pi_int, meson Ints_cases)
  have "exp (2 * of_real pi * \<i> * x) = exp (\<i> * complex_of_real (2 * x * pi))"
  proof -
    have "2 * of_real pi * \<i> * x = \<i> * complex_of_real (2 * x * pi)" by simp
    thus ?thesis by argo
  qed
  also from cis_conv_exp have "\<dots> = cis (2 * x * pi)" by simp
  finally show ?thesis using c by simp
qed

(* Manuel *)
lemma of_int_divide_in_Ints_iff:
  assumes "b \<noteq> 0"
  shows   "(of_int a / of_int b :: 'a :: field_char_0) \<in> \<int> \<longleftrightarrow> b dvd a"
proof
  assume *: "(of_int a / of_int b :: 'a :: field_char_0) \<in> \<int>"
  from * obtain n where "of_int a / of_int b = (of_int n :: 'a)"
    by (elim Ints_cases)
  hence "of_int (b * n) = (of_int a :: 'a)"
    using assms by (subst of_int_mult) (auto simp: field_simps)
  hence "b * n = a"
    by (subst (asm) of_int_eq_iff)
  thus "b dvd a" by auto
qed auto

(* Manuel *)
lemma of_nat_divide_in_Ints_iff:
  assumes "b \<noteq> 0"
  shows   "(of_nat a / of_nat b :: 'a :: field_char_0) \<in> \<int> \<longleftrightarrow> b dvd a"
  using of_int_divide_in_Ints_iff[of "int b" "int a"] assms by simp

lemma true_nth_unity_root:
  fixes n::nat
  obtains x::complex where "x ^ n = 1" "\<And>m. \<lbrakk>0<m; m<n\<rbrakk> \<Longrightarrow> x ^ m \<noteq> 1"
proof(cases "n = 0")
  case False
  show ?thesis
  proof (rule that)
    show "cis (2 * pi / n) ^ n = 1"
      by (simp add: DeMoivre)
  next
    fix m assume m: "m > 0" "m < n"
    have "cis (2 * pi / n) ^ m = cis (2 * pi * m / n)"
      by (simp add: DeMoivre algebra_simps)
    also have "\<dots> = 1 \<longleftrightarrow> real m / real n \<in> \<int>"
      using exp_one_2pi_iff[of "m / n"] by (simp add: cis_conv_exp algebra_simps)
    also have "\<dots> \<longleftrightarrow> n dvd m"
      using m by (subst of_nat_divide_in_Ints_iff) auto
    also have "\<not>n dvd m"
      using m by auto
    finally show "cis (2 * pi / real n) ^ m \<noteq> 1" .
  qed
qed simp

lemma finite_bij_betwI:
  assumes "finite A" "finite B" "inj_on f A" "f \<in> A \<rightarrow> B" "card A = card B"
  shows "bij_betw f A B"
proof (intro bij_betw_imageI)
  show "inj_on f A" by fact
  show "f ` A = B"
  proof -
    have "card (f ` A) = card B" using assms by (simp add: card_image)
    moreover have "f ` A \<subseteq> B" using assms by blast
    ultimately show ?thesis using assms by (meson card_subset_eq)
  qed
qed

lemma powi_mod:
  "x powi m = x powi (m mod n)" if "x ^ n = 1" "n > 0" for x::complex and m::int
proof -
  have xnz: "x \<noteq> 0" using that by (metis zero_neq_one zero_power)
  obtain k::int where k: "m = k*n + (m mod n)" using div_mod_decomp_int by blast
  have "x powi m = x powi (k*n) * x powi (m mod n)" by (subst k, intro power_int_add, use xnz in auto)
  moreover have "x powi (k*n) = 1" using that by (metis mult.commute power_int_1_left power_int_mult power_int_of_nat)
  ultimately show ?thesis by force
qed

end