(* Author: Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk *)

section \<open>Tensor Products\<close>

theory Tensor
imports
  Complex_Vectors
  Matrix_Tensor.Matrix_Tensor
  Jordan_Normal_Form.Matrix
begin

text \<open>
There is already a formalization of tensor products in the Archive of Formal Proofs,
namely Matrix\_Tensor.thy in Tensor Product of Matrices[1] by T.V.H. Prathamesh, but it does not build
on top of the formalization of vectors and matrices given in Matrices, Jordan Normal Forms, and
Spectral Radius Theory[2] by René Thiemann and Akihisa Yamada.
In the present theory our purpose consists in giving such a formalization. Of course, we will reuse
Prathamesh's code as much as possible, and in order to achieve that we formalize some lemmas that
translate back and forth between vectors (resp. matrices) seen as lists (resp. lists of lists) and
vectors (resp. matrices) as formalized in [2].
\<close>

subsection \<open>The Kronecker Product of Complex Vectors\<close>

definition tensor_vec:: "complex Matrix.vec \<Rightarrow> complex Matrix.vec \<Rightarrow> complex Matrix.vec" (infixl "\<otimes>" 63)
where "tensor_vec u v \<equiv> vec_of_list (mult.vec_vec_Tensor (*) (list_of_vec u) (list_of_vec v))"

subsection \<open>The Tensor Product of Complex Matrices\<close>

text \<open>To see a matrix in the sense of [2] as a matrix in the sense of [1], we convert it into its list
of column vectors.\<close>

definition mat_to_cols_list:: "complex Matrix.mat \<Rightarrow> complex list list" where
  "mat_to_cols_list A = [[A $$ (i,j) . i <- [0..< dim_row A]] . j <- [0..< dim_col A]]"

lemma length_mat_to_cols_list [simp]:
  "length (mat_to_cols_list A) = dim_col A"
  by (simp add: mat_to_cols_list_def)

lemma length_cols_mat_to_cols_list [simp]:
  assumes "j < dim_col A"
  shows "length [A $$ (i,j) . i <- [0..< dim_row A]] = dim_row A"
  using assms by simp

lemma length_row_mat_to_cols_list [simp]:
  assumes "i < dim_row A"
  shows "length (row (mat_to_cols_list A) i) = dim_col A"
  using assms by (simp add: row_def)

lemma length_col_mat_to_cols_list [simp]:
  assumes "j < dim_col A"
  shows "length (col (mat_to_cols_list A) j) = dim_row A"
  using assms by (simp add: col_def mat_to_cols_list_def)

lemma mat_to_cols_list_is_not_Nil [simp]:
  assumes "dim_col A > 0"
  shows "mat_to_cols_list A \<noteq> []"
  using assms by (simp add: mat_to_cols_list_def)

text \<open>Link between Matrix\_Tensor.row\_length and Matrix.dim\_row\<close>

lemma row_length_mat_to_cols_list [simp]:
  assumes "dim_col A > 0"
  shows "mult.row_length (mat_to_cols_list A) = dim_row A"
proof -
  have "mat_to_cols_list A \<noteq> []" by (simp add: assms)
  then have "mult.row_length (mat_to_cols_list A) = length (hd (mat_to_cols_list A))"
    using mult.row_length_def[of "1" "(*)"]
    by (simp add: \<open>\<And>xs. Matrix_Tensor.mult 1 (*) \<Longrightarrow> mult.row_length xs \<equiv> if xs = [] then 0 else length (hd xs)\<close> mult.intro)
  thus ?thesis by (simp add: assms mat_to_cols_list_def upt_conv_Cons)
qed

text \<open>@{term mat_to_cols_list} is a matrix in the sense of @{theory Matrix.Matrix_Legacy}.\<close>

lemma mat_to_cols_list_is_mat [simp]:
  assumes "dim_col A > 0"
  shows "mat (mult.row_length (mat_to_cols_list A)) (length (mat_to_cols_list A)) (mat_to_cols_list A)"
proof -
  have "Ball (set (mat_to_cols_list A)) (Matrix_Legacy.vec (mult.row_length (mat_to_cols_list A)))"
    using assms row_length_mat_to_cols_list mat_to_cols_list_def Ball_def set_def vec_def by fastforce
  thus ?thesis by(auto simp: mat_def)
qed

definition mat_of_cols_list:: "nat \<Rightarrow> complex list list \<Rightarrow> complex Matrix.mat" where
  "mat_of_cols_list nr cs = Matrix.mat nr (length cs) (\<lambda> (i,j). cs ! j ! i)"

lemma index_mat_of_cols_list [simp]:
  assumes "i < nr" and "j < length cs"
  shows "mat_of_cols_list nr cs $$ (i,j) = cs ! j ! i"
  by (simp add: assms mat_of_cols_list_def)

lemma mat_to_cols_list_to_mat [simp]:
  "mat_of_cols_list (dim_row A) (mat_to_cols_list A) = A"
proof
  show f1:"dim_row (mat_of_cols_list (dim_row A) (mat_to_cols_list A)) = dim_row A"
    by (simp add: mat_of_cols_list_def)
next
  show f2:"dim_col (mat_of_cols_list (dim_row A) (mat_to_cols_list A)) = dim_col A"
    by (simp add: Tensor.mat_of_cols_list_def)
next
  show "\<And>i j. i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow>
    (mat_of_cols_list (dim_row A) (mat_to_cols_list A)) $$ (i, j) = A $$ (i, j)"
    by (simp add: mat_of_cols_list_def mat_to_cols_list_def)
qed

lemma plus_mult_cpx [simp]:
  "plus_mult 1 (*) 0 (+) (a_inv cpx_rng)"
  apply unfold_locales
  apply (auto intro: cpx_cring_is_field simp: field_simps)
proof -
  show "\<And>x. x + \<ominus>\<^bsub>cpx_rng\<^esub> x = 0"
    using group.r_inv[of "cpx_rng"] cpx_cring_is_field field_def domain_def cpx_rng_def
    by (metis UNIV_I cring.cring_simprules(17) ordered_semiring_record_simps(1)
        ordered_semiring_record_simps(11) ordered_semiring_record_simps(12))
  show "\<And>x. x + \<ominus>\<^bsub>cpx_rng\<^esub> x = 0"
    using group.r_inv[of "cpx_rng"] cpx_cring_is_field field_def domain_def cpx_rng_def
    by (metis UNIV_I cring.cring_simprules(17) ordered_semiring_record_simps(1)
        ordered_semiring_record_simps(11) ordered_semiring_record_simps(12))
qed

lemma list_to_mat_to_cols_list [simp]:
  fixes l::"complex list list"
  assumes "mat nr nc l"
  shows "mat_to_cols_list (mat_of_cols_list nr l) = l"
proof -
  have "length (mat_to_cols_list (mat_of_cols_list nr l)) = length l"
    by (simp add: mat_of_cols_list_def)
  moreover have f1:"\<forall>j<length l. length(l ! j) = mult.row_length l"
    using assms plus_mult.row_length_constant plus_mult_cpx by fastforce
  moreover have "\<And>j. j<length l \<longrightarrow> mat_to_cols_list (mat_of_cols_list nr l) ! j = l ! j"
  proof
    fix j
    assume a:"j < length l"
    then have f2:"length (mat_to_cols_list (mat_of_cols_list nr l) ! j) = length (l ! j)"
      by (metis col_def mat_def vec_def mat_of_cols_list_def assms dim_col_mat(1) dim_row_mat(1)
length_col_mat_to_cols_list nth_mem)
    then have "\<forall>i<mult.row_length l. mat_to_cols_list (mat_of_cols_list nr l) ! j ! i = l ! j ! i"
      using a mat_to_cols_list_def mat_of_cols_list_def f1 by simp
    thus "mat_to_cols_list (Tensor.mat_of_cols_list nr l) ! j = l ! j"
      using f2 by(simp add: nth_equalityI a f1)
  qed
  ultimately show ?thesis using nth_equalityI by metis
qed

lemma col_mat_of_cols_list [simp]:
  assumes "j < length l"
  shows "Matrix.col (mat_of_cols_list (length (l ! j)) l) j = vec_of_list (l ! j)"
proof -
  define u where "u = Matrix.col (mat_of_cols_list (length (l ! j)) l) j"
  then have "dim_vec u = dim_vec (vec_of_list (l ! j))"
    by (auto simp: u_def mat_of_cols_list_def Matrix.col_def vec_of_list_def)
      (metis dim_vec_of_list vec_of_list.abs_eq)
  moreover have "\<forall>i<length(l ! j). u $ i = vec_of_list (l ! j) $ i"
    by (simp add: u_def vec_of_list_index mat_of_cols_list_def assms)
  ultimately show ?thesis by(simp add: vec_eq_iff u_def)
qed

definition tensor_mat:: "[complex Matrix.mat, complex Matrix.mat] \<Rightarrow> complex Matrix.mat" (infixl "\<Otimes>" 63) where
"tensor_mat A B \<equiv>
  mat_of_cols_list (dim_row A * dim_row B) (mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list B))"

lemma dim_row_tensor_mat [simp]:
  "dim_row (A \<Otimes> B) = dim_row A * dim_row B"
  by (simp add: mat_of_cols_list_def tensor_mat_def)

lemma dim_col_tensor_mat [simp]:
  "dim_col (A \<Otimes> B) = dim_col A * dim_col B"
  using tensor_mat_def mat_of_cols_list_def mult.length_Tensor[of "1" "(*)"]
  by(simp add: \<open>\<And>M2 M1. Matrix_Tensor.mult 1 (*) \<Longrightarrow> length (mult.Tensor (*) M1 M2) = length M1 * length M2\<close> mult.intro)

lemma index_tensor_mat [simp]:
  assumes a1:"dim_row A = rA" and a2:"dim_col A = cA" and a3:"dim_row B = rB" and a4:"dim_col B = cB"
    and a5:"i < rA * rB" and a6:"j < cA * cB" and a7:"cA > 0" and a8:"cB > 0"
  shows "(A \<Otimes> B) $$ (i,j) = A $$ (i div rB, j div cB) * B $$ (i mod rB, j mod cB)"
proof -
  have "(A \<Otimes> B) $$ (i,j) = (mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list B)) ! j ! i"
    using assms tensor_mat_def mat_of_cols_list_def dim_col_tensor_mat by simp
  moreover have f:"i < mult.row_length (mat_to_cols_list A) * mult.row_length (mat_to_cols_list B)"
    by (simp add: a1 a2 a3 a4 a5 a7 a8)
  moreover have "j < length (mat_to_cols_list A) * length (mat_to_cols_list B)"
    by (simp add: a2 a4 a6)
  moreover have "mat (mult.row_length (mat_to_cols_list A)) (length (mat_to_cols_list A)) (mat_to_cols_list A)"
    using a2 a7 mat_to_cols_list_is_mat by blast
  moreover have "mat (mult.row_length (mat_to_cols_list B)) (length (mat_to_cols_list B)) (mat_to_cols_list B)"
    using a4 a8 mat_to_cols_list_is_mat by blast
  ultimately have "(A \<Otimes> B) $$ (i,j) =
    (mat_to_cols_list A) ! (j div length (mat_to_cols_list B)) ! (i div mult.row_length (mat_to_cols_list B))
    * (mat_to_cols_list B) ! (j mod length (mat_to_cols_list B)) ! (i mod mult.row_length (mat_to_cols_list B))"
    using mult.matrix_Tensor_elements[of "1" "(*)"]
    by(simp add: \<open>\<And>M2 M1. mult 1 (*) \<Longrightarrow> \<forall>i j. (i<mult.row_length M1 * mult.row_length M2
    \<and> j<length M1 * length M2) \<and> mat (mult.row_length M1) (length M1) M1 \<and> mat (mult.row_length M2) (length M2) M2 \<longrightarrow>
    mult.Tensor (*) M1 M2 ! j ! i = M1 ! (j div length M2) ! (i div mult.row_length M2) * M2 ! (j mod length M2) ! (i mod mult.row_length M2)\<close>  mult.intro)
  thus ?thesis
    using mat_to_cols_list_def
    by (metis a2 a3 a4 a6 f index_mat_of_cols_list length_mat_to_cols_list less_mult_imp_div_less
less_nat_zero_code mat_to_cols_list_to_mat mult_0_right neq0_conv row_length_mat_to_cols_list
unique_euclidean_semiring_numeral_class.pos_mod_bound)
qed

text \<open>To go from @{term Matrix.row} to @{term Matrix_Legacy.row}\<close>

lemma Matrix_row_is_Legacy_row:
  assumes "i < dim_row A"
  shows "Matrix.row A i = vec_of_list (row (mat_to_cols_list A) i)"
proof
  show "dim_vec (Matrix.row A i) = dim_vec (vec_of_list (row (mat_to_cols_list A) i))"
    using length_mat_to_cols_list Matrix.dim_vec_of_list by (metis row_def index_row(2) length_map)
next
  show "\<And>j. j<dim_vec (vec_of_list (row (mat_to_cols_list A) i)) \<Longrightarrow>
              Matrix.row A i $ j = vec_of_list (row (mat_to_cols_list A) i) $ j"
    using Matrix.row_def vec_of_list_def mat_to_cols_list_def
    by(smt row_def assms dim_vec_of_list index_mat_of_cols_list index_row(1)
length_mat_to_cols_list length_row_mat_to_cols_list mat_to_cols_list_to_mat nth_map vec_of_list_index)
qed

text \<open>To go from @{term Matrix_Legacy.row} to @{term Matrix.row}\<close>

lemma Legacy_row_is_Matrix_row:
  assumes "i < mult.row_length A"
  shows "row A i = list_of_vec (Matrix.row (mat_of_cols_list (mult.row_length A) A) i)"
