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

section\<open>Matrices as nested IArrays\<close>

theory Matrix_To_IArray_QR
imports
  Rank_Nullity_Theorem.Mod_Type
  Gauss_Jordan.Elementary_Operations
  IArray_Addenda_QR
begin

text\<open>The file is similar to the \<open>Matrix_To_IArray.thy\<close> one, presented in the Gauss-Jordan
algorithm. But now, some proofs have changed slightly because of the new instantiations presented
in the file \<open>IArray_Addenda_QR.thy\<close>.\<close>

subsection\<open>Isomorphism between matrices implemented by vecs and matrices implemented by iarrays\<close>

subsubsection\<open>Isomorphism between vec and iarray\<close>

definition vec_to_iarray :: "'a^'n::{mod_type} \<Rightarrow> 'a iarray"
  where "vec_to_iarray A = IArray.of_fun (\<lambda>i. A $ (from_nat i)) (CARD('n))"

definition iarray_to_vec :: "'a iarray \<Rightarrow> 'a^'n::{mod_type}"
  where "iarray_to_vec A = (\<chi> i. A !! (to_nat i))"

  (*
  definition iarray_to_vec_option :: "'a iarray \<Rightarrow> ('a^'n::{mod_type}) option"
  where "iarray_to_vec_option A = (if (IArray.length A) = CARD('n)
  then Some (\<chi> i::'n. A!!(to_nat i))
  else None)"
  *)

lemma vec_to_iarray_nth:
  fixes A::"'a^'n::{finite, mod_type}"
  assumes i: "i<CARD('n)"
  shows "(vec_to_iarray A) !! i = A $ (from_nat i)"
  unfolding vec_to_iarray_def using of_fun_nth[OF i] .

lemma vec_to_iarray_nth':
  fixes A::"'a^'n::{mod_type}"
  shows "(vec_to_iarray A) !! (to_nat i) = A $ i"
proof -
  have to_nat_less_card: "to_nat i<CARD('n)"
    using bij_to_nat[where ?'a='n] unfolding bij_betw_def by fastforce
  show ?thesis
    unfolding vec_to_iarray_def unfolding of_fun_nth[OF to_nat_less_card] from_nat_to_nat_id ..
qed

lemma iarray_to_vec_nth:
  shows "(iarray_to_vec A) $ i = A !! (to_nat i)"
  unfolding iarray_to_vec_def by simp

