(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

header {* Veblen Hierarchies *}

theory OrdinalVeblen
imports OrdinalOmega
begin

subsection {* Closed, unbounded sets *}

locale normal_set =
fixes A :: "ordinal set"
assumes closed:    "\<And>g. \<forall>n. g n \<in> A \<Longrightarrow> oLimit g \<in> A"
    and unbounded: "\<And>x. \<exists>y\<in>A. x < y"

lemma (in normal_set) less_next: "x < (LEAST z. z \<in> A \<and> x < z)"
 apply (rule LeastI2_ex)
 apply (fold Bex_def, rule unbounded)
 apply (erule conjunct2)
done

lemma (in normal_set) mem_next: "(LEAST z. z \<in> A \<and> x < z) \<in> A"
 apply (rule LeastI2_ex)
 apply (fold Bex_def, rule unbounded)
 apply (erule conjunct1)
done

lemma (in normal) normal_set_range: "normal_set (range F)"
 apply (rule normal_set.intro)
  apply (simp add: image_def)
  apply (rule_tac x="oLimit (\<lambda>n. LEAST x. g n = F x)" in exI)
  apply (simp only: oLimit)
  apply (rule_tac f=oLimit in arg_cong)
  apply (rule ext)
  apply (rule LeastI_ex)
  apply (erule spec)
 apply (rule_tac x="F (oSuc x)" in bexI)
  apply (rule order_le_less_trans [OF increasing])
  apply (simp add: cancel_less)
 apply (rule rangeI)
done

lemma oLimit_mem_INTER:
"\<lbrakk>\<forall>n. normal_set (A n); \<forall>n. A (Suc n) \<subseteq> A n;
  \<forall>n. f n \<in> A n; mono f\<rbrakk>
  \<Longrightarrow> oLimit f \<in> (\<Inter>n. A n)"
 apply (clarsimp, rename_tac k)
 apply (subgoal_tac "oLimit (\<lambda>n. f (n + k)) \<in> A k")
  apply (simp add: oLimit_shift_mono)
 apply (rule normal_set.closed [rule_format], erule spec)
 apply (rule_tac A="A (n + k)" in subsetD)
  apply (induct_tac n, simp, rename_tac m)
  apply (rule_tac B="A (m + k)" in subset_trans, simp, simp)
 apply (erule spec)
done

lemma normal_set_INTER:
"\<lbrakk>\<forall>n. normal_set (A n); \<forall>n. A (Suc n) \<subseteq> A n\<rbrakk> \<Longrightarrow> normal_set (\<Inter>n. A n)"
 apply (rule normal_set.intro)
  apply (clarsimp simp add: normal_set.closed)
 apply (rule_tac x="oLimit (\<lambda>n. LEAST y. y \<in> A n \<and> x < y)" in bexI)
  apply (rule_tac y="LEAST y. y \<in> A n \<and> x < y" in order_less_le_trans)
   apply (simp only: normal_set.less_next)
  apply (rule le_oLimit)
 apply (rule oLimit_mem_INTER, assumption+)
  apply (simp add: normal_set.mem_next)
 apply (rule mono_natI)
 apply (rule Least_le)
 apply (rule conjI)
  apply (rule subsetD, erule spec)
  apply (simp only: normal_set.mem_next)
 apply (simp only: normal_set.less_next)
done

subsection {* Ordering functions *}

text "There is a one-to-one correspondence between closed,
unbounded sets of ordinals and normal functions on ordinals."

definition
  ordering  :: "(ordinal set) \<Rightarrow> (ordinal \<Rightarrow> ordinal)" where
  "ordering A = ordinal_rec (LEAST z. z \<in> A) (\<lambda>p x. LEAST z. z \<in> A \<and> x < z)"

lemma ordering_0:
"ordering A 0 = (LEAST z. z \<in> A)"
by (simp add: ordering_def)

lemma ordering_oSuc:
"ordering A (oSuc x) = (LEAST z. z \<in> A \<and> ordering A x < z)"
by (simp add: ordering_def)

lemma (in normal_set) normal_ordering: "normal (ordering A)"
 apply (unfold ordering_def)
 apply (rule normal_ordinal_rec [rule_format])
 apply (rule less_next)
done

lemma (in normal_set) ordering_oLimit:
"ordering A (oLimit f) = oLimit (\<lambda>n. ordering A (f n))"
 apply (rule normal.oLimit)
 apply (rule normal_ordering)
done

lemma (in normal) ordering_range: "ordering (range F) = F"
 apply (rule ext, rule_tac a=x in oLimit_induct)
   apply (simp add: ordering_0)
   apply (rule Least_equality)
    apply (rule rangeI)
   apply (clarsimp simp add: cancel_le)
  apply (simp add: ordering_oSuc)
  apply (rule Least_equality)
   apply (simp add: cancel_less)
  apply (clarsimp simp add: cancel_le cancel_less oSuc_leI)
 apply (subst normal_set.ordering_oLimit)
  apply (rule normal_set_range)
 apply (simp add: oLimit)
done

lemma (in normal_set) ordering_mem: "ordering A x \<in> A"
 apply (rule_tac a=x in oLimit_induct)
   apply (subst ordering_0)
   apply (rule LeastI_ex)
   apply (cut_tac unbounded, force)
  apply (subst ordering_oSuc)
  apply (rule mem_next)
 apply (subst ordering_oLimit)
 apply (erule closed)
done

lemma (in normal_set) range_ordering_lemma:
"\<forall>y. y \<in> A \<longrightarrow> y < ordering A x \<longrightarrow> y \<in> range (ordering A)"
 apply (simp add: image_def)
 apply (rule_tac a=x in oLimit_induct, safe)
   apply (simp add: ordering_0)
   apply (drule not_less_Least, simp)
  apply (simp add: ordering_oSuc)
  apply (drule not_less_Least, simp)
  apply (force simp add: linorder_not_less order_le_less)
 apply (simp add: ordering_oLimit)
 apply (drule less_oLimitD, clarsimp)
done

lemma (in normal_set) range_ordering: "range (ordering A) = A"
 apply (safe intro!: ordering_mem)
 apply (erule_tac x="oSuc x" in range_ordering_lemma[rule_format])
 apply (rule order_less_le_trans[OF less_oSuc])
 apply (rule normal.increasing[OF normal_ordering])
done

lemma ordering_INTER_0:
"\<lbrakk>\<forall>n. normal_set (A n); \<forall>n. A (Suc n) \<subseteq> A n\<rbrakk>
 \<Longrightarrow> ordering (\<Inter>n. A n) 0 = oLimit (\<lambda>n. ordering (A n) 0)"
 apply (subst ordering_0)
 apply (rule Least_equality)
  apply (rule oLimit_mem_INTER, assumption+)
   apply (simp add: normal_set.ordering_mem)
  apply (rule mono_natI)
  apply (simp add: ordering_0)
  apply (rule Least_le)
  apply (rule subsetD, erule spec)
  apply (drule_tac x="Suc n" in spec)
  apply (drule normal_set.unbounded, clarify)
  apply (erule LeastI)
 apply (rule oLimit_leI[rule_format])
 apply (simp add: ordering_0)
 apply (rule Least_le)
 apply (erule spec)
done

subsection {* Critical ordinals *}

definition
  critical_set :: "ordinal set \<Rightarrow> ordinal \<Rightarrow> ordinal set" where
  "critical_set A =
     ordinal_rec0 A (\<lambda>p x. x \<inter> range (oDeriv (ordering x))) (\<lambda>f. \<Inter>n. f n)"

lemma critical_set_0:
"critical_set A 0 = A"
by (unfold critical_set_def, rule ordinal_rec0_0)

lemma critical_set_oSuc_lemma:
"critical_set A (oSuc n) =
  critical_set A n \<inter> range (oDeriv (ordering (critical_set A n)))"
by (unfold critical_set_def, rule ordinal_rec0_oSuc)

lemma omega_complete_INTER:
"omega_complete (\<lambda>x y. y \<subseteq> x) (INTER UNIV)"
 apply (rule omega_complete.intro)
  apply (rule porder.flip)
  apply (rule porder_order)
 apply (rule omega_complete_axioms.intro)
  apply fast
 apply fast
done

lemma critical_set_oLimit:
"critical_set A (oLimit f) = (\<Inter>n. critical_set A (f n))"
 apply (unfold critical_set_def)
 apply (rule omega_complete.ordinal_rec0_oLimit)
  apply (rule omega_complete_INTER)
 apply fast
done

lemma critical_set_mono:
"x \<le> y \<Longrightarrow> critical_set A y \<subseteq> critical_set A x"
 apply (unfold critical_set_def)
 apply (rule omega_complete.ordinal_rec0_mono
          [OF omega_complete_INTER])
  apply fast
 apply assumption
done

lemma (in normal_set) range_oDeriv_subset:
"range (oDeriv (ordering A)) \<subseteq> A"
 apply (clarsimp, rename_tac x)
 apply (cut_tac n=x in oDeriv_fixed[OF normal_ordering])
 apply (erule subst)
 apply (rule ordering_mem)
done

lemma normal_set_critical_set:
"normal_set A \<Longrightarrow> normal_set (critical_set A x)"
 apply (rule_tac a=x in oLimit_induct)
   apply (simp only: critical_set_0)
  apply (simp only: critical_set_oSuc_lemma)
  apply (subst Int_absorb1)
   apply (erule normal_set.range_oDeriv_subset)
  apply (rule normal.normal_set_range)
  apply (rule normal_oDeriv)
 apply (simp only: critical_set_oLimit)
 apply (erule normal_set_INTER)
 apply (rule allI, rule critical_set_mono)
 apply (simp add: strict_mono_monoD)
done

lemma critical_set_oSuc:
"normal_set A
 \<Longrightarrow> critical_set A (oSuc x) = range (oDeriv (ordering (critical_set A x)))"
 apply (simp only: critical_set_oSuc_lemma)
 apply (rule Int_absorb1)
 apply (rule normal_set.range_oDeriv_subset)
 apply (erule normal_set_critical_set)
done

subsection {* Veblen hierarchy over a normal function *}

definition
  oVeblen :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oVeblen F = (\<lambda>x. ordering (critical_set (range F) x))"

lemma (in normal) oVeblen_0: "oVeblen F 0 = F"
 apply (unfold oVeblen_def)
 apply (subst critical_set_0)
 apply (rule ordering_range)
done

lemma (in normal) oVeblen_oSuc:
"oVeblen F (oSuc x) = oDeriv (oVeblen F x)"
 apply (unfold oVeblen_def)
 apply (subst critical_set_oSuc)
  apply (rule normal_set_range)
 apply (rule normal.ordering_range)
 apply (rule normal_oDeriv)
done

lemma (in normal) oVeblen_oLimit:
"oVeblen F (oLimit f) = ordering (\<Inter>n. range (oVeblen F (f n)))"
 apply (unfold oVeblen_def)
 apply (subst critical_set_oLimit)
 apply (cut_tac normal_set_range)
 apply (simp add: normal_set.range_ordering[OF normal_set_critical_set])
done

lemma (in normal) normal_oVeblen:
"normal (oVeblen F x)"
 apply (unfold oVeblen_def)
 apply (rule normal_set.normal_ordering)
 apply (rule normal_set_critical_set)
 apply (rule normal_set_range)
done

lemma (in normal) continuous_oVeblen_0:
"continuous (\<lambda>x. oVeblen F x 0)"
 apply (rule continuousI)
  apply (simp add: oVeblen_def critical_set_oLimit)
  apply (rule ordering_INTER_0[rule_format])
   apply (rule normal_set_critical_set)
   apply (rule normal_set_range)
  apply (rule critical_set_mono)
  apply (simp add: strict_mono_monoD)
 apply (simp only: oVeblen_oSuc)
 apply (rule oDeriv_increasing)
 apply (rule normal.continuous)
 apply (rule normal_oVeblen)
done

lemma (in normal) oVeblen_oLimit_0:
"oVeblen F (oLimit f) 0 = oLimit (\<lambda>n. oVeblen F (f n) 0)"
by (rule continuousD[OF continuous_oVeblen_0])

lemma (in normal) normal_oVeblen_0:
"0 < F 0 \<Longrightarrow> normal (\<lambda>x. oVeblen F x 0)"
 apply (rule normalI)
  apply (rule oVeblen_oLimit_0)
 apply (simp only: oVeblen_oSuc)
 apply (subst oDeriv_fixed[OF normal_oVeblen, symmetric])
 apply (rule normal.strict_monoD[OF normal_oVeblen])
 apply (simp add: zero_less_oFix_eq)
 apply (erule order_less_le_trans)
 apply (subgoal_tac "oVeblen F 0 0 \<le> oVeblen F x 0")
  apply (simp add: oVeblen_0)
 apply (rule continuous.monoD[OF _ ordinal_0_le])
 apply (rule continuous_oVeblen_0)
done

lemma (in normal) range_oVeblen:
"range (oVeblen F x) = critical_set (range F) x"
 apply (unfold oVeblen_def)
 apply (rule normal_set.range_ordering)
 apply (rule normal_set_critical_set)
 apply (rule normal_set_range)
done

lemma (in normal) range_oVeblen_subset:
"x \<le> y \<Longrightarrow> range (oVeblen F y) \<subseteq> range (oVeblen F x)"
 apply (simp only: range_oVeblen)
 apply (erule critical_set_mono)
done

lemma (in normal) oVeblen_fixed:
"\<forall>x<y. \<forall>a. oVeblen F x (oVeblen F y a) = oVeblen F y a"
 apply (rule_tac a=y in oLimit_induct)
   apply simp
  apply (clarsimp simp only: oVeblen_oSuc)
  apply (erule less_oSucE)
   apply (drule spec, drule mp, assumption)
   apply (drule_tac x="oDeriv (oVeblen F x) a" in spec)
   apply (simp add: oDeriv_fixed normal_oVeblen)
  apply simp
  apply (rule oDeriv_fixed)
  apply (rule normal_oVeblen)
 apply clarsimp
 apply (erule less_oLimitE)
 apply (drule spec, drule spec, drule mp, assumption)
 apply (subgoal_tac "oVeblen F (oLimit f) a \<in> range (oVeblen F (f n))")
  apply clarsimp
 apply (rule_tac A="range (oVeblen F (oLimit f))" in subsetD)
  apply (rule range_oVeblen_subset)
  apply (rule le_oLimit)
 apply (rule rangeI)
done

lemma (in normal) critical_set_fixed:
"0 < z \<Longrightarrow> range (oVeblen F z) = {x. \<forall>y<z. oVeblen F y x = x}"
 apply (rule equalityI)
  apply (clarsimp simp add: oVeblen_fixed)
 apply (erule rev_mp)
 apply (rule_tac a=z in oLimit_induct)
   apply simp
  apply clarsimp
  apply (simp add: oVeblen_oSuc range_oDeriv normal_oVeblen)
 apply clarsimp
 apply (simp add: range_oVeblen)
 apply (clarsimp simp add: critical_set_oLimit)
 apply (rule_tac A="critical_set (range F) (f (Suc n))" in subsetD)
  apply (rule critical_set_mono)
  apply (simp add: strict_mono_monoD)
 apply (drule_tac x="Suc n" in spec, drule mp)
  apply (rule_tac y="f n" in order_le_less_trans, simp)
  apply (erule OrdinalInduct.strict_monoD, simp)
 apply (erule subsetD, clarsimp)
 apply (drule spec, erule mp)
 apply (erule order_less_le_trans)
 apply (rule le_oLimit)
done

subsection {* Veblen hierarchy over $\lambda x.\ 1 + x$ *}

lemma oDeriv_id: "oDeriv id = id"
 apply (rule ext, rule_tac a=x in oLimit_induct)
   apply (simp add: oFix_eq_self)
  apply (simp add: oFix_eq_self)
 apply simp
done

lemma oFix_plus: "oFix (\<lambda>x. a + x) 0 = a * \<omega>"
 apply (simp add: oFix_def omega_def)
 apply (rule_tac f=oLimit in arg_cong)
 apply (rule ext, induct_tac n, simp)
 apply (simp, rename_tac n)
 apply (induct_tac n, simp)
 apply (simp add: ordinal_plus_assoc[symmetric])
done

lemma oDeriv_plus: "oDeriv (op + a) = (op + (a * \<omega>))"
 apply (rule ext, rule_tac a=x in oLimit_induct)
   apply (simp add: oFix_plus)
  apply (simp add: oFix_eq_self
                   ordinal_plus_assoc[symmetric]
                   ordinal_plus_times_omega)
 apply simp
done

lemma oVeblen_1_plus: "oVeblen (op + 1) x = (op + (\<omega> ** x))"
 apply (rule_tac a=x in wf_induct[OF wf], simp)
 apply (rule_tac a=x in ordinal_cases)
   apply (simp add: normal.oVeblen_0[OF normal_plus])
  apply (simp add: normal.oVeblen_oSuc[OF normal_plus])
  apply (simp add: oDeriv_plus)
 apply clarsimp
 apply (rule normal_range_eq)
   apply (rule normal.normal_oVeblen[OF normal_plus])
  apply (rule normal_plus)
 apply (subst normal.critical_set_fixed[OF normal_plus])
  apply (rule_tac y="f 0" in order_le_less_trans, simp)
  apply (simp add: strict_mono_less_oLimit)
 apply safe
  apply (simp add: image_def)
  apply (rule exI, rule ordinal_plus_minus2[symmetric])
  apply (rule oLimit_leI[rule_format])
  apply (subgoal_tac "\<omega> ** f n + x = x", erule subst, simp)
  apply (drule_tac x="f n" in spec)
  apply (simp add: strict_mono_less_oLimit)
 apply simp
 apply (simp only: ordinal_exp_oLimit[symmetric] zero_less_omega)
 apply (simp only: ordinal_plus_assoc[symmetric])
 apply (simp only: absorb_omega_exp2)
done

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Record Based Version\<close>
theory Finite_Field_Factorization_Record_Based
imports
  Finite_Field_Factorization
  Matrix_Record_Based
  Poly_Mod_Finite_Field_Record_Based
  "HOL-Types_To_Sets.Types_To_Sets"
  Jordan_Normal_Form.Matrix_IArray_Impl
  Jordan_Normal_Form.Gauss_Jordan_IArray_Impl
  Polynomial_Interpolation.Improved_Code_Equations
  Polynomial_Factorization.Missing_List
begin

hide_const(open) monom coeff

text \<open>Whereas @{thm finite_field_factorization} provides a result for a polynomials over GF(p),
  we now develop a theorem which speaks about integer polynomials modulo p.\<close>
lemma (in poly_mod_prime_type) finite_field_factorization_modulo_ring:
  assumes g: "(g :: 'a mod_ring poly) = of_int_poly f"
  and sf: "square_free_m f"
  and fact: "finite_field_factorization g = (d,gs)"
  and c: "c = to_int_mod_ring d"
  and fs: "fs = map to_int_poly gs"
  shows "unique_factorization_m f (c, mset fs)"
proof -
  have [transfer_rule]: "MP_Rel f g" unfolding g MP_Rel_def by (simp add: Mp_f_representative)
  have sg: "square_free g" by (transfer, rule sf)
  have [transfer_rule]: "M_Rel c d" unfolding M_Rel_def c by (rule M_to_int_mod_ring)
  have fs_gs[transfer_rule]: "list_all2 MP_Rel fs gs"
    unfolding fs list_all2_map1 MP_Rel_def[abs_def] Mp_to_int_poly by (simp add: list.rel_refl)
  have [transfer_rule]: "rel_mset MP_Rel (mset fs) (mset gs)"
    using fs_gs using rel_mset_def by blast
  have [transfer_rule]: "MF_Rel (c,mset fs) (d,mset gs)" unfolding MF_Rel_def by transfer_prover
  from finite_field_factorization[OF sg fact]
  have uf: "unique_factorization Irr_Mon g (d,mset gs)" by auto
  from uf[untransferred] show "unique_factorization_m f (c, mset fs)" .
qed

text \<open>We now have to implement @{const finite_field_factorization}.\<close>
context
  fixes p :: int
  and ff_ops :: "'i arith_ops_record"  (* finite-fields *)
begin

fun power_poly_f_mod_i :: "('i list \<Rightarrow> 'i list) \<Rightarrow> 'i list \<Rightarrow> nat \<Rightarrow> 'i list" where
  "power_poly_f_mod_i modulus a n = (if n = 0 then modulus (one_poly_i ff_ops)
    else let (d,r) = Divides.divmod_nat n 2;
       rec = power_poly_f_mod_i modulus (modulus (times_poly_i ff_ops a a)) d in
    if r = 0 then rec else modulus (times_poly_i ff_ops rec a))"