proof (rule nth_equalityI)
  show "length (row A i) = length (list_of_vec (Matrix.row (mat_of_cols_list (mult.row_length A) A) i))"
    using row_def length_list_of_vec by(metis mat_of_cols_list_def dim_col_mat(1) index_row(2) length_map)
next
  fix j:: nat
  assume "j < length (row A i)"
  then show "row A i ! j = list_of_vec (Matrix.row (mat_of_cols_list (mult.row_length A) A) i) ! j"
    using assms index_mat_of_cols_list
    by(metis row_def mat_of_cols_list_def dim_col_mat(1) dim_row_mat(1) index_row(1) length_map list_of_vec_index nth_map)
qed

text \<open>To go from @{term Matrix.col} to @{term Matrix_Legacy.col}\<close>

lemma Matrix_col_is_Legacy_col:
  assumes "j < dim_col A"
  shows "Matrix.col A j = vec_of_list (col (mat_to_cols_list A) j)"
proof
  show "dim_vec (Matrix.col A j) = dim_vec (vec_of_list (col (mat_to_cols_list A) j))"
    by (simp add: col_def assms mat_to_cols_list_def)
next
  show "\<And>i. i < dim_vec (vec_of_list (col (mat_to_cols_list A) j)) \<Longrightarrow>
         Matrix.col A j $ i = vec_of_list (col (mat_to_cols_list A) j) $ i"
    using mat_to_cols_list_def
    by (metis col_def assms col_mat_of_cols_list length_col_mat_to_cols_list length_mat_to_cols_list
mat_to_cols_list_to_mat)
qed

text \<open>To go from @{term Matrix_Legacy.col} to @{term Matrix.col}\<close>

lemma Legacy_col_is_Matrix_col:
  assumes a1:"j < length A" and a2:"length (A ! j) = mult.row_length A"
  shows "col A j = list_of_vec (Matrix.col (mat_of_cols_list (mult.row_length A) A) j)"
proof (rule nth_equalityI)
  have "length (list_of_vec (Matrix.col (mat_of_cols_list (mult.row_length A) A) j)) =
dim_vec (Matrix.col (mat_of_cols_list (mult.row_length A) A) j)"
    using length_list_of_vec by blast
  also have "\<dots> = dim_row (mat_of_cols_list (mult.row_length A) A)"
    using Matrix.col_def by simp
  also have f1:"\<dots> = mult.row_length A"
    by (simp add: mat_of_cols_list_def)
  finally show f2:"length (col A j) = length (list_of_vec (Matrix.col (mat_of_cols_list (mult.row_length A) A) j))"
    using a2 by (simp add: col_def)
next
  fix i:: nat
  assume "i<length (col A j)"
  then show "(col A j) ! i = (list_of_vec (Matrix.col (mat_of_cols_list (mult.row_length A) A) j)) ! i"
    by (metis col_def a1 a2 col_mat_of_cols_list list_vec)
qed

text \<open>Link between @{term plus_mult.scalar_product} and @{term Matrix.scalar_prod}\<close>

lemma scalar_prod_is_Matrix_scalar_prod [simp]:
  fixes u::"complex list" and v::"complex list"
  assumes "length u = length v"
  shows "plus_mult.scalar_product (*) 0 (+) u v = (vec_of_list u) \<bullet> (vec_of_list v)"
proof -
  have f:"(vec_of_list u) \<bullet> (vec_of_list v) = (\<Sum>i=0..<length v. u ! i * v ! i)"
    using assms scalar_prod_def[of "vec_of_list u" "vec_of_list v"] Matrix.dim_vec_of_list[of v] index_vec_of_list
    by (metis (no_types, lifting) atLeastLessThan_iff sum.cong)
  thus ?thesis
  proof -
    have "plus_mult.scalar_product (*) 0 (+) u v = semiring_0_class.scalar_prod u v"
      using  plus_mult.scalar_product_def[of 1 "(*)" 0 "(+)" "a_inv cpx_rng" u v] by simp
    also have "\<dots> = sum_list (map (\<lambda>(x,y). x * y) (zip u v))"
      by (simp add: scalar_prod)
    moreover have "\<forall>i<length v. (zip u v) ! i = (u ! i, v ! i)"
      using assms zip_def by simp
    then have "\<forall>i<length v. (map (\<lambda>(x,y). x * y) (zip u v)) ! i = u ! i * v ! i"
      by (simp add: assms)
    ultimately have "plus_mult.scalar_product (*) 0 (+) u v = (\<Sum>i=0..<length v. u ! i * v ! i)"
      by(metis (no_types, lifting) assms atLeastLessThan_iff length_map map_fst_zip sum.cong sum_list_sum_nth)
    thus ?thesis by (simp add: f)
  qed
qed

text \<open>Link between @{term times} and @{term plus_mult.matrix_mult}\<close>

lemma matrix_mult_to_times_mat:
  assumes "dim_col A > 0" and "dim_col B > 0" and "dim_col (A::complex Matrix.mat) = dim_row B"
  shows "A * B = mat_of_cols_list (dim_row A) (plus_mult.matrix_mult (*) 0 (+) (mat_to_cols_list A) (mat_to_cols_list B))"
proof
  define M where "M = mat_of_cols_list (dim_row A) (plus_mult.matrix_mult (*) 0 (+) (mat_to_cols_list A) (mat_to_cols_list B))"
  then show f1:"dim_row (A * B) = dim_row M"
    by (simp add: mat_of_cols_list_def times_mat_def)
  have "length (plus_mult.matrix_mult (*) 0 (+) (mat_to_cols_list A) (mat_to_cols_list B)) = dim_col B"
    by (simp add: mat_multI_def)
  then show f2:"dim_col (A * B) = dim_col M"
    by (simp add: M_def times_mat_def mat_of_cols_list_def)
  show "\<And>i j. i < dim_row M \<Longrightarrow> j < dim_col M \<Longrightarrow> (A * B) $$ (i, j) = M $$ (i, j)"
  proof -
    fix i j
    assume a1:"i < dim_row M" and a2:"j < dim_col M"
    then have "(A * B) $$ (i,j) = Matrix.row A i \<bullet> Matrix.col B j"
      using f1 f2 by simp
    also have "\<dots> = vec_of_list (row (mat_to_cols_list A) i) \<bullet> vec_of_list (col (mat_to_cols_list B) j)"
      using f1 f2 a1 a2 by (simp add: Matrix_row_is_Legacy_row Matrix_col_is_Legacy_col)
    also have "\<dots> = plus_mult.scalar_product (*) 0 (+) (row (mat_to_cols_list A) i) (col (mat_to_cols_list B) j)"
      using a1 a2 assms(3) f1 f2 by simp
    also have "M $$ (i,j) =  plus_mult.scalar_product (*) 0 (+) (row (mat_to_cols_list A) i) (col (mat_to_cols_list B) j)"
    proof-
      have "M $$ (i,j) = (plus_mult.matrix_mult (*) 0 (+) (mat_to_cols_list A) (mat_to_cols_list B)) ! j ! i"
        using M_def f1 f2
\<open>length (mat_mult (mult.row_length (mat_to_cols_list A)) (mat_to_cols_list A) (mat_to_cols_list B)) = dim_col B\<close> a1 a2 by simp
      moreover have "mat (mult.row_length (mat_to_cols_list A)) (dim_col A) (mat_to_cols_list A)"
        using mat_to_cols_list_is_mat assms(1) by simp
      moreover have "mat (dim_col A) (dim_col B) (mat_to_cols_list B)"
        using assms(2) assms(3) mat_to_cols_list_is_mat by simp
      ultimately show ?thesis
        using assms(1) a1 a2 row_length_mat_to_cols_list plus_mult.matrix_index[of 1 "(*)" 0 "(+)"] plus_mult_cpx
        by (smt f1 f2 index_mult_mat(2) index_mult_mat(3))
    qed
    finally show "(A * B) $$ (i, j) = M $$ (i, j)" by simp
  qed
qed

lemma mat_to_cols_list_times_mat [simp]:
  assumes "dim_col A = dim_row B" and "dim_col A > 0"
  shows "mat_to_cols_list (A * B) = plus_mult.matrix_mult (*) 0 (+) (mat_to_cols_list A) (mat_to_cols_list B)"
proof (rule nth_equalityI)
  define M where "M = plus_mult.matrix_mult (*) 0 (+) (mat_to_cols_list A) (mat_to_cols_list B)"
  then show f0:"length (mat_to_cols_list (A * B)) = length M" by (simp add: mat_multI_def)
  moreover have f1:"\<And>j. j<length (mat_to_cols_list (A * B)) \<longrightarrow> mat_to_cols_list (A * B) ! j = M ! j"
  proof
    fix j:: nat
    assume a0:"j < length (mat_to_cols_list (A * B))"
    then have "length (mat_to_cols_list (A * B) ! j) = dim_row A"
      by (simp add: mat_to_cols_list_def)
    then also have f2:"length (M ! j) = dim_row A"
      using a0 M_def mat_multI_def[of 0 "(+)" "(*)" "dim_row A" "mat_to_cols_list A" "mat_to_cols_list B"]
        row_length_mat_to_cols_list assms(2)
      by (metis assms(1) f0 length_greater_0_conv length_map length_mat_to_cols_list
list_to_mat_to_cols_list mat_mult mat_to_cols_list_is_mat matrix_mult_to_times_mat)
    ultimately have "length (mat_to_cols_list (A * B) ! j) = length (M ! j)" by simp
    moreover have "\<And>i. i<dim_row A \<longrightarrow> mat_to_cols_list (A * B) ! j ! i = M ! j ! i"
    proof
      fix i
      assume a1:"i < dim_row A"
      have "mat (mult.row_length (mat_to_cols_list A)) (dim_col A) (mat_to_cols_list A)"
        using mat_to_cols_list_is_mat assms(2) by simp
      moreover have "mat (dim_col A) (dim_col B) (mat_to_cols_list B)"
        using mat_to_cols_list_is_mat assms(1) a0 by simp
      ultimately have "M ! j ! i = plus_mult.scalar_product (*) 0 (+) (row (mat_to_cols_list A) i) (col (mat_to_cols_list B) j)"
        using plus_mult.matrix_index a0 a1 row_length_mat_to_cols_list assms(2) plus_mult_cpx M_def
        by (metis index_mult_mat(3) length_mat_to_cols_list)
      also have "\<dots> = vec_of_list (row (mat_to_cols_list A) i) \<bullet> vec_of_list (col (mat_to_cols_list B) j)"
        using a0 a1 assms(1) by simp
      finally show "mat_to_cols_list (A * B) ! j ! i = M ! j ! i"
        using mat_to_cols_list_def index_mult_mat(1) a0 a1
        by(simp add: Matrix_row_is_Legacy_row Matrix_col_is_Legacy_col)
    qed
    ultimately show "mat_to_cols_list (A * B) ! j = M ! j" by(simp add: nth_equalityI f2)
  qed
  fix i:: nat
  assume "i < length (mat_to_cols_list (A * B))"
  thus "mat_to_cols_list (A * B) ! i = M ! i" by (simp add: f1)
qed

text \<open>
Finally, we prove that the tensor product of complex matrices is distributive over the
multiplication of complex matrices.
\<close>

lemma mult_distr_tensor:
  assumes a1:"dim_col A = dim_row B" and a2:"dim_col C = dim_row D" and a3:"dim_col A > 0" and
    a4:"dim_col B > 0" and a5:"dim_col C > 0" and a6:"dim_col D > 0"
  shows "(A * B) \<Otimes> (C * D) = (A \<Otimes> C) * (B \<Otimes> D)"
proof -
  define A' B' C' D' M N where "A' = mat_to_cols_list A" and "B' = mat_to_cols_list B" and
    "C' = mat_to_cols_list C" and "D' = mat_to_cols_list D" and
    "M = mat_of_cols_list (dim_row A * dim_row C) (mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list C))" and
    "N = mat_of_cols_list (dim_row B * dim_row D) (mult.Tensor (*) (mat_to_cols_list B) (mat_to_cols_list D))"
  then have "(A \<Otimes> C) * (B \<Otimes> D) = M * N"
    by (simp add: tensor_mat_def)
  also have "\<dots> = mat_of_cols_list (dim_row A * dim_row C) (plus_mult.matrix_mult (*) 0 (+)
  (mat_to_cols_list M) (mat_to_cols_list N))"
    using assms M_def N_def dim_col_tensor_mat dim_row_tensor_mat tensor_mat_def
    by(simp add: matrix_mult_to_times_mat)
  also have f1:"\<dots> = mat_of_cols_list (dim_row A * dim_row C) (plus_mult.matrix_mult (*) 0 (+)
  (mult.Tensor (*) A' C') (mult.Tensor (*) B' D'))"
  proof -
    define M' N' where "M' = mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list C)" and
      "N' = mult.Tensor (*) (mat_to_cols_list B) (mat_to_cols_list D)"
    then have "mat (mult.row_length M') (length M') M'"
      using M'_def mult.effective_well_defined_Tensor[of 1 "(*)"] mat_to_cols_list_is_mat a3 a5
      by (smt mult.length_Tensor mult.row_length_mat plus_mult_cpx plus_mult_def)
    moreover have "mat (mult.row_length N') (length N') N'"
      using N'_def mult.effective_well_defined_Tensor[of 1 "(*)"] mat_to_cols_list_is_mat a4 a6
      by (smt mult.length_Tensor mult.row_length_mat plus_mult_cpx plus_mult_def)
    ultimately show ?thesis
      using list_to_mat_to_cols_list M_def N_def mult.row_length_mat row_length_mat_to_cols_list
      assms(3) a4 a5 a6 A'_def B'_def C'_def D'_def by(metis M'_def N'_def plus_mult_cpx plus_mult_def)
   qed
   also have "\<dots> = mat_of_cols_list (dim_row A * dim_row C) (mult.Tensor (*)
    (plus_mult.matrix_mult (*) 0 (+) A' B')
    (plus_mult.matrix_mult (*) 0 (+) C' D'))"
   proof -
     have f2:"mat (mult.row_length A') (length A') A'"
       using A'_def a3 mat_to_cols_list_is_mat by simp
     moreover have "mat (mult.row_length B') (length B') B'"
       using B'_def a4 mat_to_cols_list_is_mat by simp
     moreover have "mat (mult.row_length C') (length C') C'"
       using C'_def a5 mat_to_cols_list_is_mat by simp
     moreover have "mat (mult.row_length D') (length D') D'"
       using D'_def a6 mat_to_cols_list_is_mat by simp
     moreover have "length A' = mult.row_length B'"
       using A'_def B'_def a1 a4 by simp
     moreover have "length C' = mult.row_length D'"
       using C'_def D'_def a2 a6 by simp
     moreover have "A' \<noteq> [] \<and> B' \<noteq> [] \<and> C' \<noteq> [] \<and> D' \<noteq> []"
       using A'_def B'_def C'_def D'_def a3 a4 a5 a6 by simp
     ultimately have "plus_mult.matrix_match A' B' C' D'"
       using plus_mult.matrix_match_def[of 1 "(*)" 0 "(+)" "a_inv cpx_rng"] by simp
     thus ?thesis
       using f1 plus_mult.distributivity plus_mult_cpx by fastforce
   qed
   also have "\<dots> = mat_of_cols_list (dim_row A * dim_row C) (mult.Tensor (*)
   (mat_to_cols_list (A * B)) (mat_to_cols_list (C * D)))"
     using A'_def B'_def C'_def D'_def a1 a2 a3 a5 by simp
   finally show ?thesis by(simp add: tensor_mat_def)
 qed

