(*
  File: Module.thy
  Author: Bohua Zhan

  Definition of modules.
*)

theory Module
  imports Int
begin

definition "mod_ring_name = succ(\<emptyset>)"
definition "mod_ring(M) = graph_eval(M, mod_ring_name)"
definition "mtimes_fun_name = succ(succ(succ(succ(succ(succ(succ(\<emptyset>)))))))"
definition "mtimes_fun(M) = graph_eval(M, mtimes_fun_name)"
setup {* add_field_data (@{term mod_ring_name}, @{term mod_ring}) *}
setup {* add_field_data (@{term mtimes_fun_name}, @{term mtimes_fun}) *}

definition mtimes :: "[i, i, i] \<Rightarrow> i" where [rewrite_bidir]:
  "mtimes(M,a,x) = mtimes_fun(M)`\<langle>a,x\<rangle>"
abbreviation mtimes_notation ("(_/ \<bullet>\<^sub>_ _)" [70,70,71] 70) where "a \<bullet>\<^sub>M x \<equiv> mtimes(M,a,x)"
setup {* register_wellform_data ("a \<bullet>\<^sub>M x", ["x \<in>. M", "a \<in>. mod_ring(M)"]) *}

section \<open>Module structure\<close>

definition is_mod_raw :: "i \<Rightarrow> o" where [rewrite]:
  "is_mod_raw(M) \<longleftrightarrow> is_abgroup_raw(M) \<and> is_ring(mod_ring(M)) \<and>
      mtimes_fun(M) \<in> carrier(mod_ring(M)) \<times> carrier(M) \<rightarrow> carrier(M)"

lemma is_mod_rawD1 [forward]:
  "is_mod_raw(M) \<Longrightarrow> is_abgroup_raw(M)"
  "is_mod_raw(M) \<Longrightarrow> is_ring(mod_ring(M))" by auto2+

lemma is_mod_rawD2 [typing]:
  "is_mod_raw(M) \<Longrightarrow> mtimes_fun(M) \<in> carrier(mod_ring(M)) \<times> carrier(M) \<rightarrow> carrier(M)" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_mod_raw_def} *}

definition mod_form :: "i \<Rightarrow> o" where [rewrite]:
  "mod_form(M) \<longleftrightarrow> is_mod_raw(M) \<and>
    is_func_graph(M,{carrier_name,mod_ring_name,zero_name,plus_fun_name,mtimes_fun_name})"

lemma mod_form_to_raw [forward]: "mod_form(M) \<Longrightarrow> is_mod_raw(M)" by auto2

definition LMod :: "[i, i, i, i \<Rightarrow> i \<Rightarrow> i, i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "LMod(S,R,z,p,f) = Struct({\<langle>carrier_name,S\<rangle>, \<langle>mod_ring_name,R\<rangle>,
    \<langle>zero_name,z\<rangle>, \<langle>plus_fun_name, binary_fun_of(S,p)\<rangle>,
    \<langle>mtimes_fun_name, Fun(carrier(R)\<times>S, S, \<lambda>x. f(fst(x),snd(x)))\<rangle>})"

definition mod_fun :: "i \<Rightarrow> i \<Rightarrow> [i \<Rightarrow> i \<Rightarrow> i] \<Rightarrow> o" where [rewrite]:
  "mod_fun(S,R,f) \<longleftrightarrow> (\<forall>x\<in>.R. \<forall>y\<in>S. f(x,y) \<in> S)"

lemma mod_funD [typing]: "mod_fun(S,R,f) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in> S \<Longrightarrow> f(x,y) \<in> S" by auto2
setup {* del_prfstep_thm_eqforward @{thm mod_fun_def} *}

lemma LMod_is_mod_form [backward]:
  "is_ring(R) \<Longrightarrow> z \<in> S \<Longrightarrow> binary_fun(S,p) \<Longrightarrow> mod_fun(S,R,f) \<Longrightarrow> mod_form(LMod(S,R,z,p,f))"
@proof
  @let "M = LMod(S,R,z,p,f)"
  @have "is_abgroup_raw(M)"
  @have "mtimes_fun(M) \<in> carrier(mod_ring(M)) \<times> carrier(M) \<rightarrow> carrier(M)"
@qed

lemma mod_eval [rewrite]:
  "carrier(LMod(S,R,z,p,f)) = S"
  "mod_ring(LMod(S,R,z,p,f)) = R"
  "M = LMod(S,R,z,p,f) \<Longrightarrow> \<zero>\<^sub>M = z"
  "M = LMod(S,R,z,p,f) \<Longrightarrow> x \<in>. M \<Longrightarrow> y \<in>. M \<Longrightarrow> is_mod_raw(M) \<Longrightarrow> x +\<^sub>M y = p(x,y)"
  "M = LMod(S,R,z,p,f) \<Longrightarrow> a \<in>. R \<Longrightarrow> x \<in>. M \<Longrightarrow> is_mod_raw(M) \<Longrightarrow> a \<bullet>\<^sub>M x = f(a,x)" by auto2+
setup {* del_prfstep_thm @{thm LMod_def} *}

(* Equality between left modules *)
definition eq_str_mod :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "eq_str_mod(M,N) \<longleftrightarrow> eq_str_abgroup(M,N) \<and> mod_ring(M) = mod_ring(N) \<and> mtimes_fun(M) = mtimes_fun(N)"

lemma eq_str_modD1 [forward]:
  "eq_str_mod(M,N) \<Longrightarrow> eq_str_abgroup(M,N)" by auto2

lemma eq_str_modD2 [rewrite]:
  "eq_str_mod(M,N) \<Longrightarrow> mod_ring(M) = mod_ring(N)"
  "a \<in>. mod_ring(M) \<Longrightarrow> x \<in>. M \<Longrightarrow> eq_str_mod(M,N) \<Longrightarrow> a \<bullet>\<^sub>M x = a \<bullet>\<^sub>N x"
  "eq_str_mod(M,N) \<Longrightarrow> mtimes_fun(M) = mtimes_fun(N)" by auto2+
lemma eq_str_mod_sym [forward]: "eq_str_mod(M,N) \<Longrightarrow> eq_str_mod(N,M)" by auto2

lemma eq_str_modI [backward]:
  "is_mod_raw(M) \<Longrightarrow> is_mod_raw(N) \<Longrightarrow> eq_str_abgroup(M,N) \<Longrightarrow> mod_ring(M) = mod_ring(N) \<Longrightarrow>
   \<forall>a\<in>.mod_ring(M). \<forall>x\<in>.M. a \<bullet>\<^sub>M x = a \<bullet>\<^sub>N x \<Longrightarrow> eq_str_mod(M,N)" by auto2
setup {* del_prfstep_thm @{thm eq_str_mod_def} *}

lemma mod_eq [backward]:
  "mod_form(M) \<Longrightarrow> mod_form(N) \<Longrightarrow> eq_str_mod(M,N) \<Longrightarrow> M = N" by auto2
setup {* del_prfstep_thm @{thm mod_form_def} *}

section \<open>Definition of a module\<close>

definition is_mod :: "i \<Rightarrow> o" where [rewrite]:
  "is_mod(M) \<longleftrightarrow> (let R = mod_ring(M) in
    is_ring(R) \<and> is_abgroup(M) \<and>
    (\<forall>a\<in>.R. \<forall>b\<in>.R. \<forall>x\<in>.M. (a +\<^sub>R b) \<bullet>\<^sub>M x = a \<bullet>\<^sub>M x +\<^sub>M b \<bullet>\<^sub>M x) \<and>
    (\<forall>a\<in>.R. \<forall>x\<in>.M. \<forall>y\<in>.M. a \<bullet>\<^sub>M (x +\<^sub>M y) = a \<bullet>\<^sub>M x +\<^sub>M a \<bullet>\<^sub>M y) \<and>
    (\<forall>a\<in>.R. \<forall>b\<in>.R. \<forall>x\<in>.M. (a *\<^sub>R b) \<bullet>\<^sub>M x = a \<bullet>\<^sub>M (b \<bullet>\<^sub>M x)) \<and>
    (\<forall>x\<in>.M. \<one>\<^sub>R \<bullet>\<^sub>M x = x))"

lemma is_modD1 [forward]:
  "is_mod(M) \<Longrightarrow> is_ring(mod_ring(M))"
  "is_mod(M) \<Longrightarrow> is_abgroup(M)" by auto2+

lemma is_modD2 [rewrite]:
  "is_mod(M) \<Longrightarrow> R = mod_ring(M) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> x \<in>. M \<Longrightarrow> (a +\<^sub>R b) \<bullet>\<^sub>M x = a \<bullet>\<^sub>M x +\<^sub>M b \<bullet>\<^sub>M x"
  "is_mod(M) \<Longrightarrow> R = mod_ring(M) \<Longrightarrow> a \<in>. R \<Longrightarrow> x \<in>. M \<Longrightarrow> y \<in>. M \<Longrightarrow> a \<bullet>\<^sub>M (x +\<^sub>M y) = a \<bullet>\<^sub>M x +\<^sub>M a \<bullet>\<^sub>M y"
  "is_mod(M) \<Longrightarrow> R = mod_ring(M) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> x \<in>. M \<Longrightarrow> (a *\<^sub>R b) \<bullet>\<^sub>M x = a \<bullet>\<^sub>M (b \<bullet>\<^sub>M x)"
  "is_mod(M) \<Longrightarrow> R = mod_ring(M) \<Longrightarrow> x \<in>. M \<Longrightarrow> \<one>\<^sub>R \<bullet>\<^sub>M x = x"
  by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_mod_def} *}

section \<open>Every abelian group is a module\<close>

definition mod_of_abgroup :: "i \<Rightarrow> i" where [rewrite]:
  "mod_of_abgroup(R) = LMod(carrier(R),\<int>,\<zero>\<^sub>R, \<lambda>x y. x +\<^sub>R y, \<lambda>a x. int_act(R,a,x))"

lemma mod_of_abgroup_is_mod [forward]:
  "is_abgroup(R) \<Longrightarrow> mod_form(mod_of_abgroup(R))" by auto2

lemma mod_of_abgroup_eval [rewrite]:
  "carrier(mod_of_abgroup(R)) = carrier(R)"
  "mod_ring(mod_of_abgroup(R)) = \<int>"
  "is_abgroup(R) \<Longrightarrow> M = mod_of_abgroup(R) \<Longrightarrow> \<zero>\<^sub>M = \<zero>\<^sub>R"
  "is_abgroup(R) \<Longrightarrow> M = mod_of_abgroup(R) \<Longrightarrow> x \<in>. M \<Longrightarrow> y \<in>. M \<Longrightarrow> x +\<^sub>M y = x +\<^sub>R y"
  "is_abgroup(R) \<Longrightarrow> M = mod_of_abgroup(R) \<Longrightarrow> a \<in>. mod_ring(M) \<Longrightarrow> x \<in>. M \<Longrightarrow> a \<bullet>\<^sub>M x = int_act(R,a,x)" by auto2+
setup {* del_prfstep_thm @{thm mod_of_abgroup_def} *}

lemma mod_of_abgroup_is_module [forward]:
  "is_abgroup(R) \<Longrightarrow> is_mod(mod_of_abgroup(R))"
@proof @have "eq_str_abgroup(mod_of_abgroup(R),R)" @qed

end


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

section\<open>Computing determinants of matrices using the Gauss Jordan algorithm over nested IArrays\<close>

theory Determinants_IArrays
imports
    Determinants2
    Gauss_Jordan_IArrays
begin

subsection\<open>Definitions\<close>

definition "Gauss_Jordan_in_ij_det_P_iarrays A i j = (let n = least_non_zero_position_of_vector_from_index (column_iarray j A) i
  in (if i = n then 1 / A !! i !! j else - 1 / A !! n !! j, Gauss_Jordan_in_ij_iarrays A i j))"

definition "Gauss_Jordan_column_k_det_P_iarrays A' k = (let det_P = fst A'; i = fst (snd A'); A = snd (snd A')
 in if vector_all_zero_from_index (i, column_iarray k A) \<or> i = nrows_iarray A then (det_P, i, A)
    else let gauss = Gauss_Jordan_in_ij_det_P_iarrays A i k in (fst gauss * det_P, i + 1, snd gauss))"

definition "Gauss_Jordan_upt_k_det_P_iarrays A k = (let foldl = foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, A) [0..<Suc k] in (fst foldl, snd (snd foldl)))"
definition "Gauss_Jordan_det_P_iarrays A = Gauss_Jordan_upt_k_det_P_iarrays A (ncols_iarray A - 1)"

subsection\<open>Proofs\<close>

text\<open>A more efficient equation for @{term "Gauss_Jordan_in_ij_det_P_iarrays A i j"}.\<close>

lemma Gauss_Jordan_in_ij_det_P_iarrays_code[code]: "Gauss_Jordan_in_ij_det_P_iarrays A i j
    = (let n = least_non_zero_position_of_vector_from_index (column_iarray j A) i;
           interchange_A = interchange_rows_iarray A i n;
           A' = mult_row_iarray interchange_A i (1 / interchange_A !! i !! j)
       in (if i = n then 1 / A !! i !! j else - 1 / A !! n !! j, IArray.of_fun (\<lambda>s. if s = i then A' !! s else row_add_iarray A' s i (- interchange_A !! s !! j) !! s) (nrows_iarray A)))"
unfolding Gauss_Jordan_in_ij_det_P_iarrays_def Gauss_Jordan_in_ij_iarrays_def Let_def ..

