theory Zp_poly_test
imports "~~/src/HOL/Algebra/UnivPoly" padic_sequences cring_poly
begin

context padic_integers
begin

lemma(in cring) plus_pairs:
  assumes "a1 \<in> carrier R"
  assumes "a2 \<in> carrier R"
  assumes "a3 \<in> carrier R"
  assumes "b1 \<in> carrier R"
  assumes "b2 \<in> carrier R"
  assumes "b3 \<in> carrier R"
  shows "(a1 \<oplus> a2 \<oplus> a3) \<oplus> (b1 \<oplus> b2 \<oplus> b3) = (a1 \<oplus> b1) \<oplus> (a2 \<oplus> b2) \<oplus> (a3 \<oplus> b3)"
  by (simp add: add.m_assoc add.m_lcomm assms(1) assms(2) assms(3) assms(4) assms(5) assms(6))

lemma(in cring) minus_pairs:
  assumes "a1 \<in> carrier R"
  assumes "a2 \<in> carrier R"
  assumes "a3 \<in> carrier R"
  assumes "b1 \<in> carrier R"
  assumes "b2 \<in> carrier R"
  assumes "b3 \<in> carrier R"
  shows "(a1 \<oplus> a2 \<oplus> a3) \<ominus> (b1 \<oplus> b2 \<oplus> b3) = (a1 \<ominus> b1) \<oplus> (a2 \<ominus> b2) \<oplus> (a3 \<ominus> b3)"
proof-
  have " \<ominus> (b1 \<oplus> b2 \<oplus> b3) = \<ominus>b1 \<oplus>(\<ominus>b2) \<oplus>(\<ominus>b3)"
    using assms inv_add minus_eq
    by auto
  then show ?thesis
  unfolding a_minus_def
  using plus_pairs[of a1 a2 a3 "\<ominus>b1" "\<ominus>b2" "\<ominus>b3"]
        a_inv_closed[of "b1"]
        a_inv_closed[of "b2"]
        a_inv_closed[of "b3"]
        assms
  by auto
qed

lemma(in cring) minus_pairs_cancel_1:
  assumes "a1 \<in> carrier R"
  assumes "a2 \<in> carrier R"
  assumes "a3 \<in> carrier R"
  assumes "b2 \<in> carrier R"
  assumes "b3 \<in> carrier R"
  shows "(a1 \<oplus> a2 \<oplus> a3) \<ominus> (a1 \<oplus> b2 \<oplus> b3) = (a2 \<ominus> b2) \<oplus> (a3 \<ominus> b3)"
  using assms  minus_pairs[of a1 a2 a3 a1 b2 b3]
  by simp

lemma(in cring) minus_pair_factor:
  assumes "a1 \<in> carrier R"
  assumes "b1 \<in> carrier R"
  assumes "c \<in> carrier R"
  assumes "d \<in> carrier R"
  shows "(c \<otimes> a1 \<ominus> c \<otimes> b1) = c \<otimes>(a1 \<ominus> b1)"
proof-
  have "(c \<otimes> a1 \<oplus> c \<otimes> (\<ominus>b1)) = c \<otimes>(a1 \<ominus> b1)"
    using assms
    by (simp add: minus_eq r_distr)
  then show ?thesis
    by (simp add: assms cring.cring_simprules(29) is_cring minus_eq)
qed

lemma(in cring) minus_pairs_factor:
  assumes "a1 \<in> carrier R"
  assumes "a2 \<in> carrier R"
  assumes "b1 \<in> carrier R"
  assumes "b2 \<in> carrier R"
  assumes "c \<in> carrier R"
  assumes "d \<in> carrier R"
  shows "(c \<otimes> a1 \<ominus> c \<otimes> b1) \<oplus> (d \<otimes> a2 \<ominus> c \<otimes> b2) = c \<otimes>(a1 \<ominus> b1)\<oplus> (d \<otimes> a2 \<ominus> c \<otimes> b2)"
  using minus_pair_factor assms(1) assms(3) assms(5)
  by auto

lemma(in cring) minus_pairs_cancel_2:
  assumes "a1 \<in> carrier R"
  assumes "a2 \<in> carrier R"
  assumes "a \<in> carrier R"
  shows "(a1 \<ominus> a \<ominus> (a2 \<ominus> a)) =a1 \<ominus>a2"
  by (smt a_minus_def abelian_group.a_inv_closed abelian_group.minus_closed
      abelian_group.right_inv_add assms(1) assms(2) assms(3) cring.cring_simprules(17)
      is_abelian_group is_cring local.ring_axioms ring.ring_simprules(15) ring.ring_simprules(22))

(*
\<oplus> (d \<otimes> a2 \<ominus> d \<otimes> a)  \<oplus> d \<otimes>(a2 \<ominus> b2)
*)
type_synonym padic_int_poly = "nat \<Rightarrow> padic_int"

lemma monom_term_car:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "x \<in> carrier Z\<^sub>p"
  shows "c \<otimes> x[^](n::nat) \<in> carrier Z\<^sub>p"
  using assms Zp_is_cring monoid.nat_pow_closed
  by (simp add: monoid.nat_pow_closed cring.cring_simprules(5) cring_def ring_def)

(*Univariate polynomial ring over Z\<^sub>p*)

abbreviation P_Zp where
"P_Zp \<equiv> UP Z\<^sub>p"

lemma P_Zp_is_UP_ring[simp]:
"UP_ring Z\<^sub>p"
  by (metis UP_ring.intro Zp_is_cring cring_def)

lemma P_Zp_is_UP_cring[simp]:
"UP_cring Z\<^sub>p"
  by (simp add: UP_cring_def)

lemma P_Zp_is_UP_domain[simp]:
"UP_domain Z\<^sub>p"
  by (simp add: UP_domain_def Zp_is_domain)

lemma P_Zp_ring[simp]:
"ring P_Zp "
  by (simp add: UP_ring.UP_ring)

lemma P_Zp_cring[simp]:
"cring P_Zp "
  by (simp add: UP_cring.UP_cring)

lemma P_Zp_domain[simp]:
"domain P_Zp "
  by (simp add: UP_domain.UP_domain)

(*Basic simp rules to streaminline computation*)

lemma pow_closedP[simp]:
  assumes "f \<in> carrier P_Zp"
  shows "f[^]\<^bsub>P_Zp\<^esub>(n::nat) \<in> carrier P_Zp "
  by (meson P_Zp_ring assms monoid.nat_pow_closed ring_def)

lemma pow_closed[simp]:
  assumes "f \<in> carrier Z\<^sub>p"
  shows "f[^](n::nat) \<in> carrier Z\<^sub>p"
  by (meson Zp_is_domain domain_def cring_def assms monoid.nat_pow_closed ring_def)

lemma(in ring) pow_zero[simp]:
  assumes "(n::nat)>0"
  shows "\<zero>[^] n = \<zero>"
  by (simp add: assms nat_pow_zero)

lemma pow_zero[simp]:
  assumes "(n::nat)>0"
  shows "\<zero>[^] n = \<zero>"
  using Zp_is_cring
  unfolding cring_def
  using ring.pow_zero
        assms
  by blast

lemma pow_zeroP[simp]:
  assumes "n >0"
  shows "\<zero>\<^bsub>P_Zp\<^esub>[^]\<^bsub>P_Zp\<^esub>(n::nat) = \<zero>\<^bsub>P_Zp\<^esub>"
  using assms ring.pow_zero[of P_Zp] by simp

lemma sum_closedP[simp]:
  assumes "f \<in> carrier P_Zp"
  assumes "g \<in> carrier P_Zp"
  shows "f \<oplus>\<^bsub>P_Zp\<^esub>g \<in>  carrier P_Zp"
  by (simp add: assms(1) assms(2) cring.cring_simprules(1))

lemma sum_closed[simp]:
  assumes "f \<in> carrier Z\<^sub>p"
  assumes "g \<in> carrier Z\<^sub>p"
  shows "f \<oplus> g \<in>  carrier Z\<^sub>p"
  by (simp add: assms(1) assms(2) cring.cring_simprules(1))

lemma mult_zero[simp]:
  assumes "f \<in> carrier Z\<^sub>p"
  shows "f \<otimes> \<zero> = \<zero>"
        "\<zero> \<otimes> f = \<zero>"
   apply (simp add: assms cring.cring_simprules(27))
   apply (simp add: assms cring.cring_simprules(26))
  done

lemma mult_zeroP[simp]:
  assumes "f \<in> carrier P_Zp"
  shows "f \<otimes>\<^bsub>P_Zp\<^esub> \<zero>\<^bsub>P_Zp\<^esub> = \<zero>\<^bsub>P_Zp\<^esub>"
        "\<zero>\<^bsub>P_Zp\<^esub> \<otimes>\<^bsub>P_Zp\<^esub> f = \<zero>\<^bsub>P_Zp\<^esub>"
  apply (simp add: assms cring.cring_simprules(27))
  apply (simp add: assms cring.cring_simprules(26))
  done

lemma add_zero[simp]:
  assumes "f \<in> carrier Z\<^sub>p"
  shows "f \<oplus> \<zero> = f"
        "\<zero> \<oplus> f = f"
   apply (simp add: Zp_is_cring assms cring.cring_simprules)
   apply (simp add: Zp_is_cring assms cring.cring_simprules)
   done

lemma add_zeroP[simp]:
  assumes "f \<in> carrier P_Zp "
  shows "f \<oplus>\<^bsub>P_Zp\<^esub> \<zero>\<^bsub>P_Zp\<^esub> = f"
        "\<zero>\<^bsub>P_Zp\<^esub> \<oplus>\<^bsub>P_Zp\<^esub> f = f"
   apply (simp add: assms cring.cring_simprules)
   apply (simp add: assms cring.cring_simprules)
   done

(*Degree function*)
abbreviation degree:: "padic_int_poly \<Rightarrow> nat" where
"degree f \<equiv>  deg Z\<^sub>p f"

(*Coefficient function*)
abbreviation cf :: "padic_int_poly \<Rightarrow> nat \<Rightarrow> padic_int" where
"cf  \<equiv> coeff (UP Z\<^sub>p)"

(*Leading term function*)
abbreviation lt  where
"lt \<equiv> leading_term Z\<^sub>p"

(*Leading coefficient function*)
abbreviation lc where
"lc \<equiv> leading_coefficient Z\<^sub>p"

(*Truncation function*)
abbreviation trunc where
"trunc \<equiv> truncate Z\<^sub>p"

(*Turning a padic polynomial into a function on Z\<^sub>p*)
abbreviation fun_of :: "_ \<Rightarrow> padic_int_fun" (infixl "\<star>" 70) where
"fun_of f a \<equiv> function_of Z\<^sub>p f a"

(*predicate for monomial polynomials*)
abbreviation is_monom where
"is_monom \<equiv> is_monom_poly Z\<^sub>p"

(*technical lemmas for reasoning about fun_of*)
lemma id_is_hom:
"ring_hom_cring Z\<^sub>p Z\<^sub>p (\<lambda>x. x)"
proof(rule ring_hom_cringI)
  show "cring Z\<^sub>p"
    using Zp_is_cring by auto
  show "cring Z\<^sub>p"
    using Zp_is_cring by auto
  show "(\<lambda>x. x) \<in> ring_hom Z\<^sub>p Z\<^sub>p"
    unfolding ring_hom_def
    apply(auto)
    done
qed

lemma UP_pre_univ_prop_fact:
"UP_pre_univ_prop Z\<^sub>p Z\<^sub>p (\<lambda>x. x)"
  unfolding UP_pre_univ_prop_def
  by (simp add: UP_cring_def  id_is_hom)

(*P_Zp addition commutes with evaluation addition*)
lemma fun_of_fun_sum:
  assumes "f \<in> carrier P_Zp"
  assumes "g \<in> carrier P_Zp"
  assumes "h = f \<oplus>\<^bsub>P_Zp\<^esub> g"
  shows "fun_sum (fun_of f) (fun_of g) \<doteq> fun_of h"
  unfolding eq_on_Zp_def
  apply(auto)
proof-
  fix x
  assume A: "x \<in> carrier Z\<^sub>p"
  show "fun_sum (fun_of f) (fun_of g) x = fun_of h x "
    unfolding fun_sum_def
    unfolding function_of_def
  proof-
    have "(eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x)) x \<in> (ring_hom P_Zp Z\<^sub>p)"
      using UP_pre_univ_prop_fact A UP_pre_univ_prop.eval_ring_hom[of Z\<^sub>p Z\<^sub>p "(\<lambda>x. x)" x]    by auto
    then show "eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x) x f \<oplus> eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x) x g = eval Z\<^sub>p Z\<^sub>p (\<lambda>x. x) x h "
      using assms ring_hom_add   by (simp add: \<open>f \<in> carrier P_Zp\<close> ring_hom_def)
  qed
qed

(*monomial functions are monomials*)
lemma fun_of_monom_is_monom0:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "c \<noteq>\<zero>"
  assumes "f = monom P_Zp c n"
  assumes "x \<in> carrier Z\<^sub>p"
  shows "fun_of f x = mon c n x"
proof-
  have 1: "fun_of f x = c \<otimes> x [^] n"
    using UP_domain.fun_of_monom assms P_Zp_is_UP_domain
    by (simp add: UP_domain.fun_of_monom)
  show ?thesis
    unfolding mon_def scalar_mult_def X_pow_Zp_def
    apply auto
     apply (metis "1" Zp_is_cring cring.axioms(1) monoid.nat_pow_0 ring_def)
    using 1  by simp
qed

lemma fun_of_monom_is_monom:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "f = monom P_Zp c n"
  shows "fun_of f \<doteq> mon c n"