lemma tensor_mat_is_assoc:
  fixes A B C:: "complex Matrix.mat"
  shows "A \<Otimes> (B \<Otimes> C) = (A \<Otimes> B) \<Otimes> C"
proof-
  define M where d:"M = mat_of_cols_list (dim_row B * dim_row C) (mult.Tensor (*) (mat_to_cols_list B) (mat_to_cols_list C))"
  then have "B \<Otimes> C = M"
    using tensor_mat_def by simp
  moreover have "A \<Otimes> (B \<Otimes> C) = mat_of_cols_list (dim_row A * (dim_row B * dim_row C))
(mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list M))"
    using tensor_mat_def d dim_row_tensor_mat by simp
  moreover have "mat_to_cols_list M = mult.Tensor (*) (mat_to_cols_list B) (mat_to_cols_list C)"
    using d list_to_mat_to_cols_list
    by (smt calculation(1) dim_col_tensor_mat length_greater_0_conv length_mat_to_cols_list mat_to_cols_list_is_mat
mult.Tensor.simps(1) mult.Tensor_null mult.well_defined_Tensor nat_0_less_mult_iff plus_mult_cpx plus_mult_def row_length_mat_to_cols_list)
  ultimately have "A \<Otimes> (B \<Otimes> C) = mat_of_cols_list (dim_row A * (dim_row B * dim_row C))
(mult.Tensor (*) (mat_to_cols_list A) (mult.Tensor (*) (mat_to_cols_list B) (mat_to_cols_list C)))" by simp
  moreover have "\<dots> = mat_of_cols_list ((dim_row A * dim_row B) * dim_row C)
(mult.Tensor (*) (mult.Tensor (*) (mat_to_cols_list A) (mat_to_cols_list B)) (mat_to_cols_list C))"
    using Matrix_Tensor.mult.associativity
    by (smt ab_semigroup_mult_class.mult_ac(1) length_greater_0_conv length_mat_to_cols_list
mat_to_cols_list_is_mat mult.Tensor.simps(1) mult.Tensor_null plus_mult_cpx plus_mult_def)
  ultimately show ?thesis
    using tensor_mat_def
    by (smt Tensor.mat_of_cols_list_def dim_col_mat(1) dim_col_tensor_mat dim_row_tensor_mat length_0_conv
list_to_mat_to_cols_list mat_to_cols_list_is_mat mult.well_defined_Tensor mult_is_0 neq0_conv
plus_mult_cpx plus_mult_def row_length_mat_to_cols_list)
qed

end


theory Concrete_Semantics_3_1
  imports Main
begin
  type_synonym vname = string
  datatype aexp = N int | V vname | Plus aexp aexp

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

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a b) s = aval a s + aval b s"

value "aval (Plus (N 3) (V ''x'')) (\<lambda>x. 0)"
value "aval (Plus (N 3) (V ''x''))((\<lambda>x.  0) (''x'' := 7)) "

fun asimp_const:: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a b) =
(case (asimp_const a, asimp_const b) of
  (N n, N m) \<Rightarrow> N (n + m) |
  (c, d) \<Rightarrow> Plus c d )"

lemma "aval (asimp_const a) s = aval a s"
  apply(induction a)
    apply(auto split:aexp.split)
  done

fun plus:: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i) (N j) = N(i + j)" |
"plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"plus a b = Plus a b"

lemma aval_plus: "aval (plus a b) s = aval a s + aval b s"
  apply(induction rule: plus.induct)
      apply(auto split:aexp.split)
  done

fun asimp:: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a b) = plus (asimp a) (asimp b)"

lemma "aval (asimp a) s = aval a s"
  apply(induction rule: asimp.induct)
    apply(auto split: aexp.split)
  by (simp add: aval_plus)

fun optimal :: "aexp \<Rightarrow> bool" where
"optimal (N n) = True" |
"optimal (V x) = True" |
"optimal (Plus (N a) (N b)) = False" |
"optimal (Plus a b) = ((optimal a) \<and> (optimal b))"

lemma "optimal (asimp_const a)"
  apply(induction a)
    apply(auto split: aexp.split)
  done

fun full_plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"full_plus (N i) (N j) = N(i + j)" |
"full_plus (N i) (Plus a (N j)) = Plus a (N (i + j))" |
"full_plus (N i) (Plus (N j) a) = Plus a (N (i + j))" |
"full_plus a (Plus b (N j)) = Plus (Plus a b) (N j)" |
"full_plus a (Plus (N j) b) = Plus (Plus a b) (N j)" |
"full_plus (Plus a (N i)) (N j) = Plus a (N (i + j))" |
"full_plus (Plus (N i) b) (N j) = Plus b (N (i + j))" |
"full_plus (Plus a (N j)) b = Plus (Plus a b) (N j)" |
"full_plus (Plus (N j) a) b = Plus (Plus a b) (N j)" |
"full_plus (N i) a = (if i = 0 then a else Plus (N i) a)" |
"full_plus a (N i) = (if i = 0 then a else Plus a (N i))" |
"full_plus a b = Plus a b"

fun full_asimp :: "aexp \<Rightarrow> aexp" where
"full_asimp (N n) = N n" |
"full_asimp (V x) = V x" |
"full_asimp (Plus a b) = full_plus(full_asimp a)(full_asimp b)"

lemma aval_full_plus: "aval (full_plus a b) s = aval a s + aval b s"
  apply(induction rule: full_plus.induct)
      apply(auto split:aexp.split)
  done

lemma "aval (full_asimp a) s = aval a s"
  apply(induction a)
    apply(auto split: aexp.split)
  by (simp add: aval_full_plus)

fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = N n" |
"subst x a (V y) = (if (x = y) then a else V y)" |
"subst x a (Plus b c) = Plus (subst x a b) (subst x a c)"

lemma substitution: "aval (subst x a e) s = aval e (s(x := aval a s))"
    apply(induction e)
  apply(auto)
  done

lemma aval_uniq: "aval a1 s = aval a2 s \<Longrightarrow> aval (subst x a1 e) s = aval (subst x a2 e) s"
  apply(induction e)
  apply(auto)
  done

datatype aexp2 = N2 int | V2 vname | Plus2 aexp2 aexp2 | PIncr vname

fun get_first :: "val \<times> state \<Rightarrow> val" where
"get_first (a, s) = a"

fun get_last :: "val \<times> state \<Rightarrow> state" where
"get_last (a, s) = s"

fun aval2 :: "aexp2 \<Rightarrow> state \<Rightarrow> val \<times> state" where
"aval2 (N2 n) s = (n, s)" |
"aval2 (V2 x) s = (s x, s)" |
"aval2 (Plus2 a b) s = (get_first (aval2 a s) + get_first (aval2 b s), get_last (aval2 b s))" |
"aval2 (PIncr x) s = (s x, s(x:= (s x + 1))) "

datatype aexp3 = N3 int | V3 vname | Plus3 aexp3 aexp3 | PIncr3 vname | Div aexp3 aexp3

fun aval3 :: "aexp3 \<Rightarrow> state \<Rightarrow> (val \<times> state) option" where
"aval3 (N3 n) s = Some(n, s)" |
"aval3 (V3 x) s = Some(s x, s)" |
"aval3 (Plus3 a b) s = (case (aval3 a s) of Some (a', s') \<Rightarrow>
  (case (aval3 b s) of Some (b', s'') \<Rightarrow> Some(a' + b', s'') |
     None \<Rightarrow> None) |
  None \<Rightarrow> None)" |
