(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Result is Unique\<close>

text \<open>We combine the finite field factorization algorithm with Hensel-lifting to
  obtain factorizations mod $p^n$. Moreover, we prove results on unique-factorizations
  in mod $p^n$ which admit to extend the uniqueness result for binary Hensel-lifting
  to the general case. As a consequence, our factorization algorithm will produce
  unique factorizations mod $p^n$.\<close>

theory Berlekamp_Hensel
imports
  Finite_Field_Factorization_Record_Based
  Hensel_Lifting
begin

hide_const coeff monom

definition berlekamp_hensel :: "int \<Rightarrow> nat \<Rightarrow> int poly \<Rightarrow> int poly list" where
  "berlekamp_hensel p n f = (case finite_field_factorization_int p f of
    (_,fs) \<Rightarrow> hensel_lifting p n f fs)"

text \<open>Finite field factorization in combination with Hensel-lifting delivers
  factorization modulo $p^k$ where factors are irreducible modulo $p$.
  Assumptions: input polynomial is square-free modulo $p$.\<close>

context poly_mod_prime begin

lemma berlekamp_hensel_main:
  assumes n: "n \<noteq> 0"
    and res: "berlekamp_hensel p n f = gs"
    and cop: "coprime (lead_coeff f) p"
    and sf: "square_free_m f"
    and berl: "finite_field_factorization_int p f = (c,fs)"
  shows "poly_mod.factorization_m (p ^ n) f (lead_coeff f, mset gs) \<comment> \<open>factorization mod \<open>p^n\<close>\<close>"
    and "sort (map degree fs) = sort (map degree gs)"
    and "\<And> g. g \<in> set gs \<Longrightarrow> monic g \<and> poly_mod.Mp (p^n) g = g \<and>  \<comment> \<open>monic and normalized\<close>
        poly_mod.irreducible_m p g \<and> \<comment> \<open>irreducibility even mod \<open>p\<close>\<close>
        poly_mod.degree_m p g = degree g  \<comment> \<open>mod \<open>p\<close> does not change degree of \<open>g\<close>\<close>"
proof -
  from res[unfolded berlekamp_hensel_def berl split]
  have hen: "hensel_lifting p n f fs = gs" .
  note bh = finite_field_factorization_int[OF sf berl]
  from bh have "poly_mod.factorization_m p f (c, mset fs)" "c \<in> {0..<p}" "(\<forall>fi\<in>set fs. set (coeffs fi) \<subseteq> {0..<p})"
    by (auto simp: poly_mod.unique_factorization_m_alt_def)
  note hen = hensel_lifting[OF n hen cop sf, OF this]
  show "poly_mod.factorization_m (p ^ n) f (lead_coeff f, mset gs)"
    "sort (map degree fs) = sort (map degree gs)"
    "\<And> g. g \<in> set gs \<Longrightarrow> monic g \<and> poly_mod.Mp (p^n) g = g \<and>
      poly_mod.irreducible_m p g \<and>
      poly_mod.degree_m p g = degree g" using hen by auto
qed

theorem berlekamp_hensel:
  assumes cop: "coprime (lead_coeff f) p"
    and sf: "square_free_m f"
    and res: "berlekamp_hensel p n f = gs"
    and n: "n \<noteq> 0"
  shows "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs) \<comment> \<open>factorization mod \<open>p^n\<close>\<close>"
    and "\<And> g. g \<in> set gs \<Longrightarrow> poly_mod.Mp (p^n) g = g \<and> poly_mod.irreducible_m p g
      \<comment> \<open>normalized and \<open>irreducible\<close> even mod \<open>p\<close>\<close>"
proof -
  obtain c fs where "finite_field_factorization_int p f = (c,fs)" by force
  from berlekamp_hensel_main[OF n res cop sf this]
  show "poly_mod.factorization_m (p^n) f (lead_coeff f, mset gs)"
    "\<And> g. g \<in> set gs \<Longrightarrow> poly_mod.Mp (p^n) g = g \<and> poly_mod.irreducible_m p g" by auto
qed

lemma berlekamp_and_hensel_separated:
  assumes cop: "coprime (lead_coeff f) p"
    and sf: "square_free_m f"
    and res: "hensel_lifting p n f fs = gs"
    and berl: "finite_field_factorization_int p f = (c,fs)"
    and n: "n \<noteq> 0"
  shows "berlekamp_hensel p n f = gs"
    and "sort (map degree fs) = sort (map degree gs)"
proof -
  show "berlekamp_hensel p n f = gs" unfolding res[symmetric]
    berlekamp_hensel_def hensel_lifting_def berl split Let_def ..
  from berlekamp_hensel_main[OF n this cop sf berl] show "sort (map degree fs) = sort (map degree gs)"
    by auto
qed

end

lemma prime_cop_exp_poly_mod:
  assumes prime: "prime p" and cop: "coprime c p" and n: "n \<noteq> 0"
  shows "poly_mod.M (p^n) c \<in> {1 ..< p^n}"
proof -
  from prime have p1: "p > 1" by (simp add: prime_int_iff)
  interpret poly_mod_2 "p^n" unfolding poly_mod_2_def using p1 n by simp
  from cop p1 m1 have "M c \<noteq> 0"
    by (auto simp add: M_def)
  moreover have "M c < p^n" "M c \<ge> 0" unfolding M_def using m1 by auto
  ultimately show ?thesis by auto
qed

context poly_mod_2
begin

context
  fixes p :: int
  assumes prime: "prime p"
begin

interpretation p: poly_mod_prime p using prime by unfold_locales

lemma coprime_lead_coeff_factor: assumes "coprime (lead_coeff (f * g)) p"
  shows "coprime (lead_coeff f) p" "coprime (lead_coeff g) p"
proof -
  {
    fix f g
    assume cop: "coprime (lead_coeff (f * g)) p"
    from this[unfolded lead_coeff_mult]
    have "coprime (lead_coeff f) p" using prime
      by simp
  }
  from this[OF assms] this[of g f] assms
  show "coprime (lead_coeff f) p" "coprime (lead_coeff g) p" by (auto simp: ac_simps)
qed

lemma unique_factorization_m_factor: assumes uf: "unique_factorization_m (f * g) (c,hs)"
  and cop: "coprime (lead_coeff (f * g)) p"
  and sf: "p.square_free_m (f * g)"
  and n: "n \<noteq> 0"
  and m: "m = p^n"
  shows "\<exists> fs gs. unique_factorization_m f (lead_coeff f,fs)
  \<and> unique_factorization_m g (lead_coeff g,gs)
  \<and> Mf (c,hs) = Mf (lead_coeff f * lead_coeff g, fs + gs)
  \<and> image_mset Mp fs = fs \<and> image_mset Mp gs = gs"
proof -
  from prime have p1: "1 < p" by (simp add: prime_int_iff)
  interpret p: poly_mod_2 p by (standard, rule p1)
  note sf = p.square_free_m_factor[OF sf]
  note cop = coprime_lead_coeff_factor[OF cop]
  from cop have copm: "coprime (lead_coeff f) m" "coprime (lead_coeff g) m"
    by (simp_all add: m)
  have df: "degree_m f = degree f"
    by (rule degree_m_eq[OF _ m1], insert copm(1) m1, auto)
  have dg: "degree_m g = degree g"
    by (rule degree_m_eq[OF _ m1], insert copm(2) m1, auto)
  define fs where "fs \<equiv> mset (berlekamp_hensel p n f)"
  define gs where "gs \<equiv> mset (berlekamp_hensel p n g)"
  from p.berlekamp_hensel[OF cop(1) sf(1) refl n, folded m]
  have f: "factorization_m f (lead_coeff f,fs)"
    and f_id: "\<And> f. f \<in># fs \<Longrightarrow> Mp f = f" unfolding fs_def by auto
  from p.berlekamp_hensel[OF cop(2) sf(2) refl n, folded m]
  have g: "factorization_m g (lead_coeff g,gs)"
    and g_id: "\<And> f. f \<in># gs \<Longrightarrow> Mp f = f" unfolding gs_def by auto
  from factorization_m_prod[OF f g] uf[unfolded unique_factorization_m_alt_def]
  have eq: "Mf (lead_coeff f * lead_coeff g, fs + gs) = Mf (c,hs)" by blast
  have uff: "unique_factorization_m f (lead_coeff f,fs)"
  proof (rule unique_factorization_mI[OF f])
    fix e ks
    assume "factorization_m f (e,ks)"
    from factorization_m_prod[OF this g] uf[unfolded unique_factorization_m_alt_def]
      factorization_m_lead_coeff[OF this, unfolded degree_m_eq_lead_coeff[OF df]]
    have "Mf (e * lead_coeff g, ks + gs) = Mf (c,hs)" and e: "M (lead_coeff f) = M e" by blast+
    from this[folded eq, unfolded Mf_def split]
    have ks: "image_mset Mp ks = image_mset Mp fs" by auto
    show "Mf (e, ks) = Mf (lead_coeff f, fs)" unfolding Mf_def split ks e by simp
  qed
  have idf: "image_mset Mp fs = fs" using f_id by (induct fs, auto)
  have idg: "image_mset Mp gs = gs" using g_id by (induct gs, auto)
  have ufg: "unique_factorization_m g (lead_coeff g,gs)"
  proof (rule unique_factorization_mI[OF g])
    fix e ks
    assume "factorization_m g (e,ks)"
    from factorization_m_prod[OF f this] uf[unfolded unique_factorization_m_alt_def]
      factorization_m_lead_coeff[OF this, unfolded degree_m_eq_lead_coeff[OF dg]]
    have "Mf (lead_coeff f * e, fs + ks) = Mf (c,hs)" and e: "M (lead_coeff g) = M e" by blast+
    from this[folded eq, unfolded Mf_def split]
    have ks: "image_mset Mp ks = image_mset Mp gs" by auto
    show "Mf (e, ks) = Mf (lead_coeff g, gs)" unfolding Mf_def split ks e by simp
  qed
  from uff ufg eq[symmetric] idf idg show ?thesis by auto
qed

lemma unique_factorization_factorI:
  assumes ufact: "unique_factorization_m (f * g) FG"
    and cop: "coprime (lead_coeff (f * g)) p"
    and sf: "poly_mod.square_free_m p (f * g)"
    and n: "n \<noteq> 0"
    and m: "m = p^n"
  shows "factorization_m f F \<Longrightarrow> unique_factorization_m f F"
    and "factorization_m g G \<Longrightarrow> unique_factorization_m g G"
proof -
  obtain c fg where FG: "FG = (c,fg)" by force
  from unique_factorization_m_factor[OF ufact[unfolded FG] cop sf n m]
  obtain fs gs where ufact: "unique_factorization_m f (lead_coeff f, fs)"
    "unique_factorization_m g (lead_coeff g, gs)" by auto
  from ufact(1) show "factorization_m f F \<Longrightarrow> unique_factorization_m f F"
    by (metis unique_factorization_m_alt_def)
  from ufact(2) show "factorization_m g G \<Longrightarrow> unique_factorization_m g G"
    by (metis unique_factorization_m_alt_def)
qed

end

lemma monic_Mp_prod_mset: assumes fs: "\<And> f. f \<in># fs \<Longrightarrow> monic (Mp f)"
  shows "monic (Mp (prod_mset fs))"