proof(cases "c = \<zero>")
  case True
  have H: "f = (\<lambda> i. \<zero>)"
    apply(auto simp: assms(2))
    apply(auto simp:True)
  proof-
    have A: "\<zero> \<in> carrier Z\<^sub>p"
      using True assms(1) by auto
    then have "monom  (UP Z\<^sub>p) = (\<lambda>a\<in>carrier Z\<^sub>p. (\<lambda>n i. if i = n then a else \<zero>)) "
      by(simp add: UP_def)
    then have "monom (UP Z\<^sub>p) \<zero>  = (\<lambda>n i. if i = n then \<zero> else \<zero>)"
      using A by simp
    then have "monom (UP Z\<^sub>p) \<zero> n  =  (\<lambda>i. if i = n then \<zero> else \<zero>)"
      by simp
    then show "monom (UP Z\<^sub>p) \<zero> n = (\<lambda>i. \<zero>)"
      by simp
  qed
  have H1: "cf f= f"
    by (simp add:P_Zp_is_UP_ring UP_domain.coeff_simp1 UP_ring.monom_closed assms(1) assms(2))
  show ?thesis
    unfolding eq_on_Zp_def
    apply(auto )
    unfolding mon_def scalar_mult_def X_pow_Zp_def
  proof-
    fix x
    assume A: "x \<in> carrier Z\<^sub>p"
    have P0: "fun_of f x = \<zero>"
    proof-
      have C0: "abelian_monoid Z\<^sub>p"
        using Zp_is_cring abelian_group_def cring_def ring_def by blast
      have C1: "\<And> i::nat. \<zero> \<otimes> x [^]i = \<zero>"
      proof-
        fix i::nat
        show "\<zero> \<otimes> x [^] i = \<zero>"
          using Zp_is_cring A monoid.nat_pow_closed
          by (simp add: monoid.nat_pow_closed cring.cring_simprules(26) cring_def ring_def)
      qed
      have C2: "f \<in> carrier P_Zp"
        apply(auto simp: assms(2))
        using assms(1) P_Zp_is_UP_ring UP_ring.monom_closed[of Z\<^sub>p c n] apply simp
        done
      have C3: "fun_of f x = (\<Oplus>i \<in> {..degree f}. (cf f i) \<otimes> x [^] i)"
        using  A  C2 P_Zp_is_UP_domain UP_domain.fun_of_formula[of Z\<^sub>p f x]
        by blast
      show ?thesis
        apply(auto simp: C3 H1 )
        apply(auto simp: H)
        apply(auto simp: C1)
        apply(auto simp: C0 abelian_monoid.finsum_zero)
        done
    qed
    show "fun_of f x = c \<otimes> (if n = 0 then \<one> else x [^] n) "
      apply(auto simp: P0)
       apply (simp add: True Zp_one_car cring.cring_simprules(26))
      using A assms(1) monom_term_car[of c x]
      by (metis True Zp_is_cring cring.cring_simprules(26) cring_def monoid.nat_pow_closed ring_def)
  qed
next
  case False
  then show ?thesis
    unfolding eq_on_Zp_def
    apply(auto)
    by (simp add: assms(1) assms(2) fun_of_monom_is_monom0)
qed

lemma fun_of_monom_is_monom':
  assumes "is_monom f"
  shows "fun_of f \<doteq> mon (lc f) (degree f)"
  using P_Zp_is_UP_domain assms
    UP_domain.is_monom_id[of Z\<^sub>p f]
    fun_of_monom_is_monom[of "lc f" f "degree f"]
    UP_domain.lc_closed[of Z\<^sub>p f]
  unfolding   is_monom_poly_def
  by auto

(*monomials are continuous*)

lemma monom_poly_is_continuous:
  assumes "c \<in> carrier Z\<^sub>p"
  assumes "f = monom P_Zp c n"
  shows "is_continuous (fun_of f)"
proof-
  have 0: "is_continuous (mon c n)"
    unfolding mon_def using assms(1)
    by (simp add: X_pow_Zp_is_continuous scalar_mult_is_continuous)
  have 1: "fun_of f \<doteq> mon c n"
    by (simp add: assms(1) assms(2) fun_of_monom_is_monom)
  show ?thesis using 0 1 is_continuous_eq eq_on_Zp_def by auto
qed

lemma monom_poly_is_continuous':
  assumes "is_monom f"
  shows "is_continuous (fun_of f)"
  using P_Zp_is_UP_domain UP_domain.is_monom_id[of Z\<^sub>p f]
        monom_poly_is_continuous[of "lc f" f "degree f"]
        assms UP_domain.lc_closed[of Z\<^sub>p f]
  unfolding is_monom_poly_def
  by (simp add:  )

lemma degree_0_imp_constant1:
  assumes "f \<in> carrier P_Zp"
  assumes "degree f = 0"
  obtains g where "is_constant_fun g" and "g \<doteq> fun_of f"
proof-
  obtain c where c0: "c \<in> carrier Z\<^sub>p" and  c1: "\<And>x.  x \<in> carrier Z\<^sub>p \<Longrightarrow> (fun_of f) x = c"
    using P_Zp_is_UP_domain UP_domain.degree_0_imp_constant0  assms(1) assms(2) by blast
  obtain g where g_def: "g = to_const_fun c"
    by simp
  have 0: "is_constant_fun g"
    by (simp add: \<open>g = to_const_fun c\<close> c0 to_const_fun_is_const)
  have 1: "g \<doteq> fun_of f"
    unfolding eq_on_Zp_def
    apply(auto)
  proof-
    fix x
    assume A: "x \<in> carrier Z\<^sub>p"
    show "g x = fun_of f x "
    proof-
      have LHS: "g x = c"
        using g_def using to_const_fun_def by simp
      have RHS: "fun_of f x = c"
        apply(auto simp: A c1)
        done
      then show ?thesis
        using RHS LHS by auto
    qed
  qed
  show ?thesis
    using 0 1  that by auto
qed

(*degree 0 polynomials induce continuous functions*)
lemma degree_0_imp_continuous:
  assumes "f \<in> carrier P_Zp"
  assumes "degree f = 0"
  shows "is_continuous (fun_of f)"
proof-
  obtain g where 0: "is_constant_fun g" and 1: "g \<doteq> fun_of f"
    using assms degree_0_imp_constant1 by auto
  have "is_continuous g"
    using 0 by (simp add: constant_is_continuous)
  then show ?thesis
    using 1 is_continuous_eq by blast
qed

(*all polynomials induce continuous functions*)
lemma polynomial_is_continuous0:
  fixes n::nat
  shows "\<And>f. f \<in> carrier P_Zp \<Longrightarrow> degree f \<le> n \<Longrightarrow> is_continuous (fun_of f)"
proof(induction n)
case 0
  then show ?case
    using degree_0_imp_continuous by blast
next
  case (Suc n)
  fix n
  assume IH: "\<And>f. f \<in> carrier P_Zp \<Longrightarrow> (degree f \<le> n \<Longrightarrow> is_continuous (fun_of f))"
  show "\<And>f. f \<in> carrier P_Zp \<Longrightarrow> degree f \<le> Suc n \<Longrightarrow> is_continuous (fun_of f) "
  proof-
    fix f
    assume A0:"f \<in> carrier P_Zp"
    assume D: "degree f \<le> Suc n"
    show "is_continuous (fun_of f)"
    proof(cases "degree f < Suc n")
      case True
      then show ?thesis
        using IH A0 by simp
    next
      case False
      then have E: "degree f = Suc n"
        using D by auto
      then have E0: "degree f > (0::nat)"
        by auto
      obtain g where g_def: "g \<in> carrier P_Zp \<and> (f = g \<oplus>\<^bsub>P_Zp\<^esub> (lt f)) \<and> degree g < degree f"
        using E0 A0 P_Zp_is_UP_domain UP_domain.lt_decomp[of Z\<^sub>p f] by auto
      have g0: "g \<in> carrier P_Zp"
        using g_def by auto
      have g1: "f = g \<oplus>\<^bsub>P_Zp\<^esub> (lt f)"
        using g_def by auto
      have g2: "degree g < degree f"
        using g_def by auto
      have LS: "is_continuous (fun_of g)"
        using E g0 g1 g2 IH by auto
      have RS: "is_continuous (fun_of (lt f))"
        using monom_poly_is_continuous leading_term_def A0  UP_ring.lcoeff_closed
            P_Zp_is_UP_ring UP_domain.coeff_simp1 P_Zp_is_UP_domain   by metis
      have "fun_of f \<doteq>  fun_sum (fun_of g) (fun_of (lt f))"
        using  fun_of_fun_sum g0 A0 g1  eq_on_Zp_def UP_domain.lt_closed
        by (metis (mono_tags, lifting) P_Zp_is_UP_domain)
      then show ?thesis
        using LS RS sum_of_cont_is_cont
        by (metis eq_on_Zp_def is_continuous_eq)
    qed
  qed
qed

lemma polynomial_is_continuous:
  assumes "f \<in> carrier P_Zp"
  shows "is_continuous (fun_of f)"
proof-
  obtain n where n_def: "n = degree f"
    by simp
  then show ?thesis
    using assms polynomial_is_continuous0 by auto
qed

(**************************************************************************************************)
(**************************************************************************************************)
(**********************************    Polynomial Substitution   **********************************)
(**************************************************************************************************)
(**************************************************************************************************)

(*The inclusion of Z\<^sub>p into P_Zp*)
abbreviation to_poly :: "padic_int \<Rightarrow> padic_int_poly" where
"to_poly \<equiv> to_polynomial Z\<^sub>p"

lemma to_poly_is_ring_hom:
"to_poly \<in> ring_hom Z\<^sub>p P_Zp"
  by (simp add: UP_domain.to_poly_is_ring_hom)

abbreviation sub :: "padic_int_poly \<Rightarrow> padic_int_poly \<Rightarrow> padic_int_poly" (infixl "of" 70)where
"sub \<equiv> compose Z\<^sub>p"

abbreviation rev_sub :: "padic_int_poly \<Rightarrow> padic_int_poly \<Rightarrow> padic_int_poly" where
"rev_sub \<equiv> rev_compose Z\<^sub>p"

lemma sub_rev_sub:
"sub f g = rev_sub g f"
  by (simp add:  UP_domain.sub_rev_sub)

(*The polynomial X*)

abbreviation X where
"X \<equiv> X_poly Z\<^sub>p"

(*Translates of X*)

abbreviation X_plus where
"X_plus \<equiv> X_poly_plus  Z\<^sub>p"

abbreviation X_minus where
"X_minus \<equiv> X_poly_minus  Z\<^sub>p"

(*The Taylor expansion*)

abbreviation Taylor ("T\<^bsub>_\<^esub>") where
"Taylor \<equiv> taylor_expansion Z\<^sub>p"

(*Derivative function*)

abbreviation deriv  where
"deriv \<equiv> derivative Z\<^sub>p"

(*Zero coefficient function*)

abbreviation cf0 where
"cf0 \<equiv> zero_coefficient"

(*The shift function*)

abbreviation poly_shift where
"poly_shift \<equiv> polynomial_shift Z\<^sub>p"

(*The iterated shift function*)

abbreviation shift where
"shift \<equiv> poly_shift_iter Z\<^sub>p"

(*The "first n+1 terms" function*)

abbreviation deg_leq where
"deg_leq \<equiv> degree_n_or_less_terms Z\<^sub>p"

(*The linear part function*)
abbreviation lin_part where
"lin_part \<equiv> linear_part Z\<^sub>p"

(*the derivative operator*)

abbreviation pderiv where
"pderiv \<equiv> poly_deriv Z\<^sub>p"

(*Evaluating polynomials in the residue rings*)

lemma fun_of_res_X_pow:
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "a k = b k"
  shows "(fun_of (X[^]\<^bsub>P_Zp\<^esub>(n::nat)) a) k = (fun_of (X[^]\<^bsub>P_Zp\<^esub>n) b) k"
proof(induction n)
  case 0
  then show ?case
    by (smt P_Zp_is_UP_domain P_Zp_is_UP_ring P_Zp_ring UP_domain.X_is_poly UP_ring.deg_monom
        UP_ring.monom_one Zp_one_car Zp_one_notzero assms(1) assms(2) degree_0_imp_constant1
        eq_on_Zp_def is_constant_fun_def monoid.nat_pow_0 pow_closedP ring_def)
next
  case (Suc n)
  fix n::nat
  assume IH: "(X [^]\<^bsub>P_Zp\<^esub> n \<star> a) k = (X [^]\<^bsub>P_Zp\<^esub> n \<star> b) k"
  show "(X [^]\<^bsub>P_Zp\<^esub> Suc n \<star> a) k = (X [^]\<^bsub>P_Zp\<^esub> Suc n \<star> b) k"
  proof-
    have LHS0: "(X [^]\<^bsub>P_Zp\<^esub> Suc n \<star> a) k = ((X [^]\<^bsub>P_Zp\<^esub> n \<star> a) \<otimes> (X \<star> a)) k"
      by (metis (no_types, lifting) P_Zp_is_UP_domain P_Zp_ring UP_domain.X_is_poly
          UP_domain.fun_of_mult assms(1) monoid.nat_pow_Suc pow_closedP ring_def)
    have LHS1: "(X [^]\<^bsub>P_Zp\<^esub> Suc n \<star> a) k = (X [^]\<^bsub>P_Zp\<^esub> n \<star> a) k \<otimes>\<^bsub>R k\<^esub> (X \<star> a) k"
      using LHS0
      by (simp add: Res_def Z\<^sub>p_def padic_mult_simp)
    then show ?thesis using assms IH
      by (smt P_Zp_is_UP_domain P_Zp_ring UP_domain.X_is_poly
          UP_domain.fun_of_X UP_domain.fun_of_mult Z\<^sub>p_def monoid.nat_pow_Suc
          monoid.simps(1) padic_simps(3) pow_closedP ring_def)
  qed
qed

lemma fun_of_res_lt:
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "f \<in> carrier P_Zp"
  assumes "a k = b k"
  shows "(fun_of (lt f) a) k = (fun_of (lt f) b) k"