"aval3 (PIncr3 x) s = Some (s x, s(x:= (s x + 1))) " |
"aval3 (Div a b) s = (case (aval3 b s) of Some(b', s') \<Rightarrow>
  (if b' = 0 then None else
    (case (aval3 a s) of Some(a', s'') \<Rightarrow> Some(a' div b', s'') | None \<Rightarrow> None  )) |
  None \<Rightarrow> None)"

lemma "aval3 (Div (N3 3) (N3 0)) (\<lambda>x. 1) = None"
  by auto

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> int" where
"lval (Nl n) s = n" |
"lval (Vl x) s = s x" |
"lval (Plusl a b) s = (lval a s) + (lval b s)" |
"lval (LET x a b) s = lval b (s (x := lval a s))"

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n) = (N n)" |
"inline (Vl x) = (V x)" |
"inline (Plusl a b) = (Plus (inline a) (inline b))" |
"inline (LET x a b) = subst x (inline a) (inline b)"

lemma "aval (inline e) s = lval e s"
  apply(induction e arbitrary: s)
     apply(auto split:lexp.split)
  by (simp add: substitution)

end


theory Queue
imports "../l4v/tools/autocorres/AutoCorres"
begin

text{*

Author: Andrew Gacek
Description: Correctness proofs for enqueue and dequeue operations on a circular queue.

*}

type_synonym 'a queue = "'a list \<times> nat \<times> nat"

fun wf :: "'a queue \<Rightarrow> bool" where
  "wf (xs, f, n) = (0 < length xs \<and> f < length xs \<and> n \<le> length xs)"

fun is_empty :: "'a queue \<Rightarrow> bool" where
  "is_empty (xs, f, n) = (n = 0)"

fun is_full :: "'a queue \<Rightarrow> bool" where
  "is_full (xs, f, n) = (n = length xs)"

fun enqueue :: "'a queue \<Rightarrow> 'a \<Rightarrow> 'a queue" where
  "enqueue (xs, f, n) x =
    (if \<not>is_full (xs, f, n) then
       (xs[(f + n) mod length xs := x], f, n + 1)
     else
       undefined)"

fun dequeue :: "'a queue \<Rightarrow> 'a \<times> 'a queue" where
  "dequeue (xs, f, Suc n) = (xs!f, (xs, (f + 1) mod length xs, n))" |
  "dequeue (xs, f, 0) = undefined"

fun rep :: "'a queue \<Rightarrow> 'a list" where
  "rep (xs, f, n) = take n (rotate f xs)"

lemma enqueue_wf[intro, simp]:
  "\<lbrakk> wf q; \<not>is_full q \<rbrakk> \<Longrightarrow> wf (enqueue q x)"
by (cases q, auto)

lemma dequeue_wf[intro, simp]:
  "\<lbrakk> wf q; \<not>is_empty q \<rbrakk> \<Longrightarrow> wf (snd (dequeue q))"
by (cases q, auto simp: gr0_conv_Suc)

lemma nth_rotate1:
  "i < length xs \<Longrightarrow> rotate1 xs ! i = (if Suc i < length xs then xs ! (Suc i) else xs ! 0)"
by (cases "xs = []", auto simp: rotate1_hd_tl nth_append nth_tl hd_conv_nth)

lemma nth_rotate1_mod:
  "0 < length xs \<Longrightarrow> rotate1 xs ! (i mod length xs) = xs ! (Suc i mod length xs)"
by (metis hd_rotate_conv_nth length_greater_0_conv length_rotate1 rotate1_rotate_swap rotate_Suc)

lemma rotate1_Suc_update:
  "rotate1 (xs[Suc n mod length xs := x]) = (rotate1 xs)[n mod length xs := x]"
by (cases "xs = []", auto simp: mod_Suc nth_list_update nth_rotate1 intro: nth_equalityI)

lemma rotate_update:
  "rotate f (xs[(f + n) mod length xs := x]) = rotate f xs[n mod length xs := x]"
by (induction f arbitrary: n, simp_all, metis rotate1_Suc_update length_rotate add_Suc_right)

lemma nth_rotate:
  "n < length xs \<Longrightarrow> (rotate f xs) ! n = xs ! ((f + n) mod length xs)"
by (induction f arbitrary: xs, auto simp: rotate1_rotate_swap nth_rotate1_mod length_ineq_not_Nil)

lemma enqueue_rep:
  "\<lbrakk> wf q; \<not>is_full q \<rbrakk> \<Longrightarrow> rep (enqueue q x) = rep q @ [x]"
by (cases q, auto simp: take_Suc_conv_app_nth rotate_update nth_rotate)

lemma dequeue_rep:
  "\<lbrakk> wf q; \<not>is_empty q; dequeue q = (x, q') \<rbrakk> \<Longrightarrow> rep q = x # rep q'"
apply (cases q, simp)
apply (auto simp: gr0_conv_Suc take_Suc hd_rotate_conv_nth rotate_conv_mod[symmetric] rotate1_hd_tl)
done

install_C_file queue.c
autocorres[ts_rules = nondet, heap_abs_syntax] queue.c

context queue begin

definition is_queue :: "lifted_globals \<Rightarrow> bool" where
  "is_queue s \<equiv> front_'' s < 10 \<and> length_'' s \<le> 10"

definition the_queue :: "lifted_globals \<Rightarrow> 8 word queue" where
  "the_queue s \<equiv> (list_array (contents_'' s), unat (front_'' s), unat (length_'' s))"

fun queue_length :: "'a queue \<Rightarrow> nat" where
  "queue_length (xs, f, n) = n"

lemma is_full_wp [wp]:
  "\<lbrace> \<lambda>s. if queue_length (the_queue s) = 10 then Q 1 s else Q 0 s \<rbrace>
   is_full'
   \<lbrace> \<lambda>r s. Q r s \<rbrace>!"
apply (unfold is_full'_def)
apply wp
apply (auto simp: the_queue_def unat_arith_simps)
done

lemma enqueue_full:
  "\<lbrace> \<lambda>s. is_queue s \<and> queue_length (the_queue s) = 10 \<and> P s \<rbrace>
   enqueue' x
   \<lbrace> \<lambda>r s. r = 0 \<and> P s \<rbrace>!"
apply (unfold enqueue'_def)
apply wp
apply (auto simp: is_queue_def the_queue_def unat_arith_simps)
done

lemma list_array_update:
  "i < length (list_array a) \<Longrightarrow> list_array (Arrays.update a i x) = list_array a[i := x]"
by (auto simp add: list_array_def nth_list_update intro: nth_equalityI)

lemma enqueue_not_full:
  "(\<And>s c. P (s\<lparr>contents_'' := c\<rparr>) = P s) \<Longrightarrow>
   (\<And>s n. P (s\<lparr>length_'' := n\<rparr>) = P s) \<Longrightarrow>
   \<lbrace> \<lambda>s. is_queue s \<and>
         q = the_queue s \<and>
         queue_length q < 10 \<and>
         P s \<rbrace>
   enqueue' x
   \<lbrace> \<lambda>r s. r > 0 \<and>
           the_queue s = enqueue q x \<and>
           is_queue s \<and>
           P s \<rbrace>!"
apply (unfold enqueue'_def)
apply wp
apply (auto simp: is_queue_def the_queue_def list_array_update unat_arith_simps)
done

lemma is_empty_wp [wp]:
  "\<lbrace> \<lambda>s. if queue_length (the_queue s) = 0 then Q 1 s else Q 0 s \<rbrace>
   is_empty'
   \<lbrace> \<lambda>r s. Q r s \<rbrace>!"
apply (unfold is_empty'_def)
apply wp
apply (auto simp: the_queue_def unat_arith_simps)
done

lemma dequeue_empty:
  "\<lbrace> \<lambda>s. is_queue s \<and> queue_length (the_queue s) = 0 \<and> P s \<rbrace>
   dequeue' x
   \<lbrace> \<lambda>r s. r = 0 \<and> P s \<rbrace>!"
apply (unfold dequeue'_def)
apply wp
apply (auto simp: is_queue_def the_queue_def unat_arith_simps)
done

lemma dequeue_not_empty:
  "(\<And>s f. P (s\<lparr>front_'' := f\<rparr>) = P s) \<Longrightarrow>
   (\<And>s n. P (s\<lparr>length_'' := n\<rparr>) = P s) \<Longrightarrow>
   (\<And>s v. P (s[x := v]) = P s) \<Longrightarrow>
   \<lbrace> \<lambda>s. is_queue s \<and>
         q = the_queue s \<and>
         queue_length q > 0 \<and>
         is_valid_w8 s x \<and>
         P s \<rbrace>
   dequeue' x
   \<lbrace> \<lambda>r s. r > 0 \<and>
           dequeue q = (heap_w8 s x, the_queue s) \<and>
           is_queue s \<and>
           P s \<rbrace>!"
apply (unfold dequeue'_def)
apply wp
apply (auto simp: fun_upd_def is_queue_def the_queue_def queue.update_w8_def
                  gr0_conv_Suc list_array_nth unat_arith_simps)
done

end
end


section \<open>Monotonic Boolean Transformers\<close>

theory Mono_Bool_Tran
imports
  LatticeProperties.Complete_Lattice_Prop
  LatticeProperties.Conj_Disj
begin

text\<open>
The type of monotonic transformers is the type associated to the set of monotonic
functions from a partially ordered set (poset) to itself. The type of monotonic
transformers with the pointwise extended order is also a poset.
The monotonic transformers with composition and identity
form a monoid, and the monoid operation is compatible with the order.

Gradually we extend the algebraic structure of monotonic transformers to
lattices, and complete lattices. We also introduce a dual operator
($(\mathsf{dual}\;f) p = - f (-p)$) on monotonic transformers over
a boolean algebra. However the monotonic transformers over a boolean
algebra are not closed to the pointwise extended negation operator.

Finally we introduce an iteration operator on monotonic transformers
over a complete lattice.
\<close>

notation
  bot  ("\<bottom>") and
  top  ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65) and
  Inf  ("\<Sqinter>_" [900] 900) and
  Sup  ("\<Squnion>_" [900] 900)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

lemma Inf_comp_fun:
  "\<Sqinter>M \<circ> f = (\<Sqinter>m\<in>M. m \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma INF_comp_fun:
  "(\<Sqinter>a\<in>A. g a) \<circ> f = (\<Sqinter>a\<in>A. g a \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma Sup_comp_fun:
  "\<Squnion>M \<circ> f = (\<Squnion>m\<in>M. m \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma SUP_comp_fun:
  "(\<Squnion>a\<in>A. g a) \<circ> f = (\<Squnion>a\<in>A. g a \<circ> f)"
  by (simp add: fun_eq_iff image_comp)

lemma (in order) mono_const [simp]:
  "mono (\<lambda>_. c)"
  by (auto intro: monoI)

lemma (in order) mono_id [simp]:
  "mono id"
  by (auto intro: order_class.monoI)

lemma (in order) mono_comp [simp]:
  "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (f \<circ> g)"
  by (auto intro!: monoI elim!: monoE order_class.monoE)

lemma (in bot) mono_bot [simp]:
  "mono \<bottom>"
  by (auto intro: monoI)

lemma (in top) mono_top [simp]:
  "mono \<top>"
  by (auto intro: monoI)

lemma (in semilattice_inf) mono_inf [simp]:
  assumes "mono f" and "mono g"
  shows "mono (f \<sqinter> g)"
proof
  fix a b
  assume "a \<le> b"
  have "f a \<sqinter> g a \<le> f a" by simp
  also from \<open>mono f\<close> \<open>a \<le> b\<close> have "\<dots> \<le> f b" by (auto elim: monoE)
  finally have *: "f a \<sqinter> g a \<le> f b" .
  have "f a \<sqinter> g a \<le> g a" by simp
  also from \<open>mono g\<close> \<open>a \<le> b\<close> have "\<dots> \<le> g b" by (auto elim: monoE)
  finally have **: "f a \<sqinter> g a \<le> g b" .
  from * ** show "(f \<sqinter> g) a \<le> (f \<sqinter> g) b" by auto
qed

lemma (in semilattice_sup) mono_sup [simp]:
  assumes "mono f" and "mono g"
  shows "mono (f \<squnion> g)"
proof
  fix a b
  assume "a \<le> b"
  from \<open>mono f\<close> \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
  also have "f b \<le> f b \<squnion> g b" by simp
  finally have *: "f a \<le> f b \<squnion> g b" .
  from \<open>mono g\<close> \<open>a \<le> b\<close> have "g a \<le> g b" by (auto elim: monoE)
  also have "g b \<le> f b \<squnion> g b" by simp
  finally have **: "g a \<le> f b \<squnion> g b" .
  from * ** show "(f \<squnion> g) a \<le> (f \<squnion> g) b" by auto
qed

lemma (in complete_lattice) mono_Inf [simp]:
  assumes "A \<subseteq> {f :: 'a \<Rightarrow> 'b:: complete_lattice. mono f}"
  shows "mono (\<Sqinter>A)"
proof
  fix a b
  assume "a \<le> b"
  { fix f
    assume "f \<in> A"
    with assms have "mono f" by auto
    with \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
  }
  then have "(\<Sqinter>f\<in>A. f a) \<le> (\<Sqinter>f\<in>A. f b)"
    by (auto intro: complete_lattice_class.INF_greatest complete_lattice_class.INF_lower2)
  then show "(\<Sqinter>A) a \<le> (\<Sqinter>A) b" by simp
qed

lemma (in complete_lattice) mono_Sup [simp]:
  assumes "A \<subseteq> {f :: 'a \<Rightarrow> 'b:: complete_lattice. mono f}"
  shows "mono (\<Squnion>A)"
proof
  fix a b
  assume "a \<le> b"
  { fix f
    assume "f \<in> A"
    with assms have "mono f" by auto
    with \<open>a \<le> b\<close> have "f a \<le> f b" by (auto elim: monoE)
  }
  then have "(\<Squnion>f\<in>A. f a) \<le> (\<Squnion>f\<in>A. f b)"
    by (auto intro: complete_lattice_class.SUP_least complete_lattice_class.SUP_upper2)
  then show "(\<Squnion>A) a \<le> (\<Squnion>A) b" by simp
qed

typedef (overloaded) 'a MonoTran = "{f::'a::order \<Rightarrow> 'a . mono f}"
proof
  show "id \<in> ?MonoTran" by simp
qed

setup_lifting type_definition_MonoTran

instantiation MonoTran :: (order) order
begin

lift_definition less_eq_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> bool"
  is less_eq .

lift_definition less_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> bool"
  is less .

instance
  by intro_classes (transfer, auto intro: order_antisym)+

end

instantiation MonoTran :: (order) monoid_mult
begin

lift_definition one_MonoTran :: "'a MonoTran"
  is id
  by (fact mono_id)

lift_definition times_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
  is comp
  by (fact mono_comp)

instance
  by intro_classes (transfer, auto)+

end

instantiation MonoTran :: (order_bot) order_bot
begin

lift_definition bot_MonoTran :: "'a MonoTran"
  is \<bottom>
  by (fact mono_bot)

instance
  by intro_classes (transfer, simp)

end

instantiation MonoTran :: (order_top) order_top
begin

lift_definition top_MonoTran :: "'a MonoTran"
  is \<top>
  by (fact mono_top)

instance
  by intro_classes (transfer, simp)

end

instantiation MonoTran :: (lattice) lattice
begin

lift_definition inf_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
  is inf
  by (fact mono_inf)

lift_definition sup_MonoTran :: "'a MonoTran \<Rightarrow> 'a MonoTran \<Rightarrow> 'a MonoTran"
  is sup
  by (fact mono_sup)

instance
  by intro_classes (transfer, simp)+

end

instance MonoTran :: (distrib_lattice) distrib_lattice
  by intro_classes (transfer, rule sup_inf_distrib1)

instantiation MonoTran :: (complete_lattice) complete_lattice
begin

lift_definition Inf_MonoTran :: "'a MonoTran set \<Rightarrow> 'a MonoTran"
  is Inf
  by (rule mono_Inf) auto

lift_definition Sup_MonoTran :: "'a MonoTran set \<Rightarrow> 'a MonoTran"
  is Sup
  by (rule mono_Sup) auto

instance
  by intro_classes (transfer, simp add: Inf_lower Sup_upper Inf_greatest Sup_least)+

end

context includes lifting_syntax
begin

lemma [transfer_rule]:
  "(rel_set A ===> (A ===> pcr_MonoTran HOL.eq) ===> pcr_MonoTran HOL.eq) (\<lambda>A f. \<Squnion>(f ` A)) (\<lambda>A f. \<Squnion>(f ` A))"
  by transfer_prover

end

instance MonoTran :: (complete_distrib_lattice) complete_distrib_lattice
proof (intro_classes, transfer)
  fix A :: "('a \<Rightarrow> 'a) set set"
  assume " \<forall>A\<in>A. Ball A mono"
  from this have [simp]: "{f ` A |f. \<forall>Y\<in>A. f Y \<in> Y} = {x. (\<exists>f. (\<forall>x. (\<forall>x\<in>x. mono x) \<longrightarrow> mono (f x)) \<and> x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> (\<forall>x\<in>x. mono x)}"
    apply safe
      apply (rule_tac x = "\<lambda> x . if x \<in> A then f x else \<bottom>" in exI)
      apply (simp add: if_split image_def)
    by blast+

  show " \<Sqinter>(Sup ` A) \<le> \<Squnion>(Inf ` {x. (\<exists>f\<in>Collect (pred_fun (\<lambda>A. Ball A mono) mono). x = f ` A \<and> (\<forall>Y\<in>A. f Y \<in> Y)) \<and> Ball x mono})"
    by (simp add: Inf_Sup)
qed

definition
  "dual_fun (f::'a::boolean_algebra \<Rightarrow> 'a) = uminus \<circ> f \<circ> uminus"

lemma dual_fun_apply [simp]:
  "dual_fun f p = - f (- p)"
  by (simp add: dual_fun_def)

lemma mono_dual_fun [simp]:
  "mono f \<Longrightarrow> mono (dual_fun f)"
  apply (rule monoI)
  apply (erule monoE)
  apply auto
  done

lemma (in order) mono_inf_fun [simp]:
  fixes x :: "'b::semilattice_inf"
  shows "mono (inf x)"
  by (auto intro!: order_class.monoI semilattice_inf_class.inf_mono)

lemma (in order) mono_sup_fun [simp]:
  fixes x :: "'b::semilattice_sup"
  shows "mono (sup x)"
  by (auto intro!: order_class.monoI semilattice_sup_class.sup_mono)

lemma mono_comp_fun:
  fixes f :: "'a::order \<Rightarrow> 'b::order"
  shows "mono f \<Longrightarrow> mono ((\<circ>) f)"
  by (rule monoI) (auto simp add: le_fun_def elim: monoE)

definition
  "Omega_fun f g = inf g \<circ> comp f"

lemma Omega_fun_apply [simp]:
  "Omega_fun f g h p = (g p \<sqinter> f (h p))"
  by (simp add: Omega_fun_def)

lemma mono_Omega_fun [simp]:
  "mono f \<Longrightarrow> mono (Omega_fun f g)"
  unfolding Omega_fun_def
  by (auto intro: mono_comp mono_comp_fun)

lemma mono_mono_Omega_fun [simp]:
  fixes f :: "'b::order \<Rightarrow> 'a::semilattice_inf" and g :: "'c::semilattice_inf \<Rightarrow> 'a"
  shows "mono f \<Longrightarrow> mono g \<Longrightarrow> mono_mono (Omega_fun f g)"
  apply (auto simp add: mono_mono_def Omega_fun_def)
  apply (rule mono_comp)
  apply (rule mono_inf_fun)
  apply (rule mono_comp_fun)
  apply assumption
  done

definition
  "omega_fun f = lfp (Omega_fun f id)"

definition
  "star_fun f = gfp (Omega_fun f id)"

lemma mono_omega_fun [simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "mono (omega_fun f)"
proof
  fix a b :: 'a
  assume "a \<le> b"
  from assms have "mono (lfp (Omega_fun f id))"
    by (auto intro: mono_mono_Omega_fun)
  with \<open>a \<le> b\<close> show "omega_fun f a \<le> omega_fun f b"
    by (auto simp add: omega_fun_def elim: monoE)
qed

lemma mono_star_fun [simp]:
  fixes f :: "'a::complete_lattice \<Rightarrow> 'a"
  assumes "mono f"
  shows "mono (star_fun f)"
proof
  fix a b :: 'a
  assume "a \<le> b"
  from assms have "mono (gfp (Omega_fun f id))"
    by (auto intro: mono_mono_Omega_fun)
  with \<open>a \<le> b\<close> show "star_fun f a \<le> star_fun f b"
    by (auto simp add: star_fun_def elim: monoE)
qed

lemma lfp_omega_lowerbound:
  "mono f \<Longrightarrow> Omega_fun f g A \<le> A \<Longrightarrow> omega_fun f \<circ> g \<le> A"
  apply (simp add: omega_fun_def)
  apply (rule_tac P = "\<lambda> x . x \<circ> g \<le> A" and f = "Omega_fun f id" in lfp_ordinal_induct)
  apply simp_all
  apply (simp add: le_fun_def o_def inf_fun_def id_def Omega_fun_def)
  apply auto
  apply (rule_tac y = "f (A x) \<sqinter> g x" in order_trans)
  apply simp_all
  apply (rule_tac y = "f (S (g x))" in order_trans)
  apply simp_all
  apply (simp add: mono_def) apply (auto simp add: ac_simps)
  apply (unfold Sup_comp_fun)
  apply (rule SUP_least)
  by auto

lemma gfp_omega_upperbound:
  "mono f \<Longrightarrow> A \<le> Omega_fun f g A \<Longrightarrow> A \<le> star_fun f \<circ> g"
  apply (simp add: star_fun_def)
  apply (rule_tac P = "\<lambda> x . A \<le> x \<circ> g" and f = "Omega_fun f id" in gfp_ordinal_induct)
  apply simp_all
  apply (simp add: le_fun_def o_def inf_fun_def id_def Omega_fun_def)
  apply auto
  apply (rule_tac y = "f (A x) \<sqinter> g x" in order_trans)
  apply simp_all
  apply (rule_tac y = "f (A x)" in order_trans)
  apply simp_all
  apply (simp add: mono_def)
  apply (unfold Inf_comp_fun)
  apply (rule INF_greatest)
  by auto

lemma lfp_omega_greatest:
  assumes "\<And>u. Omega_fun f g u \<le> u \<Longrightarrow> A \<le> u"
  shows "A \<le> omega_fun f \<circ> g"
  apply (unfold omega_fun_def)
  apply (simp add: lfp_def)
  apply (unfold Inf_comp_fun)
  apply (rule INF_greatest)
  apply simp
  apply (rule assms)
  apply (simp add: le_fun_def)
  done

lemma gfp_star_least:
  assumes "\<And>u. u \<le> Omega_fun f g u \<Longrightarrow> u \<le> A"
  shows "star_fun f \<circ> g \<le> A"
  apply (unfold star_fun_def)
  apply (simp add: gfp_def)
  apply (unfold Sup_comp_fun)
  apply (rule SUP_least)
  apply simp
  apply (rule assms)
  apply (simp add: le_fun_def)
  done

lemma lfp_omega:
  "mono f \<Longrightarrow> omega_fun f \<circ> g = lfp (Omega_fun f g)"
  apply (rule antisym)
  apply (rule lfp_omega_lowerbound)
  apply simp_all
  apply (simp add: lfp_def)
  apply (rule Inf_greatest)
  apply safe
  apply (rule_tac y = "Omega_fun f g x" in order_trans)
  apply simp_all
  apply (rule_tac f = " Omega_fun f g" in monoD)
  apply simp_all
  apply (rule Inf_lower)
  apply simp
  apply (rule lfp_omega_greatest)
  apply (simp add: lfp_def)
  apply (rule Inf_lower)
  by simp

lemma gfp_star:
  "mono f \<Longrightarrow> star_fun f \<circ> g = gfp (Omega_fun f g)"
  apply (rule antisym)
  apply (rule gfp_star_least)
  apply (simp add: gfp_def)
  apply (rule Sup_upper, simp)
  apply (rule gfp_omega_upperbound)
  apply simp_all
  apply (simp add: gfp_def)
  apply (rule Sup_least)
  apply safe
  apply (rule_tac y = "Omega_fun f g x" in order_trans)
  apply simp_all
  apply (rule_tac f = " Omega_fun f g" in monoD)
  apply simp_all
  apply (rule Sup_upper)
  by simp

definition
  "assert_fun p q = (p \<sqinter> q :: 'a::semilattice_inf)"

lemma mono_assert_fun [simp]:
  "mono (assert_fun p)"
  apply (simp add: assert_fun_def mono_def, safe)
  by (rule_tac y = x in order_trans, simp_all)

lemma assert_fun_le_id [simp]: "assert_fun p \<le> id"
  by (simp add: assert_fun_def id_def le_fun_def)

lemma assert_fun_disjunctive [simp]: "assert_fun (p::'a::distrib_lattice) \<in> Apply.disjunctive"
  by (simp add: assert_fun_def Apply.disjunctive_def inf_sup_distrib)

definition
  "assertion_fun = range assert_fun"

lemma assert_cont:
  "(x :: 'a::boolean_algebra \<Rightarrow> 'a)  \<le> id \<Longrightarrow> x \<in> Apply.disjunctive \<Longrightarrow> x = assert_fun (x \<top>)"
  apply (rule antisym)
  apply (simp_all add: le_fun_def assert_fun_def, safe)
  apply (rule_tac f = x in  monoD, simp_all)
  apply (subgoal_tac "x top = sup (x xa) (x (-xa))")
  apply simp
  apply (subst inf_sup_distrib)
  apply simp
  apply (rule_tac y = "inf (- xa) xa" in order_trans)
  supply [[simproc del: boolean_algebra_cancel_inf]]
  apply (simp del: compl_inf_bot)
  apply (rule_tac y = "x (- xa)" in order_trans)
  apply simp
  apply simp
  apply simp
  apply (cut_tac x = x and y = xa and z = "-xa" in Apply.disjunctiveD, simp)
  apply (subst (asm) sup_commute)
  apply (subst (asm) compl_sup_top)
  by simp

lemma assertion_fun_disj_less_one: "assertion_fun = Apply.disjunctive \<inter> {x::'a::boolean_algebra \<Rightarrow> 'a . x \<le> id}"
  apply safe
  apply (simp_all add: assertion_fun_def, auto simp add: image_def)
  apply (rule_tac x = "x \<top>" in exI)
  by (rule assert_cont, simp_all)

lemma assert_fun_dual: "((assert_fun p) o \<top>) \<sqinter> (dual_fun (assert_fun p)) = assert_fun p"
  by (simp add: fun_eq_iff inf_fun_def dual_fun_def o_def assert_fun_def top_fun_def inf_sup_distrib)

lemma assertion_fun_dual: "x \<in> assertion_fun \<Longrightarrow> (x o \<top>) \<sqinter> (dual_fun x) = x"
  by (simp add: assertion_fun_def, safe, simp add: assert_fun_dual)

lemma assertion_fun_MonoTran [simp]: "x \<in> assertion_fun \<Longrightarrow> mono x"
  by (unfold assertion_fun_def, auto)

lemma assertion_fun_le_one [simp]: "x \<in> assertion_fun \<Longrightarrow> x \<le> id"
  by (unfold assertion_fun_def, auto)

end


(*  Title:      Sort.thy
    Author:     Danijela Petrovi\'c, Facylty of Mathematics, University of Belgrade *)

header {* Verification of functional Selection Sort *}

theory SelectionSort_Functional
imports RemoveMax
begin

subsection {* Defining data structure *}

text{* Selection sort works with list and that is the reason why {\em
  Collection} should be interpreted as list. *}

interpretation Collection "[]" "\<lambda> l. l = []" id multiset_of
by (unfold_locales, auto)

subsection {* Defining function remove\_max *}

text{* The following is definition of {\em remove\_max} function.
The idea is very well known -- assume that the maximum element is the
first one and then compare with each element of the list. Function
{\em f} is one step in iteration, it compares current maximum {\em m}
with one element {\em x}, if it is bigger then {\em m} stays current
maximum and {\em x} is added in the resulting list, otherwise {\em x}
is current maximum and {\em m} is added in the resulting
list.
*}

fun f where "f (m, l) x = (if x \<ge> m then (x, m#l) else (m, x#l))"

definition remove_max where
  "remove_max l = foldl f (hd l, []) (tl l)"

lemma max_Max_commute:
  "finite A \<Longrightarrow> max (Max (insert m A)) x = max m (Max (insert x A))"
  apply (cases "A = {}", simp)
  by (metis Max_insert max.commute max.left_commute)

text{* The function really returned the
maximum value. *}

lemma remove_max_max_lemma:
  shows "fst (foldl f (m, t) l) =  Max (set (m # l))"
using assms
proof (induct l arbitrary: m t rule: rev_induct)
  case (snoc x xs)
  let ?a = "foldl f (m, t) xs"
  let ?m' = "fst ?a" and ?t' = "snd ?a"
  have "fst (foldl f (m, t) (xs @ [x])) = max ?m' x"
    by (cases ?a) (auto simp add: max_def)
  thus ?case
    using snoc
    by (simp add: max_Max_commute)
qed simp

lemma remove_max_max:
  assumes "l \<noteq> []" "(m, l') = remove_max l"
  shows "m = Max (set l)"
using assms
unfolding remove_max_def
using remove_max_max_lemma[of "hd l" "[]" "tl l"]
using fst_conv[of m l']
by simp

text{* Nothing new is added in the list and noting is deleted
from the list except the maximum element. *}

lemma remove_max_multiset_of_lemma:
  assumes "(m, l') = foldl f (m', t') l"
  shows "multiset_of (m # l') = multiset_of (m' # t' @ l)"
using assms
proof (induct l arbitrary: l' m m' t' rule: rev_induct)
  case (snoc x xs)
  let ?a = "foldl f (m', t') xs"
  let ?m' = "fst ?a" and ?t' = "snd ?a"
  have "multiset_of (?m' # ?t') = multiset_of (m' # t' @ xs)"
    using snoc(1)[of ?m' ?t' m' t']
    by simp
  thus ?case
    using snoc(2)
    apply (cases "?a")
    apply (auto split: split_if_asm, (simp add: union_lcomm union_commute)+)
    by (metis union_assoc)
qed simp

lemma remove_max_multiset_of:
  assumes "l \<noteq> []" "(m, l') = remove_max l"
  shows "multiset_of l' + {#m#} = multiset_of l"
using assms
unfolding remove_max_def
using remove_max_multiset_of_lemma[of m l' "hd l" "[]" "tl l"]
by auto

definition ssf_ssort' where
  [simp, code del]: "ssf_ssort' = RemoveMax.ssort' (\<lambda> l. l = []) remove_max"
definition ssf_ssort where
  [simp, code del]: "ssf_ssort = RemoveMax.ssort (\<lambda> l. l = []) id remove_max"

interpretation SSRemoveMax:
  RemoveMax "[]" "\<lambda> l. l = []" id multiset_of remove_max "\<lambda> _. True"
  where
 "RemoveMax.ssort' (\<lambda> l. l = []) remove_max = ssf_ssort'" and
 "RemoveMax.ssort (\<lambda> l. l = []) id remove_max = ssf_ssort"
using remove_max_max
by (unfold_locales, auto simp add: remove_max_multiset_of)

end


(* Author: Maximilian P. L. Haslbeck *)

theory IHT_Knapsack
  imports
    "../Functional/Knapsack"
    "../SepLogicTime/SLTC_Main"
    "../Asymptotics/Asymptotics_Recurrences"
    IHT_Matrix
begin

section \<open>functional hybrid version using list of lists\<close>

definition kna' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list list \<Rightarrow> nat" where [rewrite]:
  "kna' i j W xs = (case i of
     0 \<Rightarrow> 0
   | Suc i' \<Rightarrow>
     (if j < w (Suc i')
      then \<comment> \<open>cant be added\<close>
        (xs ! i') ! j
      else \<comment> \<open>can be added\<close>
        max ((xs ! i') ! j) (v (Suc i') + ((xs ! i') ! (j - w (Suc i')))))
    )"

lemma kna'_correct:
  "i < length xs \<Longrightarrow> \<forall>ii\<le>i. length (xs!ii) = W \<Longrightarrow>
   \<forall>ii<i. \<forall>jj<W. (xs!ii)!jj = knapsack (ii,jj) \<Longrightarrow>
   j<W \<Longrightarrow> kna' i j W xs = knapsack (i,j)"
  unfolding kna'_def by (cases i) auto

fun fillrow_fun :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list list \<Rightarrow> nat list list" where
  "fillrow_fun i 0 W xs = xs"
| "fillrow_fun i (Suc j) W xs =
   (let xs' = fillrow_fun i j W xs;
        V = kna' i j W xs'
      in xs'[i:=((xs'!i)[j:=V])])"
declare fillrow_fun.simps [rewrite]

lemma fillrow_fun_length_o [rewrite]:
  "i < length xs \<Longrightarrow> length (fillrow_fun i j W xs) = length xs"
  apply (induct j arbitrary: xs i) apply auto
  by (metis length_list_update)

lemma fillrow_fun_length_i:
  "i < length xs \<Longrightarrow> length (fillrow_fun i j W xs ! ii) = length (xs ! ii)"
  apply(induct j arbitrary: xs i) apply auto
  by (metis fillrow_fun_length_o length_list_update nth_list_update)

lemma fillrow_fun_correct:
  "i < length xs \<Longrightarrow>
   \<forall>ii\<le>i. length (xs!ii) = W \<Longrightarrow>   \<comment> \<open> rows have correct length \<close>
   \<forall>ii<i. \<forall>jj<W. (xs!ii)!jj = knapsack (ii,jj) \<Longrightarrow>
   j\<le>W \<Longrightarrow> (ii<i\<and>jj<W) \<or> (ii=i\<and>jj<j) \<Longrightarrow> ((fillrow_fun i j W xs) ! ii) ! jj = knapsack (ii,jj)"
proof (induct j arbitrary: ii jj xs)
  case 0
  then show ?case by auto
next
  case (Suc j)
  let ?xs' = "fillrow_fun i j W xs"
  let ?V = "kna' i j W ?xs'"
  have V: "?V = knapsack (i,j)" apply(rule kna'_correct)
    subgoal using fillrow_fun_length_o Suc(2) by auto
    subgoal using fillrow_fun_length_i Suc(2,3) by auto
    subgoal apply safe apply (rule Suc(1)) using Suc(2-5) by auto
    subgoal using Suc(5) by auto done
  have F: "fillrow_fun i (Suc j) W xs = ?xs'[i:=((?xs'!i)[j:=?V])]"
    apply auto by metis
  show ?case
  proof(cases "ii<i")
    case True
    then show ?thesis unfolding F apply simp apply(rule Suc(1)[OF Suc(2,3,4), of ii jj])
          using Suc(5) Suc(6) by auto
  next
    case False
    with Suc(6) have I: "ii=i" "jj<Suc j" by auto
    show ?thesis
    proof(cases "jj<j")
      case True
      with I show ?thesis unfolding F using fillrow_fun_length_o Suc(2) apply auto
          using Suc(1)[OF Suc(2,3,4), of ii jj] Suc(5) by auto
    next
      case False
      with I have t: "jj=j" "ii=i" by auto
      have rw: "list_update (fillrow_fun i j W xs)
                 i (list_update (fillrow_fun i j W xs ! i) j ?V) ! i ! j
            = knapsack (i,j)" unfolding V using Suc(6) Suc(2,3,5) using fillrow_fun_length_o
        using fillrow_fun_length_i[OF Suc(2)] by auto
      show ?thesis unfolding F t rw by simp
    qed
  qed
qed

fun knapsack''_fun :: "nat \<Rightarrow> nat \<Rightarrow> nat list list \<Rightarrow> nat list list" where
  "knapsack''_fun 0 W xs = xs"
| "knapsack''_fun (Suc i) W xs =
   (let xs' = knapsack''_fun i W xs in
      fillrow_fun i W W xs')"
declare knapsack''_fun.simps [rewrite]

lemma knapsack''_fun_length_o [rewrite]:
  "i \<le> length xs \<Longrightarrow> length (knapsack''_fun i W xs) = length xs"
  apply (induct i arbitrary: xs) by (auto simp: fillrow_fun_length_o)

lemma knapsack''_fun_length_i:
  "i < length xs \<Longrightarrow> j < length xs \<Longrightarrow> length (knapsack''_fun i W xs ! j) = length (xs ! j)"
  apply(induct i arbitrary: xs j) apply (auto)
  apply(subst fillrow_fun_length_i) by (auto simp: knapsack''_fun_length_o)

lemma knapsack''_fun_correct:
  "i \<le> length xs \<Longrightarrow>
   \<forall>ii<i. length (xs!ii) = W \<Longrightarrow>  \<comment> \<open>rows have correct length\<close>
   jj<W \<Longrightarrow> ii<i \<Longrightarrow> ((knapsack''_fun i W xs) ! ii) ! jj = knapsack (ii,jj)"
proof (induct i arbitrary: xs ii jj)
  case (Suc i)
  let ?xs' = "knapsack''_fun i W xs"
  have i: "i < length ?xs'" using knapsack''_fun_length_o Suc(2) by auto
  have A: "\<forall>ii\<le>i. length (knapsack''_fun i W xs ! ii) = W"
    using Suc(2,3) knapsack''_fun_length_i by auto
  thm Suc(1)
  have B: "\<forall>ii<i. \<forall>jj<W. knapsack''_fun i W xs ! ii ! jj = knapsack (ii, jj)"
    apply safe apply(rule Suc(1)) using Suc(2-5) by auto
  thm fillrow_fun_correct[OF i A B, of W ii jj]
  show ?case apply simp
    apply(rule fillrow_fun_correct)
        apply (rule i A B)+ using Suc(4,5) by auto
qed simp

definition knapsack_full_fun :: "nat \<Rightarrow> nat \<Rightarrow> nat" where [rewrite]:
  "knapsack_full_fun i W = (let
      xs = empty_matrix (Suc i) (Suc W) (undefined::nat);
      xs' = knapsack''_fun (Suc i) (Suc W) xs
     in
       (xs' ! i) ! W
    )"

lemma knapsack_full_fun_correct:
  "knapsack_full_fun i W = knapsack (i,W)"
  unfolding knapsack_full_fun_def apply (simp del: knapsack''_fun.simps)
  apply(rule knapsack''_fun_correct) unfolding empty_matrix_def
  by (simp_all del: replicate.simps)

section \<open>functional hybrid version using list of lists\<close>

definition kna'_impl :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat matrix \<Rightarrow> nat Heap" where
  "kna'_impl i j W a = (case i of
     0 \<Rightarrow> return 0
   | Suc i' \<Rightarrow>
     (if j < w (Suc i')
      then \<comment> \<open> cant be added \<close>
        nth_matrix i' j a
      else do {  \<comment> \<open> can be added \<close>
        x \<leftarrow> nth_matrix i' j a;
        y \<leftarrow> nth_matrix i' (j - w (Suc i')) a;
        return (max x (v (Suc i') + y))
      }))"

lemma kna'_impl_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> j < n \<Longrightarrow>
   <matrix_assn n xs p * $3>
    kna'_impl i j W p
   <\<lambda>r. matrix_assn n xs p * \<up>(r = kna' i j W xs)>\<^sub>t"
@proof @cases i @qed

setup \<open>del_prfstep_thm @{thm kna'_def}\<close>

fun fillrow_impl :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat matrix \<Rightarrow> unit Heap" where
  "fillrow_impl i 0 W p = return ()"
| "fillrow_impl i (Suc j) W p = do {
     fillrow_impl i j W p;
     V \<leftarrow> kna'_impl i j W p;
     upd_matrix  i j V p
   }"

fun fill_impl_time :: "nat \<Rightarrow> nat" where
  "fill_impl_time 0 = 1"
| "fill_impl_time (Suc n) = fill_impl_time n + 5"
declare fill_impl_time.simps [rewrite]

lemma fill_impl_time_closedform: "fill_impl_time n = 1 + 5 * n"
  by (induct n) auto

lemma fill_impl_time_bound [asym_bound]:  "(\<lambda>n. fill_impl_time n) \<in> \<Theta>(\<lambda>n. n)"
  by (simp only: fill_impl_time_closedform) auto2

lemma fill_impl_rule [hoare_triple]:
  "i < length xs \<Longrightarrow> j \<le> n \<Longrightarrow>
   <matrix_assn n xs p * $(fill_impl_time j)>
    fillrow_impl i j W p
   <\<lambda>_. matrix_assn n (fillrow_fun i j W xs) p>\<^sub>t"
@proof @induct j @qed

setup \<open>fold del_prfstep_thm @{thms fill_impl_time.simps}\<close>

fun knapsack''_impl :: "nat \<Rightarrow> nat \<Rightarrow> nat matrix \<Rightarrow> unit Heap" where
  "knapsack''_impl 0 W p = return ()"
| "knapsack''_impl (Suc i) W p = do {
     knapsack''_impl i W p;
     fillrow_impl i W W p
   }"

fun knapsack''_impl_time :: "nat \<times> nat \<Rightarrow> nat" where
  "knapsack''_impl_time (0, W) = 1"
| "knapsack''_impl_time (Suc n, W) = knapsack''_impl_time (n,W) + fill_impl_time W"
declare knapsack''_impl_time.simps [rewrite]

lemma knapsack''_impl_time_bound [asym_bound]: "knapsack''_impl_time \<in> \<Theta>\<^sub>2(\<lambda>(n,m). real (n * m))"
  apply (rule bivariateTheta[where N=0])
  using fill_impl_time_bound by (auto simp: eventually_nonneg_def eventually_prod_sequentially)

lemma knapsack''_impl_rule [hoare_triple]:
  "i \<le> length xs \<Longrightarrow>
   <matrix_assn W xs p * $(knapsack''_impl_time (i,W))>
    knapsack''_impl i W p
   <\<lambda>_. matrix_assn W (knapsack''_fun i W xs) p >\<^sub>t"
@proof @induct i @qed

setup \<open>fold del_prfstep_thm @{thms knapsack''_impl_time.simps}\<close>

definition knapsack_full_impl :: "nat \<Rightarrow> nat \<Rightarrow> nat Heap" where
  "knapsack_full_impl i W = do {
     p \<leftarrow> init_matrix (Suc i) (Suc W) undefined;
     knapsack''_impl (Suc i) (Suc W) p;
     nth_matrix i W p
   }"

fun knapsack_full_impl_time :: "nat \<times> nat \<Rightarrow> nat" where
  "knapsack_full_impl_time (i,W) =
     init_matrix_time (i+1,W+1) +
     knapsack''_impl_time (i+1,W+1) + 1"
declare knapsack_full_impl_time.simps [rewrite]

lemma knapsack_full_impl_time_asym [asym_bound]:
  "knapsack_full_impl_time \<in> \<Theta>\<^sub>2(\<lambda>x. real (fst x * snd x))"
  apply (subst surjective_pairing) unfolding knapsack_full_impl_time.simps by auto2

lemma knapsack_full_impl_rule':
  "<$(knapsack_full_impl_time (i,W))>
    knapsack_full_impl i W
   <\<lambda>r. \<up>(r = knapsack_full_fun i W)>\<^sub>t" by auto2

lemma knapsack_full_impl_rule [hoare_triple]:
  "<$(knapsack_full_impl_time (i,W))>
    knapsack_full_impl i W
   <\<lambda>r. \<up>(r = OPT i W)>\<^sub>t"
  using knapsack_full_impl_rule' knapsack_full_fun_correct knapsack_correct by metis

end (* Theory *)


(* Title:      Matrix Model of Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Matrices\<close>

theory Matrix
imports "HOL-Library.Word" Dioid
begin

text \<open>In this section we formalise a perhaps more natural version of
matrices of fixed dimension ($m \times n$-matrices). It is well known
that such matrices over a Kleene algebra form a Kleene
algebra~\<^cite>\<open>"conway71regular"\<close>.\<close>

subsection \<open>Type Definition\<close>

typedef (overloaded) 'a atMost = "{..<LENGTH('a::len)}"
by auto

declare Rep_atMost_inject [simp]

lemma UNIV_atMost:
  "(UNIV::'a atMost set) = Abs_atMost ` {..<LENGTH('a::len)}"
 apply auto
 apply (rule Abs_atMost_induct)
 apply auto
done

lemma finite_UNIV_atMost [simp]: "finite (UNIV::('a::len) atMost set)"
  by (simp add: UNIV_atMost)

text \<open>Our matrix type is similar to \mbox{\<open>'a^'n^'m\<close>} from
{\em HOL/Multivariate\_Analysis/Finite\_Cartesian\_Product.thy}, but
(i)~we explicitly define a type constructor for matrices and square
matrices, and (ii)~in the definition of operations, e.g., matrix
multiplication, we impose weaker sort requirements on the element
type.\<close>

context notes [[typedef_overloaded]]
begin

datatype ('a,'m,'n) matrix = Matrix "'m atMost \<Rightarrow> 'n atMost \<Rightarrow> 'a"

datatype ('a,'m) sqmatrix = SqMatrix "'m atMost \<Rightarrow> 'm atMost \<Rightarrow> 'a"

end

fun sqmatrix_of_matrix where
  "sqmatrix_of_matrix (Matrix A) = SqMatrix A"

fun matrix_of_sqmatrix where
  "matrix_of_sqmatrix (SqMatrix A) = Matrix A"

subsection \<open>0 and 1\<close>

instantiation matrix :: (zero,type,type) zero
begin
  definition zero_matrix_def: "0 \<equiv> Matrix (\<lambda>i j. 0)"
  instance ..
end

instantiation sqmatrix :: (zero,type) zero
begin
  definition zero_sqmatrix_def: "0 \<equiv> SqMatrix (\<lambda>i j. 0)"
  instance ..
end

text \<open>Tricky sort issues: compare @{term one_matrix} with @{term
one_sqmatrix} \dots\<close>

instantiation matrix :: ("{zero,one}",len,len) one
begin
  definition one_matrix_def:
    "1 \<equiv> Matrix (\<lambda>i j. if Rep_atMost i = Rep_atMost j then 1 else 0)"
  instance ..
end

instantiation sqmatrix :: ("{zero,one}",type) one
begin
  definition one_sqmatrix_def:
    "1 \<equiv> SqMatrix (\<lambda>i j. if i = j then 1 else 0)"
  instance ..
end

subsection \<open>Matrix Addition\<close>

fun matrix_plus where
  "matrix_plus (Matrix A) (Matrix B) = Matrix (\<lambda>i j. A i j + B i j)"

instantiation matrix :: (plus,type,type) plus
begin
  definition plus_matrix_def: "A + B \<equiv> matrix_plus A B"
  instance ..
end

lemma plus_matrix_def' [simp]:
  "Matrix A + Matrix B = Matrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_matrix_def)

instantiation sqmatrix :: (plus,type) plus
begin
  definition plus_sqmatrix_def:
    "A + B \<equiv> sqmatrix_of_matrix (matrix_of_sqmatrix A + matrix_of_sqmatrix B)"
  instance ..
end

lemma plus_sqmatrix_def' [simp]:
  "SqMatrix A + SqMatrix B = SqMatrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_sqmatrix_def)

lemma matrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma matrix_add_assoc:
  "(A::('a::semigroup_add,'m,'n) matrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma matrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + (B + C) = B + (A + C)"
  by (metis matrix_add_assoc matrix_add_commute)

lemma sqmatrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma sqmatrix_add_assoc:
  "(A::('a::semigroup_add,'m) sqmatrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma sqmatrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + (B + C) = B + (A + C)"
  by (metis sqmatrix_add_commute sqmatrix_add_assoc)

subsection \<open>Order (via Addition)\<close>

instantiation matrix :: (plus,type,type) plus_ord
begin
  definition less_eq_matrix_def:
    "(A::('a, 'b, 'c) matrix) \<le> B \<equiv> A + B = B"
  definition less_matrix_def:
    "(A::('a, 'b, 'c) matrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b, 'c) matrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_matrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_matrix_def)
  qed
end

instantiation sqmatrix :: (plus,type) plus_ord
begin
  definition less_eq_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) \<le> B \<equiv> A + B = B"
  definition less_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b) sqmatrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_sqmatrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_sqmatrix_def)
  qed
end

subsection \<open>Matrix Multiplication\<close>

fun matrix_times :: "('a::{comm_monoid_add,times},'m,'k) matrix \<Rightarrow> ('a,'k,'n) matrix \<Rightarrow> ('a,'m,'n) matrix" where
  "matrix_times (Matrix A) (Matrix B) = Matrix (\<lambda>i j. sum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"

notation matrix_times (infixl "*\<^sub>M" 70)

instantiation sqmatrix :: ("{comm_monoid_add,times}",type) times
begin
  definition times_sqmatrix_def:
    "A * B = sqmatrix_of_matrix (matrix_of_sqmatrix A *\<^sub>M matrix_of_sqmatrix B)"
  instance ..
end

lemma times_sqmatrix_def' [simp]:
  "SqMatrix A * SqMatrix B = SqMatrix (\<lambda>i j. sum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"
  by (simp add: times_sqmatrix_def)

lemma matrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) *\<^sub>M 0 = 0"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_mult_0_left [simp]:
  "0 *\<^sub>M (A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) = 0"
  by (cases A, simp add: zero_matrix_def)

lemma sum_delta_r_0 [simp]:
  "\<lbrakk> finite S; j \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = 0"
  by (induct S rule: finite_induct, auto)

lemma sum_delta_r_1 [simp]:
  "\<lbrakk> finite S; j \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = f j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) *\<^sub>M 1 = A"
  by (cases A, simp add: one_matrix_def)

lemma sum_delta_l_0 [simp]:
  "\<lbrakk> finite S; i \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = 0"
  by (induct S rule: finite_induct, auto)

lemma sum_delta_l_1 [simp]:
  "\<lbrakk> finite S; i \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = f i j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_left [simp]:
  "1 *\<^sub>M (A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) = A"
  by (cases A, simp add: one_matrix_def)

lemma matrix_mult_assoc:
  "(A::('a::semiring_0,'m,'n) matrix) *\<^sub>M B *\<^sub>M C = A *\<^sub>M (B *\<^sub>M C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: sum_distrib_right sum_distrib_left mult.assoc)
 apply (subst sum.swap)
 apply (rule refl)
done

lemma matrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) *\<^sub>M (B + C) = A *\<^sub>M B + A *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_left sum.distrib)

lemma matrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) + B) *\<^sub>M C = A *\<^sub>M C + B *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_right sum.distrib)

lemma sqmatrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) * 0 = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_0_left [simp]:
  "0 * (A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) * 1 = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_1_left [simp]:
  "1 * (A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_assoc:
  "(A::('a::{semiring_0,monoid_mult},'m) sqmatrix) * B * C = A * (B * C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: sum_distrib_right sum_distrib_left mult.assoc)
 apply (subst sum.swap)
 apply (rule refl)
done

lemma sqmatrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) * (B + C) = A * B + A * C"
  by (cases A, cases B, cases C, simp add: distrib_left sum.distrib)

