(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Deep Learning Networks\<close>

theory DL_Network
imports Tensor_Product
  Jordan_Normal_Form.Matrix Tensor_Unit_Vec DL_Flatten_Matrix
  Jordan_Normal_Form.DL_Missing_List
begin

text \<open>This symbol is used for the Tensor product:\<close>
no_notation Group.monoid.mult (infixl "\<otimes>\<index>" 70)

notation Matrix.unit_vec ("unit\<^sub>v")
hide_const (open) Matrix.unit_vec

datatype 'a convnet = Input nat | Conv 'a "'a convnet" | Pool "'a convnet" "'a convnet"

fun input_sizes :: "'a convnet \<Rightarrow> nat list" where
"input_sizes (Input M) = [M]" |
"input_sizes (Conv A m) = input_sizes m" |
"input_sizes (Pool m1 m2) = input_sizes m1 @ input_sizes m2"

fun count_weights :: "bool \<Rightarrow> (nat \<times> nat) convnet \<Rightarrow> nat" where
"count_weights shared (Input M) = 0" |
"count_weights shared (Conv (r0, r1) m) = r0 * r1 + count_weights shared m" |
"count_weights shared (Pool m1 m2) =
  (if shared
    then max (count_weights shared m1) (count_weights shared m2)
    else count_weights shared m1 + count_weights shared m2)"

fun output_size :: "(nat \<times> nat) convnet \<Rightarrow> nat" where
"output_size (Input M) = M" |
"output_size (Conv (r0,r1) m) = r0" |
"output_size (Pool m1 m2) = output_size m1"

inductive valid_net :: "(nat\<times>nat) convnet \<Rightarrow> bool" where
"valid_net (Input M)" |
"output_size m = r1 \<Longrightarrow> valid_net m \<Longrightarrow> valid_net (Conv (r0,r1) m)" |
"output_size m1 = output_size m2 \<Longrightarrow> valid_net m1 \<Longrightarrow> valid_net m2 \<Longrightarrow> valid_net (Pool m1 m2)"

fun insert_weights :: "bool \<Rightarrow> (nat \<times> nat) convnet \<Rightarrow> (nat \<Rightarrow> real) \<Rightarrow> real mat convnet" where
"insert_weights shared (Input M) w = Input M" |
"insert_weights shared (Conv (r0,r1) m) w = Conv
  (extract_matrix w r0 r1)
  (insert_weights shared m (\<lambda>i. w (i+r0*r1)))" |
"insert_weights shared (Pool m1 m2) w = Pool
  (insert_weights shared m1 w)
  (insert_weights shared m2 (if shared then w else (\<lambda>i. w (i+(count_weights shared m1)))))"

fun remove_weights :: "real mat convnet \<Rightarrow> (nat \<times> nat) convnet" where
"remove_weights (Input M) = Input M" |
"remove_weights (Conv A m) = Conv (dim_row A, dim_col A) (remove_weights m)" |
"remove_weights (Pool m1 m2) = Pool (remove_weights m1) (remove_weights m2)"

abbreviation "output_size' == (\<lambda>m. output_size (remove_weights m))"
abbreviation "valid_net' == (\<lambda>m. valid_net (remove_weights m))"

fun evaluate_net :: "real mat convnet \<Rightarrow> real vec list \<Rightarrow> real vec" where
"evaluate_net (Input M) inputs = hd inputs" |
"evaluate_net (Conv A m) inputs = A *\<^sub>v evaluate_net m inputs" |
"evaluate_net (Pool m1 m2) inputs = component_mult
  (evaluate_net m1 (take (length (input_sizes m1)) inputs))
  (evaluate_net m2 (drop (length (input_sizes m1)) inputs))"

definition mat_tensorlist_mult :: "real mat \<Rightarrow> real tensor vec \<Rightarrow> nat list \<Rightarrow> real tensor vec"
where "mat_tensorlist_mult A Ts ds
 = Matrix.vec (dim_row A) (\<lambda>j. tensor_from_lookup ds (\<lambda>is. (A *\<^sub>v (map_vec (\<lambda>T. Tensor.lookup T is) Ts)) $j))"

lemma insert_weights_cong:
assumes "(\<And>i. i<count_weights s m \<Longrightarrow> w1 i = w2 i)"
shows "insert_weights s m w1 = insert_weights s m w2"
using assms proof (induction m arbitrary: w1 w2)
  case Input
  then show ?case by simp
next
  case (Conv r01 m)
  then obtain r0 r1 where "r01 = (r0,r1)" by (meson surj_pair)
  have 2:"insert_weights s m (\<lambda>i. w1 (i + r0 * r1)) = insert_weights s m (\<lambda>i. w2 (i + r0 * r1))" using Conv
    using \<open>r01 = (r0, r1)\<close> add.commute add_less_cancel_right count_weights.simps(2) by fastforce
  then show ?case unfolding \<open>r01 = (r0,r1)\<close> insert_weights.simps
    by (metis Conv.prems \<open>r01 = (r0, r1)\<close> count_weights.simps(2) extract_matrix_cong trans_less_add1)
next
  case (Pool m1 m2)
  have 1:"insert_weights s m1 w1 = insert_weights s m1 w2"
    using Pool(1)[of w1 w2] Pool(3)[unfolded count_weights.simps]
    by (cases s; auto)
  have shared:"s=True \<Longrightarrow> insert_weights s m2 w1 = insert_weights s m2 w2"
    using Pool(2)[of w1 w2] Pool(3)[unfolded count_weights.simps] by auto
  have unshared:"s=False \<Longrightarrow> insert_weights s m2 (\<lambda>i. w1 (i + count_weights s m1)) = insert_weights s m2 (\<lambda>i. w2 (i + count_weights s m1))"
    using Pool(2) Pool(3) count_weights.simps by fastforce
  show ?case unfolding insert_weights.simps 1 using unshared shared by simp
qed

lemma dims_mat_tensorlist_mult:
assumes "T\<in>set\<^sub>v (mat_tensorlist_mult A Ts ds)"
shows "Tensor.dims T = ds"
proof -
  obtain j where "T = tensor_from_lookup ds (\<lambda>is. (A *\<^sub>v (map_vec (\<lambda>T. Tensor.lookup T is) Ts)) $j)"
    using vec_setE[OF assms, unfolded mat_tensorlist_mult_def] by (metis dim_vec index_vec)
  then show ?thesis by (simp add: length_tensor_vec_from_lookup tensor_from_lookup_def)
qed

fun tensors_from_net :: "real mat convnet \<Rightarrow> real tensor vec" where
"tensors_from_net (Input M) = Matrix.vec M (\<lambda>i. unit_vec M i)" |
"tensors_from_net (Conv A m) = mat_tensorlist_mult A (tensors_from_net m) (input_sizes m)" |
"tensors_from_net (Pool m1 m2) = component_mult (tensors_from_net m1) (tensors_from_net m2)"

lemma output_size_correct_tensors:
assumes "valid_net' m"
shows "output_size' m = dim_vec (tensors_from_net m)"
using assms proof (induction m)
  case Input
  then show ?case by simp
next
  case (Conv A m)
  then show ?case
    unfolding remove_weights.simps output_size.simps tensors_from_net.simps
    using mat_tensorlist_mult_def by auto
next
  case (Pool m1 m2)
  then show ?case by (metis convnet.distinct(3) convnet.distinct(5) convnet.inject(3) dim_component_mult
    min.idem output_size.simps(3) remove_weights.simps(3) tensors_from_net.simps(3) valid_net.simps)
qed

lemma output_size_correct:
assumes "valid_net' m"
and "map dim_vec inputs = input_sizes m"
shows "output_size' m = dim_vec (evaluate_net m inputs)"
using assms proof (induction m arbitrary:inputs)
  case Input
  then show ?case using length_Cons list.map_sel(1) list.sel(1) list.simps(8) list.size(3) nat.simps(3) by auto
next
  case (Conv A m)
  then show ?case unfolding evaluate_net.simps remove_weights.simps output_size.simps dim_mult_mat_vec
    by auto
next
  case (Pool m1 m2)
  then have "valid_net' m1" "valid_net' m2"
    using convnet.distinct(3) convnet.distinct(5) convnet.inject(3) remove_weights.simps(3) valid_net.cases by fastforce+
  moreover have "map dim_vec (take (length (input_sizes m1)) inputs) = input_sizes m1"
       "map dim_vec (drop (length (input_sizes m1)) inputs) = input_sizes m2"
    using Pool.prems(2) by (metis append_eq_conv_conj drop_map input_sizes.simps(3) take_map)+
  ultimately have
    "output_size' m1 = dim_vec (evaluate_net m1 (take (length (input_sizes m1)) inputs))"
    "output_size' m2 = dim_vec (evaluate_net m2 (drop (length (input_sizes m1)) inputs))"
    using Pool.IH by blast+
  then show ?case unfolding evaluate_net.simps remove_weights.simps output_size.simps
    by (metis Pool.prems(1) \<open>valid_net' m1\<close> \<open>valid_net' m2\<close> dim_component_mult
     output_size.simps(3) output_size_correct_tensors remove_weights.simps(3) tensors_from_net.simps(3))
qed

lemma input_sizes_remove_weights: "input_sizes m = input_sizes (remove_weights m)"
  by (induction m; simp)

lemma dims_tensors_from_net:
assumes "T \<in> set\<^sub>v (tensors_from_net m)"
shows "Tensor.dims T = input_sizes m"
using assms proof (induction m arbitrary:T)
  case (Input M)
  then obtain j where "T = unit_vec M j"
    using vec_setE tensors_from_net.simps(1) by (metis dim_vec index_vec)
  then show ?case by (simp add: dims_unit_vec)
next
  case (Conv A m)
  then show ?case unfolding remove_weights.simps input_sizes.simps
    using dims_mat_tensorlist_mult by (simp add: input_sizes_remove_weights)
next
  case (Pool m1 m2 T)
  then obtain i where
    "component_mult (tensors_from_net m1) (tensors_from_net m2) $ i = T"
    "i < dim_vec (tensors_from_net m1)" "i < dim_vec (tensors_from_net m2)"
    using tensors_from_net.simps vec_setE dim_component_mult by (metis min.strict_boundedE)
  then obtain T1 T2 where "T = T1 \<otimes> T2" "T1 \<in> set\<^sub>v (tensors_from_net m1)" "T2 \<in> set\<^sub>v (tensors_from_net m2)"
    using vec_setI by (metis index_component_mult)
  then show ?case unfolding remove_weights.simps input_sizes.simps by (simp add: Pool.IH(1) Pool.IH(2))
qed

definition base_input :: "real mat convnet \<Rightarrow> nat list \<Rightarrow> real vec list" where
"base_input m is = (map (\<lambda>(n, i). unit\<^sub>v n i) (zip (input_sizes m) is))"

lemma base_input_length:
assumes "is \<lhd> input_sizes m"
shows "input_sizes m = map dim_vec (base_input m is)"
proof (rule nth_equalityI)
  have "length (input_sizes m) = length is" using assms valid_index_length by auto
  then show "length (input_sizes m) = length (map dim_vec (base_input m is))" unfolding base_input_def by auto
  {
    fix i
    assume "i<length (input_sizes m)"
    then have "map (\<lambda>(n, i). unit\<^sub>v n i) (zip (input_sizes m) is) ! i = unit\<^sub>v (input_sizes m ! i) (is ! i)"
      using \<open>length (input_sizes m) = length is\<close> by auto
    then have "input_sizes m ! i = map dim_vec (base_input m is) ! i" unfolding base_input_def using index_unit_vec(3)
      using \<open>i < length (input_sizes m)\<close> \<open>length (input_sizes m) = length (map dim_vec (base_input m is))\<close>
       base_input_def assms length_map nth_map valid_index_lt by (simp add: input_sizes_remove_weights)
  }
  then show "\<And>i. i < length (input_sizes m) \<Longrightarrow> input_sizes m ! i = map dim_vec (base_input m is) ! i" by auto
qed

lemma nth_mat_tensorlist_mult:
assumes "\<And>A. A\<in>set\<^sub>v Ts \<Longrightarrow> dims A = ds"
assumes "i < dim_row A"
assumes "dim_vec Ts = dim_col A"
shows "mat_tensorlist_mult A Ts ds $ i = listsum ds (map (\<lambda>j. (A $$ (i,j)) \<cdot> Ts $ j) [0..<dim_vec Ts])"
  (is "_ = listsum ds ?Ts'")
proof (rule tensor_lookup_eqI)
  have dims_Ts':"\<And>T. T\<in>set ?Ts' \<Longrightarrow> dims T = ds"
  proof -
    fix T assume "T\<in>set ?Ts'"
    then obtain k where "T = ?Ts' ! k" and "k < length ?Ts'" "k < dim_vec Ts" using in_set_conv_nth by force
    show "dims T = ds" unfolding \<open>T = ?Ts' ! k\<close>   nth_map[OF \<open>k < length ?Ts'\<close>[unfolded length_map]]
      using assms(1) \<open>k < dim_vec Ts\<close>
      by (simp add: \<open>k < length (map (\<lambda>j. A $$ (i, j) \<cdot> Ts $ j) [0..<dim_vec Ts])\<close> vec_setI)
  qed
  then show dims_eq:"dims (mat_tensorlist_mult A Ts ds $ i) = dims (Tensor_Plus.listsum ds (map (\<lambda>j. A $$ (i, j) \<cdot> Ts $ j) [0..<dim_vec Ts]))"
    using dims_mat_tensorlist_mult assms  mat_tensorlist_mult_def listsum_dims
    by (metis (no_types, lifting) dim_vec vec_setI)

  fix "is" assume is_valid:"is \<lhd> dims (mat_tensorlist_mult A Ts ds $ i)"
  then have "is \<lhd> ds" using dims_eq dims_Ts' listsum_dims by (metis (no_types, lifting))

  have summand_eq: "\<And>j. j \<in> {0 ..< dim_vec Ts} \<Longrightarrow> row A i $ j * (map_vec (\<lambda>T. Tensor.lookup T is) Ts) $ j = lookup (A $$ (i, j) \<cdot> Ts $ j) is"
    using index_vec \<open>i<dim_row A\<close> row_def \<open>dim_vec Ts = dim_col A\<close>
     \<open>is \<lhd> ds\<close> assms(1) lookup_smult atLeastLessThan_iff index_map_vec(1) vec_setI by metis

  have "lookup (mat_tensorlist_mult A Ts ds $ i) is = (A *\<^sub>v (map_vec (\<lambda>T. Tensor.lookup T is) Ts)) $ i"
    unfolding mat_tensorlist_mult_def using lookup_tensor_from_lookup[OF \<open>is \<lhd> ds\<close>] using \<open>i<dim_row A\<close> by auto
  also have "... = row A i \<bullet> map_vec (\<lambda>T. Tensor.lookup T is) Ts"
    using \<open>i<dim_row A\<close> by simp
  also have "... = (\<Sum> j \<in> {0 ..< dim_vec Ts}. row A i $ j * (map_vec (\<lambda>T. Tensor.lookup T is) Ts) $ j)"
    unfolding scalar_prod_def nth_rows[OF \<open>i<dim_row A\<close>] by simp
  also have "... = (\<Sum>j\<in>{0..<dim_vec Ts}. lookup (A $$ (i, j) \<cdot> Ts $ j) is)" using summand_eq by force
  also have "... = (\<Sum>A\<leftarrow>?Ts'. lookup A is)" unfolding map_map
    Groups_List.sum_set_upt_conv_sum_list_nat[symmetric]  atLeastLessThan_upt[symmetric] by auto
  also have "... = lookup (listsum ds ?Ts') is" using lookup_listsum[OF \<open>is \<lhd> ds\<close>] dims_Ts' by fastforce
  finally show "lookup (mat_tensorlist_mult A Ts ds $ i) is = lookup (listsum ds ?Ts') is" by metis