proof -
  have "monic (prod_mset (image_mset Mp fs))"
    by (rule monic_prod_mset, insert fs, auto)
  from monic_Mp[OF this] have "monic (Mp (prod_mset (image_mset Mp fs)))" .
  also have "Mp (prod_mset (image_mset Mp fs)) = Mp (prod_mset fs)" by (rule Mp_prod_mset)
  finally show ?thesis .
qed

lemma degree_Mp_mult_monic: assumes "monic f" "monic g"
  shows "degree (Mp (f * g)) = degree f + degree g"
  by (metis zero_neq_one assms degree_monic_mult leading_coeff_0_iff monic_degree_m monic_mult)

lemma factorization_m_degree: assumes "factorization_m f (c,fs)"
  and 0: "Mp f \<noteq> 0"
  shows "degree_m f = sum_mset (image_mset degree_m fs)"
proof -
  note a = assms[unfolded factorization_m_def split]
  hence deg: "degree_m f = degree_m (smult c (prod_mset fs))"
    and fs: "\<And> f. f \<in># fs \<Longrightarrow> monic (Mp f)" by auto
  define gs where "gs \<equiv> Mp (prod_mset fs)"
  from monic_Mp_prod_mset[OF fs] have mon_gs: "monic gs" unfolding gs_def .
  have d:"degree (Mp (Polynomial.smult c gs)) = degree gs"
  proof -
    have f1: "0 \<noteq> c" by (metis "0" Mp_0 a(1) smult_eq_0_iff)
    then have "M c \<noteq> 0" by (metis (no_types) "0" assms(1) factorization_m_lead_coeff leading_coeff_0_iff)
    then show "degree (Mp (Polynomial.smult c gs)) = degree gs"
      unfolding monic_degree_m[OF mon_gs,symmetric]
      using f1 by (metis coeff_smult degree_m_eq degree_smult_eq m1 mon_gs monic_degree_m mult_cancel_left1 poly_mod.M_def)
  qed
  note deg
  also have "degree_m (smult c (prod_mset fs)) = degree_m (smult c gs)"
    unfolding gs_def by simp
  also have "\<dots> = degree gs" using d.
  also have "\<dots> = sum_mset (image_mset degree_m fs)" unfolding gs_def
    using fs
  proof (induct fs)
    case (add f fs)
    have mon: "monic (Mp f)" "monic (Mp (prod_mset fs))" using monic_Mp_prod_mset[of fs]
      add(2) by auto
    have "degree (Mp (prod_mset (add_mset f fs))) = degree (Mp (Mp f * Mp (prod_mset fs)))"
      by (auto simp: ac_simps)
    also have "\<dots> = degree (Mp f) + degree (Mp (prod_mset fs))"
      by (rule degree_Mp_mult_monic[OF mon])
    also have "degree (Mp (prod_mset fs)) = sum_mset (image_mset degree_m fs)"
      by (rule add(1), insert add(2), auto)
    finally show ?case by (simp add: ac_simps)
  qed simp
  finally show ?thesis .
qed

lemma degree_m_mult_le: "degree_m (f * g) \<le> degree_m f + degree_m g"
  using degree_m_mult_le by auto

lemma degree_m_prod_mset_le: "degree_m (prod_mset fs) \<le> sum_mset (image_mset degree_m fs)"
proof (induct fs)
  case empty
  show ?case by simp
next
  case (add f fs)
  then show ?case using degree_m_mult_le[of f "prod_mset fs"] by auto
qed

end

context poly_mod_prime
begin

lemma unique_factorization_m_factor_partition: assumes l0: "l \<noteq> 0"
  and uf: "poly_mod.unique_factorization_m (p^l) f (lead_coeff f, mset gs)"
  and f: "f = f1 * f2"
  and cop: "coprime (lead_coeff f) p"
  and sf: "square_free_m f"
  and part: "List.partition (\<lambda>gi. gi dvdm f1) gs = (gs1, gs2)"
shows "poly_mod.unique_factorization_m (p^l) f1 (lead_coeff f1, mset gs1)"
  "poly_mod.unique_factorization_m (p^l) f2 (lead_coeff f2, mset gs2)"