proof-
  have "lt f = (lc f)\<odot>\<^bsub>P_Zp\<^esub>(X[^]\<^bsub>P_Zp\<^esub>(degree f))"
    by (simp add: UP_domain.lt_rep_X_pow assms(3))
  have LHS0: "(fun_of (lt f) a) = (lc f) \<otimes> (fun_of (X[^]\<^bsub>P_Zp\<^esub>(degree f)) a)"
    by (simp add: UP_domain.X_is_poly UP_domain.fun_of_smult UP_domain.lc_closed \<open>lt f = lc f \<odot>\<^bsub>P_Zp\<^esub> X [^]\<^bsub>P_Zp\<^esub> degree f\<close> assms(1) assms(3))
  have RHS0: "(fun_of (lt f) b) = (lc f) \<otimes> (fun_of (X[^]\<^bsub>P_Zp\<^esub>(degree f)) b)"
    by (simp add: UP_domain.X_is_poly UP_domain.fun_of_smult UP_domain.lc_closed \<open>lt f = lc f \<odot>\<^bsub>P_Zp\<^esub> X [^]\<^bsub>P_Zp\<^esub> degree f\<close> assms(2) assms(3))
  have LHS1: "(fun_of (lt f) a) k = ((lc f) k) \<otimes>\<^bsub>R k\<^esub> (fun_of (X[^]\<^bsub>P_Zp\<^esub>(degree f)) a) k"
    using LHS0 assms
    by (simp add: Res_def Z\<^sub>p_def padic_simps(3))
  have RHS1: "(fun_of (lt f) b) k = ((lc f) k) \<otimes>\<^bsub>R k\<^esub> (fun_of (X[^]\<^bsub>P_Zp\<^esub>(degree f)) b) k"
    using RHS0 assms
    by (simp add: Res_def Z\<^sub>p_def padic_simps(3))
  then show ?thesis
    using LHS1 RHS1 assms
    by (metis fun_of_res_X_pow)
qed

lemma fun_of_res:
  assumes "f \<in> carrier P_Zp"
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "a k = b k"
  shows "(fun_of f a) k = (fun_of f b) k"
proof(rule UP_domain.poly_induct2[of Z\<^sub>p f])
  show "UP_domain Z\<^sub>p" by simp
  show "f \<in> carrier P_Zp" using assms by simp
  show "\<And>p. p \<in> carrier P_Zp \<Longrightarrow> degree p = 0 \<Longrightarrow> (p \<star> a) k = (p \<star> b) k"
    by (metis P_Zp_is_UP_domain UP_domain.degree_0_imp_constant0 assms(2) assms(3))
  show "\<And>p. 0 < degree p \<Longrightarrow> p \<in> carrier P_Zp \<Longrightarrow> (trunc p \<star> a) k = (trunc p \<star> b) k
                \<Longrightarrow> (p \<star> a) k = (p \<star> b) k"
  proof-
    fix p
    assume A: "0 < degree p" "p \<in> carrier P_Zp"
    assume IH: " (trunc p \<star> a) k = (trunc p \<star> b) k "
    show "(p \<star> a) k = (p \<star> b) k"
    proof-
      have "(p \<star> a) k = (((trunc p)\<star> a) \<oplus> ((lt p) \<star> a)) k "
        by (metis A(2) P_Zp_is_UP_domain UP_domain.fun_of_plus
            UP_domain.lt_closed UP_domain.trunc_simps(1) UP_domain.trunc_simps(3) assms(2))
      then have 0: "(p \<star> a) k = (((trunc p)\<star> b) k) \<oplus>\<^bsub>R k\<^esub> ((lt p) \<star> a) k "
        using IH
        by (simp add: Res_def Z\<^sub>p_def padic_add_def)
      have "((lt p) \<star> a) k = ((lt p) \<star> b) k"
        by (simp add: A(2) assms(2) assms(3) assms(4) fun_of_res_lt)
      then have 1: "(p \<star> a) k = (((trunc p)\<star> b) k) \<oplus>\<^bsub>R k\<^esub> ((lt p) \<star> b) k "
        using 0 by auto
      then have 2: "(p \<star> a) k = (((trunc p)\<star> b) \<oplus> ((lt p) \<star> b)) k "
        using IH Z\<^sub>p_def \<open>(lt p \<star> a) k = (lt p \<star> b) k\<close> \<open>(p \<star> a) k = (trunc p \<star> a \<oplus> lt p \<star> a) k\<close>
          padic_add_def by auto
      then have 2: "(p \<star> a) k = (((trunc p) \<oplus>\<^bsub>P_Zp\<^esub>(lt p)) \<star> b) k"
        by (simp add: A(2) UP_domain.fun_of_plus UP_domain.lt_closed
            UP_domain.trunc_simps(3) assms(3))
      then show ?thesis
        by (metis A(2) P_Zp_is_UP_domain UP_domain.trunc_simps(1))
    qed
  qed
qed

lemma deriv_res:
  assumes "f \<in> carrier P_Zp"
  assumes "a \<in> carrier Z\<^sub>p"
  assumes "b \<in> carrier Z\<^sub>p"
  assumes "a k = b k"
  shows "(deriv f a) k = (deriv f b) k"
proof-
  have 0: "deriv f a = fun_of (pderiv f) a"
    by (simp add: UP_domain.pderiv_eval_deriv assms(1) assms(2))
  have 1: "deriv f b = fun_of (pderiv f) b"
    by (simp add: UP_domain.pderiv_eval_deriv assms(1) assms(3))
  have 2: "pderiv f \<in> carrier P_Zp"
    by (simp add: UP_domain.poly_deriv_closed assms(1))
  show ?thesis
    using assms fun_of_res[of "pderiv f" a b k] 0 1 2
    by auto
qed