lemma sqmatrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) + B) * C = A * C + B * C"
  by (cases A, cases B, cases C, simp add: distrib_right sum.distrib)

subsection \<open>Square-Matrix Model of Dioids\<close>

text \<open>The following subclass proofs are necessary to connect parts
of our algebraic hierarchy to the hierarchy found in the Isabelle/HOL
library.\<close>

subclass (in ab_near_semiring_one_zerol) comm_monoid_add
proof
  fix a :: 'a
  show "0 + a = a"
    by (fact add_zerol)
qed

subclass (in semiring_one_zero) semiring_0
proof
  fix a :: 'a
  show "0 * a = 0"
    by (fact annil)
  show "a * 0 = 0"
    by (fact annir)
qed

subclass (in ab_near_semiring_one) monoid_mult ..

instantiation sqmatrix :: (dioid_one_zero,len) dioid_one_zero
begin
  instance
  proof
    fix A B C :: "('a, 'b) sqmatrix"
    show "A + B + C = A + (B + C)"
      by (fact sqmatrix_add_assoc)
    show "A + B = B + A"
      by (fact sqmatrix_add_commute)
    show "A * B * C = A * (B * C)"
      by (fact sqmatrix_mult_assoc)
    show "(A + B) * C = A * C + B * C"
      by (fact sqmatrix_mult_distrib_right)
    show "1 * A = A"
      by (fact sqmatrix_mult_1_left)
    show "A * 1 = A"
      by (fact sqmatrix_mult_1_right)
    show "0 + A = A"
      by (fact sqmatrix_add_0_left)
    show "0 * A = 0"
      by (fact sqmatrix_mult_0_left)
    show "A * 0 = 0"
      by (fact sqmatrix_mult_0_right)
    show "A + A = A"
      by (cases A, simp)
    show "A * (B + C) = A * B + A * C"
      by (fact sqmatrix_mult_distrib_left)
  qed