lemma matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P:
assumes ex_n: "\<exists>n. A $ n $ j \<noteq> 0 \<and> i \<le> n"
shows "fst (Gauss_Jordan_in_ij_det_P A i j) = fst (Gauss_Jordan_in_ij_det_P_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j))"
proof -
have least_n_eq: "least_non_zero_position_of_vector_from_index (vec_to_iarray (column j A)) (to_nat i) = to_nat (LEAST n. A $ n $ j \<noteq> 0 \<and> i \<le> n)"
by (rule vec_to_iarray_least_non_zero_position_of_vector_from_index'[unfolded matrix_vector_all_zero_from_index[symmetric]], metis ex_n)
show ?thesis
unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_det_P_iarrays_def Let_def fst_conv
 unfolding  least_n_eq[unfolded vec_to_iarray_column] unfolding matrix_to_iarray_nth by auto
qed

corollary matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P':
assumes "\<not> (vector_all_zero_from_index (to_nat i, vec_to_iarray (column j A)))"
shows "fst (Gauss_Jordan_in_ij_det_P A i j) = fst (Gauss_Jordan_in_ij_det_P_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j))"
using matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P assms unfolding matrix_vector_all_zero_from_index[symmetric]
by auto

lemma matrix_to_iarray_snd_Gauss_Jordan_in_ij_det_P:
assumes ex_n: "\<exists>n. A $ n $ j \<noteq> 0 \<and> i \<le> n"
shows "matrix_to_iarray (snd (Gauss_Jordan_in_ij_det_P A i j)) = snd (Gauss_Jordan_in_ij_det_P_iarrays (matrix_to_iarray A) (to_nat i) (to_nat j))"
unfolding Gauss_Jordan_in_ij_det_P_def Gauss_Jordan_in_ij_det_P_iarrays_def Let_def snd_conv
by (rule matrix_to_iarray_Gauss_Jordan_in_ij, simp add: matrix_vector_all_zero_from_index[symmetric], metis ex_n)

lemma matrix_to_iarray_fst_Gauss_Jordan_column_k_det_P:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "fst (Gauss_Jordan_column_k_det_P (n, i, A) k) = fst (Gauss_Jordan_column_k_det_P_iarrays (n, i, matrix_to_iarray A) k)"
proof (cases "i<nrows A")
case True
show ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index
using matrix_to_iarray_fst_Gauss_Jordan_in_ij_det_P'[of "from_nat i" "from_nat k" A]
unfolding vec_to_iarray_column
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]]
by auto
next
case False
hence "i=nrows A" using i by simp
thus ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv unfolding matrix_to_iarray_nrows by force
qed

lemma matrix_to_iarray_fst_snd_Gauss_Jordan_column_k_det_P:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "fst (snd (Gauss_Jordan_column_k_det_P (n, i, A) k)) = fst (snd (Gauss_Jordan_column_k_det_P_iarrays (n, i, matrix_to_iarray A) k))"
proof (cases "i<nrows A")
case True
show ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index
unfolding vec_to_iarray_column
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]] by auto
next
case False
thus ?thesis
using assms
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def snd_conv fst_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index by auto
qed

lemma matrix_to_iarray_snd_snd_Gauss_Jordan_column_k_det_P:
assumes i: "i\<le>nrows A" and k: "k<ncols A"
shows "matrix_to_iarray (snd (snd (Gauss_Jordan_column_k_det_P (n, i, A) k))) = snd (snd (Gauss_Jordan_column_k_det_P_iarrays (n, i, matrix_to_iarray A) k))"
proof (cases "i<nrows A")
case True
show ?thesis
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def fst_conv snd_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index
using matrix_to_iarray_snd_Gauss_Jordan_in_ij_det_P[of A "from_nat k" "from_nat i"]
using matrix_vector_all_zero_from_index[of "from_nat i" A "from_nat k"]
unfolding vec_to_iarray_column
unfolding to_nat_from_nat_id[OF True[unfolded nrows_def]]
unfolding to_nat_from_nat_id[OF k[unfolded ncols_def]]
by auto
next
case False
thus ?thesis
using assms
unfolding Gauss_Jordan_column_k_det_P_def Gauss_Jordan_column_k_det_P_iarrays_def Let_def fst_conv snd_conv
unfolding matrix_to_iarray_nrows matrix_vector_all_zero_from_index by auto
qed

lemma fst_snd_Gauss_Jordan_column_k_det_P_le_nrows:
assumes i: "i\<le>nrows A"
shows "fst (snd (Gauss_Jordan_column_k_det_P (n, i, A) k)) \<le> nrows A"
unfolding fst_snd_Gauss_Jordan_column_k_det_P_eq_fst_snd_Gauss_Jordan_column_k_PA[unfolded fst_snd_Gauss_Jordan_column_k_PA_eq]
by (rule fst_Gauss_Jordan_column_k[OF i])

text\<open>The proof of the following theorem is very similar to the ones of \<open>foldl_Gauss_Jordan_column_k_eq\<close>,
      \<open>rref_and_index_Gauss_Jordan_upt_k\<close> and \<open>foldl_Gauss_Jordan_column_k_det_P\<close>.\<close>

lemma
assumes "k<ncols A"
shows matrix_to_iarray_fst_Gauss_Jordan_upt_k_det_P: "fst (Gauss_Jordan_upt_k_det_P A k) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and matrix_to_iarray_snd_Gauss_Jordan_upt_k_det_P: "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A k)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) \<le> nrows A"
and "fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]))"
using assms
proof (induct k)
show "fst (Gauss_Jordan_upt_k_det_P A 0) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) 0)"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv
by (simp, rule matrix_to_iarray_fst_Gauss_Jordan_column_k_det_P, simp_all add: ncols_def)
show "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A 0)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) 0)"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv snd_conv
by (simp, rule matrix_to_iarray_snd_snd_Gauss_Jordan_column_k_det_P, simp_all add: ncols_def)
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc 0])) \<le> nrows A"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv snd_conv
by (simp, rule fst_snd_Gauss_Jordan_column_k_det_P_le_nrows, simp add: nrows_def)
show "fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc 0])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc 0]))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv snd_conv
by (simp, rule matrix_to_iarray_fst_snd_Gauss_Jordan_column_k_det_P[symmetric], simp_all add: ncols_def)
next
fix k
assume "(k < ncols A \<Longrightarrow> fst (Gauss_Jordan_upt_k_det_P A k) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k))"
        and "(k < ncols A \<Longrightarrow> matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A k)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k))"
        and "(k < ncols A \<Longrightarrow> fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) \<le> nrows A)"
        and "(k < ncols A \<Longrightarrow> fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])))"
        and Suc_k_less_ncols: "Suc k < ncols A"
hence hyp1: "fst (Gauss_Jordan_upt_k_det_P A k) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and hyp2: "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A k)) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) k)"
and hyp3: "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])) \<le> nrows A"
and hyp4: "(fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k])))"
  by auto
have list_rw: "[0..<Suc (Suc k)] = [0..<(Suc k)] @ [Suc k]" by simp
define f where "f = foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc k]"
define g where "g = foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc k]"
have f_rw: "f = (fst f, fst (snd f), snd (snd f))" by simp
have g_rw: "g = (fst g, fst (snd g), snd (snd g))" by simp
have fst_rw: "fst g = fst f" unfolding f_def g_def using hyp1[unfolded Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv] ..
have fst_snd_rw: "fst (snd g) = fst (snd f)" unfolding f_def g_def using hyp4 .
have snd_snd_rw: "snd (snd g) = matrix_to_iarray (snd (snd f))"
  unfolding f_def g_def using hyp2[unfolded Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def snd_conv] ..