(*Predicate for a polynomial that satisfies the hypothesis of Hensel's lemma at a point a*)

abbreviation hensel where
"hensel f a \<equiv> (f \<in> carrier P_Zp \<and> a \<in> carrier Z\<^sub>p \<and> ((f \<star> a) 1) = 0 \<and> (deriv f a 1) \<noteq> 0)"

lemma pre_hensel:
  assumes "hensel f a"
  assumes "b \<in> carrier Z\<^sub>p \<and> (f \<star> b) (Suc n) = 0 \<and> b 1 = a 1"
  shows "\<exists> b' \<in> carrier Z\<^sub>p. (f \<star> b') (Suc (Suc n)) = 0 \<and> b' 1 = a 1 \<and> b' (Suc n) = b (Suc n)"
proof-
    have b_def: "b \<in> carrier Z\<^sub>p \<and> (f \<star> b) (Suc n) = 0 \<and> b 1 = a 1"
      using assms by blast
    have  "val_Zp (\<p>[^](Suc n)) \<preceq>\<^bsub>G\<^esub> val_Zp (f \<star> b)"
    proof(cases "f \<star> b = \<zero>")
      case True
      then show ?thesis
        by (simp add: G_ord(1) val_Zp_def)
    next
      case False
      then have "f \<star> b \<in>nonzero Z\<^sub>p"
        by (meson assms b_def continuous_is_closed is_closed_fun_simp
            not_nonzero_Zp order_refl polynomial_is_continuous0)
      then have "ord_Zp (f \<star> b) \<ge> Suc n"
        using b_def  False Zp_nonzero_def(1) ord_Zp_geq by force
      then have "ord_Zp (\<p>[^](Suc n)) \<le> ord_Zp (f \<star> b)"
        using b_def  by (simp add: ord_Zp_p_pow)
      then show ?thesis
        using False G_ord(3) \<open>int (Suc n) \<le> ord_Zp (f \<star> b)\<close> ord_Zp_def val_Zp_def val_Zp_p_pow by auto
    qed
    then have 1:"divide (f \<star> b) (\<p>[^](Suc n)) \<otimes> (\<p>[^](Suc n)) = f \<star> b"
      using assms b_def continuous_is_closed divide_id'(2)  is_closed_fun_simp
        p_pow_nonzero polynomial_is_continuous by auto
    have 2: "(deriv f a) \<in> carrier Z\<^sub>p"
      by (simp add: UP_domain.derivative_closed assms)
    have 3: "(deriv f a) 1 \<noteq> 0" using assms by blast
    have "ord_Zp (deriv f a) = 0" using 2 3
      by (simp )
    then have 4: "(deriv f a) \<in> Units Z\<^sub>p"
      using 2 ord_Zp_0_imp_unit[of "(f' a)"] by simp
    obtain k where  k_def: "k =inv\<^bsub>(R 1)\<^esub> ((deriv f a) 1)" by simp
    have "k \<otimes>\<^bsub>R 1\<^esub>((deriv f a) 1) = \<one>\<^bsub>R 1\<^esub> \<and> k \<in> carrier (R 1)"
    proof-
      have P0:"field (R 1)"
        using Res_1_field by auto
      have P1: "(deriv f a) 1 \<in> carrier (R 1)"
        using 2 Res_def Z\<^sub>p_def by (metis padic_set_simp0 partial_object.select_convs(1))
      have "\<zero>\<^bsub>R 1\<^esub> = 0"
        by (simp add: Res_def residue_ring_def)
      then have P: "(deriv f a) 1 \<noteq> \<zero>\<^bsub>R 1\<^esub>"
        using "3" by linarith
      then have P2: "k \<otimes>\<^bsub>R 1\<^esub>((deriv f a) 1) = \<one>\<^bsub>R 1\<^esub>"
        using residue_ring_def Res_def P0 P1 m_inv_def field.field_inv[of "R 1" "(deriv f a) 1"] k_def
        by auto
      have "(deriv f a) 1 \<in> Units (R 1)"
        using "3" P1 Res_1_field \<open>\<zero>\<^bsub>R 1\<^esub> = 0\<close> field_axioms_def field_def by fastforce
      have P3: "k \<in> carrier (R 1)" using k_def P0 P1 P field.field_inv[of "R 1" "(deriv f a) 1"] by auto
      then show ?thesis
        using P3 P2 by auto
    qed
    obtain m::int where m_def: "m =(\<ominus>\<^bsub>R 1\<^esub> (((divide (f \<star> b) (\<p>[^](Suc n))) 1) \<otimes>\<^bsub>R 1\<^esub> k))"
      by simp
    obtain t where t_def: "t = [m]\<cdot>\<one>"
      by simp
    have 5: "(f \<star> (b \<oplus> ((\<p>[^](Suc n)) \<otimes> t))) (Suc (Suc n)) = 0"
    proof-
      obtain fb where fb_def[simp]: "fb = f \<star> b"
        by simp
      obtain f'b where f'b_def[simp]: "f'b = (deriv f b)"
        by simp
      obtain c where c_def: "c = (shift 2 (T\<^bsub>b\<^esub>f)) \<star> ((\<p>[^](Suc n)) \<otimes> t)"
        by simp
      have pnt_car: "((\<p>[^](Suc n)) \<otimes> t) \<in> carrier Z\<^sub>p"
        by (simp add: Zp_int_mult_closed Zp_one_car
            cring.cring_simprules(5) t_def)
      have c_car:"c \<in> carrier Z\<^sub>p"
        using P_Zp_is_UP_domain Taylor_closed_UP_domain
              poly_shift_closed_UP_domain pnt_car c_def
        by (simp add: assms b_def)
      have A0: " f \<star> (\<p> [^] (Suc n) \<otimes> t \<oplus> b) = fb \<oplus> f'b \<otimes> (\<p> [^] (Suc n) \<otimes> t) \<oplus> c \<otimes> (\<p> [^](Suc n) \<otimes> t) [^] (2::nat)"
      proof-
        have P0: "\<p> [^] (Suc n) \<otimes> t \<in> carrier Z\<^sub>p"
          by (simp add: Zp_int_mult_closed Zp_one_car cring.cring_simprules(5)  t_def)
        have P1: "f \<in> carrier P_Zp"
          using assms by auto
        have P2: "b \<in> carrier Z\<^sub>p"
          using b_def by auto
        show ?thesis
          using P0 P1 P2   fb_def f'b_def c_def
                P_Zp_is_UP_domain UP_domain.Taylor_deg_1_eval[of Z\<^sub>p f b "(\<p>[^](Suc n)) \<otimes> t" c fb f'b]
        by auto
      qed
      have A1: "(c \<otimes> (\<p> [^] (Suc n) \<otimes> t) [^] (2::nat)) (Suc (Suc n)) = 0"
      proof-
        have Q0: "(\<p> [^] (Suc n) \<otimes> t) [^] (2::nat) = ((\<p> [^] (Suc n)) [^] (2::nat)) \<otimes> (t [^] (2::nat))"
          using Zp_int_mult_closed Zp_is_cring Zp_one_car
            comm_monoid.nat_pow_distr cring_def p_pow_car_nat t_def
          by (simp add: comm_monoid.nat_pow_distr cring_def)
        then have Q1:"t = \<zero> \<or> ord_Zp ((\<p> [^] (Suc n) \<otimes> t) [^] (2::nat)) \<ge> 2*(Suc n)"
        proof(cases "t = \<zero>")
          case True
          then show ?thesis by auto
        next
          case False
          then have Q1: "ord_Zp ((\<p> [^] (Suc n) \<otimes> t) [^] (2::nat)) = ord_Zp ((\<p> [^] (Suc n)) [^] (2::nat))
                                                         + ord_Zp (t [^] (2::nat))"
            using Q0 ord_Zp_mult
            by (metis Zp_int_mult_closed Zp_nat_pow_nonzero Zp_one_car not_nonzero_Zp p_pow_nonzero t_def)
          have Q2: "ord_Zp ((\<p> [^] (Suc n)) [^] (2::nat))  = 2*(Suc n)"
            by (simp add: ord_Zp_p_pow)
          have Q3: "ord_Zp (t [^] (2::nat)) \<ge> 0"
            by (metis False Zp_int_mult_closed Zp_one_car mult_sign_intros(1)
                not_nonzero_Zp of_nat_0_le_iff ord_Zp_pow ord_pos t_def)
          show ?thesis using Q1 Q2 Q3
            by linarith
        qed
        show ?thesis
        proof(cases "t = \<zero>")
          case True
          then have "(c \<otimes> (\<p> [^] (Suc n) \<otimes> t) [^] (2::nat)) = \<zero>"
          proof-
            have "(\<p> [^] (Suc n) \<otimes> t) = \<zero>"
              using True
              by (metis Zp_int_mult_closed Zp_is_cring Zp_one_car
                  cring.cring_simprules(14) cring.cring_simprules(26) p_pow_car_nat t_def)
            then have "(\<p> [^] (Suc n) \<otimes> t) [^] (2::nat) = \<zero>"
              by simp
            then have "(c \<otimes> (\<p> [^] (Suc n) \<otimes> t) [^] (2::nat)) = \<zero>"
              using c_car by simp
            then show ?thesis
              by blast
          qed
          then show ?thesis
            by (simp add: zero_vals)
        next
          case False
          then have Q2:"ord_Zp ((\<p> [^] (Suc n) \<otimes> t) [^] (2::nat)) \<ge> 2*(Suc n)"
            using Q1 by auto
          have Q3: "2*(Suc n) \<ge> Suc (Suc n)"
            by auto
          then have Q4:"ord_Zp ((\<p> [^] (Suc n) \<otimes> t) [^] (2::nat)) \<ge> (Suc (Suc n))"
            using Q2 by linarith
          have "((\<p> [^] (Suc n)   \<otimes> t) [^] (2::nat)) \<in> carrier Z\<^sub>p"
            by (simp add: Zp_int_mult_closed Zp_one_car cring.cring_simprules(5) t_def)
          then have "((\<p> [^] (Suc n)  \<otimes> t) [^] (2::nat)) (Suc (Suc n)) = 0"
            using  Q4  int.lless_eq zero_below_ord
            by blast
          then show ?thesis
            using  c_car  \<open>(\<p> [^] Suc n \<otimes> t) [^] 2 \<in> carrier Z\<^sub>p\<close> res_mult_zero(2)
            by blast
        qed
      qed
      have A2:"fb \<oplus> f'b \<otimes> (\<p> [^] (Suc n) \<otimes> t) \<in> carrier Z\<^sub>p"
      proof-
        have A20: "f'b \<in> carrier Z\<^sub>p"
          using f'b_def  assms b_def UP_domain.derivative_closed[of Z\<^sub>p f b] P_Zp_is_UP_domain
          by blast
        have A21: "fb \<in> carrier Z\<^sub>p"
          using fb_def b_def assms
          by simp
        then show ?thesis
          using t_def
          using A20 cring.cring_simprules(5) pnt_car by force
      qed
      have A3: "c \<otimes> (\<p> [^](Suc n) \<otimes> t) [^] (2::nat) \<in> carrier Z\<^sub>p"
        using c_car monom_term_car pnt_car by auto
      have A4: " (f \<star> (\<p> [^] (Suc n) \<otimes> t \<oplus> b)) (Suc (Suc n)) = (fb \<oplus> f'b \<otimes> (\<p> [^] (Suc n) \<otimes> t)) (Suc (Suc n))"
        using A0 A1 A2 A3
              res_add_zero(2)[of "(Suc (Suc n))" "c \<otimes> (\<p> [^](Suc n) \<otimes> t) [^] (2::nat)"
                                          "fb \<oplus> f'b \<otimes> (\<p> [^] (Suc n) \<otimes> t)"]
        by auto
      have A6: "(f'b \<otimes> (\<p> [^] (Suc n) \<otimes> t)) \<in> carrier Z\<^sub>p"
      proof-
        have A20: "f'b \<in> carrier Z\<^sub>p"
          using f'b_def  assms b_def UP_domain.derivative_closed[of Z\<^sub>p f b] P_Zp_is_UP_domain
          by blast
        then show ?thesis using t_def
          using Zp_is_cring cring.cring_simprules(5) pnt_car by fastforce
      qed
      have A7: "fb  \<in> carrier Z\<^sub>p"
        using fb_def b_def assms
          by simp
      have A8: "(fb \<oplus> f'b \<otimes> (\<p> [^] (Suc n) \<otimes> t)) (Suc (Suc n)) = 0"
      proof-
        obtain fa where fa_def[simp]: "fa = fun_of f a"
          by simp
        obtain f'a where f'a_def[simp]: "f'a = deriv f a"
          by simp
        have A80: "(f'a \<otimes> t) 1= \<ominus>\<^bsub>R 1\<^esub>(divide (fb) (\<p>[^](Suc n))) 1"
        proof-
          have C0: "t 1 = m mod p"
          proof-
            have 0: "t 1 = ([m]\<cdot>\<one>) 1"
              using t_def by auto
            have 1: "([m]\<cdot>\<one>) 1 = m mod p"
              using  int_inc_rep r_def by auto
            then show ?thesis using 0 1 by auto
          qed
          show C1: "(f'a \<otimes> t) 1 = \<ominus>\<^bsub>R 1\<^esub>(divide (fb) (\<p>[^](Suc n))) 1"
          proof-
            have C10:"(f'a \<otimes> t) 1  = (f'a 1) \<otimes>\<^bsub>R 1\<^esub> (t 1)"
              by (simp add: Res_def Z\<^sub>p_def padic_mult_simp)
            have C11:"(f'a \<otimes> t) 1  = (f'a 1) \<otimes>\<^bsub>R 1\<^esub>(\<ominus>\<^bsub>R 1\<^esub> (((divide (f \<star> b) (\<p>[^](Suc n))) 1) \<otimes>\<^bsub>R 1\<^esub> k))"
              using C10 m_def C0
              by (smt R_residues Res_def mod_mult_right_eq of_nat_0_less_iff
                  of_nat_le_0_iff power_one_right residues.res_mult_eq zero_neq_one)
            have C12: "(f'a \<otimes> t) 1  = ((f'a 1) )\<otimes>\<^bsub>R 1\<^esub>(\<ominus>\<^bsub>R 1\<^esub> (k \<otimes>\<^bsub>R 1\<^esub>(((divide (f \<star> b) (\<p>[^](Suc n))) 1))))"
            proof-
              have C120:"((divide (f \<star> b) (\<p>[^](Suc n))) 1) \<in> carrier (R 1)"
                by (metis A7 Res_def Z\<^sub>p_def \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close>
                    divide_id'(1) fb_def p_pow_nonzero padic_set_simp0
                    partial_object.select_convs(1))
              have C121: "k \<in> carrier R 1"
                using \<open>k \<otimes>\<^bsub>R 1\<^esub> deriv f a 1 = \<one>\<^bsub>R 1\<^esub> \<and> k \<in> carrier R 1\<close> by auto
              have C122: "(\<ominus>\<^bsub>R 1\<^esub> (((divide (f \<star> b) (\<p>[^](Suc n))) 1) \<otimes>\<^bsub>R 1\<^esub> k))
                              =(\<ominus>\<^bsub>R 1\<^esub> (k \<otimes>\<^bsub>R 1\<^esub> ((divide (f \<star> b) (\<p>[^](Suc n))) 1)))"
                using C120 C121   Res_1_field
                by (metis R_residues Res_def mult.commute nat_less_le
                    residues.res_mult_eq zero_le_one zero_neq_one)
              have C123: "f'a 1 \<in> carrier (R 1)"
                by (metis "2" Res_def Z\<^sub>p_def f'a_def padic_set_simp0 partial_object.select_convs(1))
              show ?thesis
                unfolding a_minus_def
                using  C11 C120 C121 C122 C123   Res_1_field
                by simp
            qed
            have C13: "k \<in> carrier R 1"
              using \<open>k \<otimes>\<^bsub>R 1\<^esub> deriv f a 1 = \<one>\<^bsub>R 1\<^esub> \<and> k \<in> carrier R 1\<close> by auto
            have C14: "f'a 1 \<in> carrier (R 1)"
              by (metis "2" Res_def Z\<^sub>p_def f'a_def padic_set_simp0 partial_object.select_convs(1))
            have C15: "(k \<otimes>\<^bsub>R 1\<^esub>(((divide (f \<star> b) (\<p>[^](Suc n))) 1))) \<in> carrier (R 1)"
            proof-
              have "(divide (f \<star> b) (\<p>[^](Suc n))) \<in> carrier Z\<^sub>p"
                using A7 \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close> divide_id'(1) fb_def p_pow_nonzero
                by blast
              then have "(divide (f \<star> b) (\<p>[^](Suc n))) 1 \<in> carrier (R 1)"
                by (metis Res_def Z\<^sub>p_def padic_set_simp0 partial_object.select_convs(1))
              then show ?thesis using Res_1_field C13
                by simp
            qed
            then have "(f'a \<otimes> t) 1  = (\<ominus>\<^bsub>R 1\<^esub> ((f'a 1) )\<otimes>\<^bsub>R 1\<^esub>(k \<otimes>\<^bsub>R 1\<^esub>(((divide (f \<star> b) (\<p>[^](Suc n))) 1))))"
              using C12 C13 C14 C15 Res_1_field R_cring[of 1] R_residues[of 1]
              unfolding Res_def
              by (simp add: cring.cring_simprules(28) cring.cring_simprules(29))
            then have "(f'a \<otimes> t) 1  = (\<ominus>\<^bsub>R 1\<^esub> ((f'a 1) \<otimes>\<^bsub>R 1\<^esub> k ) \<otimes>\<^bsub>R 1\<^esub>(((divide (f \<star> b) (\<p>[^](Suc n))) 1)))"
              using C12 C13 C14 C15 Res_1_field R_cring[of 1] R_residues[of 1]
              unfolding Res_def
              by (metis (no_types, lifting) A7 Z\<^sub>p_def \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close> cring.cring_simprules(11) cring.cring_simprules(28) cring.cring_simprules(3) divide_id'(1) fb_def p_pow_nonzero padic_set_simp0 partial_object.select_convs(1) zero_less_one)
            then have  "(f'a \<otimes> t) 1  = (\<ominus>\<^bsub>R 1\<^esub> (((divide (f \<star> b) (\<p>[^](Suc n))) 1)))"
              using k_def 4 Res_1_field  C12 C13 C14 C15 Res_1_field R_cring[of 1] R_residues[of 1]
              unfolding Res_def
              by (smt A7 Res_def Z\<^sub>p_def \<open>k \<otimes>\<^bsub>R 1\<^esub> deriv f a 1 = \<one>\<^bsub>R 1\<^esub> \<and> k \<in> carrier R 1\<close> \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close> cring.cring_simprules(12) cring.cring_simprules(14) cring.cring_simprules(29) cring.cring_simprules(3) cring.cring_simprules(5) divide_id'(1) f'a_def fb_def p_pow_nonzero padic_set_simp0 partial_object.select_convs(1) zero_less_one)
            then show ?thesis
              using fb_def by auto
          qed
        qed
        then have A81: "(f'a \<otimes> t) 1= (\<ominus> (divide (fb) (\<p>[^](Suc n)))) 1"
          using res_uminus
          using A7 Res_def Z\<^sub>p_def \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close>
            divide_id'(1) p_pow_nonzero padic_inv prime by auto
        have A82: "(fb \<oplus> f'a \<otimes>(\<p>[^](Suc n) \<otimes> t)) (Suc (Suc n)) = 0"
        proof-
          obtain h where h_def: "h \<in> carrier Z\<^sub>p \<and> (f'a \<otimes> t) = (\<ominus>(divide (fb) (\<p>[^](Suc n)))) \<oplus> h \<otimes> \<p>[^](1::nat)"
            using eq_res_mod[of "(f'a \<otimes> t)" "\<ominus>(divide (fb) (\<p>[^](Suc n)))" 1]
            by (metis (no_types, lifting) "2" A7 A81 Zp_int_inc_closed Zp_is_cring
                \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close> cring.cring_simprules(14)
                cring.cring_simprules(3) cring.cring_simprules(5) divide_id'(1) f'a_def
                fb_def p_pow_car_nat p_pow_nonzero t_def)
          have A820: "(f'a \<otimes> t) \<in> carrier Z\<^sub>p"
            by (metis A7 Zp_is_cring \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close>
                cring.cring_simprules(3) cring.cring_simprules(5) divide_id'(1)
                fb_def h_def p_pow_car_nat p_pow_nonzero sum_closed)
          have A821: "(\<ominus>(divide (fb) (\<p>[^](Suc n)))) \<in> carrier Z\<^sub>p"
            by (metis A7 Zp_is_cring \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close>
                cring.cring_simprules(3) divide_id'(1) fb_def p_pow_nonzero)
          have A822: "(h \<otimes> \<p>[^](1::nat)) \<in> carrier Z\<^sub>p"
            by (simp add: Zp_nat_inc_closed h_def monom_term_car)
          have A823:"(f'a \<otimes> t) \<oplus> (divide (fb) (\<p>[^](Suc n))) =  h \<otimes> \<p>[^](1::nat)"
            using h_def A820 A821 A822 Zp_is_cring
            by (metis A7 \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close>
                cring.cring_simprules(10) cring.cring_simprules(19)
                cring.cring_simprules(21) divide_id'(1) fb_def p_pow_nonzero)
          then have A824: "(f'a \<otimes> t)\<otimes>  (\<p>[^](Suc n)) \<oplus> (fb)  = h \<otimes> (\<p>[^](Suc (Suc n)))"
          proof-
            have "((f'a \<otimes> t) \<oplus> (divide (fb) (\<p>[^](Suc n)))) \<otimes>  (\<p>[^](Suc n)) =  h \<otimes> \<p>[^](1::nat) \<otimes>  (\<p>[^](Suc n))"
              using A823 by auto
            then have A8240: "((f'a \<otimes> t) \<otimes>  (\<p>[^](Suc n))) \<oplus> (divide (fb) (\<p>[^](Suc n))) \<otimes>  (\<p>[^](Suc n)) =  h \<otimes> (\<p>[^](1::nat) \<otimes>  (\<p>[^](Suc n)))"
              using A820 A821 A822 Zp_is_cring
              by (metis A7 \<open>val_Zp (f \<star> b) \<succeq>\<^bsub>G\<^esub> val_Zp (\<p> [^] Suc n)\<close> cring.cring_simprules(11)
                  cring.cring_simprules(13) divide_id'(1) fb_def h_def p_pow_car_nat p_pow_nonzero)
            have "(divide (fb) (\<p>[^](Suc n))) \<otimes>  (\<p>[^](Suc n))  = fb"
              by (simp add: "1")
            then have A8241: "((f'a \<otimes> t) \<otimes>  (\<p>[^](Suc n))) \<oplus>  (fb) =  h \<otimes> (\<p>[^](1::nat) \<otimes>  (\<p>[^](Suc n)))"
              using A8240 by simp
            then show ?thesis
              by (simp add: p_natpow_prod)
          qed
          then show ?thesis
            using p_pow_factor[of h "(Suc (Suc n))" "Suc (Suc n)"]
            by (metis (mono_tags, lifting) "2" A7 A820 Zp_int_mult_closed Zp_is_cring
                Zp_nat_mult_closed Zp_one_car cring.cring_simprules(10)
                cring.cring_simprules(11) cring.cring_simprules(14)
                f'a_def h_def monom_term_car order_refl p_pow_car_nat t_def)
        qed
        have A83: "(f'a \<otimes>(\<p>[^](Suc n) \<otimes> t)) (Suc (Suc n))=  (f'b \<otimes> (\<p> [^] (Suc n) \<otimes> t))(Suc (Suc n))"
        proof-
          have A830: "f'a 1 = f'b 1"
            using f'a_def f'b_def b_def assms deriv_res
            by metis
          have A831: "f'a \<in> carrier Z\<^sub>p"
            using f'a_def   "2" by blast
          have A832: "f'b \<in> carrier Z\<^sub>p"
            using f'b_def b_def assms UP_domain.derivative_closed[of Z\<^sub>p f b] P_Zp_is_UP_domain
            by auto
          then obtain j where j_def0: "j \<in> carrier Z\<^sub>p \<and> f'a = f'b \<oplus> (\<p>[^](1::nat) \<otimes>j)"
            using f'a_def f'b_def   eq_res_mod[of f'a f'b 1] A830 A831 A832
            by auto
          then have j_def: "j \<in> carrier Z\<^sub>p \<and> f'a = f'b \<oplus> (j \<otimes> \<p>)"
            by (simp add: Zp_nat_inc_closed cring.cring_simprules(14) p_pow_rep0)
          then have "(f'a \<otimes>(\<p>[^](Suc n) \<otimes> t)) =  (f'b \<oplus> (j \<otimes> \<p>))\<otimes>(\<p>[^](Suc n) \<otimes> t)"
            by blast
          then have "(f'a \<otimes>(\<p>[^](Suc n) \<otimes> t)) =  (f'b\<otimes>(\<p>[^](Suc n) \<otimes> t)) \<oplus> (j \<otimes> \<p>)\<otimes>(\<p>[^](Suc n) \<otimes> t)"
            by (metis A832 Zp_is_cring Zp_nat_inc_closed cring.cring_simprules(13)
                cring.cring_simprules(5) j_def0 pnt_car)
          then have "(f'a \<otimes>(\<p>[^](Suc n) \<otimes> t)) =  (f'b\<otimes>(\<p>[^](Suc n) \<otimes> t)) \<oplus> (j \<otimes> \<p>[^](Suc (Suc n)) \<otimes> t)"
            by (metis Zp_int_inc_closed Zp_is_cring Zp_nat_inc_closed cring.cring_simprules(11)
                j_def p_natpow_prod_Suc(1) p_pow_car_nat pnt_car t_def)
          then have A833: "(f'a \<otimes>(\<p>[^](Suc n) \<otimes> t)) =  (f'b\<otimes>(\<p>[^](Suc n) \<otimes> t)) \<oplus> ( \<p>[^](Suc (Suc n)) \<otimes> (j \<otimes>t))"
            by (metis (no_types, lifting) Z\<^sub>p_def Zp_is_cring Zp_one_car cring.cring_simprules(14)
                j_def p_pow_car_nat padic_integers.Zp_int_mult_closed padic_integers_axioms
                padic_mult_assoc prime t_def)
          have A834:"( \<p>[^](Suc (Suc n)) \<otimes> (j \<otimes>t)) (Suc (Suc n)) = 0"
            by (smt Z\<^sub>p_def Zp_is_cring Zp_one_car cring.cring_simprules(5) j_def ord_Zp_p_pow
                p_pow_car_nat padic_integers.Zp_int_mult_closed padic_integers.res_mult_zero(1)
                padic_integers_axioms t_def zero_below_ord zero_less_Suc)
          have "(f'a \<otimes>(\<p>[^](Suc n) \<otimes> t)) (Suc (Suc n)) =
                          (f'b\<otimes>(\<p>[^](Suc n) \<otimes> t)) (Suc (Suc n))
                        \<oplus>\<^bsub>R (Suc (Suc n))\<^esub> ( \<p>[^](Suc (Suc n)) \<otimes> (j \<otimes>t))(Suc (Suc n))"
            using A833
            by (simp add: Res_def Z\<^sub>p_def padic_add_def)
          then show ?thesis
            using A834
            unfolding Res_def
            by (smt A6 Z\<^sub>p_def Zp_is_cring Zp_one_car
                \<open>f'a \<otimes> (\<p> [^] Suc n \<otimes> t) = f'b \<otimes> (\<p> [^] Suc n \<otimes> t) \<oplus> j \<otimes> \<p> [^] Suc (Suc n) \<otimes> t\<close>
                cring.cring_simprules(10) cring.cring_simprules(11) cring.cring_simprules(14)
                cring.cring_simprules(5) j_def p_pow_car_nat padic_integers.Zp_int_mult_closed
                padic_integers_axioms res_add_zero(1) t_def zero_less_Suc)
        qed
        then show "(fb \<oplus> f'b \<otimes>(\<p>[^](Suc n) \<otimes> t)) (Suc (Suc n)) = 0"
          using A83 A82
          by (simp add: Z\<^sub>p_def padic_add_def)
      qed
      show ?thesis
        using A8 A4
        by (simp add: b_def cring.cring_simprules(10) pnt_car)
    qed
    obtain b1 where b1_def: "b1 = (b \<oplus> ((\<p>[^](Suc n)) \<otimes> t))"
      by simp
    have b10: "b1 \<in> carrier Z\<^sub>p"
      by (simp add: Zp_int_mult_closed Zp_one_car b1_def b_def cring.cring_simprules(5) t_def)
    have b11: "(f \<star> b1) (Suc (Suc n)) = 0"
      using b1_def 5
      by auto
    have b12: "b1 1 = a 1"
    proof-
      have "b1 1 = b 1"
      proof-
        have "b1 1 = (b \<oplus> ((\<p>[^](Suc n)) \<otimes> t)) 1"
          using b1_def by auto
        then have b120: "b1 1 = (b 1) \<oplus>\<^bsub>R 1\<^esub> ((\<p>[^](Suc n)) \<otimes> t) 1"
          by (simp add: Res_def Z\<^sub>p_def padic_add_def)
        have b121: "((\<p>[^](Suc n)) \<otimes> t) 1 = 0"
          by (metis Z\<^sub>p_def Zero_not_Suc Zp_int_mult_closed Zp_one_car nat_int of_nat_0
              ord_Zp_0_criterion ord_Zp_p_pow p_pow_car_nat padic_integers.res_mult_zero(1)
              padic_integers_axioms t_def zero_less_one)
        show ?thesis
          using b120 b121
          unfolding Res_def
          by (smt Z\<^sub>p_def Zp_int_inc_zero Zp_int_mult_closed Zp_one_car add_zero(1)
              b_def ord_Zp_0_criterion ord_of_nonzero(1) padic_add_def ring.simps(2))
      qed
      then show ?thesis using b_def by auto
    qed
    show ?thesis using b10 b11 b12 by blast
  qed
qed

definition hensel_sequence where
"hensel_sequence f a = (\<lambda>n::nat. (SOME b. b \<in> carrier Z\<^sub>p \<and> (f \<star> b) (Suc n) = 0 \<and> b 1 = a 1))"

lemma hensel_sequence_id:
  assumes "hensel f a"
  assumes " b = (hensel_sequence f a)"
  assumes "n > m"
  shows "(b n) m = (b m) m"
proof-
  obtain bn where bn_def[simp]: "bn = b n"
    by simp
  obtain bm where bm_def[simp]: "bm = b m"
    by simp

  have bn: "bn \<in> carrier Z\<^sub>p \<and> (f \<star> (bn)) (Suc n) = 0 \<and> (bn) 1 = a 1"
    using pre_hensel[of f a] assms bn_def
    unfolding hensel_sequence_def
    by (smt someI_ex)
  have bm: "bm \<in> carrier Z\<^sub>p \<and> (f \<star> (bm)) (Suc m) = 0 \<and> (bm) 1 = a 1"
    using pre_hensel[of f a] assms bm_def
    unfolding hensel_sequence_def
    by (smt someI_ex)

  obtain fbn where fbn_def[simp]: "fbn = fun_of f (bn)"
    by simp
  obtain fbm where fbm_def[simp]: "fbm = fun_of f (bm)"
    by simp

  have fbn_car[simp]: "fbn \<in> carrier Z\<^sub>p"
    using assms(1) bn continuous_is_closed fbn_def
        is_closed_fun_simp polynomial_is_continuous by blast
  have fbm_car[simp]: "fbm \<in> carrier Z\<^sub>p"
    using assms(1) bm continuous_is_closed fbm_def
         is_closed_fun_simp polynomial_is_continuous
    by blast

  obtain f'a where f'a_def[simp]:"f'a = deriv f a"
    by simp
  have f'a_car[simp]: "f'a \<in> carrier Z\<^sub>p"
    using assms f'a_def P_Zp_is_UP_domain
    by (simp add: UP_domain.derivative_closed)

  obtain fa where fa_def: "fa = fun_of f a"
    by simp
  have fa_car: "fa \<in> carrier Z\<^sub>p"
    using fa_def P_Zp_is_UP_domain
    by (simp add: assms(1))

  obtain cn where cn_def: "cn = fun_of (shift (2::nat) (T\<^bsub>a\<^esub> f)) (bn \<ominus> a)"
    by simp
  have cn_car[simp]: "cn \<in> carrier Z\<^sub>p"
    using cn_def P_Zp_is_UP_domain
    by (metis UP_domain.Taylor_closed Zp_is_cring a_minus_def assms(1)
        bn cring.cring_simprules(3) fun_of_closed_UP_domain shift_closed_UP_domain sum_closed)

  obtain cm where cm_def: "cm = fun_of (shift (2::nat) (T\<^bsub>a\<^esub> f)) (bm \<ominus> a)"
    by simp
  have cm_car[simp]: "cm \<in> carrier Z\<^sub>p"
    using cm_def P_Zp_is_UP_domain

    by (metis UP_domain.Taylor_closed Zp_is_cring a_minus_def assms(1)
        bm cring.cring_simprules(3) fun_of_closed_UP_domain shift_closed_UP_domain sum_closed)

  have fbn0: "fbn =  fa \<oplus> f'a \<otimes> (bn \<ominus> a) \<oplus> (cn \<otimes> (bn \<ominus> a)[^](2::nat))"
    using UP_domain.Taylor_deg_1_expansion[of Z\<^sub>p f a bn cn fa f'a] P_Zp_is_UP_domain
          assms(1) bn cn_def f'a_def fa_def fbn_def
    by blast
  have fbm0: "fbm =  fa \<oplus> f'a \<otimes> (bm \<ominus> a) \<oplus> (cm \<otimes> (bm \<ominus> a)[^](2::nat))"
    using UP_domain.Taylor_deg_1_expansion[of Z\<^sub>p f a bm cm fa f'a] P_Zp_is_UP_domain
          assms(1) bm cm_def f'a_def fa_def fbm_def
    by blast
-

  have fb_diff: "fbn \<ominus> fbm = f'a \<otimes>(bn \<ominus> bm) \<oplus>  (cn \<otimes> (bn \<ominus> a) [^] (2::nat) \<ominus> cm \<otimes> (bm \<ominus> a) [^] (2::nat))"
  proof-
    have fb_d0:"fbn \<ominus> fbm = fa \<oplus> f'a \<otimes> (bn \<ominus> a) \<oplus> (cn \<otimes> (bn \<ominus> a)[^](2::nat))
                    \<ominus>(fa \<oplus> f'a \<otimes> (bm \<ominus> a) \<oplus> (cm \<otimes> (bm \<ominus> a)[^](2::nat)))"
      using fbn0 fbm0 by auto
    have fb_d1:"fbn \<ominus> fbm =  f'a \<otimes> (bn \<ominus> a) \<ominus> f'a \<otimes> (bm \<ominus> a) \<oplus> (cn \<otimes> (bn \<ominus> a) [^] (2::nat) \<ominus> cm \<otimes> (bm \<ominus> a) [^] (2::nat))"
    proof-
      have fb_d10[simp]:"f'a \<otimes> (bn \<ominus> a) \<in> carrier Z\<^sub>p" "f'a \<otimes> (bm \<ominus> a) \<in> carrier Z\<^sub>p"
        using Zp_is_cring cring_def[of Z\<^sub>p]
              fbn_car bn cn_car f'a_car fa_car  assms
              cring.cring_simprules(1-5)[of Z\<^sub>p]
              ring.ring_simprules(1-6)[of Z\<^sub>p]
        apply meson
        using Zp_is_cring cring.cring_simprules(4)[of Z\<^sub>p]  cring.cring_simprules(5)[of Z\<^sub>p]
              assms(1) bm f'a_car
        apply blast done
      have fb_d11[simp]:"cn \<otimes> (bn \<ominus> a) [^] (2::nat) \<in> carrier Z\<^sub>p" "cm \<otimes> (bm \<ominus> a) [^] (2::nat) \<in> carrier Z\<^sub>p"
       apply (meson Zp_is_cring assms(1) bn cn_car cring.cring_simprules(4) monom_term_car)
       by (meson Zp_is_cring assms(1) bm cm_car cring.cring_simprules(4) monom_term_car)
     show ?thesis
       using fb_d0 fb_d10 fb_d11 cring_def fa_car
              cring.minus_pairs_cancel_1[of Z\<^sub>p fa "f'a \<otimes> (bn \<ominus> a)" "(cn \<otimes> (bn \<ominus> a)[^](2::nat))"
                                                  "f'a \<otimes> (bm \<ominus> a)" "(cm \<otimes> (bm \<ominus> a)[^](2::nat))"]
       by force
    qed
    have fb_d2:"fbn \<ominus> fbm = f'a \<otimes> (bn \<ominus> a \<ominus> (bm \<ominus> a)) \<oplus>  (cn \<otimes> (bn \<ominus> a) [^] (2::nat) \<ominus> cm \<otimes> (bm \<ominus> a) [^] (2::nat))"
      using Zp_is_cring cring.minus_pair_factor[of Z\<^sub>p "(bn \<ominus> a)" "(bm \<ominus> a)" f'a ]
      by (metis assms(1) bm bn cring.cring_simprules(4) f'a_car fb_d1)
    have fb_d3: "(bn \<ominus> a \<ominus> (bm \<ominus> a)) = bn \<ominus> bm"
      using  cring.minus_pairs_cancel_2[of Z\<^sub>p bn bm a]
             Zp_is_cring assms(1) bm bn
      by blast
    show ?thesis using fb_d2 fb_d3
      by auto
  qed

lemma hensels_lemma0:
assumes "hensel f a"
shows "\<exists> \<alpha> \<in> carrier Z\<^sub>p. f\<star>\<alpha> = \<zero> \<and> \<alpha> 1 = a 1"

end
end


section {* \isaheader{List Based Maps} *}
theory Impl_List_Map
imports
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
  List
begin

type_synonym ('k,'v) list_map = "('k\<times>'v) list"

definition "list_map_invar = distinct o map fst"

definition list_map_rel_internal_def:
    "list_map_rel Rk Rv \<equiv> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel O br map_of list_map_invar"

lemma list_map_rel_def:
    "\<langle>Rk,Rv\<rangle>list_map_rel = \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel O br map_of list_map_invar"
    unfolding list_map_rel_internal_def[abs_def] by (simp add: relAPP_def)

lemma list_rel_Range:
    "\<forall>x'\<in>set l'. x' \<in> Range R \<Longrightarrow> l' \<in> Range (\<langle>R\<rangle>list_rel)"
proof (induction l')
  case Nil thus ?case by force
next
  case (Cons x' xs')
    then obtain xs where "(xs,xs') \<in> \<langle>R\<rangle> list_rel" by force
    moreover from Cons.prems obtain x where "(x,x') \<in> R" by force
    ultimately have "(x#xs, x'#xs') \<in> \<langle>R\<rangle> list_rel" by simp
    thus ?case ..
qed

text {* All finite maps can be represented *}
lemma list_map_rel_range:
  "Range (\<langle>Rk,Rv\<rangle>list_map_rel) =
       {m. finite (dom m) \<and> dom m \<subseteq> Range Rk \<and> ran m \<subseteq> Range Rv}"
       (is "?A = ?B")
proof (intro equalityI subsetI)
  fix m' assume "m' \<in> ?A"
  then obtain l l' where A: "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel" and
                         B: "m' = map_of l'" and C: "list_map_invar l'"
       unfolding list_map_rel_def br_def by blast
  {
    fix x' y' assume "m' x' = Some y'"
    with B have "(x',y') \<in> set l'" by (fast dest: map_of_SomeD)
    hence "x' \<in> Range Rk" and "y' \<in> Range Rv"
      by (induction rule: list_rel_induct[OF A], auto)
  }
  with B show "m' \<in> ?B" by (force dest: map_of_SomeD simp: ran_def)

next
  fix m' assume "m' \<in> ?B"
  hence A: "finite (dom m')" and B: "dom m' \<subseteq> Range Rk" and
        C: "ran m' \<subseteq> Range Rv" by simp_all
  from A have "finite (map_to_set m')" by (simp add: finite_map_to_set)
  from finite_distinct_list[OF this]
      obtain l' where l'_props: "distinct l'" "set l' = map_to_set m'" by blast
  hence "distinct (map fst l')"
      by (force simp: distinct_map inj_on_def map_to_set_def)
  moreover from map_of_map_to_set[OF this] and l'_props
      have  "map_of l' = m'" by simp
  ultimately have "(l',m') \<in> br map_of list_map_invar"
      unfolding br_def list_map_invar_def o_def by simp

  moreover from B and C and l'_props
      have "\<forall>x \<in> set l'. x \<in> Range (\<langle>Rk,Rv\<rangle>prod_rel)"
      unfolding map_to_set_def ran_def prod_rel_def by force
  from list_rel_Range[OF this] obtain l where
      "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel" by force

  ultimately show "m' \<in> ?A" unfolding list_map_rel_def by blast
qed

  lemmas [autoref_rel_intf] = REL_INTFI[of list_map_rel i_map]

  lemma list_map_rel_finite[autoref_ga_rules]:
    "finite_map_rel (\<langle>Rk,Rv\<rangle>list_map_rel)"
    unfolding finite_map_rel_def list_map_rel_def
    by (auto simp: br_def)

  lemma list_map_rel_sv[relator_props]:
    "single_valued Rk \<Longrightarrow> single_valued Rv \<Longrightarrow>
        single_valued (\<langle>Rk,Rv\<rangle>list_map_rel)"
    unfolding list_map_rel_def
    by tagged_solver

  (* TODO: Move to Misc *)

subsection {* Implementation *}

primrec list_map_lookup ::
    "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow> ('k,'v) list_map \<Rightarrow> 'v option" where
"list_map_lookup eq _ [] = None" |
"list_map_lookup eq k (y#ys) =
     (if eq (fst y) k then Some (snd y) else list_map_lookup eq k ys)"

primrec list_map_update_aux :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow>
    ('k,'v) list_map \<Rightarrow> ('k,'v) list_map \<Rightarrow> ('k,'v) list_map"where
"list_map_update_aux eq k v [] accu = (k,v) # accu" |
"list_map_update_aux eq k v (x#xs) accu =
    (if eq (fst x) k
        then (k,v) # xs @ accu
        else list_map_update_aux eq k v xs (x#accu))"

definition "list_map_update eq k v m \<equiv>
    list_map_update_aux eq k v m []"

primrec list_map_delete_aux :: "('k \<Rightarrow> 'k \<Rightarrow> bool) \<Rightarrow> 'k \<Rightarrow>
    ('k, 'v) list_map \<Rightarrow> ('k, 'v) list_map \<Rightarrow> ('k, 'v) list_map" where
"list_map_delete_aux eq k [] accu = accu" |
"list_map_delete_aux eq k (x#xs) accu =
    (if eq (fst x) k
        then xs @ accu
        else list_map_delete_aux eq k xs (x#accu))"

definition "list_map_delete eq k m \<equiv> list_map_delete_aux eq k m []"

definition list_map_isEmpty :: "('k,'v) list_map \<Rightarrow> bool"
    where "list_map_isEmpty \<equiv> List.null"

definition list_map_isSng :: "('k,'v) list_map \<Rightarrow> bool"
    where "list_map_isSng m = (case m of [x] \<Rightarrow> True | _ \<Rightarrow> False)"

definition list_map_size :: "('k,'v) list_map \<Rightarrow> nat"
    where "list_map_size \<equiv> length"

definition list_map_iteratei :: "('k,'v) list_map \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow>
    (('k\<times>'v) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'b"
    where "list_map_iteratei \<equiv> foldli"

definition list_map_to_list :: "('k,'v) list_map \<Rightarrow> ('k\<times>'v) list"
    where "list_map_to_list = id"

subsection {* Parametricity *}

lemma list_map_autoref_empty[autoref_rules]:
  "([], op_map_empty)\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
  by (auto simp: list_map_rel_def br_def list_map_invar_def)

lemma param_list_map_lookup[param]:
  "(list_map_lookup,list_map_lookup) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rv\<rangle>option_rel"
unfolding list_map_lookup_def[abs_def] by parametricity

lemma list_map_autoref_lookup_aux:
  assumes eq: "GEN_OP eq op= (Rk\<rightarrow>Rk\<rightarrow>Id)"
  assumes K: "(k, k') \<in> Rk"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_lookup eq k m, op_map_lookup k' (map_of m'))
               \<in> \<langle>Rv\<rangle>option_rel"
unfolding op_map_lookup_def
proof (induction rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
    show ?case by simp
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    with eq'[param_fo] and K  and Cons
        show ?case by (force simp: prod_rel_def)
qed

lemma param_list_map_update_aux[param]:
  "(list_map_update_aux,list_map_update_aux) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> Rv \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_aux_def[abs_def] by parametricity

lemma param_list_map_update[param]:
  "(list_map_update,list_map_update) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> Rv \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_def[abs_def] by parametricity

lemma list_map_autoref_update_aux1:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  assumes K: "(k, k') \<in> Rk"
  assumes V: "(v, v') \<in> Rv"
  assumes A: "(accu, accu') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_update_aux eq k v m accu,
          list_map_update_aux op= k' v' m' accu')
               \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
proof (insert A, induction arbitrary: accu accu'
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
      thus ?case by (simp add: K V)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    from eq'[param_fo] Cons(1) K
        have [simp]: "(eq (fst x) k) \<longleftrightarrow> ((fst x') = k')"
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        with K and V and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_update1[param]:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(list_map_update eq, list_map_update op=) \<in> Rk \<rightarrow> Rv \<rightarrow>
             \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_update_def[abs_def]
  by (intro fun_relI, erule (1) list_map_autoref_update_aux1[OF eq],
      simp_all)

(* TODO: Move - Perhaps. *)
lemma map_add_sng_right: "m ++ [k\<mapsto>v] = m(k \<mapsto> v)"
    unfolding map_add_def by force
lemma map_add_sng_right':
    "m ++ (\<lambda>a. if a = k then Some v else None) = m(k \<mapsto> v)"
    unfolding map_add_def by force

lemma list_map_autoref_update_aux2:
  assumes K: "(k, k') \<in> Id"
  assumes V: "(v, v') \<in> Id"
  assumes A: "(accu, accu') \<in> br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k \<notin> set (map fst accu)"
  assumes M: "(m, m') \<in> br map_of list_map_invar"
  shows "(list_map_update_aux op= k v m accu,
          accu' ++ op_map_update k' v' m')
               \<in> br map_of list_map_invar" (is "(?f m accu, _) \<in> _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K V show ?case by (auto simp: br_def list_map_invar_def
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        hence "((k, v) # xs @ accu, accu' ++ op_map_update k' v' m')
                   \<in> br map_of list_map_invar"
            using K V Cons.prems(3,4) unfolding br_def
            by (force simp add: A list_map_invar_def)
        also from True have "(k,v) # xs @ accu = ?f (x # xs) accu" by simp
        finally show ?thesis .
    next
      case False
        from Cons.prems(1) have B: "(xs, map_of xs) \<in> br map_of
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) \<in> br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
            by simp
        from Cons.prems(4) and False have E: "k \<notin> set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D]
            have F: "\<And>z. (fst x, z) \<in> set xs \<Longrightarrow> z = snd x" by force
        have "map_of (x # accu) ++ op_map_update k' v' (map_of xs) =
                  accu' ++ op_map_update k' v' m'"
            by (intro ext, auto simp: A F map_add_def
                    dest: map_of_SomeD split: option.split)
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_update2[param]:
  shows "(list_map_update op=, op_map_update) \<in> Id \<rightarrow> Id \<rightarrow>
             br map_of list_map_invar \<rightarrow> br map_of list_map_invar"
unfolding list_map_update_def[abs_def]
apply (intro fun_relI)
apply (drule list_map_autoref_update_aux2
                 [where accu="[]" and accu'="Map.empty"])
apply (auto simp: br_def list_map_invar_def)
done

lemma list_map_autoref_update[autoref_rules]:
  assumes eq: "GEN_OP eq op= (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(list_map_update eq, op_map_update) \<in>
      Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (2) list_map_autoref_update1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_update2[param_fo], simp_all)
done

context begin interpretation autoref_syn .
lemma list_map_autoref_update_dj[autoref_rules]:
    assumes "PRIO_TAG_OPTIMIZATION"
    assumes new: "SIDE_PRECOND_OPT (k' \<notin> dom m')"
    assumes K: "(k,k')\<in>Rk" and V: "(v,v')\<in>Rv"
    assumes M: "(l,m')\<in>\<langle>Rk, Rv\<rangle>list_map_rel"
    defines "R_annot \<equiv> Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
    shows "
      ((k, v)#l,
        (OP op_map_update:::R_annot)$k'$v'$m')
      \<in> \<langle>Rk,Rv\<rangle>list_map_rel"
proof -
  from M obtain l' where A: "(l,l') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" and
      B: "(l',m') \<in> br map_of list_map_invar"
      unfolding list_map_rel_def by blast
  hence "((k,v)#l, (k',v')#l')\<in>\<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
      and "((k',v')#l', m'(k' \<mapsto> v')) \<in> br map_of list_map_invar"
      using assms unfolding br_def list_map_invar_def
          by (simp_all add: dom_map_of_conv_image_fst)
  thus ?thesis
    unfolding autoref_tag_defs
    by (force simp: list_map_rel_def)
qed
end

lemma param_list_map_delete_aux[param]:
  "(list_map_delete_aux,list_map_delete_aux) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel
        \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_aux_def[abs_def] by parametricity

lemma param_list_map_delete[param]:
  "(list_map_delete,list_map_delete) \<in> (Rk \<rightarrow> Rk \<rightarrow> bool_rel) \<rightarrow>
       Rk \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_def[abs_def] by parametricity

lemma list_map_autoref_delete_aux1:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  assumes K: "(k, k') \<in> Rk"
  assumes A: "(accu, accu') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  assumes M: "(m, m') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_delete_aux eq k m accu,
          list_map_delete_aux op= k' m' accu')
               \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
proof (insert A, induction arbitrary: accu accu'
           rule: list_rel_induct[OF M, case_names Nil Cons])
  case Nil
      thus ?case by (simp add: K)
next
  case (Cons x x' xs xs')
    from eq have eq': "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id" by simp
    from eq'[param_fo] Cons(1) K
        have [simp]: "(eq (fst x) k) \<longleftrightarrow> ((fst x') = k')"
        by (force simp: prod_rel_def)
    show ?case
    proof (cases "eq (fst x) k")
      case False
        from Cons.prems and Cons.hyps have "(x # accu, x' # accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        from Cons.IH[OF this] and False show ?thesis by simp
    next
      case True
        from Cons.prems and Cons.hyps have "(xs @ accu, xs' @ accu') \<in>
            \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity
        with K and True show ?thesis by simp
  qed
qed

lemma list_map_autoref_delete1[param]:
  assumes eq: "(eq,op=) \<in> Rk \<rightarrow> Rk \<rightarrow> Id"
  shows "(list_map_delete eq, list_map_delete op=) \<in> Rk \<rightarrow>
             \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel"
unfolding list_map_delete_def[abs_def]
  by (intro fun_relI, erule list_map_autoref_delete_aux1[OF eq],
      simp_all)

lemma list_map_autoref_delete_aux2:
  assumes K: "(k, k') \<in> Id"
  assumes A: "(accu, accu') \<in> br map_of list_map_invar"
  assumes A1: "distinct (map fst (m @ accu))"
  assumes A2: "k \<notin> set (map fst accu)"
  assumes M: "(m, m') \<in> br map_of list_map_invar"
  shows "(list_map_delete_aux op= k m accu,
          accu' ++ op_map_delete k' m')
               \<in> br map_of list_map_invar" (is "(?f m accu, _) \<in> _")
using M A A1 A2
proof (induction m arbitrary: accu accu' m')
  case Nil
    with K show ?case by (auto simp: br_def list_map_invar_def
        map_add_sng_right')
next
  case (Cons x xs accu accu' m')
    from Cons.prems have A: "m' = map_of (x#xs)" "accu' = map_of accu"
        unfolding br_def by simp_all
    show ?case
    proof (cases "(fst x) =  k")
      case True
        with Cons.prems(3) have "map_of xs (fst x) = None"
            by (induction xs, simp_all)
        with fun_upd_triv[of "map_of xs" "fst x"]
            have "map_of xs |` (- {fst x}) = map_of xs" by simp
        with True have"(xs @ accu, accu' ++ op_map_delete k' m')
                           \<in> br map_of list_map_invar"
            using K Cons.prems unfolding br_def
            by (auto simp add: A list_map_invar_def)
        thus ?thesis using True by simp
    next
      case False
        from False and K have [simp]: "fst x \<noteq> k'" by simp
        from Cons.prems(1) have B: "(xs, map_of xs) \<in> br map_of
            list_map_invar"by (simp add: br_def list_map_invar_def)
        from Cons.prems(2,3) have C: "(x#accu, map_of (x#accu)) \<in> br map_of
            list_map_invar" by (simp add: br_def list_map_invar_def)
        from Cons.prems(3) have D: "distinct (map fst (xs @ x # accu))"
            by simp
        from Cons.prems(4) and False have E: "k \<notin> set (map fst (x # accu))"
            by simp
        note Cons.IH[OF B C D E]
        also from False have "?f xs (x#accu) = ?f (x#xs) accu" by simp
        also from distinct_map_fstD[OF D]
            have F: "\<And>z. (fst x, z) \<in> set xs \<Longrightarrow> z = snd x" by force

        from Cons.prems(3) have "map_of xs (fst x) = None"
            by (induction xs, simp_all)
        hence "map_of (x # accu) ++ op_map_delete k' (map_of xs) =
               accu' ++ op_map_delete k' m'"
            apply (intro ext, simp add: map_add_def A
                                   split: option.split)
            apply (intro conjI impI allI)
            apply (auto simp: restrict_map_def)
            done
        finally show ?thesis .
    qed
qed

lemma list_map_autoref_delete[autoref_rules]:
  assumes eq: "GEN_OP eq op= (Rk\<rightarrow>Rk\<rightarrow>Id)"
  shows "(list_map_delete eq, op_map_delete) \<in>
      Rk \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> \<langle>Rk,Rv\<rangle>list_map_rel"
unfolding list_map_rel_def
apply (intro fun_relI, elim relcompE, intro relcompI, clarsimp)
apply (erule (1) list_map_autoref_delete1[param_fo, OF eq[simplified]])
apply (rule list_map_autoref_delete2[param_fo], simp_all)
done

lemma list_map_autoref_isEmpty[autoref_rules]:
  shows "(list_map_isEmpty, op_map_isEmpty) \<in>
             \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> bool_rel"
unfolding list_map_isEmpty_def op_map_isEmpty_def[abs_def]
    list_map_rel_def br_def List.null_def[abs_def] by force

lemma param_list_map_isSng[param]:
  assumes "(l,l') \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
  shows "(list_map_isSng l, list_map_isSng l') \<in> bool_rel"
unfolding list_map_isSng_def using assms by parametricity

(* TODO: clean up this mess *)
lemma list_map_autoref_isSng_aux:
  assumes "(l',m') \<in> br map_of list_map_invar"
  shows "(list_map_isSng l', op_map_isSng m') \<in> bool_rel"
using assms
unfolding list_map_isSng_def op_map_isSng_def br_def list_map_invar_def
apply (clarsimp split: list.split)
apply (intro conjI impI allI)
apply (metis map_upd_nonempty)
apply blast
apply (simp, metis fun_upd_apply option.distinct(1))
done

lemma list_map_autoref_isSng[autoref_rules]:
  "(list_map_isSng, op_map_isSng) \<in> \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> bool_rel"
  using assms unfolding list_map_rel_def
  by (blast dest!: param_list_map_isSng list_map_autoref_isSng_aux)

lemma list_map_autoref_size_aux:
  assumes "distinct (map fst x)"
  shows "card (dom (map_of x)) = length x"
proof-
  have "card (dom (map_of x)) = card (map_to_set (map_of x))"
      by (simp add: card_map_to_set)
  also from assms have "... = card (set x)"
      by (simp add: map_to_set_map_of)
  also from assms have "... = length x"
      by (force simp: distinct_card dest!: distinct_mapI)
  finally show ?thesis .
qed

lemma param_list_map_size[param]:
  "(list_map_size, list_map_size) \<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> nat_rel"
  unfolding list_map_size_def[abs_def] by parametricity

lemma list_map_autoref_size[autoref_rules]:
  shows "(list_map_size, op_map_size) \<in>
             \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> nat_rel"
unfolding list_map_size_def[abs_def] op_map_size_def[abs_def]
    list_map_rel_def br_def list_map_invar_def
    by (force simp: list_map_autoref_size_aux list_rel_imp_same_length)

lemma autoref_list_map_is_iterator[autoref_ga_rules]:
  shows "is_map_to_list Rk Rv list_map_rel list_map_to_list"
unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix l m'
  assume "(l,m') \<in> \<langle>Rk,Rv\<rangle>list_map_rel"
  then obtain l' where "(l,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
      and "(l',m')\<in>br map_of list_map_invar"
      unfolding list_map_rel_def by blast
  moreover from this have "RETURN l' \<le> it_to_sorted_list
                               (key_rel (\<lambda>_ _. True)) (map_to_set m')"
      unfolding it_to_sorted_list_def
      apply (intro refine_vcg)
      unfolding br_def list_map_invar_def key_rel_def[abs_def]
      apply (auto intro: distinct_mapI simp: map_to_set_map_of)
      done
  ultimately show
      "\<exists>l'. (list_map_to_list l, l') \<in> \<langle>\<langle>Rk, Rv\<rangle>prod_rel\<rangle>list_rel \<and>
            RETURN l' \<le> it_to_sorted_list (key_rel (\<lambda>_ _. True))
                             (map_to_set m')"
       unfolding list_map_to_list_def by force
qed

lemma pi_list_map[icf_proper_iteratorI]:
  "proper_it (list_map_iteratei m) (list_map_iteratei m)"
unfolding proper_it_def list_map_iteratei_def by blast

lemma pi'_list_map[icf_proper_iteratorI]:
  "proper_it' list_map_iteratei list_map_iteratei"
  by (rule proper_it'I, rule pi_list_map)

primrec list_map_pick_remove where
  "list_map_pick_remove [] = undefined"
| "list_map_pick_remove (kv#l) = (kv,l)"

context begin interpretation autoref_syn .
  lemma list_map_autoref_pick_remove[autoref_rules]:
    assumes NE: "SIDE_PRECOND (m\<noteq>Map.empty)"
    assumes R: "(l,m)\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
    defines "Rres \<equiv> \<langle>(Rk\<times>\<^sub>rRv) \<times>\<^sub>r \<langle>Rk,Rv\<rangle>list_map_rel\<rangle>nres_rel"
    shows "(
        RETURN (list_map_pick_remove l),
        (OP op_map_pick_remove ::: \<langle>Rk,Rv\<rangle>list_map_rel \<rightarrow> Rres)$m
      ) \<in> Rres"
  proof -
    from NE R obtain k v lr where
      [simp]: "l=(k,v)#lr"
      by (cases l) (auto simp: list_map_rel_def br_def)

    thm list_map_rel_def
    from R obtain l' where
      LL': "(l,l')\<in>\<langle>Rk\<times>\<^sub>rRv\<rangle>list_rel" and
      L'M: "(l',m)\<in>br map_of list_map_invar"
      unfolding list_map_rel_def by auto
    from LL' obtain k' v' lr' where
      [simp]: "l' = (k',v')#lr'" and
        KVR: "(k,k')\<in>Rk" "(v,v')\<in>Rv" and
        LRR: "(lr,lr')\<in>\<langle>Rk\<times>\<^sub>rRv\<rangle>list_rel"
      by (fastforce elim!: list_relE)

    from L'M have
      MKV': "m k' = Some v'" and
      LRR': "(lr',m|`(-{k'}))\<in>br map_of list_map_invar"
      by (auto
        simp: restrict_map_def map_of_eq_None_iff br_def list_map_invar_def
        intro!: ext
        intro: sym)

    from LRR LRR' have LM: "(lr,m|`(-{k'}))\<in>\<langle>Rk,Rv\<rangle>list_map_rel"
      unfolding list_map_rel_def by auto

    show ?thesis
      apply (simp add: Rres_def)
      apply (refine_rcg SPEC_refine nres_relI refine_vcg)
      using LM KVR MKV'
      by auto
  qed
end

end


subsection \<open>Monotone Convergence \label{sec:monconv}\<close>

theory MonConv
imports Complex_Main
begin

text \<open>A sensible requirement for an integral operator is that it be
  ``well-behaved'' with respect to limit functions. To become just a
  little more
  precise, it is expected that the limit operator may be interchanged
  with the integral operator under conditions that are as weak as
  possible. To this
  end, the notion of monotone convergence is introduced and later
  applied in the definition of the integral.

  In fact, we distinguish three types of monotone convergence here:
  There are converging sequences of real numbers, real functions and
  sets. Monotone convergence could even be defined more generally for
  any type in the axiomatic type class\footnote{For the concept of axiomatic type
  classes, see \cite{Nipkow93,wenzelax}} \<open>ord\<close> of ordered
  types like this.

  @{prop "mon_conv u f \<equiv> (\<forall>n. u n \<le> u (Suc n)) \<and> Sup (range u) = f"}

  However, this employs the general concept of a least upper bound.
  For the special types we have in mind, the more specific
  limit --- respective union --- operators are available, combined with many theorems
  about their properties. For the type of real- (or rather ordered-) valued functions,
  the less-or-equal relation is defined pointwise.

  @{thm le_fun_def [no_vars]}
\<close>

(*monotone convergence*)

text \<open>Now the foundations are laid for the definition of monotone
  convergence. To express the similarity of the different types of
  convergence, a single overloaded operator is used.\<close>

consts
  mon_conv:: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a::ord \<Rightarrow> bool" ("_\<up>_" [60,61] 60)
overloading
  mon_conv_real \<equiv> "mon_conv :: _ \<Rightarrow> real \<Rightarrow> bool"
  mon_conv_real_fun \<equiv> "mon_conv :: _ \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool"
  mon_conv_set \<equiv> "mon_conv :: _ \<Rightarrow> 'a set \<Rightarrow> bool"
begin

definition "x\<up>(y::real) \<equiv> (\<forall>n. x n \<le> x (Suc n)) \<and> x \<longlonglongrightarrow> y"
definition "u\<up>(f::'a \<Rightarrow> real) \<equiv> (\<forall>n. u n \<le> u (Suc n)) \<and>  (\<forall>w. (\<lambda>n. u n w) \<longlonglongrightarrow> f w)"
definition "A\<up>(B::'a set) \<equiv> (\<forall>n. A n \<le> A (Suc n)) \<and> B = (\<Union>n. A n)"

end

theorem realfun_mon_conv_iff: "(u\<up>f) = (\<forall>w. (\<lambda>n. u n w)\<up>((f w)::real))"
  by (auto simp add: mon_conv_real_def mon_conv_real_fun_def le_fun_def)

text \<open>The long arrow signifies convergence of real sequences as
  defined in the theory \<open>SEQ\<close> \cite{Fleuriot:2000:MNR}. Monotone convergence
  for real functions is simply pointwise monotone convergence.

  Quite a few properties of these definitions will be necessary later,
  and they are listed now, giving only few select proofs.\<close>

    (*This theorem, too, could be proved just the same for any ord
  Type!*)

lemma assumes mon_conv: "x\<up>(y::real)"
  shows mon_conv_mon: "(x i) \<le> (x (m+i))"
(*<*)proof (induct m)
  case 0
  show ?case by simp

next
  case (Suc n)
  also
  from mon_conv have "x (n+i) \<le> x (Suc n+i)"
    by (simp add: mon_conv_real_def)
  finally show ?case .
qed(*>*)

lemma limseq_shift_iff: "(\<lambda>m. x (m+i)) \<longlonglongrightarrow> y = x \<longlonglongrightarrow> y"
(*<*)proof (induct i)
  case 0 show ?case by simp
next
  case (Suc n)
  also have "(\<lambda>m. x (m + n)) \<longlonglongrightarrow> y = (\<lambda>m. x (Suc m + n)) \<longlonglongrightarrow> y"
    by (rule LIMSEQ_Suc_iff[THEN sym])
  also have "\<dots> = (\<lambda>m. x (m + Suc n)) \<longlonglongrightarrow> y"
    by simp
  finally show ?case .
qed(*>*)

    (*This, too, could be established in general*)
theorem assumes mon_conv: "x\<up>(y::real)"
  shows real_mon_conv_le: "x i \<le> y"
proof -
  from mon_conv have "(\<lambda>m. x (m+i)) \<longlonglongrightarrow> y"
    by (simp add: mon_conv_real_def limseq_shift_iff)
  also from mon_conv have "\<forall>m\<ge>0. x i \<le> x (m+i)" by (simp add: mon_conv_mon)
  ultimately show ?thesis by (rule LIMSEQ_le_const[OF _ exI[where x=0]])
qed

theorem assumes mon_conv: "x\<up>(y::('a \<Rightarrow> real))"
  shows realfun_mon_conv_le: "x i \<le> y"
proof -
  {fix w
    from mon_conv have "(\<lambda>i. x i w)\<up>(y w)"
      by (simp add: realfun_mon_conv_iff)
    hence "x i w \<le> y w"
      by (rule real_mon_conv_le)
  }
  thus ?thesis by (simp add: le_fun_def)
qed

lemma assumes mon_conv: "x\<up>(y::real)"
  and less: "z < y"
  shows real_mon_conv_outgrow: "\<exists>n. \<forall>m. n \<le> m \<longrightarrow> z < x m"
proof -
  from less have less': "0 < y-z"
    by simp
  have "\<exists>n.\<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < y - z"
  proof -
    from mon_conv have aux: "\<And>r. r > 0 \<Longrightarrow> \<exists>n. \<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < r"
    unfolding mon_conv_real_def lim_sequentially dist_real_def by auto
    with less' show "\<exists>n. \<forall>m. n \<le> m \<longrightarrow> \<bar>x m - y\<bar> < y - z" by auto
  qed
  also
  { fix m
    from mon_conv have "x m \<le> y"
      by (rule real_mon_conv_le)
    hence "\<bar>x m - y\<bar> = y - x m"
      by arith
    also assume "\<bar>x m - y\<bar> < y - z"
    ultimately have "z < x m"
      by arith
  }
  ultimately show ?thesis
    by blast
qed

theorem real_mon_conv_times:
  assumes xy: "x\<up>(y::real)" and nn: "0\<le>z"
  shows "(\<lambda>m. z*x m)\<up>(z*y)"
(*<*)proof -
  from assms have "\<And>n. z*x n \<le> z*x (Suc n)"
    by (simp add: mon_conv_real_def mult_left_mono)
  also from xy have "(\<lambda>m. z*x m)\<longlonglongrightarrow>(z*y)"
    by (simp add: mon_conv_real_def tendsto_const tendsto_mult)
  ultimately show ?thesis by (simp add: mon_conv_real_def)
qed(*>*)

theorem realfun_mon_conv_times:
  assumes xy: "x\<up>(y::'a\<Rightarrow>real)" and nn: "0\<le>z"
  shows "(\<lambda>m w. z*x m w)\<up>(\<lambda>w. z*y w)"
(*<*)proof -
  from assms have "\<And>w. (\<lambda>m. z*x m w)\<up>(z*y w)"
    by (simp add: realfun_mon_conv_iff real_mon_conv_times)
  thus ?thesis by (auto simp add: realfun_mon_conv_iff)
qed(*>*)

theorem real_mon_conv_add:
  assumes xy: "x\<up>(y::real)" and ab: "a\<up>(b::real)"
  shows "(\<lambda>m. x m + a m)\<up>(y + b)"
(*<*)proof -
  { fix n
    from assms have "x n \<le> x (Suc n)" and "a n \<le> a (Suc n)"
      by (simp_all add: mon_conv_real_def)
    hence "x n + a n \<le> x (Suc n) + a (Suc n)"
      by simp
  }
  also from assms have "(\<lambda>m. x m + a m)\<longlonglongrightarrow>(y + b)" by (simp add: mon_conv_real_def tendsto_add)
  ultimately show ?thesis by (simp add: mon_conv_real_def)
qed(*>*)

theorem realfun_mon_conv_add:
  assumes xy: "x\<up>(y::'a\<Rightarrow>real)" and ab: "a\<up>(b::'a \<Rightarrow> real)"
  shows "(\<lambda>m w. x m w + a m w)\<up>(\<lambda>w. y w + b w)"
(*<*)proof -
  from assms have "\<And>w. (\<lambda>m. x m w + a m w)\<up>(y w + b w)"
    by (simp add: realfun_mon_conv_iff real_mon_conv_add)
  thus ?thesis by (auto simp add: realfun_mon_conv_iff)
qed(*>*)

theorem real_mon_conv_bound:
  assumes mon: "\<And>n. c n \<le> c (Suc n)"
  and bound: "\<And>n. c n \<le> (x::real)"
  shows "\<exists>l. c\<up>l \<and> l\<le>x"
proof -
  from incseq_convergent[of c x] mon bound
  obtain l where "c \<longlonglongrightarrow> l" "\<forall>i. c i \<le> l"
    by (auto simp: incseq_Suc_iff)
  moreover \<comment> \<open>This is like $\isacommand{also}$ but lacks the transitivity step.\<close>
  with bound have "l \<le> x"
    by (intro LIMSEQ_le_const2) auto
  ultimately show ?thesis
    by (auto simp: mon_conv_real_def mon)
qed

theorem real_mon_conv_dom:
  assumes xy: "x\<up>(y::real)" and mon: "\<And>n. c n \<le> c (Suc n)"
  and dom: "c \<le> x"
  shows "\<exists>l. c\<up>l \<and> l\<le>y"
proof -
  from dom have "\<And>n. c n \<le> x n" by (simp add: le_fun_def)
  also from xy have "\<And>n. x n \<le> y" by (simp add: real_mon_conv_le)
  also note mon
  ultimately show ?thesis by (simp add: real_mon_conv_bound)
qed

text\<open>\newpage\<close>
theorem realfun_mon_conv_bound:
  assumes mon: "\<And>n. c n \<le> c (Suc n)"
  and bound: "\<And>n. c n \<le> (x::'a \<Rightarrow> real)"
  shows "\<exists>l. c\<up>l \<and> l\<le>x"
(*<*)proof
  define r where "r t = (SOME l. (\<lambda>n. c n t)\<up>l \<and> l\<le>x t)" for t
  { fix t
    from mon have m2: "\<And>n. c n t \<le> c (Suc n) t" by (simp add: le_fun_def)
    also
    from bound have "\<And>n. c n t \<le> x t" by (simp add: le_fun_def)

    ultimately have "\<exists>l. (\<lambda>n. c n t)\<up>l \<and> l\<le>x t" (is "\<exists>l. ?P l")
      by (rule real_mon_conv_bound)
    hence "?P (SOME l. ?P l)" by (rule someI_ex)
    hence "(\<lambda>n. c n t)\<up>r t \<and> r t\<le>x t" by (simp add: r_def)
  }
  thus "c\<up>r \<and> r \<le> x" by (simp add: realfun_mon_conv_iff le_fun_def)
qed (*>*)

text \<open>This brings the theory to an end. Notice how the definition of the limit of a
  real sequence is visible in the proof to \<open>real_mon_conv_outgrow\<close>, a lemma that will be used for a
  monotonicity proof of the integral of simple functions later on.\<close>(*<*)
  (*Another set construction. Needed in ImportPredSet, but Set is shadowed beyond
  reconstruction there.
  Before making disjoint, we first need an ascending series of sets*)

primrec mk_mon::"(nat \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a set"
where
  "mk_mon A 0 = A 0"
| "mk_mon A (Suc n) = A (Suc n) \<union> mk_mon A n"

lemma "mk_mon A \<up> (\<Union>i. A i)"
proof (unfold mon_conv_set_def)
  { fix n
    have "mk_mon A n \<subseteq> mk_mon A (Suc n)"
      by auto
  }
  also
  have "(\<Union>i. mk_mon A i) = (\<Union>i. A i)"
  proof
    { fix i x
      assume "x \<in> mk_mon A i"
      hence "\<exists>j. x \<in> A j"
        by (induct i) auto
      hence "x \<in> (\<Union>i. A i)"
        by simp
    }
    thus "(\<Union>i. mk_mon A i) \<subseteq> (\<Union>i. A i)"
      by auto

    { fix i
      have "A i \<subseteq> mk_mon A i"
        by (induct i) auto
    }
    thus "(\<Union>i. A i) \<subseteq> (\<Union>i. mk_mon A i)"
      by auto
  qed
  ultimately show "(\<forall>n. mk_mon A n \<subseteq> mk_mon A (Suc n)) \<and> \<Union>(A ` UNIV) = (\<Union>n. mk_mon A n)"
    by simp
qed(*>*)

end


(* Title:      Regular Algebras
   Author:     Simon Foster, Georg Struth
   Maintainer: Simon Foster <s.foster at york.ac.uk>
               Georg Struth <g.struth at sheffield.ac.uk>
*)

header {* Variants of Regular Algebra *}

theory Regular_Algebra_Variants
  imports Regular_Algebras Pratts_Counterexamples
begin

text {* Replacing Kozen's induction axioms by Boffa's leads to incompleteness. *}

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x. x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
  shows "\<And>x y. (x + y)\<^sup>\<star> = x\<^sup>\<star> \<cdot> (y \<cdot> x\<^sup>\<star>)\<^sup>\<star>"
  nitpick [expect=genuine] --"5-element counterexample"
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x. x \<cdot> x = x \<Longrightarrow> x\<^sup>\<star> = 1 + x"
  shows "\<And>x y. x \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y\<^sup>\<star>"
  nitpick [expect=genuine] --"5-element counterexample"
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. 1 + x \<le> y \<and> y \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y"
  shows "\<And>x. 1 + x \<le> x\<^sup>\<star>"
  by (metis add_iso_r assms(1) mult_oner subdistl)

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. 1 + x \<le> y \<and> y \<cdot> y \<le> y \<longrightarrow> x\<^sup>\<star> \<le> y"
  shows "\<And>x. x\<^sup>\<star> = (1 + x)\<^sup>\<star>"
oops -- "need to reconsider this"

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. 1 + x + y \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
  shows "\<And>x. x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y z. x \<cdot> y = y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y = y \<cdot> z\<^sup>\<star>"
  shows "1\<^sup>\<star> = 1"
  nitpick -- "3-element counterexample"
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y z. x \<cdot> y \<le> y \<cdot> z \<Longrightarrow> x\<^sup>\<star> \<cdot> y \<le> y \<cdot> z\<^sup>\<star>"
  and "\<And>x y z. y \<cdot> x \<le> z \<cdot> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> y"
  shows "1\<^sup>\<star> = 1"
  nitpick [expect=genuine] -- "3-element counterexample"
oops

lemma (in star_dioid)
  assumes "\<And>x. 1 + x \<cdot> x\<^sup>\<star> =  x\<^sup>\<star>"
  and "\<And>x. 1 + x\<^sup>\<star> \<cdot> x =  x\<^sup>\<star>"
  and "\<And>x y. x = y \<cdot> x \<Longrightarrow> x = y\<^sup>\<star> \<cdot> x"
  and "\<And>x y. x = x \<cdot> y \<Longrightarrow> x = x \<cdot> y\<^sup>\<star>"
  shows "\<And>x y. y \<cdot> x \<le> y \<Longrightarrow> y \<cdot> x\<^sup>\<star> \<le> y"
oops

class C3l_var = conway_dioid +
  assumes C3l_var: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"

class C3r_var = conway_dioid +
  assumes C3r_var: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

class C3_var = C3l_var + C3r_var

sublocale C3l_var \<subseteq> C3l_algebra
  by (unfold_locales, metis C3l_var add_lub_var order_refl)

sublocale C3l_algebra \<subseteq> C3l_var
  by (unfold_locales, metis star_inductl_var)

sublocale C3_var \<subseteq> C3_algebra
  by (unfold_locales, metis C3r_var add_lub_var order_refl)

sublocale C3_algebra \<subseteq> C3_var
  by (unfold_locales, metis star_inductr_var)

class Brtc_algebra = star_dioid +
  assumes rtc1: "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
  and rtc2: "1 + x + y \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"

sublocale B2_algebra \<subseteq> Brtc_algebra
proof
  fix x y
  show "1 + x\<^sup>\<star> \<cdot> x\<^sup>\<star> + x \<le> x\<^sup>\<star>"
    by (metis B21 R_lemma add_lub star_plus_one star_trans_eq)
  show "1 + x + y \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<le> y"
    by (metis B23 add_lub eq_iff mult_1_right subdistl)
qed

sublocale Brtc_algebra \<subseteq> B2_algebra
proof
  fix x y
  show "1 + x \<le> x\<^sup>\<star>"
    by (metis rtc1 add_lub)
  show "x\<^sup>\<star> \<cdot> x\<^sup>\<star> = x\<^sup>\<star>"
  proof (rule antisym)
    show "x\<^sup>\<star> \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
      by (metis rtc1 add_lub)
    show "x\<^sup>\<star> \<le> x\<^sup>\<star> \<cdot> x\<^sup>\<star>"
      by (metis rtc1 add.commute add_lub less_eq_def mult_isor mult_onel)
  qed
  show "\<lbrakk> 1 + x \<le> y; y \<cdot> y = y \<rbrakk> \<Longrightarrow> x\<^sup>\<star> \<le> y"
    by (metis rtc2 eq_refl less_eq_def)
qed

class wB1_algebra = conway_dioid +
  assumes wR: "x \<cdot> x \<le> x \<Longrightarrow> x\<^sup>\<star> = 1 + x"

sublocale wB1_algebra \<subseteq> B1_algebra
  by (unfold_locales, metis order_refl wR)

lemma (in B1_algebra) one_plus_star:  "x\<^sup>\<star> = (1 + x)\<^sup>\<star>"
  by (metis C11_var R add_idem' mult_onel mult_oner)

sublocale B1_algebra \<subseteq> wB1_algebra
proof unfold_locales
  fix x :: 'a
  assume "x \<cdot> x \<le> x"
  hence "x \<cdot> (1 + x) = x"
    using distrib_left less_eq_def by simp
  hence "(1 + x) \<cdot> (1 + x) = 1 + x"
    using add.left_commute distrib_right' by simp
  thus "x\<^sup>\<star> = 1 + x"
    by (metis R add_assoc' add_idem' one_plus_star)
qed

end