end

subsection \<open>Kleene Star for Matrices\<close>

text \<open>We currently do not implement the Kleene star of matrices,
since this is complicated.\<close>

end


(*
  File:     Nearest_Neighbors.thy
  Author:   Martin Rau, TU München
*)

section \<open>Nearest Neighbor Search on the \<open>k\<close>-d Tree\<close>

theory Nearest_Neighbors
imports
  KDTree
begin

text \<open>
  Verifying nearest neighbor search on the k-d tree. Given a \<open>k\<close>-d tree and a point \<open>p\<close>,
  which might not be in the tree, find the points \<open>ps\<close> that are closest to \<open>p\<close> using the
  Euclidean metric.
\<close>

subsection \<open>Auxiliary Lemmas about \<open>sorted_wrt\<close>\<close>

lemma
  assumes "sorted_wrt f xs"
  shows sorted_wrt_take: "sorted_wrt f (take n xs)"
  and sorted_wrt_drop: "sorted_wrt f (drop n xs)"
proof -
  have "sorted_wrt f (take n xs @ drop n xs)"
    using assms by simp
  thus "sorted_wrt f (take n xs)" "sorted_wrt f (drop n xs)"
    using sorted_wrt_append by blast+
qed

definition sorted_wrt_dist :: "('k::finite) point \<Rightarrow> 'k point list \<Rightarrow> bool" where
  "sorted_wrt_dist p \<equiv> sorted_wrt (\<lambda>p\<^sub>0 p\<^sub>1. dist p\<^sub>0 p \<le> dist p\<^sub>1 p)"