have fst_snd_f_le_nrows: "fst (snd f) \<le> nrows (snd (snd f))"  unfolding f_def g_def using hyp3 unfolding nrows_def .
have Suc_k_less_ncols': "Suc k < ncols (snd (snd f))"  using Suc_k_less_ncols unfolding ncols_def .
show "fst (Gauss_Jordan_upt_k_det_P A (Suc k)) = fst (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) (Suc k))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def fst_conv
unfolding list_rw foldl_append
unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
by (subst f_rw, subst g_rw, unfold fst_rw fst_snd_rw snd_snd_rw, rule matrix_to_iarray_fst_Gauss_Jordan_column_k_det_P[OF fst_snd_f_le_nrows Suc_k_less_ncols'])
show "matrix_to_iarray (snd (Gauss_Jordan_upt_k_det_P A (Suc k))) = snd (Gauss_Jordan_upt_k_det_P_iarrays (matrix_to_iarray A) (Suc k))"
unfolding Gauss_Jordan_upt_k_det_P_def Gauss_Jordan_upt_k_det_P_iarrays_def Let_def snd_conv
unfolding list_rw foldl_append
unfolding List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
by (subst f_rw, subst g_rw, unfold fst_rw fst_snd_rw snd_snd_rw, rule matrix_to_iarray_snd_snd_Gauss_Jordan_column_k_det_P[OF fst_snd_f_le_nrows Suc_k_less_ncols'])
show "fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc (Suc k)])) \<le> nrows A"
unfolding list_rw foldl_append List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
apply (subst f_rw)
using fst_snd_Gauss_Jordan_column_k_det_P_le_nrows[OF fst_snd_f_le_nrows]
unfolding nrows_def .
show "fst (snd (foldl Gauss_Jordan_column_k_det_P_iarrays (1, 0, matrix_to_iarray A) [0..<Suc (Suc k)])) = fst (snd (foldl Gauss_Jordan_column_k_det_P (1, 0, A) [0..<Suc (Suc k)]))"
unfolding list_rw foldl_append List.foldl.simps
unfolding f_def[symmetric] g_def[symmetric]
by (subst f_rw, subst g_rw, unfold fst_rw fst_snd_rw snd_snd_rw,rule matrix_to_iarray_fst_snd_Gauss_Jordan_column_k_det_P[symmetric, OF fst_snd_f_le_nrows Suc_k_less_ncols'])
qed

lemma matrix_to_iarray_fst_Gauss_Jordan_det_P:
shows "fst (Gauss_Jordan_det_P A) = fst (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A))"
unfolding Gauss_Jordan_det_P_def Gauss_Jordan_det_P_iarrays_def
using matrix_to_iarray_fst_Gauss_Jordan_upt_k_det_P
by (metis diff_less matrix_to_iarray_ncols ncols_not_0 neq0_conv zero_less_one)

lemma matrix_to_iarray_snd_Gauss_Jordan_det_P:
shows "matrix_to_iarray (snd (Gauss_Jordan_det_P A)) = snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A))"
unfolding Gauss_Jordan_det_P_def Gauss_Jordan_det_P_iarrays_def
using matrix_to_iarray_snd_Gauss_Jordan_upt_k_det_P
by (metis diff_less matrix_to_iarray_ncols ncols_not_0 neq0_conv zero_less_one)

subsection\<open>Code equations\<close>
definition "det_iarrays A = (let A' = Gauss_Jordan_det_P_iarrays A in prod_list (map (\<lambda>i. (snd A') !! i !! i) [0..<nrows_iarray A]) / fst A')"

lemma matrix_to_iarray_det[code_unfold]:
fixes A::"'a::{field}^'n::{mod_type}^'n::{mod_type}"
shows "det A = det_iarrays (matrix_to_iarray A)"
proof -
let ?f="(\<lambda>i. snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A)) !! i !! i)"
have *: "fst (Gauss_Jordan_det_P A) = fst (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A))"
  unfolding matrix_to_iarray_fst_Gauss_Jordan_det_P ..
  have "prod_list (map ?f [0..<nrows_iarray (matrix_to_iarray A)]) = prod ?f (set [0..<nrows_iarray (matrix_to_iarray A)])"
    by (metis (no_types, lifting) distinct_upt prod.distinct_set_conv_list)
also have "... = (\<Prod>i\<in>UNIV. snd (Gauss_Jordan_det_P A) $ i $ i)"
  proof (rule prod.reindex_cong[of "to_nat::('n=>nat)"])
    show "inj (to_nat::('n=>nat))" by (metis strict_mono_imp_inj_on strict_mono_to_nat)
    show "set [0..<nrows_iarray (matrix_to_iarray A)] = range (to_nat::'n=>nat)"
    unfolding nrows_eq_card_rows using bij_to_nat[where ?'a='n]
    unfolding bij_betw_def
    unfolding atLeast0LessThan atLeast_upt by auto
    fix x
    show "snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A)) !! to_nat x !! to_nat x = snd (Gauss_Jordan_det_P A) $ x $ x"
    unfolding matrix_to_iarray_snd_Gauss_Jordan_det_P[symmetric]
    unfolding matrix_to_iarray_nth ..
    qed
  finally have "(\<Prod>i\<in>UNIV. snd (Gauss_Jordan_det_P A) $ i $ i)
  = prod_list (map (\<lambda>i. snd (Gauss_Jordan_det_P_iarrays (matrix_to_iarray A)) !! i !! i) [0..<nrows_iarray (matrix_to_iarray A)])" ..
  thus ?thesis using * unfolding det_code_equation det_iarrays_def Let_def  by presburger
qed

end


(*  Title:      HOL/UNITY/Transformers.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2003  University of Cambridge

Predicate Transformers.  From

    David Meier and Beverly Sanders,
    Composing Leads-to Properties
    Theoretical Computer Science 243:1-2 (2000), 339-361.

    David Meier,
    Progress Properties in Program Refinement and Parallel Composition
    Swiss Federal Institute of Technology Zurich (1997)
*)

section\<open>Predicate Transformers\<close>

theory Transformers imports Comp begin

subsection\<open>Defining the Predicate Transformers \<^term>\<open>wp\<close>,
   \<^term>\<open>awp\<close> and  \<^term>\<open>wens\<close>\<close>

definition wp :: "[('a*'a) set, 'a set] => 'a set" where
    \<comment> \<open>Dijkstra's weakest-precondition operator (for an individual command)\<close>
    "wp act B == - (act\<inverse> `` (-B))"

definition awp :: "['a program, 'a set] => 'a set" where
    \<comment> \<open>Dijkstra's weakest-precondition operator (for a program)\<close>
    "awp F B == (\<Inter>act \<in> Acts F. wp act B)"

definition wens :: "['a program, ('a*'a) set, 'a set] => 'a set" where
    \<comment> \<open>The weakest-ensures transformer\<close>
    "wens F act B == gfp(\<lambda>X. (wp act B \<inter> awp F (B \<union> X)) \<union> B)"

text\<open>The fundamental theorem for wp\<close>
theorem wp_iff: "(A <= wp act B) = (act `` A <= B)"
by (force simp add: wp_def)

text\<open>This lemma is a good deal more intuitive than the definition!\<close>
lemma in_wp_iff: "(a \<in> wp act B) = (\<forall>x. (a,x) \<in> act --> x \<in> B)"
by (simp add: wp_def, blast)

lemma Compl_Domain_subset_wp: "- (Domain act) \<subseteq> wp act B"
by (force simp add: wp_def)

lemma wp_empty [simp]: "wp act {} = - (Domain act)"
by (force simp add: wp_def)

text\<open>The identity relation is the skip action\<close>
lemma wp_Id [simp]: "wp Id B = B"
by (simp add: wp_def)

lemma wp_totalize_act:
     "wp (totalize_act act) B = (wp act B \<inter> Domain act) \<union> (B - Domain act)"
by (simp add: wp_def totalize_act_def, blast)

lemma awp_subset: "(awp F A \<subseteq> A)"
by (force simp add: awp_def wp_def)

lemma awp_Int_eq: "awp F (A\<inter>B) = awp F A \<inter> awp F B"
by (simp add: awp_def wp_def, blast)

text\<open>The fundamental theorem for awp\<close>
theorem awp_iff_constrains: "(A <= awp F B) = (F \<in> A co B)"
by (simp add: awp_def constrains_def wp_iff INT_subset_iff)

lemma awp_iff_stable: "(A \<subseteq> awp F A) = (F \<in> stable A)"
by (simp add: awp_iff_constrains stable_def)

lemma stable_imp_awp_ident: "F \<in> stable A ==> awp F A = A"
apply (rule equalityI [OF awp_subset])
apply (simp add: awp_iff_stable)
done

lemma wp_mono: "(A \<subseteq> B) ==> wp act A \<subseteq> wp act B"
by (simp add: wp_def, blast)

lemma awp_mono: "(A \<subseteq> B) ==> awp F A \<subseteq> awp F B"
by (simp add: awp_def wp_def, blast)

lemma wens_unfold:
     "wens F act B = (wp act B \<inter> awp F (B \<union> wens F act B)) \<union> B"
apply (simp add: wens_def)
apply (rule gfp_unfold)
apply (simp add: mono_def wp_def awp_def, blast)
done

lemma wens_Id [simp]: "wens F Id B = B"
by (simp add: wens_def gfp_def wp_def awp_def, blast)

text\<open>These two theorems justify the claim that \<^term>\<open>wens\<close> returns the
weakest assertion satisfying the ensures property\<close>
lemma ensures_imp_wens: "F \<in> A ensures B ==> \<exists>act \<in> Acts F. A \<subseteq> wens F act B"
apply (simp add: wens_def ensures_def transient_def, clarify)
apply (rule rev_bexI, assumption)
apply (rule gfp_upperbound)
apply (simp add: constrains_def awp_def wp_def, blast)
done

lemma wens_ensures: "act \<in> Acts F ==> F \<in> (wens F act B) ensures B"
by (simp add: wens_def gfp_def constrains_def awp_def wp_def
              ensures_def transient_def, blast)

text\<open>These two results constitute assertion (4.13) of the thesis\<close>
lemma wens_mono: "(A \<subseteq> B) ==> wens F act A \<subseteq> wens F act B"
apply (simp add: wens_def wp_def awp_def)
apply (rule gfp_mono, blast)
done

lemma wens_weakening: "B \<subseteq> wens F act B"
by (simp add: wens_def gfp_def, blast)

text\<open>Assertion (6), or 4.16 in the thesis\<close>
lemma subset_wens: "A-B \<subseteq> wp act B \<inter> awp F (B \<union> A) ==> A \<subseteq> wens F act B"
apply (simp add: wens_def wp_def awp_def)
apply (rule gfp_upperbound, blast)
done

text\<open>Assertion 4.17 in the thesis\<close>
lemma Diff_wens_constrains: "F \<in> (wens F act A - A) co wens F act A"
by (simp add: wens_def gfp_def wp_def awp_def constrains_def, blast)
  \<comment> \<open>Proved instantly, yet remarkably fragile. If \<open>Un_subset_iff\<close>
      is declared as an iff-rule, then it's almost impossible to prove.
      One proof is via \<open>meson\<close> after expanding all definitions, but it's
      slow!\<close>

text\<open>Assertion (7): 4.18 in the thesis.  NOTE that many of these results
hold for an arbitrary action.  We often do not require \<^term>\<open>act \<in> Acts F\<close>\<close>
lemma stable_wens: "F \<in> stable A ==> F \<in> stable (wens F act A)"
apply (simp add: stable_def)
apply (drule constrains_Un [OF Diff_wens_constrains [of F act A]])
apply (simp add: Un_Int_distrib2 Compl_partition2)
apply (erule constrains_weaken, blast)
apply (simp add: wens_weakening)
done

text\<open>Assertion 4.20 in the thesis.\<close>
lemma wens_Int_eq_lemma:
      "[|T-B \<subseteq> awp F T; act \<in> Acts F|]
       ==> T \<inter> wens F act B \<subseteq> wens F act (T\<inter>B)"
apply (rule subset_wens)
apply (rule_tac P="\<lambda>x. f x \<subseteq> b" for f b in ssubst [OF wens_unfold])
apply (simp add: wp_def awp_def, blast)
done

text\<open>Assertion (8): 4.21 in the thesis. Here we indeed require
      \<^term>\<open>act \<in> Acts F\<close>\<close>
lemma wens_Int_eq:
      "[|T-B \<subseteq> awp F T; act \<in> Acts F|]
       ==> T \<inter> wens F act B = T \<inter> wens F act (T\<inter>B)"
apply (rule equalityI)
 apply (simp_all add: Int_lower1)
 apply (rule wens_Int_eq_lemma, assumption+)
apply (rule subset_trans [OF _ wens_mono [of "T\<inter>B" B]], auto)
done

subsection\<open>Defining the Weakest Ensures Set\<close>

inductive_set
  wens_set :: "['a program, 'a set] => 'a set set"
  for F :: "'a program" and B :: "'a set"
where

  Basis: "B \<in> wens_set F B"

| Wens:  "[|X \<in> wens_set F B; act \<in> Acts F|] ==> wens F act X \<in> wens_set F B"

| Union: "W \<noteq> {} ==> \<forall>U \<in> W. U \<in> wens_set F B ==> \<Union>W \<in> wens_set F B"

lemma wens_set_imp_co: "A \<in> wens_set F B ==> F \<in> (A-B) co A"
apply (erule wens_set.induct)
  apply (simp add: constrains_def)
 apply (drule_tac act1=act and A1=X
        in constrains_Un [OF Diff_wens_constrains])
 apply (erule constrains_weaken, blast)
 apply (simp add: wens_weakening)
apply (rule constrains_weaken)
apply (rule_tac I=W and A="\<lambda>v. v-B" and A'="\<lambda>v. v" in constrains_UN, blast+)
done

lemma wens_set_imp_leadsTo: "A \<in> wens_set F B ==> F \<in> A leadsTo B"
apply (erule wens_set.induct)
  apply (rule leadsTo_refl)
 apply (blast intro: wens_ensures leadsTo_Trans)
apply (blast intro: leadsTo_Union)
done

lemma leadsTo_imp_wens_set: "F \<in> A leadsTo B ==> \<exists>C \<in> wens_set F B. A \<subseteq> C"
apply (erule leadsTo_induct_pre)
  apply (blast dest!: ensures_imp_wens intro: wens_set.Basis wens_set.Wens)
 apply (clarify, drule ensures_weaken_R, assumption)
 apply (blast dest!: ensures_imp_wens intro: wens_set.Wens)
apply (case_tac "S={}")
 apply (simp, blast intro: wens_set.Basis)
apply (clarsimp dest!: bchoice simp: ball_conj_distrib Bex_def)
apply (rule_tac x = "\<Union>{Z. \<exists>U\<in>S. Z = f U}" in exI)
apply (blast intro: wens_set.Union)
done

text\<open>Assertion (9): 4.27 in the thesis.\<close>
lemma leadsTo_iff_wens_set: "(F \<in> A leadsTo B) = (\<exists>C \<in> wens_set F B. A \<subseteq> C)"
by (blast intro: leadsTo_imp_wens_set leadsTo_weaken_L wens_set_imp_leadsTo)

text\<open>This is the result that requires the definition of \<^term>\<open>wens_set\<close> to
  require \<^term>\<open>W\<close> to be non-empty in the Unio case, for otherwise we should
  always have \<^term>\<open>{} \<in> wens_set F B\<close>.\<close>
lemma wens_set_imp_subset: "A \<in> wens_set F B ==> B \<subseteq> A"
apply (erule wens_set.induct)
  apply (blast intro: wens_weakening [THEN subsetD])+
done

subsection\<open>Properties Involving Program Union\<close>

text\<open>Assertion (4.30) of thesis, reoriented\<close>
lemma awp_Join_eq: "awp (F\<squnion>G) B = awp F B \<inter> awp G B"
by (simp add: awp_def wp_def, blast)

lemma wens_subset: "wens F act B - B \<subseteq> wp act B \<inter> awp F (B \<union> wens F act B)"
by (subst wens_unfold, fast)

text\<open>Assertion (4.31)\<close>
lemma subset_wens_Join:
      "[|A = T \<inter> wens F act B;  T-B \<subseteq> awp F T; A-B \<subseteq> awp G (A \<union> B)|]
       ==> A \<subseteq> wens (F\<squnion>G) act B"
apply (subgoal_tac "(T \<inter> wens F act B) - B \<subseteq>
                    wp act B \<inter> awp F (B \<union> wens F act B) \<inter> awp F T")
 apply (rule subset_wens)
 apply (simp add: awp_Join_eq awp_Int_eq Un_commute)
 apply (simp add: awp_def wp_def, blast)
apply (insert wens_subset [of F act B], blast)
done

text\<open>Assertion (4.32)\<close>
lemma wens_Join_subset: "wens (F\<squnion>G) act B \<subseteq> wens F act B"
apply (simp add: wens_def)
apply (rule gfp_mono)
apply (auto simp add: awp_Join_eq)
done

text\<open>Lemma, because the inductive step is just too messy.\<close>
lemma wens_Union_inductive_step:
  assumes awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
  shows "[|X \<in> wens_set F B; act \<in> Acts F; Y \<subseteq> X; T\<inter>X = T\<inter>Y|]
         ==> wens (F\<squnion>G) act Y \<subseteq> wens F act X \<and>
             T \<inter> wens F act X = T \<inter> wens (F\<squnion>G) act Y"
apply (subgoal_tac "wens (F\<squnion>G) act Y \<subseteq> wens F act X")
 prefer 2
 apply (blast dest: wens_mono intro: wens_Join_subset [THEN subsetD], simp)
apply (rule equalityI)
 prefer 2 apply blast
apply (simp add: Int_lower1)
apply (frule wens_set_imp_subset)
apply (subgoal_tac "T-X \<subseteq> awp F T")
 prefer 2 apply (blast intro: awpF [THEN subsetD])
apply (rule_tac B = "wens (F\<squnion>G) act (T\<inter>X)" in subset_trans)
 prefer 2 apply (blast intro!: wens_mono)
apply (subst wens_Int_eq, assumption+)
apply (rule subset_wens_Join [of _ T], simp, blast)
apply (subgoal_tac "T \<inter> wens F act (T\<inter>X) \<union> T\<inter>X = T \<inter> wens F act X")
 prefer 2
 apply (subst wens_Int_eq [symmetric], assumption+)
 apply (blast intro: wens_weakening [THEN subsetD], simp)
apply (blast intro: awpG [THEN subsetD] wens_set.Wens)
done

theorem wens_Union:
  assumes awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
      and major: "X \<in> wens_set F B"
  shows "\<exists>Y \<in> wens_set (F\<squnion>G) B. Y \<subseteq> X & T\<inter>X = T\<inter>Y"
apply (rule wens_set.induct [OF major])
  txt\<open>Basis: trivial\<close>
  apply (blast intro: wens_set.Basis)
 txt\<open>Inductive step\<close>
 apply clarify
 apply (rule_tac x = "wens (F\<squnion>G) act Y" in rev_bexI)
  apply (force intro: wens_set.Wens)
 apply (simp add: wens_Union_inductive_step [OF awpF awpG])
txt\<open>Union: by Axiom of Choice\<close>
apply (simp add: ball_conj_distrib Bex_def)
apply (clarify dest!: bchoice)
apply (rule_tac x = "\<Union>{Z. \<exists>U\<in>W. Z = f U}" in exI)
apply (blast intro: wens_set.Union)
done

theorem leadsTo_Join:
  assumes leadsTo: "F \<in> A leadsTo B"
      and awpF: "T-B \<subseteq> awp F T"
      and awpG: "!!X. X \<in> wens_set F B ==> (T\<inter>X) - B \<subseteq> awp G (T\<inter>X)"
  shows "F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule leadsTo [THEN leadsTo_imp_wens_set, THEN bexE])
apply (rule wens_Union [THEN bexE])
   apply (rule awpF)
  apply (erule awpG, assumption)
apply (blast intro: wens_set_imp_leadsTo [THEN leadsTo_weaken_L])
done

subsection \<open>The Set \<^term>\<open>wens_set F B\<close> for a Single-Assignment Program\<close>
text\<open>Thesis Section 4.3.3\<close>

text\<open>We start by proving laws about single-assignment programs\<close>
lemma awp_single_eq [simp]:
     "awp (mk_program (init, {act}, allowed)) B = B \<inter> wp act B"
by (force simp add: awp_def wp_def)

lemma wp_Un_subset: "wp act A \<union> wp act B \<subseteq> wp act (A \<union> B)"
by (force simp add: wp_def)

lemma wp_Un_eq: "single_valued act ==> wp act (A \<union> B) = wp act A \<union> wp act B"
apply (rule equalityI)
 apply (force simp add: wp_def single_valued_def)
apply (rule wp_Un_subset)
done

lemma wp_UN_subset: "(\<Union>i\<in>I. wp act (A i)) \<subseteq> wp act (\<Union>i\<in>I. A i)"
by (force simp add: wp_def)

lemma wp_UN_eq:
     "[|single_valued act; I\<noteq>{}|]
      ==> wp act (\<Union>i\<in>I. A i) = (\<Union>i\<in>I. wp act (A i))"
apply (rule equalityI)
 prefer 2 apply (rule wp_UN_subset)
 apply (simp add: wp_def Image_INT_eq)
done

lemma wens_single_eq:
     "wens (mk_program (init, {act}, allowed)) act B = B \<union> wp act B"
by (simp add: wens_def gfp_def wp_def, blast)

text\<open>Next, we express the \<^term>\<open>wens_set\<close> for single-assignment programs\<close>

definition wens_single_finite :: "[('a*'a) set, 'a set, nat] => 'a set" where
    "wens_single_finite act B k == \<Union>i \<in> atMost k. (wp act ^^ i) B"

definition wens_single :: "[('a*'a) set, 'a set] => 'a set" where
    "wens_single act B == \<Union>i. (wp act ^^ i) B"

lemma wens_single_Un_eq:
      "single_valued act
       ==> wens_single act B \<union> wp act (wens_single act B) = wens_single act B"
apply (rule equalityI)
 apply (simp_all add: Un_upper1)
apply (simp add: wens_single_def wp_UN_eq, clarify)
apply (rule_tac a="Suc xa" in UN_I, auto)
done

lemma atMost_nat_nonempty: "atMost (k::nat) \<noteq> {}"
by force

lemma wens_single_finite_0 [simp]: "wens_single_finite act B 0 = B"
by (simp add: wens_single_finite_def)

lemma wens_single_finite_Suc:
      "single_valued act
       ==> wens_single_finite act B (Suc k) =
           wens_single_finite act B k \<union> wp act (wens_single_finite act B k)"
apply (simp add: wens_single_finite_def wp_UN_eq [OF _ atMost_nat_nonempty])
apply (force elim!: le_SucE)
done

lemma wens_single_finite_Suc_eq_wens:
     "single_valued act
       ==> wens_single_finite act B (Suc k) =
           wens (mk_program (init, {act}, allowed)) act
                (wens_single_finite act B k)"
by (simp add: wens_single_finite_Suc wens_single_eq)

lemma def_wens_single_finite_Suc_eq_wens:
     "[|F = mk_program (init, {act}, allowed); single_valued act|]
       ==> wens_single_finite act B (Suc k) =
           wens F act (wens_single_finite act B k)"
by (simp add: wens_single_finite_Suc_eq_wens)

lemma wens_single_finite_Un_eq:
      "single_valued act
       ==> wens_single_finite act B k \<union> wp act (wens_single_finite act B k)
           \<in> range (wens_single_finite act B)"
by (simp add: wens_single_finite_Suc [symmetric])

lemma wens_single_eq_Union:
      "wens_single act B = \<Union>(range (wens_single_finite act B))"
by (simp add: wens_single_finite_def wens_single_def, blast)

lemma wens_single_finite_eq_Union:
     "wens_single_finite act B n = (\<Union>k\<in>atMost n. wens_single_finite act B k)"
apply (auto simp add: wens_single_finite_def)
apply (blast intro: le_trans)
done

lemma wens_single_finite_mono:
     "m \<le> n ==> wens_single_finite act B m \<subseteq> wens_single_finite act B n"
by (force simp add:  wens_single_finite_eq_Union [of act B n])

lemma wens_single_finite_subset_wens_single:
      "wens_single_finite act B k \<subseteq> wens_single act B"
by (simp add: wens_single_eq_Union, blast)

lemma subset_wens_single_finite:
      "[|W \<subseteq> wens_single_finite act B ` (atMost k); single_valued act; W\<noteq>{}|]
       ==> \<exists>m. \<Union>W = wens_single_finite act B m"
apply (induct k)
 apply (rule_tac x=0 in exI, simp, blast)
apply (auto simp add: atMost_Suc)
apply (case_tac "wens_single_finite act B (Suc k) \<in> W")
 prefer 2 apply blast
apply (drule_tac x="Suc k" in spec)
apply (erule notE, rule equalityI)
 prefer 2 apply blast
apply (subst wens_single_finite_eq_Union)
apply (simp add: atMost_Suc, blast)
done

text\<open>lemma for Union case\<close>
lemma Union_eq_wens_single:
      "\<lbrakk>\<forall>k. \<not> W \<subseteq> wens_single_finite act B ` {..k};
        W \<subseteq> insert (wens_single act B)
            (range (wens_single_finite act B))\<rbrakk>
       \<Longrightarrow> \<Union>W = wens_single act B"
apply (cases "wens_single act B \<in> W")
 apply (blast dest: wens_single_finite_subset_wens_single [THEN subsetD])
apply (simp add: wens_single_eq_Union)
apply (rule equalityI, blast)
apply (simp add: UN_subset_iff, clarify)
apply (subgoal_tac "\<exists>y\<in>W. \<exists>n. y = wens_single_finite act B n & i\<le>n")
 apply (blast intro: wens_single_finite_mono [THEN subsetD])
apply (drule_tac x=i in spec)
apply (force simp add: atMost_def)
done

lemma wens_set_subset_single:
      "single_valued act
       ==> wens_set (mk_program (init, {act}, allowed)) B \<subseteq>
           insert (wens_single act B) (range (wens_single_finite act B))"
apply (rule subsetI)
apply (erule wens_set.induct)
  txt\<open>Basis\<close>
  apply (fastforce simp add: wens_single_finite_def)
 txt\<open>Wens inductive step\<close>
 apply (case_tac "acta = Id", simp)
 apply (simp add: wens_single_eq)
 apply (elim disjE)
 apply (simp add: wens_single_Un_eq)
 apply (force simp add: wens_single_finite_Un_eq)
txt\<open>Union inductive step\<close>
apply (case_tac "\<exists>k. W \<subseteq> wens_single_finite act B ` (atMost k)")
 apply (blast dest!: subset_wens_single_finite, simp)
apply (rule disjI1 [OF Union_eq_wens_single], blast+)
done

lemma wens_single_finite_in_wens_set:
      "single_valued act \<Longrightarrow>
         wens_single_finite act B k
         \<in> wens_set (mk_program (init, {act}, allowed)) B"
apply (induct_tac k)
 apply (simp add: wens_single_finite_def wens_set.Basis)
apply (simp add: wens_set.Wens
                 wens_single_finite_Suc_eq_wens [of act B _ init allowed])
done

lemma single_subset_wens_set:
      "single_valued act
       ==> insert (wens_single act B) (range (wens_single_finite act B)) \<subseteq>
           wens_set (mk_program (init, {act}, allowed)) B"
apply (simp add: image_def wens_single_eq_Union)
apply (blast intro: wens_set.Union wens_single_finite_in_wens_set)
done

text\<open>Theorem (4.29)\<close>
theorem wens_set_single_eq:
     "[|F = mk_program (init, {act}, allowed); single_valued act|]
      ==> wens_set F B =
          insert (wens_single act B) (range (wens_single_finite act B))"
apply (rule equalityI)
 apply (simp add: wens_set_subset_single)
apply (erule ssubst, erule single_subset_wens_set)
done

text\<open>Generalizing Misra's Fixed Point Union Theorem (4.41)\<close>

lemma fp_leadsTo_Join:
    "[|T-B \<subseteq> awp F T; T-B \<subseteq> FP G; F \<in> A leadsTo B|] ==> F\<squnion>G \<in> T\<inter>A leadsTo B"
apply (rule leadsTo_Join, assumption, blast)
apply (simp add: FP_def awp_iff_constrains stable_def constrains_def, blast)
done

end


(*  Title:      IPv6.thy
    Authors:    Cornelius Diekmann
*)
theory IPv6
  imports
    IP_Address
    NumberWang_IPv6
    (* include "HOL-Library.Code_Target_Nat" if you need to work with actual numbers.*)
begin

section \<open>IPv6 Addresses\<close>
  text\<open>An IPv6 address is basically a 128 bit unsigned integer. RFC 4291, Section 2.\<close>
  type_synonym ipv6addr = "128 word"

  text\<open>Conversion between natural numbers and IPv6 adresses\<close>
  definition nat_of_ipv6addr :: "ipv6addr \<Rightarrow> nat" where
    "nat_of_ipv6addr a = unat a"
  definition ipv6addr_of_nat :: "nat \<Rightarrow> ipv6addr" where
    "ipv6addr_of_nat n =  of_nat n"

lemma "ipv6addr_of_nat n = word_of_int (int n)"
    by(simp add: ipv6addr_of_nat_def)

  text\<open>The maximum IPv6 address\<close>
  definition max_ipv6_addr :: "ipv6addr" where
    "max_ipv6_addr \<equiv> ipv6addr_of_nat ((2^128) - 1)"

  lemma max_ipv6_addr_number: "max_ipv6_addr = 0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"
    unfolding max_ipv6_addr_def ipv6addr_of_nat_def by(simp)
  lemma "max_ipv6_addr = 340282366920938463463374607431768211455"
    by(fact max_ipv6_addr_number)
  lemma max_ipv6_addr_max_word: "max_ipv6_addr = - 1"
    by(simp add: max_ipv6_addr_number)
  lemma max_ipv6_addr_max: "\<forall>a. a \<le> max_ipv6_addr"
    by(simp add: max_ipv6_addr_max_word)
  lemma UNIV_ipv6addrset: "UNIV = {0 .. max_ipv6_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ipv6_addr_max_word) fastforce

  text\<open>identity functions\<close>
  lemma nat_of_ipv6addr_ipv6addr_of_nat_mod: "nat_of_ipv6addr (ipv6addr_of_nat n) = n mod 2^128"
    by (simp add: ipv6addr_of_nat_def nat_of_ipv6addr_def unat_of_nat take_bit_eq_mod)
  lemma nat_of_ipv6addr_ipv6addr_of_nat:
    "n \<le> nat_of_ipv6addr max_ipv6_addr \<Longrightarrow> nat_of_ipv6addr (ipv6addr_of_nat n) = n"
    by (simp add: nat_of_ipv6addr_ipv6addr_of_nat_mod max_ipv6_addr_def)
  lemma ipv6addr_of_nat_nat_of_ipv6addr: "ipv6addr_of_nat (nat_of_ipv6addr addr) = addr"
    by(simp add: ipv6addr_of_nat_def nat_of_ipv6addr_def)

subsection\<open>Syntax of IPv6 Adresses\<close>
  text\<open>RFC 4291, Section 2.2.: Text Representation of Addresses\<close>

  text\<open>Quoting the RFC (note: errata exists):\<close>
  text_raw\<open>
  \begin{verbatim}
   1. The preferred form is x:x:x:x:x:x:x:x, where the 'x's are one to
      four hexadecimal digits of the eight 16-bit pieces of the address.
      Examples:
         ABCD:EF01:2345:6789:ABCD:EF01:2345:6789
         2001:DB8:0:0:8:800:200C:417A
  \end{verbatim}
\<close>
  datatype ipv6addr_syntax =
    IPv6AddrPreferred "16 word" "16 word" "16 word" "16 word" "16 word" "16 word" "16 word" "16 word"

  text_raw\<open>
  \begin{verbatim}
   2. [...] In order to make writing addresses containing zero
      bits easier, a special syntax is available to compress the zeros.
      The use of "::" indicates one or more groups of 16 bits of zeros.
      The "::" can only appear once in an address.  The "::" can also be
      used to compress leading or trailing zeros in an address.

      For example, the following addresses
         2001:DB8:0:0:8:800:200C:417A   a unicast address
         FF01:0:0:0:0:0:0:101           a multicast address
         0:0:0:0:0:0:0:1                the loopback address
         0:0:0:0:0:0:0:0                the unspecified address

      may be represented as
         2001:DB8::8:800:200C:417A      a unicast address
         FF01::101                      a multicast address
         ::1                            the loopback address
         ::                             the unspecified address
  \end{verbatim}
\<close>
  (*datatype may take some minutes to load*)
  datatype ipv6addr_syntax_compressed =
  \<comment> \<open>using @{typ unit} for the omission @{text "::"}.

     Naming convention of the datatype:
      The first number is the position where the omission occurs.
      The second number is the length of the specified address pieces.
        I.e. `8 minus the second number' pieces are omitted.\<close>
    IPv6AddrCompressed1_0 unit
  | IPv6AddrCompressed1_1 unit "16 word"
  | IPv6AddrCompressed1_2 unit "16 word" "16 word"
  | IPv6AddrCompressed1_3 unit "16 word" "16 word" "16 word"
  | IPv6AddrCompressed1_4 unit "16 word" "16 word" "16 word" "16 word"
  | IPv6AddrCompressed1_5 unit "16 word" "16 word" "16 word" "16 word" "16 word"
  | IPv6AddrCompressed1_6 unit "16 word" "16 word" "16 word" "16 word" "16 word" "16 word"
  | IPv6AddrCompressed1_7 unit "16 word" "16 word" "16 word" "16 word" "16 word" "16 word" "16 word"

  | IPv6AddrCompressed2_1 "16 word" unit
  | IPv6AddrCompressed2_2 "16 word" unit "16 word"
  | IPv6AddrCompressed2_3 "16 word" unit "16 word" "16 word"
  | IPv6AddrCompressed2_4 "16 word" unit "16 word" "16 word" "16 word"
  | IPv6AddrCompressed2_5 "16 word" unit "16 word" "16 word" "16 word" "16 word"
  | IPv6AddrCompressed2_6 "16 word" unit "16 word" "16 word" "16 word" "16 word" "16 word"
  | IPv6AddrCompressed2_7 "16 word" unit "16 word" "16 word" "16 word" "16 word" "16 word" "16 word"

  | IPv6AddrCompressed3_2 "16 word" "16 word" unit
  | IPv6AddrCompressed3_3 "16 word" "16 word" unit "16 word"
  | IPv6AddrCompressed3_4 "16 word" "16 word" unit "16 word" "16 word"
  | IPv6AddrCompressed3_5 "16 word" "16 word" unit "16 word" "16 word" "16 word"
  | IPv6AddrCompressed3_6 "16 word" "16 word" unit "16 word" "16 word" "16 word" "16 word"
  | IPv6AddrCompressed3_7 "16 word" "16 word" unit "16 word" "16 word" "16 word" "16 word" "16 word"

  | IPv6AddrCompressed4_3 "16 word" "16 word" "16 word" unit
  | IPv6AddrCompressed4_4 "16 word" "16 word" "16 word" unit "16 word"
  | IPv6AddrCompressed4_5 "16 word" "16 word" "16 word" unit "16 word" "16 word"
  | IPv6AddrCompressed4_6 "16 word" "16 word" "16 word" unit "16 word" "16 word" "16 word"
  | IPv6AddrCompressed4_7 "16 word" "16 word" "16 word" unit "16 word" "16 word" "16 word" "16 word"

  | IPv6AddrCompressed5_4 "16 word" "16 word" "16 word" "16 word" unit
  | IPv6AddrCompressed5_5 "16 word" "16 word" "16 word" "16 word" unit "16 word"
  | IPv6AddrCompressed5_6 "16 word" "16 word" "16 word" "16 word" unit "16 word" "16 word"
  | IPv6AddrCompressed5_7 "16 word" "16 word" "16 word" "16 word" unit "16 word" "16 word" "16 word"

  | IPv6AddrCompressed6_5 "16 word" "16 word" "16 word" "16 word" "16 word" unit
  | IPv6AddrCompressed6_6 "16 word" "16 word" "16 word" "16 word" "16 word" unit "16 word"
  | IPv6AddrCompressed6_7 "16 word" "16 word" "16 word" "16 word" "16 word" unit "16 word" "16 word"

  | IPv6AddrCompressed7_6 "16 word" "16 word" "16 word" "16 word" "16 word" "16 word" unit
  | IPv6AddrCompressed7_7 "16 word" "16 word" "16 word" "16 word" "16 word" "16 word" unit "16 word"

  | IPv6AddrCompressed8_7 "16 word" "16 word" "16 word" "16 word" "16 word" "16 word" "16 word" unit

  (*RFC 5952:
    """
    4.  A Recommendation for IPv6 Text Representation
    4.2.2.  Handling One 16-Bit 0 Field
       The symbol "::" MUST NOT be used to shorten just one 16-bit 0 field.
       For example, the representation 2001:db8:0:1:1:1:1:1 is correct, but
       2001:db8::1:1:1:1:1 is not correct.
    """

    So we could remove all IPv6AddrCompressed*_7 constructors.
    But these are `recommendations', we might still see these non-recommended definitions.
    "[...] all implementations must accept and be able to handle any legitimate RFC 4291 format."
  *)

  (*More convenient parser helper function for compressed IPv6 addresses:
    Input list (from parser):
      Some 16word \<longrightarrow> address piece
      None \<longrightarrow> omission '::'

   Basically, the parser must only do the following (python syntax):
     split the string which is an ipv6 address at ':'
     map empty string to None
     map everything else to Some (string_to_16word str)
     sanitize empty strings at the start and the end (see toString and parser theories)
   Example:
     "1:2:3".split(":")  = ['1', '2', '3']
     ":2:3:4".split(":") = ['', '2', '3', '4']
     ":2::3".split(":")  = ['', '2', '', '3']
     "1:2:3:".split(":") = ['1', '2', '3', '']
  *)
  definition parse_ipv6_address_compressed :: "((16 word) option) list \<Rightarrow> ipv6addr_syntax_compressed option" where
    "parse_ipv6_address_compressed as = (case as of
      [None] \<Rightarrow> Some (IPv6AddrCompressed1_0 ())
    | [None, Some a] \<Rightarrow> Some (IPv6AddrCompressed1_1 () a)
    | [None, Some a, Some b] \<Rightarrow> Some (IPv6AddrCompressed1_2 () a b)
    | [None, Some a, Some b, Some c] \<Rightarrow> Some (IPv6AddrCompressed1_3 () a b c)
    | [None, Some a, Some b, Some c, Some d] \<Rightarrow> Some (IPv6AddrCompressed1_4 () a b c d)
    | [None, Some a, Some b, Some c, Some d, Some e] \<Rightarrow> Some (IPv6AddrCompressed1_5 () a b c d e)
    | [None, Some a, Some b, Some c, Some d, Some e, Some f] \<Rightarrow> Some (IPv6AddrCompressed1_6 () a b c d e f)
    | [None, Some a, Some b, Some c, Some d, Some e, Some f, Some g] \<Rightarrow> Some (IPv6AddrCompressed1_7 () a b c d e f g)

    | [Some a, None] \<Rightarrow> Some (IPv6AddrCompressed2_1 a ())
    | [Some a, None, Some b] \<Rightarrow> Some (IPv6AddrCompressed2_2 a () b)
    | [Some a, None, Some b, Some c] \<Rightarrow> Some (IPv6AddrCompressed2_3 a () b c)
    | [Some a, None, Some b, Some c, Some d] \<Rightarrow> Some (IPv6AddrCompressed2_4 a () b c d)
    | [Some a, None, Some b, Some c, Some d, Some e] \<Rightarrow> Some (IPv6AddrCompressed2_5 a () b c d e)
    | [Some a, None, Some b, Some c, Some d, Some e, Some f] \<Rightarrow> Some (IPv6AddrCompressed2_6 a () b c d e f)
    | [Some a, None, Some b, Some c, Some d, Some e, Some f, Some g] \<Rightarrow> Some (IPv6AddrCompressed2_7 a () b c d e f g)

    | [Some a, Some b, None] \<Rightarrow> Some (IPv6AddrCompressed3_2 a b ())
    | [Some a, Some b, None, Some c] \<Rightarrow> Some (IPv6AddrCompressed3_3 a b () c)
    | [Some a, Some b, None, Some c, Some d] \<Rightarrow> Some (IPv6AddrCompressed3_4 a b () c d)
    | [Some a, Some b, None, Some c, Some d, Some e] \<Rightarrow> Some (IPv6AddrCompressed3_5 a b () c d e)
    | [Some a, Some b, None, Some c, Some d, Some e, Some f] \<Rightarrow> Some (IPv6AddrCompressed3_6 a b () c d e f)
    | [Some a, Some b, None, Some c, Some d, Some e, Some f, Some g] \<Rightarrow> Some (IPv6AddrCompressed3_7 a b () c d e f g)

    | [Some a, Some b, Some c, None] \<Rightarrow> Some (IPv6AddrCompressed4_3 a b c ())
    | [Some a, Some b, Some c, None, Some d] \<Rightarrow> Some (IPv6AddrCompressed4_4 a b c () d)
    | [Some a, Some b, Some c, None, Some d, Some e] \<Rightarrow> Some (IPv6AddrCompressed4_5 a b c () d e)
    | [Some a, Some b, Some c, None, Some d, Some e, Some f] \<Rightarrow> Some (IPv6AddrCompressed4_6 a b c () d e f)
    | [Some a, Some b, Some c, None, Some d, Some e, Some f, Some g] \<Rightarrow> Some (IPv6AddrCompressed4_7 a b c () d e f g)

    | [Some a, Some b, Some c, Some d, None] \<Rightarrow> Some (IPv6AddrCompressed5_4 a b c d ())
    | [Some a, Some b, Some c, Some d, None, Some e] \<Rightarrow> Some (IPv6AddrCompressed5_5 a b c d () e)
    | [Some a, Some b, Some c, Some d, None, Some e, Some f] \<Rightarrow> Some (IPv6AddrCompressed5_6 a b c d () e f)
    | [Some a, Some b, Some c, Some d, None, Some e, Some f, Some g] \<Rightarrow> Some (IPv6AddrCompressed5_7 a b c d () e f g)

    | [Some a, Some b, Some c, Some d, Some e, None] \<Rightarrow> Some (IPv6AddrCompressed6_5 a b c d e ())
    | [Some a, Some b, Some c, Some d, Some e, None, Some f] \<Rightarrow> Some (IPv6AddrCompressed6_6 a b c d e () f)
    | [Some a, Some b, Some c, Some d, Some e, None, Some f, Some g] \<Rightarrow> Some (IPv6AddrCompressed6_7 a b c d e () f g)

    | [Some a, Some b, Some c, Some d, Some e, Some f, None] \<Rightarrow> Some (IPv6AddrCompressed7_6 a b c d e f ())
    | [Some a, Some b, Some c, Some d, Some e, Some f, None, Some g] \<Rightarrow> Some (IPv6AddrCompressed7_7 a b c d e f () g)

    | [Some a, Some b, Some c, Some d, Some e, Some f, Some g, None] \<Rightarrow> Some (IPv6AddrCompressed8_7 a b c d e f g ())
    | _ \<Rightarrow> None \<comment> \<open>invalid ipv6 copressed address.\<close>
)"

  fun ipv6addr_syntax_compressed_to_list :: "ipv6addr_syntax_compressed \<Rightarrow> ((16 word) option) list"
    where
      "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_0 _) =
                                     [None]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_1 () a) =
                                     [None, Some a]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_2 () a b) =
                                     [None, Some a, Some b]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_3 () a b c) =
                                     [None, Some a, Some b, Some c]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_4 () a b c d) =
                                     [None, Some a, Some b, Some c, Some d]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_5 () a b c d e) =
                                     [None, Some a, Some b, Some c, Some d, Some e]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_6 () a b c d e f) =
                                     [None, Some a, Some b, Some c, Some d, Some e, Some f]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed1_7 () a b c d e f g) =
                                     [None, Some a, Some b, Some c, Some d, Some e, Some f, Some g]"

    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed2_1 a ()) =
                                     [Some a, None]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed2_2 a () b) =
                                     [Some a, None, Some b]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed2_3 a () b c) =
                                     [Some a, None, Some b, Some c]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed2_4 a () b c d) =
                                     [Some a, None, Some b, Some c, Some d]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed2_5 a () b c d e) =
                                     [Some a, None, Some b, Some c, Some d, Some e]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed2_6 a () b c d e f) =
                                     [Some a, None, Some b, Some c, Some d, Some e, Some f]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed2_7 a () b c d e f g) =
                                     [Some a, None, Some b, Some c, Some d, Some e, Some f, Some g]"

    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed3_2 a b ()) = [Some a, Some b, None]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed3_3 a b () c) =
                                     [Some a, Some b, None, Some c]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed3_4 a b () c d) =
                                     [Some a, Some b, None, Some c, Some d]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed3_5 a b () c d e) =
                                     [Some a, Some b, None, Some c, Some d, Some e]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed3_6 a b () c d e f) =
                                     [Some a, Some b, None, Some c, Some d, Some e, Some f]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed3_7 a b () c d e f g) =
                                     [Some a, Some b, None, Some c, Some d, Some e, Some f, Some g]"

    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed4_3 a b c ()) =
                                     [Some a, Some b, Some c, None]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed4_4 a b c () d) =
                                     [Some a, Some b, Some c, None, Some d]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed4_5 a b c () d e) =
                                     [Some a, Some b, Some c, None, Some d, Some e]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed4_6 a b c () d e f) =
                                     [Some a, Some b, Some c, None, Some d, Some e, Some f]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed4_7 a b c () d e f g) =
                                     [Some a, Some b, Some c, None, Some d, Some e, Some f, Some g]"

    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed5_4 a b c d ()) =
                                     [Some a, Some b, Some c, Some d, None]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed5_5 a b c d () e) =
                                     [Some a, Some b, Some c, Some d, None, Some e]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed5_6 a b c d () e f) =
                                     [Some a, Some b, Some c, Some d, None, Some e, Some f]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed5_7 a b c d () e f g) =
                                     [Some a, Some b, Some c, Some d, None, Some e, Some f, Some g]"

    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed6_5 a b c d e ()) =
                                     [Some a, Some b, Some c, Some d, Some e, None]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed6_6 a b c d e () f) =
                                     [Some a, Some b, Some c, Some d, Some e, None, Some f]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed6_7 a b c d e () f g) =
                                     [Some a, Some b, Some c, Some d, Some e, None, Some f, Some g]"

    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed7_6 a b c d e f ()) =
                                     [Some a, Some b, Some c, Some d, Some e, Some f, None]"
    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed7_7 a b c d e f () g) =
                                     [Some a, Some b, Some c, Some d, Some e, Some f, None, Some g]"

    | "ipv6addr_syntax_compressed_to_list (IPv6AddrCompressed8_7 a b c d e f g ()) =
                                     [Some a, Some b, Some c, Some d, Some e, Some f, Some g, None]"

