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

section\<open>Gauss Jordan algorithm over nested IArrays\<close>

theory Gauss_Jordan_IArrays
imports
  Matrix_To_IArray
  Gauss_Jordan
begin

subsection\<open>Definitions and functions to compute the Gauss-Jordan algorithm over matrices represented as nested iarrays\<close>

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.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\<open>Proving the equivalence between Gauss-Jordan algorithm over nested iarrays and over nested vecs (abstract matrices).\<close>

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 Option.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 IArray.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 IArray.sub_def[symmetric] IArray.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: IArray.length_def IArray.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
      define ja where "ja = (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: IArray.sub_def IArray.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\<open>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"}.\<close>

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"
    using [[unfold_abs_def = false]]
    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\<open>Implementation over IArrays of the computation of the @{term "rank"} of a matrix\<close>

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\<open>Proving the equivalence between @{term "rank"} and @{term "rank_iarray"}.\<close>

text\<open>First of all, some code equations are removed to allow the execution of Gauss-Jordan algorithm using iarrays\<close>
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 IArray.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\<open>Code equations for computing the rank over nested iarrays and the dimensions of the elementary subspaces\<close>

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 IArray.length_def[symmetric] IArray.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


subsection "Algebraic Classes"

theory Derive_Algebra_Laws
  imports Main "../Derive" Derive_Datatypes
begin

datatype simple_int = A int | B int int | C

class semigroup =
  fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70)
  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)"

class monoidl = semigroup +
  fixes neutral :: 'a ("\<one>")
  assumes neutl : "\<one> \<otimes> x = x"

class group = monoidl +
  fixes inverse :: "'a \<Rightarrow> 'a"
  assumes invl: "(inverse x) \<otimes> x = \<one>"

definition semigroup_law :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
"semigroup_law MULT = (\<forall> x y z. MULT (MULT x y) z = MULT x (MULT y z))"
definition monoidl_law :: "'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
"monoidl_law NEUTRAL MULT = ((\<forall> x. MULT NEUTRAL x = x) \<and> semigroup_law MULT)"
definition group_law :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
"group_law INVERSE NEUTRAL MULT = ((\<forall> x. MULT (INVERSE x) x = NEUTRAL) \<and> monoidl_law NEUTRAL MULT)"

lemma transfer_semigroup:
  assumes "Derive.iso f g"
  shows "semigroup_law MULT \<Longrightarrow> semigroup_law (\<lambda>x y. g (MULT (f x) (f y)))"
  unfolding semigroup_law_def
  using assms unfolding Derive.iso_def by simp

lemma transfer_monoidl:
  assumes "Derive.iso f g"
  shows "monoidl_law NEUTRAL MULT \<Longrightarrow> monoidl_law (g NEUTRAL) (\<lambda>x y. g (MULT (f x) (f y)))"
  unfolding monoidl_law_def semigroup_law_def
  using assms unfolding Derive.iso_def by simp

lemma transfer_group:
  assumes "Derive.iso f g"
  shows "group_law INVERSE NEUTRAL MULT \<Longrightarrow> group_law (\<lambda> x. g (INVERSE (f x))) (g NEUTRAL) (\<lambda>x y. g (MULT (f x) (f y)))"
  unfolding group_law_def monoidl_law_def semigroup_law_def
  using assms unfolding Derive.iso_def by simp

lemma semigroup_law_semigroup: "semigroup_law mult"
  unfolding semigroup_law_def
  using semigroup_class.axioms unfolding class.semigroup_def .

lemma monoidl_law_monoidl: "monoidl_law neutral mult"
  unfolding monoidl_law_def
  using monoidl_class.axioms semigroup_law_semigroup
  unfolding class.monoidl_axioms_def by simp

lemma group_law_group: "group_law inverse neutral mult"
  unfolding group_law_def
  using group_class.axioms monoidl_law_monoidl
  unfolding class.group_axioms_def by simp

derive_generic_setup semigroup
  unfolding semigroup_class_law_def
  Derive.iso_def
  by simp

derive_generic_setup monoidl
  unfolding monoidl_class_law_def semigroup_class_law_def Derive.iso_def
  by simp

derive_generic_setup group
  unfolding group_class_law_def monoidl_class_law_def semigroup_class_law_def Derive.iso_def
  by simp

(* Manual instances for int, unit, prod, and sum *)
instantiation int and unit:: semigroup
begin
  definition mult_int_def : "mult (x::int) y = x + y"
  definition mult_unit_def: "mult (x::unit) y = x"
instance proof
  fix x y z :: int
  show "x \<otimes> y \<otimes> z = x \<otimes> (y \<otimes> z)"
    unfolding mult_int_def by simp
next
  fix x y z :: unit
  show "x \<otimes> y \<otimes> z = x \<otimes> (y \<otimes> z)"
    unfolding mult_unit_def by simp
qed
end
instantiation int and unit:: monoidl
begin
  definition neutral_int_def : "neutral = (0::int)"
  definition neutral_unit_def: "neutral = ()"
instance proof
  fix x :: int
  show "\<one> \<otimes> x = x" unfolding neutral_int_def mult_int_def by simp
next
  fix x :: unit
  show "\<one> \<otimes> x = x" unfolding neutral_unit_def mult_unit_def by simp
qed
end

instantiation int and unit:: group
begin
  definition inverse_int_def : "inverse (i::int) = \<one> - i"
  definition inverse_unit_def: "inverse u = ()"
instance proof
  fix x :: int
  show "inverse x \<otimes> x = \<one>" unfolding inverse_int_def mult_int_def by simp
next
  fix x :: unit
  show "inverse x \<otimes> x = \<one>" unfolding inverse_unit_def mult_unit_def by simp
qed
end

instantiation prod and sum :: (semigroup, semigroup) semigroup
begin
  definition mult_prod_def: "x \<otimes> y = (fst x \<otimes> fst y, snd x \<otimes> snd y)"
  definition mult_sum_def: "x \<otimes> y = (case x of Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> Inl (a \<otimes> b) | Inr b \<Rightarrow> Inr b)
                                             | Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> Inr a | Inr b \<Rightarrow> Inr (a \<otimes> b)))"
instance proof
  fix x y z :: "('a::semigroup) \<times> ('b::semigroup)"
  show "x \<otimes> y \<otimes> z = x \<otimes> (y \<otimes> z)" unfolding mult_prod_def by (simp add: assoc)