proof -
  interpret pl: poly_mod_2 "p^l" by (standard, insert m1 l0, auto)
  let ?I = "image_mset pl.Mp"
  note Mp_pow [simp] = Mp_Mp_pow_is_Mp[OF l0 m1]
  have [simp]: "pl.Mp x dvdm u = (x dvdm u)" for x u unfolding dvdm_def using Mp_pow[of x]
    by (metis poly_mod.mult_Mp(1))
  have gs_split: "set gs = set gs1 \<union> set gs2" using part by auto
  from pl.unique_factorization_m_factor[OF prime uf[unfolded f] _ _ l0 refl, folded f, OF cop sf]
  obtain hs1 hs2 where uf': "pl.unique_factorization_m f1 (lead_coeff f1, hs1)"
      "pl.unique_factorization_m f2 (lead_coeff f2, hs2)"
    and gs_hs: "?I (mset gs) = hs1 + hs2"
    unfolding pl.Mf_def split by auto
  have gs_gs: "?I (mset gs) = ?I (mset gs1) + ?I (mset gs2)" using part
    by (auto, induct gs arbitrary: gs1 gs2, auto)
  with gs_hs have gs_hs12: "?I (mset gs1) + ?I (mset gs2) = hs1 + hs2" by auto
  note pl_dvdm_imp_p_dvdm = pl_dvdm_imp_p_dvdm[OF l0]
  note fact = pl.unique_factorization_m_imp_factorization[OF uf]
  have gs1: "?I (mset gs1) = {#x \<in># ?I (mset gs). x dvdm f1#}"
    using part by (auto, induct gs arbitrary: gs1 gs2, auto)
  also have "\<dots> = {#x \<in># hs1. x dvdm f1#} + {#x \<in># hs2. x dvdm f1#}" unfolding gs_hs by simp
  also have "{#x \<in># hs2. x dvdm f1#} = {#}"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    then obtain x where x: "x \<in># hs2" and dvd: "x dvdm f1" by fastforce
    from x gs_hs have "x \<in># ?I (mset gs)" by auto
    with fact[unfolded pl.factorization_m_def]
    have xx: "pl.irreducible\<^sub>d_m x" "monic x" by auto
    from square_free_m_prod_imp_coprime_m[OF sf[unfolded f]]
    have cop_h_f: "coprime_m f1 f2" by auto
    from pl.factorization_m_mem_dvdm[OF pl.unique_factorization_m_imp_factorization[OF uf'(2)], of x] x
    have "pl.dvdm x f2" by auto
    hence "x dvdm f2" by (rule pl_dvdm_imp_p_dvdm)
    from cop_h_f[unfolded coprime_m_def, rule_format, OF dvd this]
    have "x dvdm 1" by auto
    from dvdm_imp_degree_le[OF this xx(2) _ m1] have "degree x = 0" by auto
    with xx show False unfolding pl.irreducible\<^sub>d_m_def by auto
  qed
  also have "{#x \<in># hs1. x dvdm f1#} = hs1"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    from filter_mset_inequality[OF this]
    obtain x where x: "x \<in># hs1" and dvd: "\<not> x dvdm f1" by blast
    from pl.factorization_m_mem_dvdm[OF pl.unique_factorization_m_imp_factorization[OF uf'(1)],
      of x] x dvd
    have "pl.dvdm x f1" by auto
    from pl_dvdm_imp_p_dvdm[OF this] dvd show False by auto
  qed
  finally have gs_hs1: "?I (mset gs1) = hs1" by simp
  with gs_hs12 have "?I (mset gs2) = hs2" by auto
  with uf' gs_hs1 have "pl.unique_factorization_m f1 (lead_coeff f1, ?I (mset gs1))"
     "pl.unique_factorization_m f2 (lead_coeff f2, ?I (mset gs2))" by auto
  thus "pl.unique_factorization_m f1 (lead_coeff f1, mset gs1)"
     "pl.unique_factorization_m f2 (lead_coeff f2, mset gs2)"
    unfolding pl.unique_factorization_m_def
    by (auto simp: pl.Mf_def image_mset.compositionality o_def)
qed

lemma factorization_pn_to_factorization_p: assumes fact: "poly_mod.factorization_m (p^n) C (c,fs)"
  and sf: "square_free_m C"
  and n: "n \<noteq> 0"
shows "factorization_m C (c,fs)"
proof -
  let ?q = "p^n"
  from n m1 have q: "?q > 1" by simp
  interpret q: poly_mod_2 ?q by (standard, insert q, auto)
  from fact[unfolded q.factorization_m_def]
  have eq: "q.Mp C = q.Mp (Polynomial.smult c (prod_mset fs))"
    and irr: "\<And> f. f \<in># fs \<Longrightarrow> q.irreducible\<^sub>d_m f"
    and mon: "\<And> f. f \<in># fs \<Longrightarrow> monic (q.Mp f)"
    by auto
  from arg_cong[OF eq, of Mp]
  have eq: "eq_m C (smult c (prod_mset fs))"
    by (simp add: Mp_Mp_pow_is_Mp m1 n)
  show ?thesis unfolding factorization_m_def split
  proof (rule conjI[OF eq], intro ballI conjI)
    fix f
    assume f: "f \<in># fs"
    from mon[OF this] have mon_qf: "monic (q.Mp f)" .
    hence lc: "lead_coeff (q.Mp f) = 1" by auto
    from mon_qf show mon_f: "monic (Mp f)"
      by (metis Mp_Mp_pow_is_Mp m1 monic_Mp n)
    from irr[OF f] have irr: "q.irreducible\<^sub>d_m f" .
    hence "q.degree_m f \<noteq> 0" unfolding q.irreducible\<^sub>d_m_def by auto
    also have "q.degree_m f = degree_m f" using mon[OF f]
      by (metis Mp_Mp_pow_is_Mp m1 monic_degree_m n)
    finally have deg: "degree_m f \<noteq> 0" by auto
    from f obtain gs where fs: "fs = {#f#} + gs"
      by (metis mset_subset_eq_single subset_mset.add_diff_inverse)
    from eq[unfolded fs] have "Mp C = Mp (f * smult c (prod_mset gs))" by auto
    from square_free_m_factor[OF square_free_m_cong[OF sf this]]
    have sf_f: "square_free_m f" by simp
    have sf_Mf: "square_free_m (q.Mp f)"
      by (rule square_free_m_cong[OF sf_f], auto simp: Mp_Mp_pow_is_Mp n m1)
    have "coprime (lead_coeff (q.Mp f)) p" using mon[OF f] prime by simp
    from berlekamp_hensel[OF this sf_Mf refl n, unfolded lc] obtain gs where
      qfact: "q.factorization_m (q.Mp f) (1, mset gs)"
      and "\<And> g. g \<in> set gs \<Longrightarrow> irreducible_m g" by blast
    hence fact: "q.Mp f = q.Mp (prod_list gs)"
      and gs: "\<And> g. g\<in> set gs \<Longrightarrow> irreducible\<^sub>d_m g \<and> q.irreducible\<^sub>d_m g \<and> monic (q.Mp g)"
      unfolding q.factorization_m_def by auto
    from q.factorization_m_degree[OF qfact]
    have deg: "q.degree_m (q.Mp f) = sum_mset (image_mset q.degree_m (mset gs))"
      using mon_qf by fastforce
    from irr[unfolded q.irreducible\<^sub>d_m_def]
    have "sum_mset (image_mset q.degree_m (mset gs)) \<noteq> 0" by (fold deg, auto)
    then obtain g gs' where gs1: "gs = g # gs'" by (cases gs, auto)
    {
      assume "gs' \<noteq> []"
      then obtain h hs where gs2: "gs' = h # hs" by (cases gs', auto)
      from deg gs[unfolded q.irreducible\<^sub>d_m_def]
      have small: "q.degree_m g < q.degree_m f"
        "q.degree_m h + sum_mset (image_mset q.degree_m (mset hs)) < q.degree_m f"
        unfolding gs1 gs2 by auto
      have "q.eq_m f (g * (h * prod_list hs))"
        using fact unfolding gs1 gs2 by simp
      with irr[unfolded q.irreducible\<^sub>d_m_def, THEN conjunct2, rule_format, of g "h * prod_list hs"]
        small(1) have "\<not> q.degree_m (h * prod_list hs) < q.degree_m f" by auto
      hence "q.degree_m f \<le> q.degree_m (h * prod_list hs)" by simp
      also have "\<dots> = q.degree_m (prod_mset ({#h#} + mset hs))" by simp
      also have "\<dots> \<le> sum_mset (image_mset q.degree_m ({#h#} + mset hs))"
        by (rule q.degree_m_prod_mset_le)
      also have "\<dots> < q.degree_m f" using small(2) by simp
      finally have False by simp
    }
    hence gs1: "gs = [g]" unfolding gs1 by (cases gs', auto)
    with fact have "q.Mp f = q.Mp g" by auto
    from arg_cong[OF this, of Mp] have eq: "Mp f = Mp g"
      by (simp add: Mp_Mp_pow_is_Mp m1 n)
    from gs[unfolded gs1] have g: "irreducible\<^sub>d_m g" by auto
    with eq show "irreducible\<^sub>d_m f" unfolding irreducible\<^sub>d_m_def by auto
  qed
qed

    from sfAB have sfB: "square_free_m B" by (rule square_free_m_factor)
    from IH[OF lenH ufactB monB sfB] obtain Bs where
      IH2: "q.unique_factorization_m B (1, Bs)" by auto

    from CAB have "q.Mp C = q.Mp (q.Mp A * q.Mp B)" by simp
    also have "q.Mp A * q.Mp B = q.Mp A * q.Mp (prod_mset Bs)"
      using IH2 unfolding q.unique_factorization_m_alt_def q.factorization_m_def by auto
    also have "q.Mp \<dots> = q.Mp (A * prod_mset Bs)" by simp
    finally have factC: "q.factorization_m C (1, {# A #} + Bs)" using IH2 monA' irrA
      by (auto simp: q.unique_factorization_m_alt_def q.factorization_m_def)
    show ?thesis
    proof (rule exI, rule q.unique_factorization_mI[OF factC])
      fix d gs
      assume dgs: "q.factorization_m C (d,gs)"
      from pre_unique[OF dgs, unfolded add] have d1: "q.M d = 1" and
        gs_fs: "image_mset Mp gs = {# Mp D #} + image_mset Mp H" by (auto simp: ac_simps)
      have "\<forall>f m p ma. image_mset f m \<noteq> add_mset (p::int poly) ma \<or>
                (\<exists>mb pa. m = add_mset (pa::int poly) mb \<and> f pa = p \<and> image_mset f mb = ma)"
          by (simp add: msed_map_invR)
      then obtain g hs where gs: "gs = {# g #} + hs" and gD: "Mp g = Mp D"
        and hsH: "image_mset Mp hs = image_mset Mp H"
        using gs_fs by (metis add_mset_add_single union_commute)
      from dgs[unfolded q.factorization_m_def split]
      have eq: "q.Mp C = q.Mp (smult d (prod_mset gs))"
        and irr_mon: "\<And> g. g\<in>#gs \<Longrightarrow> q.irreducible\<^sub>d_m g \<and> monic (q.Mp g)"
        using d1 by auto
      note eq
      also have "q.Mp (smult d (prod_mset gs)) = q.Mp (smult (q.M d) (prod_mset gs))"
        by simp
      also have "\<dots> = q.Mp (prod_mset gs)" unfolding d1 by simp
      finally have eq: "q.eq_m (q.Mp g * q.Mp (prod_mset hs)) C" unfolding gs by simp
      from gD have Dg: "eq_m (Mp D) (q.Mp g)" by simp
      have "Mp (prod_mset H) = Mp (prod_mset (image_mset Mp H))" by simp
      also have "\<dots> = Mp (prod_mset hs)" unfolding hsH[symmetric] by simp
      finally have Hhs: "eq_m (Mp (prod_mset H)) (q.Mp (prod_mset hs))" by simp
      from irr_mon[of g, unfolded gs] have mon_g: "monic (q.Mp g)" by auto
      from unique[OF eq mon_g Dg Hhs q.Mp_Mp q.Mp_Mp]
      have gA: "q.Mp g = A" and hsB: "q.Mp (prod_mset hs) = B" by auto
      have "q.factorization_m B (1, hs)" unfolding q.factorization_m_def split
        by (simp add: hsB norm irr_mon[unfolded gs])
      with IH2 have hsBs: "q.Mf (1,hs) = q.Mf (1,Bs)" unfolding q.unique_factorization_m_alt_def by blast
      show "q.Mf (d, gs) = q.Mf (1, {# A #} + Bs)"
        using gA hsBs d1 unfolding gs q.Mf_def by auto
    qed
  qed
qed

theorem berlekamp_hensel_unique:
  assumes cop: "coprime (lead_coeff f) p"
  and sf: "poly_mod.square_free_m p f"
  and res: "berlekamp_hensel p n f = gs"
  and n: "n \<noteq> 0"
  shows "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs) \<comment> \<open>unique factorization mod \<open>p^n\<close>\<close>"
    "\<And> g. g \<in> set gs \<Longrightarrow> poly_mod.Mp (p^n) g = g   \<comment> \<open>normalized\<close>"
proof -
  let ?q = "p^n"
  interpret q: poly_mod_2 ?q unfolding poly_mod_2_def using m1 n by simp
  from berlekamp_hensel[OF assms]
  have bh_fact: "q.factorization_m f (lead_coeff f, mset gs)" by auto
  from berlekamp_hensel[OF assms]
  show "\<And> g. g \<in> set gs \<Longrightarrow> poly_mod.Mp (p^n) g = g" by blast
    from prime have p1: "p > 1" by (simp add: prime_int_iff)
  let ?lc = "coeff f (degree f)"
  define ilc where "ilc \<equiv> inverse_mod ?lc (p ^ n)"
  from cop p1 n have inv: "q.M (ilc * ?lc) = 1"
    by (auto simp add: q.M_def ilc_def inverse_mod_pow)
  hence ilc0: "ilc \<noteq> 0" by (cases "ilc = 0", auto)
  {
    fix q
    assume "ilc * ?lc = ?q * q"
    from arg_cong[OF this, of q.M] have "q.M (ilc * ?lc) = 0"
      unfolding q.M_def by auto
    with inv have False by auto
  } note not_dvd = this
  let ?in = "q.Mp (smult ilc f)"
  have mon: "monic ?in" unfolding q.Mp_coeff coeff_smult
    by (subst q.degree_m_eq[OF _ q.m1], insert not_dvd, auto simp: inv ilc0)
  have "q.Mp f = q.Mp (smult (q.M (?lc * ilc)) f)" using inv by (simp add: ac_simps)
  also have "\<dots> = q.Mp (smult ?lc (smult ilc f))" by simp
  finally have f: "q.Mp f = q.Mp (smult ?lc (smult ilc f))" .
  from arg_cong[OF f, of Mp]
  have "Mp f = Mp (smult ?lc (smult ilc f))"
    by (simp add: Mp_Mp_pow_is_Mp n p1)
  from arg_cong[OF this, of square_free_m, unfolded Mp_square_free_m] sf
  have "square_free_m (smult (coeff f (degree f)) (smult ilc f))" by simp
  from square_free_m_smultD[OF this] have sf: "square_free_m (smult ilc f)" .
  have Mp_in: "Mp ?in = Mp (smult ilc f)"
    by (simp add: Mp_Mp_pow_is_Mp n p1)
  from Mp_square_free_m[of ?in, unfolded Mp_in] sf have sf: "square_free_m ?in"
    unfolding Mp_square_free_m by simp
  obtain a b where "finite_field_factorization_int p ?in = (a,b)" by force
  from finite_field_factorization_int[OF sf this]
  have ufact: "unique_factorization_m ?in (a, mset b)" by auto
  from unique_factorization_m_imp_factorization[OF this]
  have fact: "factorization_m ?in (a, mset b)" .
  from factorization_m_lead_coeff[OF this] monic_Mp[OF mon]
  have "M a = 1" by auto
  with ufact have "unique_factorization_m ?in (1, mset b)"
    unfolding unique_factorization_m_def Mf_def by auto
  from unique_monic_hensel_factorization[OF this mon sf n]
  obtain hs where "q.unique_factorization_m ?in (1, hs)" by auto
  hence unique: "q.unique_factorization_m (smult ilc f) (1, hs)"
    unfolding unique_factorization_m_def Mf_def by auto
  from q.factorization_m_smult[OF q.unique_factorization_m_imp_factorization[OF unique], of ?lc]
  have "q.factorization_m (smult (ilc * ?lc) f) (?lc, hs)" by (simp add: ac_simps)
  moreover have "q.Mp (smult (q.M (ilc * ?lc)) f) = q.Mp f" unfolding inv by simp
  ultimately have fact: "q.factorization_m f (?lc, hs)"
    unfolding q.factorization_m_def by auto
  have "q.unique_factorization_m f (?lc, hs)"
  proof (rule q.unique_factorization_mI[OF fact])
    fix d us
    assume other_fact: "q.factorization_m f (d,us)"
    from q.factorization_m_lead_coeff[OF this] have lc: "q.M d = lead_coeff (q.Mp f)" ..
    have lc: "q.M d = q.M ?lc" unfolding lc
      by (metis bh_fact q.factorization_m_lead_coeff)
    from q.factorization_m_smult[OF other_fact, of ilc] unique
    have eq: "q.Mf (d * ilc, us) = q.Mf (1, hs)" unfolding q.unique_factorization_m_def by auto
    thus "q.Mf (d, us) = q.Mf (?lc, hs)" using lc unfolding q.Mf_def by auto
  qed
  with bh_fact show "q.unique_factorization_m f (lead_coeff f, mset gs)"
    unfolding q.unique_factorization_m_alt_def by metis
qed

lemma hensel_lifting_unique:
  assumes n: "n \<noteq> 0"
  and res: "hensel_lifting p n f fs = gs"                        \<comment> \<open>result of hensel is fact. \<open>gs\<close>\<close>
  and cop: "coprime (lead_coeff f) p"
  and sf: "poly_mod.square_free_m p f"
  and fact: "poly_mod.factorization_m p f (c, mset fs)"          \<comment> \<open>input is fact. \<open>fs mod p\<close>\<close>
  and c: "c \<in> {0..<p}"
  and norm: "(\<forall>fi\<in>set fs. set (coeffs fi) \<subseteq> {0..<p})"
shows "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs)" \<comment> \<open>unique factorization mod \<open>p^n\<close>\<close>
    "sort (map degree fs) = sort (map degree gs)"                       \<comment> \<open>degrees stay the same\<close>
    "\<And> g. g \<in> set gs \<Longrightarrow> monic g \<and> poly_mod.Mp (p^n) g = g \<and>    \<comment> \<open>monic and normalized\<close>
      poly_mod.irreducible_m p g \<and>                              \<comment> \<open>irreducibility even mod \<open>p\<close>\<close>
      poly_mod.degree_m p g = degree g   \<comment> \<open>mod \<open>p\<close> does not change degree of \<open>g\<close>\<close>"
proof -
  note hensel = hensel_lifting[OF assms]
  show "sort (map degree fs) = sort (map degree gs)"
    "\<And> g. g \<in> set gs \<Longrightarrow> monic g \<and> poly_mod.Mp (p^n) g = g \<and>
      poly_mod.irreducible_m p g \<and>
      poly_mod.degree_m p g = degree g" using hensel by auto
  from berlekamp_hensel_unique[OF cop sf refl n]
  have "poly_mod.unique_factorization_m (p ^ n) f (lead_coeff f, mset (berlekamp_hensel p n f))"  by auto
  with hensel(1) show "poly_mod.unique_factorization_m (p^n) f (lead_coeff f, mset gs)"
    by (metis poly_mod.unique_factorization_m_alt_def)
qed

end

end


theory EigbyzDefs
imports "../HOModel"
begin

section \<open>Verification of the \eigbyz{} Consensus Algorithm\<close>

text \<open>
  Lynch~\cite{lynch:distributed} presents \eigbyz{}, a version of
  the \emph{exponential information gathering} algorithm tolerating
  Byzantine faults, that works in $f$ rounds, and that was originally
  introduced in~\cite{bar-noy:shifting-gears}.

  We begin by introducing an anonymous type of processes of finite
  cardinality that will instantiate the type variable \<open>'proc\<close>
  of the generic HO model.
\<close>

typedecl Proc \<comment> \<open>the set of processes\<close>
axiomatization where Proc_finite: "OFCLASS(Proc, finite_class)"
instance Proc :: finite by (rule Proc_finite)

abbreviation
  "N \<equiv> card (UNIV::Proc set)"   \<comment> \<open>number of processes\<close>

text \<open>
  The algorithm is parameterized by $f$, which represents the number of
  rounds and the height of the tree data structure (see below).
\<close>

axiomatization f::nat
where f: "f < N"
(* NB: couldn't turn this into a locale, since f is used in the typedef below *)

subsection \<open>Tree Data Structure\<close>

text \<open>
  The algorithm relies on propagating information about the initially proposed
  values among all the processes. This information is stored in trees whose
  branches are labeled by lists of (distinct) processes. For example, the
  interpretation of an entry \<open>[p,q] \<mapsto> Some v\<close> is that the current
  process heard from process \<open>q\<close> that it had heard from process \<open>p\<close>
  that its proposed value is \<open>v\<close>. The value initially proposed by the process
  itself is stored at the root of the tree.

  We introduce the type of \emph{labels}, which encapsulate lists of distinct
  process identifiers and whose length is at most \<open>f+1\<close>.
\<close>

definition "Label = {xs::Proc list. length xs \<le> Suc f \<and> distinct xs}"
typedef Label = Label
  by (auto simp: Label_def intro: exI[where x= "[]"])  \<comment> \<open>the empty list is a label\<close>

text \<open>There is a finite number of different labels.\<close>

lemma finite_Label: "finite Label"
proof -
  have "Label \<subseteq> {xs. set xs \<subseteq> (UNIV::Proc set) \<and> length xs \<le> Suc f}"
    by (auto simp: Label_def)
  moreover
  have "finite {xs. set xs \<subseteq> (UNIV::Proc set) \<and> length xs \<le> Suc f}"
    by (rule finite_lists_length_le) auto
  ultimately
  show ?thesis by (auto elim: finite_subset)
qed

lemma finite_UNIV_Label: "finite (UNIV::Label set)"
proof -
  from finite_Label have "finite (Abs_Label ` Label)" by simp
  moreover
  {
    fix l::Label
    have "l \<in> Abs_Label ` Label"
      by (rule Abs_Label_cases) auto
  }
  hence "(UNIV::Label set) = (Abs_Label ` Label)" by auto
  ultimately show ?thesis by simp
qed

lemma finite_Label_set [iff]: "finite (S :: Label set)"
  using finite_UNIV_Label by (auto intro: finite_subset)

text \<open>Utility functions on labels.\<close>

definition root_node where
  "root_node \<equiv> Abs_Label []"

definition length_lbl where
  "length_lbl l \<equiv> length (Rep_Label l)"
(* Don't declare the following [simp] because it would then be simplified away from
   hypotheses, whereas it can be useful for arithmetic reasoning. *)
lemma length_lbl [intro]: "length_lbl l \<le> Suc f"
  unfolding length_lbl_def using Label_def Rep_Label by auto

definition is_leaf where
 "is_leaf l \<equiv> length_lbl l = Suc f"

definition last_lbl where
  "last_lbl l \<equiv> last (Rep_Label l)"

definition butlast_lbl where
  "butlast_lbl l \<equiv> Abs_Label (butlast (Rep_Label l))"

definition set_lbl where
  "set_lbl l = set (Rep_Label l)"

text \<open>
  The children of a non-leaf label are all possible extensions of that label.
\<close>
(**
definition children where
  "children t \<equiv> { s . s \<noteq> root_node \<and> t = butlast_lbl s }"
**)

definition children where
  "children l \<equiv>
   if is_leaf l
   then {}
   else { Abs_Label (Rep_Label l @ [p]) | p . p \<notin> set_lbl l }"

subsection \<open>Model of the Algorithm\<close>

text \<open>
  The following record models the local state of a process.
\<close>

record 'val pstate =
  vals :: "Label \<Rightarrow> 'val option"
  newvals :: "Label \<Rightarrow> 'val"
  decide :: "'val option"

text \<open>
  Initially, no values are assigned to non-root labels, and an arbitrary value
  is assigned to the root: that value is interpreted as the initial proposal of
  the process. No decision has yet been taken, and the \<open>newvals\<close> field
  is unconstrained.
\<close>

definition EIG_initState (*::"Proc \<Rightarrow> 'val pstate \<Rightarrow> bool"*) where
  "EIG_initState p st \<equiv>
     (\<forall>l. (vals st l = None) = (l \<noteq> root_node))
   \<and> decide st = None"

type_synonym 'val Msg = "Label \<Rightarrow> 'val option"

text \<open>
  At every round, every process sends its current \<open>vals\<close> tree to all processes.
  In fact, only the level of the tree corresponding to the round number
  is used (cf. definition of \<open>extend_vals\<close> below).
\<close>

definition EIG_sendMsg (*:: "nat \<Rightarrow> Proc \<Rightarrow> Proc \<Rightarrow> 'val pstate \<Rightarrow> 'val Msg"*) where
  "EIG_sendMsg r p q st \<equiv> vals st"

text \<open>
  During the first \<open>f-1\<close> rounds, every process extends its
  tree \<open>vals\<close> according to the values received in the round.
  No decision is taken.
\<close>

definition extend_vals where
  "extend_vals r p st msgs st' \<equiv>
   vals st' = (\<lambda> l.
      if length_lbl l = Suc r \<and> msgs (last_lbl l) \<noteq> None
      then (the (msgs (last_lbl l))) (butlast_lbl l)
      else if length_lbl l = Suc r \<and> msgs (last_lbl l) = None then None
      else vals st l)"

definition next_main where
  "next_main r p st msgs st' \<equiv> extend_vals r p st msgs st' \<and> decide st' = None"

text \<open>
  In the final round, in addition to extending the tree as described previously,
  processes construct the tree \<open>newvals\<close>, starting
  at the leaves. The values at the leaves are copied from \<open>vals\<close>,
  except that missing values \<open>None\<close> are replaced by the default value
  \<open>undefined\<close>. Moving up, if there exists a majority value among the
  children, it is assigned to the parent node, otherwise the parent node
  receives the default value \<open>undefined\<close>. The decision is set to the
  value computed for the root of the tree.
\<close>

fun fixupval :: "'val option \<Rightarrow> 'val" where
  "fixupval None = undefined"
| "fixupval (Some v) = v"

definition has_majority :: "'val \<Rightarrow> ('a \<Rightarrow> 'val) \<Rightarrow> 'a set \<Rightarrow> bool" where
  "has_majority v g S \<equiv> card {e \<in> S. g e = v} > (card S) div 2"

definition check_newvals :: "'val pstate \<Rightarrow> bool" where
  "check_newvals st \<equiv>
   \<forall>l. is_leaf l \<and> newvals st l = fixupval (vals st l)
     \<or> \<not>(is_leaf l) \<and>
       ( (\<exists>w. has_majority w (newvals st) (children l) \<and> newvals st l = w)
       \<or> (\<not>(\<exists>w. has_majority w (newvals st) (children l))
             \<and> newvals st l = undefined))"

definition next_end where
  "next_end r p st msgs st' \<equiv>
     extend_vals r p st msgs st'
   \<and> check_newvals st'
   \<and> decide st' = Some (newvals st' root_node)"

text \<open>
  The overall next-state relation is defined such that every process applies
  \<open>nextMain\<close> during rounds \<open>0\<close>, \ldots, \<open>f-1\<close>, and applies
  \<open>nextEnd\<close> during round \<open>f\<close>. After that, the algorithm terminates
  and nothing changes anymore.
\<close>
definition EIG_nextState where
  "EIG_nextState r \<equiv>
   if r < f then next_main r
   else if r = f then next_end r
   else (\<lambda>p st msgs st'. st' = st)"

subsection \<open>Communication Predicate for \eigbyz\<close>

text \<open>
  The secure kernel \<open>SKr\<close> w.r.t. given HO and SHO collections consists
  of the process from which every process receives the correct message.
\<close>

definition SKr :: "Proc HO \<Rightarrow> Proc HO \<Rightarrow> Proc set" where
  "SKr HO SHO \<equiv> { q . \<forall>p. q \<in> HO p \<inter> SHO p}"

text \<open>
  The secure kernel \<open>SK\<close> of an entire execution (i.e., for sequences of
  HO and SHO collections) is the intersection of the secure kernels for
  all rounds. Obviously, only the first \<open>f\<close> rounds really matter,
  since the algorithm terminates after that.
\<close>

definition SK :: "(nat \<Rightarrow> Proc HO) \<Rightarrow> (nat \<Rightarrow> Proc HO) \<Rightarrow> Proc set" where
  "SK HOs SHOs \<equiv> {q. \<forall>r. q \<in> SKr (HOs r) (SHOs r)}"

text \<open>
  The round-by-round predicate requires that the secure kernel at every round
  contains more than \<open>(N+f) div 2\<close> processes.
\<close>

definition EIG_commPerRd where
  "EIG_commPerRd HO SHO \<equiv> card (SKr HO SHO) > (N + f) div 2"

text \<open>
  The global predicate requires that the secure kernel for the entire
  execution contains at least \<open>N-f\<close> processes. Messages from these
  processes are always correctly received by all processes.
\<close>

definition EIG_commGlobal where
  "EIG_commGlobal HOs SHOs \<equiv> card (SK HOs SHOs) \<ge> N - f"

text \<open>
  The above communication predicates differ from Lynch's presentation of
  \eigbyz{}. In fact, the algorithm was originally designed for synchronous
  systems with reliable links and at most \<open>f\<close> faulty processes.
  In such a system, every process receives the correct message from at least
  the non-faulty processes at every round, and therefore the global predicate
  \<open>EIG_commGlobal\<close> is satisfied. The standard correctness
  proof assumes that $N>3f$, and therefore $N - f > (N + f) \div 2$.
  Since moreover, for any $r$, we obviously have
  \[
   \bigg(\bigcap_{p \in \Pi, r' \in \nat}\!\!\!\! SHO(p,r')\bigg)
   \ \subseteq\ \bigg(\bigcap_{p \in \Pi} SHO(p,r)\bigg),
  \]
  it follows that any execution of \eigbyz{} where $N>3f$ also satisfies
  \<open>EIG_commPerRd\<close> at any round. The standard correctness hypotheses thus imply
  our communication predicates.

  However, our proof shows that \eigbyz{} can indeed tolerate more
  transient faults than the standard bound can express. For example, consider the
  case where $N=5$ and $f=2$. Our predicates are satisfied in
  executions where two processes exhibit transient faults, but never fail
  simultaneously. Indeed, in such an execution, every process receives four
  correct messages at every round, hence \<open>EIG_commPerRd\<close> always holds.
  Also, \<open>EIG_commGlobal\<close> is satisfied because there are
  three processes from which every process receives the correct messages at all
  rounds. By our correctness proof, it follows that $EIGByz_f$ then
  achieves Consensus, unlike what one could expect from the standard correctness
  predicate. This observation underlines the interest of expressing assumptions
  about transient faults, as in the HO model.
\<close>

subsection \<open>The \eigbyz{} Heard-Of Machine\<close>

text \<open>
  We now define the non-coordinated SHO machine for \eigbyz{} by assembling
  the algorithm definition and its communication-predicate.
\<close>

definition EIG_SHOMachine where
  "EIG_SHOMachine = \<lparr>
    CinitState =  (\<lambda> p st crd. EIG_initState p st),
    sendMsg =  EIG_sendMsg,
    CnextState = (\<lambda> r p st msgs crd st'. EIG_nextState r p st msgs st'),
    SHOcommPerRd = EIG_commPerRd,
    SHOcommGlobal = EIG_commGlobal
   \<rparr>"

abbreviation "EIG_M \<equiv> (EIG_SHOMachine::(Proc, 'val pstate, 'val Msg) SHOMachine)"

end  (* theory EIGbyzDefs *)


theory PowerSum
  imports Main
begin

section\<open>Lemmas about Sums of Powers divided by their Base\<close>

text\<open>
The following lemmas speak about cases like
  \<open>(\<Sum>n\<in>A. b ^ n) div b\<close>
where @{term "(div)"} is integer division.

This is useful for example when for bit-shifting a number
\<open>X\<close> with binary representation \<open>x\<^sub>0 x\<^sub>1 x\<^sub>2 \<dots>\<close> such that \<open>X = x\<^sub>0 * 2^0 + x\<^sub>1 * 2^1 + x\<^sub>2 * 2^2 + \<dots>\<close>
we can say that
\<open>X >> 1 = (x\<^sub>0 * 2^0 + x\<^sub>1 * 2^1 + x\<^sub>2 * 2^2 + \<dots>) div 2 = x\<^sub>1 * 2^0 + x\<^sub>2 * 2^1 + \<dots>\<close>
so in this case:
 1. Filter out the summand where the exponent is 0
 2. Subtract 1 from all remaining exponents
\<close>

text\<open>
This is the generalization of step 1 above, filter out any summand that has no effect on the
result after dividing by the base.
\<close>
lemma power_sum_div_filter:
  fixes A :: "'a set" and b :: int
  assumes "card (Set.filter (\<lambda>n. f n = 0) A) \<le> 1" "finite A" "b > 1"
  shows "(\<Sum>n\<in>A. b ^ f n) div b = (\<Sum>n\<in>Set.filter (\<lambda>n. f n \<noteq> 0) A. b ^ f n) div b"
proof -
  have *: "(\<Sum>n\<in>A. b ^ f n) =
    (\<Sum>n\<in>Set.filter (\<lambda>n. f n \<noteq> 0) A. b ^ f n)
    + (\<Sum>n\<in>Set.filter (\<lambda>n. f n = 0) A. b ^ f n)"
    apply (subst sum.union_disjoint[of "Set.filter (\<lambda>n. f n \<noteq> 0) A" "Set.filter (\<lambda>n. f n = 0) A", THEN sym])
    using assms apply auto[3]
    apply (rule arg_cong[where f="sum (\<lambda>n. b ^ f n)"]) unfolding Set.filter_def by auto
  hence "(\<Sum>n\<in>A. b ^ f n) div b =
    (\<Sum>n\<in>Set.filter (\<lambda>n. f n \<noteq> 0) A. b ^ f n) div b
    + (\<Sum>n\<in>Set.filter (\<lambda>n. f n = 0) A. b ^ f n) div b"
    apply (subst *)
    apply (rule div_plus_div_distrib_dvd_left)
    apply (rule dvd_sum)
    by simp
  moreover have "(\<Sum>n\<in>Set.filter (\<lambda>n. f n = 0) A. b ^ f n) div b = 0"
  proof (cases "Set.filter (\<lambda>n. f n = 0) A = {}")
    case False
    hence "0 < card (Set.filter (\<lambda>n. f n = 0) A)"
      apply (subst card_gt_0_iff) using \<open>finite A\<close> by simp
    hence "is_singleton (Set.filter (\<lambda>n. f n = 0) A)"
      unfolding is_singleton_def apply (subst card_1_singleton_iff[THEN sym])
      using \<open>card _ \<le> 1\<close> using False by simp
    then obtain x where x: "Set.filter (\<lambda>n. f n = 0) A = {x}" by (rule is_singletonE)
    hence 0: "f x = 0" by auto
    then show ?thesis unfolding x using \<open>b > 1\<close> by simp
  qed simp
  ultimately show ?thesis by presburger
qed

text\<open>
Step 2, when there are no summands remaining where the exponent is 0,
one can subtract 1 from all remaining exponents to resolve the division.
\<close>
lemma power_sum_div_n0:
  fixes A :: "'a set" and b :: int
  assumes n0: "\<And>n. n \<in> A \<Longrightarrow> f n \<noteq> 0" and "b \<noteq> 0"
  shows "(\<Sum>n\<in>A. b ^ f n) div b = (\<Sum>n\<in>A. b ^ (f n - 1))"
proof -
  have *: "(\<Sum>n\<in>A. b ^ f n) = b * (\<Sum>n\<in>A. b ^ (f n - 1))"
    apply (subst sum_distrib_left)
    apply (subst power_eq_if)
    apply (rule sum.cong)
    apply standard
    using n0 by fastforce
  show ?thesis unfolding * using \<open>b \<noteq> 0\<close> by simp
qed

text\<open>Both steps combined\<close>
lemma power_sum_div:
  fixes A :: "'a set" and b :: int
  assumes "card (Set.filter (\<lambda>n. f n = 0) A) \<le> 1" "finite A" "b > 1"
  shows "(\<Sum>n\<in>A. b ^ f n) div b = (\<Sum>n\<in>Set.filter (\<lambda>n. f n \<noteq> 0) A. b ^ (f n - 1))"
  apply (subst power_sum_div_filter[OF assms])
  apply (rule power_sum_div_n0)
  using \<open>b > 1\<close> by auto

text\<open>Example usage for bit shifts\<close>
lemma "(\<Sum>n = 0..<length X. if X ! n then 2 ^ n else 0) div (2::int)
     = (\<Sum>n = 1..<length X. if X ! n then 2 ^ (n-1) else 0)"
proof -
  let ?A = "Set.filter ((!) X) {0..<length X}"
  let ?b = 2
  let ?f = "\<lambda>x. x"
  have s: "{a \<in> {a \<in> {0..<length X}. X ! a}. ?f a \<noteq> 0} = {a \<in> {1..<length X}. X ! a}" by auto
  have "(\<Sum>n = 0..<length X. if X ! n then 2 ^ n else 0) div (2::int) =
    (\<Sum>n\<in>?A. ?b ^ (?f n)) div 2"
    unfolding Set.filter_def by (subst sum.inter_filter[symmetric]) auto
  also have "\<dots> = (\<Sum>n\<in>Set.filter (\<lambda>n. ?f n \<noteq> 0) ?A. ?b ^ (?f n - 1))"
    apply (rule power_sum_div)
    apply (rule order.trans[where b="card (Set.filter (\<lambda>n. n = 0) {0..<length X})"])
    apply (rule card_mono)
    by (auto simp: card_le_Suc0_iff_eq)
  also have "\<dots> = (\<Sum>n = 1..<length X. if X ! n then 2 ^ (n-1) else 0)"
    unfolding Set.filter_def
    apply (subst sum.inter_filter[symmetric])
    unfolding s by auto
  finally show ?thesis .
qed

end


(*  Title:      HOL/Datatype_Examples/TreeFI.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Andrei Popescu, TU Muenchen
    Copyright   2012

Finitely branching possibly infinite trees.
*)

section \<open>Finitely Branching Possibly Infinite Trees\<close>

theory TreeFI
imports Main
begin

codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI list")

(* Tree reverse:*)
primcorec trev where
  "lab (trev t) = lab t"
| "sub (trev t) = map trev (rev (sub t))"

lemma treeFI_coinduct:
  assumes *: "phi x y"
  and step: "\<And>a b. phi a b \<Longrightarrow>
     lab a = lab b \<and>
     length (sub a) = length (sub b) \<and>
     (\<forall>i < length (sub a). phi (nth (sub a) i) (nth (sub b) i))"
  shows "x = y"
using * proof (coinduction arbitrary: x y)
  case (Eq_treeFI t1 t2)
  from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
  have "list_all2 phi (sub t1) (sub t2)"
  proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: list_induct2)
    case (Cons x xs y ys)
    note sub = Cons(3,4)[symmetric] and phi = mp[OF spec[OF Cons(5)], unfolded sub]
      and IH = Cons(2)[of "Tree (lab t1) (tl (sub t1))" "Tree (lab t2) (tl (sub t2))",
        unfolded sub, simplified]
    from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
  qed simp
  with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
qed

lemma trev_trev: "trev (trev tr) = tr"
  by (coinduction arbitrary: tr rule: treeFI_coinduct) (auto simp add: rev_map)

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_71
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun elem :: "Nat => Nat list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = (if x y z2 then True else elem y xs)"

fun t2 :: "Nat => Nat => bool" where
  "t2 y (Z) = False"
| "t2 (Z) (S z2) = True"
| "t2 (S x2) (S z2) = t2 x2 z2"

fun ins :: "Nat => Nat list => Nat list" where
  "ins y (nil2) = cons2 y (nil2)"
| "ins y (cons2 z2 xs) =
     (if t2 y z2 then cons2 y (cons2 z2 xs) else cons2 z2 (ins y xs))"

theorem property0 :
  "((~ (x y z)) ==> ((elem y (ins z xs)) = (elem y xs)))"
  oops

end


theory SDL imports Main                   (* Christoph Benzmüller & Xavier Parent, 2018 *)

begin  (* SDL: Standard Deontic Logic (Modal Logic D) *)
 typedecl i (*type for possible worlds*)  type_synonym \<sigma> = "(i\<Rightarrow>bool)"
 consts r::"i\<Rightarrow>i\<Rightarrow>bool" (infixr"r"70) (*Accessibility relation.*)  cw::i (*Current world.*)

 abbreviation mtop ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation mbot ("\<^bold>\<bottom>") where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
 abbreviation mnot ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation mand (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
 abbreviation mor  (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
 abbreviation mimp (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
 abbreviation mequ (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"
 abbreviation mobligatory ("OB") where "OB \<phi> \<equiv> \<lambda>w. \<forall>v. w r v \<longrightarrow> \<phi>(v)" (*obligatory*)
 abbreviation mpermissible ("PE") where "PE \<phi> \<equiv> \<^bold>\<not>(OB(\<^bold>\<not>\<phi>))" (*permissible*)
 abbreviation mimpermissible ("IM") where "IM \<phi> \<equiv> OB(\<^bold>\<not>\<phi>)"  (*impermissible*)
 abbreviation omissible ("OM") where "OM \<phi> \<equiv> \<^bold>\<not>(OB \<phi>)" (*omissible*)
 abbreviation moptional ("OP") where "OP \<phi> \<equiv> (\<^bold>\<not>(OB \<phi>) \<^bold>\<and>  \<^bold>\<not>(OB(\<^bold>\<not>\<phi>)))" (*optional*)

 abbreviation ddlvalid::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]105)      (*Global Validity*)
  where "\<lfloor>A\<rfloor> \<equiv> \<forall>w. A w"
 abbreviation ddlvalidcw::"\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>\<^sub>c\<^sub>w"[7]105)  (*Local Validity (in cw)*)
  where "\<lfloor>A\<rfloor>\<^sub>c\<^sub>w \<equiv> A cw"

(* The D axiom is postulated *)
 axiomatization where D: "\<lfloor>\<^bold>\<not> ((OB \<phi>) \<^bold>\<and> (OB (\<^bold>\<not> \<phi>)))\<rfloor>"

(* Meta-level study: D corresponds to seriality *)
 lemma "\<lfloor>\<^bold>\<not> ((OB \<phi>) \<^bold>\<and> (OB (\<^bold>\<not> \<phi>)))\<rfloor> \<longleftrightarrow> (\<forall>w. \<exists>v. w r v)" by auto

 lemma "\<lfloor>(OB \<phi>) \<^bold>\<rightarrow> (\<^bold>\<not> (OB (\<^bold>\<not> \<phi>)))\<rfloor>" using D by blast

 lemma assumes "\<lfloor>(OB \<phi>) \<^bold>\<rightarrow> (\<^bold>\<not> (OB (\<^bold>\<not> \<phi>)))\<rfloor>" shows  "\<lfloor>\<^bold>\<not> ((OB \<phi>) \<^bold>\<and> (OB (\<^bold>\<not> \<phi>)))\<rfloor>" using assms by blast

(* Standardised syntax: unary operator for obligation in SDL *)
abbreviation obligatorySDL::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>O\<^bold>\<langle>_\<^bold>\<rangle>") where "\<^bold>O\<^bold>\<langle>A\<^bold>\<rangle>  \<equiv>  OB A"
abbreviation obligatorySDL'::"\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<circle><_>") where "\<^bold>\<circle><A>  \<equiv>  OB A"

(* Consistency *)
  lemma True nitpick [satisfy] oops

 (* Unimportant *)
  sledgehammer_params [max_facts=20,timeout=20] (* Sets parameters for theorem provers *)
  nitpick_params [user_axioms,expect=genuine,show_all,format=2] (* ... and model finder. *)

end


\<^marker>\<open>creator "Johannes Hölzl"\<close>
\<^marker>\<open>contributor "Maximilian P.L. Haslbeck"\<close>
theory PGCL_Misc
imports MDP_Semantics
begin

subsection "Johannes"

lemma lfp_linear:
  assumes "b < 1"
  shows "lfp (\<lambda>r. a + b * r :: ennreal) = a / (1 - b)"
proof (rule antisym)
  show "lfp (\<lambda>r. a + b * r) \<le> a / (1 - b)"
  proof (intro lfp_lowerbound)
    show "a + b * (a / (1 - b)) \<le> a / (1 - b)"
      using \<open>b < 1\<close>
      by (cases a b rule: ennreal2_cases)
         (auto simp del: ennreal_1 ennreal_plus
               simp add: ennreal_1[symmetric] ennreal_mult[symmetric] ennreal_plus[symmetric]
                         ennreal_minus divide_ennreal ennreal_less_iff field_simps ennreal_top_divide)
  qed
  show "a / (1 - b) \<le> lfp (\<lambda>r. a + b * r)"
  proof (rule lfp_greatest)
    fix u show "a + b * u \<le> u \<Longrightarrow> a / (1 - b) \<le> u"
      using \<open>b < 1\<close>
      by (cases a b u rule: ennreal3_cases)
         (auto simp del: ennreal_1 ennreal_plus
               simp add: ennreal_1[symmetric] ennreal_mult[symmetric] ennreal_plus[symmetric]
                         ennreal_minus divide_ennreal ennreal_less_iff field_simps top_add top_unique)
  qed
qed

lemma lfp_linear_inf:
  assumes "b \<ge> 1" and "a > 0"
  shows "lfp (\<lambda>r. a + b * r :: ennreal) = \<infinity>"
proof (rule antisym)
  show "lfp (\<lambda>r. a + b * r :: ennreal) \<ge> \<infinity>"
  proof (rule lfp_greatest)
    fix u show "a + b * u \<le> u \<Longrightarrow> \<infinity> \<le> u"
      using \<open>b \<ge> 1\<close>  \<open>a > 0\<close>
      apply (cases a b u rule: ennreal3_cases)
      apply
           (auto simp del: ennreal_1 ennreal_plus
                 simp add: ennreal_1[symmetric] ennreal_mult[symmetric] ennreal_plus[symmetric]
                           ennreal_minus divide_ennreal ennreal_less_iff field_simps top_add top_unique)
      subgoal for a' b' u' using mult_right_mono by fastforce
      subgoal for a' u'
        by (metis add.right_neutral assms(2) ennreal_add_eq_top ennreal_neq_top ennreal_top_mult le_zero_eq not_gr_zero top.extremum_unique)
      done
  qed
  show "lfp (\<lambda>r. a + b * r :: ennreal) \<le> \<infinity>" by auto
qed

lemma lfp_parallel_induct[consumes 2, case_names bot step cont]:
  assumes f: "sup_continuous f" and g: "sup_continuous g"
  assumes bot: "R \<bottom> \<bottom>"
  assumes step: "\<And>x y. R x y \<Longrightarrow> R (f x) (g y)"
  assumes cont: "\<And>X Y. (\<And>i::nat. R (X i) (Y i)) \<Longrightarrow> mono X \<Longrightarrow> mono Y \<Longrightarrow> R (SUP i. X i) (SUP i. Y i)"
  shows "R (lfp f) (lfp g)"
  unfolding f[THEN sup_continuous_lfp] g[THEN sup_continuous_lfp]
proof (rule cont)
  show "incseq (\<lambda>i. (f ^^ i) \<bottom>)" "incseq (\<lambda>i. (g ^^ i) \<bottom>)"
    by (intro mono_funpow f[THEN sup_continuous_mono] g[THEN sup_continuous_mono])+
  show "R ((f ^^ i) \<bottom>) ((g ^^ i) \<bottom>)" for i
    by (induction i) (auto intro: bot step)
qed

subsection "misc"

lemma sup_continuous_wp: "sup_continuous (wp P)"
  by (induction P)
     (auto intro!: order_continuous_intros sup_continuous_lfp''[THEN sup_continuous_applyD]
           dest: sup_continuous_compose sup_continuous_applyD)

lemma mono_wp: "mono (wp P)"
  using sup_continuous_mono[OF sup_continuous_wp] .

subsection \<open>Angelic Weakest Preexpectation Transformer\<close>

primrec awp :: "'a pgcl \<Rightarrow> ('a \<Rightarrow> ennreal) \<Rightarrow> ('a \<Rightarrow> ennreal)"
where
  "awp Empty f = f"
| "awp Skip f = f"
| "awp Halt f = \<bottom>"
| "awp (Assign u) = (\<lambda>f x. \<integral>\<^sup>+y. f y \<partial>u x)"
| "awp (Seq c\<^sub>1 c\<^sub>2) f = awp c\<^sub>1 (awp c\<^sub>2 f)"
| "awp (Par c\<^sub>1 c\<^sub>2) f = (awp c\<^sub>1 f) \<squnion> (awp c\<^sub>2 f)"
| "awp (If g c\<^sub>1 c\<^sub>2) f = (\<lambda>x. if g x then awp c\<^sub>1 f x else awp c\<^sub>2 f x)"
| "awp (While g c) f = lfp (\<lambda>W x. (if g x then awp c W x else f x))"

lemma sup_continuous_awp: "sup_continuous (awp P)"
  by (induction P)
     (auto intro!: order_continuous_intros sup_continuous_lfp''[THEN sup_continuous_applyD]
           dest: sup_continuous_compose sup_continuous_applyD)

lemma mono_awp: "mono (awp P)"
  using sup_continuous_mono[OF sup_continuous_awp] .

end


theory Euclidean_Algorithm
  imports "ITree_VCG.ITree_VCG"
begin

zstore gcd_st =
  a :: int
  b :: int

procedure eucl "(A::int, B::int)" over gcd_st =
"(a, b) := (A, B) ;
 while a \<noteq> b inv a > 0 \<and> b > 0 \<and> gcd a b = gcd A B do
   if a > b
     then a := a - b
     else b := b - a
   fi
 od"

execute "eucl (2, 8)"
execute "eucl (12, 30)"

lemma eucl_correct: "\<^bold>{A > 0 \<and> B > 0\<^bold>} eucl (A, B) \<^bold>{a = gcd A B\<^bold>}"
  apply (vcg)
  apply (simp add: gcd_diff1)
  apply (metis gcd.commute gcd_diff1)
  done

end


(*  Authors:  Klaus Aehlig, Tobias Nipkow *)

section \<open>Testing implementation of normalization by evaluation\<close>

theory Normalization_by_Evaluation
imports Complex_Main
begin

lemma "True" by normalization
lemma "p \<longrightarrow> True" by normalization
declare disj_assoc [code nbe]
lemma "((P | Q) | R) = (P | (Q | R))" by normalization
lemma "0 + (n::nat) = n" by normalization
lemma "0 + Suc n = Suc n" by normalization
lemma "Suc n + Suc m = n + Suc (Suc m)" by normalization
lemma "~((0::nat) < (0::nat))" by normalization

datatype n = Z | S n

primrec add :: "n \<Rightarrow> n \<Rightarrow> n" where
   "add Z = id"
 | "add (S m) = S o add m"

primrec add2 :: "n \<Rightarrow> n \<Rightarrow> n" where
   "add2 Z n = n"
 | "add2 (S m) n = S(add2 m n)"

declare add2.simps [code]
lemma [code nbe]: "add2 (add2 n m) k = add2 n (add2 m k)"
  by (induct n) auto

lemma "add2 (add2 n m) k = add2 n (add2 m k)" by normalization
lemma "add2 (add2 (S n) (S m)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization
lemma "add2 (add2 (S n) (add2 (S m) Z)) (S k) = S(S(S(add2 n (add2 m k))))" by normalization

primrec mul :: "n \<Rightarrow> n \<Rightarrow> n" where
   "mul Z = (%n. Z)"
 | "mul (S m) = (%n. add (mul m n) n)"

primrec mul2 :: "n \<Rightarrow> n \<Rightarrow> n" where
   "mul2 Z n = Z"
 | "mul2 (S m) n = add2 n (mul2 m n)"

primrec exp :: "n \<Rightarrow> n \<Rightarrow> n" where
   "exp m Z = S Z"
 | "exp m (S n) = mul (exp m n) m"

lemma "mul2 (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization
lemma "mul (S(S(S(S(S Z))))) (S(S(S Z))) = S(S(S(S(S(S(S(S(S(S(S(S(S(S(S Z))))))))))))))" by normalization
lemma "exp (S(S Z)) (S(S(S(S Z)))) = exp (S(S(S(S Z)))) (S(S Z))" by normalization

lemma "(let ((x,y),(u,v)) = ((Z,Z),(Z,Z)) in add (add x y) (add u v)) = Z" by normalization
lemma "case_prod (%x y. x) (a, b) = a" by normalization
lemma "(%((x,y),(u,v)). add (add x y) (add u v)) ((Z,Z),(Z,Z)) = Z" by normalization

lemma "case Z of Z \<Rightarrow> True | S x \<Rightarrow> False" by normalization

lemma "[] @ [] = []" by normalization
lemma "map f [x,y,z::'x] = [f x, f y, f z]" by normalization
lemma "[a, b, c] @ xs = a # b # c # xs" by normalization
lemma "[] @ xs = xs" by normalization
lemma "map (%f. f True) [id, g, Not] = [True, g True, False]" by normalization

lemma "map (%f. f True) ([id, g, Not] @ fs) = [True, g True, False] @ map (%f. f True) fs"
  by normalization rule
lemma "rev [a, b, c] = [c, b, a]" by normalization
value [nbe] "rev (a#b#cs) = rev cs @ [b, a]"
value [nbe] "map (%F. F [a,b,c::'x]) (map map [f,g,h])"
value [nbe] "map (%F. F ([a,b,c] @ ds)) (map map ([f,g,h]@fs))"
value [nbe] "map (%F. F [Z,S Z,S(S Z)]) (map map [S,add (S Z),mul (S(S Z)),id])"
lemma "map (%x. case x of None \<Rightarrow> False | Some y \<Rightarrow> True) [None, Some ()] = [False, True]"
  by normalization
value [nbe] "case xs of [] \<Rightarrow> True | x#xs \<Rightarrow> False"
value [nbe] "map (%x. case x of None \<Rightarrow> False | Some y \<Rightarrow> True) xs = P"
lemma "let x = y in [x, x] = [y, y]" by normalization
lemma "Let y (%x. [x,x]) = [y, y]" by normalization
value [nbe] "case n of Z \<Rightarrow> True | S x \<Rightarrow> False"
lemma "(%(x,y). add x y) (S z,S z) = S (add z (S z))" by normalization
value [nbe] "filter (%x. x) ([True,False,x]@xs)"
value [nbe] "filter Not ([True,False,x]@xs)"

lemma "[x,y,z] @ [a,b,c] = [x, y, z, a, b, c]" by normalization
lemma "(%(xs, ys). xs @ ys) ([a, b, c], [d, e, f]) = [a, b, c, d, e, f]" by normalization
lemma "map (%x. case x of None \<Rightarrow> False | Some y \<Rightarrow> True) [None, Some ()] = [False, True]" by normalization

lemma "last [a, b, c] = c" by normalization
lemma "last ([a, b, c] @ xs) = last (c # xs)" by normalization

lemma "(2::int) + 3 - 1 + (- k) * 2 = 4 + - k * 2" by normalization
lemma "(-4::int) * 2 = -8" by normalization
lemma "\<bar>(-4::int) + 2 * 1\<bar> = 2" by normalization
lemma "(2::int) + 3 = 5" by normalization
lemma "(2::int) + 3 * (- 4) * (- 1) = 14" by normalization
lemma "(2::int) + 3 * (- 4) * 1 + 0 = -10" by normalization
lemma "(2::int) < 3" by normalization
lemma "(2::int) <= 3" by normalization
lemma "\<bar>(-4::int) + 2 * 1\<bar> = 2" by normalization
lemma "4 - 42 * \<bar>3 + (-7::int)\<bar> = -164" by normalization
lemma "(if (0::nat) \<le> (x::nat) then 0::nat else x) = 0" by normalization
lemma "4 = Suc (Suc (Suc (Suc 0)))" by normalization
lemma "nat 4 = Suc (Suc (Suc (Suc 0)))" by normalization
lemma "[Suc 0, 0] = [Suc 0, 0]" by normalization
lemma "max (Suc 0) 0 = Suc 0" by normalization
lemma "(42::rat) / 1704 = 1 / 284 + 3 / 142" by normalization
value [nbe] "Suc 0 \<in> set ms"

(* non-left-linear patterns, equality by extensionality *)

lemma "f = f" by normalization
lemma "f x = f x" by normalization
lemma "(f o g) x = f (g x)" by normalization
lemma "(f o id) x = f x" by normalization
lemma "(id :: bool \<Rightarrow> bool) = id" by normalization
value [nbe] "(\<lambda>x. x)"

(* Church numerals: *)

value [nbe] "(%m n f x. m f (n f x)) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"
value [nbe] "(%m n f x. m (n f) x) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"
value [nbe] "(%m n. n m) (%f x. f(f(f(x)))) (%f x. f(f(f(x))))"

(* handling of type classes in connection with equality *)

lemma "map f [x, y] = [f x, f y]" by normalization
lemma "(map f [x, y], w) = ([f x, f y], w)" by normalization
lemma "map f [x, y] = [f x :: 'a::semigroup_add, f y]" by normalization
lemma "map f [x :: 'a::semigroup_add, y] = [f x, f y]" by normalization
lemma "(map f [x :: 'a::semigroup_add, y], w :: 'b::finite) = ([f x, f y], w)" by normalization

end


theory "FMap-Nominal"
  imports FMap "Nominal-Utils"
begin

subsubsection {* Permtuations on finite maps *}

instantiation "fmap" :: (pt,pt) pt
begin
  lift_definition permute_fmap :: "perm \<Rightarrow> 'a::pt f\<rightharpoonup> 'b::pt \<Rightarrow> 'a f\<rightharpoonup> 'b"
    is "\<lambda> p f . p \<bullet> f" by (metis (full_types) dom_perm_rev permute_finite)

  instance
  apply(default)
  apply(transfer, simp)+
  done
end

subsubsection {* Equivariance lemmas related to finite maps *}

lemma lookup_eqvt[eqvt]:
  "\<pi> \<bullet> lookup m x = lookup (\<pi> \<bullet> m) (\<pi> \<bullet> x)"
  by transfer simp

lemma the_lookup_eqvt:
  "x \<in> fdom m \<Longrightarrow> \<pi> \<bullet> (m f! x) = (\<pi> \<bullet> m) f! (\<pi> \<bullet> x)"
  apply (transfer fixing: x)
  apply auto
  by (metis Some_eqvt permute_fun_app_eq the.simps)

lemma the_lookup_perm[simp]:
  fixes \<rho> :: "'a::at_base f\<rightharpoonup> 'b::pure"
  shows "((x' \<leftrightarrow> x) \<bullet> \<rho>) f! xa = \<rho> f! ((x' \<leftrightarrow> x) \<bullet> xa) "
  by (metis lookup_eqvt permute_flip_cancel permute_pure)

lemma fempty_eqvt[eqvt, simp]:
  "\<pi> \<bullet> fempty = fempty"
  by (transfer, auto simp add: permute_fun_def)

lemma fempty_supp[simp]: "supp fempty = {}"
  by (metis eqvtI fempty_eqvt supp_fun_eqvt)

lemma fempty_fresh[simp]: "a \<sharp> fempty"
  by (simp add: fresh_def)

lemma fempty_fresh_star[simp]: "a \<sharp>* fempty"
  by (simp add: fresh_star_def)

lemma fdom_perm: "fdom (\<pi> \<bullet> f) = \<pi> \<bullet> (fdom f)"
  apply transfer by (rule dom_perm)
lemmas fdom_perm_rev[simp,eqvt] = fdom_perm[symmetric]

lemma mem_fdom_perm[simp]:
  fixes \<rho> :: "'a::at_base f\<rightharpoonup> 'b::pure"
  shows "xa \<in> fdom (p \<bullet> \<rho>) \<longleftrightarrow> - p \<bullet> xa \<in> fdom \<rho>"
  by (metis (mono_tags) fdom_perm_rev mem_Collect_eq permute_set_eq)

lemma fmap_upd_eqvt[eqvt]: "p \<bullet> (fmap_upd f x y) = fmap_upd (p \<bullet> f) (p \<bullet> x) (p \<bullet> y)"
  by transfer (metis Some_eqvt fun_upd_eqvt)

lemma fmap_restr_eqvt[eqvt]:
  "\<pi> \<bullet> (fmap_restr d m) = fmap_restr (\<pi> \<bullet> d) (\<pi> \<bullet> m)"
proof
case goal1 thus ?case by (metis fdom_fmap_restr fdom_perm_rev inter_eqvt)
case goal2
  from goal2 have "x \<in> \<pi> \<bullet> fdom m \<inter> \<pi> \<bullet> d" by (metis (full_types) fdom_fmap_restr fdom_perm_rev inter_eqvt)
  then obtain y where "x = \<pi> \<bullet> y" and "y \<in> fdom m \<inter> d" by (auto simp add: permute_set_def)

  have "(\<pi> \<bullet> fmap_restr d m) f! x = (\<pi> \<bullet> fmap_restr d m) f! (\<pi> \<bullet> y)" by (simp add: `x = _`)
  also have "... = \<pi> \<bullet> ((fmap_restr d m) f! y)" using  `y \<in> fdom m \<inter> d` by (metis fdom_fmap_restr the_lookup_eqvt)
  also have "... = \<pi> \<bullet> (m f! y)" using `y \<in> _` by simp
  also have "... = (\<pi> \<bullet> m) f! x" using `x = _` `y \<in> _` by (simp add: the_lookup_eqvt)
  also have "... = fmap_restr (\<pi> \<bullet> d) (\<pi> \<bullet> m) f! x" using `x \<in> _ \<inter> _` by simp
  finally show ?case.
qed

lemma fmap_delete_eqvt[eqvt]:
  "\<pi> \<bullet> fmap_delete x m = fmap_delete (\<pi> \<bullet> x) (\<pi> \<bullet> m)"
  by transfer simp

lemma fmap_copy_eqvt[eqvt]:
  "\<pi> \<bullet> fmap_copy m a b = fmap_copy (\<pi> \<bullet> m) (\<pi> \<bullet> a) (\<pi> \<bullet> b)"
  by transfer simp

lemma fun_merge_eqvt[eqvt]:
  "\<pi> \<bullet> m1 f++ m2 = (\<pi> \<bullet> m1) f++ (\<pi> \<bullet> m2)"
  by transfer simp

lemma fmap_of_eqvt[eqvt]:
  "\<pi> \<bullet> fmap_of l = fmap_of (\<pi> \<bullet> l)"
by transfer (rule map_of_eqvt)

lemma fmap_map_eqvt[eqvt]:
  "\<pi> \<bullet> fmap_map f m = fmap_map (\<pi> \<bullet> f) (\<pi> \<bullet> m)"
by transfer simp

subsubsection {* Permutation and restriction *}

lemma fmap_restr_perm:
  fixes \<rho> :: "'a::at f\<rightharpoonup> 'b::pure"
  assumes "supp p \<sharp>* S" and [simp]: "finite S"
  shows "(p \<bullet> \<rho>) f|` S = \<rho> f|` S"
using assms
apply transfer
apply rule
apply (case_tac "x \<in> S")
apply (simp)
apply (subst permute_fun_def)
apply (simp add: permute_pure)
apply (subst perm_supp_eq)
apply (auto simp add:perm_supp_eq supp_minus_perm fresh_star_def fresh_def supp_set_elem_finite)
done

lemma fmap_restr_flip:
  fixes \<rho> :: "'a::at f\<rightharpoonup> 'b::pure"
  assumes "x \<notin> S" and "x' \<notin> S"
  shows "((x' \<leftrightarrow> x) \<bullet> \<rho>) f|` S = \<rho> f|` S"
  using assms
  by (auto simp add: permute_flip_at  split:if_splits)

end


theory Chapter10_3
imports
  "~~/src/HOL/IMP/Live"
  "~~/src/HOL/IMP/Small_Step"
begin

text{*
\exercise
Prove the following termination-insensitive version of the correctness of
@{const L}:
*}

theorem "\<lbrakk> (c,s) \<Rightarrow> s';  (c,t) \<Rightarrow> t';  s = t on L c X \<rbrakk> \<Longrightarrow> s' = t' on X"
(* your definition/proof here *)

text{*
Do not derive it as a corollary of the original correctness theorem
but prove it separately. Hint: modify the original proof.
\endexercise

\exercise\label{exe:bury-not-idemp}
Find a command @{text c} such that @{prop"bury (bury c {}) {} \<noteq> bury c {}"}.
For an arbitrary command, can you put a limit on the amount of burying needed
until everything that is dead is also buried?
*}

text{*
\endexercise

\exercise
Let @{term"lvars c"} / @{term"rvars c"} be the set of variables that
occur on the left-hand / right-hand side of an assignment in @{text c}.
Let @{term "rvars c"} additionally including those variables mentioned in
the conditionals of @{text IF} and @{text WHILE}.
Both functions are predefined in theory @{theory Vars}.
Show the following two properties of the small-step semantics.
Variables that are not assigned to do not change their value:
*}

lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); lvars c \<inter> X = {}\<rbrakk> \<Longrightarrow> s = s' on X"
(* your definition/proof here *)

text{*
The reduction behaviour of a command is only influenced by the variables
read by the command:
*}

lemma "\<lbrakk>(c,s) \<rightarrow>* (c',s'); s = t on X; rvars c \<subseteq> X\<rbrakk>
  \<Longrightarrow> \<exists>t'. (c,t) \<rightarrow>* (c',t') \<and> s' = t' on X"
(* your definition/proof here *)

text{*
Hint: prove single step versions of the lemmas first.
\endexercise

\exercise
An \concept{available definitions} analysis determines which previous
assignments \texttt{x := a} are valid equalities \texttt{x = a} at later
program points.  For example, after \texttt{x := y+1} the equality \texttt{x =
y+1} is available, but after \mbox{\texttt{x := y+1;}} \texttt{y := 2} the equality \texttt{x = y+1} is
no longer available. The motivation for the analysis is that if \texttt{x =
a} is available before \texttt{v := a} then \mbox{\texttt{v := a}} can be replaced by
\texttt{v := x}.

Define an available definitions analysis as a gen/kill analysis,
for suitably defined @{text gen} and @{text kill} (which may need to be
mutually recursive):
*}
hide_const (open) gen "kill"
fun gen :: "com \<Rightarrow> (vname * aexp) set"
and "kill" :: "com \<Rightarrow> (vname * aexp) set" where
(* your definition/proof here *)

definition AD :: "(vname * aexp) set \<Rightarrow> com \<Rightarrow> (vname * aexp) set" where
"AD A c = gen c \<union> (A - kill c)"

text{*
The defining equations for both @{const gen} and @{const kill} follow
the \isacom{where} and are separated by ``@{text "|"}'' as usual.

A call \ @{term"AD A c"} \ should compute the available definitions
after the execution of @{text c} assuming that the definitions in @{text A}
are available before the execution of @{text c}.

Prove correctness of the analysis:
*}

theorem "\<lbrakk> (c,s) \<Rightarrow> s';  \<forall> (x,a) \<in> A. s x = aval a s \<rbrakk>
  \<Longrightarrow> \<forall> (x,a) \<in> AD A c. s' x = aval a s'"
(* your definition/proof here *)

text{*
\endexercise
*}

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
subsection \<open>Order of Polynomial Roots\<close>

text \<open>We extend the collection of results on the order of roots of polynomials.
  Moreover, we provide code-equations to compute the order for a given root and
polynomial.\<close>

theory Order_Polynomial
imports
  Polynomial_Interpolation.Missing_Polynomial
begin

lemma order_linear[simp]: "order a [:- a, 1:] = Suc 0" unfolding order_def
proof (rule Least_equality, intro notI)
  assume "[:- a, 1:] ^ Suc (Suc 0) dvd [:- a, 1:]"
  from dvd_imp_degree_le[OF this] show False by auto
next
  fix n
  assume *: "\<not> [:- a, 1:] ^ Suc n dvd [:- a, 1:]"
  thus "Suc 0 \<le> n"
    by (cases n, auto)
qed

declare order_power_n_n[simp]

lemma linear_power_nonzero: "[: a, 1 :] ^ n \<noteq> 0"
proof
  assume "[: a, 1 :]^n = 0"
  with arg_cong[OF this, of degree, unfolded degree_linear_power]
  show False by auto
qed

lemma order_linear_power': "order a ([: b, 1:]^Suc n) = (if b = -a then Suc n else 0)"
proof (cases "b = -a")
  case True
  thus ?thesis unfolding True order_power_n_n by simp
next
  case False
  let ?p = "[: b, 1:]^Suc n"
  from linear_power_nonzero have "?p \<noteq> 0" .
  have p: "?p = (\<Prod>a\<leftarrow> replicate (Suc n) b. [:a, 1:])" by auto
  {
    assume "order a ?p \<noteq> 0"
    then obtain m where ord: "order a ?p = Suc m" by (cases "order a ?p", auto)
    from order[OF \<open>?p \<noteq> 0\<close>, of a, unfolded ord] have dvd: "[:- a, 1:] ^ Suc m dvd ?p" by auto
    from poly_linear_exp_linear_factors[OF dvd[unfolded p]] False have False by auto
  }
  hence "order a ?p = 0" by auto
  with False show ?thesis by simp
qed

lemma order_linear_power: "order a ([: b, 1:]^n) = (if b = -a then n else 0)"
proof (cases n)
  case (Suc m)
  show ?thesis unfolding Suc order_linear_power' by simp
qed simp

lemma order_linear': "order a [: b, 1:] = (if b = -a then 1 else 0)"
  using order_linear_power'[of a b 0] by simp

lemma degree_div_less:
  assumes p: "(p::'a::field poly) \<noteq> 0" and dvd: "r dvd p" and deg: "degree r \<noteq> 0"
  shows "degree (p div r) < degree p"
proof -
  from dvd obtain q where prq: "p = r * q" unfolding dvd_def by auto
  have "degree p = degree r + degree q"
    unfolding prq
    by (rule degree_mult_eq, insert p prq, auto)
  with deg have deg: "degree q < degree p" by auto
  from prq have "q = p div r"
    using deg p by auto
  with deg show ?thesis by auto
qed

lemma order_sum_degree: assumes "p \<noteq> 0"
  shows "sum (\<lambda> a. order a p) { a. poly p a = 0 } \<le> degree p"
proof -
  define n where "n = degree p"
  have "degree p \<le> n" unfolding n_def by auto
  thus ?thesis using \<open>p \<noteq> 0\<close>
  proof (induct n arbitrary: p)
    case (0 p)
    define a where "a = coeff p 0"
    from 0 have "degree p = 0" by auto
    hence p: "p = [: a :]" unfolding a_def
      by (metis degree_0_id)
    with 0 have "a \<noteq> 0" by auto
    thus ?case unfolding p by auto
  next
    case (Suc m p)
    note order = order[OF \<open>p \<noteq> 0\<close>]
    show ?case
    proof (cases "\<exists> a. poly p a = 0")
      case True
      then obtain a where root: "poly p a = 0" by auto
      with order_root[of p a] Suc obtain n where orda: "order a p = Suc n"
        by (cases "order a p", auto)
      let ?a = "[: -a, 1 :] ^ Suc n"
      from order_decomp[OF \<open>p \<noteq> 0\<close>, of a, unfolded orda]
        obtain q where p: "p = ?a * q" and ndvd: "\<not> [:- a, 1:] dvd q" by auto
      from \<open>p \<noteq> 0\<close>[unfolded p] have nz: "?a \<noteq> 0" "q \<noteq> 0" by auto
      hence deg: "degree p = degree ?a + degree q" unfolding p
        by (subst degree_mult_eq, auto)
      have ord: "\<And> a. order a p = order a ?a + order a q"
        unfolding p
        by (subst order_mult, insert nz, auto)
      have roots: "{ a. poly p a = 0 } = insert a ({ a. poly q a = 0} - {a})" using root
        unfolding p poly_mult by auto
      have fin: "finite {a. poly q a = 0}" by (rule poly_roots_finite[OF \<open>q \<noteq> 0\<close>])
      have "Suc n = order a p" using orda by simp
      also have "\<dots> = Suc n + order a q" unfolding ord order_linear_power' by simp
      finally have "order a q = 0" by auto
      with order_root[of q a] \<open>q \<noteq> 0\<close> have qa: "poly q a \<noteq> 0" by auto
      have "(\<Sum>a\<in>{a. poly q a = 0} - {a}. order a p) = (\<Sum>a\<in>{a. poly q a = 0} - {a}. order a q)"
      proof (rule sum.cong[OF refl])
        fix b
        assume "b \<in> {a. poly q a = 0} - {a}"
        hence "b \<noteq> a" by auto
        hence "order b ?a = 0" unfolding order_linear_power' by simp
        thus "order b p = order b q" unfolding ord by simp
      qed
      also have "\<dots> = (\<Sum>a\<in>{a. poly q a = 0}. order a q)" using qa by auto
      also have "\<dots> \<le> degree q"
        by (rule Suc(1)[OF _ \<open>q \<noteq> 0\<close>],
        insert deg[unfolded degree_linear_power] Suc(2), auto)
      finally have "(\<Sum>a\<in>{a. poly q a = 0} - {a}. order a p) \<le> degree q" .
      thus ?thesis unfolding roots deg using fin
        by (subst sum.insert, simp_all only: degree_linear_power, auto simp: orda)
    qed auto
  qed
qed

lemma order_code[code]: "order (a::'a::idom_divide) p =
  (if p = 0 then Code.abort (STR ''order of polynomial 0 undefined'') (\<lambda> _. order a p)
   else if poly p a \<noteq> 0 then 0 else Suc (order a (p div [: -a, 1 :])))"
proof (cases "p = 0")
  case False note p = this
  note order = order[OF p]
  show ?thesis
  proof (cases "poly p a = 0")
    case True
    with order_root[of p a] p obtain n where ord: "order a p = Suc n"
      by (cases "order a p", auto)
    from this(1) have "[: -a, 1 :] dvd p"
      using True poly_eq_0_iff_dvd by blast
    then obtain q where p: "p = [: -a, 1 :] * q" unfolding dvd_def by auto
    have ord: "order a p = order a [: -a, 1 :] + order a q"
      using p False order_mult[of "[: -a, 1 :]" q] by auto
    have q: "p div [: -a, 1 :] = q" using False p
      by (metis mult_zero_left nonzero_mult_div_cancel_left)
    show ?thesis unfolding ord q using False True by auto
  next
    case False
    with order_root[of p a] p show ?thesis by auto
  qed
qed auto

end