(*for all ipv6_syntax, there is a corresponding list representation*)
lemma parse_ipv6_address_compressed_exists:
  obtains ss where "parse_ipv6_address_compressed ss = Some ipv6_syntax"
proof
  define ss where "ss = ipv6addr_syntax_compressed_to_list ipv6_syntax"
  thus "parse_ipv6_address_compressed ss = Some ipv6_syntax"
    by (cases ipv6_syntax; simp add: parse_ipv6_address_compressed_def)
qed

lemma parse_ipv6_address_compressed_identity:
      "parse_ipv6_address_compressed (ipv6addr_syntax_compressed_to_list (ipv6_syntax)) = Some ipv6_syntax"
  by(cases ipv6_syntax; simp add: parse_ipv6_address_compressed_def)

lemma parse_ipv6_address_compressed_someE:
  assumes "parse_ipv6_address_compressed as = Some ipv6"
  obtains
    "as = [None]" "ipv6 = (IPv6AddrCompressed1_0 ())"  |
    a where "as = [None, Some a]" "ipv6 = (IPv6AddrCompressed1_1 () a)"  |
    a b where "as = [None, Some a, Some b]" "ipv6 = (IPv6AddrCompressed1_2 () a b)"  |
    a b c where "as = [None, Some a, Some b, Some c]" "ipv6 = (IPv6AddrCompressed1_3 () a b c)" |
    a b c d where "as = [None, Some a, Some b, Some c, Some d]" "ipv6 = (IPv6AddrCompressed1_4 () a b c d)" |
    a b c d e where "as = [None, Some a, Some b, Some c, Some d, Some e]" "ipv6 = (IPv6AddrCompressed1_5 () a b c d e)" |
    a b c d e f where "as = [None, Some a, Some b, Some c, Some d, Some e, Some f]" "ipv6 = (IPv6AddrCompressed1_6 () a b c d e f)" |
    a b c d e f g where "as = [None, Some a, Some b, Some c, Some d, Some e, Some f, Some g]" "ipv6 = (IPv6AddrCompressed1_7 () a b c d e f g)" |

    a where "as = [Some a, None]" "ipv6 = (IPv6AddrCompressed2_1 a ())" |
    a b where "as = [Some a, None, Some b]" "ipv6 = (IPv6AddrCompressed2_2 a () b)" |
    a b c where "as = [Some a, None, Some b, Some c]" "ipv6 = (IPv6AddrCompressed2_3 a () b c)" |
    a b c d where "as = [Some a, None, Some b, Some c, Some d]" "ipv6 = (IPv6AddrCompressed2_4 a () b c d)" |
    a b c d e where "as = [Some a, None, Some b, Some c, Some d, Some e]" "ipv6 = (IPv6AddrCompressed2_5 a () b c d e)" |
    a b c d e f where "as = [Some a, None, Some b, Some c, Some d, Some e, Some f]" "ipv6 = (IPv6AddrCompressed2_6 a () b c d e f)" |
    a b c d e f g where "as = [Some a, None, Some b, Some c, Some d, Some e, Some f, Some g]" "ipv6 = (IPv6AddrCompressed2_7 a () b c d e f g)" |

    a b where "as = [Some a, Some b, None]" "ipv6 = (IPv6AddrCompressed3_2 a b ())" |
    a b c where "as = [Some a, Some b, None, Some c]" "ipv6 = (IPv6AddrCompressed3_3 a b () c)" |
    a b c d where "as = [Some a, Some b, None, Some c, Some d]" "ipv6 = (IPv6AddrCompressed3_4 a b () c d)" |
    a b c d e where "as = [Some a, Some b, None, Some c, Some d, Some e]" "ipv6 = (IPv6AddrCompressed3_5 a b () c d e)" |
    a b c d e f where "as = [Some a, Some b, None, Some c, Some d, Some e, Some f]" "ipv6 = (IPv6AddrCompressed3_6 a b () c d e f)" |
    a b c d e f g where "as = [Some a, Some b, None, Some c, Some d, Some e, Some f, Some g]" "ipv6 = (IPv6AddrCompressed3_7 a b () c d e f g)" |

    a b c where "as = [Some a, Some b, Some c, None]" "ipv6 = (IPv6AddrCompressed4_3 a b c ())" |
    a b c d where "as = [Some a, Some b, Some c, None, Some d]" "ipv6 = (IPv6AddrCompressed4_4 a b c () d)" |
    a b c d e where "as = [Some a, Some b, Some c, None, Some d, Some e]" "ipv6 = (IPv6AddrCompressed4_5 a b c () d e)" |
    a b c d e f where "as = [Some a, Some b, Some c, None, Some d, Some e, Some f]" "ipv6 = (IPv6AddrCompressed4_6 a b c () d e f)" |
    a b c d e f g where "as = [Some a, Some b, Some c, None, Some d, Some e, Some f, Some g]" "ipv6 = (IPv6AddrCompressed4_7 a b c () d e f g)" |

    a b c d where "as = [Some a, Some b, Some c, Some d, None]" "ipv6 = (IPv6AddrCompressed5_4 a b c d ())" |
    a b c d e where "as = [Some a, Some b, Some c, Some d, None, Some e]" "ipv6 = (IPv6AddrCompressed5_5 a b c d () e)" |
    a b c d e f where "as = [Some a, Some b, Some c, Some d, None, Some e, Some f]" "ipv6 = (IPv6AddrCompressed5_6 a b c d () e f)" |
    a b c d e f g where "as = [Some a, Some b, Some c, Some d, None, Some e, Some f, Some g]" "ipv6 = (IPv6AddrCompressed5_7 a b c d () e f g)" |

    a b c d e where "as = [Some a, Some b, Some c, Some d, Some e, None]" "ipv6 = (IPv6AddrCompressed6_5 a b c d e ())" |
    a b c d e f where "as = [Some a, Some b, Some c, Some d, Some e, None, Some f]" "ipv6 = (IPv6AddrCompressed6_6 a b c d e () f)" |
    a b c d e f g where "as = [Some a, Some b, Some c, Some d, Some e, None, Some f, Some g]" "ipv6 = (IPv6AddrCompressed6_7 a b c d e () f g)" |

    a b c d e f where "as = [Some a, Some b, Some c, Some d, Some e, Some f, None]" "ipv6 = (IPv6AddrCompressed7_6 a b c d e f ())" |
    a b c d e f g where "as = [Some a, Some b, Some c, Some d, Some e, Some f, None, Some g]" "ipv6 = (IPv6AddrCompressed7_7 a b c d e f () g)" |

    a b c d e f g where "as = [Some a, Some b, Some c, Some d, Some e, Some f, Some g, None]" "ipv6 = (IPv6AddrCompressed8_7 a b c d e f g ())"