declare power_poly_f_mod_i.simps[simp del]

fun power_polys_i :: "'i list \<Rightarrow> 'i list \<Rightarrow> 'i list \<Rightarrow> nat \<Rightarrow> 'i list list" where
  "power_polys_i mul_p u curr_p (Suc i) = curr_p #
      power_polys_i mul_p u (mod_field_poly_i ff_ops (times_poly_i ff_ops curr_p mul_p) u) i"
| "power_polys_i mul_p u curr_p 0 = []"

lemma length_power_polys_i[simp]: "length (power_polys_i x y z n) = n"
  by (induct n arbitrary: x y z, auto)

definition berlekamp_mat_i :: "'i list \<Rightarrow> 'i mat" where
  "berlekamp_mat_i u = (let n = degree_i u;
    ze = arith_ops_record.zero ff_ops; on = arith_ops_record.one ff_ops;
    mul_p = power_poly_f_mod_i (\<lambda> v. mod_field_poly_i ff_ops v u)
      [ze, on] (nat p);
    xks = power_polys_i mul_p u [on] n
   in mat_of_rows_list n (map (\<lambda> cs. cs @ replicate (n - length cs) ze) xks))"

definition berlekamp_resulting_mat_i :: "'i list \<Rightarrow> 'i mat" where
"berlekamp_resulting_mat_i u = (let Q = berlekamp_mat_i u;
    n = dim_row Q;
    QI = mat n n (\<lambda> (i,j). if i = j then arith_ops_record.minus ff_ops (Q $$ (i,j)) (arith_ops_record.one ff_ops) else Q $$ (i,j))
    in (gauss_jordan_single_i ff_ops (transpose_mat QI)))"

definition berlekamp_basis_i :: "'i list \<Rightarrow> 'i list list" where
  "berlekamp_basis_i u = (map (poly_of_list_i ff_ops o list_of_vec)
    (find_base_vectors_i ff_ops (berlekamp_resulting_mat_i u)))"

primrec berlekamp_factorization_main_i :: "'i \<Rightarrow> 'i \<Rightarrow> nat \<Rightarrow> 'i list list \<Rightarrow> 'i list list \<Rightarrow> nat \<Rightarrow> 'i list list" where
  "berlekamp_factorization_main_i ze on d divs (v # vs) n = (
    if v = [on] then berlekamp_factorization_main_i ze on d divs vs n else
    if length divs = n then divs else
    let of_int = arith_ops_record.of_int ff_ops;
        facts = filter (\<lambda> w. w \<noteq> [on])
          [ gcd_poly_i ff_ops u (minus_poly_i ff_ops v (if s = 0 then [] else [of_int (int s)])) .
            u \<leftarrow> divs, s \<leftarrow> [0 ..< nat p]];
      (lin,nonlin) = List.partition (\<lambda> q. degree_i q = d) facts
      in lin @ berlekamp_factorization_main_i ze on d nonlin vs (n - length lin))"
| "berlekamp_factorization_main_i ze on d divs [] n = divs"

definition berlekamp_monic_factorization_i :: "nat \<Rightarrow> 'i list \<Rightarrow> 'i list list" where
  "berlekamp_monic_factorization_i d f = (let
     vs = berlekamp_basis_i f
    in berlekamp_factorization_main_i (arith_ops_record.zero ff_ops) (arith_ops_record.one ff_ops) d [f] vs (length vs))"