qed

lemma lookup_tensors_from_net:
assumes "valid_net' m"
and "is \<lhd> input_sizes m"
and "j < output_size' m"
shows "Tensor.lookup (tensors_from_net m $ j) is = evaluate_net m (base_input m is) $ j"
using assms proof (induction m arbitrary:j "is")
  case (Input M)
  then have "j < M" using output_size.simps(1) using Input by auto
  then have 1:"tensors_from_net (Input M) $ j = unit_vec M j" by simp
  obtain i where "is = [i]" "i<M" using Input Suc_length_conv input_sizes.simps(1) length_0_conv list.size(3) valid_index_length by auto
  then have 2:"Tensor.lookup (tensors_from_net (Input M) $ j) is = (if i=j then 1 else 0)" using lookup_unit_vec 1 by metis
  have "evaluate_net (Input M) (map (\<lambda>(n, i). unit\<^sub>v n i) (zip (input_sizes (Input M)) is)) = unit\<^sub>v M i" using \<open>is = [i]\<close> by auto
  then show ?case using 2 \<open>j < M\<close> base_input_def by (simp add: \<open>i < M\<close>)
next
  case (Conv A m j "is")
  have is_valid:"is \<lhd> input_sizes m" using Conv.prems by simp
  have valid_net:"valid_net' m" using Conv.prems(1) unfolding remove_weights.simps
    using valid_net.simps convnet.distinct(1) convnet.distinct(5) convnet.inject(2) by blast
  then have length_em: "dim_vec (evaluate_net m (base_input m is)) = output_size' m"
    using output_size_correct base_input_length is_valid by metis

  have IH':"map_vec (\<lambda>T. Tensor.lookup T is) (tensors_from_net m) =
                evaluate_net m (base_input m is)"
  proof (rule eq_vecI)
    show equal_lengths: "dim_vec (map_vec (\<lambda>T. lookup T is) (tensors_from_net m))
      = dim_vec (evaluate_net m (base_input m is))" using length_em
      by (simp add: output_size_correct_tensors valid_net)
    show "\<And>i. i < dim_vec (evaluate_net m (base_input m is)) \<Longrightarrow>
         map_vec (\<lambda>T. lookup T is) (tensors_from_net m) $ i = evaluate_net m (base_input m is) $ i"
    proof -
      fix i
      assume "i < dim_vec (evaluate_net m (base_input m is))"
      then have "i < output_size' m" using equal_lengths length_em by auto
      then show "map_vec (\<lambda>T. lookup T is) (tensors_from_net m) $ i
        = evaluate_net m (base_input m is) $ i"
        using Conv.IH is_valid equal_lengths valid_net base_input_def length_em nth_map_upt
        length_map nth_map by auto
    qed
  qed

  have "Tensor.lookup ((tensors_from_net (Conv A m)) $ j) is =
    (A *\<^sub>v (map_vec (\<lambda>T. Tensor.lookup T is) (tensors_from_net m))) $ j"
  proof -
    have "dim_vec (tensors_from_net (Conv A m)) = output_size' (Conv A m)"
      using Conv by (simp add: mat_tensorlist_mult_def)
    then have "j<dim_vec (tensors_from_net (Conv A m))" using Conv.prems by auto
    then have "(tensors_from_net (Conv A m)) $ j =  tensor_from_lookup (input_sizes m)
                (\<lambda>is. (A *\<^sub>v (map_vec (\<lambda>T. Tensor.lookup T is) (tensors_from_net m))) $ j)"
      unfolding tensors_from_net.simps mat_tensorlist_mult_def by fastforce
    then show ?thesis
        using lookup_tensor_from_lookup[OF is_valid] by auto
  qed
  also have "(A *\<^sub>v (map_vec (\<lambda>T. Tensor.lookup T is) (tensors_from_net m))) $ j
    = (A *\<^sub>v (evaluate_net m (base_input m is))) $ j" using IH' by auto
  also have "... = evaluate_net (Conv A m) (base_input (Conv A m) is) $ j"
    unfolding base_input_def using evaluate_net.simps by auto
  finally show ?case by auto
next
  case (Pool m1 m2 j "is")

  text \<open>We split "is" into two parts for each subnet:\<close>
  obtain is1 is2 where is12_def:"is = is1 @ is2" "is1 \<lhd> input_sizes m1" "is2 \<lhd> input_sizes m2"
    by (metis Pool.prems(2) input_sizes.simps(3) valid_index_split)

  text \<open>Apply the induction hypothesis to the subnets:\<close>
  have IH:"Tensor.lookup (tensors_from_net m1 $ j) is1
      = evaluate_net m1 (map (\<lambda>(x, y). unit\<^sub>v x y) (zip (input_sizes m1) is1)) $ j"
      "Tensor.lookup (tensors_from_net m2 $ j) is2
      = evaluate_net m2 (map (\<lambda>(x, y). unit\<^sub>v x y) (zip (input_sizes m2) is2)) $ j"
    using Pool convnet.distinct(3) convnet.distinct(5) convnet.inject(3) remove_weights.simps(3)
    valid_net.simps  \<open>is1 \<lhd> input_sizes m1\<close> \<open>is2 \<lhd> input_sizes m2\<close> output_size.simps(3)
    by (metis base_input_def)+

  text \<open>In the Pool layer tensor entries get multiplied:\<close>
  have lookup_prod: "Tensor.lookup (tensors_from_net (Pool m1 m2) $ j) is
    = Tensor.lookup (tensors_from_net m1 $ j) is1 * Tensor.lookup (tensors_from_net m2 $ j) is2"
  proof -
    have j_small: "j < dim_vec (tensors_from_net m1)"  "j < dim_vec (tensors_from_net m2)"
      by (metis Pool.prems(1) Pool.prems(3) convnet.distinct(3) convnet.inject(3) convnet.simps(9)
      output_size.simps(3) output_size_correct_tensors remove_weights.simps(3) valid_net.cases)+
    then have 0:"tensors_from_net (Pool m1 m2) $ j = tensors_from_net m1 $ j \<otimes> tensors_from_net m2 $ j"
      unfolding tensors_from_net.simps using j_small index_component_mult by blast
    have "Tensor.dims (tensors_from_net m1 $ j) = input_sizes m1"
         "Tensor.dims (tensors_from_net m2 $ j) = input_sizes m2"
      using dims_tensors_from_net j_small nth_mem by (simp_all add: vec_setI)
    then have is12_valid:
              "is1 \<lhd> Tensor.dims (tensors_from_net m1 $ j)"
              "is2 \<lhd> Tensor.dims (tensors_from_net m2 $ j)"
      using is12_def by presburger+
    then show ?thesis
      unfolding 0 using lookup_tensor_prod[OF is12_valid] is12_def by auto
  qed

  text \<open>Output values get multiplied in the Pool layer as well:\<close>
  have "evaluate_net (Pool m1 m2) (base_input (Pool m1 m2) is) $ j
    = evaluate_net m1 (base_input m1 is1) $ j * evaluate_net m2 (base_input m2 is2) $ j"
  proof -
    have "valid_net' m1" "valid_net' m2"
      using remove_weights.simps  valid_net.simps Pool.prems
      by (metis convnet.distinct(3) convnet.distinct(5) convnet.inject(3))+
    have "input_sizes m1 = map dim_vec (base_input m1 is1)"
         "input_sizes m2 = map dim_vec (base_input m2 is2)"
      using base_input_def base_input_length base_input_def is12_def by auto
    have "j < dim_vec (evaluate_net m1 (base_input m1 is1))" "j < dim_vec (evaluate_net m2 (base_input m2 is2))"
      using Pool.prems \<open>input_sizes m1 = map dim_vec (base_input m1 is1)\<close> \<open>valid_net' m1\<close>
      output_size_correct by (auto,metis Pool.prems(1) Pool.prems(3) \<open>input_sizes m2 = map dim_vec (base_input m2 is2)\<close>
      convnet.distinct(3) convnet.distinct(5) convnet.inject(3) output_size.simps(3) output_size_correct
      remove_weights.simps(3) valid_net.cases)
    then show ?thesis unfolding evaluate_net.simps unfolding base_input_def
      using is12_def(1) is12_def(2) valid_index_length by (simp add: append_eq_conv_conj drop_map
      drop_zip index_component_mult input_sizes_remove_weights take_map take_zip)
  qed

  then show ?case using lookup_prod IH base_input_def by auto