using assms
unfolding parse_ipv6_address_compressed_def
by (auto split: list.split_asm option.split_asm) (* takes a minute *)

lemma parse_ipv6_address_compressed_identity2:
      "ipv6addr_syntax_compressed_to_list ipv6_syntax = ls \<longleftrightarrow>
        (parse_ipv6_address_compressed ls) = Some ipv6_syntax"
      (is "?lhs = ?rhs")
proof
  assume ?rhs
  thus ?lhs
    by (auto elim: parse_ipv6_address_compressed_someE)
next
  assume ?lhs
  thus ?rhs
    by (cases ipv6_syntax) (auto simp: parse_ipv6_address_compressed_def)
qed

text\<open>Valid IPv6 compressed notation:
  \<^item> at most one omission
  \<^item> at most 7 pieces
\<close>
lemma RFC_4291_format: "parse_ipv6_address_compressed as \<noteq> None \<longleftrightarrow>
       length (filter (\<lambda>p. p = None) as) = 1 \<and> length (filter (\<lambda>p. p \<noteq> None) as) \<le> 7"
       (is "?lhs = ?rhs")
proof
  assume ?lhs
  then obtain addr where "parse_ipv6_address_compressed as = Some addr"
    by blast
  thus ?rhs
    by (elim parse_ipv6_address_compressed_someE; simp)