lemma sorted_wrt_dist_insort_key:
  "sorted_wrt_dist p ps \<Longrightarrow> sorted_wrt_dist p (insort_key (\<lambda>q. dist q p) q ps)"
  by (induction ps) (auto simp: sorted_wrt_dist_def set_insort_key)

lemma sorted_wrt_dist_take_drop:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>p\<^sub>0 \<in> set (take n ps). \<forall>p\<^sub>1 \<in> set (drop n ps). dist p\<^sub>0 p \<le> dist p\<^sub>1 p"
  using assms sorted_wrt_append[of _ "take n ps" "drop n ps"] by (simp add: sorted_wrt_dist_def)

lemma sorted_wrt_dist_last_take_mono:
  assumes "sorted_wrt_dist p ps" "n \<le> length ps" "0 < n"
  shows "dist (last (take n ps)) p \<le> dist (last ps) p"
  using assms unfolding sorted_wrt_dist_def by (induction ps arbitrary: n) (auto simp add: take_Cons')

lemma sorted_wrt_dist_last_insort_key_eq:
  assumes "sorted_wrt_dist p ps" "insort_key (\<lambda>q. dist q p) q ps \<noteq> ps @ [q]"
  shows "last (insort_key (\<lambda>q. dist q p) q ps) = last ps"
  using assms unfolding sorted_wrt_dist_def by (induction ps) (auto)

lemma sorted_wrt_dist_last:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>q \<in> set ps. dist q p \<le> dist (last ps) p"
proof (cases "ps = []")
  case True
  thus ?thesis by simp
next
  case False
  then obtain ps' p' where [simp]:"ps = ps' @ [p']"
    using rev_exhaust by blast
  hence "sorted_wrt_dist p (ps' @ [p'])"
    using assms by blast
  thus ?thesis
    unfolding sorted_wrt_dist_def using sorted_wrt_append[of _ ps' "[p']"] by simp
qed

subsection \<open>Neighbors Sorted wrt. Distance\<close>

definition upd_nbors :: "nat \<Rightarrow> ('k::finite) point \<Rightarrow> 'k point \<Rightarrow> 'k point list \<Rightarrow> 'k point list" where
  "upd_nbors n p q ps = take n (insort_key (\<lambda>q. dist q p) q ps)"

lemma sorted_wrt_dist_nbors:
  assumes "sorted_wrt_dist p ps"
  shows "sorted_wrt_dist p (upd_nbors n p q ps)"
proof -
  have "sorted_wrt_dist p (insort_key (\<lambda>q. dist q p) q ps)"
    using assms sorted_wrt_dist_insort_key by blast
  thus ?thesis
    by (simp add: sorted_wrt_dist_def sorted_wrt_take upd_nbors_def)
qed

lemma sorted_wrt_dist_nbors_diff:
  assumes "sorted_wrt_dist p ps"
  shows "\<forall>r \<in> set ps \<union> {q} - set (upd_nbors n p q ps). \<forall>s \<in> set (upd_nbors n p q ps). dist s p \<le> dist r p"
proof -
  let ?ps' = "insort_key (\<lambda>q. dist q p) q ps"
  have "set ps \<union> { q } = set ?ps'"
    by (simp add: set_insort_key)
  moreover have "set ?ps' = set (take n ?ps') \<union> set (drop n ?ps')"
    using append_take_drop_id set_append by metis
  ultimately have "set ps \<union> { q } - set (take n ?ps') \<subseteq> set (drop n ?ps')"
    by blast
  moreover have "sorted_wrt_dist p ?ps'"
    using assms sorted_wrt_dist_insort_key by blast
  ultimately show ?thesis
    unfolding upd_nbors_def using sorted_wrt_dist_take_drop by blast
qed

lemma sorted_wrt_dist_last_upd_nbors_mono:
  assumes "sorted_wrt_dist p ps" "n \<le> length ps" "0 < n"
  shows "dist (last (upd_nbors n p q ps)) p \<le> dist (last ps) p"
proof (cases "insort_key (\<lambda>q. dist q p) q ps = ps @ [q]")
  case True
  thus ?thesis
    unfolding upd_nbors_def using assms sorted_wrt_dist_last_take_mono by auto
next
  case False
  hence "last (insort_key (\<lambda>q. dist q p) q ps) = last ps"
    using sorted_wrt_dist_last_insort_key_eq assms by blast
  moreover have "dist (last (upd_nbors  n p q ps)) p \<le> dist (last (insort_key (\<lambda>q. dist q p) q ps)) p"
    unfolding upd_nbors_def using assms sorted_wrt_dist_last_take_mono[of p "insort_key (\<lambda>q. dist q p) q ps"]
    by (simp add: sorted_wrt_dist_insort_key)
  ultimately show ?thesis
    by simp
qed

subsection \<open>The Recursive Nearest Neighbor Algorithm\<close>

fun nearest_nbors :: "nat \<Rightarrow> ('k::finite) point list \<Rightarrow> 'k point \<Rightarrow> 'k kdt \<Rightarrow> 'k point list" where
  "nearest_nbors n ps p (Leaf q) = upd_nbors n p q ps"
| "nearest_nbors n ps p (Node k v l r) = (
    if p$k \<le> v then
      let candidates = nearest_nbors n ps p l in
      if length candidates = n \<and> dist p (last candidates) \<le> dist v (p$k) then
        candidates
      else
        nearest_nbors n candidates p r
    else
      let candidates = nearest_nbors n ps p r in
      if length candidates = n \<and> dist p (last candidates) \<le> dist v (p$k) then
        candidates
      else
        nearest_nbors n candidates p l
  )"