lemma vec_to_iarray_morph:
  fixes A::"'a^'n::{mod_type}"
  shows "(A = B) = (vec_to_iarray A = vec_to_iarray B)"
  by (metis vec_eq_iff vec_to_iarray_nth')

lemma inj_vec_to_iarray:
  shows "inj vec_to_iarray"
  using vec_to_iarray_morph unfolding inj_on_def by blast

lemma iarray_to_vec_vec_to_iarray:
  fixes A::"'a^'n::{mod_type}"
  shows "iarray_to_vec (vec_to_iarray A)=A"
proof (unfold vec_to_iarray_def iarray_to_vec_def, vector, auto)
  fix i::'n
  have "to_nat i<CARD('n)" using bij_to_nat[where ?'a='n] unfolding bij_betw_def by auto
  thus "map (\<lambda>i. A $ from_nat i) [0..<CARD('n)] ! to_nat i = A $ i" by simp
qed

lemma vec_to_iarray_iarray_to_vec:
  assumes length_eq: "IArray.length A = CARD('n::{mod_type})"
  shows "vec_to_iarray (iarray_to_vec A::'a^'n::{mod_type}) = A"
proof (unfold vec_to_iarray_def iarray_to_vec_def, vector, auto)
  obtain xs where xs: "A = IArray xs" by (metis iarray.exhaust)
  show "IArray (map (\<lambda>i. IArray.list_of A ! to_nat (from_nat i::'n)) [0..<CARD('n)]) = A"
  proof(unfold xs iarray.inject list_eq_iff_nth_eq, auto)
    show "CARD('n) = length xs" using length_eq unfolding xs by simp
    fix i assume i: "i < CARD('n)"
    show "xs ! to_nat (from_nat i::'n) = xs ! i" unfolding to_nat_from_nat_id[OF i] ..
  qed
qed

lemma length_vec_to_iarray:
  fixes xa::"'a^'n::{mod_type}"
  shows "IArray.length (vec_to_iarray xa) = CARD('n)"
  unfolding vec_to_iarray_def by simp

subsubsection\<open>Isomorphism between matrix and nested iarrays\<close>

definition matrix_to_iarray :: "'a^'n::{mod_type}^'m::{mod_type} => 'a iarray iarray"
  where "matrix_to_iarray A = IArray (map (vec_to_iarray \<circ> (($) A) \<circ> (from_nat::nat=>'m)) [0..<CARD('m)])"

definition iarray_to_matrix :: "'a iarray iarray \<Rightarrow> 'a^'n::{mod_type}^'m::{mod_type}"
  where "iarray_to_matrix A = (\<chi> i j. A !! (to_nat i) !! (to_nat j))"

lemma matrix_to_iarray_morph:
  fixes A::"'a^'n::{mod_type}^'m::{mod_type}"
  shows "(A = B) = (matrix_to_iarray A = matrix_to_iarray B)"
  unfolding matrix_to_iarray_def apply simp
  unfolding forall_from_nat_rw[of "\<lambda>x. vec_to_iarray (A $ x) = vec_to_iarray (B $ x)"]
  by (metis from_nat_to_nat_id vec_eq_iff vec_to_iarray_morph)

lemma matrix_to_iarray_eq_of_fun:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  assumes vec_eq_f: "\<forall>i. vec_to_iarray (A $ i) = f (to_nat i)"
  and n_eq_length: "n=IArray.length (matrix_to_iarray A)"
  shows "matrix_to_iarray A = IArray.of_fun f n"
proof (unfold IArray.of_fun_def matrix_to_iarray_def iarray.inject list_eq_iff_nth_eq, auto)
  show *: "CARD('rows) = n" using n_eq_length unfolding matrix_to_iarray_def by auto
  fix i assume i: "i < CARD('rows)"
  hence i_less_n: "i<n" using * i by simp
  show "vec_to_iarray (A $ from_nat i) = map f [0..<n] ! i"
    using vec_eq_f  using i_less_n
    by (simp, unfold to_nat_from_nat_id[OF i], simp)
qed

lemma map_vec_to_iarray_rw[simp]:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<CARD('rows)] ! to_nat i = vec_to_iarray (A $ i)"
proof -
  have i_less_card: "to_nat i < CARD('rows)"
    using bij_to_nat[where ?'a='rows] unfolding bij_betw_def by fastforce
  hence "map (\<lambda>x. vec_to_iarray (A $ from_nat x)) [0..<CARD('rows)] ! to_nat i
    = vec_to_iarray (A $ from_nat (to_nat i))" by simp
  also have "... =  vec_to_iarray (A $ i)" unfolding from_nat_to_nat_id ..
  finally show ?thesis .
qed

lemma matrix_to_iarray_nth:
  "matrix_to_iarray A !! to_nat i !! to_nat j = A $ i $ j"
  unfolding matrix_to_iarray_def o_def using vec_to_iarray_nth' by auto

lemma vec_matrix: "vec_to_iarray (A$i) = (matrix_to_iarray A) !! (to_nat i)"
  unfolding matrix_to_iarray_def o_def by fastforce

lemma iarray_to_matrix_matrix_to_iarray:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "iarray_to_matrix (matrix_to_iarray A) = A"
  unfolding matrix_to_iarray_def iarray_to_matrix_def o_def
  by (vector, auto, metis IArray.sub_def vec_to_iarray_nth')

subsection\<open>Definition of operations over matrices implemented by iarrays\<close>

definition mult_iarray :: "'a::{times} iarray => 'a => 'a iarray"
  where "mult_iarray A q = IArray.of_fun (\<lambda>n. q * A!!n) (IArray.length A)"

definition row_iarray :: "nat => 'a iarray iarray => 'a iarray"
  where "row_iarray k A = A !! k"

definition column_iarray :: "nat => 'a iarray iarray  => 'a iarray"
  where "column_iarray k A = IArray.of_fun (\<lambda>m. A !! m !! k) (IArray.length A)"

definition nrows_iarray :: "'a iarray iarray => nat"
  where "nrows_iarray A = IArray.length A"

definition ncols_iarray :: "'a iarray iarray => nat"
  where "ncols_iarray A = IArray.length (A!!0)"

definition "rows_iarray A = {row_iarray i A | i. i \<in> {..<nrows_iarray A}}"
definition "columns_iarray A = {column_iarray i A | i. i \<in> {..<ncols_iarray A}}"

definition tabulate2 :: "nat => nat => (nat => nat => 'a) => 'a iarray iarray"
  where "tabulate2 m n f = IArray.of_fun (\<lambda>i. IArray.of_fun (f i) n) m"

definition transpose_iarray :: "'a iarray iarray => 'a iarray iarray"
  where "transpose_iarray A =  tabulate2 (ncols_iarray A) (nrows_iarray A) (\<lambda>a b. A!!b!!a)"

definition matrix_matrix_mult_iarray :: "'a::{times, comm_monoid_add} iarray iarray => 'a iarray iarray => 'a iarray iarray"  (infixl "**i" 70)
  where "A **i B = tabulate2 (nrows_iarray A) (ncols_iarray B) (\<lambda>i j. sum (\<lambda>k. ((A!!i)!!k) * ((B!!k)!!j)) {0..<ncols_iarray A})"

definition matrix_vector_mult_iarray :: "'a::{semiring_1} iarray iarray => 'a iarray => 'a iarray" (infixl "*iv" 70)
  where "A *iv x = IArray.of_fun (\<lambda>i. sum (\<lambda>j. ((A!!i)!!j) * (x!!j)) {0..<IArray.length x}) (nrows_iarray A)"

definition vector_matrix_mult_iarray :: "'a::{semiring_1} iarray => 'a iarray iarray => 'a iarray" (infixl "v*i" 70)
  where "x v*i A = IArray.of_fun (\<lambda>j. sum (\<lambda>i. ((A!!i)!!j) * (x!!i)) {0..<IArray.length x}) (ncols_iarray A)"

definition mat_iarray :: "'a::{zero} => nat => 'a iarray iarray"
  where "mat_iarray k n = tabulate2 n n (\<lambda> i j. if i = j then k else 0)"

definition is_zero_iarray :: "'a::{zero} iarray \<Rightarrow> bool"
  where "is_zero_iarray A = IArray_Addenda_QR.all (\<lambda>i. A !! i = 0) (IArray[0..<IArray.length A])"

subsubsection\<open>Properties of previous definitions\<close>
lemma is_zero_iarray_eq_iff:
  fixes A::"'a::{zero}^'n::{mod_type}"
  shows "(A = 0) = (is_zero_iarray (vec_to_iarray A))"
proof (auto)
  show "is_zero_iarray (vec_to_iarray 0)" by (simp add: vec_to_iarray_def is_zero_iarray_def Option.is_none_def find_None_iff)
  show "is_zero_iarray (vec_to_iarray A) \<Longrightarrow> A = 0"
  proof (simp add: vec_to_iarray_def is_zero_iarray_def Option.is_none_def find_None_iff vec_eq_iff, clarify)
    fix i::'n
    assume "\<forall>i\<in>{0..<CARD('n)}. A $ mod_type_class.from_nat i = 0"
    hence eq_zero: "\<forall>x<CARD('n). A $ from_nat x = 0" by force
    have "to_nat i<CARD('n)" using bij_to_nat[where ?'a='n] unfolding bij_betw_def by fastforce
    hence "A $ (from_nat (to_nat i)) = 0" using eq_zero by blast
    thus "A $ i = 0" unfolding from_nat_to_nat_id .
  qed
qed

lemma mult_iarray_works:
  assumes "a<IArray.length A" shows "mult_iarray A q !! a = q * A!!a"
  unfolding mult_iarray_def
  unfolding IArray.of_fun_def unfolding sub_def
  using assms by simp

lemma length_eq_card_rows:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "IArray.length (matrix_to_iarray A) = CARD('rows)"
  unfolding matrix_to_iarray_def by auto

lemma nrows_eq_card_rows:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "nrows_iarray (matrix_to_iarray A) = CARD('rows)"
  unfolding nrows_iarray_def length_eq_card_rows ..

lemma length_eq_card_columns:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "IArray.length (matrix_to_iarray A !! 0) = CARD ('columns)"
  unfolding matrix_to_iarray_def o_def vec_to_iarray_def by simp

lemma ncols_eq_card_columns:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "ncols_iarray (matrix_to_iarray A) = CARD('columns)"
  unfolding ncols_iarray_def length_eq_card_columns ..

lemma matrix_to_iarray_nrows:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "nrows A = nrows_iarray (matrix_to_iarray A)"
  unfolding nrows_def nrows_eq_card_rows ..

lemma matrix_to_iarray_ncols:
  fixes A::"'a^'columns::{mod_type}^'rows::{mod_type}"
  shows "ncols A = ncols_iarray (matrix_to_iarray A)"
  unfolding ncols_def ncols_eq_card_columns ..

lemma vec_to_iarray_row[code_unfold]: "vec_to_iarray (row i A) = row_iarray (to_nat i) (matrix_to_iarray A)"
  unfolding row_def row_iarray_def vec_to_iarray_def
  by (auto, metis IArray.sub_def IArray.of_fun_def vec_matrix vec_to_iarray_def)

lemma vec_to_iarray_row': "vec_to_iarray (row i A) = (matrix_to_iarray A) !! (to_nat i)"
  unfolding row_def vec_to_iarray_def
  by (auto, metis IArray.sub_def IArray.of_fun_def vec_matrix vec_to_iarray_def)

lemma vec_to_iarray_column[code_unfold]: "vec_to_iarray (column i A) = column_iarray (to_nat i) (matrix_to_iarray A)"
  unfolding column_def vec_to_iarray_def column_iarray_def length_eq_card_rows
  by (auto, metis IArray.sub_def from_nat_not_eq vec_matrix vec_to_iarray_nth')

lemma vec_to_iarray_column':
  assumes k: "k<ncols A"
  shows "(vec_to_iarray (column (from_nat k) A)) = (column_iarray k (matrix_to_iarray A))"
  unfolding vec_to_iarray_column unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]] ..

lemma column_iarray_nth:
  assumes i: "i<nrows_iarray A"
  shows "column_iarray j A !! i = A !! i !! j"
proof -
  have "column_iarray j A !! i = map (\<lambda>m. A !! m !! j) [0..<IArray.length A] ! i"
    unfolding column_iarray_def by auto
  also have "... = (\<lambda>m. A !! m !! j) ([0..<IArray.length A] ! i)" using i nth_map unfolding nrows_iarray_def by auto
  also have "... = (\<lambda>m. A !! m !! j) (i)" using nth_upt[of 0 i "IArray.length A"] i unfolding nrows_iarray_def by simp
  finally show ?thesis .
qed

lemma vec_to_iarray_rows: "vec_to_iarray` (rows A) = rows_iarray (matrix_to_iarray A)"
  unfolding rows_def unfolding rows_iarray_def
  apply (auto simp add: vec_to_iarray_row to_nat_less_card nrows_eq_card_rows)
  by (unfold image_def, auto, metis from_nat_not_eq vec_to_iarray_row)

lemma vec_to_iarray_columns: "vec_to_iarray` (columns A) = columns_iarray (matrix_to_iarray A)"
  unfolding columns_def unfolding columns_iarray_def
  apply(auto simp add: ncols_eq_card_columns to_nat_less_card vec_to_iarray_column)
  by (unfold image_def, auto, metis from_nat_not_eq vec_to_iarray_column)

subsection\<open>Definition of elementary operations\<close>

definition interchange_rows_iarray :: "'a iarray iarray => nat => nat => 'a iarray iarray"
  where "interchange_rows_iarray A a b = IArray.of_fun (\<lambda>n. if n=a then A!!b else if n=b then A!!a else A!!n) (IArray.length A)"

definition mult_row_iarray :: "'a::{times} iarray iarray => nat => 'a => 'a iarray iarray"
  where "mult_row_iarray A a q = IArray.of_fun (\<lambda>n. if n=a then mult_iarray (A!!a) q else A!!n) (IArray.length A)"

definition row_add_iarray :: "'a::{plus, times,zero} iarray iarray => nat => nat => 'a => 'a iarray iarray"
  where "row_add_iarray A a b q = IArray.of_fun (\<lambda>n. if n=a then A!!a + mult_iarray (A!!b) q else A!!n) (IArray.length A)"

definition interchange_columns_iarray :: "'a iarray iarray => nat => nat => 'a iarray iarray"
  where "interchange_columns_iarray A a b =  tabulate2 (nrows_iarray A) (ncols_iarray A) (\<lambda>i j. if j = a then A !! i !! b else if j = b then A !! i !! a else A !! i !! j)"

definition mult_column_iarray :: "'a::{times} iarray iarray => nat => 'a => 'a iarray iarray"
  where "mult_column_iarray A n q = tabulate2 (nrows_iarray A) (ncols_iarray A) (\<lambda>i j. if j = n then A !! i !! j * q else A !! i !! j)"

definition column_add_iarray :: "'a::{plus, times} iarray iarray => nat => nat => 'a => 'a iarray iarray"
  where "column_add_iarray A n m q = tabulate2 (nrows_iarray A) (ncols_iarray A) (\<lambda>i j. if j = n then A !! i !! n + A !! i !! m * q else A !! i !! j)"

subsubsection\<open>Code generator\<close>

lemma vec_to_iarray_plus[code_unfold]: "vec_to_iarray (a + b) =  (vec_to_iarray a) + (vec_to_iarray b)"
  unfolding vec_to_iarray_def
  unfolding plus_iarray_def Let_def by auto

lemma matrix_to_iarray_plus[code_unfold]: "matrix_to_iarray (A + B) = (matrix_to_iarray A) + (matrix_to_iarray B)"
  unfolding matrix_to_iarray_def o_def
  by (simp add: plus_iarray_def Let_def vec_to_iarray_plus)

lemma matrix_to_iarray_mat[code_unfold]:
  "matrix_to_iarray (mat k ::'a::{zero}^'n::{mod_type}^'n::{mod_type}) = mat_iarray k CARD('n::{mod_type})"
  unfolding matrix_to_iarray_def o_def vec_to_iarray_def mat_def mat_iarray_def tabulate2_def
  using from_nat_eq_imp_eq by fastforce

lemma matrix_to_iarray_transpose[code_unfold]:
  shows "matrix_to_iarray (transpose A) = transpose_iarray (matrix_to_iarray A)"
  unfolding matrix_to_iarray_def transpose_def transpose_iarray_def
    o_def tabulate2_def nrows_iarray_def ncols_iarray_def vec_to_iarray_def
  by auto

lemma matrix_to_iarray_matrix_matrix_mult[code_unfold]:
  fixes A::"'a::{semiring_1}^'m::{mod_type}^'n::{mod_type}" and B::"'a^'b::{mod_type}^'m::{mod_type}"
  shows "matrix_to_iarray (A ** B) = (matrix_to_iarray A) **i (matrix_to_iarray B)"
  unfolding matrix_to_iarray_def matrix_matrix_mult_iarray_def matrix_matrix_mult_def
  unfolding o_def tabulate2_def nrows_iarray_def ncols_iarray_def vec_to_iarray_def
  using sum.reindex_cong[of "from_nat::nat=>'m"] using bij_from_nat unfolding bij_betw_def by fastforce

lemma vec_to_iarray_matrix_matrix_mult[code_unfold]:
  fixes A::"'a::{semiring_1}^'m::{mod_type}^'n::{mod_type}" and x::"'a^'m::{mod_type}"
  shows "vec_to_iarray (A *v x) = (matrix_to_iarray A) *iv (vec_to_iarray x)"
  unfolding matrix_vector_mult_iarray_def matrix_vector_mult_def
  unfolding o_def tabulate2_def nrows_iarray_def ncols_iarray_def matrix_to_iarray_def vec_to_iarray_def
  using sum.reindex_cong[of "from_nat::nat=>'m"] using bij_from_nat unfolding bij_betw_def by fastforce

lemma vec_to_iarray_vector_matrix_mult[code_unfold]:
  fixes A::"'a::{semiring_1}^'m::{mod_type}^'n::{mod_type}" and x::"'a^'n::{mod_type}"
  shows "vec_to_iarray (x v* A) = (vec_to_iarray x) v*i (matrix_to_iarray A)"
  unfolding vector_matrix_mult_def vector_matrix_mult_iarray_def
  unfolding o_def tabulate2_def nrows_iarray_def ncols_iarray_def matrix_to_iarray_def vec_to_iarray_def
proof (auto)
  fix xa
  show "(\<Sum>i\<in>UNIV. A $ i $ from_nat xa * x $ i) = (\<Sum>i = 0..<CARD('n). A $ from_nat i $ from_nat xa * x $ from_nat i)"
    apply (rule sum.reindex_cong[of "from_nat::nat=>'n"]) using bij_from_nat[where ?'a='n] unfolding bij_betw_def by fast+
qed

lemma matrix_to_iarray_interchange_rows[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (interchange_rows A i j) = interchange_rows_iarray (matrix_to_iarray A) (to_nat i) (to_nat j)"
proof (unfold matrix_to_iarray_def interchange_rows_iarray_def o_def map_vec_to_iarray_rw, auto)
  fix x assume x_less_card: "x < CARD('rows)"
    and x_not_j: "x \<noteq> to_nat j" and x_not_i: "x \<noteq> to_nat i"
  show "vec_to_iarray (interchange_rows A i j $ from_nat x) = vec_to_iarray (A $ from_nat x)"
    by (metis interchange_rows_preserves to_nat_from_nat_id x_less_card x_not_i x_not_j)
qed

lemma matrix_to_iarray_mult_row[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (mult_row A i q) = mult_row_iarray (matrix_to_iarray A) (to_nat i) q"
  unfolding matrix_to_iarray_def mult_row_iarray_def o_def
  unfolding mult_iarray_def vec_to_iarray_def mult_row_def apply auto
proof -
  fix i x
  assume i_contr:"i \<noteq> to_nat (from_nat i::'rows)" and "x < CARD('columns)"
    and "i<CARD('rows)"
  hence "i = to_nat (from_nat i::'rows)" using to_nat_from_nat_id by fastforce
  thus "q * A $ from_nat i $ from_nat x = A $ from_nat i $ from_nat x"
    using i_contr by contradiction
qed

lemma matrix_to_iarray_row_add[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (row_add A i j q) = row_add_iarray (matrix_to_iarray A) (to_nat i) (to_nat j) q"
proof (unfold matrix_to_iarray_def row_add_iarray_def o_def, auto)
  show "vec_to_iarray (row_add A i j q $ i) = vec_to_iarray (A $ i) + mult_iarray (vec_to_iarray (A $ j)) q"
    unfolding mult_iarray_def vec_to_iarray_def unfolding plus_iarray_def Let_def row_add_def by auto
  fix ia assume ia_not_i: "ia \<noteq> to_nat i" and ia_card: "ia < CARD('rows) "
  have from_nat_ia_not_i: "from_nat ia \<noteq> i"
  proof (rule ccontr)
    assume "\<not> from_nat ia \<noteq> i" hence "from_nat ia = i" by simp
    hence "to_nat (from_nat ia::'rows) = to_nat i" by simp
    hence "ia=to_nat i" using to_nat_from_nat_id ia_card by fastforce
    thus False  using ia_not_i by contradiction
  qed
  show "vec_to_iarray (row_add A i j q $ from_nat ia) = vec_to_iarray (A $ from_nat ia)"
    using ia_not_i
    unfolding vec_to_iarray_morph[symmetric] unfolding row_add_def using from_nat_ia_not_i by vector
qed

lemma matrix_to_iarray_interchange_columns[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (interchange_columns A i j) = interchange_columns_iarray (matrix_to_iarray A) (to_nat i) (to_nat j)"
  unfolding interchange_columns_def interchange_columns_iarray_def o_def tabulate2_def
  unfolding nrows_eq_card_rows ncols_eq_card_columns
  unfolding  matrix_to_iarray_def o_def vec_to_iarray_def
  by (auto simp add: to_nat_from_nat_id to_nat_less_card[of i] to_nat_less_card[of j])

lemma matrix_to_iarray_mult_columns[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (mult_column A i q) = mult_column_iarray (matrix_to_iarray A) (to_nat i) q"
  unfolding mult_column_def mult_column_iarray_def o_def tabulate2_def
  unfolding nrows_eq_card_rows ncols_eq_card_columns
  unfolding  matrix_to_iarray_def o_def vec_to_iarray_def
  by (auto simp add: to_nat_from_nat_id)

lemma matrix_to_iarray_column_add[code_unfold]:
  fixes A::"'a::{semiring_1}^'columns::{mod_type}^'rows::{mod_type}"
  shows "matrix_to_iarray (column_add A i j q) = column_add_iarray (matrix_to_iarray A) (to_nat i) (to_nat j) q"
  unfolding column_add_def column_add_iarray_def o_def tabulate2_def
  unfolding nrows_eq_card_rows ncols_eq_card_columns
  unfolding  matrix_to_iarray_def o_def vec_to_iarray_def
  by (auto simp add: to_nat_from_nat_id to_nat_less_card[of i] to_nat_less_card[of j])

end


(*  Title:       Binary Search Trees, Isar-Style
    Author:      Viktor Kuncak, MIT CSAIL, November 2003
    Maintainer:  Larry Paulson <Larry.Paulson at cl.cam.ac.uk>
    License:     LGPL
*)

section \<open>Isar-style Reasoning for Binary Tree Operations\<close>
theory BinaryTree imports Main begin

text \<open>We prove correctness of operations on
 binary search tree implementing a set.

 This document is LGPL.

 Author: Viktor Kuncak, MIT CSAIL, November 2003\<close>

(*============================================================*)
section \<open>Tree Definition\<close>
(*============================================================*)

datatype 'a Tree = Tip | T "'a Tree" 'a "'a Tree"

primrec
  setOf :: "'a Tree => 'a set"
  \<comment> \<open>set abstraction of a tree\<close>
where
  "setOf Tip = {}"
| "setOf (T t1 x t2) = (setOf t1) Un (setOf t2) Un {x}"

type_synonym
  \<comment> \<open>we require index to have an irreflexive total order <\<close>
  \<comment> \<open>apart from that, we do not rely on index being int\<close>
  index = int

type_synonym \<comment> \<open>hash function type\<close>
  'a hash = "'a => index"

definition eqs :: "'a hash => 'a => 'a set" where
  \<comment> \<open>equivalence class of elements with the same hash code\<close>
  "eqs h x == {y. h y = h x}"

primrec
  sortedTree :: "'a hash => 'a Tree => bool"
  \<comment> \<open>check if a tree is sorted\<close>
where
  "sortedTree h Tip = True"
| "sortedTree h (T t1 x t2) =
    (sortedTree h t1 &
     (\<forall>l \<in> setOf t1. h l < h x) &
     (\<forall>r \<in> setOf t2. h x < h r) &
     sortedTree h t2)"

lemma sortLemmaL:
  "sortedTree h (T t1 x t2) ==> sortedTree h t1" by simp
lemma sortLemmaR:
  "sortedTree h (T t1 x t2) ==> sortedTree h t2" by simp

(*============================================================*)
section \<open>Tree Lookup\<close>
(*============================================================*)

primrec
  tlookup :: "'a hash => index => 'a Tree => 'a option"
where
  "tlookup h k Tip = None"
| "tlookup h k (T t1 x t2) =
   (if k < h x then tlookup h k t1
    else if h x < k then tlookup h k t2
    else Some x)"

lemma tlookup_some:
     "sortedTree h t & (tlookup h k t = Some x) --> x:setOf t & h x = k"
apply (induct t)
  \<comment> \<open>Just auto will do it, but very slowly\<close>
apply (simp)
apply (clarify, auto)
apply (simp_all split: if_split_asm)
done

definition sorted_distinct_pred :: "'a hash => 'a => 'a => 'a Tree => bool" where
  \<comment> \<open>No two elements have the same hash code\<close>
  "sorted_distinct_pred h a b t == sortedTree h t &
      a:setOf t & b:setOf t & h a = h b -->
      a = b"

declare sorted_distinct_pred_def [simp]

\<comment> \<open>for case analysis on three cases\<close>
lemma cases3: "[| C1 ==> G; C2 ==> G; C3 ==> G;
                  C1 | C2 | C3 |] ==> G"
by auto

text \<open>@{term sorted_distinct_pred} holds for out trees:\<close>

lemma sorted_distinct: "sorted_distinct_pred h a b t" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof (unfold sorted_distinct_pred_def, safe)
    assume s: "sortedTree h (T t1 x t2)"
    assume adef: "a : setOf (T t1 x t2)"
    assume bdef: "b : setOf (T t1 x t2)"
    assume hahb: "h a = h b"
    from s have s1: "sortedTree h t1" by auto
    from s have s2: "sortedTree h t2" by auto
    show "a = b"
    \<comment> \<open>We consider 9 cases for the position of a and b are in the tree\<close>
    proof -
    \<comment> \<open>three cases for a\<close>
    from adef have "a : setOf t1 | a = x | a : setOf t2" by auto
    moreover { assume adef1: "a : setOf t1"
      have ?thesis
      proof -
      \<comment> \<open>three cases for b\<close>
      from bdef have "b : setOf t1 | b = x | b : setOf t2" by auto
      moreover { assume bdef1: "b : setOf t1"
        from s1 adef1 bdef1 hahb h1 have ?thesis by simp }
      moreover { assume bdef1: "b = x"
        from adef1 bdef1 s have "h a < h b" by auto
        from this hahb have ?thesis by simp }
      moreover { assume bdef1: "b : setOf t2"
        from adef1 s have o1: "h a < h x" by auto
        from bdef1 s have o2: "h x < h b" by auto
        from o1 o2 have "h a < h b" by simp
        from this hahb have ?thesis by simp } \<comment> \<open>case impossible\<close>
      ultimately show ?thesis by blast
      qed
    }
    moreover { assume adef1: "a = x"
      have ?thesis
      proof -
      \<comment> \<open>three cases for b\<close>
      from bdef have "b : setOf t1 | b = x | b : setOf t2" by auto
      moreover { assume bdef1: "b : setOf t1"
        from this s have "h b < h x" by auto
        from this adef1 have "h b < h a" by auto
        from hahb this have ?thesis by simp } \<comment> \<open>case impossible\<close>
      moreover { assume bdef1: "b = x"
        from adef1 bdef1 have ?thesis by simp }
      moreover { assume bdef1: "b : setOf t2"
        from this s have "h x < h b" by auto
        from this adef1 have "h a < h b" by simp
        from hahb this have ?thesis by simp } \<comment> \<open>case impossible\<close>
      ultimately show ?thesis by blast
      qed
    }
    moreover { assume adef1: "a : setOf t2"
      have ?thesis
      proof -
      \<comment> \<open>three cases for b\<close>
      from bdef have "b : setOf t1 | b = x | b : setOf t2" by auto
      moreover { assume bdef1: "b : setOf t1"
        from bdef1 s have o1: "h b < h x" by auto
        from adef1 s have o2: "h x < h a" by auto
        from o1 o2 have "h b < h a" by simp
        from this hahb have ?thesis by simp } \<comment> \<open>case impossible\<close>
      moreover { assume bdef1: "b = x"
        from adef1 bdef1 s have "h b < h a" by auto
        from this hahb have ?thesis by simp } \<comment> \<open>case impossible\<close>
      moreover { assume bdef1: "b : setOf t2"
        from s2 adef1 bdef1 hahb h2 have ?thesis by simp }
      ultimately show ?thesis by blast
      qed
    }
    ultimately show ?thesis by blast
    qed
  qed
qed

lemma tlookup_finds: \<comment> \<open>if a node is in the tree, lookup finds it\<close>
"sortedTree h t & y:setOf t -->
 tlookup h (h y) t = Some y"
proof safe
  assume s: "sortedTree h t"
  assume yint: "y : setOf t"
  show "tlookup h (h y) t = Some y"
  proof (cases "tlookup h (h y) t")
  case None note res = this
    from s res have "sortedTree h t & (tlookup h (h y) t = None)" by simp
    from this have o1: "\<forall>x\<in>setOf t. h x ~= h y" by (simp add: tlookup_none)
    from o1 yint have "h y ~= h y" by fastforce (* auto does not work *)
    from this show ?thesis by simp
  next case (Some z) note res = this
    have ls: "sortedTree h t & (tlookup h (h y) t = Some z) -->
              z:setOf t & h z = h y" by (simp add: tlookup_some)
    have sd: "sorted_distinct_pred h y z t"
    by (insert sorted_distinct [of h y z t], simp)
       (* for some reason simplifier would never guess this substitution *)
    from s res ls have o1: "z:setOf t & h z = h y" by simp
    from s yint o1 sd have "y = z" by auto
    from this res show "tlookup h (h y) t = Some y" by simp
  qed
qed

subsection \<open>Tree membership as a special case of lookup\<close>

definition memb :: "'a hash => 'a => 'a Tree => bool" where
  "memb h x t ==
   (case (tlookup h (h x) t) of
      None => False
    | Some z => (x=z))"

lemma assumes s: "sortedTree h t"
      shows memb_spec: "memb h x t = (x : setOf t)"
proof (cases "tlookup h (h x) t")
case None note tNone = this
  from tNone have res: "memb h x t = False" by (simp add: memb_def)
  from s tNone tlookup_none have o1: "\<forall>y\<in>setOf t. h y ~= h x" by fastforce
  have notIn: "x ~: setOf t"
  proof
    assume h: "x : setOf t"
    from h o1 have "h x ~= h x" by fastforce
    from this show False by simp
  qed
  from res notIn show ?thesis by simp
next case (Some z) note tSome = this
  from s tSome tlookup_some have zin: "z : setOf t" by fastforce
  show ?thesis
  proof (cases "x=z")
  case True note xez = this
    from tSome xez have res: "memb h x t" by (simp add: memb_def)
    from res zin xez show ?thesis by simp
  next case False note xnez = this
    from tSome xnez have res: "~ memb h x t" by (simp add: memb_def)
    have "x ~: setOf t"
    proof
      assume xin: "x : setOf t"
      from s tSome tlookup_some have hzhx: "h x = h z" by fastforce
      have o1: "sorted_distinct_pred h x z t"
      by (insert sorted_distinct [of h x z t], simp)
      from s xin zin hzhx o1 have "x = z" by fastforce
      from this xnez show False by simp
    qed
    from this res show ?thesis by simp
  qed
qed

declare sorted_distinct_pred_def [simp del]

(*============================================================*)
section \<open>Insertion into a Tree\<close>
(*============================================================*)

primrec
  binsert :: "'a hash => 'a => 'a Tree => 'a Tree"
where
  "binsert h e Tip = (T Tip e Tip)"
| "binsert h e (T t1 x t2) = (if h e < h x then
                             (T (binsert h e t1) x t2)
                            else
                             (if h x < h e then
                               (T t1 x (binsert h e t2))
                              else (T t1 e t2)))"

text \<open>A technique for proving disjointness of sets.\<close>
lemma disjCond: "[| !! x. [| x:A; x:B |] ==> False |] ==> A Int B = {}"
by fastforce

text \<open>The following is a proof that insertion correctly implements
        the set interface.
        Compared to \<open>BinaryTree_TacticStyle\<close>, the claim is more
        difficult, and this time we need to assume as a hypothesis
        that the tree is sorted.\<close>

text \<open>Using the correctness of set implementation,
        preserving sortedness is still simple.\<close>
lemma binsert_sorted: "sortedTree h t --> sortedTree h (binsert h x t)"
by (induct t) (auto simp add: binsert_set)

text \<open>We summarize the specification of binsert as follows.\<close>
corollary binsert_spec: "sortedTree h t -->
                     sortedTree h (binsert h x t) &
                     setOf (binsert h e t) = (setOf t) - (eqs h e) Un {e}"
by (simp add: binsert_set binsert_sorted)

(*============================================================*)
section \<open>Removing an element from a tree\<close>
(*============================================================*)

text \<open>These proofs are influenced by those in \<open>BinaryTree_Tactic\<close>\<close>

primrec
  rm :: "'a hash => 'a Tree => 'a"
  \<comment> \<open>rightmost element of a tree\<close>
where
"rm h (T t1 x t2) =
  (if t2=Tip then x else rm h t2)"

primrec
  wrm :: "'a hash => 'a Tree => 'a Tree"
  \<comment> \<open>tree without the rightmost element\<close>
where
"wrm h (T t1 x t2) =
  (if t2=Tip then t1 else (T t1 x (wrm h t2)))"

primrec
  wrmrm :: "'a hash => 'a Tree => 'a Tree * 'a"
  \<comment> \<open>computing rightmost and removal in one pass\<close>
where
"wrmrm h (T t1 x t2) =
  (if t2=Tip then (t1,x)
   else (T t1 x (fst (wrmrm h t2)),
         snd (wrmrm h t2)))"

primrec
  remove :: "'a hash => 'a => 'a Tree => 'a Tree"
   \<comment> \<open>removal of an element from the tree\<close>
where
  "remove h e Tip = Tip"
| "remove h e (T t1 x t2) =
    (if h e < h x then (T (remove h e t1) x t2)
     else if h x < h e then (T t1 x (remove h e t2))
     else (if t1=Tip then t2
           else let (t1p,r) = wrmrm h t1
                in (T t1p r t2)))"

theorem wrmrm_decomp: "t ~= Tip --> wrmrm h t = (wrm h t, rm h t)"
apply (induct_tac t)
apply simp_all
done

lemma rm_set: "t ~= Tip & sortedTree h t --> rm h t : setOf t"
apply (induct_tac t)
apply simp_all
done

lemma wrm_set: "t ~= Tip & sortedTree h t -->
                setOf (wrm h t) = setOf t - {rm h t}" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof (rule impI, erule conjE)
    assume s: "sortedTree h (T t1 x t2)"
    show "setOf (wrm h (T t1 x t2)) =
          setOf (T t1 x t2) - {rm h (T t1 x t2)}"
    proof (cases "t2 = Tip")
    case True note t2tip = this
      from t2tip have rm_res: "rm h (T t1 x t2) = x" by simp
      from t2tip have wrm_res: "wrm h (T t1 x t2) = t1" by simp
      from s have "x ~: setOf t1" by auto
      from this rm_res wrm_res t2tip show ?thesis by simp
    next case False note t2nTip = this
      from t2nTip have rm_res: "rm h (T t1 x t2) = rm h t2" by simp
      from t2nTip have wrm_res: "wrm h (T t1 x t2) = T t1 x (wrm h t2)" by simp
      from s have s2: "sortedTree h t2" by simp
      from h2 t2nTip s2
      have o1: "setOf (wrm h t2) = setOf t2 - {rm h t2}" by simp
      show ?thesis
      proof (simp add: rm_res wrm_res t2nTip h2 o1)
        show "insert x (setOf t1 Un (setOf t2 - {rm h t2})) =
              insert x (setOf t1 Un setOf t2) - {rm h t2}"
        proof -
          from s rm_set t2nTip have xOk: "h x < h (rm h t2)" by auto
          have t1Ok: "\<forall>l \<in> setOf t1. h l < h (rm h t2)"
          proof safe
            fix l :: 'a  assume ldef: "l : setOf t1"
            from ldef s have lx: "h l < h x" by auto
            from lx xOk show "h l < h (rm h t2)" by auto
          qed
          from xOk t1Ok show ?thesis by auto
        qed
      qed
    qed
  qed
qed

lemma wrm_set1: "t ~= Tip & sortedTree h t --> setOf (wrm h t) <= setOf t"
by (auto simp add: wrm_set)

lemma wrm_sort: "t ~= Tip & sortedTree h t --> sortedTree h (wrm h t)" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof safe
    assume s: "sortedTree h (T t1 x t2)"
    show "sortedTree h (wrm h (T t1 x t2))"
    proof (cases "t2 = Tip")
    case True note t2tip = this
      from t2tip have res: "wrm h (T t1 x t2) = t1" by simp
      from res s show ?thesis by simp
    next case False note t2nTip = this
      from t2nTip have res: "wrm h (T t1 x t2) = T t1 x (wrm h t2)" by simp
      from s have s1: "sortedTree h t1" by simp
      from s have s2: "sortedTree h t2" by simp
      from s2 h2 t2nTip have o1: "sortedTree h (wrm h t2)" by simp
      from s2 t2nTip wrm_set1 have o2: "setOf (wrm h t2) <= setOf t2" by auto
      from s o2 have o3: "\<forall>r \<in> setOf (wrm h t2). h x < h r" by auto
      from s1 o1 o3 res s show "sortedTree h (wrm h (T t1 x t2))" by simp
    qed
  qed
qed

lemma wrm_less_rm:
  "t ~= Tip & sortedTree h t -->
   (\<forall>l \<in> setOf (wrm h t). h l < h (rm h t))" (is "?P t")
proof (induct t)
  show "?P Tip" by simp
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof safe
    fix l :: "'a" assume ldef: "l : setOf (wrm h (T t1 x t2))"
    assume s: "sortedTree h (T t1 x t2)"
    from s have s1: "sortedTree h t1" by simp
    from s have s2: "sortedTree h t2" by simp
    show "h l < h (rm h (T t1 x t2))"
    proof (cases "t2 = Tip")
    case True note t2tip = this
      from t2tip have rm_res: "rm h (T t1 x t2) = x" by simp
      from t2tip have wrm_res: "wrm h (T t1 x t2) = t1" by simp
      from ldef wrm_res have o1: "l : setOf t1" by simp
      from rm_res o1 s show ?thesis by simp
    next case False note t2nTip = this
      from t2nTip have rm_res: "rm h (T t1 x t2) = rm h t2" by simp
      from t2nTip have wrm_res: "wrm h (T t1 x t2) = T t1 x (wrm h t2)" by simp
      from ldef wrm_res
      have l_scope: "l : {x} Un setOf t1 Un setOf (wrm h t2)" by simp
      have hLess: "h l < h (rm h t2)"
      proof (cases "l = x")
      case True note lx = this
        from s t2nTip rm_set s2 have o1: "h x < h (rm h t2)" by auto
        from lx o1 show ?thesis by simp
      next case False note lnx = this
        show ?thesis
        proof (cases "l : setOf t1")
        case True note l_in_t1 = this
          from s t2nTip rm_set s2 have o1: "h x < h (rm h t2)" by auto
          from l_in_t1 s have o2: "h l < h x" by auto
          from o1 o2 show ?thesis by simp
        next case False note l_notin_t1 = this
          from l_scope lnx l_notin_t1
          have l_in_res: "l : setOf (wrm h t2)" by auto
          from l_in_res h2 t2nTip s2 show ?thesis by auto
        qed
      qed
      from rm_res hLess show ?thesis by simp
    qed
  qed
qed

lemma remove_set: "sortedTree h t -->
  setOf (remove h e t) = setOf t - eqs h e" (is "?P t")
proof (induct t)
  show "?P Tip" by auto
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof
    assume s: "sortedTree h (T t1 x t2)"
    show "setOf (remove h e (T t1 x t2)) = setOf (T t1 x t2) - eqs h e"
    proof (cases "h e < h x")
    case True note elx = this
      from elx have res: "remove h e (T t1 x t2) = T (remove h e t1) x t2"
      by simp
      from s have s1: "sortedTree h t1" by simp
      from s1 h1 have o1: "setOf (remove h e t1) = setOf t1 - eqs h e" by simp
      show ?thesis
      proof (simp add: o1 elx)
        show "insert x (setOf t1 - eqs h e Un setOf t2) =
              insert x (setOf t1 Un setOf t2) - eqs h e"
        proof -
          have xOk: "x ~: eqs h e"
          proof
            assume h: "x : eqs h e"
            from h have o1: "~ (h e < h x)" by (simp add: eqs_def)
            from elx o1 show "False" by contradiction
          qed
          have t2Ok: "(setOf t2) Int (eqs h e) = {}"
          proof (rule disjCond)
            fix y :: 'a
            assume y_in_t2: "y : setOf t2"
            assume y_in_eq: "y : eqs h e"
            from y_in_t2 s have xly: "h x < h y" by auto
            from y_in_eq have eey: "h y = h e" by (simp add: eqs_def) (* must "add:" not "from" *)
            from xly eey have nelx: "~ (h e < h x)" by simp
            from nelx elx show False by contradiction
          qed
          from xOk t2Ok show ?thesis by auto
        qed
      qed
    next case False note nelx = this
      show ?thesis
      proof (cases "h x < h e")
      case True note xle = this
        from xle have res: "remove h e (T t1 x t2) = T t1 x (remove h e t2)" by simp
        from s have s2: "sortedTree h t2" by simp
        from s2 h2 have o1: "setOf (remove h e t2) = setOf t2 - eqs h e" by simp
        show ?thesis
        proof (simp add: o1 xle nelx)
          show "insert x (setOf t1 Un (setOf t2 - eqs h e)) =
                insert x (setOf t1 Un setOf t2) - eqs h e"
          proof -
            have xOk: "x ~: eqs h e"
            proof
              assume h: "x : eqs h e"
              from h have o1: "~ (h x < h e)" by (simp add: eqs_def)
              from xle o1 show "False" by contradiction
            qed
            have t1Ok: "(setOf t1) Int (eqs h e) = {}"
            proof (rule disjCond)
              fix y :: 'a
              assume y_in_t1: "y : setOf t1"
              assume y_in_eq: "y : eqs h e"
              from y_in_t1 s have ylx: "h y < h x" by auto
              from y_in_eq have eey: "h y = h e" by (simp add: eqs_def)
              from ylx eey have nxle: "~ (h x < h e)" by simp
              from nxle xle show False by contradiction
            qed
            from xOk t1Ok show ?thesis by auto
          qed
        qed
      next case False note nxle = this
        from nelx nxle have ex: "h e = h x" by simp
        have t2Ok: "(setOf t2) Int (eqs h e) = {}"
        proof (rule disjCond)
          fix y :: 'a
          assume y_in_t2: "y : setOf t2"
          assume y_in_eq: "y : eqs h e"
          from y_in_t2 s have xly: "h x < h y" by auto
          from y_in_eq have eey: "h y = h e" by (simp add: eqs_def)
          from y_in_eq ex eey have nxly: "~ (h x < h y)" by simp
          from nxly xly show False by contradiction
        qed
        show ?thesis
        proof (cases "t1 = Tip")
        case True note t1tip = this
          from ex t1tip have res: "remove h e (T t1 x t2) = t2" by simp
          show ?thesis
          proof (simp add: res t1tip ex)
            show "setOf t2 = insert x (setOf t2) - eqs h e"
            proof -
              from ex have x_in_eqs: "x : eqs h e" by (simp add: eqs_def)
              from x_in_eqs t2Ok show ?thesis by auto
           qed
          qed
        next case False note t1nTip = this
          from nelx nxle ex t1nTip
          have res: "remove h e (T t1 x t2) =
                     T (wrm h t1) (rm h t1) t2"
          by (simp add: Let_def wrmrm_decomp)
          from res show ?thesis
          proof simp
            from s have s1: "sortedTree h t1" by simp
            show "insert (rm h t1) (setOf (wrm h t1) Un setOf t2) =
                  insert x (setOf t1 Un setOf t2) - eqs h e"
            proof (simp add: t1nTip s1 rm_set wrm_set)
              show "insert (rm h t1) (setOf t1 - {rm h t1} Un setOf t2) =
                    insert x (setOf t1 Un setOf t2) - eqs h e"
              proof -
                from t1nTip s1 rm_set
                have o1: "insert (rm h t1) (setOf t1 - {rm h t1} Un setOf t2) =
                          setOf t1 Un setOf t2" by auto
                have o2: "insert x (setOf t1 Un setOf t2) - eqs h e =
                          setOf t1 Un setOf t2"
                proof -
                  from ex have xOk: "x : eqs h e" by (simp add: eqs_def)
                  have t1Ok: "(setOf t1) Int (eqs h e) = {}"
                  proof (rule disjCond)
                    fix y :: 'a
                    assume y_in_t1: "y : setOf t1"
                    assume y_in_eq: "y : eqs h e"
                    from y_in_t1 s ex have o1: "h y < h e" by auto
                    from y_in_eq have o2: "~ (h y < h e)" by (simp add: eqs_def)
                    from o1 o2 show False by contradiction
                  qed
                  from xOk t1Ok t2Ok show ?thesis by auto
                qed
                from o1 o2 show ?thesis by simp
              qed
            qed
          qed
        qed
      qed
    qed
  qed
qed

lemma remove_sort: "sortedTree h t -->
                    sortedTree h (remove h e t)" (is "?P t")
proof (induct t)
  show "?P Tip" by auto
  fix t1 :: "'a Tree" assume h1: "?P t1"
  fix t2 :: "'a Tree" assume h2: "?P t2"
  fix x :: 'a
  show "?P (T t1 x t2)"
  proof
    assume s: "sortedTree h (T t1 x t2)"
    from s have s1: "sortedTree h t1" by simp
    from s have s2: "sortedTree h t2" by simp
    from h1 s1 have sr1: "sortedTree h (remove h e t1)" by simp
    from h2 s2 have sr2: "sortedTree h (remove h e t2)" by simp
    show "sortedTree h (remove h e (T t1 x t2))"
    proof (cases "h e < h x")
    case True note elx = this
      from elx have res: "remove h e (T t1 x t2) = T (remove h e t1) x t2"
      by simp
      show ?thesis
      proof (simp add: s sr1 s2 elx res)
        let ?C1 = "\<forall>l \<in> setOf (remove h e t1). h l < h x"
        let ?C2 = "\<forall>r \<in> setOf t2. h x < h r"
        have o1: "?C1"
        proof -
          from s1 have "setOf (remove h e t1) = setOf t1 - eqs h e" by (simp add: remove_set)
          from s this show ?thesis by auto
        qed
        from o1 s show "?C1 & ?C2" by auto
      qed
    next case False note nelx = this
      show ?thesis
      proof (cases "h x < h e")
      case True note xle = this
        from xle have res: "remove h e (T t1 x t2) = T t1 x (remove h e t2)" by simp
        show ?thesis
        proof (simp add: s s1 sr2 xle nelx res)
          let ?C1 = "\<forall>l \<in> setOf t1. h l < h x"
          let ?C2 = "\<forall>r \<in> setOf (remove h e t2). h x < h r"
          have o2: "?C2"
          proof -
            from s2 have "setOf (remove h e t2) = setOf t2 - eqs h e" by (simp add: remove_set)
            from s this show ?thesis by auto
          qed
          from o2 s show "?C1 & ?C2" by auto
        qed
      next case False note nxle = this
        from nelx nxle have ex: "h e = h x" by simp
        show ?thesis
        proof (cases "t1 = Tip")
        case True note t1tip = this
          from ex t1tip have res: "remove h e (T t1 x t2) = t2" by simp
          show ?thesis by (simp add: res t1tip ex s2)
        next case False note t1nTip = this
          from nelx nxle ex t1nTip
          have res: "remove h e (T t1 x t2) =
                     T (wrm h t1) (rm h t1) t2"
          by (simp add: Let_def wrmrm_decomp)
          from res show ?thesis
          proof simp
            let ?C1 = "sortedTree h (wrm h t1)"
            let ?C2 = "\<forall>l \<in> setOf (wrm h t1). h l < h (rm h t1)"
            let ?C3 = "\<forall>r \<in> setOf t2. h (rm h t1) < h r"
            let ?C4 = "sortedTree h t2"
            from s1 t1nTip have o1: ?C1 by (simp add: wrm_sort)
            from s1 t1nTip have o2: ?C2 by (simp add: wrm_less_rm)
            have o3: ?C3
            proof
              fix r :: 'a
              assume rt2: "r : setOf t2"
              from s rm_set s1 t1nTip have o1: "h (rm h t1) < h x" by auto
              from rt2 s have o2: "h x < h r" by auto
              from o1 o2 show "h (rm h t1) < h r" by simp
            qed
            from o1 o2 o3 s2 show "?C1 & ?C2 & ?C3 & ?C4" by simp
          qed
        qed
      qed
    qed
  qed
qed

text \<open>We summarize the specification of remove as follows.\<close>
corollary remove_spec: "sortedTree h t -->
     sortedTree h (remove h e t) &
     setOf (remove h e t) = setOf t - eqs h e"
by (simp add: remove_sort remove_set)

definition "test = tlookup id 4 (remove id 3 (binsert id 4 (binsert id 3 Tip)))"

export_code test
  in SML module_name BinaryTree_Code file \<open>BinaryTree_Code.ML\<close>

end


theory RelationalIncorrectness
  imports "HOL-IMP.Big_Step"
begin

(* Author: Toby Murray *)

section "Under-Approximate Relational Judgement"

text \<open>
  This is the relational analogue of OHearn's~\<^cite>\<open>"OHearn_19"\<close> and de Vries \& Koutavas'~\<^cite>\<open>"deVries_Koutavas_11"\<close>
  judgements.

  Note that in our case it doesn't really make sense to talk about ``erroneous'' states: the
  presence of an error can be seen only by the violation of a relation. Unlike O'Hearn, we cannot
  encode it directly into the semantics of our programs, without giving them a relational semantics.
  We use the standard big step semantics of IMP unchanged.
\<close>

type_synonym rassn = "state \<Rightarrow> state \<Rightarrow> bool"

definition
  ir_valid :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
  where
  "ir_valid P c c' Q \<equiv> (\<forall> t t'. Q t t' \<longrightarrow> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"

section "Rules of the Logic"

definition
  flip :: "rassn \<Rightarrow> rassn"
  where
  "flip P \<equiv> \<lambda>s s'. P s' s"

inductive
  ir_hoare :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> bool"
  where
  ir_Skip: "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c',s') \<Rightarrow> t') \<Longrightarrow>
            ir_hoare P SKIP c' Q" |
  ir_If_True:   "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) c\<^sub>1 c' Q \<Longrightarrow>
                 ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
  ir_If_False:   "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) c\<^sub>2 c' Q \<Longrightarrow>
                  ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q" |
  ir_Seq1: "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d SKIP R \<Longrightarrow> ir_hoare P (Seq c d) c' R" |
  ir_Assign: "ir_hoare (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow>
              ir_hoare P (Assign x e) c' Q" |
  ir_While_False: "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                  ir_hoare P (WHILE b DO c) c' Q" |
  ir_While_True: "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s) (c;; WHILE b DO c) c' Q \<Longrightarrow>
                  ir_hoare P (WHILE b DO c) c' Q" |
  ir_While_backwards_frontier: "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                                ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
                                ir_hoare (P 0) (WHILE b DO c) c' Q" |
  ir_conseq:      "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                   ir_hoare P' c c' Q'" |
  ir_disj:        "ir_hoare P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_hoare P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                   ir_hoare (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')" |
  ir_sym: "ir_hoare (flip P) c c' (flip Q) \<Longrightarrow> ir_hoare P c' c Q"

section "Simple Derived Rules"

lemma meh_simp[simp]: "(SKIP, s') \<Rightarrow> t' = (s' = t')"
  by auto

lemma ir_pre: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s')  \<Longrightarrow>
                  ir_hoare P' c c' Q"
  by(erule ir_conseq, blast+)

lemma ir_post: "ir_hoare P c c' Q \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s')  \<Longrightarrow>
                  ir_hoare P c c' Q'"
  by(erule ir_conseq, blast+)

section "Soundness"

lemma Skip_ir_valid[intro]:
  "(\<And>t t'. Q t t' \<Longrightarrow> \<exists>s'. P t s' \<and> (c', s') \<Rightarrow> t') \<Longrightarrow> ir_valid P SKIP c' Q"
  by(auto simp: ir_valid_def)

lemma sym_ir_valid[intro]:
  "ir_valid (flip P) c' c (flip Q) \<Longrightarrow> ir_valid P c c' Q"
  by(fastforce simp: ir_valid_def flip_def)

lemma If_True_ir_valid[intro]:
  "ir_valid (\<lambda>a c. P a c \<and> bval b a) c\<^sub>1 c' Q \<Longrightarrow>
   ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
  by(fastforce simp: ir_valid_def)

lemma If_False_ir_valid[intro]:
  "ir_valid (\<lambda>a c. P a c \<and> \<not> bval b a) c\<^sub>2 c' Q \<Longrightarrow>
   ir_valid P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) c' Q"
  by(fastforce simp: ir_valid_def)

lemma Seq1_ir_valid[intro]:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d SKIP R \<Longrightarrow> ir_valid P (c;; d) c' R"
  by(fastforce simp: ir_valid_def)

lemma Seq2_ir_valid[intro]:
  "ir_valid P c SKIP Q \<Longrightarrow> ir_valid Q d c' R \<Longrightarrow> ir_valid P (c;; d) c' R"
  by(fastforce simp: ir_valid_def)

lemma Seq_ir_valid[intro]:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid Q d d' R \<Longrightarrow> ir_valid P (c;; d) (c';; d') R"
  by(fastforce simp: ir_valid_def)

lemma Assign_blah[intro]:
  "t x = aval e (t(x := v))
       \<Longrightarrow> (x ::= e, t(x := v)) \<Rightarrow> t"
  using Assign
  by (metis fun_upd_triv fun_upd_upd)

lemma Assign_ir_valid[intro]:
  "ir_valid (\<lambda>t t'. \<exists> v. P (t(x := v)) t' \<and> (t x) = aval e (t(x := v))) SKIP c' Q \<Longrightarrow> ir_valid P (Assign x e) c' Q"
  by(fastforce simp: ir_valid_def)

lemma While_False_ir_valid[intro]:
  "ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
   ir_valid P (WHILE b DO c) c' Q"
  by(fastforce simp: ir_valid_def)

lemma While_True_ir_valid[intro]:
  "ir_valid (\<lambda>s s'. P s s' \<and> bval b s) (Seq c (WHILE b DO c)) c' Q \<Longrightarrow>
   ir_valid P (WHILE b DO c) c' Q"
  by(clarsimp simp: ir_valid_def, blast)

lemma While_backwards_frontier_ir_valid':
  assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                    (\<exists>s. P (k + n) s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t)"
  assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
  assumes post: "Q t t'"
  shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t'"
proof -
  from post last obtain s s' n where
    "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(c', s') \<Rightarrow> t'"
    by blast
  with asm  show ?thesis
  proof(induction n arbitrary: k t t')
    case 0
    then show ?case
      by (metis WhileFalse WhileTrue add.right_neutral)
  next
    case (Suc n)
    from Suc
    obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(c', r') \<Rightarrow> t'"
      by (metis add_Suc_shift)
    from final_iteration(1) obtain q q' where
     "P k q r' \<and> bval b q \<and>  (c, q) \<Rightarrow> r"
      by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
    with final_iteration show ?case by blast
  qed
qed

lemma While_backwards_frontier_ir_valid[intro]:
  "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
   ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (P 0) (WHILE b DO c) c' Q"
  by(auto simp: meh_simp ir_valid_def intro: While_backwards_frontier_ir_valid')

lemma conseq_ir_valid:
  "ir_valid P c c' Q \<Longrightarrow> (\<And>s s'. P s s' \<Longrightarrow> P' s s') \<Longrightarrow> (\<And>s s'. Q' s s' \<Longrightarrow> Q s s') \<Longrightarrow>
                  ir_valid P' c c' Q'"
  by(clarsimp simp: ir_valid_def, blast)

lemma disj_ir_valid[intro]:
  "ir_valid P\<^sub>1 c c' Q\<^sub>1 \<Longrightarrow> ir_valid P\<^sub>2 c c' Q\<^sub>2 \<Longrightarrow>
                  ir_valid (\<lambda>s s'. P\<^sub>1 s s' \<or> P\<^sub>2 s s') c c' (\<lambda> t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
  by(fastforce simp: ir_valid_def)

theorem soundness:
  "ir_hoare P c c' Q \<Longrightarrow> ir_valid P c c' Q"
  apply(induction rule: ir_hoare.induct)
              apply(blast intro!: Skip_ir_valid)
  by (blast intro: conseq_ir_valid)+

section "Completeness"

lemma ir_Skip_Skip[intro]:
  "ir_hoare P SKIP SKIP P"
  by(rule ir_Skip, simp)

lemma ir_hoare_Skip_Skip[simp]:
  "ir_hoare P SKIP SKIP Q = (\<forall>s s'. Q s s' \<longrightarrow> P s s')"
  using soundness ir_valid_def meh_simp ir_conseq ir_Skip by metis

lemma ir_valid_Seq1:
  "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t'))"
  by(auto simp: ir_valid_def)

lemma ir_valid_Seq1':
  "ir_valid P (c1;; c2) c' Q \<Longrightarrow> ir_valid (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> (\<exists>u. (c2,t) \<Rightarrow> u \<and> Q u t')) c2 SKIP Q"
  by(clarsimp simp: ir_valid_def, meson SeqE)

lemma ir_valid_track_history:
  "ir_valid P c c' Q \<Longrightarrow>
   ir_valid P c c' (\<lambda>t t'. Q s s' \<and> (\<exists>s s'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'))"
  by(auto simp: ir_valid_def)

lemma ir_valid_If:
  "ir_valid (\<lambda>s s'. P s s') (IF b THEN c1 ELSE c2) c' Q \<Longrightarrow>
   ir_valid (\<lambda>s s'. P s s' \<and> bval b s) c1 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> bval b s)) \<and>
   ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) c2 c' (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> \<not> bval b s))"
  by(clarsimp simp: ir_valid_def, blast)

text \<open>
  Inspired by the
  ``@{text "p(n) = {\<sigma> | you can get back from \<sigma> to some state in p by executing C backwards n times}"}''
  part of OHearn~\<^cite>\<open>"OHearn_19"\<close>.
\<close>
primrec get_back where
  "get_back P b c 0 = (\<lambda>t t'. P t t')" |
  "get_back P b c (Suc n) = (\<lambda>t t'. \<exists>s. (c,s) \<Rightarrow> t \<and> bval b s \<and> get_back P b c n s t')"

(* Currently not used anywhere *)
lemma ir_valid_get_back:
  "ir_valid (get_back P b c (Suc k)) (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
proof(induct k)
  case 0
  then show ?case by(clarsimp simp: ir_valid_def, blast)
next
  case (Suc k)
  then show ?case  using  WhileTrue get_back.simps(2) ir_valid_def by smt
qed

(* both this an the next one get used in the completeness proof *)
lemma ir_valid_While1:
  "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
   (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c SKIP (\<lambda>t t'. get_back P b c (Suc k) t t' \<and> (\<exists>u u'. (WHILE b DO c,t) \<Rightarrow> u \<and> (c',t') \<Rightarrow> u' \<and> Q u u')))"
proof (subst ir_valid_def, clarsimp)
  fix t t' s u u'
  assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
         "(WHILE b DO c, t) \<Rightarrow> u"
         "(c, s) \<Rightarrow> t"
         "(c', t') \<Rightarrow> u'"
         "Q u u'"
         "bval b s"
         "get_back P b c k s t'"
  thus "\<exists>s. get_back P b c k s t' \<and> bval b s \<and> (c, s) \<Rightarrow> t"
  proof(induction k arbitrary: t t' s u u')
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    show ?case
      using Suc.prems(3) Suc.prems(6) Suc.prems(7) by blast
  qed
qed

lemma ir_valid_While3:
  "ir_valid (get_back P b c k) (WHILE b DO c) c' Q \<Longrightarrow>
   (ir_valid (\<lambda>s s'. get_back P b c k s s' \<and> bval b s) c c' (\<lambda>t t'. (\<exists>s'. (c',s') \<Rightarrow> t' \<and> get_back P b c (Suc k) t s' \<and> (\<exists>u. (WHILE b DO c,t) \<Rightarrow> u \<and>  Q u t'))))"
  apply(subst ir_valid_def, clarsimp)
proof -
  fix t t' s' s u
  assume "ir_valid (get_back P b c k) (WHILE b DO c) c' Q"
         "(WHILE b DO c, t) \<Rightarrow> u"
         "(c, s) \<Rightarrow> t"
         "(c', s') \<Rightarrow> t'"
         "Q u t'"
         "bval b s"
         "get_back P b c k s s'"
  thus "\<exists>s s'. get_back P b c k s s' \<and> bval b s \<and> (c, s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
  proof(induction k arbitrary: t t' s' s u)
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    show ?case
      using Suc.prems(3) Suc.prems(4) Suc.prems(6) Suc.prems(7) by blast
  qed
qed

(* not used anywhere *)
lemma ir_valid_While2:
   "ir_valid P (WHILE b DO c) c' Q \<Longrightarrow>
   ir_valid (\<lambda>s s'. P s s' \<and> \<not> bval b s) SKIP c' (\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c',s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval b t))"
  by(clarsimp simp: ir_valid_def, blast)

lemma assign_upd_blah:
  "(\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) = s"
  by(rule ext, auto)

lemma Assign_complete:
  assumes v: "ir_valid P (x1 ::= x2) c' Q"
  assumes q: "Q t t'"
  shows  "\<exists>s'. (\<exists>v. P (t(x1 := v)) s' \<and> t x1 = aval x2 (t(x1 := v))) \<and> (c', s') \<Rightarrow> t'"
proof -
  from v and q obtain s s' where a: "P s s' \<and> (x1 ::= x2,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t'"
    using ir_valid_def by smt
  hence "P (\<lambda>a. if a = x1 then s x1 else (s(x1 := aval x2 s)) a) s' \<and> aval x2 s = aval x2 (s(x1 := s x1))"
    using assign_upd_blah
    by simp
  thus ?thesis
    using assign_upd_blah a
    by (metis AssignE fun_upd_same fun_upd_triv fun_upd_upd)
qed

lemmas ir_Skip_sym = ir_sym[OF ir_Skip, simplified flip_def]

theorem completeness:
  "ir_valid P c c' Q \<Longrightarrow> ir_hoare P c c' Q"
proof(induct c arbitrary: P c' Q)
case SKIP
  show ?case
    apply(rule ir_Skip)
    using SKIP by(fastforce simp: ir_valid_def)
next
  case (Assign x1 x2)
  show ?case
    apply(rule ir_Assign)
    apply(rule ir_Skip)
    using Assign_complete Assign by blast
next
  case (Seq c1 c2)
  have a: "ir_hoare P c1 c' (\<lambda>t t'. \<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> (\<exists>u. (c2, t) \<Rightarrow> u \<and> Q u t'))"
    using ir_valid_Seq1 Seq by blast
  show ?case
    apply(rule ir_Seq1)
     apply (blast intro: a)
    apply(rule ir_Skip_sym)
    by(metis SeqE ir_valid_def Seq)
next
  case (If x1 c1 c2)
  have t: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c1 c'
      (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c1, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> bval x1 s))" and
       f: " ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval x1 s) c2 c'
      (\<lambda>t t'. Q t t' \<and> (\<exists>s s'. P s s' \<and> (c2, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t' \<and> \<not> bval x1 s))"
    using ir_valid_If If by blast+
  show ?case
    (* consider both cases of the if via conseq, disj, then _True and _False *)
    apply(rule ir_conseq)
      apply(rule ir_disj)
       apply(rule ir_If_True,fastforce intro: t)
      apply(rule ir_If_False, fastforce intro: f)
     apply blast
    by (smt IfE ir_valid_def If)
next
  case (While x1 c)
  have a: "\<And>n. ir_hoare (\<lambda>s s'. get_back P x1 c n s s' \<and> bval x1 s) c SKIP (get_back P x1 c (Suc n))"
    using ir_valid_While1  While
    by (smt get_back.simps(2) ir_valid_def meh_simp)
  have b: "ir_hoare (\<lambda>s s'. P s s' \<and> bval x1 s) c c'
                    (\<lambda>t t'.  \<exists>s'. (c', s') \<Rightarrow> t' \<and> (\<exists>s. (c, s) \<Rightarrow> t \<and> bval x1 s \<and> P s s') \<and>
                    (\<exists>u. (WHILE x1 DO c, t) \<Rightarrow> u \<and> Q u t'))"
    using ir_valid_While3[where k=0,simplified] While by blast
  have gb: "\<And>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t) \<Longrightarrow>
                    \<exists>s'. ((\<exists>n. get_back P x1 c n t s') \<and> \<not> bval x1 t) \<and> (c', s') \<Rightarrow> t'"
    by (meson get_back.simps(1))

  show ?case
    (* use the frontier rule much as in OHearn POPL *)
    apply(rule ir_conseq)
      apply(rule_tac P="get_back P x1 c" in ir_While_backwards_frontier)
       apply(blast intro: a)
      (* consider both cases of the While via conseq, disj, then _True and _False *)
      apply(rule ir_conseq)
        apply(rule ir_disj)
         apply(rule_tac P="\<lambda>s s'. \<exists>n. get_back P x1 c n s s'" and Q="(\<lambda>t t'. Q t t' \<and> (\<exists>s'. (c', s') \<Rightarrow> t' \<and> P t s' \<and> \<not> bval x1 t))" in ir_While_False)
         apply(rule ir_Skip, blast intro: gb)
        apply(rule ir_While_True)
        apply(rule ir_Seq1[OF b])
        apply(rule ir_Skip_sym)
        apply(fastforce)
       apply (metis get_back.simps(1))
      apply assumption
     apply simp
    by (metis While.prems WhileE ir_valid_def)
qed

section "A Decomposition Principle: Proofs via Under-Approximate Hoare Logic"

text \<open>
  We show the under-approximate analogue holds for Beringer's~\<^cite>\<open>"Beringer_11"\<close> decomposition
  principle for over-approximate relational logic.
\<close>

definition
  decomp :: "rassn \<Rightarrow> com \<Rightarrow> com \<Rightarrow> rassn \<Rightarrow> rassn" where
  "decomp P c c' Q \<equiv> \<lambda>t s'. \<exists>s t'. P s s' \<and> (c,s) \<Rightarrow> t \<and> (c',s') \<Rightarrow> t' \<and> Q t t'"

lemma ir_valid_decomp1:
  "ir_valid P c c' Q \<Longrightarrow> ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q"
  by(fastforce simp: ir_valid_def meh_simp decomp_def)

lemma ir_valid_decomp2:
  "ir_valid P c SKIP R \<and> ir_valid R SKIP c' Q \<Longrightarrow> ir_valid P c c' Q"
  by(fastforce simp: ir_valid_def meh_simp decomp_def)

lemma ir_valid_decomp:
  "ir_valid P c c' Q = (ir_valid P c SKIP (decomp P c c' Q) \<and> ir_valid (decomp P c c' Q) SKIP c' Q)"
  using ir_valid_decomp1 ir_valid_decomp2 by blast

text \<open>
  Completeness with soundness means we can prove proof rules about @{term ir_hoare} in terms
  of @{term ir_valid}.
\<close>

lemma ir_to_Skip:
  "ir_hoare P c c' Q = (ir_hoare P c SKIP (decomp P c c' Q) \<and> ir_hoare (decomp P c c' Q) SKIP c' Q)"
  using soundness completeness ir_valid_decomp
  by meson

text \<open>
  O'Hearn's under-approximate Hoare triple, for the ``ok'' case (since that is the only case we have)
  This is also likely the same as from the "Reverse Hoare Logic" paper (SEFM).
\<close>
type_synonym assn = "state \<Rightarrow> bool"
definition
  ohearn :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool"
  where
  "ohearn P c Q \<equiv> (\<forall>t. Q t \<longrightarrow> (\<exists>s. P s \<and> (c,s) \<Rightarrow> t))"

lemma fold_ohearn2:
  "ir_valid P SKIP c' Q = (\<forall>t. ohearn (P t) c' (Q t))"
  by(simp add: ir_valid_def ohearn_def)

theorem relational_via_hoare:
  "ir_hoare P c c' Q = ((\<forall>t'. ohearn (\<lambda>t. P t t') c (\<lambda>t. decomp P c c' Q t t')) \<and> (\<forall>t. ohearn (decomp P c c' Q t) c' (Q t)))"
proof -
  have a: "\<And>P c c' Q. ir_hoare P c c' Q = ir_valid P c c' Q"
    using soundness completeness by auto
  show ?thesis
    using ir_to_Skip a fold_ohearn1 fold_ohearn2 by metis
qed

section "Deriving Proof Rules from Completeness"

text \<open>
  Note that we can more easily derive proof rules sometimes by appealing to the
   corresponding properties of @{term ir_valid} than from the proof rules directly.

  We see more examples of this later on when we consider examples.
\<close>

lemma ir_Seq2:
  "ir_hoare P c SKIP Q \<Longrightarrow> ir_hoare Q d c' R \<Longrightarrow> ir_hoare P (Seq c d) c' R"
  using soundness completeness Seq2_ir_valid by metis

lemma ir_Seq:
  "ir_hoare P c c' Q \<Longrightarrow> ir_hoare Q d d' R \<Longrightarrow> ir_hoare P (Seq c d) (Seq c' d') R"
  using soundness completeness Seq_ir_valid by metis

section "Examples"

subsection "Some Derived Proof Rules"

text \<open>
First derive some proof rules -- here not by appealing to completeness but just using
the existing rules
\<close>

lemma ir_If_True_False:
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> \<not> bval b' s') c\<^sub>1 c\<^sub>2' Q \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') Q"
  apply(rule ir_If_True)
  apply(rule ir_sym)
  apply(rule ir_If_False)
  apply(rule ir_sym)
  by(simp add: flip_def)

lemma ir_Assign_Assign:
  "ir_hoare P (x ::= e) (x' ::= e') (\<lambda>t t'. \<exists>v v'. P (t(x := v)) (t'(x' := v')) \<and> t x = aval e (t(x := v)) \<and> t' x' = aval e' (t'(x' := v')))"
  apply(rule ir_Assign)
  apply(rule ir_sym)
  apply(rule ir_Assign)
  by(simp add: flip_def, auto)

subsection "prog1"

text \<open>
  A tiny insecure program. Note that we only need to reason on one path through this program to
  detect that it is insecure.
\<close>

abbreviation low_eq :: rassn where "low_eq s s' \<equiv> s ''low'' = s' ''low''"
abbreviation low_neq :: rassn where "low_neq s s' \<equiv> \<not> low_eq s s'"
definition prog1 :: com where
  "prog1 \<equiv> (IF (Less (N 0) (V ''x'')) THEN (Assign ''low'' (N 1)) ELSE (Assign ''low'' (N 0)))"

text \<open>
  We prove that @{term prog1} is definitely insecure. To do that, we need to find some non-empty
  post-relation that implies insecurity. The following property encodes the idea that the
  post-relation is non-empty, i.e. represents a feasible pair of execution paths.
\<close>
definition
  nontrivial :: "rassn \<Rightarrow> bool"
  where
  "nontrivial Q \<equiv> (\<exists>t t'. Q t t')"

text \<open>
  Note the property we prove here explicitly encodes the fact that the postcondition can be anything
  that implies insecurity, i.e. implies @{term low_neq}. In particular we should not necessarily
  expect it to cover the entirely of all states that satisfy @{term low_neq}.

  Also note that we also have to prove that the postcondition is non-trivial. This is necessary to
  make sure that the violation we find is not an infeasible path.
\<close>
lemma prog1:
  "\<exists>Q. ir_hoare low_eq prog1 prog1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI)
  apply(rule conjI)
   apply(simp add: prog1_def)
   apply(rule ir_If_True_False)
   apply(rule ir_Assign_Assign)
  apply(rule conjI)
   apply auto[1]
  apply(clarsimp simp: nontrivial_def)
  apply(rule_tac x="\<lambda>v. 1" in exI)
  apply simp
  apply(rule_tac x="\<lambda>v. 0" in exI)
  by auto

subsection "More Derived Proof Rules for Examples"

definition BEq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
  "BEq a b \<equiv> And (Less a (Plus b (N 1))) (Less b (Plus a (N 1)))"

lemma BEq_aval[simp]:
  "bval (BEq a b) s = ((aval a s) = (aval b s))"
  by(auto simp add: BEq_def)

lemma ir_If_True_True:
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t')"
  by(simp add: ir_If_True ir_sym flip_def)

lemma ir_If_False_False:
  "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>2 t t')"
  by(simp add: ir_If_False ir_sym flip_def)

lemma ir_If':
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') c\<^sub>1 c\<^sub>1' Q\<^sub>1 \<Longrightarrow>
   ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') c\<^sub>2 c\<^sub>2' Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (IF b THEN c\<^sub>1 ELSE c\<^sub>2) (IF b' THEN c\<^sub>1' ELSE c\<^sub>2') (\<lambda>t t'. Q\<^sub>1 t t' \<or> Q\<^sub>2 t t')"
  apply(rule ir_pre)
   apply(rule ir_disj)
    apply(rule ir_If_True_True)
    apply assumption
   apply(rule ir_If_False_False)
   apply assumption
  apply blast
  done

lemma ir_While_triv:
  "ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>2 s s'))"
  by(simp add: ir_While_False ir_sym flip_def)

lemma ir_While':
  "ir_hoare (\<lambda>s s'. P s s' \<and> bval b s \<and> bval b' s') (c;;WHILE b DO c) (c';;WHILE b' DO c') Q\<^sub>1 \<Longrightarrow>
   ir_hoare (\<lambda>s s'. P s s' \<and> \<not> bval b s \<and> \<not> bval b' s') SKIP SKIP Q\<^sub>2 \<Longrightarrow>
   ir_hoare P (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. (Q\<^sub>1 s s' \<or> Q\<^sub>2 s s'))"
  apply(rule ir_pre)
   apply(rule ir_disj)
     apply(rule ir_While_True)
     apply(rule ir_sym)
     apply(simp add: flip_def)
     apply(rule ir_While_True)
     apply(rule ir_sym)
    apply(simp add: flip_def)
   apply(rule ir_While_triv)
   apply assumption
  apply simp
  done

subsection "client0"

definition low_eq_strong where
  "low_eq_strong s s' \<equiv> (s ''high'' \<noteq> s' ''high'') \<and> low_eq s s'"

lemma low_eq_strong_upd[simp]:
  "var \<noteq> ''high'' \<and> var \<noteq> ''low'' \<Longrightarrow> low_eq_strong(s(var := v)) (s'(var := v')) = low_eq_strong s s'"
  by(auto simp: low_eq_strong_def)

text \<open>
  A variation on client0 from O'Hearn~\<^cite>\<open>"OHearn_19"\<close>: how to reason about loops via a single unfolding
\<close>
definition client0 :: com where
  "client0 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (N 0) (V ''n''))
                     ((Assign ''x'' (Plus (V ''x'') (V ''n'')));;
                      (Assign ''n'' (V ''nondet''))));;
              (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"

lemma client0:
  "\<exists>Q. ir_hoare low_eq client0 client0 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client0_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
    apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
     apply clarsimp

    apply(rule ir_While')
      apply clarsimp

      apply(rule ir_Seq)
       apply(rule ir_Seq)
        apply(rule ir_Assign_Assign)
       apply(rule ir_Assign_Assign)
      apply clarsimp

      apply(rule ir_While_triv)
      apply clarsimp
      apply assumption

     apply clarsimp
     apply assumption

    apply(rule ir_If_True_True)
    apply(rule ir_Assign_Assign)
   apply(fastforce simp: low_eq_strong_def)
  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then -1 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

(* Not needed? *)
lemma ir_While_backwards:
  "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s) c SKIP (P (Suc n))) \<Longrightarrow>
                       ir_hoare (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s) SKIP c' Q \<Longrightarrow>
                       ir_hoare (P 0) (WHILE b DO c) c' Q"
  apply(rule ir_While_backwards_frontier)
   apply assumption
  apply(rule ir_While_False)
  apply auto
  done

subsection "Derive a variant of the backwards variant rule"

text \<open>Here we appeal to completeness again to derive this rule from the corresponding
        property about @{term ir_valid}.\<close>

subsection "A variant of the frontier rule"

text \<open>
  Agin we derive this rule by appealing to completeness and the corresponding property of
  @{term ir_valid}
\<close>

lemma While_backwards_frontier_both_ir_valid':
  assumes asm: "\<And>n. \<forall>t t'. P (k + Suc n) t t' \<longrightarrow>
                    (\<exists>s s'. P (k + n) s s' \<and> bval b s \<and> bval b' s' \<and> (c, s) \<Rightarrow> t \<and> (c', s') \<Rightarrow> t')"
  assumes last: "\<forall>t t'. Q t t' \<longrightarrow> (\<exists>s s'. (\<exists>n. P (k + n) s s') \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t')"
  assumes post: "Q t t'"
  shows "\<exists>s s'. P k s s' \<and> (WHILE b DO c, s) \<Rightarrow> t \<and> (WHILE b' DO c', s') \<Rightarrow> t'"
proof -
  from post last obtain s s' n where
    "P (k + n) s s'" "(WHILE b DO c, s) \<Rightarrow> t" "(WHILE b' DO c', s') \<Rightarrow> t'"
    by blast
  with asm  show ?thesis
  proof(induction n arbitrary: k t t')
    case 0
    then show ?case
      by (metis WhileFalse WhileTrue add.right_neutral)
  next
    case (Suc n)
    from Suc
    obtain r r' where final_iteration: "P (Suc k) r r'" "(WHILE b DO c, r) \<Rightarrow> t" "(WHILE b' DO c', r') \<Rightarrow> t'"
      by (metis add_Suc_shift)
    from final_iteration(1) obtain q q' where
     "P k q q' \<and> bval b q \<and> bval b' q' \<and> (c, q) \<Rightarrow> r \<and> (c', q') \<Rightarrow> r'"
      by (metis Nat.add_0_right Suc.prems(1) plus_1_eq_Suc semiring_normalization_rules(24))
    with final_iteration show ?case by blast
  qed
qed

lemma While_backwards_frontier_both_ir_valid[intro]:
  "(\<And>n. ir_valid (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
   ir_valid (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q \<Longrightarrow>
   ir_valid (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
  by(auto simp: ir_valid_def intro: While_backwards_frontier_both_ir_valid')

lemma ir_While_backwards_frontier_both:
  "\<lbrakk>\<And>n. ir_hoare (\<lambda>s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n));
   ir_hoare (\<lambda>s s'. \<exists>n. P n s s') (WHILE b DO c) (WHILE b' DO c') Q\<rbrakk>
   \<Longrightarrow> ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. Q s s')"
  using soundness completeness While_backwards_frontier_both_ir_valid by auto

text \<open>
  The following rule then follows easily as a special case
\<close>
lemma ir_While_backwards_both:
  "(\<And>n. ir_hoare (\<lambda> s s'. P n s s' \<and> bval b s \<and> bval b' s') c c' (P (Suc n))) \<Longrightarrow>
                       ir_hoare (P 0) (WHILE b DO c) (WHILE b' DO c') (\<lambda>s s'. \<exists>n. P n s s' \<and> \<not> bval b s \<and> \<not> bval b' s')"
  apply(rule ir_While_backwards_frontier_both)
   apply blast
  by(simp add: ir_While_False ir_sym flip_def)

subsection "client1"

text \<open>
  An example roughly equivalent to cient1 from O'Hearn~\<^cite>\<open>"OHearn_19"\<close>0

  In particular we use the backwards variant rule to reason about the loop.
\<close>
definition client1 :: com where
  "client1 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (V ''x'') (V ''n''))
                     ((Assign ''x'' (Plus (V ''x'') (N 1)))));;
              (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))"

lemma client1:
  "\<exists>Q. ir_hoare low_eq client1 client1 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client1_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
    apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
     apply clarsimp

  apply(rule ir_pre)
      apply(rule ir_While_backwards_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> int n \<le> s ''n'' \<and> int n \<le> s' ''n''"])
      apply(rule ir_post)
       apply(rule ir_Assign_Assign)
      apply clarsimp

     apply clarsimp

    apply(rule ir_If_True_True)
    apply(rule ir_Assign_Assign)
   apply(fastforce simp: low_eq_strong_def)
  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  apply clarsimp
  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 2000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

subsection "client2"

text \<open>
  An example akin to client2 from O'Hearn~\<^cite>\<open>"OHearn_19"\<close>.

  Note that this example is carefully written to show use of the frontier rule first to
  reason up to the broken loop iteration, and then we unfold the loop at that point to
  reason about the broken iteration, and then use the plain backwards variant rule to
  reason over the remainder of the loop.
\<close>
definition client2 :: com where
  "client2 \<equiv> (Assign ''x'' (N 0);;
              (While (Less (V ''x'') (N 4000000))
                     ((Assign ''x'' (Plus (V ''x'') (N 1)));;
                       (If (BEq (V ''x'') (N 2000000)) (Assign ''low'' (V ''high'')) SKIP))
                       )
              )"

lemma client2:
  "\<exists>Q. ir_hoare low_eq client2 client2 Q \<and> (\<forall>s s'. Q s s' \<longrightarrow> low_neq s s') \<and> nontrivial Q"
  apply(rule exI, rule conjI, simp add: client2_def)
   apply(rule_tac P=low_eq_strong in ir_pre)
   apply(rule ir_Seq)
     apply(rule ir_Assign_Assign)
    apply clarsimp

  apply(rule ir_pre)
     apply(rule ir_While_backwards_frontier_both[where P="\<lambda>n s s'. low_eq_strong s s' \<and> s ''x'' = int n \<and> s' ''x'' = int n \<and> s ''x'' \<ge> 0 \<and> s ''x'' \<le> 2000000 - 1 \<and> s' ''x'' \<ge> 0 \<and> s' ''x'' \<le> 2000000 - 1"])
      apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
  apply clarsimp
      apply(rule ir_post)
       apply(rule ir_If')
        apply(rule ir_Assign_Assign)
       apply(rule ir_Skip_Skip)
      apply clarsimp

     apply clarsimp
     apply(rule ir_While')
      apply clarsimp
      apply(rule ir_Seq)
       apply(rule ir_Seq)
       apply(rule ir_Assign_Assign)
      apply(rule ir_If_True_True)
      apply(rule ir_Assign_Assign)
     apply clarsimp

  apply(rule ir_pre)
     apply(rule ir_While_backwards_both[where P="\<lambda>n s s'.  s ''x'' = 2000000 + int n \<and> s' ''x'' = 2000000 + int n \<and> s ''x'' \<ge> 2000000 \<and> s ''x'' \<le> 4000000 \<and> s' ''x'' \<ge> 2000000 \<and> s' ''x'' \<le> 4000000 \<and> s ''low'' = s ''high'' \<and> s' ''low'' = s' ''high'' \<and> s ''high'' \<noteq> s' ''high''"])

     apply(rule ir_Seq)
      apply(rule ir_Assign_Assign)
      apply(rule ir_If_False_False)
       apply fastforce
      apply (fastforce simp: low_eq_strong_def)
     apply fastforce
    apply(fastforce simp: low_eq_strong_def)
   apply(fastforce simp: low_eq_strong_def)

  apply(rule conjI)
   apply(clarsimp simp: low_eq_strong_def split: if_splits)

  apply clarsimp
  (* ugh having to manually do constraint solving here... *)
  apply(clarsimp simp: low_eq_strong_def nontrivial_def)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 1 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 1 else undefined" in exI)
  apply(rule_tac x="\<lambda>v. if v = ''x'' then 4000000 else if v = ''high'' then 0 else if v = ''n'' then 2000000 else if v = ''nondet'' then -1 else if v = ''low'' then 0 else undefined" in exI)
  apply clarsimp
  done

end


section \<open>Dichotomous Lazard\<close>

text \<open>This theory contains Lazard's optimization in the computation of
  the subresultant PRS as described by Ducos \<^cite>\<open>\<open>Section 2\<close> in "Ducos"\<close>.\<close>
theory Dichotomous_Lazard
imports
  "HOL-Computational_Algebra.Polynomial_Factorial" (* to_fract *)
begin

lemma power_fract[simp]: "(Fract a b)^n = Fract (a^n) (b^n)"
  by (induct n, auto simp: fract_collapse)

lemma range_to_fract_dvd_iff: assumes b: "b \<noteq> 0"
  shows "Fract a b \<in> range to_fract \<longleftrightarrow> b dvd a"
proof
  assume "b dvd a" then obtain c where a: "a = b * c" unfolding dvd_def by auto
  have "Fract a b = Fract c 1" using b unfolding a by (simp add: eq_fract)
  thus "Fract a b \<in> range to_fract" unfolding to_fract_def by auto
next
  assume "Fract a b \<in> range to_fract"
  then obtain c where "Fract a b = Fract c 1" unfolding to_fract_def by auto
  hence "a = b * c" using b by (simp add: eq_fract)
  thus "b dvd a" ..
qed

lemma Fract_cases_coprime [cases type: fract]:
  fixes q :: "'a :: factorial_ring_gcd fract"
  obtains (Fract) a b where "q = Fract a b" "b \<noteq> 0" "coprime a b"
proof -
  obtain a b where q: "q = Fract a b" and b0: "b \<noteq> 0" by (cases q, auto)
  define g where g: "g = gcd a b"
  define A where A: "A = a div g"
  define B where B: "B = b div g"
  have a: "a = A * g" unfolding A g by simp
  have b: "b = B * g" unfolding B g by simp
  from b0 b have 0: "B \<noteq> 0" by auto
  have q: "q = Fract A B" unfolding q a b
    by (subst eq_fract, auto simp: b0 0 g)
  have cop: "coprime A B" unfolding A B g using b0
    by (simp add: div_gcd_coprime)
  assume "\<And>a b. q = Fract a b \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> thesis"
  from this[OF q 0 cop] show ?thesis .
qed

fun dichotomous_Lazard :: "'a :: idom_divide \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "dichotomous_Lazard x y n = (if n \<le> 1 then if n = 1 then x else 1 else
    let (d,r) = Euclidean_Rings.divmod_nat n 2;
       rec = dichotomous_Lazard x y d;
       recsq = rec * rec div y in
    if r = 0 then recsq else recsq * x div y)"

lemma dichotomous_Lazard_main: fixes x :: "'a :: idom_divide"
  assumes "\<And> i. i \<le> n \<Longrightarrow> (to_fract x)^i / (to_fract y)^(i - 1) \<in> range to_fract"
  shows "to_fract (dichotomous_Lazard x y n) = (to_fract x)^n / (to_fract y)^(n-1)"
  using assms
proof (induct x y n rule: dichotomous_Lazard.induct)
  case (1 x y n)
  let ?f = to_fract
  consider (0) "n = 0" | (1) "n = 1" | (n) "\<not> n \<le> 1" by linarith
  thus ?case
  proof cases
    case n
    obtain d r where n2: "Euclidean_Rings.divmod_nat n 2 = (d,r)" by force
    from Euclidean_Rings.divmod_nat_def[of n 2] n2 have dr: "d = n div 2" "r = n mod 2" by auto
    hence r: "r = 0 \<or> r = 1" by auto
    define rec where "rec = dichotomous_Lazard x y d"
    let ?sq = "rec * rec div y"
    have res: "dichotomous_Lazard x y n = (if r = 0 then ?sq else ?sq * x div y)"
      unfolding dichotomous_Lazard.simps[of x y n] n2 Let_def rec_def using n by auto
    have ndr: "n = d + d + r" unfolding dr by presburger
    from ndr r n have d0: "d \<noteq> 0" by auto
    have IH: "?f rec = ?f x ^ d / ?f y ^ (d - 1)"
      using 1(1)[OF n refl n2[symmetric] 1(2), folded rec_def] ndr by auto
    have "?f (rec * rec) = ?f x ^ d / ?f y ^ (d - 1) * ?f x ^ d / ?f y ^ (d - 1)" using IH by simp
    also have "\<dots> = ?f x ^ (d + d) / ?f y ^ (d - 1 + (d - 1))" unfolding power_add by simp
    also have "d - 1 + (d - 1) = d + d - 2" using d0 by simp
    finally have id: "?f (rec * rec) = ?f x ^ (d + d) / ?f y ^ (d + d - 2)"  .
    let ?dd = "(?f x ^ (d + d) / ?f y ^ (d + d - 2)) / ?f y"
    let ?d = "?f x ^ (d + d) / ?f y ^ (d + d - 1)"
    have dd: "?dd = ?d" using d0 by (cases d, auto)
    have sq: "?f ?sq = ?d" unfolding dd[symmetric]
    proof (rule sym, rule div_divide_to_fract[OF _ refl refl id[symmetric] refl], unfold dd)
      show "?d \<in> range ?f" by (rule 1(2), insert ndr, auto)
    qed
    show ?thesis
    proof (cases "r = 0")
      case True
      with res sq show ?thesis unfolding ndr by auto
    next
      case False
      with r have r: "r = 1" by auto
      let ?sq' = "?sq * x div y"
      from False res have res: "dichotomous_Lazard x y n = ?sq'" by simp
      from sq have id: "?f (?sq * x) = ?f x ^ (d + d + r) / ?f y ^ (d + d - 1)"
        unfolding r by simp
      let ?dd = "(?f x ^ (d + d + r) / ?f y ^ (d + d - 1)) / ?f y"
      let ?d = "?f x ^ (d + d + r) / ?f y ^ (d + d + r - 1)"
      have dd: "?dd = ?d" using d0 unfolding r by (cases d, auto)
      have sq': "?f ?sq' = ?d" unfolding dd[symmetric]
      proof (rule sym, rule div_divide_to_fract[OF _ refl refl id[symmetric] refl], unfold dd)
        show "?d \<in> range ?f" by (rule 1(2), unfold ndr, auto)
      qed
      show ?thesis unfolding res sq' unfolding ndr by simp
    qed
  qed auto
qed

lemma dichotomous_Lazard: fixes x :: "'a :: factorial_ring_gcd"
  assumes "(to_fract x)^n / (to_fract y)^(n-1) \<in> range to_fract"
  shows "to_fract (dichotomous_Lazard x y n) = (to_fract x)^n / (to_fract y)^(n-1)"
proof (rule dichotomous_Lazard_main)
  fix i
  assume i: "i \<le> n"
  show "to_fract x ^ i / to_fract y ^ (i - 1) \<in> range to_fract"
  proof (cases i)
    case (Suc j)
    have id: "to_fract x ^ i / to_fract y ^ (i - 1) = to_fract x * (to_fract x / to_fract y) ^ j"
      unfolding Suc by (simp add: power_divide)
    from Suc i have "n \<noteq> 0" and j: "j \<le> n - 1" by auto
    hence idd: "to_fract x * (to_fract x / to_fract y) ^ (n - 1) = (to_fract x)^n / (to_fract y)^(n-1)"
      by (cases n, auto simp: power_divide)
    show ?thesis unfolding id
      by (rule to_fract_power_le[OF _ _ j], unfold idd, insert assms, auto)
  next
    case 0
    have "1 = to_fract 1" by simp
    hence "1 \<in> range to_fract" by blast
    thus ?thesis using 0 by auto
  qed
qed

declare dichotomous_Lazard.simps[simp del]

end