next
  assume ?rhs
  thus ?lhs
    unfolding parse_ipv6_address_compressed_def
    by (auto split: option.split list.split if_split_asm)
qed

  text_raw\<open>
  \begin{verbatim}
  3. An alternative form that is sometimes more convenient when dealing
      with a mixed environment of IPv4 and IPv6 nodes is
      x:x:x:x:x:x:d.d.d.d, where the 'x's are the hexadecimal values of
      the six high-order 16-bit pieces of the address, and the 'd's are
      the decimal values of the four low-order 8-bit pieces of the
      address (standard IPv4 representation).  Examples:

         0:0:0:0:0:0:13.1.68.3
         0:0:0:0:0:FFFF:129.144.52.38

      or in compressed form:

         ::13.1.68.3
         ::FFFF:129.144.52.38
  \end{verbatim}

  This is currently not supported by our library!
\<close>
  (*TODO*)
  (*TODO: oh boy, they can also be compressed*)

subsection\<open>Semantics\<close>
  fun ipv6preferred_to_int :: "ipv6addr_syntax \<Rightarrow> ipv6addr" where
    "ipv6preferred_to_int (IPv6AddrPreferred a b c d e f g h) = (ucast a << (16 * 7)) OR
                                                                (ucast b << (16 * 6)) OR
                                                                (ucast c << (16 * 5)) OR
                                                                (ucast d << (16 * 4)) OR
                                                                (ucast e << (16 * 3)) OR
                                                                (ucast f << (16 * 2)) OR
                                                                (ucast g << (16 * 1)) OR
                                                                (ucast h << (16 * 0))"

  lemma "ipv6preferred_to_int (IPv6AddrPreferred 0x2001 0xDB8 0x0 0x0 0x8 0x800 0x200C 0x417A) =
          42540766411282592856906245548098208122" by eval

  lemma "ipv6preferred_to_int (IPv6AddrPreferred 0xFF01 0x0 0x0 0x0 0x0 0x0 0x0 0x101) =
          338958331222012082418099330867817087233" by eval

  declare ipv6preferred_to_int.simps[simp del]

  definition int_to_ipv6preferred :: "ipv6addr \<Rightarrow> ipv6addr_syntax" where
    "int_to_ipv6preferred i = IPv6AddrPreferred (ucast ((i AND 0xFFFF0000000000000000000000000000) >> 16*7))
                                                (ucast ((i AND 0xFFFF000000000000000000000000) >> 16*6))
                                                (ucast ((i AND 0xFFFF00000000000000000000) >> 16*5))
                                                (ucast ((i AND 0xFFFF0000000000000000) >> 16*4))
                                                (ucast ((i AND 0xFFFF000000000000) >> 16*3))
                                                (ucast ((i AND 0xFFFF00000000) >> 16*2))
                                                (ucast ((i AND 0xFFFF0000) >> 16*1))
                                                (ucast ((i AND 0xFFFF)))"

  lemma "int_to_ipv6preferred 42540766411282592856906245548098208122 =
         IPv6AddrPreferred 0x2001 0xDB8 0x0 0x0 0x8 0x800 0x200C 0x417A" by eval

  lemma word128_masks_ipv6pieces:
    "(0xFFFF0000000000000000000000000000::ipv6addr) = (mask 16) << 112"
    "(0xFFFF000000000000000000000000::ipv6addr) = (mask 16) << 96"
    "(0xFFFF00000000000000000000::ipv6addr) = (mask 16) << 80"
    "(0xFFFF0000000000000000::ipv6addr) = (mask 16) << 64"
    "(0xFFFF000000000000::ipv6addr) = (mask 16) << 48"
    "(0xFFFF00000000::ipv6addr) = (mask 16) << 32"
    "(0xFFFF0000::ipv6addr) = (mask 16) << 16"
    "(0xFFFF::ipv6addr) = (mask 16)"
    by (simp_all add: mask_eq push_bit_of_1)

  text\<open>Correctness: round trip property one\<close>
  lemma ipv6preferred_to_int_int_to_ipv6preferred:
    "ipv6preferred_to_int (int_to_ipv6preferred ip) = ip"
  proof -
    have and_mask_shift_helper: "w AND (mask m << n) >> n << n = w AND (mask m << n)"
      for m n::nat and w::ipv6addr
      by (metis is_aligned_shift is_aligned_shiftr_shiftl shiftr_and_eq_shiftl)
    have ucast_ipv6_piece_rule:
      "length (dropWhile Not (to_bl w)) \<le> 16 \<Longrightarrow> (ucast::16 word \<Rightarrow> 128 word) ((ucast::128 word \<Rightarrow> 16 word) w) = w"
      for w::ipv6addr
      by(rule ucast_short_ucast_long_ingoreLeadingZero) (simp_all)
    have ucast_ipv6_piece: "16 \<le> 128 - n \<Longrightarrow>
      (ucast::16 word \<Rightarrow> 128 word) ((ucast::128 word \<Rightarrow> 16 word) (w AND (mask 16 << n) >> n)) << n = w AND (mask 16 << n)"
      for w::ipv6addr and n::nat
      apply(subst ucast_ipv6_piece_rule)
       apply(rule length_drop_mask_inner)
       apply(simp; fail)
      apply(subst and_mask_shift_helper)
      apply simp
      done

    have ucast16_ucast128_masks_highest_bits:
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF0000000000000000000000000000 >> 112)) << 112) =
             (ip AND 0xFFFF0000000000000000000000000000)"
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF000000000000000000000000 >> 96)) << 96) =
           ip AND 0xFFFF000000000000000000000000"
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF00000000000000000000 >> 80)) << 80) =
           ip AND 0xFFFF00000000000000000000"
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF0000000000000000 >> 64)) << 64) =
           ip AND 0xFFFF0000000000000000"
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF000000000000 >> 48)) << 48) =
           ip AND 0xFFFF000000000000"
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF00000000 >> 32)) << 32) =
           ip AND 0xFFFF00000000"
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF0000 >> 16)) << 16) =
           ip AND 0xFFFF0000"
            apply (simp_all add: word128_masks_ipv6pieces ucast_ipv6_piece and_mask2 word_size flip: take_bit_eq_mask)
            apply (simp_all add: bit_eq_iff)
            apply (auto simp add: bit_simps)
      done

    have ucast16_ucast128_masks_highest_bits0:
      "(ucast ((ucast::ipv6addr \<Rightarrow> 16 word) (ip AND 0xFFFF))) = ip AND 0xFFFF"
      apply(subst word128_masks_ipv6pieces)+
      apply(subst ucast_short_ucast_long_ingoreLeadingZero)
        apply simp_all
      by (simp add: length_drop_mask)

    have mask_len_word:"n = (LENGTH('a)) \<Longrightarrow> w AND mask n = w"
      for n and w::"'a::len word" by (simp add: mask_eq_iff)

    have ipv6addr_16word_pieces_compose_or:
            "ip && (mask 16 << 112) ||
             ip && (mask 16 << 96) ||
             ip && (mask 16 << 80) ||
             ip && (mask 16 << 64) ||
             ip && (mask 16 << 48) ||
             ip && (mask 16 << 32) ||
             ip && (mask 16 << 16) ||
             ip && mask 16 =
             ip"
      apply(subst word_ao_dist2[symmetric])+
      apply(simp add: mask_eq push_bit_of_1)
      apply(subst mask128)
      apply(rule mask_len_word)
      apply simp
      done

    show ?thesis
      apply (simp add: ipv6preferred_to_int.simps int_to_ipv6preferred_def)
      apply (simp add: ucast16_ucast128_masks_highest_bits ucast16_ucast128_masks_highest_bits0)
      apply (simp add: word128_masks_ipv6pieces ucast_ucast_mask)
      using ipv6addr_16word_pieces_compose_or
      apply (simp flip: push_bit_and add: shiftr_and_eq_shiftl)
      done
  qed

  text\<open>Correctness: round trip property two\<close>
  lemma int_to_ipv6preferred_ipv6preferred_to_int: "int_to_ipv6preferred (ipv6preferred_to_int ip) = ip"
  proof -
    note ucast_shift_simps=helper_masked_ucast_generic helper_masked_ucast_reverse_generic
                           helper_masked_ucast_generic[where n=0, simplified]
                           helper_masked_ucast_equal_generic
    note ucast_simps=helper_masked_ucast_reverse_generic[where m=0, simplified]
                     helper_masked_ucast_equal_generic[where n=0, simplified]
    show ?thesis
    apply (cases ip, rename_tac a b c d e f g h)
    apply (simp add: ipv6preferred_to_int.simps int_to_ipv6preferred_def)
    apply (simp add: word128_masks_ipv6pieces)
      apply (simp add: word_ao_dist ucast_shift_simps ucast_simps)
      apply (simp add: unsigned_or_eq)
      apply (simp flip: take_bit_eq_mask add: unsigned_take_bit_eq take_bit_word_eq_self)
      apply (simp add: shiftl_shiftr1 shiftl_shiftr2)
      apply (simp flip: take_bit_eq_mask push_bit_and add: word_size)
      apply (simp add: unsigned_take_bit_eq take_bit_word_eq_self)
      apply (simp flip: unsigned_take_bit_eq)
      apply (simp add: unsigned_ucast_eq)
      apply (simp add: unsigned_push_bit_eq take_bit_word_eq_self)
      apply (simp flip: ucast_drop_bit_eq)
      done
  qed