qed

primrec extract_weights::"bool \<Rightarrow> real mat convnet \<Rightarrow> nat \<Rightarrow> real" where
  extract_weights_Input: "extract_weights shared (Input M) = (\<lambda>x. 0)"
| extract_weights_Conv: "extract_weights shared (Conv A m) =
    (\<lambda>x. if x < dim_row A * dim_col A then flatten_matrix A x
         else extract_weights shared m (x - dim_row A * dim_col A))"
| extract_weights_Pool: "extract_weights shared (Pool m1 m2) =
    (\<lambda>x. if x < count_weights shared (remove_weights m1)
         then extract_weights shared m1 x
         else extract_weights shared m2 (x - count_weights shared (remove_weights m1)))"

inductive balanced_net::"(nat \<times> nat) convnet \<Rightarrow> bool" where
  balanced_net_Input: "balanced_net (Input M)"
| balanced_net_Conv: "balanced_net m \<Longrightarrow> balanced_net (Conv A m)"
| balanced_net_Pool: "balanced_net m1 \<Longrightarrow> balanced_net m2 \<Longrightarrow>
    count_weights True m1 = count_weights True m2 \<Longrightarrow> balanced_net (Pool m1 m2)"

inductive shared_weight_net::"real mat convnet \<Rightarrow> bool" where
  shared_weight_net_Input: "shared_weight_net (Input M)"
| shared_weight_net_Conv: "shared_weight_net m \<Longrightarrow> shared_weight_net (Conv A m)"
| shared_weight_net_Pool: "shared_weight_net m1 \<Longrightarrow> shared_weight_net m2 \<Longrightarrow>
  count_weights True (remove_weights m1) = count_weights True (remove_weights m2) \<Longrightarrow>
  (\<And>x. x < count_weights True (remove_weights m1) \<Longrightarrow> extract_weights True m1 x = extract_weights True m2 x)
   \<Longrightarrow> shared_weight_net (Pool m1 m2)"

lemma insert_extract_weights_cong_shared:
assumes "shared_weight_net m"
assumes "\<And>x. x < count_weights True (remove_weights m) \<Longrightarrow> f x = extract_weights True m x"
shows "m = insert_weights True (remove_weights m) f"
using assms proof (induction m arbitrary:f)
case (shared_weight_net_Input M)
  then show ?case
    by simp
next
  case (shared_weight_net_Conv m A)
  have "extract_matrix f (dim_row A) (dim_col A) = A"
    by (simp add: extract_matrix_cong extract_matrix_flatten_matrix shared_weight_net_Conv.prems)
  then show ?case
    using shared_weight_net_Conv.IH[of "(\<lambda>i. f (i + dim_row A * dim_col A))"]
    using shared_weight_net_Conv.prems by auto
next
  case (shared_weight_net_Pool m1 m2)
  have "m1 = insert_weights True (remove_weights m1) f"
    using shared_weight_net_Pool.IH(1) shared_weight_net_Pool.prems by auto
  have "m2 = insert_weights True (remove_weights m2) f"
    using local.shared_weight_net_Pool(3) shared_weight_net_Pool.IH(2)
    shared_weight_net_Pool.hyps(4) shared_weight_net_Pool.prems by fastforce
  then show ?case
    using \<open>m1 = insert_weights True (remove_weights m1) f\<close> by auto
qed

lemma insert_extract_weights_cong_unshared:
assumes "\<And>x. x < count_weights False (remove_weights m) \<Longrightarrow> f x = extract_weights False m x"
shows "m = insert_weights False (remove_weights m) f"
using assms proof (induction m arbitrary:f)
case (Input M)
  then show ?case
    by simp
next
  case (Conv A m)
  then have "extract_matrix f (dim_row A) (dim_col A) = A"
    by (metis count_weights.simps(2) extract_matrix_flatten_matrix_cong extract_weights_Conv remove_weights.simps(2) trans_less_add1)
  then show ?case
    using Conv.IH Conv.prems by auto
next
  case (Pool m1 m2)
  then show ?case
    using Pool.IH(1) Pool.IH(2) Pool.prems by auto
qed

lemma remove_insert_weights:
shows "remove_weights (insert_weights s m w) = m"
proof (induction m arbitrary:w)
  case Input
  then show ?case by simp
next
  case (Conv r12 m)
  then obtain r1 r2 where "r12 = (r1, r2)" by fastforce
  then have "remove_weights (insert_weights s m w) = m" using Conv.IH by blast
  then have "remove_weights (insert_weights s (Conv (r1,r2) m) w) = Conv (r1,r2) m"
    unfolding insert_weights.simps remove_weights.simps
    using extract_matrix_def Conv.IH dim_extract_matrix(1) by (metis dim_col_mat(1) )
  then show ?case using \<open>r12 = (r1, r2)\<close> by blast
next
  case (Pool m1 m2 w)
  then show ?case unfolding insert_weights.simps remove_weights.simps using Pool.IH by blast
qed

lemma extract_insert_weights_shared:
assumes "x<count_weights True m"
and "balanced_net m"
shows "extract_weights True (insert_weights True m w) x = w x"
using assms
proof (induction m arbitrary:w x)
  case (Input x)
  then show ?case
    by simp
next
  case (Conv r01 m)
  obtain r0 r1 where "r01 = (r0,r1)" by force
  then show ?case unfolding \<open>r01 = (r0,r1)\<close> insert_weights.simps extract_weights.simps
    apply (cases "x < dim_row (extract_matrix w r0 r1) * dim_col (extract_matrix w r0 r1)")
     apply (auto simp add: dim_extract_matrix(1) dim_extract_matrix(2) flatten_matrix_extract_matrix)
    using Conv.IH[of _ "\<lambda>i. w (i + r0 * r1)"] Conv.prems(1) Conv.prems(2) \<open>r01 = (r0, r1)\<close> balanced_net.cases by force
next
  case (Pool m1 m2)
  then show ?case unfolding insert_weights.simps extract_weights.simps  remove_insert_weights
    apply (cases "x < count_weights True m1")
     apply (metis balanced_net.simps convnet.distinct(5) convnet.inject(3) count_weights.simps(1) not_less_zero)
    by (metis (no_types, lifting) balanced_net.simps convnet.distinct(5) convnet.inject(3) count_weights.simps(1) count_weights.simps(3) less_max_iff_disj not_less_zero)
qed

lemma shared_weight_net_insert_weights: "balanced_net m \<Longrightarrow> shared_weight_net (insert_weights True m w)"
proof (induction m arbitrary:w)
  case (Input x)
  then show ?case using insert_weights.simps balanced_net.simps shared_weight_net.simps by metis
next
  case (Conv r01 m)
  then obtain r0 r1 where "r01 = (r0,r1)" by force
  then show ?case  unfolding \<open>r01 = (r0,r1)\<close> insert_weights.simps
    by (metis Conv.IH Conv.prems balanced_net.simps convnet.distinct(1) convnet.distinct(5) convnet.inject(2) shared_weight_net_Conv)
next
  case (Pool m1 m2)
  have "balanced_net m1" "balanced_net m2"
    using Pool.prems balanced_net.simps by blast+
  have "\<And>x. x < count_weights True m1 \<Longrightarrow>
         extract_weights True (insert_weights True m1 w) x = extract_weights True (insert_weights True m2 w) x"
    using extract_insert_weights_shared
    by (metis Pool.prems balanced_net.simps convnet.distinct(3) convnet.distinct(5) convnet.inject(3))
  then show ?case unfolding insert_weights.simps using Pool(1)[of w] Pool(2)[of w]
    by (metis Pool.prems balanced_net.simps convnet.distinct(3) convnet.distinct(5) convnet.inject(3) remove_insert_weights shared_weight_net_Pool)
qed

lemma finite_valid_index: "finite {is. is \<lhd> ds}"
proof (induction ds)
  case Nil
  then show ?case by (metis List.finite_set finite_subset length_0_conv list.set_intros(1) mem_Collect_eq subsetI valid_index_length)