subsection \<open>Auxiliary Lemmas\<close>

lemma cutoff_r:
  assumes "invar (Node k v l r)"
  assumes "p$k \<le> v" "dist p c \<le> dist (p$k) v"
  shows "\<forall>q \<in> set_kdt r. dist p c \<le> dist p q"
proof standard
  fix q
  assume *: "q \<in> set_kdt r"
  have "dist p c \<le> dist (p$k) v"
    using assms(3) by blast
  also have "... \<le> dist (p$k) v + dist v (q$k)"
    by simp
  also have "... = dist (p$k) (q$k)"
    using * assms(1,2) dist_real_def by auto
  also have "... \<le> dist p q"
    using dist_vec_nth_le by blast
  finally show "dist p c \<le> dist p q" .
qed

lemma cutoff_l:
  assumes "invar (Node k v l r)"
  assumes "v \<le> p$k" "dist p c \<le> dist v (p$k)"
  shows "\<forall>q \<in> set_kdt l. dist p c \<le> dist p q"
proof standard
  fix q
  assume *: "q \<in> set_kdt l"
  have "dist p c \<le> dist v (p$k)"
    using assms(3) by blast
  also have "... \<le> dist v (p$k) + dist (q$k) v"
    by simp
  also have "... = dist (p$k) (q$k)"
    using * assms(1,2) dist_real_def by auto
  also have "... \<le> dist p q"
    using dist_vec_nth_le by blast
  finally show "dist p c \<le> dist p q" .
qed

subsection \<open>The Main Theorems\<close>

lemma set_nns:
  "set (nearest_nbors n ps p kdt) \<subseteq> set_kdt kdt \<union> set ps"
  apply (induction kdt arbitrary: ps)
  apply (auto simp: Let_def upd_nbors_def set_insort_key)
  using in_set_takeD set_insort_key by fastforce

lemma length_nns:
  "length (nearest_nbors n ps p kdt) = min n (size_kdt kdt + length ps)"
  by (induction kdt arbitrary: ps) (auto simp: Let_def upd_nbors_def)

lemma length_nns_gt_0:
  "0 < n \<Longrightarrow> 0 < length (nearest_nbors n ps p kdt)"
  by (induction kdt arbitrary: ps) (auto simp: Let_def upd_nbors_def)

lemma length_nns_n:
  assumes "(set_kdt kdt \<union> set ps) - set (nearest_nbors n ps p kdt) \<noteq> {}"
  shows "length (nearest_nbors n ps p kdt) = n"
  using assms
proof (induction kdt arbitrary: ps)
  case (Node k v l r)
  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"
  consider (A) "p$k \<le> v \<and> length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k)"
         | (B) "p$k \<le> v \<and> \<not>(length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k))"
         | (C) "v < p$k \<and> length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k)"
         | (D) "v < p$k \<and> \<not>(length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k))"
    by argo
  thus ?case
  proof cases
    case B
    let ?nns = "nearest_nbors n ?nnsl p r"
    have "length ?nnsl \<noteq> n \<longrightarrow> (set_kdt l \<union> set ps - set (nearest_nbors n ps p l) = {})"
      using Node.IH(1) by blast
    hence "length ?nnsl \<noteq> n \<longrightarrow> (set_kdt r \<union> set ?nnsl - set ?nns \<noteq> {})"
      using B Node.prems by auto
    moreover have "length ?nnsl = n \<longrightarrow> ?thesis"
      using B by (auto simp: length_nns)
    ultimately show ?thesis
      using B Node.IH(2) by force
  next
    case D
    let ?nns = "nearest_nbors n ?nnsr p l"
    have "length ?nnsr \<noteq> n \<longrightarrow> (set_kdt r \<union> set ps - set (nearest_nbors n ps p r) = {})"
      using Node.IH(2) by blast
    hence "length ?nnsr \<noteq> n \<longrightarrow> (set_kdt l \<union> set ?nnsr - set ?nns \<noteq> {})"
      using D Node.prems by auto
    moreover have "length ?nnsr = n \<longrightarrow> ?thesis"
      using D by (auto simp: length_nns)
    ultimately show ?thesis
      using D Node.IH(1) by force
  qed auto
qed (auto simp: upd_nbors_def min_def set_insort_key)

lemma sorted_nns:
  "sorted_wrt_dist p ps \<Longrightarrow> sorted_wrt_dist p (nearest_nbors n ps p kdt)"
  using sorted_wrt_dist_nbors by (induction kdt arbitrary: ps) (auto simp: Let_def)

lemma distinct_nns:
  assumes "invar kdt" "distinct ps" "set ps \<inter> set_kdt kdt = {}"
  shows "distinct (nearest_nbors n ps p kdt)"
  using assms
proof (induction kdt arbitrary: ps)
  case (Node k v l r)
  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"
  have "set ps \<inter> set_kdt l = {}" "set ps \<inter> set_kdt r = {}"
    using Node.prems(3) by auto
  hence DCLR: "distinct ?nnsl" "distinct ?nnsr"
    using Node invar_l invar_r by blast+
  have "set ?nnsl \<inter> set_kdt r = {}" "set ?nnsr \<inter> set_kdt l = {}"
    using Node.prems(1,3) set_nns by fastforce+
  hence "distinct (nearest_nbors n ?nnsl p r)" "distinct (nearest_nbors n ?nnsr p l)"
    using Node.IH(1,2) Node.prems(1,2) DCLR invar_l invar_r by blast+
  thus ?case
    using DCLR by (auto simp add: Let_def)
qed (auto simp: upd_nbors_def distinct_insort)

theorem dist_nns:
  assumes "invar kdt" "sorted_wrt_dist p ps" "set ps \<inter> set_kdt kdt = {}" "distinct ps" "0 < n"
  shows "\<forall>q \<in> set_kdt kdt \<union> set ps - set (nearest_nbors n ps p kdt). dist (last (nearest_nbors n ps p kdt)) p \<le> dist q p"
  using assms
proof (induction kdt arbitrary: ps)
  case (Node k v l r)

  let ?nnsl = "nearest_nbors n ps p l"
  let ?nnsr = "nearest_nbors n ps p r"

  have IHL: "\<forall>q \<in> set_kdt l \<union> set ps - set ?nnsl. dist (last ?nnsl) p \<le> dist q p"
    using Node.IH(1) Node.prems invar_l invar_set by auto
  have IHR: "\<forall>q \<in> set_kdt r \<union> set ps - set ?nnsr. dist (last ?nnsr) p \<le> dist q p"
    using Node.IH(2) Node.prems invar_r invar_set by auto

  have SORTED_L: "sorted_wrt_dist p ?nnsl"
    using sorted_nns Node.prems(2) by blast
  have SORTED_R: "sorted_wrt_dist p ?nnsr"
    using sorted_nns Node.prems(2) by blast

  have DISTINCT_L: "distinct ?nnsl"
    using Node.prems distinct_nns invar_set invar_l by fastforce
  have DISTINCT_R: "distinct ?nnsr"
    using Node.prems distinct_nns invar_set invar_r
    by (metis inf_bot_right inf_sup_absorb inf_sup_aci(3) sup.commute)

  consider (A) "p$k \<le> v \<and> length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k)"
         | (B) "p$k \<le> v \<and> \<not>(length ?nnsl = n \<and> dist p (last ?nnsl) \<le> dist v (p$k))"
         | (C) "v < p$k \<and> length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k)"
         | (D) "v < p$k \<and> \<not>(length ?nnsr = n \<and> dist p (last ?nnsr) \<le> dist v (p$k))"
    by argo
  thus ?case
  proof cases
    case A
    hence "\<forall>q \<in> set_kdt r. dist (last ?nnsl) p \<le> dist q p"
      using Node.prems(1,2) cutoff_r by (metis dist_commute)
    thus ?thesis
      using IHL A by auto
  next
    case B

    let ?nns = "nearest_nbors n ?nnsl p r"

    have "set ?nnsl \<subseteq> set_kdt l \<union> set ps" "set ps \<inter> set_kdt r = {}"
      using set_nns Node.prems(1,3) by (simp add: set_nns disjoint_iff_not_equal)+
    hence "set ?nnsl \<inter> set_kdt r = {}"
      using Node.prems(1) by fastforce
    hence IHLR: "\<forall>q \<in> set_kdt r \<union> set ?nnsl - set ?nns. dist (last ?nns) p \<le> dist q p"
      using Node.IH(2)[OF _ SORTED_L _ DISTINCT_L Node.prems(5)] Node.prems(1) invar_r by blast

    have "\<forall>q \<in> set ps - set ?nnsl. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set ps - set ?nnsl"

      hence "length ?nnsl = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsl) p"
        using last_nns_mono SORTED_L invar_r Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsl) p \<le> dist q p"
        using IHL * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence R: "\<forall>q \<in> set_kdt r \<union> set ps - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHLR by auto

    have "\<forall>q \<in> set_kdt l - set ?nnsl. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set_kdt l - set ?nnsl"

      hence "length ?nnsl = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsl) p"
        using last_nns_mono SORTED_L invar_r Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsl) p \<le> dist q p"
        using IHL * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence L: "\<forall>q \<in> set_kdt l - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHLR by blast

    show ?thesis
      using B R L by auto
  next
    case C
    hence "\<forall>q \<in> set_kdt l. dist (last ?nnsr) p \<le> dist q p"
      using Node.prems(1,2) cutoff_l by (metis dist_commute less_imp_le)
    thus ?thesis
      using IHR C by auto
  next
    case D

    let ?nns = "nearest_nbors n ?nnsr p l"

    have "set ?nnsr \<subseteq> set_kdt r \<union> set ps" "set ps \<inter> set_kdt l = {}"
      using set_nns Node.prems(1,3) by (simp add: set_nns disjoint_iff_not_equal)+
    hence "set ?nnsr \<inter> set_kdt l = {}"
      using Node.prems(1) by fastforce
    hence IHRL: "\<forall>q \<in> set_kdt l \<union> set ?nnsr - set ?nns. dist (last ?nns) p \<le> dist q p"
      using Node.IH(1)[OF _ SORTED_R _ DISTINCT_R Node.prems(5)] Node.prems(1) invar_l by blast

    have "\<forall>q \<in> set ps - set ?nnsr. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set ps - set ?nnsr"

      hence "length ?nnsr = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsr) p"
        using last_nns_mono SORTED_R invar_l Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsr) p \<le> dist q p"
        using IHR * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence R: "\<forall>q \<in> set_kdt l \<union> set ps - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHRL by auto

    have "\<forall>q \<in> set_kdt r - set ?nnsr. dist (last ?nns) p \<le> dist q p"
    proof standard
      fix q
      assume *: "q \<in> set_kdt r - set ?nnsr"

      hence "length ?nnsr = n"
        using length_nns_n by blast
      hence LAST: "dist (last ?nns) p \<le> dist (last ?nnsr) p"
        using last_nns_mono SORTED_R invar_l Node.prems(1,2,5) by (metis order_refl)
      have "dist (last ?nnsr) p \<le> dist q p"
        using IHR * by blast
      thus "dist (last ?nns) p \<le> dist q p"
        using LAST by argo
    qed
    hence L: "\<forall>q \<in> set_kdt r - set ?nns. dist (last ?nns) p \<le> dist q p"
      using IHRL by blast

    show ?thesis
      using D R L by auto
  qed
qed (auto simp: sorted_wrt_dist_nbors_diff upd_nbors_def)

subsection \<open>Nearest Neighbors Definition and Theorems\<close>

definition nearest_neighbors :: "nat \<Rightarrow> ('k::finite) point \<Rightarrow> 'k kdt \<Rightarrow> 'k point list" where
  "nearest_neighbors n p kdt = nearest_nbors n [] p kdt"

theorem length_nearest_neighbors:
  "length (nearest_neighbors n p kdt) = min n (size_kdt kdt)"
  by (simp add: length_nns nearest_neighbors_def)

theorem sorted_wrt_dist_nearest_neighbors:
  "sorted_wrt_dist p (nearest_neighbors n p kdt)"
  using sorted_nns unfolding nearest_neighbors_def sorted_wrt_dist_def by force

theorem distinct_nearest_neighbors:
  assumes "invar kdt"
  shows "distinct (nearest_neighbors n p kdt)"
  using assms by (simp add: distinct_nns nearest_neighbors_def)

theorem dist_nearest_neighbors:
  assumes "invar kdt" "nns = nearest_neighbors n p kdt"
  shows "\<forall>q \<in> (set_kdt kdt - set nns). \<forall>r \<in> set nns. dist r p \<le> dist q p"
proof (cases "0 < n")
  case True
  have "\<forall>q \<in> set_kdt kdt - set nns. dist (last nns) p \<le> dist q p"
    using nearest_neighbors_def dist_nns[OF assms(1), of p "[]", OF _ _ _ True] assms(2)
    by (simp add: nearest_neighbors_def sorted_wrt_dist_def)
  hence "\<forall>q \<in> set_kdt kdt - set nns. \<forall>n \<in> set nns. dist n p \<le> dist q p"
    using assms(2) sorted_wrt_dist_nearest_neighbors[of p n kdt] sorted_wrt_dist_last[of p nns] by force
  thus ?thesis
    using nearest_neighbors_def by blast
next
  case False
  hence "length nns = 0"
    using assms(2) unfolding nearest_neighbors_def by (auto simp: length_nns)
  thus ?thesis
    by simp
qed

end