text\<open>compressed to preferred format\<close>
fun ipv6addr_c2p :: "ipv6addr_syntax_compressed \<Rightarrow> ipv6addr_syntax" where
    "ipv6addr_c2p (IPv6AddrCompressed1_0 ()) = IPv6AddrPreferred 0 0 0 0 0 0 0 0"
  | "ipv6addr_c2p (IPv6AddrCompressed1_1 () h) = IPv6AddrPreferred 0 0 0 0 0 0 0 h"
  | "ipv6addr_c2p (IPv6AddrCompressed1_2 () g h) = IPv6AddrPreferred 0 0 0 0 0 0 g h"
  | "ipv6addr_c2p (IPv6AddrCompressed1_3 () f g h) = IPv6AddrPreferred 0 0 0 0 0 f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed1_4 () e f g h) = IPv6AddrPreferred 0 0 0 0 e f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed1_5 () d e f g h) = IPv6AddrPreferred 0 0 0 d e f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed1_6 () c d e f g h) = IPv6AddrPreferred 0 0 c d e f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed1_7 () b c d e f g h) = IPv6AddrPreferred 0 b c d e f g h"

  | "ipv6addr_c2p (IPv6AddrCompressed2_1 a ()) = IPv6AddrPreferred a 0 0 0 0 0 0 0"
  | "ipv6addr_c2p (IPv6AddrCompressed2_2 a () h) = IPv6AddrPreferred a 0 0 0 0 0 0 h"
  | "ipv6addr_c2p (IPv6AddrCompressed2_3 a () g h) = IPv6AddrPreferred a 0 0 0 0 0 g h"
  | "ipv6addr_c2p (IPv6AddrCompressed2_4 a () f g h) = IPv6AddrPreferred a 0 0 0 0 f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed2_5 a () e f g h) = IPv6AddrPreferred a 0 0 0 e f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed2_6 a () d e f g h) = IPv6AddrPreferred a 0 0 d e f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed2_7 a () c d e f g h) = IPv6AddrPreferred a 0 c d e f g h"

  | "ipv6addr_c2p (IPv6AddrCompressed3_2 a b ()) = IPv6AddrPreferred a b 0 0 0 0 0 0"
  | "ipv6addr_c2p (IPv6AddrCompressed3_3 a b () h) = IPv6AddrPreferred a b 0 0 0 0 0 h"
  | "ipv6addr_c2p (IPv6AddrCompressed3_4 a b () g h) = IPv6AddrPreferred a b 0 0 0 0 g h"
  | "ipv6addr_c2p (IPv6AddrCompressed3_5 a b () f g h) = IPv6AddrPreferred a b 0 0 0 f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed3_6 a b () e f g h) = IPv6AddrPreferred a b 0 0 e f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed3_7 a b () d e f g h) = IPv6AddrPreferred a b 0 d e f g h"

  | "ipv6addr_c2p (IPv6AddrCompressed4_3 a b c ()) = IPv6AddrPreferred a b c 0 0 0 0 0"
  | "ipv6addr_c2p (IPv6AddrCompressed4_4 a b c () h) = IPv6AddrPreferred a b c 0 0 0 0 h"
  | "ipv6addr_c2p (IPv6AddrCompressed4_5 a b c () g h) = IPv6AddrPreferred a b c 0 0 0 g h"
  | "ipv6addr_c2p (IPv6AddrCompressed4_6 a b c () f g h) = IPv6AddrPreferred a b c 0 0 f g h"
  | "ipv6addr_c2p (IPv6AddrCompressed4_7 a b c () e f g h) = IPv6AddrPreferred a b c 0 e f g h"

  | "ipv6addr_c2p (IPv6AddrCompressed5_4 a b c d ()) = IPv6AddrPreferred a b c d 0 0 0 0"
  | "ipv6addr_c2p (IPv6AddrCompressed5_5 a b c d () h) = IPv6AddrPreferred a b c d 0 0 0 h"
  | "ipv6addr_c2p (IPv6AddrCompressed5_6 a b c d () g h) = IPv6AddrPreferred a b c d 0 0 g h"
  | "ipv6addr_c2p (IPv6AddrCompressed5_7 a b c d () f g h) = IPv6AddrPreferred a b c d 0 f g h"

  | "ipv6addr_c2p (IPv6AddrCompressed6_5 a b c d e ()) = IPv6AddrPreferred a b c d e 0 0 0"
  | "ipv6addr_c2p (IPv6AddrCompressed6_6 a b c d e () h) = IPv6AddrPreferred a b c d e 0 0 h"
  | "ipv6addr_c2p (IPv6AddrCompressed6_7 a b c d e () g h) = IPv6AddrPreferred a b c d e 0 g h"

  | "ipv6addr_c2p (IPv6AddrCompressed7_6 a b c d e f ()) = IPv6AddrPreferred a b c d e f 0 0"
  | "ipv6addr_c2p (IPv6AddrCompressed7_7 a b c d e f () h) = IPv6AddrPreferred a b c d e f 0 h"

  | "ipv6addr_c2p (IPv6AddrCompressed8_7 a b c d e f g ()) = IPv6AddrPreferred a b c d e f g 0"

definition ipv6_unparsed_compressed_to_preferred :: "((16 word) option) list \<Rightarrow> ipv6addr_syntax option" where
  "ipv6_unparsed_compressed_to_preferred ls = (
    if
      length (filter (\<lambda>p. p = None) ls) \<noteq> 1 \<or> length (filter (\<lambda>p. p \<noteq> None) ls) > 7
    then
      None
    else
      let
        before_omission = map the (takeWhile (\<lambda>x. x \<noteq> None) ls);
        after_omission = map the (drop 1 (dropWhile (\<lambda>x. x \<noteq> None) ls));
        num_omissions = 8 - (length before_omission + length after_omission);
        expanded = before_omission @ (replicate num_omissions 0) @ after_omission
      in
        case expanded of [a,b,c,d,e,f,g,h] \<Rightarrow> Some (IPv6AddrPreferred a b c d e f g h)
                         | _               \<Rightarrow> None
      )"

  lemma "ipv6_unparsed_compressed_to_preferred
    [Some 0x2001, Some 0xDB8, None, Some 0x8, Some 0x800, Some 0x200C, Some 0x417A]
      = Some (IPv6AddrPreferred 0x2001 0xDB8 0 0 8 0x800 0x200C 0x417A)" by eval

  lemma "ipv6_unparsed_compressed_to_preferred [None] = Some (IPv6AddrPreferred 0 0 0 0 0 0 0 0)" by eval

  lemma "ipv6_unparsed_compressed_to_preferred [] = None" by eval

  lemma ipv6_unparsed_compressed_to_preferred_identity1:
   "ipv6_unparsed_compressed_to_preferred (ipv6addr_syntax_compressed_to_list ipv6compressed) = Some ipv6prferred
    \<longleftrightarrow> ipv6addr_c2p ipv6compressed = ipv6prferred"
    by (cases ipv6compressed) (simp_all add: ipv6_unparsed_compressed_to_preferred_def numeral_eq_Suc) (*1s*)

  lemma ipv6_unparsed_compressed_to_preferred_identity2:
    "ipv6_unparsed_compressed_to_preferred ls = Some ipv6prferred
     \<longleftrightarrow> (\<exists>ipv6compressed. parse_ipv6_address_compressed ls = Some ipv6compressed \<and>
                           ipv6addr_c2p ipv6compressed = ipv6prferred)"
  apply(rule iffI)
   apply(subgoal_tac "parse_ipv6_address_compressed ls \<noteq> None")
    prefer 2
    apply(subst RFC_4291_format)
    apply(simp add: ipv6_unparsed_compressed_to_preferred_def split: if_split_asm; fail)
   apply(simp)
   apply(erule exE, rename_tac ipv6compressed)
   apply(rule_tac x="ipv6compressed" in exI)
   apply(simp)
   apply(subgoal_tac "(ipv6addr_syntax_compressed_to_list ipv6compressed = ls)")
    prefer 2
    using parse_ipv6_address_compressed_identity2 apply presburger
   using ipv6_unparsed_compressed_to_preferred_identity1 apply blast
  apply(erule exE, rename_tac ipv6compressed)
  apply(subgoal_tac "(ipv6addr_syntax_compressed_to_list ipv6compressed = ls)")
   prefer 2
   using parse_ipv6_address_compressed_identity2 apply presburger
  using ipv6_unparsed_compressed_to_preferred_identity1 apply blast
  done

subsection\<open>IPv6 Pretty Printing (converting to compressed format)\<close>
text_raw\<open>
RFC5952:
\begin{verbatim}
4.  A Recommendation for IPv6 Text Representation

   A recommendation for a canonical text representation format of IPv6
   addresses is presented in this section.  The recommendation in this
   document is one that complies fully with [RFC4291], is implemented by
   various operating systems, and is human friendly.  The recommendation
   in this section SHOULD be followed by systems when generating an
   address to be represented as text, but all implementations MUST
   accept and be able to handle any legitimate [RFC4291] format.  It is
   advised that humans also follow these recommendations when spelling
   an address.