next
  fix x y z :: "('a::semigroup) + ('b::semigroup)"
  show "x \<otimes> y \<otimes> z = x \<otimes> (y \<otimes> z)" unfolding mult_sum_def
    by (simp add: assoc sum.case_eq_if)
qed
end

instantiation prod and sum :: (monoidl, monoidl) monoidl
begin
  definition neutral_prod_def: "neutral = (neutral,neutral)"
  definition neutral_sum_def: "neutral = Inl neutral"
instance proof
  fix x :: "('a::monoidl) \<times> ('b::monoidl)"
  show "\<one> \<otimes> x = x" unfolding neutral_prod_def mult_prod_def by (simp add: neutl)
next
  fix x :: "('a::monoidl) + ('b::monoidl)"
  show "\<one> \<otimes> x = x" unfolding neutral_sum_def mult_sum_def
    by (simp add: neutl sum.case_eq_if sum.exhaust_sel)
qed
end

instantiation prod :: (group, group) group
begin
  definition inverse_prod_def: "inverse p = (inverse (fst p), inverse (snd p))"
instance proof
  fix x :: "('a::group) \<times> ('b::group)"
  show "inverse x \<otimes> x = \<one>" unfolding inverse_prod_def mult_prod_def neutral_prod_def
    by (simp add: invl)
qed
end

derive_generic semigroup simple_int .
derive_generic monoidl simple_int .

derive_generic semigroup either .
derive_generic monoidl either .

lemma "(B \<one> 6) \<otimes> (B 4 5) = B 4 11" by eval
lemma "(A 2) \<otimes> (A 3) = A 5" by eval
lemma "(B \<one> 6) \<otimes> \<one> = B 0 6" by eval

lemma "(L 3) \<otimes> ((L 4)::(int,int) either) = L 7" by eval
lemma "(R (2::int)) \<otimes> (L (3::int)) = R 2" by eval