partial_function (tailrec) dist_degree_factorize_main_i ::
  "'i \<Rightarrow> 'i \<Rightarrow> nat \<Rightarrow> 'i list \<Rightarrow> 'i list \<Rightarrow> nat \<Rightarrow> (nat \<times> 'i list) list
  \<Rightarrow> (nat \<times> 'i list) list" where
  [code]: "dist_degree_factorize_main_i ze on dv v w d res = (if v = [on] then res else if d + d > dv
    then (dv, v) # res else let
      w = power_poly_f_mod_i (\<lambda> f. mod_field_poly_i ff_ops f v) w (nat p);
      d = Suc d;
      gd = gcd_poly_i ff_ops (minus_poly_i ff_ops w [ze,on]) v
      in if gd = [on] then dist_degree_factorize_main_i ze on dv v w d res else
      let v' = div_field_poly_i ff_ops v gd
      in dist_degree_factorize_main_i ze on (degree_i v') v' (mod_field_poly_i ff_ops w v') d ((d,gd) # res))"

definition distinct_degree_factorization_i
  :: "'i list \<Rightarrow> (nat \<times> 'i list) list" where
  "distinct_degree_factorization_i f = (let ze = arith_ops_record.zero ff_ops;
     on = arith_ops_record.one ff_ops in if degree_i f = 1 then [(1,f)] else
     dist_degree_factorize_main_i ze on (degree_i f) f [ze,on] 0 [])"

definition finite_field_factorization_i :: "'i list \<Rightarrow> 'i \<times> 'i list list" where
  "finite_field_factorization_i f = (if degree_i f = 0 then (lead_coeff_i ff_ops f,[]) else let
     a = lead_coeff_i ff_ops f;
     u = smult_i ff_ops (arith_ops_record.inverse ff_ops a) f;
     gs = (if use_distinct_degree_factorization then distinct_degree_factorization_i u else [(1,u)]);
     (irr,hs) = List.partition (\<lambda> (i,f). degree_i f = i) gs
     in (a,map snd irr @ concat (map (\<lambda> (i,g). berlekamp_monic_factorization_i i g) hs)))"
end

context prime_field_gen
begin

lemma power_polys_i: assumes i: "i < n" and [transfer_rule]: "poly_rel f f'" "poly_rel g g'"
  and h: "poly_rel h h'"
  shows "poly_rel (power_polys_i ff_ops g f h n ! i) (power_polys g' f' h' n ! i)"
  using i h
proof (induct n arbitrary: h h' i)
  case (Suc n h h' i) note * = this
  note [transfer_rule] = *(3)
  show ?case
  proof (cases i)
    case 0
    with Suc show ?thesis by auto
  next
    case (Suc j)
    with *(2-) have "j < n" by auto
    note IH = *(1)[OF this]
    show ?thesis unfolding Suc by (simp, rule IH, transfer_prover)
  qed
qed simp

lemma power_poly_f_mod_i: assumes m: "(poly_rel ===> poly_rel) m (\<lambda> x'. x' mod m')"
  shows "poly_rel f f' \<Longrightarrow> poly_rel (power_poly_f_mod_i ff_ops m f n) (power_poly_f_mod m' f' n)"
proof -
  from m have m: "\<And> x x'. poly_rel x x' \<Longrightarrow> poly_rel (m x) (x' mod m')"
    unfolding rel_fun_def by auto
  show "poly_rel f f' \<Longrightarrow> poly_rel (power_poly_f_mod_i ff_ops m f n) (power_poly_f_mod m' f' n)"
  proof (induct n arbitrary: f f' rule: less_induct)
    case (less n f f')
    note f[transfer_rule] = less(2)
    show ?case
    proof (cases "n = 0")
      case True
      show ?thesis
        by (simp add: True power_poly_f_mod_i.simps power_poly_f_mod_binary,
          rule m[OF poly_rel_one])
    next
      case False
      hence n: "(n = 0) = False" by simp
      obtain q r where div: "Divides.divmod_nat n 2 = (q,r)" by force
      from this[unfolded divmod_nat_def] n have "q < n" by auto
      note IH = less(1)[OF this]
      have rec: "poly_rel (power_poly_f_mod_i ff_ops m (m (times_poly_i ff_ops f f)) q)
        (power_poly_f_mod m' (f' * f' mod m') q)"
        by (rule IH, rule m, transfer_prover)
      have other: "poly_rel
        (m (times_poly_i ff_ops (power_poly_f_mod_i ff_ops m (m (times_poly_i ff_ops f f)) q) f))
        (power_poly_f_mod m' (f' * f' mod m') q * f' mod m')"
        by (rule m, rule poly_rel_times[unfolded rel_fun_def, rule_format, OF rec f])
      show ?thesis unfolding power_poly_f_mod_i.simps[of _ _ _ n] Let_def
        power_poly_f_mod_binary[of _ _ n] div split n if_False using rec other by auto
    qed
  qed
qed

lemma berlekamp_mat_i[transfer_rule]: "(poly_rel ===> mat_rel R)
  (berlekamp_mat_i p ff_ops) berlekamp_mat"
proof (intro rel_funI)
  fix f f'
  let ?ze = "arith_ops_record.zero ff_ops"
  let ?on = "arith_ops_record.one ff_ops"
  assume f[transfer_rule]: "poly_rel f f'"
  have deg: "degree_i f = degree f'" by transfer_prover
  {
    fix i j
    assume i: "i < degree f'" and j: "j < degree f'"
    define cs where "cs = (\<lambda>cs :: 'i list. cs @ replicate (degree f' - length cs) ?ze)"
    define cs' where "cs' = (\<lambda>cs :: 'a mod_ring poly. coeffs cs @ replicate (degree f' - length (coeffs cs)) 0)"
    define poly where "poly = power_polys_i ff_ops
         (power_poly_f_mod_i ff_ops (\<lambda>v. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p)) f [?on]
         (degree f')"
    define poly' where "poly' = (power_polys (power_poly_f_mod f' [:0, 1:] (nat p)) f' 1 (degree f'))"
    have *: "poly_rel (power_poly_f_mod_i ff_ops (\<lambda>v. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p))
      (power_poly_f_mod f' [:0, 1:] (nat p))"
      by (rule power_poly_f_mod_i, transfer_prover, simp add: poly_rel_def one zero)
    have [transfer_rule]: "poly_rel (poly ! i) (poly' ! i)"
      unfolding poly_def poly'_def
      by (rule power_polys_i[OF i f *], simp add: poly_rel_def one)
    have *: "list_all2 R (cs (poly ! i)) (cs' (poly' ! i))"
      unfolding cs_def cs'_def by transfer_prover
    from list_all2_nthD[OF *[unfolded poly_rel_def], of j] j
    have "R (cs (poly ! i) ! j) (cs' (poly' ! i) ! j)" unfolding cs_def by auto
    hence "R
            (mat_of_rows_list (degree f')
              (map (\<lambda>cs. cs @ replicate (degree f' - length cs) ?ze)
                (power_polys_i ff_ops
                  (power_poly_f_mod_i ff_ops (\<lambda>v. mod_field_poly_i ff_ops v f) [?ze, ?on] (nat p)) f [?on]
                  (degree f'))) $$
             (i, j))
            (mat_of_rows_list (degree f')
              (map (\<lambda>cs. coeffs cs @ replicate (degree f' - length (coeffs cs)) 0)
                (power_polys (power_poly_f_mod f' [:0, 1:] (nat p)) f' 1 (degree f'))) $$
             (i, j))"
        unfolding mat_of_rows_list_def length_map length_power_polys_i power_polys_works
          length_power_polys index_mat[OF i j] split
        unfolding poly_def cs_def poly'_def cs'_def using i
        by auto
  } note main = this
  show "mat_rel R (berlekamp_mat_i p ff_ops f) (berlekamp_mat f')"
    unfolding berlekamp_mat_i_def berlekamp_mat_def Let_def nat_p[symmetric] deg
    unfolding mat_rel_def
    by (intro conjI allI impI, insert main, auto)
qed

lemma berlekamp_resulting_mat_i[transfer_rule]: "(poly_rel ===> mat_rel R)
  (berlekamp_resulting_mat_i p ff_ops) berlekamp_resulting_mat"
proof (intro rel_funI)
  fix f f'
  assume "poly_rel f f'"
  from berlekamp_mat_i[unfolded rel_fun_def, rule_format, OF this]
  have bmi: "mat_rel R (berlekamp_mat_i p ff_ops f) (berlekamp_mat f')" .
  show "mat_rel R (berlekamp_resulting_mat_i p ff_ops f) (berlekamp_resulting_mat f')"
    unfolding berlekamp_resulting_mat_def Let_def berlekamp_resulting_mat_i_def
    by (rule gauss_jordan_i[unfolded rel_fun_def, rule_format],
    insert bmi, auto simp: mat_rel_def one intro!: minus[unfolded rel_fun_def, rule_format])
qed

lemma berlekamp_basis_i[transfer_rule]: "(poly_rel ===> list_all2 poly_rel)
  (berlekamp_basis_i p ff_ops) berlekamp_basis"
  unfolding berlekamp_basis_i_def[abs_def] berlekamp_basis_code[abs_def] o_def
  by transfer_prover

lemma berlekamp_factorization_main_i[transfer_rule]:
  "((=) ===> list_all2 poly_rel ===> list_all2 poly_rel ===> (=) ===> list_all2 poly_rel)
     (berlekamp_factorization_main_i p ff_ops (arith_ops_record.zero ff_ops)
       (arith_ops_record.one ff_ops))
     berlekamp_factorization_main"
proof (intro rel_funI, clarify, goal_cases)
  case (1 _ d xs xs' ys ys' _ n)
  let ?ze = "arith_ops_record.zero ff_ops"
  let ?on = "arith_ops_record.one ff_ops"
  let ?of_int = "arith_ops_record.of_int ff_ops"
  from 1(2) 1(1) show ?case
  proof (induct ys ys' arbitrary: xs xs' n rule: list_all2_induct)
    case (Cons y ys y' ys' xs xs' n)
    note trans[transfer_rule] = Cons(1,2,4)
    obtain clar0 clar1 clar2 where clarify: "\<And> s u. gcd_poly_i ff_ops u
                         (minus_poly_i ff_ops y
                        (if s = 0 then [] else [?of_int (int s)])) = clar0 s u"
        "[0..<nat p] = clar1"
        "[?on] = clar2" by auto
    define facts where "facts = concat (map (\<lambda>u. concat
                        (map (\<lambda>s. if gcd_poly_i ff_ops u
                                      (minus_poly_i ff_ops y (if s = 0 then [] else [?of_int (int s)])) \<noteq>
                                     [?on]
                                  then [gcd_poly_i ff_ops u
                                         (minus_poly_i ff_ops y (if s = 0 then [] else [?of_int (int s)]))]
                                  else [])
                          [0..<nat p])) xs)"
    define Facts where "Facts = [w\<leftarrow>concat
                          (map (\<lambda>u. map (\<lambda>s. gcd_poly_i ff_ops u
                                              (minus_poly_i ff_ops y
                                                (if s = 0 then [] else [?of_int (int s)])))
                                     [0..<nat p])
                            xs) .  w \<noteq> [?on]]"
    have Facts: "Facts = facts"
      unfolding Facts_def facts_def clarify
    proof (induct xs)
      case (Cons x xs)
      show ?case by (simp add: Cons, induct clar1, auto)
    qed simp
    define facts' where "facts' = concat
             (map (\<lambda>u. concat
                        (map (\<lambda>x. if gcd u (y' - [:of_nat x:]) \<noteq> 1
                                  then [gcd u (y' - [:of_int (int x):])] else [])
                          [0..<nat p]))
               xs')"
    have id: "\<And> x. of_int (int x) = of_nat x" "[?on] = one_poly_i ff_ops"
      by (auto simp: one_poly_i_def)
    have facts[transfer_rule]: "list_all2 poly_rel facts facts'"
      unfolding facts_def facts'_def
    apply (rule concat_transfer[unfolded rel_fun_def, rule_format])
    apply (rule list.map_transfer[unfolded rel_fun_def, rule_format, OF _ trans(3)])
    apply (rule concat_transfer[unfolded rel_fun_def, rule_format])
    apply (rule list_all2_map_map)
    proof (unfold id)
      fix f f' x
      assume [transfer_rule]: "poly_rel f f'" and x: "x \<in> set [0..<nat p]"
      hence *: "0 \<le> int x" "int x < p" by auto
      from of_int[OF this] have rel[transfer_rule]: "R (?of_int (int x)) (of_nat x)" by auto
      {
        assume "0 < x"
        with * have *: "0 < int x" "int x < p" by auto
        have "(of_nat x :: 'a mod_ring) = of_int (int x)" by simp
        also have "\<dots> \<noteq> 0" unfolding of_int_of_int_mod_ring using * unfolding p
          by (transfer', auto)
      }
      with rel have [transfer_rule]: "poly_rel (if x = 0 then [] else [?of_int (int x)]) [:of_nat x:]"
        unfolding poly_rel_def by (auto simp add: cCons_def p)
      show "list_all2 poly_rel
          (if gcd_poly_i ff_ops f (minus_poly_i ff_ops y (if x = 0 then [] else [?of_int (int x)])) \<noteq> one_poly_i ff_ops
           then [gcd_poly_i ff_ops f (minus_poly_i ff_ops y (if x = 0 then [] else [?of_int (int x)]))]
           else [])
          (if gcd f' (y' - [:of_nat x:]) \<noteq> 1 then [gcd f' (y' - [:of_nat x:])] else [])"
        by transfer_prover
    qed
    have id1: "berlekamp_factorization_main_i p ff_ops ?ze ?on d xs (y # ys) n = (
      if y = [?on] then berlekamp_factorization_main_i p ff_ops ?ze ?on d xs ys n else
      if length xs = n then xs else
      (let fac = facts;
          (lin, nonlin) = List.partition (\<lambda>q. degree_i q = d) fac
             in lin @ berlekamp_factorization_main_i p ff_ops ?ze ?on d nonlin ys (n - length lin)))"
      unfolding berlekamp_factorization_main_i.simps Facts[symmetric]
      by (simp add: o_def Facts_def Let_def)
    have id2: "berlekamp_factorization_main d xs' (y' # ys') n = (
      if y' = 1 then berlekamp_factorization_main d xs' ys' n
      else if length xs' = n then xs' else
      (let fac = facts';
          (lin, nonlin) = List.partition (\<lambda>q. degree q = d) fac
              in lin @ berlekamp_factorization_main d nonlin ys' (n - length lin)))"
      by (simp add: o_def facts'_def nat_p)
    have len: "length xs = length xs'" by transfer_prover
    have id3: "(y = [?on]) = (y' = 1)"
      by (transfer_prover_start, transfer_step+, simp add: one_poly_i_def finite_field_ops_int_def)
    show ?case
    proof (cases "y' = 1")
      case True
      hence id4: "(y' = 1) = True" by simp
      show ?thesis unfolding id1 id2 id3 id4 if_True
        by (rule Cons(3), transfer_prover)
    next
      case False
      hence id4: "(y' = 1) = False" by simp
      note id1 = id1[unfolded id3 id4 if_False]
      note id2 = id2[unfolded id4 if_False]
      show ?thesis
      proof (cases "length xs' = n")
        case True
        thus ?thesis unfolding id1 id2 Let_def len using trans by simp
      next
        case False
        hence id: "(length xs' = n) = False" by simp
        have id': "length [q\<leftarrow>facts . degree_i q = d] = length [q\<leftarrow>facts'. degree q = d]"
          by transfer_prover
        have [transfer_rule]: "list_all2 poly_rel (berlekamp_factorization_main_i p ff_ops ?ze ?on d [x\<leftarrow>facts . degree_i x \<noteq> d] ys
         (n - length [q\<leftarrow>facts . degree_i q = d]))
         (berlekamp_factorization_main d [x\<leftarrow>facts' . degree x \<noteq> d] ys'
         (n - length [q\<leftarrow>facts' . degree q = d]))"
          unfolding id'
          by (rule Cons(3), transfer_prover)
        show ?thesis unfolding id1 id2 Let_def len id if_False
          unfolding partition_filter_conv o_def split by transfer_prover
      qed
    qed
  qed simp
qed

lemma berlekamp_monic_factorization_i[transfer_rule]:
  "((=) ===> poly_rel ===> list_all2 poly_rel)
     (berlekamp_monic_factorization_i p ff_ops) berlekamp_monic_factorization"
  unfolding berlekamp_monic_factorization_i_def[abs_def] berlekamp_monic_factorization_def[abs_def] Let_def
  by transfer_prover

lemma dist_degree_factorize_main_i:
  "poly_rel F f \<Longrightarrow> poly_rel G g \<Longrightarrow> list_all2 (rel_prod (=) poly_rel) Res res
   \<Longrightarrow> list_all2 (rel_prod (=) poly_rel)
      (dist_degree_factorize_main_i p ff_ops
         (arith_ops_record.zero ff_ops) (arith_ops_record.one ff_ops) (degree_i F) F G d Res)
      (dist_degree_factorize_main f g d res)"
proof (induct f g d res arbitrary: F G Res rule: dist_degree_factorize_main.induct)
  case (1 v w d res V W Res)
  let ?ze = "arith_ops_record.zero ff_ops"
  let ?on = "arith_ops_record.one ff_ops"
  note simp = dist_degree_factorize_main.simps[of v w d]
    dist_degree_factorize_main_i.simps[of p ff_ops ?ze ?on "degree_i V" V W d]
  have v[transfer_rule]: "poly_rel V v" by (rule 1)
  have w[transfer_rule]: "poly_rel W w" by (rule 1)
  have res[transfer_rule]: "list_all2 (rel_prod (=) poly_rel) Res res" by (rule 1)
  have [transfer_rule]: "poly_rel [?on] 1"
    by (simp add: one poly_rel_def)
  have id1: "(V = [?on]) = (v = 1)" unfolding finite_field_ops_int_def by transfer_prover
  have id2: "degree_i V = degree v" by transfer_prover
  note simp = simp[unfolded id1 id2]
  note IH = 1(1,2)
  show ?case
  proof (cases "v = 1")
    case True
    with res show ?thesis unfolding id2 simp by simp
  next
    case False
    with id1 have "(v = 1) = False" by auto
    note simp = simp[unfolded this if_False]
    note IH = IH[OF False]
    show ?thesis
    proof (cases "degree v < d + d")
      case True
      thus ?thesis unfolding id2 simp using res v by auto
    next
      case False
      hence "(degree v < d + d) = False" by auto
      note simp = simp[unfolded this if_False]
      let ?P = "power_poly_f_mod_i ff_ops (\<lambda>f. mod_field_poly_i ff_ops f V) W (nat p)"
      let ?G = "gcd_poly_i ff_ops (minus_poly_i ff_ops ?P [?ze, ?on]) V"
      let ?g = "gcd (w ^ CARD('a) mod v - monom 1 1) v"
      define G where "G = ?G"
      define g where "g = ?g"
      note simp = simp[unfolded Let_def, folded G_def g_def]
      note IH = IH[OF False refl refl refl]
      have [transfer_rule]: "poly_rel [?ze,?on] (monom 1 1)" unfolding poly_rel_def
        by (auto simp: coeffs_monom one zero)
      have id: "w ^ CARD('a) mod v = power_poly_f_mod v w (nat p)"
        unfolding power_poly_f_mod_def by (simp add: p)
      have P[transfer_rule]: "poly_rel ?P (w ^ CARD('a) mod v)" unfolding id
        by (rule power_poly_f_mod_i[OF _ w], transfer_prover)
      have g[transfer_rule]: "poly_rel G g" unfolding G_def g_def by transfer_prover
      have id3: "(G = [?on]) = (g = 1)" by transfer_prover
      note simp = simp[unfolded id3]
      show ?thesis
      proof (cases "g = 1")
        case True
        from IH(1)[OF this[unfolded g_def] v P res] True
        show ?thesis unfolding id2 simp by simp
      next
        case False
        have vg: "poly_rel (div_field_poly_i ff_ops V G) (v div g)" by transfer_prover
        have "poly_rel (mod_field_poly_i ff_ops ?P
          (div_field_poly_i ff_ops V G)) (w ^ CARD('a) mod v mod (v div g))" by transfer_prover
        note IH = IH(2)[OF False[unfolded g_def] refl vg[unfolded G_def g_def] this[unfolded G_def g_def],
            folded g_def G_def]
        have "list_all2 (rel_prod (=) poly_rel) ((Suc d, G) # Res) ((Suc d, g) # res)"
          using g res by auto
        note IH = IH[OF this]
        from False have "(g = 1) = False" by simp
        note simp = simp[unfolded this if_False]
        show ?thesis unfolding id2 simp using IH by simp
      qed
    qed
  qed
qed

lemma distinct_degree_factorization_i[transfer_rule]: "(poly_rel ===> list_all2 (rel_prod (=) poly_rel))
  (distinct_degree_factorization_i p ff_ops) distinct_degree_factorization"
proof
  fix F f
  assume f[transfer_rule]: "poly_rel F f"
  have id: "(degree_i F = 1) = (degree f = 1)" by transfer_prover
  note d = distinct_degree_factorization_i_def distinct_degree_factorization_def
  let ?ze = "arith_ops_record.zero ff_ops"
  let ?on = "arith_ops_record.one ff_ops"
  show "list_all2 (rel_prod (=) poly_rel) (distinct_degree_factorization_i p ff_ops F)
            (distinct_degree_factorization f)"
  proof (cases "degree f = 1")
    case True
    with id f show ?thesis unfolding d by auto
  next
    case False
    from False id have "?thesis = (list_all2 (rel_prod (=) poly_rel)
      (dist_degree_factorize_main_i p ff_ops ?ze ?on (degree_i F) F [?ze, ?on] 0 [])
      (dist_degree_factorize_main f (monom 1 1) 0 []))" unfolding d Let_def by simp
    also have \<dots>
      by (rule dist_degree_factorize_main_i[OF f], auto simp: poly_rel_def
        coeffs_monom one zero)
    finally show ?thesis .
  qed
qed

lemma finite_field_factorization_i[transfer_rule]:
  "(poly_rel ===> rel_prod R (list_all2 poly_rel))
     (finite_field_factorization_i p ff_ops) finite_field_factorization"
  unfolding finite_field_factorization_i_def finite_field_factorization_def Let_def lead_coeff_i_def'
  by transfer_prover

text \<open>Since the implementation is sound, we can now combine it with the soundness result
  of the finite field factorization.\<close>

lemma finite_field_i_sound:
  assumes f': "f' = of_int_poly_i ff_ops (Mp f)"
  and berl_i: "finite_field_factorization_i p ff_ops f' = (c',fs')"
  and sq: "square_free_m f"
  and fs: "fs = map (to_int_poly_i ff_ops) fs'"
  and c: "c = arith_ops_record.to_int ff_ops c'"
  shows "unique_factorization_m f (c, mset fs)
    \<and> c \<in> {0 ..< p}
    \<and> (\<forall> fi \<in> set fs. set (coeffs fi) \<subseteq> {0 ..< p})"
proof -
  define f'' :: "'a mod_ring poly" where "f'' = of_int_poly (Mp f)"
  have rel_f[transfer_rule]: "poly_rel f' f''"
    by (rule poly_rel_of_int_poly[OF f'], simp add: f''_def)
  interpret pff: idom_ops "poly_ops ff_ops" poly_rel
    by (rule idom_ops_poly)
  obtain c'' fs'' where berl: "finite_field_factorization f'' = (c'',fs'')" by force
  from rel_funD[OF finite_field_factorization_i rel_f, unfolded rel_prod_conv assms(2) split berl]
  have rel[transfer_rule]: "R c' c''" "list_all2 poly_rel fs' fs''" by auto
  from to_int[OF rel(1)] have cc': "c = to_int_mod_ring c''" unfolding c by simp
  have c: "c \<in> {0 ..< p}" unfolding cc'
    by (metis Divides.pos_mod_bound Divides.pos_mod_sign M_to_int_mod_ring atLeastLessThan_iff
      gr_implies_not_zero nat_le_0 nat_p not_le poly_mod.M_def zero_less_card_finite)
  {
    fix f
    assume "f \<in> set fs'"
    with rel(2) obtain f' where "poly_rel f f'"  unfolding list_all2_conv_all_nth set_conv_nth
      by auto
    hence "is_poly ff_ops f" using fun_cong[OF Domainp_is_poly, of f]
      unfolding Domainp_iff[abs_def] by auto
  }
  hence fs': "Ball (set fs') (is_poly ff_ops)" by auto
  define mon :: "'a mod_ring poly \<Rightarrow> bool" where "mon = monic"
  have [transfer_rule]: "(poly_rel ===> (=)) (monic_i ff_ops) mon" unfolding mon_def
    by (rule poly_rel_monic)
  have len: "length fs' = length fs''" by transfer_prover
  have fs': "fs = map to_int_poly fs''" unfolding fs
  proof (rule nth_map_conv[OF len], intro allI impI)
    fix i
    assume i: "i < length fs'"
    obtain f g where id: "fs' ! i = f" "fs'' ! i = g" by auto
    from i rel(2)[unfolded list_all2_conv_all_nth[of _ fs' fs'']] id
    have "poly_rel f g" by auto
    from to_int_poly_i[OF this] have "to_int_poly_i ff_ops f = to_int_poly g" .
    thus "to_int_poly_i ff_ops (fs' ! i) = to_int_poly (fs'' ! i)" unfolding id .
  qed
  have f: "f'' = of_int_poly f" unfolding poly_eq_iff f''_def
    by (simp add: to_int_mod_ring_hom.injectivity to_int_mod_ring_of_int_M Mp_coeff)
  have *: "unique_factorization_m f (c, mset fs)"
    using finite_field_factorization_modulo_ring[OF f sq berl cc' fs'] by auto
  have fs': "(\<forall>fi\<in>set fs. set (coeffs fi) \<subseteq> {0..<p})" unfolding fs'
    using range_to_int_mod_ring[where 'a = 'a]
    by (auto simp: coeffs_to_int_poly p)
  with c fs *
  show ?thesis by blast
qed
end

definition finite_field_factorization_main :: "int \<Rightarrow> 'i arith_ops_record \<Rightarrow> int poly \<Rightarrow> int \<times> int poly list" where
  "finite_field_factorization_main p f_ops f \<equiv>
    let (c',fs') = finite_field_factorization_i p f_ops (of_int_poly_i f_ops (poly_mod.Mp p f))
      in (arith_ops_record.to_int f_ops c', map (to_int_poly_i f_ops) fs')"

lemma(in prime_field_gen) finite_field_factorization_main:
  assumes res: "finite_field_factorization_main p ff_ops f = (c,fs)"
  and sq: "square_free_m f"
  shows "unique_factorization_m f (c, mset fs)
    \<and> c \<in> {0 ..< p}
    \<and> (\<forall> fi \<in> set fs. set (coeffs fi) \<subseteq> {0 ..< p})"
proof -
  obtain c' fs' where
    res': "finite_field_factorization_i p ff_ops (of_int_poly_i ff_ops (Mp f)) = (c', fs')"  by force
  show ?thesis
    by (rule finite_field_i_sound[OF refl res' sq],
      insert res[unfolded finite_field_factorization_main_def res'], auto)
qed

definition finite_field_factorization_int :: "int \<Rightarrow> int poly \<Rightarrow> int \<times> int poly list" where
  "finite_field_factorization_int p = (
    if p \<le> 65535
    then finite_field_factorization_main p (finite_field_ops32 (uint32_of_int p))
    else if p \<le> 4294967295
    then finite_field_factorization_main p (finite_field_ops64 (uint64_of_int p))
    else finite_field_factorization_main p (finite_field_ops_integer (integer_of_int p)))"

context poly_mod_prime begin
lemmas finite_field_factorization_main_integer = prime_field_gen.finite_field_factorization_main
  [OF prime_field.prime_field_finite_field_ops_integer, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas finite_field_factorization_main_uint32 = prime_field_gen.finite_field_factorization_main
  [OF prime_field.prime_field_finite_field_ops32, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas finite_field_factorization_main_uint64 = prime_field_gen.finite_field_factorization_main
  [OF prime_field.prime_field_finite_field_ops64, unfolded prime_field_def mod_ring_locale_def,
  unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma finite_field_factorization_int:
  assumes sq: "poly_mod.square_free_m p f"
  and result: "finite_field_factorization_int p f = (c,fs)"
  shows "poly_mod.unique_factorization_m p f (c, mset fs)
    \<and> c \<in> {0 ..< p}
    \<and> (\<forall> fi \<in> set fs. set (coeffs fi) \<subseteq> {0 ..< p})"
  using finite_field_factorization_main_integer[OF  _ sq, of c fs]
    finite_field_factorization_main_uint32[OF _ _ sq, of c fs]
    finite_field_factorization_main_uint64[OF _ _ sq, of c fs]
    result[unfolded finite_field_factorization_int_def]
  by (auto split: if_splits)

end

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory WordAbstract
imports
  L2Defs
  ExecConcrete
  Lib.NatBitwise
begin

definition "WORD_MAX x \<equiv> ((2 ^ (len_of x - 1) - 1) :: int)"
definition "WORD_MIN x \<equiv> (- (2 ^ (len_of x - 1)) :: int)"
definition "UWORD_MAX x \<equiv> ((2 ^ (len_of x)) - 1 :: nat)"

lemma WORD_values [simplified]:
  "WORD_MAX (TYPE( 8 signed)) = (2 ^  7 - 1)"
  "WORD_MAX (TYPE(16 signed)) = (2 ^ 15 - 1)"
  "WORD_MAX (TYPE(32 signed)) = (2 ^ 31 - 1)"
  "WORD_MAX (TYPE(64 signed)) = (2 ^ 63 - 1)"

  "WORD_MIN (TYPE( 8 signed)) = - (2 ^  7)"
  "WORD_MIN (TYPE(16 signed)) = - (2 ^ 15)"
  "WORD_MIN (TYPE(32 signed)) = - (2 ^ 31)"
  "WORD_MIN (TYPE(64 signed)) = - (2 ^ 63)"

  "UWORD_MAX (TYPE( 8)) = (2 ^  8 - 1)"
  "UWORD_MAX (TYPE(16)) = (2 ^ 16 - 1)"
  "UWORD_MAX (TYPE(32)) = (2 ^ 32 - 1)"
  "UWORD_MAX (TYPE(64)) = (2 ^ 64 - 1)"
  by (auto simp: WORD_MAX_def WORD_MIN_def UWORD_MAX_def)

lemmas WORD_values_add1 =
   WORD_values [THEN arg_cong [where f="\<lambda>x. x + 1"],
    simplified semiring_norm, simplified numeral_One]

lemmas WORD_values_minus1 =
   WORD_values [THEN arg_cong [where f="\<lambda>x. x - 1"],
    simplified semiring_norm, simplified numeral_One nat_numeral]

lemmas [L1unfold] =
  WORD_values [symmetric]
  WORD_values_add1 [symmetric]
  WORD_values_minus1 [symmetric]

lemma WORD_signed_to_unsigned [simp]:
   "WORD_MAX TYPE('a signed) = WORD_MAX TYPE('a::len)"
   "WORD_MIN TYPE('a signed) = WORD_MIN TYPE('a::len)"
   "UWORD_MAX TYPE('a signed) = UWORD_MAX TYPE('a::len)"
  by (auto simp: WORD_MAX_def WORD_MIN_def UWORD_MAX_def)

(*
 * The following set of theorems allow us to discharge simple
 * equalities involving INT_MIN, INT_MAX and UINT_MAX without
 * the constants being unfolded in the final output.
 *
 * For example:
 *
 *    (4 < INT_MAX)  becomes  True
 *    (x < INT_MAX)  remains  (x < INT_MAX)
 *)

lemma INT_MIN_comparisons [simp]:
  "\<lbrakk> a \<le> - (2 ^ (len_of TYPE('a) - 1)) \<rbrakk> \<Longrightarrow> a \<le> WORD_MIN (TYPE('a::len))"
  "a < - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a < WORD_MIN (TYPE('a::len))"
  "a \<ge> - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a \<ge> WORD_MIN (TYPE('a::len))"
  "a > - (2 ^ (len_of TYPE('a) - 1)) \<Longrightarrow> a \<ge> WORD_MIN (TYPE('a::len))"
  by (auto simp: WORD_MIN_def)

lemma INT_MAX_comparisons [simp]:
  "a \<le> (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<le> WORD_MAX (TYPE('a::len))"
  "a < (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a < WORD_MAX (TYPE('a::len))"
  "a \<ge> (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<ge> WORD_MAX (TYPE('a::len))"
  "a > (2 ^ (len_of TYPE('a) - 1)) - 1 \<Longrightarrow> a \<ge> WORD_MAX (TYPE('a::len))"
  by (auto simp: WORD_MAX_def)

lemma UINT_MAX_comparisons [simp]:
  "x \<le> (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<le> UWORD_MAX (TYPE('a::len))"
  "x < (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<le> UWORD_MAX (TYPE('a::len))"
  "x \<ge> (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x \<ge> UWORD_MAX (TYPE('a::len))"
  "x > (2 ^ (len_of TYPE('a))) - 1 \<Longrightarrow> x > UWORD_MAX (TYPE('a::len))"
  by (auto simp: UWORD_MAX_def)

(*
 * This definition is used when we are trying to introduce a new type
 * in the program text: it simply states that introducing a given
 * abstraction is desired in the current context.
 *)
definition "introduce_typ_abs_fn f \<equiv> True"

declare introduce_typ_abs_fn_def [simp]

lemma introduce_typ_abs_fn:
  "introduce_typ_abs_fn f"
  by simp

(*
 * Show that a binary operator "X" (of type "'a \<Rightarrow> 'a \<Rightarrow> bool") is an
 * abstraction (over function f) of "X'".
 *
 * For example, (a \<le>\<^sub>i\<^sub>n\<^sub>t b) could be an abstraction of (a \<le>\<^sub>w\<^sub>3\<^sub>2 b)
 * over the abstraction function "unat".
 *)
definition
  abstract_bool_binop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a)
               \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> bool"
where
  "abstract_bool_binop P f X X' \<equiv> \<forall>a b. P (f a) (f b) \<longrightarrow> (X' a b = X (f a) (f b))"

(* Show that a binary operator "X" (of type "'a \<Rightarrow> 'a \<Rightarrow> 'b") abstracts "X'". *)
definition
  abstract_binop :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'a)
               \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> bool"
where
   "abstract_binop P f X X' \<equiv> \<forall>a b. P (f a) (f b) \<longrightarrow> (f (X' a b) = X (f a) (f b))"

(* The value "a" is the abstract version of "b" under precondition "P". *)
definition "abstract_val P a f b \<equiv> P \<longrightarrow> (a = f b)"

(* The variable "a" is the abstracted version of the variable "b". *)
definition "abs_var a f b \<equiv> abstract_val True a f b"

declare abstract_bool_binop_def [simp]
declare abstract_binop_def [simp]
declare abstract_val_def [simp]
declare abs_var_def [simp]

lemma abstract_val_trivial:
  "abstract_val True (f b) f b"
  by simp

lemma abstract_binop_is_abstract_val:
    "abstract_binop P f X X' = (\<forall>a b. abstract_val (P (f a) (f b)) (X (f a) (f b)) f (X' a b))"
  by auto

lemma abstract_expr_bool_binop:
  "\<lbrakk> abstract_bool_binop E f X X';
     introduce_typ_abs_fn f;
     abstract_val P a f a';
     abstract_val Q b f b' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q \<and> E a b) (X a b) id (X' a' b')"
  by clarsimp

lemma abstract_expr_binop:
  "\<lbrakk> abstract_binop E f X X';
     abstract_val P a f a';
     abstract_val Q b f b' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q \<and> E a b) (X a b) f (X' a' b')"
  by clarsimp

lemma unat_abstract_bool_binops:
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (<) (<)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (\<le>) (\<le>)"
    "abstract_bool_binop (\<lambda>_ _. True) (unat :: ('a::len) word \<Rightarrow> nat) (=) (=)"
  by (auto simp:  word_less_nat_alt word_le_nat_alt eq_iff)

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [unfolded word_bits_len_of]]

lemma le_to_less_plus_one:
    "((a::nat) \<le> b) = (a < b + 1)"
  by arith

lemma unat_abstract_binops:
  "abstract_binop (\<lambda>a b. a + b \<le> UWORD_MAX TYPE('a::len)) (unat :: 'a word \<Rightarrow> nat) (+) (+)"
  "abstract_binop (\<lambda>a b. a * b \<le> UWORD_MAX TYPE('a)) (unat :: 'a word \<Rightarrow> nat) (*) (*)"
  "abstract_binop (\<lambda>a b. a \<ge> b) (unat :: 'a word \<Rightarrow> nat) (-) (-)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (div) (div)"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a word \<Rightarrow> nat) (mod) (mod)"
  by (auto simp: unat_plus_if' unat_div unat_mod UWORD_MAX_def le_to_less_plus_one
              WordAbstract.unat_mult_simple word_bits_def unat_sub word_le_nat_alt)

lemma unat_of_int:
  "\<lbrakk>i \<ge> 0; i < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> unat (of_int i :: 'a::len word) = nat i"
  unfolding unat_def
  apply (subst eq_nat_nat_iff, clarsimp+)
  apply (simp add: word_of_int uint_word_of_int)
  done

(* FIXME generalises Word_Lemmas_32.unat_of_int_32 *)
lemma unat_of_int_signed:
  "\<lbrakk>i \<ge> 0; i < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> unat (of_int i :: 'a::len signed word) = nat i"
  by (simp add: unat_of_int)

lemma nat_sint:
  "0 <=s (x :: 'a::len signed word) \<Longrightarrow> nat (sint x) = unat x"
  apply (subst unat_of_int_signed[where 'a='a, symmetric])
    apply (simp add: word_sle_def)
   apply (rule less_trans[OF sint_lt])
   apply simp
  apply simp
  done

lemma int_unat_nonneg:
  "0 <=s (x :: 'a::len signed word) \<Longrightarrow> int (unat x) = sint x"
  by (simp add: int_unat word_sle_msb_le sint_eq_uint)

lemma unat_bitwise_abstract_binops:
  "abstract_binop (\<lambda>a b. True) (unat :: 'a::len word \<Rightarrow> nat) bitAND bitAND"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a::len word \<Rightarrow> nat) bitOR bitOR"
  "abstract_binop (\<lambda>a b. True) (unat :: 'a::len word \<Rightarrow> nat) bitXOR bitXOR"
  apply (simp add: bitAND_nat_def bitAND_word_def uint_nat unat_of_int
           flip: word_of_int)
  apply (simp add: bitOR_nat_def bitOR_word_def uint_nat unat_of_int OR_upper
           flip: word_of_int)
  apply (simp add: bitXOR_nat_def bitXOR_word_def uint_nat unat_of_int XOR_upper
           flip: word_of_int)
  done

lemma unat_max_word:
  "unat (max_word :: 'a::len word) = 2^LENGTH('a) - 1"
  by (simp add: max_word_eq unat_minus_one_word)

lemma abstract_val_unsigned_bitNOT:
  "abstract_val P x unat (x' :: 'a::len word) \<Longrightarrow>
   abstract_val P (UWORD_MAX TYPE('a) - x) unat (bitNOT x')"
  apply (clarsimp simp: UWORD_MAX_def NOT_eq)
  apply (rule subst[where t="-x' - 1" and s="-(x' + 1)"])
   apply simp
  apply (case_tac "x' + 1 = 0")
   apply (simp only:)
   apply (drule max_word_wrap)
   apply (simp add: unat_max_word)
  apply (subst unat_minus')
   apply assumption
  apply (simp add: unatSuc2)
  done

lemma snat_abstract_bool_binops:
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: ('a::len) signed word \<Rightarrow> int) (<) (word_sless)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (\<le>) (word_sle)"
    "abstract_bool_binop (\<lambda>_ _. True) (sint :: 'a signed word \<Rightarrow> int) (=) (=)"
  by (auto simp: word_sless_def word_sle_def less_le)

lemma snat_abstract_binops:
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a::len) \<le> a + b \<and> a + b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (+) (+)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a * b \<and> a * b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (*) (*)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a - b \<and> a - b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (-) (-)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a sdiv b \<and> a sdiv b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (sdiv) (sdiv)"
  "abstract_binop (\<lambda>a b. WORD_MIN TYPE('a) \<le> a smod b \<and> a smod b \<le> WORD_MAX TYPE('a)) (sint :: 'a signed word \<Rightarrow> int) (smod) (smod)"
  by (auto simp: signed_arith_sint word_size WORD_MIN_def WORD_MAX_def)

lemma sint_bitwise_abstract_binops:
  "abstract_binop (\<lambda>a b. True) (sint :: 'a::len signed word \<Rightarrow> int) bitAND bitAND"
  "abstract_binop (\<lambda>a b. True) (sint :: 'a::len signed word \<Rightarrow> int) bitOR bitOR"
  "abstract_binop (\<lambda>a b. True) (sint :: 'a::len signed word \<Rightarrow> int) bitXOR bitXOR"
  apply (fastforce intro: int_eq_test_bitI
                   simp: nth_sint bin_nth_ops test_bit_def'[symmetric]
                         test_bit_wi[where 'a="'a signed", simplified word_of_int[symmetric]])+
  done

lemma abstract_val_signed_bitNOT:
  "abstract_val P x sint (x' :: 'a::len signed word) \<Longrightarrow>
   abstract_val P (bitNOT x) sint (bitNOT x')"
  apply (fastforce intro: int_eq_test_bitI
                   simp: nth_sint bin_nth_ops word_nth_neq test_bit_def'[symmetric]
                         test_bit_wi[where 'a="'a signed", simplified word_of_int[symmetric]])
  done

lemma abstract_val_signed_unary_minus:
  "\<lbrakk> abstract_val P r sint r' \<rbrakk> \<Longrightarrow>
       abstract_val (P \<and> (- r) \<le> WORD_MAX TYPE('a)) (- r) sint ( - (r' :: ('a :: len) signed word))"
  apply clarsimp
  using sint_range_size [where w=r']
  apply -
  apply (subst signed_arith_sint)
   apply (clarsimp simp: word_size WORD_MAX_def)
  apply simp
  done

lemma bang_big_nonneg:
  "\<lbrakk> 0 <=s (x::'a::len signed word); n \<ge> size x - 1 \<rbrakk> \<Longrightarrow> (x !! n) = False"
  apply (case_tac "n = size x - 1")
   apply (simp add: word_size msb_nth[where 'a="'a signed", symmetric, simplified] word_sle_msb_le)
  apply (simp add: test_bit_bl)
  apply arith
  done

lemma sint_shiftr_nonneg:
  "\<lbrakk> 0 <=s (x :: 'a::len signed word); 0 \<le> n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> sint (x >> n) = sint x >> n"
  apply (rule int_eq_test_bitI)
  apply (clarsimp simp: bang_big_nonneg[simplified word_size] nth_sint nth_shiftr field_simps)
  done

lemma abstract_val_unsigned_unary_minus:
  "\<lbrakk> abstract_val P r unat r' \<rbrakk> \<Longrightarrow>
       abstract_val P (if r = 0 then 0 else UWORD_MAX TYPE('a::len) + 1 - r) unat ( - (r' :: 'a word))"
  by (clarsimp simp: unat_minus' word_size unat_eq_zero UWORD_MAX_def)

(* Rules for shifts *)
lemma abstract_val_signed_shiftr_signed:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> 0 \<le> n \<and> n < LENGTH('a))
                (x >> nat n) sint (x' >> unat n')"
  apply (clarsimp simp only: abstract_val_def)
  apply (subst nat_sint, simp add: word_sle_def)
  apply (subst sint_shiftr_nonneg)
     apply (simp add: word_sle_def)
    apply simp
   apply (subst SMT.nat_int_comparison(2))
   apply (subst int_unat_nonneg)
    apply (simp add: word_sle_def)
   apply assumption
  apply (rule refl)
  done

lemma abstract_val_signed_shiftr_unsigned:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n unat (n' :: ('b :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> n < LENGTH('a))
                (x >> n) sint (x' >> unat n')"
  apply (clarsimp simp: shiftr_int_def)
  apply (subst sint_shiftr_nonneg)
     apply (simp add: word_sle_def)
    apply simp
   apply assumption
  apply (clarsimp simp: shiftr_int_def)
  done

lemma sint_shiftl_nonneg:
  "\<lbrakk> 0 <=s (x :: 'a::len signed word); n < LENGTH('a); sint x << n < 2^(LENGTH('a) - 1) \<rbrakk> \<Longrightarrow>
   sint (x << n) = sint x << n"
  apply (rule int_eq_test_bitI)
  apply (clarsimp simp: bang_big_nonneg[simplified word_size] nth_sint nth_shiftl
                        int_shiftl_less_cancel int_2p_eq_shiftl word_sle_def)
  (* FIXME: cleanup *)
  apply (intro impI iffI conjI; (solves simp)?)
    apply (drule(1) int_shiftl_lt_2p_bits[rotated])
    apply (clarsimp simp: nth_sint)
    apply (drule_tac x="LENGTH('a) - 1 - n" in spec)
    apply (subgoal_tac "LENGTH('a) - 1 - n < LENGTH('a) - 1")
     apply simp
    apply arith
   apply (drule(1) int_shiftl_lt_2p_bits[rotated])
   apply (clarsimp simp: nth_sint)
   apply (drule_tac x="i - n" in spec)
   apply simp
  apply (case_tac "n = 0")
   apply (simp add: word_sle_msb_le[where x=0, simplified word_sle_def, simplified] msb_nth)
  apply (drule(1) int_shiftl_lt_2p_bits[rotated])
  apply (clarsimp simp: nth_sint)
  apply (drule_tac x="LENGTH('a) - 1 - n" in spec)
  apply (subgoal_tac "LENGTH('a) - 1 - n < LENGTH('a) - 1")
   apply simp
  apply simp
  done

lemma abstract_val_signed_shiftl_signed:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> 0 \<le> n \<and> n < LENGTH('a) \<and> x << nat n < 2^(LENGTH('a) - 1))
                (x << nat n) sint (x' << unat n')"
  apply clarsimp
  apply (subst sint_shiftl_nonneg)
     apply (simp add: word_sle_def)
    apply (subst nat_sint[symmetric], simp add: word_sle_def)
    apply (simp add: nat_less_eq_zless[where z="LENGTH('a)", simplified])
   apply (simp add: nat_sint word_sle_def)
  apply (simp add: nat_sint word_sle_def)
  done

lemma abstract_val_signed_shiftl_unsigned:
  "\<lbrakk> abstract_val Px x sint (x' :: ('a :: len) signed word);
     abstract_val Pn n unat (n' :: ('b :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> x \<and> n < LENGTH('a) \<and> x << n < 2^(LENGTH('a) - 1))
                (x << n) sint (x' << unat n')"
  by (clarsimp simp: sint_shiftl_nonneg word_sle_def
                     nat_less_eq_zless[where z="LENGTH('a)", simplified])

lemma abstract_val_unsigned_shiftr_unsigned:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n unat (n' :: ('a :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn) (x >> n) unat (x' >> unat n')"
  apply (simp add: shiftr_div_2n' shiftr_nat_def shiftr_int_def)
  apply (simp flip: zdiv_int[where b="2^n" for n, simplified])
  done

lemma abstract_val_unsigned_shiftr_signed:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> n) (x >> nat n) unat (x' >> unat n')"
  apply (clarsimp simp: shiftr_div_2n' shiftr_nat_def shiftr_int_def)
  apply (simp flip: zdiv_int[where b="2^n" for n, simplified])
  apply (subst sint_eq_uint)
   apply (simp add: word_msb_sint)
  apply (simp add: unat_def)
  done

lemma abstract_val_unsigned_shiftl_unsigned:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n unat (n' :: ('b :: len) word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> n < LENGTH('a) \<and> x << n < 2^LENGTH('a))
                (x << n) unat (x' << unat n')"
  by (clarsimp simp: shiftl_t2n shiftl_nat_alt_def unat_mult_simple field_simps)

lemma abstract_val_unsigned_shiftl_signed:
  "\<lbrakk> abstract_val Px x unat (x' :: ('a :: len) word);
     abstract_val Pn n sint (n' :: ('b :: len) signed word) \<rbrakk> \<Longrightarrow>
   abstract_val (Px \<and> Pn \<and> 0 \<le> n \<and> n < int (LENGTH('a)) \<and> x << nat n < 2^LENGTH('a))
                (x << nat n) unat (x' << unat n')"
  apply (clarsimp simp: shiftl_t2n shiftl_nat_alt_def unat_mult_simple field_simps)
  apply (simp add: sint_eq_uint word_msb_sint)
  apply (simp flip: unat_def)
  apply (simp add: uint_nat unat_mult_simple)
  done

(* TODO: this would be useful for simplifying signed left shift c_guards,
   which are already implied by the generated word abs guard (premise #2).

   However, the c_guard is translated before the new word abs guards,
   thus L2Opt (which only propagates guards forwards) is unable to
   make use of this rule at present. *)
lemma signed_shiftl_c_guard_simp (* [L2flow] *):
  "\<lbrakk> int bound < 2^LENGTH('a); a * 2^b < int bound; 0 \<le> a \<rbrakk> \<Longrightarrow>
   unat (of_int a :: 'a::len word) * 2 ^ b < bound"
  apply (subst unat_of_int)
    apply assumption
   apply (drule(1) less_trans)
   apply (subgoal_tac "a * 2^b < 2^LENGTH('a) * 2^b")
    apply simp
   apply (erule less_le_trans)
   apply simp
  apply (subgoal_tac "nat (a * 2^b) < nat (int bound)")
   apply (simp add: nat_power_eq nat_mult_distrib)
  apply (subst nat_mono_iff)
   apply (rule le_less_trans, assumption)
   apply (erule le_less_trans[rotated])
   apply (simp add: mult_left_mono[where a="1::int", simplified])
  apply simp
  done

lemmas abstract_val_signed_ops [simplified simp_thms] =
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(1)]
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(2)]
  abstract_expr_bool_binop [OF snat_abstract_bool_binops(3)]
  abstract_expr_binop [OF snat_abstract_binops(1)]
  abstract_expr_binop [OF snat_abstract_binops(2)]
  abstract_expr_binop [OF snat_abstract_binops(3)]
  abstract_expr_binop [OF snat_abstract_binops(4)]
  abstract_expr_binop [OF snat_abstract_binops(5)]
  abstract_expr_binop [OF sint_bitwise_abstract_binops(1)]
  abstract_expr_binop [OF sint_bitwise_abstract_binops(2)]
  abstract_expr_binop [OF sint_bitwise_abstract_binops(3)]
  abstract_val_signed_bitNOT
  abstract_val_signed_unary_minus
  abstract_val_signed_shiftr_signed
  abstract_val_signed_shiftr_unsigned
  abstract_val_signed_shiftl_signed
  abstract_val_signed_shiftl_unsigned

lemmas abstract_val_unsigned_ops [simplified simp_thms] =
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(1)]
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(2)]
  abstract_expr_bool_binop [OF unat_abstract_bool_binops(3)]
  abstract_expr_binop [OF unat_abstract_binops(1)]
  abstract_expr_binop [OF unat_abstract_binops(2)]
  abstract_expr_binop [OF unat_abstract_binops(3)]
  abstract_expr_binop [OF unat_abstract_binops(4)]
  abstract_expr_binop [OF unat_abstract_binops(5)]
  abstract_expr_binop [OF unat_bitwise_abstract_binops(1)]
  abstract_expr_binop [OF unat_bitwise_abstract_binops(2)]
  abstract_expr_binop [OF unat_bitwise_abstract_binops(3)]
  abstract_val_unsigned_bitNOT
  abstract_val_unsigned_unary_minus
  abstract_val_unsigned_shiftr_signed
  abstract_val_unsigned_shiftr_unsigned
  abstract_val_unsigned_shiftl_signed
  abstract_val_unsigned_shiftl_unsigned

lemma mod_less:
  "(a :: nat) < c \<Longrightarrow> a mod b < c"
  by (metis less_trans mod_less_eq_dividend order_leE)

lemma abstract_val_ucast:
    "\<lbrakk> introduce_typ_abs_fn (unat :: ('a::len) word \<Rightarrow> nat);
       abstract_val P v unat v' \<rbrakk>
       \<Longrightarrow>  abstract_val (P \<and> v \<le> nat (WORD_MAX TYPE('a)))
                  (int v) sint (ucast (v' :: 'a word) :: 'a signed word)"
  apply (clarsimp simp: uint_nat [symmetric])
  apply (subst sint_eq_uint)
   apply (rule not_msb_from_less)
   apply (clarsimp simp: word_less_nat_alt unat_ucast WORD_MAX_def le_to_less_plus_one)
   apply (subst (asm) nat_diff_distrib)
     apply simp
    apply clarsimp
   apply clarsimp
   apply (metis of_nat_numeral nat_numeral nat_power_eq of_nat_0_le_iff)
  apply (clarsimp simp: uint_up_ucast is_up)
  done

(* Base rule for heap-lifted signed words. See the function mk_sword_heap_get_rule. *)
lemma abstract_val_heap_sword_template:
  "\<lbrakk> introduce_typ_abs_fn (sint :: ('a::len) signed word \<Rightarrow> int);
     abstract_val P p' id p \<rbrakk>
   \<Longrightarrow> abstract_val P (sint (ucast (heap_get s p' :: 'a word) :: 'a signed word))
                      sint (ucast (heap_get s p) :: 'a signed word)"
  by simp

lemma abstract_val_scast:
    "\<lbrakk> introduce_typ_abs_fn (sint :: ('a::len) signed word \<Rightarrow> int);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val (P \<and> 0 \<le> C') (nat C') unat (scast (C :: ('a::len) signed word) :: ('a::len) word)"
  apply (clarsimp simp: down_cast_same [symmetric] is_down unat_ucast)
  apply (subst sint_eq_uint)
   apply (clarsimp simp: word_msb_sint)
  apply (clarsimp simp: unat_def [symmetric])
  apply (subst word_unat.norm_Rep [symmetric])
  apply clarsimp
  done

lemma abstract_val_scast_upcast:
    "\<lbrakk> len_of TYPE('a::len) \<le> len_of TYPE('b::len);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C') sint (scast (C :: 'a signed word) :: 'b signed word)"
  by (clarsimp simp: down_cast_same [symmetric] sint_up_scast is_up)

lemma abstract_val_scast_downcast:
    "\<lbrakk> len_of TYPE('b) < len_of TYPE('a::len);
       abstract_val P C' sint C \<rbrakk>
            \<Longrightarrow>  abstract_val P (sbintrunc ((len_of TYPE('b::len) - 1)) C') sint (scast (C :: 'a signed word) :: 'b signed word)"
  apply (clarsimp simp: scast_def word_of_int_def sint_uint bintrunc_mod2p [symmetric])
  apply (subst bintrunc_sbintrunc_le)
   apply clarsimp
  apply (subst Abs_word_inverse)
   apply (metis len_signed uint word_ubin.eq_norm)
  apply clarsimp
  done

lemma abstract_val_ucast_upcast:
    "\<lbrakk> len_of TYPE('a::len) \<le> len_of TYPE('b::len);
       abstract_val P C' unat C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C') unat (ucast (C :: 'a word) :: 'b word)"
  by (clarsimp simp: is_up unat_ucast_upcast)

lemma abstract_val_ucast_downcast:
    "\<lbrakk> len_of TYPE('b::len) < len_of TYPE('a::len);
       abstract_val P C' unat C \<rbrakk>
            \<Longrightarrow>  abstract_val P (C' mod (UWORD_MAX TYPE('b) + 1)) unat (ucast (C :: 'a word) :: 'b word)"
  apply (clarsimp simp: scast_def word_of_int_def sint_uint UWORD_MAX_def)
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (metis (hide_lams, mono_tags) uint_mod uint_power_lower
      unat_def unat_mod unat_power_lower)
  done

(*
 * The pair A/C are a valid abstraction/concrete-isation function pair,
 * under the precondition's P and Q.
 *)
definition
 "valid_typ_abs_fn (P :: 'a \<Rightarrow> bool) (Q :: 'a \<Rightarrow> bool) (A :: 'c \<Rightarrow> 'a) (C :: 'a \<Rightarrow> 'c) \<equiv>
     (\<forall>v. P v \<longrightarrow> A (C v) = v) \<and> (\<forall>v. Q (A v) \<longrightarrow> C (A v) = v)"

declare valid_typ_abs_fn_def [simp]

lemma valid_typ_abs_fn_id:
  "valid_typ_abs_fn \<top> \<top> id id"
  by clarsimp

lemma valid_typ_abs_fn_unit:
  "valid_typ_abs_fn \<top> \<top> id (id :: unit \<Rightarrow> unit)"
  by clarsimp

lemma valid_typ_abs_fn_unat:
  "valid_typ_abs_fn (\<lambda>v. v \<le> UWORD_MAX TYPE('a::len)) \<top> (unat :: 'a word \<Rightarrow> nat) (of_nat :: nat \<Rightarrow> 'a word)"
  by (clarsimp simp: unat_of_nat_eq UWORD_MAX_def le_to_less_plus_one)

lemma valid_typ_abs_fn_sint:
  "valid_typ_abs_fn (\<lambda>v. WORD_MIN TYPE('a::len) \<le> v \<and> v \<le> WORD_MAX TYPE('a)) \<top> (sint :: 'a signed word \<Rightarrow> int) (of_int :: int \<Rightarrow> 'a signed word)"
  by (clarsimp simp: sint_of_int_eq WORD_MIN_def WORD_MAX_def)

lemma valid_typ_abs_fn_tuple:
  "\<lbrakk> valid_typ_abs_fn P_a Q_a abs_a conc_a; valid_typ_abs_fn P_b Q_b abs_b conc_b \<rbrakk> \<Longrightarrow>
          valid_typ_abs_fn (\<lambda>(a, b). P_a a \<and> P_b b) (\<lambda>(a, b). Q_a a \<and> Q_b b) (map_prod abs_a abs_b) (map_prod conc_a conc_b)"
  by clarsimp

lemma introduce_typ_abs_fn_tuple:
  "\<lbrakk> introduce_typ_abs_fn abs_a; introduce_typ_abs_fn abs_b \<rbrakk> \<Longrightarrow>
         introduce_typ_abs_fn (map_prod abs_a abs_b)"
  by clarsimp

definition [simp]:
  "corresTA P rx ex A C \<equiv> corresXF (\<lambda>s. s) (\<lambda>r s. rx r) (\<lambda>r s. ex r) P A C"

lemma corresTA_L2_gets:
  "\<lbrakk> \<And>s. abstract_val (Q s) (C s) rx (C' s) \<rbrakk> \<Longrightarrow>
     corresTA Q rx ex (L2_gets (\<lambda>s. C s) n) (L2_gets (\<lambda>s. C' s) n)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_modify:
    "\<lbrakk> \<And>s. abstract_val (P s) (m s) id (m' s) \<rbrakk> \<Longrightarrow>
            corresTA P rx ex (L2_modify (\<lambda>s. m s)) (L2_modify (\<lambda>s. m' s))"
  by (monad_eq simp: L2_modify_def corresXF_def)

lemma corresTA_L2_throw:
  "\<lbrakk> abstract_val Q C ex C' \<rbrakk> \<Longrightarrow>
     corresTA (\<lambda>_. Q) rx ex (L2_throw C n) (L2_throw C' n)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_skip:
  "corresTA \<top> rx ex L2_skip L2_skip"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_fail:
  "corresTA \<top> rx ex L2_fail L2_fail"
  by (clarsimp simp: L2_defs corresXF_def)

lemma corresTA_L2_seq':
  fixes L' :: "('s, 'e + 'c1) nondet_monad"
  fixes R' :: "'c1 \<Rightarrow> ('s, 'e + 'c2) nondet_monad"
  fixes L :: "('s, 'ea + 'a1) nondet_monad"
  fixes R :: "'a1 \<Rightarrow> ('s, 'ea + 'a2) nondet_monad"
  shows
  "\<lbrakk> corresTA P rx1 ex L L';
     \<And>r. corresTA (Q (rx1 r)) rx2 ex (R (rx1 r)) (R' r) \<rbrakk> \<Longrightarrow>
    corresTA P rx2 ex
       (L2_seq L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r)))
       (L2_seq L' (\<lambda>r. R' r))"
  apply atomize
  apply (clarsimp simp: L2_seq_def L2_guard_def)
  apply (erule corresXF_join [where P'="\<lambda>x y s. rx1 y = x"])
    apply (monad_eq simp: corresXF_def split: sum.splits)
   apply clarsimp
   apply (rule hoareE_TrueI)
  apply simp
  done

lemma corresTA_L2_seq:
  "\<lbrakk> introduce_typ_abs_fn rx1;
    corresTA P (rx1 :: 'a \<Rightarrow> 'b) ex L L';
     \<And>r r'. abs_var r rx1 r' \<Longrightarrow> corresTA (\<lambda>s. Q r s) rx2 ex (\<lambda>s. R r s) (\<lambda>s. R' r' s) \<rbrakk> \<Longrightarrow>
       corresTA P rx2 ex (L2_seq L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_ s. R r s))) (L2_seq L' (\<lambda>r s. R' r s))"
  by (rule corresTA_L2_seq', simp+)

lemma corresTA_L2_seq_unit:
  fixes L' :: "('s, 'e + unit) nondet_monad"
  fixes R' :: "unit \<Rightarrow> ('s, 'e + 'r) nondet_monad"
  fixes L :: "('s, 'ea + unit) nondet_monad"
  fixes R :: "('s, 'ea + 'ra) nondet_monad"
  shows
  "\<lbrakk> corresTA P id ex L L';
     corresTA Q rx ex (\<lambda>s. R s) (\<lambda>s. R' () s) \<rbrakk> \<Longrightarrow>
    corresTA P rx ex
       (L2_seq L (\<lambda>r. L2_seq (L2_guard Q) (\<lambda>r s. R s)))
       (L2_seq L' (\<lambda>r s. R' r s))"
  by (rule corresTA_L2_seq', simp+)

lemma corresTA_L2_catch':
  fixes L' :: "('s, 'e1 + 'c) nondet_monad"
  fixes R' :: "'e1 \<Rightarrow> ('s, 'e2 + 'c) nondet_monad"
  fixes L :: "('s, 'e1a + 'ca) nondet_monad"
  fixes R :: "'e1a \<Rightarrow> ('s, 'e2a + 'ca) nondet_monad"
  shows
  "\<lbrakk> corresTA P rx ex1 L L';
     \<And>r. corresTA (Q (ex1 r)) rx ex2 (R (ex1 r)) (R' r) \<rbrakk> \<Longrightarrow>
    corresTA P rx ex2 (L2_catch L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r))) (L2_catch L' (\<lambda>r. R' r))"
  apply atomize
  apply (clarsimp simp: L2_seq_def L2_catch_def L2_guard_def)
  apply (erule corresXF_except [where P'="\<lambda>x y s. ex1 y = x"])
    apply (monad_eq simp: corresXF_def split: sum.splits cong: rev_conj_cong)
   apply clarsimp
   apply (rule hoareE_TrueI)
  apply simp
  done

lemma corresTA_L2_catch:
  "\<lbrakk> introduce_typ_abs_fn ex1;
     corresTA P rx ex1 L L';
     \<And>r r'. abs_var r ex1 r' \<Longrightarrow> corresTA (Q r) rx ex2 (R r) (R' r') \<rbrakk> \<Longrightarrow>
       corresTA P rx ex2 (L2_catch L (\<lambda>r. L2_seq (L2_guard (\<lambda>s. Q r s)) (\<lambda>_. R r))) (L2_catch L' (\<lambda>r. R' r))"
  by (rule corresTA_L2_catch', simp+)

lemma corresTA_L2_while:
  assumes init_corres: "abstract_val Q i rx i'"
  and cond_corres: "\<And>r r' s. abs_var r rx r'
                           \<Longrightarrow> abstract_val (G r s) (C r s) id (C' r' s)"
  and body_corres: "\<And>r r'. abs_var r rx r'
                           \<Longrightarrow> corresTA (P r) rx ex (B r) (B' r')"
  shows "corresTA (\<lambda>_. Q) rx ex
       (L2_guarded_while (\<lambda>r s. G r s) (\<lambda>r s. C r s) (\<lambda>r. L2_seq (L2_guard (\<lambda>s. P r s)) (\<lambda>_. B r)) i x)
       (L2_while (\<lambda>r s. C' r s) B' i' x)"
proof -
  note body_corres' =
       corresXF_guarded_while_body [OF body_corres [unfolded corresTA_def]]

  have init_corres':
    "Q \<Longrightarrow> i = rx i'"
    using init_corres
    by simp

  show ?thesis
    apply (clarsimp simp: L2_defs guardE_def [symmetric] returnOk_liftE [symmetric])
    apply (rule corresXF_assume_pre)
    apply (rule corresXF_guarded_while [where P="\<lambda>r s. G (rx r) s"])
        apply (cut_tac r'=x in body_corres, simp)
        apply (monad_eq simp: guardE_def corresXF_def split: sum.splits)
       apply (insert cond_corres)[1]
       apply clarsimp
      apply clarsimp
      apply (rule hoareE_TrueI)
     apply (clarsimp simp: init_corres)
     apply (insert init_corres)[1]
     apply (clarsimp)
    apply (clarsimp simp: init_corres')
  done
qed

lemma corresTA_L2_guard:
  "\<lbrakk> \<And>s. abstract_val (Q s) (G s) id (G' s) \<rbrakk>
           \<Longrightarrow> corresTA \<top> rx ex (L2_guard (\<lambda>s. G s \<and> Q s)) (L2_guard (\<lambda>s. G' s))"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_spec:
  "(\<And>s t. abstract_val (Q s) (P s t) id (P' s t)) \<Longrightarrow>
   corresTA Q rx ex (L2_spec {(s, t). P s t}) (L2_spec {(s, t). P' s t})"
  apply (monad_eq simp: L2_defs corresXF_def in_liftE split: sum.splits)
  apply (erule exI)
  done

lemma corresTA_L2_condition:
  "\<lbrakk> corresTA P rx ex L L';
     corresTA Q rx ex R R';
     \<And>s. abstract_val (T s) (C s) id (C' s)  \<rbrakk>
   \<Longrightarrow> corresTA T rx ex
          (L2_condition (\<lambda>s. C s)
            (L2_seq (L2_guard P) (\<lambda>_. L))
            (L2_seq (L2_guard Q) (\<lambda>_. R))
           ) (L2_condition (\<lambda>s. C' s) L' R')"
  apply atomize
  apply (monad_eq simp: L2_defs corresXF_def Ball_def split: sum.splits)
  apply force
  done

(* Backup rule to corresTA_L2_call. Converts the return type of the function call. *)
lemma corresTA_L2_call':
  "\<lbrakk> corresTA P f1 x1 A B;
     valid_typ_abs_fn Q1 Q1' f1 f1';
     valid_typ_abs_fn Q2 Q2' f2 f2'
   \<rbrakk> \<Longrightarrow>
   corresTA (\<lambda>s. P s) f2 x2
       (L2_seq (L2_call A) (\<lambda>ret. (L2_seq (L2_guard (\<lambda>_. Q1' ret)) (\<lambda>_. L2_gets (\<lambda>_. f2 (f1' ret)) [''ret'']))))
       (L2_call B)"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply (rule conjI)
   apply metis
  apply clarsimp
  apply blast
  done

lemma corresTA_L2_call:
  "\<lbrakk> corresTA P rx ex A B \<rbrakk> \<Longrightarrow>
        corresTA P rx ex' (L2_call A) (L2_call B)"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

lemma corresTA_measure_call:
  "\<lbrakk> monad_mono B; \<And>m. corresTA P rx id (A m) (B m) \<rbrakk> \<Longrightarrow>
        corresTA P rx id (measure_call A) (measure_call B)"
  by (simp add: corresXF_measure_call)

lemma corresTA_L2_unknown:
  "corresTA \<top> rx ex (L2_unknown x) (L2_unknown x)"
  apply (monad_eq simp: L2_defs corresXF_def)
  done

lemma corresTA_L2_call_exec_concrete:
  "\<lbrakk> corresTA P rx id A B \<rbrakk> \<Longrightarrow>
        corresTA (\<lambda>s. \<forall>s'. s = st s' \<longrightarrow> P s') rx id
               (exec_concrete st (L2_call A))
               (exec_concrete st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

lemma corresTA_L2_call_exec_abstract:
  "\<lbrakk> corresTA P rx id A B \<rbrakk> \<Longrightarrow>
        corresTA (\<lambda>s. P (st s)) rx id
               (exec_abstract st (L2_call A))
               (exec_abstract st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply fastforce
  done

(* More backup rules for calls. *)
lemma corresTA_L2_call_exec_concrete':
  "\<lbrakk> corresTA P f1 x1 A B;
     valid_typ_abs_fn Q1 Q1' f1 f1';
     valid_typ_abs_fn Q2 Q2' f2 f2'
   \<rbrakk> \<Longrightarrow>
   corresTA (\<lambda>s. \<forall>s'. s = st s' \<longrightarrow> P s') f2 x2
       (L2_seq (exec_concrete st (L2_call A)) (\<lambda>ret. (L2_seq (L2_guard (\<lambda>_. Q1' ret)) (\<lambda>_. L2_gets (\<lambda>_. f2 (f1' ret)) [''ret'']))))
       (exec_concrete st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply (rule conjI)
   apply clarsimp
   apply metis
  apply clarsimp
  apply blast
  done

lemma corresTA_L2_call_exec_abstract':
  "\<lbrakk> corresTA P f1 x1 A B;
     valid_typ_abs_fn Q1 Q1' f1 f1';
     valid_typ_abs_fn Q2 Q2' f2 f2'
   \<rbrakk> \<Longrightarrow>
   corresTA (\<lambda>s. P (st s)) f2 x2
       (L2_seq (exec_abstract st (L2_call A)) (\<lambda>ret. (L2_seq (L2_guard (\<lambda>_. Q1' ret)) (\<lambda>_. L2_gets (\<lambda>_. f2 (f1' ret)) [''ret'']))))
       (exec_abstract st (L2_call B))"
  apply (clarsimp simp: L2_defs L2_call_def corresXF_def)
  apply (monad_eq split: sum.splits)
  apply (rule conjI)
   apply metis
  apply clarsimp
  apply blast
  done

lemma abstract_val_fun_app:
   "\<lbrakk> abstract_val Q b id b'; abstract_val P a id a' \<rbrakk> \<Longrightarrow>
           abstract_val (P \<and> Q) (f $ (a $ b)) f (a' $ b')"
  by simp

lemma corresTA_precond_to_guard:
  "corresTA (\<lambda>s. P s) rx ex A A' \<Longrightarrow> corresTA \<top> rx ex (L2_seq (L2_guard (\<lambda>s. P s)) (\<lambda>_. A)) A'"
  apply (monad_eq simp: corresXF_def L2_defs split: sum.splits)
  done

lemma corresTA_precond_to_asm:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> corresTA \<top> rx ex A A' \<rbrakk> \<Longrightarrow> corresTA P rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma L2_guard_true: "L2_seq (L2_guard \<top>) A = A ()"
  by (monad_eq simp: L2_defs)
lemma corresTA_simp_trivial_guard:
  "corresTA P rx ex (L2_seq (L2_guard \<top>) A) C \<equiv> corresTA P rx ex (A ()) C"
  by (simp add: L2_guard_true)

definition "L2_assume P \<equiv> condition P (returnOk ()) (selectE {})"

lemma L2_assume_alt_def:
  "L2_assume P = (\<lambda>s. (if P s then {(Inr (), s)} else {}, False))"
  by (monad_eq simp: L2_assume_def selectE_def)

lemma corresTA_assume_values:
  "\<lbrakk> abstract_val P a f a'; corresTA \<top> rx ex X X' \<rbrakk>
              \<Longrightarrow> corresTA \<top> rx ex (L2_seq (L2_assume (\<lambda>s. P \<longrightarrow> (\<exists>a'. a = f a'))) (\<lambda>_. X)) X'"
  apply (monad_eq simp: corresXF_def L2_defs L2_assume_alt_def split: sum.splits)
  apply force
  done

lemma corresTA_extract_preconds_of_call_init:
  "\<lbrakk> corresTA (\<lambda>s. P) rx ex A A' \<rbrakk> \<Longrightarrow> corresTA (\<lambda>s. P \<and> True) rx ex A A'"
  by simp

lemma corresTA_extract_preconds_of_call_step:
  "\<lbrakk> corresTA (\<lambda>s. (abs_var a f a' \<and> R) \<and> C) rx ex A A'; abstract_val Y a f a' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. R \<and> (Y \<and> C)) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_extract_preconds_of_call_final:
  "\<lbrakk> corresTA (\<lambda>s. (abs_var a f a') \<and> C) rx ex A A'; abstract_val Y a f a' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. (Y \<and> C)) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_extract_preconds_of_call_final':
  "\<lbrakk> corresTA (\<lambda>s. True \<and> C) rx ex A A' \<rbrakk>
           \<Longrightarrow> corresTA (\<lambda>s. C) rx ex A A'"
  by (clarsimp simp: corresXF_def)

lemma corresTA_case_prod:
 "\<lbrakk> introduce_typ_abs_fn rx1;
    introduce_typ_abs_fn rx2;
    abstract_val (Q x) x (map_prod rx1 rx2) x';
      \<And>a b a' b'. \<lbrakk> abs_var a rx1 a'; abs_var  b rx2 b' \<rbrakk>
                      \<Longrightarrow>  corresTA (P a b) rx ex (M a b) (M' a' b') \<rbrakk>  \<Longrightarrow>
    corresTA (\<lambda>s. case x of (a, b) \<Rightarrow> P a b s \<and> Q (a, b)) rx ex (case x of (a, b) \<Rightarrow> M a b) (case x' of (a, b) \<Rightarrow> M' a b)"
  apply clarsimp
  apply (rule corresXF_assume_pre)
  apply (clarsimp simp: split_def map_prod_def)
  done

lemma abstract_val_case_prod:
  "\<lbrakk> abstract_val True r (map_prod f g) r';
       \<And>a b a' b'. \<lbrakk>  abs_var a f a'; abs_var  b g b' \<rbrakk>
                     \<Longrightarrow> abstract_val (P a b) (M a b) h (M' a' b') \<rbrakk>
       \<Longrightarrow> abstract_val (P (fst r) (snd r))
            (case r of (a, b) \<Rightarrow> M a b) h
            (case r' of (a, b) \<Rightarrow> M' a b)"
  apply (case_tac r, case_tac r')
  apply (clarsimp simp: map_prod_def)
  done

lemma abstract_val_case_prod_fun_app:
  "\<lbrakk> abstract_val True r (map_prod f g) r';
       \<And>a b a' b'. \<lbrakk>  abs_var a f a'; abs_var b g b' \<rbrakk>
                     \<Longrightarrow> abstract_val (P a b) (M a b s) h (M' a' b' s) \<rbrakk>
       \<Longrightarrow> abstract_val (P (fst r) (snd r))
            ((case r of (a, b) \<Rightarrow> M a b) s) h
            ((case r' of (a, b) \<Rightarrow> M' a b) s)"
  apply (case_tac r, case_tac r')
  apply (clarsimp simp: map_prod_def)
  done

lemma abstract_val_of_nat:
  "abstract_val (r \<le> UWORD_MAX TYPE('a::len)) r unat (of_nat r :: 'a word)"
  by (clarsimp simp: unat_of_nat_eq UWORD_MAX_def le_to_less_plus_one)

lemma abstract_val_of_int:
  "abstract_val (WORD_MIN TYPE('a::len) \<le> r \<and> r \<le> WORD_MAX TYPE('a)) r sint (of_int r :: 'a signed word)"
  by (clarsimp simp: sint_of_int_eq WORD_MIN_def WORD_MAX_def)

lemma abstract_val_tuple:
  "\<lbrakk> abstract_val P a absL a';
     abstract_val Q b absR b' \<rbrakk> \<Longrightarrow>
         abstract_val (P \<and> Q) (a, b) (map_prod absL absR) (a', b')"
  by clarsimp

lemma abstract_val_func:
   "\<lbrakk> abstract_val P a id a'; abstract_val Q b id b' \<rbrakk>
        \<Longrightarrow>  abstract_val (P \<and> Q) (f a b) id (f a' b')"
  by simp

lemma abstract_val_conj:
  "\<lbrakk> abstract_val P a id a';
        abstract_val Q b id b' \<rbrakk> \<Longrightarrow>
     abstract_val (P \<and> (a \<longrightarrow> Q)) (a \<and> b) id (a' \<and> b')"
  apply clarsimp
  apply blast
  done

lemma abstract_val_disj:
  "\<lbrakk> abstract_val P a id a';
        abstract_val Q b id b' \<rbrakk> \<Longrightarrow>
     abstract_val (P \<and> (\<not> a \<longrightarrow> Q)) (a \<or> b) id (a' \<or> b')"
  apply clarsimp
  apply blast
  done

lemma abstract_val_unwrap:
  "\<lbrakk> introduce_typ_abs_fn f; abstract_val P a f b \<rbrakk>
        \<Longrightarrow> abstract_val P a id (f b)"
  by simp

lemma abstract_val_uint:
  "\<lbrakk> introduce_typ_abs_fn unat; abstract_val P x unat x' \<rbrakk>
      \<Longrightarrow> abstract_val P (int x) id (uint x')"
  by (clarsimp simp: uint_nat)

lemma corresTA_L2_recguard:
  "corresTA (\<lambda>s. P s) rx ex A A' \<Longrightarrow>
        corresTA \<top> rx ex (L2_recguard m (L2_seq (L2_guard (\<lambda>s. P s)) (\<lambda>_. A))) (L2_recguard m A')"
  by (monad_eq simp: corresXF_def L2_defs split: sum.splits)

lemma corresTA_recguard_0:
    "corresTA st rx ex (L2_recguard 0 A) C"
  by (clarsimp simp: L2_recguard_def corresXF_def)

lemma abstract_val_lambda:
   "\<lbrakk> \<And>v. abstract_val (P v) (a v) id (a' v) \<rbrakk> \<Longrightarrow>
           abstract_val (\<forall>v. P v) (\<lambda>v. a v) id (\<lambda>v. a' v)"
  by auto

(* Rules for translating simpl wrappers. *)
lemma corresTA_call_L1:
  "abstract_val True arg_xf id arg_xf' \<Longrightarrow>
   corresTA \<top> id id
     (L2_call_L1 arg_xf gs ret_xf l1body)
     (L2_call_L1 arg_xf' gs ret_xf l1body)"
  apply (unfold corresTA_def abstract_val_def id_def)
  apply (subst (asm) simp_thms)
  apply (erule subst)
  apply (rule corresXF_id[simplified id_def])
  done

lemma abstract_val_call_L1_args:
  "abstract_val P x id x' \<Longrightarrow> abstract_val P y id y' \<Longrightarrow>
   abstract_val P (x and y) id (x' and y')"
  by simp

lemma abstract_val_call_L1_arg:
  "abs_var x id x' \<Longrightarrow> abstract_val P (\<lambda>s. f s = x) id (\<lambda>s. f s = x')"
  by simp

(* Variable abstraction *)

lemma abstract_val_abs_var [consumes 1]:
  "\<lbrakk> abs_var a f a' \<rbrakk> \<Longrightarrow> abstract_val True a f a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

lemma abstract_val_abs_var_concretise [consumes 1]:
  "\<lbrakk> abs_var a A a'; introduce_typ_abs_fn A; valid_typ_abs_fn PA PC A (C :: 'a \<Rightarrow> 'c)  \<rbrakk>
      \<Longrightarrow> abstract_val (PC a) (C a) id a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

lemma abstract_val_abs_var_give_up [consumes 1]:
  "\<lbrakk> abs_var a id a' \<rbrakk> \<Longrightarrow> abstract_val True (A a) A a'"
  by (clarsimp simp: fun_upd_def split: if_splits)

(* Misc *)

lemma len_of_word_comparisons [L2opt]:
  "len_of TYPE(64) \<le> len_of TYPE(64)"
  "len_of TYPE(32) \<le> len_of TYPE(64)"
  "len_of TYPE(16) \<le> len_of TYPE(64)"
  "len_of TYPE( 8) \<le> len_of TYPE(64)"
  "len_of TYPE(32) \<le> len_of TYPE(32)"
  "len_of TYPE(16) \<le> len_of TYPE(32)"
  "len_of TYPE( 8) \<le> len_of TYPE(32)"
  "len_of TYPE(16) \<le> len_of TYPE(16)"
  "len_of TYPE( 8) \<le> len_of TYPE(16)"
  "len_of TYPE( 8) \<le> len_of TYPE( 8)"

  "len_of TYPE(32) < len_of TYPE(64)"
  "len_of TYPE(16) < len_of TYPE(64)"
  "len_of TYPE( 8) < len_of TYPE(64)"
  "len_of TYPE(16) < len_of TYPE(32)"
  "len_of TYPE( 8) < len_of TYPE(32)"
  "len_of TYPE( 8) < len_of TYPE(16)"

  "len_of TYPE('a::len signed) = len_of TYPE('a)"
  "(len_of TYPE('a) = len_of TYPE('a)) = True"
  by auto

lemma scast_ucast_simps [simp, L2opt]:
  "\<lbrakk> len_of TYPE('b) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('b) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
            (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('a); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b); len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  "\<lbrakk> len_of TYPE('c) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
        (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
     (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
  "\<lbrakk> len_of TYPE('a) \<le> len_of TYPE('b) \<rbrakk> \<Longrightarrow>
            (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
  by (auto simp: is_up is_down
      scast_ucast_1 scast_ucast_3 scast_ucast_4
      ucast_scast_1 ucast_scast_3 ucast_scast_4
      scast_scast_a scast_scast_b
      ucast_ucast_a ucast_ucast_b)

declare len_signed [L2opt]

lemmas [L2opt] = zero_sle_ucast_up

lemma zero_sle_ucast_WORD_MAX [L2opt]:
  "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
                = (uint b \<le> WORD_MAX (TYPE('a)))"
  by (clarsimp simp: WORD_MAX_def zero_sle_ucast)

lemmas [L2opt] =
    is_up is_down unat_ucast_upcast sint_ucast_eq_uint

lemmas [L2opt] =
    ucast_down_add scast_down_add
    ucast_down_minus scast_down_minus
    ucast_down_mult scast_down_mult

(*
 * Setup word abstraction rules.
 *)

named_theorems word_abs

(* Common word abstraction rules. *)

lemmas [word_abs] =
  corresTA_L2_gets
  corresTA_L2_modify
  corresTA_L2_throw
  corresTA_L2_skip
  corresTA_L2_fail
  corresTA_L2_seq
  corresTA_L2_seq_unit
  corresTA_L2_catch
  corresTA_L2_while
  corresTA_L2_guard
  corresTA_L2_spec
  corresTA_L2_condition
  corresTA_L2_unknown
  corresTA_L2_recguard
  corresTA_case_prod
  corresTA_L2_call_exec_concrete'
  corresTA_L2_call_exec_concrete
  corresTA_L2_call_exec_abstract'
  corresTA_L2_call_exec_abstract
  corresTA_L2_call'
  corresTA_L2_call
  corresTA_measure_call
  corresTA_call_L1

lemmas [word_abs] =
  abstract_val_tuple
  abstract_val_conj
  abstract_val_disj
  abstract_val_case_prod
  abstract_val_trivial
  abstract_val_of_int
  abstract_val_of_nat

  abstract_val_call_L1_arg
  abstract_val_call_L1_args

  abstract_val_abs_var_give_up
  abstract_val_abs_var_concretise
  abstract_val_abs_var

lemmas word_abs_base [word_abs] =
  valid_typ_abs_fn_id [where 'a="'a::c_type"]
  valid_typ_abs_fn_id [where 'a="bool"]
  valid_typ_abs_fn_id [where 'a="c_exntype"]
  valid_typ_abs_fn_tuple
  valid_typ_abs_fn_unit
  valid_typ_abs_fn_sint
  valid_typ_abs_fn_unat
  len_of_word_comparisons

(*
 * Signed word abstraction rules: 'a sword \<rightarrow> int
 *)

lemmas word_abs_sword =
  abstract_val_signed_ops
  abstract_val_scast
  abstract_val_scast_upcast
  abstract_val_scast_downcast
  abstract_val_unwrap [where f=sint]
  introduce_typ_abs_fn [where f="sint :: (sword64 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword32 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword16 \<Rightarrow> int)"]
  introduce_typ_abs_fn [where f="sint :: (sword8 \<Rightarrow> int)"]

(*
 * Unsigned word abstraction rules: 'a word \<rightarrow> nat
 *)

lemmas word_abs_word =
  abstract_val_unsigned_ops
  abstract_val_uint
  abstract_val_ucast
  abstract_val_ucast_upcast
  abstract_val_ucast_downcast
  abstract_val_unwrap [where f=unat]
  introduce_typ_abs_fn [where f="unat :: (word64 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word32 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word16 \<Rightarrow> nat)"]
  introduce_typ_abs_fn [where f="unat :: (word8 \<Rightarrow> nat)"]

(* 'a \<rightarrow> 'a *)
lemmas word_abs_default =
  introduce_typ_abs_fn [where f="id :: ('a::c_type \<Rightarrow> 'a)"]
  introduce_typ_abs_fn [where f="id :: (bool \<Rightarrow> bool)"]
  introduce_typ_abs_fn [where f="id :: (c_exntype \<Rightarrow> c_exntype)"]
  introduce_typ_abs_fn [where f="id :: (unit \<Rightarrow> unit)"]
  introduce_typ_abs_fn_tuple

end


(*
    $Id: ex.thy,v 1.2 2004/11/23 15:14:34 webertj Exp $
*)

(*<*) theory ex1_1 imports Main begin (*>*)

text {*
Define a primitive recursive function @{text snoc} that appends an element
at the \emph{right} end of a list. Do not use @{text"@"} itself.
*}

fun  snoc :: "'a list => 'a => 'a list" where
"snoc Nil x = Cons x Nil"
|"snoc (Cons a b) c = Cons a (snoc b c)"

text {*
Prove the following theorem:
*}

theorem rev_cons: "rev (x # xs) = snoc (rev xs) x"
  apply (induct xs)
  apply auto
done

text {*
Hint: you need to prove a suitable lemma first.
*}

(*<*) end (*>*)