next
  case (Cons d ds)
  have "{is. is \<lhd> d # ds} \<subseteq> (\<Union>i<d. {i # is |is. is \<lhd> ds})"
  proof (rule subsetI)
    fix "is" assume "is \<in> {is. is \<lhd> d # ds}"
    then have "is \<lhd> d # ds" by auto
    then obtain i is' where "is = i # is'" by blast
    then have "i<d" using \<open>is \<lhd> d # ds\<close> by blast
    have "is' \<lhd> ds" using \<open>is = i # is'\<close> \<open>is \<lhd> d # ds\<close> by blast
    have "is \<in> {i # is |is. is \<lhd> ds}" by (simp add: \<open>is = i # is'\<close> \<open>is' \<lhd> ds\<close>)
    then show "is \<in> (\<Union>i<d. {i # is |is. is \<lhd> ds})" using \<open>i < d\<close> by blast
  qed
  moreover have "\<And>i. finite {i # is |is. is \<lhd> ds}" by (simp add: Cons.IH)
  ultimately show "finite {is. is \<lhd> d # ds}" by (simp add: finite_subset)
qed

lemma setsum_valid_index_split:
"(\<Sum>is | is \<lhd> ds1 @ ds2. f is) = (\<Sum>is1 | is1 \<lhd> ds1. (\<Sum>is2 | is2 \<lhd> ds2. f (is1 @ is2)))"
proof -
  have 1:"((\<lambda>(is1, is2). is1 @ is2) ` ({is1. is1 \<lhd> ds1} \<times> {is2. is2 \<lhd> ds2})) = {is. is \<lhd> ds1 @ ds2}" (is "?A = ?B")
  proof (rule subset_antisym; rule subsetI)
    fix x assume "x \<in> ?A"
    then show "x \<in> ?B" using valid_index_append by auto
  next
    fix x assume "x \<in> ?B"
    then have "x \<lhd> ds1 @ ds2" by auto
    then obtain x1 x2 where "x = x1 @ x2" "x1 \<lhd> ds1" "x2 \<lhd> ds2" by (metis valid_index_split)
    then have "(x1, x2) \<in> ({is1. is1 \<lhd> ds1} \<times> {is2. is2 \<lhd> ds2})" by auto
    then show "x \<in> ?A" using imageI \<open>x = x1 @ x2\<close> by blast
  qed
  have 2:"inj_on (\<lambda>(is1, is2). is1 @ is2) ({is1. is1 \<lhd> ds1} \<times> {is2. is2 \<lhd> ds2})"
    by (simp add: inj_on_def valid_index_length)
  show ?thesis
    unfolding Groups_Big.comm_monoid_add_class.sum.cartesian_product[of "\<lambda>is1 is2. f (is1 @ is2)"]
    using Groups_Big.comm_monoid_add_class.sum.reindex[OF 2, of f] 1
     "2" SigmaE prod.simps(2) sum.reindex_cong by (simp add: split_def)
qed

lemma prod_lessThan_split:
fixes g :: "nat \<Rightarrow> real" shows "prod g {..<n+m} = prod g {..<n} * prod (\<lambda>x. g (x+n)) {..<m}"
using Groups_Big.comm_monoid_mult_class.prod.union_inter_neutral[of "{..<n}" "{n..<n+m}" g, unfolded ivl_disj_un_one(2)[OF le_add1], OF finite_lessThan finite_atLeastLessThan]
by (metis (no_types) add.commute add.left_neutral atLeast0LessThan empty_iff ivl_disj_int_one(2) prod.shift_bounds_nat_ivl)

(* This is a nice lemma, but never used to prove the Fundamental Theorem of Network Capacity: *)
lemma evaluate_net_from_tensors:
assumes "valid_net' m"
and "map dim_vec inputs = input_sizes m"
and "j < output_size' m"
shows "evaluate_net m inputs $ j
  = (\<Sum>is\<in>{is. is \<lhd> input_sizes m}. (\<Prod>k<length inputs. inputs ! k $ (is!k)) * Tensor.lookup (tensors_from_net m $ j) is)"
using assms proof (induction m arbitrary:j "is" inputs)
  case (Input M)
  then have "length inputs = 1" "input_sizes (Input M) = [M]" by auto
  {
    fix "is" assume "is \<lhd> input_sizes (Input M)"
    then have "length is = 1" by (simp add: valid_index_length)
    then have "is = [hd is]" by (metis One_nat_def length_0_conv length_Suc_conv list.sel(1))
    then have "Tensor.lookup (tensors_from_net (Input M) $ j) is = (if hd is=j then 1 else 0)"
      by (metis Input.prems(3) \<open>input_sizes (Input M) = [M]\<close> \<open>is \<lhd> input_sizes (Input M)\<close> list.distinct(1)
      lookup_unit_vec nth_Cons_0 output_size.simps(1) remove_weights.simps(1) tensors_from_net.simps(1) valid_indexE index_vec)
    then have "(\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net (Input M) $ j) is =
               (if is=[j] then (\<Prod>k<length inputs. inputs ! k $ (is ! k)) else 0)" using \<open>is = [hd is]\<close> by auto
  }
  then have "(\<Sum>is | is \<lhd> input_sizes (Input M). (\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net (Input M) $ j) is)
   = (\<Sum>is | is \<lhd> input_sizes (Input M). (if is=[j] then (\<Prod>k<length inputs. inputs ! k $ (is ! k)) else 0))"  by auto
  also have "(\<Sum>is | is \<lhd> input_sizes (Input M). (if is=[j] then (\<Prod>k<length inputs. inputs ! k $ (is ! k)) else 0))
   = (\<Prod>k<length inputs. inputs ! k $ ([j] ! k))" unfolding sum.delta[OF finite_valid_index]
    using Input.prems(3) valid_index.Cons valid_index.Nil by auto
  also have "... = inputs ! 0 $ j" using \<open>length inputs = 1\<close> by (simp add: prod.lessThan_Suc)
  also have "... = evaluate_net (Input M) inputs $ j" unfolding evaluate_net.simps
    by (metis \<open>length inputs = 1\<close> hd_conv_nth list.size(3) zero_neq_one)
  finally show ?case by auto
next
  case (Conv A m j)
  have "j < dim_row A" using Conv.prems(3) by auto
  have 0:"\<And>is. is \<lhd> input_sizes (Conv A m) \<Longrightarrow>
  (\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net (Conv A m) $ j) is =
  (\<Sum>i = 0..<dim_vec (tensors_from_net m). row A j $ i * ((\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net m $ i) is))"
  proof -
    fix "is" assume "is \<lhd> input_sizes (Conv A m)"
    then have "is \<lhd> input_sizes m" by simp
    have 0:"lookup (tensors_from_net (Conv A m) $ j) is =
          (\<Sum>i = 0..<dim_vec (tensors_from_net m). row A j $ i * lookup (tensors_from_net m $ i) is)"
      unfolding tensors_from_net.simps mat_tensorlist_mult_def index_vec[OF \<open>j < dim_row A\<close>]
      lookup_tensor_from_lookup[OF \<open>is \<lhd> input_sizes m\<close>] index_mult_mat_vec[OF \<open>j < dim_row A\<close>] scalar_prod_def
      using index_map_vec by auto
    show "(\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net (Conv A m) $ j) is
      = (\<Sum>i = 0..<dim_vec (tensors_from_net m). row A j $ i * ((\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net m $ i) is))"
      unfolding 0 sum_distrib_left by (simp add: semiring_normalization_rules(19))
  qed
  have "valid_net' m" by (metis Conv.prems(1) convnet.distinct(1) convnet.distinct(5) convnet.inject(2) remove_weights.simps(2) valid_net.simps)
  have "map dim_vec inputs = input_sizes m" by (simp add: Conv.prems(2))
  have "output_size' m = dim_vec (tensors_from_net m)" by (simp add: \<open>valid_net' m\<close> output_size_correct_tensors)
  have 1:"\<And>i. i<dim_vec (tensors_from_net m) \<Longrightarrow> (\<Sum>is | is \<lhd> input_sizes (Conv A m). ((\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net m $ i) is)) = evaluate_net m inputs $ i" unfolding input_sizes.simps
    using Conv.IH \<open>valid_net' m\<close> \<open>map dim_vec inputs = input_sizes m\<close> \<open>output_size' m = dim_vec (tensors_from_net m)\<close> by simp

  have "(\<Sum>is | is \<lhd> input_sizes (Conv A m). (\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net (Conv A m) $ j) is)
    = (\<Sum>i = 0..<dim_vec (tensors_from_net m). (\<Sum>is | is \<lhd> input_sizes (Conv A m).  row A j $ i *  ((\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net m $ i) is)))"
    using Groups_Big.comm_monoid_add_class.sum.swap 0 by auto
  also have "... = (\<Sum>i = 0..<dim_vec (tensors_from_net m). row A j $ i * (\<Sum>is | is \<lhd> input_sizes (Conv A m). ((\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net m $ i) is)))"
    by (simp add: sum_distrib_left)
  also have "... = (\<Sum>i = 0..<dim_vec (tensors_from_net m). row A j $ i * evaluate_net m inputs $ i)" using 1 by auto
  also have "... = row A j \<bullet> evaluate_net m inputs"
    by (metis (full_types) \<open>map dim_vec inputs = input_sizes m\<close> \<open>output_size' m = dim_vec (tensors_from_net m)\<close>
    \<open>valid_net' m\<close> output_size_correct scalar_prod_def)
  also have "... = (A *\<^sub>v evaluate_net m inputs) $ j" by (simp add: \<open>j < dim_row A\<close>)
  also have "... = evaluate_net (Conv A m) inputs $ j" by simp
  finally show ?case by auto
next
  case (Pool m1 m2 j)
  have "valid_net' m1" "valid_net' m2"
    by (metis Pool.prems(1) convnet.distinct(3) convnet.inject(3) convnet.simps(9) remove_weights.simps(3) valid_net.simps)+
  have "j < output_size' m2" "j < output_size' m1"
    apply (metis Pool.prems(1) Pool.prems(3) convnet.distinct(3) convnet.inject(3) convnet.simps(9)
    output_size.simps(3) remove_weights.simps(3) valid_net.simps) using Pool.prems by auto
  then have "j < dim_vec (tensors_from_net m1)" "j < dim_vec (tensors_from_net m2)"
    by (simp_all add: \<open>valid_net' m1\<close> \<open>valid_net' m2\<close> output_size_correct_tensors)

  define inputs1 where "inputs1 = take (length (input_sizes m1)) inputs"
  define inputs2 where "inputs2 = drop (length (input_sizes m1)) inputs"
  have "map dim_vec inputs1 = input_sizes m1" "map dim_vec inputs2 = input_sizes m2"
    apply (metis Pool.prems(2) append_eq_conv_conj input_sizes.simps(3) inputs1_def take_map)
    by (metis Pool.prems(2) append_eq_conv_conj drop_map input_sizes.simps(3) inputs2_def)
  have "inputs = inputs1 @ inputs2" by (simp add: inputs1_def inputs2_def)
  {
    fix is1 is2 assume "is1 \<lhd> input_sizes m1" "is2 \<lhd> input_sizes m2"
    have "length is1 = length inputs1"
      using \<open>is1 \<lhd> input_sizes m1\<close> \<open>map dim_vec inputs1 = input_sizes m1\<close> valid_index_length by fastforce
    have "length is2 = length inputs2"
      using \<open>is2 \<lhd> input_sizes m2\<close> \<open>map dim_vec inputs2 = input_sizes m2\<close> valid_index_length by fastforce
    have 1:"(\<Prod>k<length inputs1. (inputs1 @ inputs2) ! k $ ((is1 @ is2) ! k))  = (\<Prod>k<length inputs1. inputs1 ! k $ (is1 ! k))"
      using \<open>length is1 = length inputs1\<close> \<open>length is2 = length inputs2\<close>
      nth_append by (metis (no_types, lifting) lessThan_iff prod.cong)
    have 2:"(\<Prod>x<length inputs2. (inputs1 @ inputs2) ! (x + length inputs1) $ ((is1 @ is2) ! (x + length inputs1))) =
      (\<Prod>k<length inputs2. inputs2 ! k $ (is2 ! k))"
      using \<open>length is1 = length inputs1\<close> \<open>length is2 = length inputs2\<close>
      by (metis (no_types, lifting) add.commute nth_append_length_plus)
    have "(\<Prod>k<length inputs. inputs ! k $ ((is1 @ is2) ! k)) = (\<Prod>k<length inputs1. inputs1 ! k $ (is1 ! k)) * (\<Prod>k<length inputs2. inputs2 ! k $ (is2 ! k))"
      unfolding \<open>inputs = inputs1 @ inputs2\<close> length_append prod_lessThan_split using 1 2 by metis
  }
  note 1 = this
  {
    fix is1 is2 assume "is1 \<lhd> input_sizes m1" "is2 \<lhd> input_sizes m2"
    then have "is1 \<lhd> dims (tensors_from_net m1 $ j)" "is2 \<lhd> dims (tensors_from_net m2 $ j)"
      using \<open>j < dim_vec (tensors_from_net m1)\<close>  \<open>j < dim_vec (tensors_from_net m2)\<close> dims_tensors_from_net vec_setI by force+
    have "lookup (tensors_from_net (Pool m1 m2) $ j) (is1 @ is2) = lookup (tensors_from_net m1 $ j) is1 * lookup (tensors_from_net m2 $ j) is2"
      unfolding "tensors_from_net.simps" index_component_mult[OF \<open>j < dim_vec (tensors_from_net m1)\<close> \<open>j < dim_vec (tensors_from_net m2)\<close>]
      lookup_tensor_prod[OF \<open>is1 \<lhd> dims (tensors_from_net m1 $ j)\<close> \<open>is2 \<lhd> dims (tensors_from_net m2 $ j)\<close>] by metis
  }
  note 2 = this

  have j_le_eval:"j < dim_vec (evaluate_net m1 (take (length (input_sizes m1)) inputs))"
                 "j < dim_vec (evaluate_net m2 (drop (length (input_sizes m1)) inputs))"
    using \<open>j < output_size' m1\<close> \<open>map dim_vec inputs1 = input_sizes m1\<close> \<open>valid_net' m1\<close> inputs1_def output_size_correct
    using \<open>j < output_size' m2\<close> \<open>map dim_vec inputs2 = input_sizes m2\<close> \<open>valid_net' m2\<close> inputs2_def by auto
  have "(\<Sum>is | is \<lhd> input_sizes (Pool m1 m2). (\<Prod>k<length inputs. inputs ! k $ (is ! k)) * lookup (tensors_from_net (Pool m1 m2) $ j) is)
        = (\<Sum>is1 | is1 \<lhd> input_sizes m1. \<Sum>is2 | is2 \<lhd> input_sizes m2.
          (\<Prod>k<length inputs1. inputs1 ! k $ (is1 ! k)) * (\<Prod>k<length inputs2. inputs2 ! k $ (is2 ! k)) *
          lookup (tensors_from_net m1 $ j) is1 * lookup (tensors_from_net m2 $ j) is2)"
    unfolding input_sizes.simps setsum_valid_index_split using 1 2
    using mem_Collect_eq sum.cong by (simp add: mult.assoc)
  also have "... = (\<Sum>is1 | is1 \<lhd> input_sizes m1. (\<Prod>k<length inputs1. inputs1 ! k $ (is1 ! k)) * lookup (tensors_from_net m1 $ j) is1) *
                   (\<Sum>is2 | is2 \<lhd> input_sizes m2. (\<Prod>k<length inputs2. inputs2 ! k $ (is2 ! k)) * lookup (tensors_from_net m2 $ j) is2)"
    unfolding sum_product by (rule sum.cong, metis, rule sum.cong, metis, simp)
  also have "... = evaluate_net (Pool m1 m2) inputs $ j" unfolding "evaluate_net.simps" index_component_mult[OF j_le_eval]
    using Pool.IH(1)[OF \<open>valid_net' m1\<close> _ \<open>j < output_size' m1\<close>] Pool.IH(2)[OF \<open>valid_net' m2\<close> _ \<open>j < output_size' m2\<close>]
    using \<open>map dim_vec inputs1 = input_sizes m1\<close> \<open>map dim_vec inputs2 = input_sizes m2\<close> inputs1_def inputs2_def by auto
  finally show ?case by metis
qed

lemma tensors_from_net_eqI:
assumes "valid_net' m1" "valid_net' m2" "input_sizes m1 = input_sizes m2"
assumes "\<And>inputs. input_sizes m1 = map dim_vec inputs \<Longrightarrow> evaluate_net m1 inputs = evaluate_net m2 inputs"
shows "tensors_from_net m1 = tensors_from_net m2"
proof -
  have "map dim_vec (map 0\<^sub>v (input_sizes m2)) = input_sizes m2"
       "map dim_vec (map 0\<^sub>v (input_sizes m1)) = input_sizes m1" by (auto intro: nth_equalityI)
  then have "output_size' m1 = output_size' m2" using
    output_size_correct[OF \<open>valid_net' m1\<close> \<open>map dim_vec (map 0\<^sub>v (input_sizes m1)) = input_sizes m1\<close>]
    output_size_correct[OF \<open>valid_net' m2\<close> \<open>map dim_vec (map 0\<^sub>v (input_sizes m2)) = input_sizes m2\<close>]
    assms(3) assms(4)
    by (metis (no_types))
  have "\<And>is. base_input m1 is = base_input m2 is"
    unfolding base_input_def \<open>input_sizes m1 = input_sizes m2\<close> by metis
  show ?thesis by (rule eq_vecI, rule tensor_lookup_eqI; metis
    lookup_tensors_from_net[OF \<open>valid_net' m1\<close>, unfolded \<open>\<And>is. base_input m1 is = base_input m2 is\<close> \<open>output_size' m1 = output_size' m2\<close>]
    lookup_tensors_from_net[OF \<open>valid_net' m2\<close>] assms(3) base_input_length
    assms(1) assms(2) dims_tensors_from_net output_size_correct_tensors vec_setI
    \<open>output_size' m1 = output_size' m2\<close> assms(4))
qed

end


theory NM_logic
  imports BA_logic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

(**Neighbourhood semantics for LFIs*)

consts S1::"\<sigma>\<Rightarrow>\<sigma>" ("S\<^sub>\<not>")   (** introduces additional (unconstrained) constant *)
consts S2::"\<sigma>\<Rightarrow>\<sigma>" ("S\<^sub>\<circ>")   (** introduces additional (unconstrained) constant *)

(** Paraconsistent LFI operators:*)
definition pneg::"\<sigma>\<Rightarrow>\<sigma>"       ("\<^bold>\<not>_" [57]58)   where   "\<^bold>\<not>A  \<equiv> \<^bold>\<sim>A \<^bold>\<or> (S\<^sub>\<not> A)"
definition pcon_mbC::"\<sigma>\<Rightarrow>\<sigma>"   ("\<^bold>\<circ>_" [57]58) where  "\<^bold>\<circ>A  \<equiv> \<^bold>\<sim>(A \<^bold>\<and> S\<^sub>\<not> A) \<^bold>\<and> (S\<^sub>\<circ> A)"
definition pcon_ciw :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circ>\<^sup>w_" [57]58) where "\<^bold>\<circ>\<^sup>wA  \<equiv> \<^bold>\<sim>(A \<^bold>\<and> \<^bold>\<not>A)"  (* for mbC-ciw*)
declare pneg_def[conn] pcon_mbC_def[conn] pcon_ciw_def[conn]

lemma pcon_rel1: "(A \<^bold>\<and> \<^bold>\<not>A) = (A \<^bold>\<and> S\<^sub>\<not> A)" unfolding conn by auto
lemma pcon_rel2: "\<^bold>\<circ>A = (\<^bold>\<circ>\<^sup>wA  \<^bold>\<and> S\<^sub>\<circ> A)" unfolding conn by simp

lemma LEM:  "A \<^bold>\<or> \<^bold>\<not>A \<^bold>\<approx> \<^bold>\<top>" unfolding conn by simp
lemma CONS: "a \<^bold>\<and> \<^bold>\<not>a \<^bold>\<and> \<^bold>\<circ>a \<^bold>\<approx> \<^bold>\<bottom>" unfolding conn by simp
lemma "A \<^bold>\<and> \<^bold>\<not>A \<^bold>\<approx> \<^bold>\<bottom>" nitpick oops (*counterexample found*)

(**The following axioms are commonly employed in the literature on LFIs to obtain stronger logics.
We explore under which conditions they can be assumed while keeping the logic boldly paraconsistent.*)
abbreviation ciw where "ciw \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<circ>a \<^bold>\<or> (a \<^bold>\<and> \<^bold>\<not>a)]"
abbreviation ci  where  "ci \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<circ>a \<^bold>\<rightarrow> (a \<^bold>\<and> \<^bold>\<not>a)]"
abbreviation cl  where  "cl \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<not>(a \<^bold>\<and> \<^bold>\<not>a) \<^bold>\<rightarrow> \<^bold>\<circ>a]"
abbreviation cf where "cf \<equiv> \<forall>a. [\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<not>a \<^bold>\<rightarrow> a]"
abbreviation ce where "ce \<equiv> \<forall>a. [\<^bold>\<turnstile> a \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>\<not>a]"

lemma "ciw \<longleftrightarrow> (\<forall>X. \<^bold>\<sim>(X \<^bold>\<and> S\<^sub>\<not> X) \<^bold>\<preceq> S\<^sub>\<circ> X)" unfolding conn by metis
lemma "ci \<longleftrightarrow> (\<forall>X. \<^bold>\<sim>(X \<^bold>\<and> S\<^sub>\<not> X) \<^bold>\<preceq> (S\<^sub>\<circ> X \<^bold>\<leftharpoonup> S\<^sub>\<not>(\<^bold>\<sim>(X \<^bold>\<and> S\<^sub>\<not> X) \<^bold>\<and> (S\<^sub>\<circ> X))))" unfolding conn by metis
lemma "cl \<longleftrightarrow> (\<forall>X. S\<^sub>\<not>(X \<^bold>\<and> S\<^sub>\<not> X) \<^bold>\<preceq> \<^bold>\<sim>(X \<^bold>\<and> S\<^sub>\<not> X) \<and> \<^bold>\<sim>(X \<^bold>\<and> S\<^sub>\<not> X) \<^bold>\<preceq> S\<^sub>\<circ> X)" using pcon_rel1 unfolding conn by metis
lemma "cf \<longleftrightarrow> (\<forall>X. (X \<^bold>\<leftharpoonup> (S\<^sub>\<not> X)) \<^bold>\<or> S\<^sub>\<not>(X \<^bold>\<rightarrow> (S\<^sub>\<not> X)) \<^bold>\<preceq> X)" unfolding conn by simp
lemma "ce \<longleftrightarrow> (\<forall>X. X \<^bold>\<preceq> (X \<^bold>\<leftharpoonup> (S\<^sub>\<not> X)) \<^bold>\<or> S\<^sub>\<not>(X \<^bold>\<rightarrow> (S\<^sub>\<not> X)))" unfolding conn by simp

end


theory Project
imports IPP_Lib
begin

(** PROJECT ASSIGNMENT FOR CERTIFIED PROGRAMMING COURSE

  ISSUED: Nov 17, 2017
  DUE: Dec 11, 11:59pm, 2017

  The deadline is the same for the graduate and undergraduate section.
  However, graduate students have to solve both, part I and part II, while
  undergraduates only need to solve part I.
*)

chapter \<open>General Hints and Guidelines\<close>
text \<open>
  \<^item> This folder comes with a large collection of
    examples (@{file \<open>Examples.thy\<close>}), which may provide some reference
    on how to use the VCG. It is basically the VCG we used in Tutorial5!

  \<^item> For the sorting algorithm, the two parts of its specification, i.e.,
    sortedness and preservation of elements, are independent, and you can prove
    each part separately! For example, you might first want to only prove
    preservation, and then extend your invariants and specifications to also
    show sortedness.

    If you managed to prove one property, but not not both, make sure to submit a theory that contains:
      \<^item> A complete theory file with the proof of one property, without any \<open>sorry\<close>s.
      \<^item> A separate file with your failed proof attempt of the other property or the full
        specification.

  \<^item> If you should have problems proving total correctness, you may also prove partial correctness!
    However, note that the termination proofs are straightforward!

  \<^item> Start working on the project EARLY! You cannot solve this project on
    the weekend before the deadline!

\<close>

chapter \<open>Part I: Insertion Sort\<close>
(* To be solved by all students *)

text \<open>The objective of this project is to develop an insertion sort algorithm.
  See \<^url>\<open>https://en.wikipedia.org/wiki/Insertion_sort\<close> for an overview.
  Parts of this project assignment will refer to the terminology used in
  the Wikipedia article, so it is highly recommended to read it first!
\<close>

context
begin

unbundle IMP_Syntax
interpretation Vcg_Aux_Lemmas .

section \<open>Algorithm\<close>
text \<open>
  We modify the algorithm presented at the Wikipedia page to sort an array \<open>a\<close>
  in the range \<open>l..<h\<close>.
  Recall that our array indexes are integers, so there are no restrictions on
  \<open>l\<close> or \<open>h\<close> being positive (This will make the proofs simpler!).

  We split the algorithm into three parts:
    \<^item> a swap function, which swaps \<open>a[j-1]\<close> and \<open>a[j]\<close>
    \<^item> an insert function, which inserts element a[i] to its correct position
      in a[l..<i]
    \<^item> the main loop, which sorts the array by repeatedly calling insert.

\<close>

definition "swap_prog \<equiv> CLR t;; t::=a\<^bold>[$j - \<acute>1\<^bold>];; a\<^bold>[$j - \<acute>1\<^bold>]::=a\<^bold>[$j\<^bold>];; a\<^bold>[$j\<^bold>]::=$t"

definition "insert_prog \<equiv>
  CLR j;;
  j::=$i;;
  WHILE $j>$l && a\<^bold>[$j-\<acute>1\<^bold>] > a\<^bold>[$j\<^bold>] DO (
    swap_prog;;
    j::=$j - \<acute>1
  )"

definition "sort_prog \<equiv>
  CLR i;;
  i::=$l + \<acute>1;;
  WHILE $i < $h DO (
    insert_prog;;
    i::=$i+\<acute>1
  )"

(* Boilerplate to make automatic computation of modified variable's approximation work smoothly *)

text \<open>Your task is to verify that this algorithm terminates and actually sorts the array!

  Recall that sorting an array requires to specify that:
    \<^enum> the resulting array is actually sorted,
    \<^enum> and contains exactly the elements of the original array
\<close>

subsection \<open>Sorted Range\<close>

text \<open>Sortedness of a range \<open>l..<h\<close> can be expressed as follows:\<close>
definition ran_sorted :: "(int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "ran_sorted a l h \<equiv> \<forall>i\<in>{l..<h}. \<forall>j\<in>{l..<h}. i\<le>j \<longrightarrow> a i \<le> a j"

text \<open>Here, the notation \<open>{l..<h}\<close> denotes the sets of numbers in range \<open>l..<h\<close>,
  and comes with a reasonable setup.

  A more primitive way of defining sortedness would be the following:
\<close>
lemma ran_sorted_alt: "ran_sorted a l h = ( \<forall>i j. l\<le>i \<and> i<j \<and> j<h \<longrightarrow> a i \<le> a j)"
  by (smt atLeastLessThan_iff ran_sorted_def)

text \<open>While working on this project, you are likely to require more
  lemmas about sorted ranges. It is a good idea to put these lemmas here,
  and not intersperse them with the other lemmas of your theory.
\<close>

subsection \<open>Multiset of Range\<close>
text \<open>For the multiset of the elements in a range, we use @{const mset_ran}.
  The lemmas needed for this are provided, you should never need to unfold
  @{thm mset_ran_def}.
\<close>

subsection \<open>Swap\<close>

text \<open>We define a function to swap two elements of a range\<close>
definition "swap a i j \<equiv> a(i:=a j, j:=a i)"

text \<open>And prove that it preserves the multiset of that range\<close>
lemma mset_ran_swap: "\<lbrakk> l\<le>i; i<j; j<h \<rbrakk>
  \<Longrightarrow> mset_ran (swap a i j) l h = mset_ran a l h"
  by (auto simp: swap_def mset_ran_subst_inside)

text \<open>Remark on variable bindings in pre/postconditions:
  Array variables must be bound as \<open>(name:imap)\<close>!
  See specification below for an example!
\<close>

lemma swap_prog_correct[vcg_rules]: "\<Turnstile>\<^sub>t {\<lambda>a\<^sub>0. vars (a:imap) j in a=a\<^sub>0}
            swap_prog
          {\<lambda>a\<^sub>0. vars (a:imap) j in a=swap a\<^sub>0 (j-1) j} mod {''a'',''t''}"
  unfolding swap_prog_def (* Note: swap_prog is defined as constant, so you have to unfold its definition! *)
  apply vcg
  by (simp add: Project.swap_def)

section \<open>Insert\<close>

text \<open>
  The insert algorithm is the most tricky part!
  It takes a sorted range \<open>l..<i\<close> and then "swaps down" the
  element \<open>i+1\<close> to its correct position. During the loop,
  \<open>j\<close> is the index of the swapped-down element.

  Intuitively, \<open>j\<close> splits the range \<open>l..<i+1\<close> into a left range L=\<open>l..<j\<close> and
  a right range R=\<open>j+1..<i+1\<close>. The element \<open>j\<close> is in the gap between L and R.

  Hint: Drawing this situation on a piece of paper might help a lot in getting the intuition!

  Initially, the range R is empty. During the loop, the following invariant is maintained:
    \<^item> L and R are both sorted
    \<^item> The elements of L are smaller than or equal than the elements of R
    \<^item> The element a[j] is (strictly) smaller than every element of R
    \<^item> The multiset of the whole array (l..<h) does not change

  When the loop terminates, a[j] is greater than or equal the last element
  of L. Moreover, the invariant guarantees that a[j] is less than the elements
  in R, and both L and R are sorted. Thus, the whole range \<open>L a[j] R\<close> is sorted.

  Note that we phrased some relations on every element of L or R.
  As L and R are sorted, it might be tempting to say, e.g.,

    \<^item> the last element of L is less than or equal than the first element of R

  However, L and R may be empty, and thus have no last/first element,
  which would require to formalize a lot of corner cases. With our
  formulation, we can just write, e.g., \<open>\<forall>k\<in>{j+1..<i+1}. \<dots>\<close>, regardless
  of whether the range is empty or not.

\<close>

(** Define the invariant and prove the insert algorithm correct! *)
definition insert_invar :: "(int \<Rightarrow> int) \<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "insert_invar a\<^sub>0 a l h i j \<equiv>
    i \<ge> j \<and> i> l \<and> h > i \<and> (* boundary conditions*)
    ( \<forall>k\<in>{j+1..<i+1}. a j \<le> a k)\<and> (* a[j] < R *)
    ran_sorted a l j \<and> ran_sorted a (j+1) (i+1) \<and>(* L and R are sorted*)
    (\<forall>k1\<in>{l..<j}. \<forall>k2\<in>{j+1..<i+1}. a k1 \<le> a k2) \<and>  (* Elements of L \<le> R *)
    mset_ran a l h = mset_ran a\<^sub>0 l h   (* Multiset of whole range unchanged *)
    "

subsection \<open>VCs\<close>
(**
  Hint: Extract each verification condition to its own lemmas.
    To prove these lemmas, more auxiliary lemmas and Isar proofs may be
    a good idea (although skillful use of auto/sledgehammer may bring you quite far).

    Moreover, it is very likely that quickcheck will find counterexamples
    to your VCs, if your invariant/spec is wrong. Sometimes, these counterexamples
    help to fix the invariant/spec. See below for example!

    Below are just a few examples of lemmas that I used
    (For you, they may look different)
*)

subsubsection \<open>Auxiliary Lemmas\<close>
text \<open>Swapping outside a range does not change its sortedness.
  (here the two elements right of the range are swapped)
\<close>
lemma ran_sorted_swap_outside:
  "ran_sorted (swap a (j - 1) j) l (j - 1) \<longleftrightarrow> ran_sorted a l (j-1)"
  by (auto simp: ran_sorted_def swap_def)

text \<open>
  Swapping and extending R by one element to the left preserves sortedness.
\<close>
lemma
  "\<lbrakk>l < j;                              (* L not empty, i.e., there is a last element to swap with  *)
    ran_sorted a (j + 1) (i + 1);       (* R is sorted *)
    \<forall>k1\<in>{l..<j}. \<forall>k2\<in>{j + 1..<i + 1}. a k1 \<le> a k2 (* Elements in L \<le> R *)
  \<rbrakk>
  \<Longrightarrow> ran_sorted (swap a (j - 1) j) j (i + 1)" (* Extended R is sorted after swapping *)

  sorry (* You only need to prove this lemma if you actually use it.
            Otherwise, remove it from your submission. *)

(* Add more lemmas here as required *)

subsubsection \<open>VCs\<close>
(* Put your lemmas that you extracted from the VCG here *)
lemma ins_aux0:
"\<And>z a l h i ja k.
       l < ja \<Longrightarrow>
       a ja < a (ja - 1) \<Longrightarrow>
       i < h \<Longrightarrow>
       \<forall>k\<in>{ja + 1..<i + 1}. a ja \<le> a k \<Longrightarrow>
       ran_sorted a l ja \<Longrightarrow>
       ran_sorted a (ja + 1) (i + 1) \<Longrightarrow>
       \<forall>k1\<in>{l..<ja}. \<forall>k2\<in>{ja + 1..<i + 1}. a k1 \<le> a k2 \<Longrightarrow>
       mset_ran a l h = mset_ran z l h \<Longrightarrow> ja \<le> k \<Longrightarrow> k \<le> i \<Longrightarrow> swap a (ja - 1) ja (ja - 1) \<le> swap a (ja - 1) ja k"

  unfolding mset_ran_def swap_def image_mset_def
  by simp
lemma ins_aux1:   " \<And>z a l h i ja.
       l < ja \<Longrightarrow>
       a ja < a (ja - 1) \<Longrightarrow>
       ja \<le> i \<Longrightarrow>
       i < h \<Longrightarrow>
       \<forall>k\<in>{ja + 1..<i + 1}. a ja \<le> a k \<Longrightarrow>
       ran_sorted a l ja \<Longrightarrow>
       ran_sorted a (ja + 1) (i + 1) \<Longrightarrow>
       \<forall>k1\<in>{l..<ja}. \<forall>k2\<in>{ja + 1..<i + 1}. a k1 \<le> a k2 \<Longrightarrow>
       mset_ran a l h = mset_ran z l h \<Longrightarrow> ran_sorted (swap a (ja - 1) ja) ja (i + 1)"
  unfolding mset_ran_def swap_def image_mset_def
  by (simp add: ran_sorted_def)

lemma ins_aux2 :"\<And>z a l h i ja k1 k2.
       a ja < a (ja - 1) \<Longrightarrow>
       i < h \<Longrightarrow>
       \<forall>k\<in>{ja + 1..<i + 1}. a ja \<le> a k \<Longrightarrow>
       ran_sorted a l ja \<Longrightarrow>
       ran_sorted a (ja + 1) (i + 1) \<Longrightarrow>
       \<forall>k1\<in>{l..<ja}. \<forall>k2\<in>{ja + 1..<i + 1}. a k1 \<le> a k2 \<Longrightarrow>
       mset_ran a l h = mset_ran z l h \<Longrightarrow>
       l \<le> k1 \<Longrightarrow> k1 < ja - 1 \<Longrightarrow> ja \<le> k2 \<Longrightarrow> k2 \<le> i \<Longrightarrow> swap a (ja - 1) ja k1 \<le> swap a (ja - 1) ja k2"
  unfolding mset_ran_def swap_def image_mset_def
  by (simp add: ran_sorted_alt)

lemma insert_aux0: "\<And>z a l h i ja.
       insert_invar z a l h i ja \<Longrightarrow> l < ja \<Longrightarrow> a ja < a (ja - 1) \<Longrightarrow> insert_invar z (swap a (ja - 1) ja) l h i (ja - 1)"
  apply (auto simp: insert_invar_def)
  prefer 2
  using ran_sorted_alt ran_sorted_swap_outside apply auto[1]
  prefer 4
  apply (simp add: mset_ran_swap)
  using ins_aux0 apply blast
  using ins_aux1 apply blast
  using ins_aux2 apply blast
  done

lemma insert_aux1: "\<And>z a l h i j. l < j \<longrightarrow> \<not> a j < a (j - 1) \<Longrightarrow> insert_invar z a l h i j \<Longrightarrow> ran_sorted a l (i + 1)"
  apply (auto simp: insert_invar_def)
  apply (smt atLeastLessThan_iff ran_sorted_alt)
  by (smt atLeastLessThan_iff ran_sorted_alt)
lemma insert_aux2: "\<And>z l i h. l < i \<Longrightarrow> i < h \<Longrightarrow> ran_sorted z l i \<Longrightarrow> insert_invar z z l h i i"
  apply (auto simp: insert_invar_def)
  by (simp add: ran_sorted_alt)

subsection \<open>Correctness Proof\<close>
lemma insert_correct[vcg_rules]: "
  \<Turnstile>\<^sub>t {\<lambda>a\<^sub>0. vars l i h (a:imap) in a=a\<^sub>0 \<and> l<i \<and>i<h \<and> ran_sorted a l i}
        insert_prog
     {\<lambda>a\<^sub>0. vars l i h (a:imap) in
        ran_sorted a l (i+1)
      \<and> mset_ran a l h = mset_ran a\<^sub>0 l h
      }
     mod {''a'',''t'',''j''}"
  unfolding insert_prog_def
  supply insert_aux0[simp] insert_aux1[simp] insert_aux2[simp]
  apply (rewrite annot_tinvar[where
        R = "measure_exp ($j - $l)" and
        I = "\<lambda>a\<^sub>0. vars (a:imap) l h i j in insert_invar a\<^sub>0 a l h i j" ])
  apply (vcg_all; (auto simp: insert_invar_def; fail)?)
  done

section \<open>Insertion Sort\<close>

text \<open> Here, you are on your own!
  Come up with a specification for @{const sort_prog} and prove it correct.

  Note: Do not use @{term lran} as in Tutorial~5, but use
  our @{const ran_sorted} and @{const mset_ran}! These do not go the detour
  over lists, and are thus easier to handle!

  Note: You are *not* required to specify that the elements
    of the array outside the range \<open>l..<h\<close> are preserved (cf. Bonus 1).
\<close>

definition sort_invar :: "(int \<Rightarrow> int)\<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "sort_invar a\<^sub>0 a l h i  \<equiv>
  ran_sorted a l i \<and>
  i > l \<and> i \<le> h \<and>
  mset_ran a l h = mset_ran a\<^sub>0 l h
"

lemma sort_correct[vcg_rules]: "
  \<Turnstile>\<^sub>t {\<lambda>a\<^sub>0. vars l h i (a:imap) in a=a\<^sub>0 \<and> l<h}
  sort_prog
  {\<lambda>a\<^sub>0. vars l h i (a:imap) in
      ran_sorted a l h
      \<and> mset_ran a l h = mset_ran a\<^sub>0 l h
  } mod {''a'',''t'', ''i'',''j''}"
  unfolding sort_prog_def
  apply (rewrite annot_tinvar[where
        R="measure_exp ($h - $i)" and
        I="\<lambda>a\<^sub>0. vars (a:imap) l h i in sort_invar a\<^sub>0 a l h i " ])
  apply (vcg_all; (auto simp: sort_invar_def; fail)?)
  by (simp add: ran_sorted_alt sort_invar_def)

section \<open>Bonuses\<close>
(* To grab some bonus points, for all students.

  We give 3 bonus assignments, each worth 5 bonus-% towards your final grade,
  i.e., these will be directly added to your final course percentage,
  from which your grade will be computed.

  WARNING: Only attempt these after you have solved the regular project!
    The first bonus assignment is relatively easy, the last two are hard!
    I will only give points for proofs
    (or serious proof attempts with partial results), not for
    an implementation of the algorithm without proof!

*)

subsection \<open>Elements Outside Range\<close>
text \<open>Augment your specifications and proofs to express that elements outside
  the range \<open>l..<h\<close> are not touched.
  Hint: @{prop \<open>a = a\<^sub>0 on -{l..<h}\<close>}, @{const eq_on}
\<close>

definition boundary_invar :: "(int \<Rightarrow> int)\<Rightarrow> (int \<Rightarrow> int) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "boundary_invar a\<^sub>0 a l h i  \<equiv>
ran_sorted a l h\<and>
  i > l \<and> i \<le> h  "

lemma sort_boundary_correct[vcg_rules]: "
  \<Turnstile>\<^sub>t {\<lambda>a\<^sub>0. vars l h i (a:imap) in l<h}
  sort_prog
  {\<lambda>a\<^sub>0. vars l h i (a:imap) in a = a\<^sub>0 on -{l..<h}
  } mod {''a'',''t'', ''i'',''j''}"
  unfolding sort_prog_def eq_on_def
  apply (rewrite annot_tinvar[where
        R="measure_exp ($h - $i)" and
        I="\<lambda>a\<^sub>0. vars (a:imap) l h i in boundary_invar a\<^sub>0 a l h i " ])
  apply (vcg_all; (auto simp: boundary_invar_def eq_on_def; fail)?)
  prefer 2
  quickcheck
  sorry

subsection \<open>Optimized insert Function\<close>
text \<open>
  The Wikipedia page mentions an optimized version of the inner loop,
  that stores the element at \<open>i\<close>, then shifts the elements of the array to the
  right while finding the insertion position, and finally inserts the stored element.

  Implement and prove (totally) correct the optimized insert function!
  DO NOT CHANGE YOUR ORIGINAL SOLUTION, BUT PROVIDE A COPY OF THE INSERT FUNCTION
\<close>

subsection \<open>Binary Search\<close>
text \<open>
  Implement and prove total correctness of an algorithm to find an index
  \<open>i\<in>{l..<h}\<close> with \<open>a[i] == x\<close>. You may assume that the array is sorted in
  the range \<open>l..<h\<close>. If the range does not contain the element \<open>x\<close>, return
  the index \<open>h\<close> (one beyond the end of the range).

  CAVEAT: I will only accept algorithms that run in logarithmic time in
    the size of the range. The obvious choice is binary search
    \<^url>\<open>https://en.wikipedia.org/wiki/Binary_search_algorithm\<close>

  HINT: If you plan to solve this bonus, have a look at Part II of the project,
    which is somewhat related!

\<close>

chapter \<open>Part II: Sqrt by Bisection\<close>
(* Only GRADUATE students *)

subsection \<open>Bisection\<close>
text \<open>A more efficient way of inverting monotonic functions is by bisection,
  that is, keep track of a possible interval for the solution, and half the
  interval in each step. The algorithm only needs $O(\log n)$ iterations.

  Implement bisection search to determine \<open>\<lfloor>sqrt x\<rfloor>\<close>, i.e., the square root of
  \<open>x\<close>, rounded down. You may assume that \<open>x\<close> is positive!

  High-level description of the algorithm:
    \<^item> Initialize \<open>l\<close> and \<open>h\<close> with safe under and over approximations,
      i.e. such that \<open>l\<^sup>2 \<le> x < h\<^sup>2\<close>

    \<^item> Iterate: Compute the midpoint \<open>m\<close> of the interval \<open>l..<h\<close>, and check whether
      \<open>m\<^sup>2 \<le> x\<close>. Depending on this check, adjust \<open>l\<close> or \<open>h\<close>.

    \<^item> Terminate the iteration if \<open>l\<close> and \<open>h\<close> are close enough together.
      Hint: You do not need to terminate immediately if you luckily hit
      \<open>m\<^sup>2 = x\<close>, but you can always wait until the interval has shrunk enough.
      This saves you a lot of corner cases and makes the proof simpler.

  Warning: Although the final algorithm looks quite simple,
    getting it right can be quite tricky. It is very prone
    to off-by-one errors.

  Specify the algorithm, and prove total correctness.
\<close>

definition "sqrt_bisect_prog \<equiv>
CLR l;; CLR h;;
l::= N 1;;
h::= $x + (N 1);;
WHILE  ($h - $l) > N 1 DO
(
  IF ( (($l + $h) div N 2) *(($l + $h) div N 2) ) <= $x THEN
    l::= (($l + $h) div N 2)
  ELSE
    h::= (($l + $h) div N 2)
)
"

text \<open>Hint: Testing the algorithm before attempting to prove it may be a good idea! \<close>
schematic_goal "(sqrt_bisect_prog, <''x'' := var 1>) \<Rightarrow> ?s"
  unfolding sqrt_bisect_prog_def
  by BigSteps

definition bisection_invar:: " int \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool"
  where "bisection_invar  l h x \<equiv>  1\<le>l \<and> l < h \<and> l\<^sup>2 \<le> x \<and> x < h\<^sup>2"

lemma bisect_aux0:
" \<And>l h x. 1 < h - l \<Longrightarrow>
             bisection_invar l h x \<Longrightarrow> (l + h) div 2 * ((l + h) div 2) \<le> x \<Longrightarrow> bisection_invar ((l + h) div 2) h x"
  apply (auto simp:bisection_invar_def)
  by (simp add: power2_eq_square)

lemma bisect_aux1:
"\<And>l h x. 1 < h - l \<Longrightarrow>
             bisection_invar l h x \<Longrightarrow> \<not> (l + h) div 2 * ((l + h) div 2) \<le> x \<Longrightarrow> bisection_invar l ((l + h) div 2) x"
  apply (auto simp:bisection_invar_def)
  by (simp add: power2_eq_square)

lemma bisect_aux2:
" \<And>l h x. \<not> 1 < h - l \<Longrightarrow> bisection_invar l h x \<Longrightarrow> x < (l + 1)\<^sup>2"
  apply (auto simp:bisection_invar_def)
  by smt

lemma bisect_aux3:
" \<And>x. 1 \<le> x \<Longrightarrow> bisection_invar 1 (x + 1) x "
  apply (auto simp:bisection_invar_def)
  by (smt one_less_numeral_iff power_one_right power_strict_increasing semiring_norm(76))
(*
  The specification is provided.
*)
lemma sqrt_bisect_correct: "
  \<Turnstile>\<^sub>t {\<lambda>_. vars x in 1\<le>x }
       sqrt_bisect_prog
     {\<lambda>_. vars l x in 1\<le>l \<and> l\<^sup>2\<le>x \<and> x<(l+1)\<^sup>2 } mod {''l'',''h'',''m''}"
  unfolding sqrt_bisect_prog_def
  apply (rewrite annot_tinvar[where
        R="measure (\<lambda>s. nat (s ''h'' 0 - s ''l'' 0))" and
        I="\<lambda>_. vars l h x in bisection_invar l h x"
         ])
  supply bisect_aux0[simp] bisect_aux1[simp] bisect_aux2[simp] bisect_aux3[simp]
  apply (vcg_all; (auto simp: bisection_invar_def; fail)?)
  done
  (*
    Hint: I used the invariant
      \<open>\<lambda>_. vars l h x in 0\<le>l \<and> l<h \<and> l\<^sup>2\<le>x \<and> x<h\<^sup>2\<close>
    which just states that the solution is in the interval \<open>l..<h\<close>.

    Note that, if you implement the algorithm differently than I did,
    you may need to change the invariant. DO NOT CHANGE THE SPECIFICATION.
  *)

end
end


theory append
imports Main
        "../data/list"
        "$HIPSTER_HOME/IsaHipster"

begin

fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

(*hipster append*)

lemma lemma_a [thy_expl]: "append x2 Nil2 = x2"
by (hipster_induct_schemes  append.simps)

lemma lemma_aa [thy_expl]: "append (append x2 y2) z2 = append x2 (append y2 z2)"
by (hipster_induct_schemes append.simps)

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

header {* Well-Quasi-Orders *}

theory Well_Quasi_Orders
imports Almost_Full_Relations
begin

subsection {* Basic Definitions *}

definition wqo_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "wqo_on P A \<longleftrightarrow> transp_on P A \<and> almost_full_on P A"

lemma wqo_on_UNIV:
  "wqo_on (\<lambda>_ _. True) UNIV"
  using almost_full_on_UNIV by (auto simp: wqo_on_def transp_on_def)

lemma wqo_onI [Pure.intro]:
  "\<lbrakk>transp_on P A; almost_full_on P A\<rbrakk> \<Longrightarrow> wqo_on P A"
  unfolding wqo_on_def almost_full_on_def by blast

lemma wqo_on_imp_reflp_on:
  "wqo_on P A \<Longrightarrow> reflp_on P A"
  using almost_full_on_imp_reflp_on by (auto simp: wqo_on_def)

lemma wqo_on_imp_transp_on:
  "wqo_on P A \<Longrightarrow> transp_on P A"
  by (auto simp: wqo_on_def)

lemma wqo_on_imp_almost_full_on:
  "wqo_on P A \<Longrightarrow> almost_full_on P A"
  by (auto simp: wqo_on_def)

lemma wqo_on_imp_qo_on:
  "wqo_on P A \<Longrightarrow> qo_on P A"
  by (metis qo_on_def wqo_on_imp_reflp_on wqo_on_imp_transp_on)

lemma wqo_on_imp_good:
  "wqo_on P A \<Longrightarrow> \<forall>i. f i \<in> A \<Longrightarrow> good P f"
  by (auto simp: wqo_on_def almost_full_on_def)

lemma wqo_on_subset:
  "A \<subseteq> B \<Longrightarrow> wqo_on P B \<Longrightarrow> wqo_on P A"
  using almost_full_on_subset [of A B P]
    and transp_on_subset [of A B P]
  unfolding wqo_on_def by blast

subsection {* Equivalent Definitions *}

text {*
  Given a quasi-order @{term P}, the following statements are equivalent:
  \begin{enumerate}
  \item @{term P} is a almost-full.
  \item @{term P} does neither allow decreasing chains nor antichains.
  \item Every quasi-order extending @{term P} is well-founded.
  \end{enumerate}
*}

lemma wqo_af_conv:
  assumes "qo_on P A"
  shows "wqo_on P A \<longleftrightarrow> almost_full_on P A"
  using assms by (metis qo_on_def wqo_on_def)

lemma wqo_wf_and_no_antichain_conv:
  assumes "qo_on P A"
  shows "wqo_on P A \<longleftrightarrow> wfp_on (strict P) A \<and> \<not> (\<exists>f. antichain_on P f A)"
  unfolding wqo_af_conv [OF assms]
  using af_trans_imp_wf [OF _ assms [THEN qo_on_imp_transp_on]]
    and almost_full_on_imp_no_antichain_on [of P A]
    and wf_and_no_antichain_imp_qo_extension_wf [of P A]
    and every_qo_extension_wf_imp_af [OF _ assms]
    by blast

lemma wqo_extensions_wf_conv:
  assumes "qo_on P A"
  shows "wqo_on P A \<longleftrightarrow> (\<forall>Q. (\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y) \<and> qo_on Q A \<longrightarrow> wfp_on (strict Q) A)"
  unfolding wqo_af_conv [OF assms]
  using af_trans_imp_wf [OF _ assms [THEN qo_on_imp_transp_on]]
    and almost_full_on_imp_no_antichain_on [of P A]
    and wf_and_no_antichain_imp_qo_extension_wf [of P A]
    and every_qo_extension_wf_imp_af [OF _ assms]
    by blast

lemma wqo_on_imp_wfp_on:
  "wqo_on P A \<Longrightarrow> wfp_on (strict P) A"
  by (metis (no_types) wqo_on_imp_qo_on wqo_wf_and_no_antichain_conv)

text {*
  The homomorphic image of a wqo set is wqo.
*}
lemma wqo_on_hom:
  assumes "transp_on Q (h ` A)"
    and "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q (h x) (h y)"
    and "wqo_on P A"
  shows "wqo_on Q (h ` A)"
  using assms and almost_full_on_hom [of A P Q h]
  unfolding wqo_on_def by blast

text {*
  The monomorphic preimage of a wqo set is wqo.
*}
lemma wqo_on_mon:
  assumes trans: "transp_on P A"
    and mon: "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longleftrightarrow> Q (h x) (h y)" "bij_betw h A B"
    and wqo: "wqo_on Q B"
  shows "wqo_on P A"
  using assms and almost_full_on_mon [of A P Q h]
  unfolding wqo_on_def by blast

subsection {* A Type Class for Well-Quasi-Orders *}

text {*
  In a well-quasi-order (wqo) every infinite sequence is good.
*}
class wqo = preorder +
  assumes good: "good (op \<le>) f"

lemma wqo_on_UNIV_class_wqo [intro!]:
  "wqo_on P UNIV \<Longrightarrow> class.wqo P (strict P)"
  by (unfold_locales) (auto simp: wqo_on_def almost_full_on_def, unfold transp_on_def, blast)

text {*
  The following lemma converts between @{const wqo_on} (for the special case that the domain is the
  universe of a type) and the class predicate @{const class.wqo}.
*}
lemma wqo_on_UNIV_conv:
  "wqo_on P UNIV \<longleftrightarrow> class.wqo P (strict P)" (is "?lhs = ?rhs")
proof
  assume "?lhs" then show "?rhs" by auto
next
  assume "?rhs" then show "?lhs"
    unfolding class.wqo_def class.preorder_def class.wqo_axioms_def
    by (auto simp: wqo_on_def almost_full_on_def transp_on_def)
qed

text {*
  The strict part of a wqo is well-founded.
*}
lemma (in wqo) "wfP (op <)"
proof -
  have "class.wqo (op \<le>) (op <)" ..
  hence "wqo_on (op \<le>) UNIV"
    unfolding less_le_not_le [abs_def] wqo_on_UNIV_conv [symmetric] .
  from wqo_on_imp_wfp_on [OF this]
    show ?thesis unfolding less_le_not_le [abs_def] wfp_on_UNIV .
qed

lemma wqo_on_with_bot:
  assumes "wqo_on P A"
  shows "wqo_on (option_le P) A\<^sub>\<bottom>" (is "wqo_on ?P ?A")
proof -
  { from assms have trans [unfolded transp_on_def]: "transp_on P A"
      by (auto simp: wqo_on_def)
    have "transp_on ?P ?A"
      by (auto simp: transp_on_def elim!: with_bot_cases, insert trans) blast }
  moreover
  { from assms and almost_full_on_with_bot
      have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
  ultimately
  show ?thesis by (auto simp: wqo_on_def)
qed

lemma wqo_on_option_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on (option_le P) UNIV"
  using wqo_on_with_bot [of P UNIV] by simp

text {*
  When two sets are wqo, then their disjoint sum is wqo.
*}
lemma wqo_on_Plus:
  assumes "wqo_on P A" and "wqo_on Q B"
  shows "wqo_on (sum_le P Q) (A <+> B)" (is "wqo_on ?P ?A")
proof -
  { from assms have trans [unfolded transp_on_def]: "transp_on P A" "transp_on Q B"
      by (auto simp: wqo_on_def)
    have "transp_on ?P ?A"
      unfolding transp_on_def by (auto, insert trans) (blast+) }
  moreover
  { from assms and almost_full_on_Plus have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
  ultimately
  show ?thesis by (auto simp: wqo_on_def)
qed

lemma wqo_on_sum_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on Q UNIV \<Longrightarrow> wqo_on (sum_le P Q) UNIV"
  using wqo_on_Plus [of P UNIV Q UNIV] by simp

subsection {* Dickson's Lemma *}

lemma wqo_on_Sigma:
  fixes A1 :: "'a set" and A2 :: "'b set"
  assumes "wqo_on P1 A1" and "wqo_on P2 A2"
  shows "wqo_on (prod_le P1 P2) (A1 \<times> A2)" (is "wqo_on ?P ?A")
proof -
  { from assms have "transp_on P1 A1" and "transp_on P2 A2" by (auto simp: wqo_on_def)
    hence "transp_on ?P ?A" unfolding transp_on_def prod_le_def by blast }
  moreover
  { from assms and almost_full_on_Sigma [of P1 A1 P2 A2]
      have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
  ultimately
  show ?thesis by (auto simp: wqo_on_def)
qed

lemmas dickson = wqo_on_Sigma

lemma wqo_on_prod_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on Q UNIV \<Longrightarrow> wqo_on (prod_le P Q) UNIV"
  using wqo_on_Sigma [of P UNIV Q UNIV] by simp

subsection {* Higman's Lemma *}

lemma transp_on_list_emb:
  assumes "transp_on P A"
  shows "transp_on (list_emb P) (lists A)"
  using assms and list_emb_trans [of _ _ _ P]
    unfolding transp_on_def by blast

lemma wqo_on_lists:
  assumes "wqo_on P A" shows "wqo_on (list_emb P) (lists A)"
  using assms and almost_full_on_lists
    and transp_on_list_emb by (auto simp: wqo_on_def)

lemmas higman = wqo_on_lists

lemma wqo_on_list_UNIV [intro]:
  "wqo_on P UNIV \<Longrightarrow> wqo_on (list_emb P) UNIV"
  using wqo_on_lists [of P UNIV] by simp

text {*
  Every reflexive and transitive relation on a finite set is a wqo.
*}
lemma finite_wqo_on:
  assumes "finite A" and refl: "reflp_on P A" and "transp_on P A"
  shows "wqo_on P A"
  using assms and finite_almost_full_on by (auto simp: wqo_on_def)

lemma finite_eq_wqo_on:
  assumes "finite A"
  shows "wqo_on (op =) A"
  using finite_wqo_on [OF assms, of "op ="]
  by (auto simp: reflp_on_def transp_on_def)

lemma wqo_on_lists_over_finite_sets:
  "wqo_on (list_emb (op =)) (UNIV::('a::finite) list set)"
  using wqo_on_lists [OF finite_eq_wqo_on [OF finite [of "UNIV::('a::finite) set"]]] by simp

lemma wqo_on_map:
  fixes P and Q and h
  defines "P' \<equiv> \<lambda>x y. P x y \<and> Q (h x) (h y)"
  assumes "wqo_on P A"
    and "wqo_on Q B"
    and subset: "h ` A \<subseteq> B"
  shows "wqo_on P' A"
proof
  let ?Q = "\<lambda>x y. Q (h x) (h y)"
  from `wqo_on P A` have "transp_on P A"
    by (rule wqo_on_imp_transp_on)
  then show "transp_on P' A"
    using `wqo_on Q B` and subset
    unfolding wqo_on_def transp_on_def P'_def by blast

  from `wqo_on P A` have "almost_full_on P A"
    by (rule wqo_on_imp_almost_full_on)
  from `wqo_on Q B` have "almost_full_on Q B"
    by (rule wqo_on_imp_almost_full_on)

  show "almost_full_on P' A"
  proof
    fix f
    assume *: "\<forall>i::nat. f i \<in> A"
    from almost_full_on_imp_homogeneous_subseq [OF `almost_full_on P A` this]
      obtain g :: "nat \<Rightarrow> nat"
      where g: "\<And>i j. i < j \<Longrightarrow> g i < g j"
      and **: "\<forall>i. f (g i) \<in> A \<and> P (f (g i)) (f (g (Suc i)))"
      using * by auto
    from chain_on_transp_on_less [OF ** `transp_on P A`]
      have **: "\<And>i j. i < j \<Longrightarrow> P (f (g i)) (f (g j))" .
    let ?g = "\<lambda>i. h (f (g i))"
    from * and subset have B: "\<And>i. ?g i \<in> B" by auto
    with `almost_full_on Q B` [unfolded almost_full_on_def good_def, THEN bspec, of ?g]
      obtain i j :: nat
      where "i < j" and "Q (?g i) (?g j)" by blast
    with ** [OF `i < j`] have "P' (f (g i)) (f (g j))"
      by (auto simp: P'_def)
    with g [OF `i < j`] show "good P' f" by (auto simp: good_def)
  qed
qed

lemma wqo_on_UNIV_nat:
  "wqo_on (op \<le>) (UNIV :: nat set)"
  unfolding wqo_on_def transp_on_def
  using almost_full_on_UNIV_nat by simp

end