derive_generic semigroup list
proof goal_cases
  case (1 x y z)
  then show ?case
  proof (induction x arbitrary: y z)
    case (In x')
    then show ?case
      apply(cases x')
      apply (cases y; cases z; hypsubst_thin)
       apply (simp add: Derive_Algebra_Laws.mult_mulistF.simps sum.case_eq_if mult_unit_def)
      apply(cases y; cases z; hypsubst_thin)
      unfolding sum_set_defs prod_set_defs
      apply (simp add: Derive_Algebra_Laws.mult_mulistF.simps mult_unit_def)
      by (simp add: sum.case_eq_if assoc)
  qed
qed

derive_generic semigroup tree
proof goal_cases
  case (1 x y z)
  then show ?case
  proof (induction x arbitrary: y z)
    case (In x')
    then show ?case
      apply(cases x')
      apply (cases y; cases z; hypsubst_thin)
       apply (simp add: Derive_Algebra_Laws.mult_mutreeF.simps sum.case_eq_if mult_unit_def)
      apply(cases y; cases z; hypsubst_thin)
      unfolding sum_set_defs prod_set_defs
      apply (simp add: Derive_Algebra_Laws.mult_mutreeF.simps mult_unit_def)
      by (simp add: semigroup_class.assoc sum.case_eq_if)
  qed
qed

derive_generic monoidl list
proof goal_cases
  case (1 x)
  then show ?case
  proof (induction x)
    case (In x')
    then show ?case
      apply(cases x')
      by (auto simp add: Derive_Algebra_Laws.neutral_mulistF_def sum.case_eq_if neutral_unit_def)
  qed
qed

derive_generic monoidl tree
proof goal_cases
  case (1 x)
  then show ?case
  proof (induction x)
    case (In x')
    then show ?case
      apply(cases x')
      by (auto simp add: Derive_Algebra_Laws.neutral_mutreeF_def sum.case_eq_if neutral_unit_def)
  qed
qed

lemma "[1,2,3,4::int] \<otimes> [1,2,3] = [2,4,6,4]" by eval
lemma "(Node (3::int) Leaf Leaf) \<otimes> (Node (1::int) Leaf Leaf) = (Node 4 Leaf Leaf)" by eval

end


section \<open> Bouncing Ball \<close>

theory Bouncing_Ball
  imports "UTP-dL.utp_hyprog"
begin

text \<open> The goal of this theory is to show that a bouncing ball, in normal circumstances, rebounds
  no higher than its initial height. \<close>

utp_lit_vars

text \<open> The state space has two continuous variables, and so we use a two-place vector to model it. \<close>

type_synonym state = "real vec[2]"

text \<open> Each continuous variable is modelled as a projection from the state space. \<close>

abbreviation h :: "real \<Longrightarrow> state" where "h \<equiv> mat_lens 0 0"
abbreviation v :: "real \<Longrightarrow> state" where "v \<equiv> mat_lens 0 1"

text \<open> The following locale creates a context for the hybrid system, which fixes a number of
  constants and provides assumptions. \<close>

locale Ball =
  fixes g :: real \<comment> \<open> Gravitational constant \<close>
  and H :: real \<comment> \<open> The initial or maximum height of the ball \<close>
  and c :: real \<comment> \<open> The damping coefficient applied upon rebound \<close>
  assumes g_pos: "g > 0" \<comment> \<open> The gravitational contant should be strictly positive (e.g. 9.81) \<close>
  and c_pos: "c > 0" \<comment> \<open> The damping coefficient is greater than 0... \<close>
  and c_le_one: "c \<le> 1" \<comment> \<open> ... and no greater than 1, otherwise it increases its bounce. \<close>
  and H_pos: "H \<ge> 0"
begin

text \<open> The dynamics encodes the simple first order system of ODEs. It specifies the derivative
  for each continuous variable, and a evolution domain $h \ge 0$. \<close>

abbreviation Dynamics :: "(state, unit) hyrel" where
"Dynamics \<equiv> ode [h \<mapsto>\<^sub>s v, v \<mapsto>\<^sub>s -g] U(&\<^bold>c:h \<ge> 0)"

text \<open> The ``controller'' implements a rebound when $h = 0$. \<close>

definition Control :: "(state, unit) hyrel" where
"Control \<equiv> if (&\<^bold>c:h = 0) then \<^bold>c:v := -c * &\<^bold>c:v fi"

text \<open> The entire system iterative executes the dynamics follows by the controller. \<close>

abbreviation "BBall \<equiv> (Dynamics ;; Control)\<^sup>\<star>"

text \<open> Here is the invariant we wish to prove: it is sufficient to show that always $h \le H$. \<close>

abbreviation "Inv \<equiv> U(&\<^bold>c:h \<ge> 0 \<and> &\<^bold>c:v\<^sup>2 \<le> 2*g*(H - &\<^bold>c:h))"

text \<open> We first prove that it is an invariant of the dynamics using Hoare logic. \<close>

lemma l1 [hoare_safe]: "\<^bold>{Inv\<^bold>}Dynamics\<^bold>{Inv\<^bold>}"
  apply (rule dCut_split) \<comment> \<open> Differential cut rule \<close>
   apply (rule dWeakening) \<comment> \<open> Differential weakening (invariant first conjunct) \<close>
  apply (simp)
  apply (dInduct, rel_auto) \<comment> \<open> Differential induction (invariant second conjunct) \<close>
  done

text \<open> Next, we prove its also an invariant of the controller. This requires a call to sledgehammer. \<close>

lemma l2 [hoare_safe]: "\<^bold>{Inv\<^bold>}Control\<^bold>{Inv\<^bold>}"
  unfolding Control_def
  apply (hoare_auto)
  by (smt c_le_one c_pos mult_left_le_one_le power2_eq_square power_mult_distrib zero_le_square)

text \<open> As a consequence, it is an invariant of the whole system. \<close>

lemma l3: "\<^bold>{Inv\<^bold>}BBall\<^bold>{Inv\<^bold>}"
  by (hoare_auto)

text \<open> We can now show the safety property we desire using the consequence rule and sledgehammer. \<close>

lemma safety_property_1:
  "\<^bold>{0 \<le> &\<^bold>c:h \<and> &\<^bold>c:v\<^sup>2 \<le> 2*g*(H - &\<^bold>c:h)\<^bold>}BBall\<^bold>{0 \<le> &\<^bold>c:h \<and> &\<^bold>c:h \<le> H\<^bold>}"
  apply (rule hoare_r_conseq[OF l3]) \<comment> \<open> Consequence rule \<close>
  apply (simp)
  apply (rel_simp)
  apply (smt g_pos power2_less_0 zero_le_mult_iff)
  done

text \<open> A more specific version -- the ball starts stationary and at height $h$. \<close>

lemma safety_property_2:
  "\<^bold>{&\<^bold>c:h = H \<and> &\<^bold>c:v = 0\<^bold>}BBall\<^bold>{0 \<le> &\<^bold>c:h \<and> &\<^bold>c:h \<le> H\<^bold>}"
  apply (rule hoare_r_conseq[OF safety_property_1])
  apply (rel_simp)
  using H_pos apply blast
  apply (rel_simp)
  done

end

end


theory Chapter20_2_Typechecking
imports Chapter20_1_Language
begin

primrec is_type :: "kind env => type => bool"
where "is_type del (Tyvar v) = (lookup del v ~= None)"
    | "is_type del Nat = True"
    | "is_type del (Arrow e1 e2) = (is_type del e1 & is_type del e2)"
    | "is_type del (All e) = is_type (extend del Star) e"
    | "is_type del Unit = True"
    | "is_type del (Prod e1 e2) = (is_type del e1 & is_type del e2)"
    | "is_type del Void = True"
    | "is_type del (Sum e1 e2) = (is_type del e1 & is_type del e2)"

inductive typecheck :: "kind env => type env => expr => type => bool"
where tc_var [simp]: "lookup gam x = Some t ==> typecheck del gam (Var x) t"
    | tc_zero [simp]: "typecheck del gam Zero Nat"
    | tc_suc [simp]: "typecheck del gam e Nat ==> typecheck del gam (Suc e) Nat"
    | tc_rec [simp]: "typecheck del gam et Nat ==> typecheck del gam e0 t ==>
                typecheck del (extend gam t) es t ==> typecheck del gam (Iter et e0 es) t"
    | tc_lam [simp]: "is_type del t1 ==> typecheck del (extend gam t1) e t2 ==>
                typecheck del gam (Lam t1 e) (Arrow t1 t2)"
    | tc_appl [simp]: "typecheck del gam e1 (Arrow t2 t) ==> typecheck del gam e2 t2 ==>
                typecheck del gam (Appl e1 e2) t"
    | tc_tylam [simp]: "typecheck (extend del Star) (env_map (type_insert first) gam) e t ==>
                typecheck del gam (TyLam e) (All t)"
    | tc_tyappl [simp]: "is_type del t' ==> typecheck del gam e (All t) ==>
                typecheck del gam (TyAppl t' e) (type_subst t' first t)"
    | tc_triv [simp]: "typecheck del gam Triv Unit"
    | tc_pair [simp]: "typecheck del gam e1 t1 ==> typecheck del gam e2 t2 ==>
                typecheck del gam (Pair e1 e2) (Prod t1 t2)"
    | tc_projl [simp]: "typecheck del gam e (Prod t1 t2) ==> typecheck del gam (ProjL e) t1"
    | tc_projr [simp]: "typecheck del gam e (Prod t1 t2) ==> typecheck del gam (ProjR e) t2"
    | tc_abort [simp]: "is_type del t ==> typecheck del gam e Void ==>
                typecheck del gam (Abort t e) t"
    | tc_case [simp]: "typecheck del gam et (Sum t1 t2) ==> typecheck del (extend gam t1) el t ==>
                typecheck del (extend gam t2) er t ==> typecheck del gam (Case et el er) t"
    | tc_inl [simp]: "is_type del t1 ==> is_type del t2 ==> typecheck del gam e t1 ==>
                typecheck del gam (InL t1 t2 e) (Sum t1 t2)"
    | tc_inr [simp]: "is_type del t1 ==> is_type del t2 ==> typecheck del gam e t2 ==>
                typecheck del gam (InR t1 t2 e) (Sum t1 t2)"

inductive_cases [elim!]: "typecheck del gam (Var x) t"
inductive_cases [elim!]: "typecheck del gam Zero t"
inductive_cases [elim!]: "typecheck del gam (Suc e) t"
inductive_cases [elim!]: "typecheck del gam (Iter et e0 es) t"
inductive_cases [elim!]: "typecheck del gam (Lam t1 e) t"
inductive_cases [elim!]: "typecheck del gam (Appl e1 e2) t"
inductive_cases [elim!]: "typecheck del gam (TyLam e) t"
inductive_cases [elim!]: "typecheck del gam (TyAppl e1 e2) t"
inductive_cases [elim!]: "typecheck del gam Triv t"
inductive_cases [elim!]: "typecheck del gam (Pair e1 e2) t"
inductive_cases [elim!]: "typecheck del gam (ProjL e) t"
inductive_cases [elim!]: "typecheck del gam (ProjR e) t"
inductive_cases [elim!]: "typecheck del gam (Abort t1 e) t"
inductive_cases [elim!]: "typecheck del gam (Case et el er) t"
inductive_cases [elim!]: "typecheck del gam (InL t1 t2 e) t"
inductive_cases [elim!]: "typecheck del gam (InR t1 t2 e) t"

lemma [simp]: "n in del ==> is_type del t ==> is_type (extend_at n del Star) (type_insert n t)"
by (induction t arbitrary: n del, simp_all)

lemma [simp]: "n in del ==> is_type del t' ==> is_type (extend_at n del Star) t ==>
                  is_type del (type_subst t' n t)"
by (induction t arbitrary: n del t', auto)

lemma [simp]: "typecheck del gam e t ==> n in del ==>
          typecheck (extend_at n del Star) (env_map (type_insert n) gam)
                    (expr_insert_type n e) (type_insert n t)"
proof (induction del gam e t arbitrary: n rule: typecheck.induct)
case tc_var
  thus ?case by simp
next case tc_zero
  thus ?case by simp
next case tc_suc
  thus ?case by simp
next case tc_rec
  thus ?case by simp
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by (metis expr_insert_type.simps(6) type_insert.simps(3) typecheck.tc_appl)
next case tc_tylam
  thus ?case by simp
next case (tc_tyappl del t' gam e t)
  hence "is_type (extend_at n del Star) (type_insert n t')" by simp
  moreover from tc_tyappl have "typecheck (extend_at n del Star) (env_map (type_insert n) gam)
                                          (expr_insert_type n e) (All (type_insert (next n) t))"
    by simp
  ultimately have "typecheck (extend_at n del Star) (env_map (type_insert n) gam)
                             (TyAppl (type_insert n t') (expr_insert_type n e))
                             (type_subst (type_insert n t') first (type_insert (next n) t))"
    by (metis (full_types) typecheck.tc_tyappl)
  thus ?case by simp
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by simp
next case tc_projl
  thus ?case by (metis expr_insert_type.simps(11) type_insert.simps(6) typecheck.tc_projl)
next case tc_projr
  thus ?case by (metis expr_insert_type.simps(12) type_insert.simps(6) typecheck.tc_projr)
next case tc_abort
  thus ?case by simp
next case (tc_case del gam et t1 t2 el t er)
  from tc_case have X: "typecheck (extend_at n del Star) (env_map (type_insert n) gam)
              (expr_insert_type n et) (Sum (type_insert n t1) (type_insert n t2))" by simp
  from tc_case have Y: "typecheck (extend_at n del Star) (extend (env_map (type_insert n) gam)
              (type_insert n t1)) (expr_insert_type n el) (type_insert n t)" by simp
  from tc_case have "typecheck (extend_at n del Star) (extend (env_map (type_insert n) gam)
              (type_insert n t2)) (expr_insert_type n er) (type_insert n t)" by simp
  with X Y show ?case by simp
next case tc_inl
  thus ?case by simp
next case tc_inr
  thus ?case by simp
qed

lemma [simp]: "typecheck del (extend_at n gam t') e t ==> n in gam ==> typecheck del gam e' t' ==>
                   typecheck del gam (subst e' n e) t"
proof (induction del "extend_at n gam t'" e t arbitrary: n gam t' e' rule: typecheck.induct)
case tc_var
  thus ?case by fastforce
next case tc_zero
  thus ?case by simp
next case tc_suc
  thus ?case by simp
next case tc_rec
  thus ?case by simp
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by fastforce
next case (tc_tylam del e t)
  moreover hence "n in env_map (type_insert first) gam" by force
  moreover from tc_tylam have "env_map (type_insert first) (extend_at n gam t') =
                  extend_at n (env_map (type_insert first) gam) (type_insert first t')" by simp
  moreover from tc_tylam have "typecheck (extend del Star) (env_map (type_insert first) gam)
                                         (expr_insert_type first e') (type_insert first t')" by simp
  ultimately have "typecheck (extend del Star) (env_map (type_insert first) gam)
                             (subst (expr_insert_type first e') n e) t" by blast
  thus ?case by simp
next case tc_tyappl
  thus ?case by simp
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by simp
next case tc_projl
  thus ?case by fastforce
next case tc_projr
  thus ?case by fastforce
next case tc_abort
  thus ?case by simp
next case tc_case
  thus ?case by fastforce
next case tc_inl
  thus ?case by simp
next case tc_inr
  thus ?case by simp
qed

lemma [simp]: "typecheck (extend_at n del Star) gam e t ==> n in del ==> is_type del t' ==>
        typecheck del (env_map (type_subst t' n) gam) (expr_subst_type t' n e) (type_subst t' n t)"
proof (induction "extend_at n del Star" gam e t arbitrary: del t' n rule: typecheck.induct)
case tc_var
  thus ?case by simp
next case tc_zero
  thus ?case by simp
next case tc_suc
  thus ?case by simp
next case tc_rec
  thus ?case by simp
next case tc_lam
  thus ?case by simp
next case tc_appl
  thus ?case by fastforce
next case tc_tylam
  thus ?case by simp
next case (tc_tyappl t'' gam e t)
next case (tc_tyappl t'' gam e t)
  from tc_tyappl have X: "is_type del (type_subst t' n t'')" by simp
  from tc_tyappl have "typecheck del (env_map (type_subst t' n) gam) (expr_subst_type t' n e)
                                 (All (type_subst (type_insert first t') (next n) t))" by simp
  with X have
    "typecheck del (env_map (type_subst t' n) gam)
          (TyAppl (type_subst t' n t'') (expr_subst_type t' n e))
          (type_subst (type_subst t' n t'') first (type_subst (type_insert first t') (next n) t))"
      by (metis typecheck.tc_tyappl)
  thus ?case by simp
next case tc_triv
  thus ?case by simp
next case tc_pair
  thus ?case by simp
next case tc_projl
  thus ?case by (metis expr_subst_type.simps(11) type_subst.simps(6) typecheck.tc_projl)
next case tc_projr
  thus ?case by (metis expr_subst_type.simps(12) type_subst.simps(6) typecheck.tc_projr)
next case tc_abort
  thus ?case by simp
next case tc_case
  thus ?case by fastforce
next case tc_inl
  thus ?case by simp
next case tc_inr
  thus ?case by simp
qed

lemma [simp]: "typecheck del gam (TyAppl t' e) t ==>
                  EX tt. typecheck del gam e (All tt) & t = type_subst t' first tt"
by (induction del gam "TyAppl t' e" t arbitrary: e rule: typecheck.induct, blast)

end


theory Shortest_Path
  imports
    Weighted_Graph
begin

section \<open>Shortest walk cost\<close>

definition shortest_walk_cost :: "'a graph \<Rightarrow> 'a cost_fun \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ereal" where
  "shortest_walk_cost G f u v \<equiv> INF p\<in>{p. walk G u p v}. ereal (walk_cost f p)"

definition is_shortest_walk :: "'a graph \<Rightarrow> 'a cost_fun \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool" where
  "is_shortest_walk G f u p v \<equiv> walk G u p v \<and> walk_cost f p = shortest_walk_cost G f u v"

lemma is_shortest_walkI:
  assumes "walk G u p v"
  assumes "walk_cost f p = shortest_walk_cost G f u v"
  shows "is_shortest_walk G f u p v"
  using assms
  by (simp add: is_shortest_walk_def)

subsection \<open>Basic Lemmas\<close>

lemma (in graph) shortest_walk_cost_symmetric_aux:
  shows
    "(\<lambda>p. ereal (walk_cost f p)) ` {p. walk G u p v} \<subseteq>
      (\<lambda>p. ereal (walk_cost f p)) ` {p. walk G v p u}"
    (is "?A \<subseteq> ?B")
proof
  fix x
  assume "x \<in> ?A"
  then obtain p where
    "p \<in> {p. walk G u p v}"
    "x = walk_cost f p"
    by blast
  hence
    "(rev p) \<in> {p. walk G v p u}"
    "x = walk_cost f (rev p)"
    by (simp add: walk_rev)+
  thus "x \<in> ?B"
    by blast
qed

lemma (in graph) shortest_walk_cost_symmetric:
  shows "shortest_walk_cost G f u v = shortest_walk_cost G f v u"
proof -
  have
    "(\<lambda>p. ereal (walk_cost f p)) ` {p. walk G u p v} =
      (\<lambda>p. ereal (walk_cost f p)) ` {p. walk G v p u}"
    (is "?A = ?B")
  proof
    show "?A \<subseteq> ?B"
      using shortest_walk_cost_symmetric_aux[where ?u = u and ?v = v]
      by simp
  next
    show "?B \<subseteq> ?A"
      using shortest_walk_cost_symmetric_aux[where ?u = v and ?v = u]
      by simp
  qed
  thus ?thesis
    by (simp add: shortest_walk_cost_def)
qed

lemma shortest_walk_cost_non_negative_if_cost_non_negative:
  assumes "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  shows "0 \<le> shortest_walk_cost G f u v"
proof -
  { fix p
    assume "p \<in> {p. walk G u p v}"
    hence "0 \<le> walk_cost f p"
      using assms
      by (blast intro: walk_cost_non_negative_if_cost_non_negative) }
  thus ?thesis
    by (auto simp add: shortest_walk_cost_def intro: INF_greatest)
qed

lemma shortest_walk_cost_le_walk_cost:
  assumes "walk G u p v"
  shows "shortest_walk_cost G f u v \<le> walk_cost f p"
  using assms
  by (auto simp add: shortest_walk_cost_def intro: INF_lower)

lemma (in graph) shortest_walk_cost_edge_le_cost:
  assumes "{u, v} \<in> edges G"
  shows "shortest_walk_cost G f u v \<le> f {u, v}"
proof -
  have "walk G u [u, v] v"
    using assms
    by (rule edge_is_walk)
  hence "shortest_walk_cost G f u v \<le> walk_cost f [u, v]"
    by (rule shortest_walk_cost_le_walk_cost)
  also have "... = f {u, v}"
    by (simp add: walk_cost_def)
  finally show ?thesis
    .
qed

lemma shortest_walk_cost_reachable_conv:
  shows "shortest_walk_cost G f u v \<noteq> \<infinity> = reachable G u v"
proof
  assume shortest_walk_cost_finite: "shortest_walk_cost G f u v \<noteq> \<infinity>"
  show "reachable G u v"
  proof (rule ccontr)
    assume "\<not> reachable G u v"
    hence "{p. walk G u p v} = {}"
      by (simp add: reachable_def)
    thus "False"
      using shortest_walk_cost_finite
      by (simp add: shortest_walk_cost_def top_ereal_def)
  qed
next
  assume "reachable G u v"
  then obtain p where
    "walk G u p v"
    by (auto simp add: reachable_def)
  hence "shortest_walk_cost G f u v \<le> walk_cost f p"
    by (rule shortest_walk_cost_le_walk_cost)
  also have "... < \<infinity>"
    by (simp add: walk_cost_def)
  finally show "shortest_walk_cost G f u v \<noteq> \<infinity>"
    by simp
qed

lemma singleton_is_shortest_walk:
  assumes f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  assumes v_in_vertices: "v \<in> vertices G"
  shows "is_shortest_walk G f v [v] v"
proof (intro antisym is_shortest_walkI)
  show v_walk: "walk G v [v] v"
    using v_in_vertices
    by (rule singleton_is_walk)
  have "walk_cost f [v] = 0"
    by (simp add: walk_cost_def)
  also have "... \<le> shortest_walk_cost G f v v"
    unfolding zero_ereal_def[symmetric]
    using f_non_negative
    by (rule shortest_walk_cost_non_negative_if_cost_non_negative)
  finally show "walk_cost f [v] \<le> shortest_walk_cost G f v v"
    .
  show "shortest_walk_cost G f v v \<le> walk_cost f [v]"
    using v_walk
    by (rule shortest_walk_cost_le_walk_cost)
qed

subsection \<open>Shortest path cost\<close>

(* This subsection is largely based on the formalization of directed graphs (Graph_Theory). *)

lemma (in graph) shortest_walk_cost_ge_shortest_walk_to_path_cost:
  assumes "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  shows
    "(INF p\<in>{p. walk G u p v}. ereal (walk_cost f (walk_to_path p))) \<le>
      shortest_walk_cost G f u v"
proof -
  { fix p
    assume "p \<in> {p. walk G u p v}"
    hence "walk_cost f (walk_to_path p) \<le> walk_cost f p"
      using assms
      by (intro walk_cost_ge_walk_to_path_cost) simp+ }
  thus ?thesis
    by (fastforce simp add: shortest_walk_cost_def intro: INF_mono)
qed

lemma (in graph) shortest_walk_cost_eq_shortest_path_cost:
  assumes "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  shows "shortest_walk_cost G f u v = (INF p\<in>{p. path G u p v}. ereal (walk_cost f p))"
proof (rule antisym)
  define walks where "walks = {p. walk G u p v}"
  define paths where "paths = {p. path G u p v}"

  have "paths \<subseteq> walks"
    by (auto simp add: walks_def paths_def path_def)
  thus "shortest_walk_cost G f u v \<le> (INF p\<in>{p. path G u p v}. ereal (walk_cost f p))"
    unfolding shortest_walk_cost_def walks_def[symmetric] paths_def[symmetric]
    by (rule INF_superset_mono) simp

  have "walk_to_path ` walks \<subseteq> paths"
    unfolding walks_def paths_def
    by (blast intro: walk_to_path_is_path)
  hence
    "(INF p\<in>paths. ereal (walk_cost f p)) \<le>
      (INF p\<in>walk_to_path ` walks. ereal (walk_cost f p))"
    by (rule INF_superset_mono) simp
  also have "... = (INF p\<in>walks. ereal (walk_cost f (walk_to_path p)))"
    unfolding image_image
    by simp
  also have "... \<le> (INF p\<in>walks. ereal (walk_cost f p))"
    unfolding walks_def shortest_walk_cost_def[symmetric]
    using assms
    by (rule shortest_walk_cost_ge_shortest_walk_to_path_cost)
  finally show "(INF p\<in>{p. path G u p v}. ereal (walk_cost f p)) \<le> shortest_walk_cost G f u v"
    by (simp add: walks_def paths_def shortest_walk_cost_def)
qed

lemma (in finite_graph) shortest_walk_cost_path:
  assumes reachable: "reachable G u v"
  assumes f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  shows "\<exists>p. path G u p v \<and> walk_cost f p = shortest_walk_cost G f u v"
proof -
  have paths_non_empty: "{p. path G u p v} \<noteq> {}"
    (is "?A \<noteq> {}")
    using reachable
    by (auto simp add: reachable_def intro: walk_to_path_is_path)

  have "shortest_walk_cost G f u v = (INF p\<in>?A. ereal (walk_cost f p))"
    using f_non_negative
    by (rule shortest_walk_cost_eq_shortest_path_cost)
  also have "... \<in> (\<lambda>p. ereal (walk_cost f p)) ` ?A"
    using paths_finite paths_non_empty
    by (rule INF_in_image)
  finally show ?thesis
    by (auto simp add: image_def)
qed

subsection \<open>Triangle inequality\<close>

lemma (in finite_graph) shortest_walk_cost_triangle_inequality_case_real:
  assumes f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  assumes
    assm: "shortest_walk_cost G f u v + shortest_walk_cost G f v w <
      shortest_walk_cost G f u w"
    (is "?b + ?c < ?a")
  assumes real: "shortest_walk_cost G f u w = ereal r"
  shows "False"
proof -
  have
    "?b \<noteq> \<infinity>"
    "?c \<noteq> \<infinity>"
    using assm real
    by auto
  hence
    "reachable G u v"
    "reachable G v w"
    by (simp add: shortest_walk_cost_reachable_conv)+
  hence
    "\<exists>p. path G u p v \<and> walk_cost f p = ?b"
    "\<exists>p. path G v p w \<and> walk_cost f p = ?c"
    using f_non_negative
    by (auto intro: shortest_walk_cost_path)
  then obtain p q where
    p_walk: "walk G u p v" and
    p_walk_cost: "walk_cost f p = ?b" and
    q_walk: "walk G v q w" and
    q_walk_cost: "walk_cost f q = ?c"
    by (auto simp add: path_def)

  have "walk G u (p @ tl q) w"
    using p_walk q_walk
    by (rule walk_append_is_walk)
  hence "?a \<le> walk_cost f (p @ tl q)"
    by (rule shortest_walk_cost_le_walk_cost)
  also have "... = walk_cost f p + walk_cost f q"
    using p_walk q_walk
    by (auto simp add: walk_def intro: walk_cost_append_2)
  finally have "?a \<le> ?b + ?c"
    by (simp add: plus_ereal.simps(1)[symmetric] p_walk_cost q_walk_cost)
  thus ?thesis
    using assm
    by simp
qed

lemma (in finite_graph) shortest_walk_cost_triangle_inequality_case_PInf:
  assumes "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  assumes assm: "shortest_walk_cost G f u v + shortest_walk_cost G f v w < shortest_walk_cost G f u w"
    (is "?b + ?c < ?a")
  assumes PInf: "shortest_walk_cost G f u w = \<infinity>"
  shows "False"
proof -
  have
    "?b \<noteq> \<infinity>"
    "?c \<noteq> \<infinity>"
    using assm PInf
    by simp+
  hence
    "reachable G u v"
    "reachable G v w"
    by (simp add: shortest_walk_cost_reachable_conv)+
  hence "reachable G u w"
    by (rule reachable_trans)
  hence "shortest_walk_cost G f u w \<noteq> \<infinity>"
    by (simp add: shortest_walk_cost_reachable_conv)
  thus ?thesis
    using PInf
    by simp
qed

lemma (in finite_graph) shortest_walk_cost_triangle_inequality:
  assumes "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  shows "shortest_walk_cost G f u w \<le> shortest_walk_cost G f u v + shortest_walk_cost G f v w"
    (is "?a \<le> ?b + ?c")
proof (rule ccontr)
  assume "\<not> ?a \<le> ?b + ?c"
  hence assm: "?b + ?c < ?a"
    by simp
  show "False"
  proof (cases ?a)
    case (real r)
    with assms assm
    show ?thesis
      by (rule shortest_walk_cost_triangle_inequality_case_real)
  next
    case PInf
    with assms assm
    show ?thesis
      by (rule shortest_walk_cost_triangle_inequality_case_PInf)
  next
    case MInf
    thus ?thesis
      using assm
      by simp
  qed
qed

subsection \<open>Decomposing shortest walks\<close>

lemma (in finite_graph) shortest_walk_cost_walk_vertex_decomp:
  assumes f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  assumes p_shortest_walk: "is_shortest_walk G f u p w"
  assumes v_in_p: "v \<in> set p"
  assumes qr_def: "walk_vertex_decomp G p v = (q, r)"
  shows "shortest_walk_cost G f u w = shortest_walk_cost G f u v + shortest_walk_cost G f v w"
    (is "?a = ?b + ?c")
proof (rule antisym)
  show "?a \<le> ?b + ?c"
    using f_non_negative
    by (rule shortest_walk_cost_triangle_inequality)
next
  have
    p_decomp: "p = q @ tl r" and
    q_walk: "walk G u q v" and
    r_walk: "walk G v r w"
    using p_shortest_walk v_in_p qr_def
    by (auto simp add: is_shortest_walk_def elim: walk_vertex_decompE_2)

  have "?b + ?c \<le> walk_cost f q + walk_cost f r"
    unfolding plus_ereal.simps(1)[symmetric]
    using q_walk r_walk
    by (intro shortest_walk_cost_le_walk_cost add_mono)
  also have "... = walk_cost f (q @ tl r)"
    using q_walk r_walk
    by (auto simp add: walk_def intro: walk_cost_append_2[symmetric])
  finally show "?b + ?c \<le> ?a"
    using p_shortest_walk
    by (simp add: p_decomp is_shortest_walk_def)
qed

subsection \<open>Shortest walks in subgraphs/supergraphs\<close>

lemma (in subgraph) shortest_walk_cost_subgraph_ge_shortest_walk_cost_supergraph:
  shows "shortest_walk_cost G f u v \<le> shortest_walk_cost H f u v"
proof -
  have "{p. walk H u p v} \<subseteq> {p. walk G u p v}"
    by (blast intro: walk_subgraph_is_walk_supergraph)
  hence
    "(\<lambda>p. ereal (walk_cost f p)) ` {p. walk H u p v} \<subseteq>
      (\<lambda>p. ereal (walk_cost f p)) ` {p. walk G u p v}"
    (is "?A \<subseteq> ?B")
    by blast
  hence "Inf ?B \<le> Inf ?A"
    by (rule Inf_superset_mono)
  thus ?thesis
    by (simp add: shortest_walk_cost_def)
qed

lemmas (in induced_subgraph) shortest_walk_cost_subgraph_ge_shortest_walk_cost_supergraph =
  shortest_walk_cost_subgraph_ge_shortest_walk_cost_supergraph

lemma (in induced_subgraph) shortest_walk_supergraph_is_shortest_walk_subgraph:
  assumes p_shortest_walk: "is_shortest_walk G f u p v"
  assumes "set p \<subseteq> V"
  shows "is_shortest_walk H f u p v"
proof (intro antisym is_shortest_walkI)
  show p_walk: "walk H u p v"
    using assms
    by (auto simp add: is_shortest_walk_def intro: walk_supergraph_is_walk_subgraph)
  show "walk_cost f p \<le> shortest_walk_cost H f u v"
    using p_shortest_walk shortest_walk_cost_subgraph_ge_shortest_walk_cost_supergraph
    by (simp add: is_shortest_walk_def)
  show "shortest_walk_cost H f u v \<le> walk_cost f p"
    using p_walk
    by (rule shortest_walk_cost_le_walk_cost)
qed

subsection \<open>Convenience Lemmas\<close>

lemma (in graph) shortest_walk_cost_infinite_if_not_in_vertices:
  assumes "v \<notin> vertices G"
  shows "shortest_walk_cost G f u v = \<infinity>"
proof (rule ccontr)
  assume "shortest_walk_cost G f u v \<noteq> \<infinity>"
  hence "reachable G u v"
    by (simp add: shortest_walk_cost_reachable_conv)
  then obtain p where
    "walk G u p v"
    by (auto simp add: reachable_def)
  hence "v \<in> vertices G"
    by (rule walk_last_in_vertices)
  thus "False"
    using assms
    by simp
qed

lemma (in finite_graph) shortest_walk_cost_walk:
  assumes p_walk: "walk G u p v"
  assumes f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  shows "\<exists>q. is_shortest_walk G f u q v \<and> walk_cost f q \<le> walk_cost f p"
proof -
  have "reachable G u v"
    using p_walk
    by (auto simp add: reachable_def)
  hence "\<exists>q. path G u q v \<and> walk_cost f q = shortest_walk_cost G f u v"
    using f_non_negative
    by (rule shortest_walk_cost_path)
  then obtain q where
    q_walk: "walk G u q v" and
    q_walk_cost: "walk_cost f q = shortest_walk_cost G f u v"
    by (auto simp add: path_def)

  have "walk_cost f q \<le> walk_cost f p"
    unfolding ereal_less_eq(3)[symmetric] q_walk_cost
    using p_walk
    by (rule shortest_walk_cost_le_walk_cost)
  moreover have "is_shortest_walk G f u q v"
    using q_walk q_walk_cost
    by (rule is_shortest_walkI)
  ultimately show ?thesis
    by blast
qed

definition shortest_walk :: "'a graph \<Rightarrow> 'a cost_fun \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "shortest_walk G f u v \<equiv> SOME p. is_shortest_walk G f u p v"

lemma (in finite_graph) shortest_walk_is_shortest_walk:
  assumes "reachable G u v"
  assumes "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
  shows "is_shortest_walk G f u (shortest_walk G f u v) v"
proof -
  have "\<exists>p. path G u p v \<and> walk_cost f p = shortest_walk_cost G f u v"
    using assms
    by (rule shortest_walk_cost_path)
  hence "\<exists>p. walk G u p v \<and> walk_cost f p = shortest_walk_cost G f u v"
    by (auto simp add: path_def)
  hence "\<exists>p. is_shortest_walk G f u p v"
    by (auto simp add: is_shortest_walk_def)
  thus ?thesis
    unfolding shortest_walk_def
    ..
qed

section \<open>Shortest walk length\<close>

(*
TODO: Is there a way to define shortest_walk_length as

definition shortest_walk_length :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> enat" where
  "shortest_walk_length G u v \<equiv> INF p\<in>{p. walk G u p v}. enat (walk_length p)"

and prove

  "ereal_of_enat (shortest_walk_length G u v) = shortest_walk_cost G (\<lambda>_. 1) u v"

If not, would it be better to change the type of shortest_walk_cost to enat?
*)

abbreviation shortest_walk_length :: "'a graph \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ereal" where
  "shortest_walk_length G \<equiv> shortest_walk_cost G (\<lambda>_. 1)"

lemma walk_length_eq_walk_cost:
  shows "walk_length p = walk_cost (\<lambda>_. 1) p"
proof (induction p rule: walk_induct)
case 1
  thus ?case
    by simp
next
  case (2 _)
  thus ?case
    by (simp add: walk_cost_def)
next
  case (3 v v' vs)
  define f :: "'a set \<Rightarrow> real" where
    "f = (\<lambda>_. 1)"
  have "walk_length (v # v' # vs) = 1 + walk_length (v' # vs)"
    by simp
  also have "... = 1 + walk_cost f (v' # vs)"
    by (simp add: "3.IH" f_def)
  also have "... = f {v, v'} + walk_edges_cost f (walk_edges (v' # vs))"
    by (simp add: f_def walk_cost_def)
  also have "... = walk_cost f (v # v' # vs)"
    by (simp add: walk_cost_def)
  finally show ?case
    by (simp add: f_def)
qed

lemma (in finite_graph) shortest_walk_length_eq_1:
  shows
    "0 < shortest_walk_length G u v \<and> shortest_walk_length G u v \<le> 1 \<longleftrightarrow>
      shortest_walk_length G u v = 1"
proof
  assume assm: "0 < shortest_walk_length G u v \<and> shortest_walk_length G u v \<le> 1"
  define f :: "'a set \<Rightarrow> real" where
    "f = (\<lambda>_. 1)"
  have f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
    by (simp add: f_def)

  have "shortest_walk_length G u v \<noteq> \<infinity>"
    using assm
    by auto
  hence "reachable G u v"
    by (simp add: shortest_walk_cost_reachable_conv)
  hence "\<exists>p. path G u p v \<and> walk_cost f p = shortest_walk_cost G f u v"
    using f_non_negative
    by (rule shortest_walk_cost_path)
  then obtain p where
    p_walk_cost: "walk_cost f p = shortest_walk_length G u v"
    by (auto simp add: f_def)
  hence
    "0 < walk_cost f p"
    "walk_cost f p \<le> 1"
    using assm
    by (simp add: ereal_less(2)[symmetric] ereal_less_eq(3)[symmetric] one_ereal_def)+
  hence
    "0 < walk_length p"
    "walk_length p \<le> 1"
    by (simp add: f_def walk_length_eq_walk_cost[symmetric])+
  hence "walk_length p = 1"
    by linarith
  hence "walk_cost f p = 1"
    by (simp add: walk_length_eq_walk_cost[symmetric] f_def)
  thus "shortest_walk_length G u v = 1"
    by (simp add: p_walk_cost[symmetric])
qed simp

lemma (in finite_graph) shortest_walk_length_eq_1_implies_edge:
  assumes "shortest_walk_length G u v = 1"
  shows "{u, v} \<in> edges G"
proof -
  define f :: "'a set \<Rightarrow> real" where
    "f = (\<lambda>_. 1)"
  have f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
    by (simp add: f_def)

  have "shortest_walk_length G u v \<noteq> \<infinity>"
    using assms
    by simp
  hence "reachable G u v"
    by (simp add: shortest_walk_cost_reachable_conv)
  hence "\<exists>p. path G u p v \<and> walk_cost f p = shortest_walk_cost G f u v"
    using f_non_negative
    by (rule shortest_walk_cost_path)
  then obtain p where
    p_walk: "walk G u p v" and
    "walk_cost f p = 1"
    using assms
    by (auto simp add: path_def f_def)
  hence "walk_length p = 1"
    by (simp add: f_def walk_length_eq_walk_cost[symmetric])
  hence "length p = Suc 1"
    using p_walk
    by (simp add: walk_def walk_length)
  hence "p = [u, v]"
    using p_walk
    by (intro list_length_2) (simp add: walk_def)+
  thus ?thesis
    using p_walk
    by (simp add: edge_iff_walk)
qed

lemma (in finite_graph) shortest_walk_length_le_1_if_edge:
  assumes "{u, v} \<in> edges G"
  shows "shortest_walk_length G u v \<le> 1"
proof -
  have "walk G u [u, v] v"
    using assms
    by (rule edge_is_walk)
  hence "shortest_walk_length G u v \<le> walk_cost (\<lambda>_. 1) [u, v]"
    by (rule shortest_walk_cost_le_walk_cost)
  also have "... = 1"
    by (simp add: walk_cost_def)
  finally show ?thesis
    .
qed

lemma (in finite_graph) shortest_walk_length_ge_1_if_edge:
  assumes "{u, v} \<in> edges G"
  shows "1 \<le> shortest_walk_length G u v"
proof (rule ccontr)
  assume assm: "\<not> 1 \<le> shortest_walk_length G u v"
  define f :: "'a set \<Rightarrow> real" where
    "f = (\<lambda>_. 1)"
  have f_non_negative: "\<And>e. e \<in> edges G \<Longrightarrow> 0 \<le> f e"
    by (simp add: f_def)

  have "walk G u [u, v] v"
    using assms
    by (rule edge_is_walk)
  hence "reachable G u v"
    by (auto simp add: reachable_def)
  hence "\<exists>p. path G u p v \<and> walk_cost f p = shortest_walk_cost G f u v"
    using f_non_negative
    by (rule shortest_walk_cost_path)
  then obtain p where
    p_walk: "walk G u p v" and
    "walk_cost f p = shortest_walk_length G u v"
    by (auto simp add: path_def f_def)
  hence "walk_cost f p < 1"
    using assm
    by (simp add: ereal_less(3)[symmetric])
  hence "walk_length p = 0"
    unfolding f_def walk_length_eq_walk_cost[symmetric]
    by linarith
  hence "length p = 1"
    using p_walk
    by (simp add: walk_def walk_length)
  hence "p = [u] \<and> u = v"
    using p_walk
    by (intro list_length_1) (simp add: walk_def)+
  thus "False"
    using assms graph
    by auto
qed

lemma (in finite_graph) shortest_walk_length_eq_1_if_edge:
  assumes "{u, v} \<in> edges G"
  shows "shortest_walk_length G u v = 1"
proof (rule antisym)
  show "shortest_walk_length G u v \<le> 1"
    using assms
    by (rule shortest_walk_length_le_1_if_edge)
next
  show "1 \<le> shortest_walk_length G u v"
    using assms
    by (rule shortest_walk_length_ge_1_if_edge)
qed

lemma (in finite_graph) shortest_walk_length_eq_1_iff_edge:
  shows "shortest_walk_length G u v = 1 \<longleftrightarrow> {u, v} \<in> edges G"
proof
  show "shortest_walk_length G u v = 1 \<Longrightarrow> {u, v} \<in> edges G"
    using shortest_walk_length_eq_1_implies_edge
    .
next
  show "{u, v} \<in> edges G \<Longrightarrow> shortest_walk_length G u v = 1"
    using shortest_walk_length_eq_1_if_edge
    .
qed

end