4.1.  Handling Leading Zeros in a 16-Bit Field

   Leading zeros MUST be suppressed.  For example, 2001:0db8::0001 is
   not acceptable and must be represented as 2001:db8::1.  A single 16-
   bit 0000 field MUST be represented as 0.

4.2.  "::" Usage

4.2.1.  Shorten as Much as Possible

   The use of the symbol "::" MUST be used to its maximum capability.
   For example, 2001:db8:0:0:0:0:2:1 must be shortened to 2001:db8::2:1.
   Likewise, 2001:db8::0:1 is not acceptable, because the symbol "::"
   could have been used to produce a shorter representation 2001:db8::1.

4.2.2.  Handling One 16-Bit 0 Field

   The symbol "::" MUST NOT be used to shorten just one 16-bit 0 field.
   For example, the representation 2001:db8:0:1:1:1:1:1 is correct, but
   2001:db8::1:1:1:1:1 is not correct.

4.2.3.  Choice in Placement of "::"

   When there is an alternative choice in the placement of a "::", the
   longest run of consecutive 16-bit 0 fields MUST be shortened (i.e.,
   the sequence with three consecutive zero fields is shortened in 2001:
   0:0:1:0:0:0:1).  When the length of the consecutive 16-bit 0 fields
   are equal (i.e., 2001:db8:0:0:1:0:0:1), the first sequence of zero
   bits MUST be shortened.  For example, 2001:db8::1:0:0:1 is correct
   representation.

4.3.  Lowercase

   The characters "a", "b", "c", "d", "e", and "f" in an IPv6 address
   MUST be represented in lowercase.
\end{verbatim}
\<close>
text\<open>See @{file \<open>IP_Address_toString.thy\<close>} for examples and test cases.\<close>
context
begin
  private function goup_by_zeros :: "16 word list \<Rightarrow> 16 word list list" where
    "goup_by_zeros [] = []" |
    "goup_by_zeros (x#xs) = (
        if x = 0
        then takeWhile (\<lambda>x. x = 0) (x#xs) # (goup_by_zeros (dropWhile (\<lambda>x. x = 0) xs))
        else [x]#(goup_by_zeros xs))"
  by(pat_completeness, auto)

  termination goup_by_zeros
	 apply(relation "measure (\<lambda>xs. length xs)")
	   apply(simp_all)
	 by (simp add: le_imp_less_Suc length_dropWhile_le)

	private lemma "goup_by_zeros [0,1,2,3,0,0,0,0,3,4,0,0,0,2,0,0,2,0,3,0] =
	        [[0], [1], [2], [3], [0, 0, 0, 0], [3], [4], [0, 0, 0], [2], [0, 0], [2], [0], [3], [0]]"
	by eval

	private lemma "concat (goup_by_zeros ls) = ls"
	  by(induction ls rule:goup_by_zeros.induct) simp+

	private lemma "[] \<notin> set (goup_by_zeros ls)"
	  by(induction ls rule:goup_by_zeros.induct) simp+

  private primrec List_replace1 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    "List_replace1 _ _ [] = []" |
    "List_replace1 a b (x#xs) = (if a = x then b#xs else x#List_replace1 a b xs)"

	private lemma "List_replace1 a a ls = ls"
	  by(induction ls) simp_all

	private lemma "a \<notin> set ls \<Longrightarrow> List_replace1 a b ls = ls"
	  by(induction ls) simp_all

	private lemma "a \<in> set ls \<Longrightarrow> b \<in> set (List_replace1 a b ls)"
	  apply(induction ls)
	   apply(simp)
	  apply(simp)
	  by blast

	private fun List_explode :: "'a list list \<Rightarrow> ('a option) list" where
	  "List_explode [] = []" |
	  "List_explode ([]#xs) = None#List_explode xs" |
	  "List_explode (xs1#xs2) = map Some xs1@List_explode xs2"

  private lemma "List_explode [[0::int], [2,3], [], [3,4]] = [Some 0, Some 2, Some 3, None, Some 3, Some 4]"
  by eval

  private lemma List_explode_def:
    "List_explode xss = concat (map (\<lambda>xs. if xs = [] then [None] else map Some xs) xss)"
    by(induction xss rule: List_explode.induct) simp+

  private lemma List_explode_no_empty: "[] \<notin> set xss \<Longrightarrow> List_explode xss = map Some (concat xss)"
    by(induction xss rule: List_explode.induct) simp+

  private lemma List_explode_replace1: "[] \<notin> set xss \<Longrightarrow> foo \<in> set xss \<Longrightarrow>
          List_explode (List_replace1 foo [] xss) =
            map Some (concat (takeWhile (\<lambda>xs. xs \<noteq> foo) xss)) @ [None] @
              map Some (concat (tl (dropWhile (\<lambda>xs. xs \<noteq> foo) xss)))"
    apply(induction xss rule: List_explode.induct)
      apply(simp; fail)
     apply(simp; fail)
    apply(simp)
    apply safe
      apply(simp_all add: List_explode_no_empty)
    done

  fun ipv6_preferred_to_compressed :: "ipv6addr_syntax \<Rightarrow> ((16 word) option) list" where
  "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (
    let lss = goup_by_zeros [a,b,c,d,e,f,g,h];
        max_zero_seq = foldr (\<lambda>xs. max (length xs)) lss 0;
        shortened = if max_zero_seq > 1 then List_replace1 (replicate max_zero_seq 0) [] lss else lss
    in
      List_explode shortened
    )"
  declare ipv6_preferred_to_compressed.simps[simp del]

  private lemma foldr_max_length: "foldr (\<lambda>xs. max (length xs)) lss n = fold max (map length lss) n"
    apply(subst List.foldr_fold)
     apply fastforce
    apply(induction lss arbitrary: n)
     apply(simp; fail)
    apply(simp)
    done

  private lemma List_explode_goup_by_zeros: "List_explode (goup_by_zeros xs) = map Some xs"
    apply(induction xs rule: goup_by_zeros.induct)
     apply(simp; fail)
    apply(simp)
    apply(safe)
     apply(simp)
    by (metis map_append takeWhile_dropWhile_id)

  private definition "max_zero_streak xs \<equiv> foldr (\<lambda>xs. max (length xs)) (goup_by_zeros xs) 0"

  private lemma max_zero_streak_def2: "max_zero_streak xs = fold max (map length (goup_by_zeros xs)) 0"
    unfolding max_zero_streak_def
    by(simp add: foldr_max_length)

  private lemma ipv6_preferred_to_compressed_pull_out_if:
    "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (
    if max_zero_streak [a,b,c,d,e,f,g,h] > 1 then
      List_explode (List_replace1 (replicate (max_zero_streak [a,b,c,d,e,f,g,h]) 0) [] (goup_by_zeros [a,b,c,d,e,f,g,h]))
    else
      map Some [a,b,c,d,e,f,g,h]
    )"
  by(simp add: ipv6_preferred_to_compressed.simps max_zero_streak_def List_explode_goup_by_zeros)

  private lemma "ipv6_preferred_to_compressed (IPv6AddrPreferred 0 0 0 0 0 0 0 0) = [None]" by eval
  private lemma "ipv6_preferred_to_compressed (IPv6AddrPreferred 0x2001 0xDB8 0 0 8 0x800 0x200C 0x417A) =
                [Some 0x2001, Some 0xDB8, None,           Some 8, Some 0x800, Some 0x200C, Some 0x417A]" by eval
  private lemma "ipv6_preferred_to_compressed (IPv6AddrPreferred 0x2001 0xDB8 0 3 8 0x800 0x200C 0x417A) =
                [Some 0x2001, Some 0xDB8, Some 0, Some 3, Some 8, Some 0x800, Some 0x200C, Some 0x417A]" by eval

  (*the output should even conform to RFC5952, ...*)
  lemma ipv6_preferred_to_compressed_RFC_4291_format:
    "ipv6_preferred_to_compressed ip = as \<Longrightarrow>
          length (filter (\<lambda>p. p = None) as) = 0 \<and> length as = 8
          \<or>
          length (filter (\<lambda>p. p = None) as) = 1 \<and> length (filter (\<lambda>p. p \<noteq> None) as) \<le> 7"
  apply(cases ip)
  apply(simp add: ipv6_preferred_to_compressed_pull_out_if)
  apply(simp only: split: if_split_asm)
   subgoal for a b c d e f g h
   apply(rule disjI2)
   apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
         case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
   by(auto simp add: max_zero_streak_def) (*1min*)
  subgoal
  apply(rule disjI1)
  apply(simp)
  by force
  done

  \<comment> \<open>Idea for the following proof:\<close>
  private lemma "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = None#xs \<Longrightarrow>
      xs = map Some (dropWhile (\<lambda>x. x=0) [a,b,c,d,e,f,g,h])"
    apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
          case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
    by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*20s*)

  lemma ipv6_preferred_to_compressed:
    assumes "ipv6_unparsed_compressed_to_preferred (ipv6_preferred_to_compressed ip) = Some ip'"
    shows "ip = ip'"
  proof -
    from assms have 1: "\<exists>ipv6compressed.
         parse_ipv6_address_compressed (ipv6_preferred_to_compressed ip) = Some ipv6compressed \<and>
         ipv6addr_c2p ipv6compressed = ip'" using ipv6_unparsed_compressed_to_preferred_identity2 by simp

    obtain a b c d e f g h where ip: "ip = IPv6AddrPreferred a b c d e f g h" by(cases ip)

    have ipv6_preferred_to_compressed_None1:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [a,b,c,d,e,f,g,h]) = xs \<Longrightarrow> (IPv6AddrPreferred a b c d e f g h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'" for xs
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)
    have ipv6_preferred_to_compressed_None2:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (Some a')#None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [b,c,d,e,f,g,h]) = xs \<Longrightarrow> (IPv6AddrPreferred a' b c d e f g h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'" for xs a'
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)
    have ipv6_preferred_to_compressed_None3:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (Some a')#(Some b')#None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [c,d,e,f,g,h]) = xs \<Longrightarrow> (IPv6AddrPreferred a' b' c d e f g h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'" for xs a' b'
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)
    have ipv6_preferred_to_compressed_None4:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (Some a')#(Some b')#(Some c')#None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [d,e,f,g,h]) = xs \<Longrightarrow> (IPv6AddrPreferred a' b' c' d e f g h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'" for xs a' b' c'
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)
    have ipv6_preferred_to_compressed_None5:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (Some a')#(Some b')#(Some c')#(Some d')#None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [e,f,g,h]) = xs \<Longrightarrow> (IPv6AddrPreferred a' b' c' d' e f g h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'" for xs a' b' c' d'
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)
    have ipv6_preferred_to_compressed_None6:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (Some a')#(Some b')#(Some c')#(Some d')#(Some e')#None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [f,g,h]) = xs \<Longrightarrow> (IPv6AddrPreferred a' b' c' d' e' f g h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'" for xs a' b' c' d' e'
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)
    have ipv6_preferred_to_compressed_None7:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (Some a')#(Some b')#(Some c')#(Some d')#(Some e')#(Some f')#None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [g,h]) = xs \<Longrightarrow> (IPv6AddrPreferred a' b' c' d' e' f' g h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'"  for xs a' b' c' d' e' f'
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)
    have ipv6_preferred_to_compressed_None8:
      "ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h) = (Some a')#(Some b')#(Some c')#(Some d')#(Some e')#(Some f')#(Some g')#None#xs \<Longrightarrow>
        (map Some (dropWhile (\<lambda>x. x=0) [h]) = xs \<Longrightarrow> (IPv6AddrPreferred a' b' c' d' e' f' g' h) = ip') \<Longrightarrow>
        (IPv6AddrPreferred a b c d e f g h) = ip'" for xs a' b' c' d' e' f' g'
      apply(case_tac "a=0",case_tac [!] "b=0",case_tac [!] "c=0",case_tac [!] "d=0",
            case_tac [!] "e=0",case_tac [!] "f=0",case_tac [!] "g=0",case_tac [!] "h=0")
      by(simp_all add: ipv6_preferred_to_compressed_pull_out_if max_zero_streak_def) (*5s*)

    have 2: "parse_ipv6_address_compressed (ipv6_preferred_to_compressed (IPv6AddrPreferred a b c d e f g h))
                = Some ipv6compressed \<Longrightarrow>
       ipv6addr_c2p ipv6compressed = ip' \<Longrightarrow>
       IPv6AddrPreferred a b c d e f g h = ip'"
    for ipv6compressed
      apply(erule parse_ipv6_address_compressed_someE)
                                         apply(simp_all)
                                         apply(erule ipv6_preferred_to_compressed_None1, simp split: if_split_asm)+
                                 apply(erule ipv6_preferred_to_compressed_None2, simp split: if_split_asm)+
                         apply(erule ipv6_preferred_to_compressed_None3, simp split: if_split_asm)+
                    apply(erule ipv6_preferred_to_compressed_None4, simp split: if_split_asm)+
               apply(erule ipv6_preferred_to_compressed_None5, simp split: if_split_asm)+
           apply(erule ipv6_preferred_to_compressed_None6, simp split: if_split_asm)+
        apply(erule ipv6_preferred_to_compressed_None7, simp split: if_split_asm)+
      apply(erule ipv6_preferred_to_compressed_None8, simp split: if_split_asm)
      done
    from 1 2 ip show ?thesis by(elim exE conjE, simp)
  qed
end

end