section \<open>Extended integers (i.e. with infinity)\<close>

text\<open>
  This section formalizes the extended integers, which serve as the codomain for the $p$-adic
  valuation. The element $\infty$ is added to the integers to serve as a maximxal element in the
  order, which is the valuation of $0$.
\<close>

theory Extended_Int
imports Main "HOL-Library.Countable" "HOL-Library.Order_Continuity" "HOL-Library.Extended_Nat"
begin

text\<open>
  The following is based very closely on the theory \<^theory>\<open>HOL-Library.Extended_Nat\<close> from the
  standard Isabelle distribution, with adaptations made to formalize the integers extended with
  an element for infinity. This is the standard range for the valuation function on a discretely
  valued ring such as the field of $p$-adic numbers, such as in \<^cite>\<open>"engler2005valued"\<close>.
\<close>

context
  fixes f :: "nat \<Rightarrow> 'a::{canonically_ordered_monoid_add, linorder_topology, complete_linorder}"
begin

lemma sums_SUP[simp, intro]: "f sums (SUP n. \<Sum>i<n. f i)"
  unfolding sums_def by (intro LIMSEQ_SUP monoI sum_mono2 zero_le) auto

lemma suminf_eq_SUP: "suminf f = (SUP n. \<Sum>i<n. f i)"
  using sums_SUP by (rule sums_unique[symmetric])

end

subsection \<open>Type definition\<close>

text \<open>
  We extend the standard natural numbers by a special value indicating
  infinity.
\<close>

typedef eint = "UNIV :: int option set" ..

definition eint :: "int \<Rightarrow> eint" where
  "eint n = Abs_eint (Some n)"

instantiation eint :: infinity
begin

definition "\<infinity> = Abs_eint None"
instance ..

end

fun int_option_enumeration :: "int option \<Rightarrow> nat" where
"int_option_enumeration (Some n) = (if n \<ge> 0 then nat (2*(n + 1)) else  nat (2*(-n) + 1))"|
"int_option_enumeration None = (0::nat)"

lemma int_option_enumeration_inj:
"inj int_option_enumeration"
proof
  have pos_even: "\<And>n::int. n \<ge> 0 \<Longrightarrow> even (int_option_enumeration (Some n)) \<and> (int_option_enumeration (Some n))> 0"
  proof-
    fix n::int assume "n \<ge>0" then have "(int_option_enumeration (Some n)) = nat (2*(n + 1))"
      by simp
    then show "even (int_option_enumeration (Some n)) \<and> 0 < int_option_enumeration (Some n)"
      by (smt \<open>0 \<le> n\<close> even_of_nat int_nat_eq oddE zero_less_nat_eq)
  qed
  have neg_odd: "\<And>n::int. n < 0 \<Longrightarrow> odd (int_option_enumeration (Some n))"
    by (smt evenE even_of_nat int_nat_eq int_option_enumeration.simps(1))
  fix x y assume A: "x \<in> UNIV" "y \<in> UNIV" "int_option_enumeration x = int_option_enumeration y"
  show "x = y"
    apply(cases "x = None")
      using A pos_even neg_odd
      apply (metis dvd_0_right int_option_enumeration.elims int_option_enumeration.simps(2) not_gr0 not_le)
    proof-
      assume "x \<noteq>None"
      then obtain n where n_def: "x = Some n"
        by auto
      then have y_not_None: "y \<noteq> None"
        using A
        by (metis \<open>\<And>thesis. (\<And>n. x = Some n \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
              add_cancel_right_right even_add int_option_enumeration.simps(2)
              linorder_not_less neg_odd neq0_conv pos_even)
      then obtain m where m_def: "y = Some m"
        by blast
      show ?thesis
      proof(cases "n \<ge>0")
        case True
        then show ?thesis
          using n_def A neg_odd pos_even m_def int_option_enumeration.simps(1)
          by (smt int_nat_eq)
      next
        case False
        then show ?thesis
          using n_def A neg_odd pos_even m_def int_option_enumeration.simps(1)
          by (smt int_nat_eq)
      qed
  qed
qed

definition eint_enumeration where
"eint_enumeration = int_option_enumeration \<circ> Rep_eint"

lemma eint_enumeration_inj:
"inj eint_enumeration"
  unfolding eint_enumeration_def
  using int_option_enumeration_inj Rep_eint_inject
  by (metis (mono_tags, lifting) comp_apply injD inj_on_def)

instance eint :: countable
proof
  show "\<exists>to_int::eint \<Rightarrow> nat. inj to_int"
    using eint_enumeration_inj by blast
qed

old_rep_datatype eint "\<infinity> :: eint"
proof -
  fix P i assume "\<And>j. P (eint j)" "P \<infinity>"
  then show "P i"
  proof induct
    case (Abs_eint y) then show ?case
      by (cases y rule: option.exhaust)
         (auto simp: eint_def infinity_eint_def)
  qed
qed (auto simp add: eint_def infinity_eint_def Abs_eint_inject)

declare [[coercion "eint::int\<Rightarrow>eint"]]

lemmas eint2_cases = eint.exhaust[case_product eint.exhaust]
lemmas eint3_cases = eint.exhaust[case_product eint.exhaust eint.exhaust]

lemma not_infinity_eq [iff]: "(x \<noteq> \<infinity>) = (\<exists>i. x = eint i)"
  by (cases x) auto

lemma not_eint_eq [iff]: "(\<forall>y. x \<noteq> eint y) = (x = \<infinity>)"
  by (cases x) auto

lemma eint_ex_split: "(\<exists>c::eint. P c) \<longleftrightarrow> P \<infinity> \<or> (\<exists>c::int. P c)"
  by (metis eint.exhaust)

primrec the_eint :: "eint \<Rightarrow> int"
  where "the_eint (eint n) = n"

subsection \<open>Constructors and numbers\<close>

instantiation eint :: zero_neq_one
begin

definition
  "0 = eint 0"

definition
  "1 = eint 1"

instance
  proof qed (simp add: zero_eint_def one_eint_def)

end

lemma eint_0 [code_post]: "eint 0 = 0"
  by (simp add: zero_eint_def)

lemma eint_1 [code_post]: "eint 1 = 1"
  by (simp add: one_eint_def)

lemma eint_0_iff: "eint x = 0 \<longleftrightarrow> x = 0" "0 = eint x \<longleftrightarrow> x = 0"
  by (auto simp add: zero_eint_def)

lemma eint_1_iff: "eint x = 1 \<longleftrightarrow> x = 1" "1 = eint x \<longleftrightarrow> x = 1"
  by (auto simp add: one_eint_def)

lemma infinity_ne_i0 [simp]: "(\<infinity>::eint) \<noteq> 0"
  by (simp add: zero_eint_def)

lemma i0_ne_infinity [simp]: "0 \<noteq> (\<infinity>::eint)"
  by (simp add: zero_eint_def)

lemma zero_one_eint_neq:
  "\<not> 0 = (1::eint)"
  "\<not> 1 = (0::eint)"
  unfolding zero_eint_def one_eint_def by simp_all

lemma infinity_ne_i1 [simp]: "(\<infinity>::eint) \<noteq> 1"
  by (simp add: one_eint_def)

lemma i1_ne_infinity [simp]: "1 \<noteq> (\<infinity>::eint)"
  by (simp add: one_eint_def)

subsection \<open>Addition\<close>

instantiation eint :: comm_monoid_add
begin

definition [nitpick_simp]:
  "m + n = (case m of \<infinity> \<Rightarrow> \<infinity> | eint m \<Rightarrow> (case n of \<infinity> \<Rightarrow> \<infinity> | eint n \<Rightarrow> eint (m + n)))"

lemma plus_eint_simps [simp, code]:
  fixes q :: eint
  shows "eint m + eint n = eint (m + n)"
    and "\<infinity> + q = \<infinity>"
    and "q + \<infinity> = \<infinity>"
  by (simp_all add: plus_eint_def split: eint.splits)

instance
proof
  fix n m q :: eint
  show "n + m + q = n + (m + q)"
    by (cases n m q rule: eint3_cases) auto
  show "n + m = m + n"
    by (cases n m rule: eint2_cases) auto
  show "0 + n = n"
    by (cases n) (simp_all add: zero_eint_def)
qed

end

lemma eSuc_eint: "(eint n) + 1 = eint (n + 1)"
  by (simp add: one_eint_def)

lemma eSuc_infinity [simp]: " \<infinity> + (1::eint) = \<infinity>"
  unfolding plus_eint_def
  by auto

lemma eSuc_inject [simp]: " m + (1::eint)=  n + 1 \<longleftrightarrow> m = n"
  unfolding plus_eint_def
  apply(cases "m = \<infinity>")
  apply (metis (no_types, lifting) eSuc_eint
    eint.distinct(2) eint.exhaust eint.simps(4) eint.simps(5) plus_eint_def)
  apply(cases "n = \<infinity>")
  using eSuc_eint plus_eint_def apply auto[1]
  unfolding one_eint_def
  using add.commute eSuc_eint
  by auto

lemma eSuc_eint_iff: "x + 1 = eint y \<longleftrightarrow> (\<exists>n. y = n + 1 \<and> x = eint n)"
  apply(cases "x = \<infinity>")
  apply simp
  unfolding plus_eint_def one_eint_def
  using eSuc_eint
  by auto

lemma enat_eSuc_iff: "eint y = x + 1 \<longleftrightarrow> (\<exists>n. y = n + 1 \<and> eint n = x)"
  using eSuc_eint_iff
  by metis

lemma iadd_Suc: "((m::eint) + 1) + n = (m + n) + 1"
  by (metis ab_semigroup_add_class.add_ac(1) add.assoc add.commute)

lemma iadd_Suc_right: "(m::eint) + (n + 1) = (m + n) + 1"
  using add.assoc[of m n 1] by auto

subsection \<open>Multiplication\<close>

instantiation eint :: "{comm_semiring}"
begin

definition times_eint_def [nitpick_simp]:
  "m * n = (case m of \<infinity> \<Rightarrow>  \<infinity> | eint m \<Rightarrow>
    (case n of \<infinity> \<Rightarrow> \<infinity> | eint n \<Rightarrow> eint (m * n)))"

lemma times_eint_simps [simp, code]:
  "eint m * eint n = eint (m * n)"
  "\<infinity> * \<infinity> = (\<infinity>::eint)"
  "\<infinity> * eint n = \<infinity>"
  "eint m * \<infinity> = \<infinity>"
  unfolding times_eint_def zero_eint_def
  by (simp_all split: eint.split)

lemma sum_infinity_imp_summand_infinity:
  assumes "a + b = (\<infinity>::eint)"
  shows "a = \<infinity> \<or> b = \<infinity>"
  using assms
  by (metis  not_eint_eq plus_eint_simps(1))

lemma sum_finite_imp_summands_finite:
  assumes "a + b \<noteq> (\<infinity>::eint)"
  shows "a \<noteq> \<infinity>" "b \<noteq> \<infinity>"
  using assms eint.simps(5) apply fastforce
  using assms eint.simps(5) by fastforce

instance
proof
  fix a b c :: eint
  show "(a * b) * c = a * (b * c)"
    unfolding times_eint_def zero_eint_def
    by (simp split: eint.split)
  show comm: "a * b = b * a"
    unfolding times_eint_def zero_eint_def
    by (simp split: eint.split)
  show distr: "(a + b) * c = a * c + b * c"
    unfolding times_eint_def plus_eint_def
    apply(cases "a + b = \<infinity>")
    apply(cases "a = \<infinity>")
    apply simp
    using sum_infinity_imp_summand_infinity[of a b]
    apply (metis eint.simps(5) plus_eint_def plus_eint_simps(3))
    apply(cases "c = \<infinity>")
     apply (metis eint.exhaust plus_eint_def plus_eint_simps(3) times_eint_def times_eint_simps(4))
    using sum_finite_imp_summands_finite[of a b]
    apply auto
    by (simp add: semiring_normalization_rules(1))
qed

end

lemma mult_one_right[simp]:
"(n::eint)*1 = n"
  apply(cases "n = \<infinity>")
  apply (simp add: one_eint_def)
  by (metis eint2_cases mult_cancel_left2 one_eint_def times_eint_simps(1))

lemma mult_one_left[simp]:
"1*(n::eint) = n"
  by (metis mult.commute mult_one_right)

lemma mult_eSuc: "((m::eint) + 1) * n = m * n + n"
  by (simp add: distrib_right)

lemma mult_eSuc': "((m::eint) + 1) * n = n + m * n"
  using mult_eSuc add.commute by simp

lemma mult_eSuc_right: "(m::eint) * (n + 1) =  m * n +  m "
  by(simp add: distrib_left)

lemma mult_eSuc_right': "(m::eint) * (n + 1) =  m + m * n  "
  using mult_eSuc_right add.commute by simp

subsection \<open>Numerals\<close>

lemma numeral_eq_eint:
  "numeral k = eint (numeral k)"
  by simp

lemma eint_numeral [code_abbrev]:
  "eint (numeral k) = numeral k"
  using numeral_eq_eint ..

lemma infinity_ne_numeral [simp]: "(\<infinity>::eint) \<noteq> numeral k"
  by auto

lemma numeral_ne_infinity [simp]: "numeral k \<noteq> (\<infinity>::eint)"
  by simp

subsection \<open>Subtraction\<close>

instantiation eint :: minus
begin

definition diff_eint_def:
"a - b = (case a of (eint x) \<Rightarrow> (case b of (eint y) \<Rightarrow> eint (x - y) | \<infinity> \<Rightarrow> \<infinity>)
          | \<infinity> \<Rightarrow> \<infinity>)"

instance ..

end

lemma idiff_eint_eint [simp, code]: "eint a - eint b = eint (a - b)"
  by (simp add: diff_eint_def)

lemma idiff_infinity [simp, code]: "\<infinity> - n = (\<infinity>::eint)"
  by (simp add: diff_eint_def)

lemma idiff_infinity_right [simp, code]: "eint a - \<infinity> = \<infinity>"
  by (simp add: diff_eint_def)

lemma idiff_0 [simp]: "(0::eint) - n = -n"
  by (cases n, simp_all add: zero_eint_def)

lemmas idiff_eint_0 [simp] = idiff_0 [unfolded zero_eint_def]

lemma idiff_0_right [simp]: "(n::eint) - 0 = n"
  by (cases n) (simp_all add: zero_eint_def)

lemmas idiff_eint_0_right [simp] = idiff_0_right [unfolded zero_eint_def]

lemma idiff_self [simp]: "n \<noteq> \<infinity> \<Longrightarrow> (n::eint) - n = 0"
  by (auto simp: zero_eint_def)

lemma eSuc_minus_eSuc [simp]: "((n::eint) + 1) - (m + 1) = n - m"
  apply(cases "n = \<infinity>")
  apply simp
  apply(cases "m = \<infinity>")
  apply (metis eSuc_infinity eint.exhaust idiff_infinity_right infinity_ne_i1 sum_infinity_imp_summand_infinity)
proof-
  assume A: "n \<noteq>\<infinity>" "m \<noteq> \<infinity>"
  obtain a where a_def: "n = eint a"
    using A
    by auto
  obtain b where b_def: "m = eint b"
    using A
    by auto
  show ?thesis
    using  idiff_eint_eint[of "a + 1" "b + 1"]
           idiff_eint_eint[of a b]
  by (simp add: a_def b_def eSuc_eint)
qed

lemma eSuc_minus_1 [simp]: "((n::eint)+ 1) - 1 = n"
  using eSuc_minus_eSuc[of n 0]
  by auto

(*lemmas idiff_self_eq_0_eint = idiff_self_eq_0[unfolded zero_eint_def]*)

subsection \<open>Ordering\<close>

instantiation eint :: linordered_ab_semigroup_add
begin

definition [nitpick_simp]:
  "m \<le> n = (case n of eint n1 \<Rightarrow> (case m of eint m1 \<Rightarrow> m1 \<le> n1 | \<infinity> \<Rightarrow> False)
    | \<infinity> \<Rightarrow> True)"

definition [nitpick_simp]:
  "m < n = (case m of eint m1 \<Rightarrow> (case n of eint n1 \<Rightarrow> m1 < n1 | \<infinity> \<Rightarrow> True)
    | \<infinity> \<Rightarrow> False)"

lemma eint_ord_simps [simp]:
  "eint m \<le> eint n \<longleftrightarrow> m \<le> n"
  "eint m < eint n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::eint)"
  "q < (\<infinity>::eint) \<longleftrightarrow> q \<noteq> \<infinity>"
  "(\<infinity>::eint) \<le> q \<longleftrightarrow> q = \<infinity>"
  "(\<infinity>::eint) < q \<longleftrightarrow> False"
  by (simp_all add: less_eq_eint_def less_eint_def split: eint.splits)

lemma numeral_le_eint_iff[simp]:
  shows "numeral m \<le> eint n \<longleftrightarrow> numeral m \<le> n"
  by auto

lemma numeral_less_eint_iff[simp]:
  shows "numeral m < eint n \<longleftrightarrow> numeral m < n"
  by simp

lemma eint_ord_code [code]:
  "eint m \<le> eint n \<longleftrightarrow> m \<le> n"
  "eint m < eint n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::eint) \<longleftrightarrow> True"
  "eint m < \<infinity> \<longleftrightarrow> True"
  "\<infinity> \<le> eint n \<longleftrightarrow> False"
  "(\<infinity>::eint) < q \<longleftrightarrow> False"
  by simp_all

lemma eint_ord_plus_one[simp]:
  assumes "eint n \<le> x"
  assumes "x < y"
  shows "eint (n + 1) \<le> y"
proof-
  obtain m where "x = eint m"
    using assms(2)
    by fastforce
  show ?thesis apply(cases "y = \<infinity>")
  apply simp
    using \<open>x = eint m\<close> assms(1) assms(2)
    by force
qed

instance
  by standard (auto simp add: less_eq_eint_def less_eint_def plus_eint_def split: eint.splits)

end

instance eint :: "{strict_ordered_comm_monoid_add}"
proof
  show "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d" for a b c d :: eint
    by (cases a b c d rule: eint2_cases[case_product eint2_cases]) auto
qed

(* BH: These equations are already proven generally for any type in
class linordered_semidom. However, eint is not in that class because
it does not have the cancellation property. Would it be worthwhile to
a generalize linordered_semidom to a new class that includes eint? *)

lemma add_diff_assoc_eint: "z \<le> y \<Longrightarrow> x + (y - z) = x + y - (z::eint)"
by(cases x)(auto simp add: diff_eint_def split: eint.split)

lemma eint_ord_number [simp]:
  "(numeral m :: eint) \<le> numeral n \<longleftrightarrow> (numeral m :: nat) \<le> numeral n"
  "(numeral m :: eint) < numeral n \<longleftrightarrow> (numeral m :: nat) < numeral n"
  apply simp
  by simp

lemma infinity_ileE [elim!]: "\<infinity> \<le> eint m \<Longrightarrow> R"
  by simp

lemma infinity_ilessE [elim!]: "\<infinity> < eint m \<Longrightarrow> R"
  by simp

lemma imult_infinity: "(0::eint) < n \<Longrightarrow> \<infinity> * n = \<infinity>"
  by (simp add: zero_eint_def less_eint_def split: eint.splits)

lemma imult_infinity_right: "(0::eint) < n \<Longrightarrow> n * \<infinity> = \<infinity>"
  by (simp add: zero_eint_def less_eint_def split: eint.splits)

lemma min_eint_simps [simp]:
  "min (eint m) (eint n) = eint (min m n)"
  "min q (\<infinity>::eint) = q"
  "min (\<infinity>::eint) q = q"
  by (auto simp add: min_def)

lemma max_eint_simps [simp]:
  "max (eint m) (eint n) = eint (max m n)"
  "max q \<infinity> = (\<infinity>::eint)"
  "max \<infinity> q = (\<infinity>::eint)"
  by (simp_all add: max_def)

lemma eint_ile: "n \<le> eint m \<Longrightarrow> \<exists>k. n = eint k"
  by (cases n) simp_all

lemma eint_iless: "n < eint m \<Longrightarrow> \<exists>k. n = eint k"
  by (cases n) simp_all

lemma iadd_le_eint_iff:
  "x + y \<le> eint n \<longleftrightarrow> (\<exists>y' x'. x = eint x' \<and> y = eint y' \<and> x' + y' \<le> n)"
by(cases x y rule: eint.exhaust[case_product eint.exhaust]) simp_all

lemma chain_incr: "\<forall>i. \<exists>j. Y i < Y j \<Longrightarrow> \<exists>j. eint k < Y j"
proof-
  assume A: "\<forall>i. \<exists>j. Y i < Y j"
  then have "\<forall>i. \<exists>n::int. Y i = eint n"
    by (metis eint.exhaust eint_ord_simps(6))
  then obtain i n where in_def: "Y (i::'a) = eint n"
    by blast
  show "\<exists>j. eint k < Y j"
  proof(rule ccontr)
    assume C: "\<not>(\<exists>j. eint k < Y j)"
    then have C':"\<forall>j. Y j \<le> eint k"
      using le_less_linear
      by blast
    then have "Y (i::'a) \<le> eint k"
      by simp
    have "\<And>m::nat. \<exists>j::'a. Y j \<ge> eint (n + int m)"
    proof- fix m
      show "\<exists>j::'a. Y j \<ge> eint (n + int m)"
        apply(induction m)
         apply (metis in_def int_ops(1) order_refl plus_int_code(1))
      proof- fix m
        assume "\<exists>j. eint (n + int m) \<le> Y j"
        then obtain j where j_def: "eint (n + int m) \<le> Y j"
          by blast
        obtain j' where j'_def: "Y j < Y j'"
          using A by blast
        have "eint (n + int (Suc m)) = eint (n + m + 1)"
          by auto
        then have "eint (n + int (Suc m)) \<le> Y j'"
          using j_def j'_def  eint_ord_plus_one[of "n + m" "Y j" "Y j'"]
          by presburger
        then show "\<exists>j. eint (n + int (Suc m)) \<le> Y j"
          by blast
      qed
    qed
    then show False
      by (metis A C \<open>Y i \<le> eint k\<close>   eint_ord_simps(1) in_def
          order.not_eq_order_implies_strict zle_iff_zadd)
  qed
qed

lemma eint_ord_Suc:
  assumes "(x::eint) < y"
  shows "x + 1 < y + 1"
  apply(cases "y = \<infinity>")
  using assms i1_ne_infinity sum_infinity_imp_summand_infinity
   apply fastforce
  by (metis add_mono_thms_linordered_semiring(3) assms eSuc_inject order_less_le)

lemma eSuc_ile_mono [simp]: "(n::eint) + 1 \<le> m+ 1 \<longleftrightarrow> n \<le> m"
  by (meson add_mono_thms_linordered_semiring(3) eint_ord_Suc linorder_not_le)

lemma eSuc_mono [simp]: "(n::eint) + 1 < m+ 1 \<longleftrightarrow> n < m"
  by (meson add_mono_thms_linordered_semiring(3) eint_ord_Suc linorder_not_le)

lemma ile_eSuc [simp]: "(n::eint) \<le> n + 1"
  by (metis add.right_neutral add_left_mono eint_1_iff(2) eint_ord_code(1) linear not_one_le_zero zero_eint_def)

lemma ileI1: "(m::eint) < n \<Longrightarrow> m + 1 \<le> n"
  by (metis eSuc_eint eint.exhaust eint_ex_split eint_iless eint_ord_Suc eint_ord_code(6)
      eint_ord_plus_one eint_ord_simps(3) less_le_trans linear )

lemma Suc_ile_eq: "eint (m +1) \<le> n \<longleftrightarrow> eint m < n"
  by (cases n) auto

lemma iless_Suc_eq [simp]: "eint m < n + 1 \<longleftrightarrow> eint m \<le> n"
  by (metis Suc_ile_eq eSuc_eint eSuc_ile_mono)

lemma eSuc_max: "(max (x::eint) y) + 1 = max (x+1) (y+1)"
  by (simp add: max_def)

lemma eSuc_Max:
  assumes "finite A" "A \<noteq> ({}::eint set)"
  shows " (Max A) + 1 = Max ((+)1 ` A)"
using assms proof induction
  case (insert x A)
  thus ?case
    using Max_insert[of A x] Max_singleton[of x] add.commute[of 1] eSuc_max finite_imageI
          image_insert image_is_empty
  by (simp add: add.commute hom_Max_commute)
qed simp

instantiation eint :: "{order_top}"
begin

definition top_eint :: eint where "top_eint = \<infinity>"

instance
  by standard (simp add: top_eint_def)

end

lemma finite_eint_bounded:
  assumes le_fin: "\<And>y. y \<in> A \<Longrightarrow> eint m \<le> y \<and> y \<le> eint n"
  shows "finite A"
proof (rule finite_subset)
  show "finite (eint ` {m..n})" by blast
  have "A \<subseteq> {eint m..eint n}" using le_fin by fastforce
  also have "\<dots> \<subseteq> eint ` {m..n}"
    apply (rule subsetI)
    subgoal for x by (cases x) auto
    done
  finally show "A \<subseteq> eint ` {m..n}" .
qed

subsection \<open>Cancellation simprocs\<close>

lemma add_diff_cancel_eint[simp]: "x \<noteq> \<infinity> \<Longrightarrow> x + y - x = (y::eint)"
by (metis add.commute add.right_neutral add_diff_assoc_eint idiff_self order_refl)

lemma eint_add_left_cancel: "a + b = a + c \<longleftrightarrow> a = (\<infinity>::eint) \<or> b = c"
  unfolding plus_eint_def by (simp split: eint.split)

lemma eint_add_left_cancel_le: "a + b \<le> a + c \<longleftrightarrow> a = (\<infinity>::eint) \<or> b \<le> c"
  unfolding plus_eint_def by (simp split: eint.split)

lemma eint_add_left_cancel_less: "a + b < a + c \<longleftrightarrow> a \<noteq> (\<infinity>::eint) \<and> b < c"
  unfolding plus_eint_def by (simp split: eint.split)

lemma plus_eq_infty_iff_eint: "(m::eint) + n = \<infinity> \<longleftrightarrow> m=\<infinity> \<or> n=\<infinity>"
using eint_add_left_cancel by fastforce

ML \<open>
structure Cancel_Enat_Common =
struct
  (* copied from src/HOL/Tools/nat_numeral_simprocs.ML *)
  fun find_first_t _    _ []         = raise TERM("find_first_t", [])
    | find_first_t past u (t::terms) =
          if u aconv t then (rev past @ terms)
          else find_first_t (t::past) u terms

  fun dest_summing (Const (\<^const_name>\<open>Groups.plus\<close>, _) $ t $ u, ts) =
        dest_summing (t, dest_summing (u, ts))
    | dest_summing (t, ts) = t :: ts

  val mk_sum = Arith_Data.long_mk_sum
  fun dest_sum t = dest_summing (t, [])
  val find_first = find_first_t []
  val trans_tac = Numeral_Simprocs.trans_tac
  val norm_ss =
    simpset_of (put_simpset HOL_basic_ss \<^context>
      addsimps @{thms ac_simps add_0_left add_0_right})
  fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset norm_ss ctxt))
  fun simplify_meta_eq ctxt cancel_th th =
    Arith_Data.simplify_meta_eq [] ctxt
      ([th, cancel_th] MRS trans)
  fun mk_eq (a, b) = HOLogic.mk_Trueprop (HOLogic.mk_eq (a, b))
end

structure Eq_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_eq
  val dest_bal = HOLogic.dest_bin \<^const_name>\<open>HOL.eq\<close> \<^typ>\<open>eint\<close>
  fun simp_conv _ _ = SOME @{thm eint_add_left_cancel}
)

structure Le_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less_eq\<close>
  val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less_eq\<close> \<^typ>\<open>eint\<close>
  fun simp_conv _ _ = SOME @{thm eint_add_left_cancel_le}
)

structure Less_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel \<^const_name>\<open>Orderings.less\<close>
  val dest_bal = HOLogic.dest_bin \<^const_name>\<open>Orderings.less\<close> \<^typ>\<open>eint\<close>
  fun simp_conv _ _ = SOME @{thm eint_add_left_cancel_less}
)
\<close>

simproc_setup eint_eq_cancel
  ("(l::eint) + m = n" | "(l::eint) = m + n") =
  \<open>fn phi => fn ctxt => fn ct => Eq_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

simproc_setup eint_le_cancel
  ("(l::eint) + m \<le> n" | "(l::eint) \<le> m + n") =
  \<open>fn phi => fn ctxt => fn ct => Le_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

simproc_setup eint_less_cancel
  ("(l::eint) + m < n" | "(l::eint) < m + n") =
  \<open>fn phi => fn ctxt => fn ct => Less_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

text \<open>TODO: add regression tests for these simprocs\<close>

text \<open>TODO: add simprocs for combining and cancelling numerals\<close>

subsection \<open>Well-ordering\<close>

lemma less_eintE:
  "[| n < eint m; !!k. n = eint k ==> k < m ==> P |] ==> P"
by (induct n) auto

lemma less_infinityE:
  "[| n < \<infinity>; !!k. n = eint k ==> P |] ==> P"
by (induct n) auto

subsection \<open>Traditional theorem names\<close>

lemmas eint_defs = zero_eint_def one_eint_def
  plus_eint_def less_eq_eint_def less_eint_def

instantiation eint :: uminus
begin

definition
"- b = (case b of \<infinity> \<Rightarrow> \<infinity> | eint m \<Rightarrow> eint (-m))"

lemma eint_uminus_eq:
"(a::eint) + (-a) = a - a"
  apply(induction a)
  apply (simp add: uminus_eint_def)
  by simp

instance..
end

section\<open>Additional Lemmas (Useful for the Proof of Hensel's Lemma)\<close>

lemma eint_mult_mono:
  assumes "(c::eint) > 0 \<and> c \<noteq> \<infinity>"
  assumes "k > n"
  shows "k*c > n*c"
  using assms apply(induction k, induction n, induction c)
  by(auto simp add: zero_eint_def)

lemma eint_mult_mono':
  assumes "(c::eint) \<ge> 0 \<and> c \<noteq> \<infinity>"
  assumes "k > n"
  shows "k*c \<ge> n*c"
  apply(cases "c = 0")
   apply (metis add.right_neutral assms(2) eint_add_left_cancel eint_ord_code(3)
         eint_ord_simps(4) eq_iff less_le_trans mult.commute mult_eSuc_right'
         mult_one_right not_less times_eint_simps(4) zero_eint_def)
    using assms eint_mult_mono
    by (simp add: le_less)

lemma eint_minus_le:
  assumes "(b::eint) < c"
  shows "c - b > 0"
  using assms apply(induction b, induction c)
  by (auto simp add: zero_eint_def)

lemma eint_nat_times:
  assumes "(c::eint) > 0"
  shows "(Suc n)*(c::eint) > 0"
  using assms  apply(induction c)
  apply (simp add: zero_eint_def)
  by simp

lemma eint_pos_times_is_pos:
  assumes "(c::eint) > 0"
  assumes "b > 0"
  shows "b*c > 0"
  using assms apply(induction c, induction b)
  by(auto simp add: zero_eint_def imult_infinity_right)

lemma eint_nat_is_pos:
"eint (Suc n) > 0"
  by (simp add: zero_eint_def)

lemma eint_pow_int_is_pos:
  assumes "n > 0"
  shows "eint n > 0"
  using assms by (simp add: zero_eint_def)

lemma eint_nat_times':
  assumes "(c::eint) \<ge> 0"
  shows "(Suc n)*c \<ge> 0"
  using assms zero_eint_def by fastforce

lemma eint_pos_int_times_ge:
  assumes "(c::eint) \<ge> 0"
  assumes "n > 0"
  shows "eint n * c \<ge> c"
  using assms apply(induction c)
  apply (smt eSuc_eint eint.distinct(2) eint_mult_mono' eint_pow_int_is_pos eq_iff ileI1 less_le mult.commute mult_one_right one_eint_def zero_eint_def)
  by simp

lemma eint_pos_int_times_gt:
  assumes "(c::eint) > 0"
  assumes "c \<noteq>\<infinity>"
  assumes "n > 1"
  shows "eint n * c > c"
  using assms eint_mult_mono[of c 1 "eint n"]
  by (metis eint_ord_simps(2) mult_one_left one_eint_def)

lemma eint_add_cancel_fact[simp]:
  assumes "(c::eint) \<noteq> \<infinity>"
  shows "c + (b - c) = b"
  using assms apply(induction c, induction b)
  by auto

lemma nat_mult_not_infty[simp]:
  assumes "c \<noteq> \<infinity>"
  shows "(eint n) * c \<noteq> \<infinity>"
  using assms by auto

lemma eint_minus_distl:
  assumes "(b::eint) \<noteq> d"
  shows "b*c - d*c = (b-d)*c"
  using assms apply(induction c, induction b, induction d)
  apply (metis add_diff_cancel_eint distrib_right eint.distinct(2) eint_add_cancel_fact nat_mult_not_infty)
    apply simp
      apply simp
        by (simp add: mult.commute times_eint_def)

lemma eint_minus_distr:
  assumes "(b::eint) \<noteq> d"
  shows "c*(b - d) = c*b - c*d"
  by (metis assms eint_minus_distl mult.commute)

lemma eint_int_minus_distr:
"(eint n)*c - (eint m)*c = eint (n - m) * c"
  by (metis add.right_neutral distrib_right eint_add_left_cancel eint_minus_distl idiff_eint_eint
      idiff_infinity idiff_self infinity_ne_i0 nat_mult_not_infty not_eint_eq times_eint_simps(4))

lemma eint_2_minus_1_mult[simp]:
"2*(b::eint) - b = b"
proof -
  have "\<forall>e. (\<infinity>::eint) * e = \<infinity>"
  by (simp add: times_eint_def)
  then show ?thesis
    by (metis add_diff_cancel_eint idiff_infinity mult.commute mult_eSuc_right' mult_one_right one_add_one one_eint_def plus_eint_simps(1))
qed

lemma eint_minus_comm:
"(d::eint) + b - c = d - c + b"
apply(induction c )
  apply (metis add.assoc add_diff_cancel_eint eint.distinct(2) eint_add_cancel_fact)
    apply(induction d)
    apply (metis distrib_left eint2_cases eint_minus_distl i1_ne_infinity idiff_infinity_right
           mult_one_left plus_eq_infty_iff_eint sum_infinity_imp_summand_infinity times_eint_simps(3))
      apply(induction b)
        apply simp
          by simp

lemma ge_plus_pos_imp_gt:
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "(b::eint) > 0"
  assumes "d \<ge> c + b"
  shows "d > c"
  using assms apply(induction d, induction c)
  apply (metis add.comm_neutral assms(2) eint_add_left_cancel_less less_le_trans)
   apply blast
    by simp

lemma eint_minus_ineq:
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "b \<ge> d"
  shows "b - c \<ge> d - c"
  by (metis add_left_mono antisym assms(1) assms(2) eint_add_cancel_fact linear)

lemma eint_minus_ineq':
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "b \<ge> d"
  assumes "(e::eint) > 0"
  assumes "e \<noteq> \<infinity>"
  shows "e*(b - c) \<ge> e*(d - c)"
  using assms eint_minus_ineq
  by (metis eint_mult_mono' eq_iff less_le mult.commute)

lemma eint_minus_ineq'':
  assumes "(c::eint) \<noteq>\<infinity>"
  assumes "b \<ge> d"
  assumes "(e::eint) > 0"
  assumes "e \<noteq> \<infinity>"
  shows "e*(b - c) \<ge> e*d - e*c"
  using assms eint_minus_ineq'
  proof -
    have "\<forall>e. (0::eint) + e = e"
      by simp
    then have f1: "e * 0 = 0"
      by (metis add_diff_cancel_eint assms(4) idiff_self mult_eSuc_right' mult_one_right)
    have "\<infinity> \<noteq> c * e"
      using assms(1) assms(4) eint_pos_times_is_pos by auto
    then show ?thesis
      using f1 by (metis assms(1) assms(2) assms(3) assms(4) eint_minus_distl eint_minus_ineq' idiff_self mult.commute)
  qed

lemma eint_min_ineq:
  assumes "(b::eint) \<ge> min c d"
  assumes "c > e"
  assumes "d > e"
  shows "b > e"
  by (meson assms(1) assms(2) assms(3) less_le_trans min_le_iff_disj)

lemma eint_plus_times:
  assumes "(d::eint) \<ge> 0"
  assumes "(b::eint) \<ge> c + (eint k)*d"
  assumes "k \<ge> l"
  shows "b \<ge> c + l*d"
proof-
  have "k*d \<ge> l*d"
    by (smt assms(1) assms(3) eint_mult_mono' eint_ord_simps(2) eq_iff times_eint_simps(4))
  thus ?thesis
    by (meson add_mono_thms_linordered_semiring(2) assms(2) order_subst2)
qed
end


header "Compiler for IMP"

theory sol06_1 imports "~~/src/HOL/IMP/Big_Step" "~~/src/HOL/IMP/Star"
begin

text {* \Exercise{A different instruction set architecture}

We consider a different instruction set which evaluates
boolean expressions on the stack, similar to arithmetic expressions:
\begin{itemize}
\item
The boolean value @{term False} is represented by the number @{text 0},
the boolean value @{term True} is represented by any number not equal
to @{text 0}.
\item
For every boolean operation exists a corresponding instruction which,
similar to arithmetic instructions, operates on values on top of the
stack.
\item
The new instruction set introduces a conditional jump which pops the
top-most element from the stack and jumps over a given amount of
instructions, if the popped value corresponds to @{text False}, and
otherwise goes to the next instruction.
\end{itemize}

Modify the theory @{text Compiler} by defining a suitable set of
instructions, by adapting the execution model and the compiler and
by updating the correctness proof.

*}

subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

(* MODIFICATION: Changed instruction set *)
text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  AND | NOT | LESS | JFALSE int |
  JMP int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

(* MODIFICATION: Semantics for new instructions *)
fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  AND \<Rightarrow> (i+1,s,(if hd stk \<noteq> 0 \<and> hd2 stk \<noteq> 0 then 1 else 0)#tl2 stk) |
  NOT \<Rightarrow> (i+1,s,(if hd stk \<noteq> 0 then 0 else 1)#tl stk) |
  LESS \<Rightarrow> (i+1,s,(if (hd2 stk < hd stk) then 1 else 0)#tl2 stk) |
  JFALSE n \<Rightarrow> ((if hd stk = 0 then i+1+n else i+1),s,tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk)
)"

definition
  exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
     ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)
where
  "P \<turnstile> c \<rightarrow> c' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P!!i) (i,s,stk) \<Longrightarrow> 0 \<le> i \<Longrightarrow> i < size P
  \<Longrightarrow> P \<turnstile> (i,s,stk) \<rightarrow> c'"
by (simp add: exec1_def)

abbreviation
  exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool" ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50)
where
  "exec P \<equiv> star (exec1 P)"

declare star.step[intro]

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

declare [[goals_limit = 1]]
lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
  unfolding exec1_def
  by (fastforce split: split_if_asm)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows
  "P \<turnstile> (i,s,stk) \<rightarrow> (i',s',stk') \<Longrightarrow>
   P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow> (size(P')+i',s',stk')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

lemma exec_appendL:
  fixes i i' :: int
  shows
 "P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')  \<Longrightarrow>
  P' @ P \<turnstile> (size(P')+i,s,stk) \<rightarrow>* (size(P')+i',s',stk')"
  by (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0,s,stk) \<rightarrow>* (j,t,stk') \<Longrightarrow>
  instr#P \<turnstile> (1,s,stk) \<rightarrow>* (1+j,t,stk')"
by (drule exec_appendL[where P'="[instr]"]) simp

lemma exec_appendL_if[intro]:
  fixes i i' j :: int
  shows
  "size P' <= i
   \<Longrightarrow> P \<turnstile> (i - size P',s,stk) \<rightarrow>* (j,s',stk')
   \<Longrightarrow> i' = size P' + j
   \<Longrightarrow> P' @ P \<turnstile> (i,s,stk) \<rightarrow>* (i',s',stk')"
by (drule exec_appendL[where P'=P']) simp

text{* Split the execution of a compound program up into the excution of its
parts: *}

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows
"P \<turnstile> (0,s,stk) \<rightarrow>* (i',s',stk') \<Longrightarrow>
 size P \<le> i' \<Longrightarrow>
 P' \<turnstile>  (i' - size P,s',stk') \<rightarrow>* (i'',s'',stk'') \<Longrightarrow>
 j'' = size P + i''
 \<Longrightarrow>
 P @ P' \<turnstile> (0,s,stk) \<rightarrow>* (j'',s'',stk'')"
by(metis star_trans[OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(acomp a),s,aval a s#stk)"
by (induction a arbitrary: stk) fastforce+

(* MODIFICATION: Rewritten, similar to acomp *)
fun bcomp :: "bexp \<Rightarrow> instr list" where
  "bcomp (Bc v) = (if v then [LOADI 1] else [LOADI 0])"
| "bcomp (Not b) = bcomp b@[NOT]"
| "bcomp (And b1 b2) = bcomp b1 @ bcomp b2 @ [AND]"
| "bcomp (Less a1 a2) = acomp a1 @ acomp a2 @ [LESS]"

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))"

(* MODIFICATION: Abbreviations to convert between bool and int *)
abbreviation "i2b i \<equiv> i\<noteq>0"
abbreviation "b2i b \<equiv> if b then 1 else 0"

(* MODIFICATION: Lemma similar to acomp_correct *)
lemma bcomp_correct[intro]:
  "bcomp a \<turnstile> (0,s,stk) \<rightarrow>* (size(bcomp a),s,b2i (bval a s)#stk)"
  apply (induction a arbitrary: stk)
  apply (fastforce intro!: exec_append_trans)+
  done

(*
  apply simp_all
  apply force
  apply (fastforce intro!: exec_append_trans)

  apply (fastforce intro!: exec_append_trans)

  apply (fastforce intro!: exec_append_trans)
  done
*)

(* MODIFICATION: Changed IF and WHILE cases *)
fun ccomp :: "com \<Rightarrow> instr list" where
"ccomp SKIP = []" |
"ccomp (x ::= a) = acomp a @ [STORE x]" |
"ccomp (c\<^sub>1;;c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
"ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (
  let cc\<^sub>1 = ccomp c\<^sub>1;
      cc\<^sub>2 = ccomp c\<^sub>2;
      cb = bcomp b
   in cb @ JFALSE (size cc\<^sub>1 + 1) # cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
"ccomp (WHILE b DO c) =
 (let cc = ccomp c; cb = bcomp b
  in cb @ JFALSE (size cc + 1) # cc @ [JMP (-(size cb + size cc + 2))])"

value "ccomp
 (IF Less (V ''u'') (N 1) THEN ''u'' ::= Plus (V ''u'') (N 1)
  ELSE ''v'' ::= V ''u'')"

value "ccomp (WHILE Less (V ''u'') (N 1) DO (''u'' ::= Plus (V ''u'') (N 1)))"

subsection "Preservation of semantics"

(* MODIFICATION: Changed WHILE_True, added IF-False that is no longer automatic *)
lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,1#stk)"
   using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,1#stk) \<rightarrow>* (size ?cb + 1, s1, stk)"
    by fastforce
  moreover have "?cw \<turnstile> (size ?cb + 1, s1, stk)
    \<rightarrow>* (size ?cb + 1 + size ?cc, s2, stk)"
    using  WhileTrue.IH(1) by fastforce
  moreover have "?cw \<turnstile> (size ?cb + 1 + size ?cc, s2, stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
next
  (* We have to adapt this lemma to work for the Cons (#) operator,
    not only for append (@): *)
  note aux2[intro] = exec_appendL_if[where P'="[instr]" for instr, simplified]

  (* With the adapted lemma in the intro-rules, the proof is automatic again*)
  case (IfFalse b s c2 t c1 stk)
  thus ?case by fastforce

  (* Alternatively, we can do an isar proof, similar to the WhileTrue case*)

  let ?cc1 = "ccomp c1"
  let ?cc2 = "ccomp c2"
  let ?cb = "bcomp b"
  let ?cw = "ccomp (IF b THEN c1 ELSE c2)"

  have "?cw \<turnstile> (0,s,stk) \<rightarrow>* (size ?cb,s,0#stk)"
    using `\<not>bval b s` by fastforce
  moreover have "?cw \<turnstile> (size ?cb,s,0#stk) \<rightarrow>* (size ?cb + size ?cc1 + 2,s,stk)"
    by fastforce
  moreover have "?cw \<turnstile> (size ?cb + size ?cc1 + 2,s,stk) \<rightarrow>* (size ?cw,t,stk)"
    using IfFalse.IH by fastforce
  ultimately have ?case by(blast intro: star_trans)
qed fastforce+

end


theory week08A_demo
  imports Main
begin

-- "Syntax and State Space"

type_synonym
  vname   = string
type_synonym
  state = "vname \<Rightarrow> nat"

type_synonym
  aexp  = "state \<Rightarrow> nat"
type_synonym
  bexp  = "state \<Rightarrow> bool"

datatype
  com = SKIP
      | Assign vname aexp       ("_ :== _ " [60,60] 60)
      | Semi   com com          ("_;; _"  [50, 51] 50)
      | Cond   bexp com com     ("IF _ THEN _ ELSE _"  [0,0,59] 60)
      | While  bexp com         ("WHILE _ DO _ OD"  [0,45] 60)

-- "Example Program"

definition
  A :: vname where
  "A \<equiv> ''A''"

definition
  B :: vname  where
  "B \<equiv> ''B''"

definition
  factorial :: com where
  "factorial \<equiv>  B :== (\<lambda>s. 1);;
                WHILE (\<lambda>s. s A \<noteq> 0) DO
                   B :== (\<lambda>s. s B * s A);;
                   A :== (\<lambda>s. s A - 1)
                OD"

-- "Execution"

inductive
  eval :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" ("_/ \<Rightarrow> _" [60,60] 61)
where
  Skip [intro!,simp]:
  "(SKIP, s) \<Rightarrow> s"
|
  Assign [intro!,simp]:
  "(x :== a, s) \<Rightarrow> s (x := a s)"
|
  Semi [intro!]:
  "\<lbrakk> (c\<^sub>1,s) \<Rightarrow> s''; (c\<^sub>2,s'') \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (c\<^sub>1;; c\<^sub>2, s) \<Rightarrow> s'"
|
  IfTrue:
  "\<lbrakk> b s; (c\<^sub>1,s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> s'"
|
  IfFalse:
  "\<lbrakk> \<not>b s; (c\<^sub>2,s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> s'"
|
  WhileFalse:
  "\<not>b s \<Longrightarrow> (WHILE b DO c OD, s) \<Rightarrow> s"
|
  WhileTrue:
  "\<lbrakk>b s; (c,s) \<Rightarrow> s''; (WHILE b DO c OD, s'') \<Rightarrow> s'\<rbrakk> \<Longrightarrow> (WHILE b DO c OD, s) \<Rightarrow> s'"

(* Isabelle provides eval.induct which allows the
   elimination of terms cs \<Rightarrow> t.
   In practice, we will have cs as a tuple (c,s).
   To avoid to manually have to split cs every time,
   we can use split_format as below to define an induction
   rule that will work on terms of the form (c, s) \<Rightarrow> t.*)

thm eval.induct
lemmas eval_induct = eval.induct [split_format (complete)]
thm eval_induct

(* In practice, it is also useful to have elimination rules
   for precisely when e.g. c=SKIP, or c= c1;;c2, etc.
   (If c=SKIP, eval_induct has many useless cases).
   The command inductive_cases allows exactly this.*)

inductive_cases
  skip [elim!]:   "(SKIP, s) \<Rightarrow> s'" and
  assign [elim!]: "(x :== a, s) \<Rightarrow> s'" and
  semi [elim!]:   "(c\<^sub>1;; c\<^sub>2, s) \<Rightarrow> s'" and
  "if" [elim!]:   "(IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> s'" and
  while:          "(WHILE b DO c OD, s) \<Rightarrow> s'"

thm skip assign semi "if" while

lemma skip_eq [simp]: "(SKIP, s) \<Rightarrow> s' = (s' = s)" by blast
lemma assign_eq [simp]: "(x :== a, s) \<Rightarrow> s' = (s' = s (x := a s))"  by blast

-- ---------------------------------------------------------------------
-- "Example Proof"

primrec
  fac :: "nat \<Rightarrow> nat"
where
  "fac 0 = 1"
 |"fac (Suc n) = (Suc n) * fac n"

(* Need to relate the final state of B to values of A and B *at each iteration*
   of the loop *)
lemma factorial_partial_correct_helper:
  "(prog, s) \<Rightarrow> s' \<Longrightarrow>
    prog = WHILE \<lambda>s. 0 < s A DO B :== (\<lambda>s. s B * s A) ;; A :== (\<lambda>s. s A - Suc 0)  OD \<Longrightarrow>
    s' B = s B * fac (s A)"
  using [[simp_trace]]
  (*TODO*)
  apply (induct rule: eval_induct)
        apply simp
       apply simp
      apply simp
     apply simp
    apply simp
   apply simp
  apply simp
  apply (case_tac "s A")
   apply simp
  apply clarsimp
  apply (simp add: distrib_left distrib_right)
  done

lemma factorial_partial_correct:
  "(factorial, s) \<Rightarrow> s' \<Longrightarrow> s' B = fac (s A)"
  (*TODO*)
  apply (unfold factorial_def)
  apply clarsimp
  apply (simp add: factorial_partial_correct_helper)
  done

-- ---------------------------------------------------------------------

type_synonym assn = "state => bool"

definition
  hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
  "\<Turnstile> {P} c {Q} \<equiv> \<forall>s s'. P s \<longrightarrow> (c,s) \<Rightarrow> s' \<longrightarrow> Q s'"

inductive
  hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
where
  h_skip:
  "\<turnstile> {P} SKIP {P}"
|
  h_assign:
  "\<turnstile> {\<lambda>s. P (s(x:= a s))} x:==a {P}"
|
  h_semi:
  "\<lbrakk> \<turnstile> {P} c\<^sub>1 {R}; \<turnstile> {R} c\<^sub>2 {Q} \<rbrakk> \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {Q}"
|
  h_if:
  "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> b s} c\<^sub>1 {Q}; \<turnstile> {\<lambda>s. P s \<and> \<not>b s} c\<^sub>2 {Q} \<rbrakk> \<Longrightarrow>
  \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"
|
  h_while:
  "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> b s} c {P}; \<forall>s. P s \<and> \<not>b s \<longrightarrow> Q s \<rbrakk> \<Longrightarrow>
  \<turnstile> {P} WHILE b DO c OD {Q}"
|
  conseq:
  "\<lbrakk> \<forall>s. P s \<longrightarrow> P' s; \<turnstile> {P'} c {Q'}; \<forall>s. Q' s \<longrightarrow> Q s \<rbrakk> \<Longrightarrow>
  \<turnstile> {P} c {Q}"

print_theorems

-- "Soundness Proof"

(* When a while loop is fully executed to a state s',
   then the loop condition is false in s' (otherwise there
   would have been another iteration). Moreover, if the loop
   satisfies an invariant P, then P is true when the loop exits. *)
lemma while_final:
  "\<lbrakk>(prog, s) \<Rightarrow> s';  \<forall>s. P s \<and> b s \<longrightarrow> (\<forall>s'. (c, s) \<Rightarrow> s' \<longrightarrow> P s');  P s;
    prog = WHILE b DO c OD\<rbrakk>  \<Longrightarrow> P s' \<and> \<not> b s'"
  (*TODO*)
  by (induct rule: eval_induct; auto)

(* To show that a postcondition Q holds after a While loop,
   we need to find a predicate P that is an invariant of the loop
   (i.e. preserved by the loop body at each iteration) and
   is "enough" to prove the postcondition when the proof exits.*)
lemma while_sound:
  "\<lbrakk>\<Turnstile> {\<lambda>a. P a \<and> b a} c {P}; \<forall>s. P s \<and> \<not> b s \<longrightarrow> Q s\<rbrakk> \<Longrightarrow>
  \<Turnstile> {P} WHILE b DO c OD {Q}"
  (*TODO*)
  apply (simp add: hoare_valid_def)
  apply clarsimp
  apply (drule (2) while_final, simp)
  apply simp
  done

-- --------------------------------------------------------------------------------------
-- "derived rules"

lemma h_ass:
  "(\<And>s. P s \<Longrightarrow> Q (s(x := a s))) \<Longrightarrow> \<turnstile> {P} x :== a {Q}"
  apply(rule_tac Q'=Q in conseq)
  prefer 2
  apply(rule h_assign)
  apply(blast)+
  done

-- "example proof"

lemma "\<turnstile> {\<lambda>s. True} x :== (\<lambda>s. 2) {\<lambda>s. s x = 2}"
  apply(rule h_ass)
  apply simp
  done

lemma
  "\<turnstile> {\<lambda>s. s A = n} factorial {\<lambda>s. s B = fac n}"
  apply(unfold factorial_def)
  apply(rule h_semi)
   prefer 2
   apply(rule_tac P="\<lambda>s. s B * fac (s A) = fac n" in h_while)
    apply(rule h_semi)
     prefer 2
     apply(rule h_assign)
    apply(rule h_ass)
    apply clarsimp
    apply(case_tac "s A", simp)
    apply clarsimp
    apply (simp add: add_mult_distrib2 comm_semiring_class.distrib)
   apply clarsimp
  apply(rule h_ass)
  apply clarsimp
  done

end


(* ************************************************************************** *)
(* Title:      Frobenius.thy                                                  *)
(* Author:     Paulo Emílio de Vilhena                                        *)
(* ************************************************************************** *)

theory Frobenius
imports Ideal Ring "HOL.Binomial" Int_Ring More_Finite_Product

begin

section \<open>Frobenius Endomorphism\<close>

subsection \<open>Binomials\<close>

text \<open>In order to study the Frobenius Endomorphim, we will only need two results from the
      theory of Binomials. Therefore, instead of porting them from HOL.Binomial, we will
      redemonstrate these lemmas inside the formalism we developed so far (more concretely,
      the one proposed by the FiniteProduct theory).\<close>

lemma (in cring) binomial:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "(a \<oplus> b) [^] n = (\<Oplus> k \<in> {.. n :: nat}. [(n choose k)] \<cdot> (a [^] k \<otimes> b [^] (n - k)))"
proof (induct n)
  case 0 thus ?case by simp
next
  case (Suc n)
  let ?f   = "\<lambda>k. (a [^] k \<otimes> b [^] (n - k))"
  let ?f_a = "\<lambda>k. (a [^] Suc k \<otimes> b [^] (n - k))"
  let ?f_b = "\<lambda>k. (a [^] k \<otimes> b [^] Suc (n - k))"
  let ?choose = "\<lambda>f. \<lambda>k. [(n choose k)] \<cdot> (f k)"
  have in_carrier: "\<And>k. k \<in> {.. n :: nat} \<Longrightarrow> ?choose ?f k \<in> carrier R"
    using assms by blast
  have "(a \<oplus> b) [^] Suc n = (a \<oplus> b) \<otimes> ((a \<oplus> b) [^] n)"
    using assms m_comm by simp
  also have " ... = (a \<oplus> b) \<otimes> (\<Oplus> k \<in> {.. n}. ?choose ?f k)"
    using Suc.hyps by simp
  also have " ... = (a \<otimes> (\<Oplus> k \<in> {.. n}. ?choose ?f k)) \<oplus> (b \<otimes> (\<Oplus> k \<in> {.. n}. ?choose ?f k))"
    using assms l_distr by simp
  also have " ... = (\<Oplus> k \<in> {.. n}. a \<otimes> (?choose ?f k)) \<oplus> (\<Oplus> k \<in> {.. n}. b \<otimes> (?choose ?f k))"
    using finsum_rdistr[of "{.. n}" a "?choose ?f"]
          finsum_rdistr[of "{.. n}" b "?choose ?f"] assms in_carrier by simp
  also have " ... =
    (\<Oplus> k \<in> {.. n}. ?choose (\<lambda>k. a \<otimes> (?f k)) k) \<oplus> (\<Oplus> k \<in> {.. n}. ?choose (\<lambda>k. b \<otimes> (?f k)) k)"
    using add_pow_rdistr assms in_carrier by auto
  also have " ... = (\<Oplus> k \<in> {.. n}. ?choose ?f_a k) \<oplus> (\<Oplus> k \<in> {.. n}. ?choose ?f_b k)"
    using assms m_assoc m_comm by auto
  also have " ... =
    ((a [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {..<n}.     ?choose ?f_a k)) \<oplus>
    ((b [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {Suc 0..n}. ?choose ?f_b k))"
    using add.finprod_Suc3[of "\<lambda>k. ?choose ?f_a k" n]
          add.finprod_0'[of   "\<lambda>k. ?choose ?f_b k" n] assms by simp
  also have " ... =
    ((a [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {..< n}. [(n choose k)] \<cdot> (a [^] (Suc k) \<otimes> b [^] Suc (n - (Suc k))))) \<oplus>
    ((b [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {Suc 0..n}. [(n choose k)] \<cdot> (a [^] k \<otimes> (b [^] (Suc (n - k))))))"
    using Suc_diff_Suc lessThan_iff add.finprod_cong[of "{..< n}" "{..< n}"
           "\<lambda>k. [(n choose k)] \<cdot> (a [^] (Suc k) \<otimes> b [^] Suc (n - (Suc k)))"
           "\<lambda>k. [(n choose k)] \<cdot> (a [^] (Suc k) \<otimes> b [^] (n - k))"] assms by auto
  also have " ... =
    ((a [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {Suc 0..< Suc n}. [(n choose (k - Suc 0))] \<cdot> (a [^] k \<otimes> b [^] (Suc (n - k))))) \<oplus>
    ((b [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {Suc 0..n}. [(n choose k)] \<cdot> (a [^] k \<otimes> (b [^] (Suc (n - k))))))"
    using add.finprod_reindex[of "\<lambda>k. [(n choose (k - Suc 0))] \<cdot> (a [^] k \<otimes> b [^] (Suc (n - k)))"
                                 "\<lambda>i. Suc i" "{..< n}"] assms lessThan_atLeast0 atMost_atLeast0 by simp
  finally have term1: "(a \<oplus> b) [^] Suc n =
    ((a [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {Suc 0..n}. [(n choose (k - Suc 0))] \<cdot> (a [^] k \<otimes> b [^] (Suc (n - k))))) \<oplus>
    ((b [^] (Suc n)) \<oplus> (\<Oplus> k \<in> {Suc 0..n}. [(n choose k)] \<cdot> (a [^] k \<otimes> (b [^] (Suc (n - k))))))"
    using atLeastLessThanSuc_atLeastAtMost by auto

  let ?g = "\<lambda>k. a [^] k \<otimes> b [^] (Suc (n - k))"
  define sum_1 and sum_2
    where "sum_1 = (\<Oplus> k \<in> {Suc 0..n}. [(n choose (k - Suc 0))] \<cdot> ?g k)"
      and "sum_2 = (\<Oplus> k \<in> {Suc 0..n}. [(n choose k)] \<cdot> ?g k)"
  hence term2: "(a \<oplus> b) [^] Suc n = ((a [^] (Suc n)) \<oplus> sum_1) \<oplus> ((b [^] (Suc n)) \<oplus> sum_2)"
    using term1 by simp
  have sum_1_in_carrier: "sum_1 \<in> carrier R" and sum_2_in_carrier: "sum_2 \<in> carrier R"
    using assms unfolding sum_1_def sum_2_def by auto
  hence "(a \<oplus> b) [^] Suc n = (a [^] Suc n \<oplus> b [^] Suc n) \<oplus> (sum_1 \<oplus> sum_2)"
    using term2 add.m_comm add.m_assoc assms by (simp add: add.m_assoc)
  also have " ... = (a [^] Suc n \<oplus> b [^] Suc n) \<oplus>
    (\<Oplus> k \<in> {Suc 0..n}. [(n choose (k - Suc 0))] \<cdot> ?g k \<oplus> [(n choose k)] \<cdot> ?g k)"
    using add.finprod_multf[of "\<lambda>k. [(n choose (k - Suc 0))] \<cdot> ?g k" "{Suc 0..n}"
                               "\<lambda>k. [(n choose k)] \<cdot> ?g k" ] assms
    unfolding sum_1_def sum_2_def by auto
  also have "...  = (a [^] Suc n \<oplus> b [^] Suc n) \<oplus>
    (\<Oplus> k \<in> {Suc 0..n}. [((n choose (k - Suc 0)) + (n choose k))] \<cdot> ?g k)"
    using assms by (simp add: add.nat_pow_mult)
  also have " ... = (a [^] Suc n \<oplus> b [^] Suc n) \<oplus> (\<Oplus> k \<in> {Suc 0..n}. [(Suc n choose k)] \<cdot> ?g k)"
    using add.finprod_cong[of "{Suc 0..n}" "{Suc 0..n}"
                              "\<lambda>k. [((n choose (k - Suc 0)) + (n choose k))] \<cdot> ?g k"
                              "\<lambda>k. [(Suc n choose k)] \<cdot> ?g k"]
    using choose_reduce_nat assms by simp
  also have " ... = (a [^] Suc n) \<oplus> (\<Oplus> k \<in> {..n}. [(Suc n choose k)] \<cdot> ?g k)"
    using add.finprod_0'[of "\<lambda>k. [(Suc n choose k)] \<cdot> (?g k)" n] assms by (simp add: add.m_assoc)
  also have " ... = (a [^] Suc n) \<oplus> (\<Oplus> k \<in> {..n}. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] ((Suc n) - k)))"
    using add.finprod_cong[of "{..n}" "{..n}" "\<lambda>k. [(Suc n choose k)] \<cdot> ?g k"
                              "\<lambda>k. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] ((Suc n) - k))"]
          Suc_diff_le assms by auto
  also have " ... = (\<Oplus> k \<in> {..Suc n}. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] ((Suc n) - k)))"
    using add.finprod_Suc[of "\<lambda>k. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] ((Suc n) - k))" n] assms by auto
  finally show ?case .
qed

corollary (in cring) binomial_simp:
  assumes "a \<in> carrier R" "b \<in> carrier R"
  shows "(a \<oplus> b) [^] (Suc n) = (a [^] Suc n) \<oplus> (b [^] Suc n) \<oplus>
           (\<Oplus> k \<in> {Suc 0.. n}. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] (Suc n - k)))" (is "_ = _ \<oplus> _ \<oplus> ?sum")
proof -
  have "(a \<oplus> b) [^] (Suc n) = (\<Oplus> k \<in> {..Suc n}. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] (Suc n - k)))"
    using binomial[OF assms, of "Suc n"] .
  also have " ... = (a [^] Suc n) \<oplus> (\<Oplus> k \<in> {..n}. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] (Suc n - k)))"
    using add.finprod_Suc assms by auto
  also have " ... = (a [^] Suc n) \<oplus> ((b [^] Suc n) \<oplus> ?sum)"
    using add.finprod_0'[of "\<lambda>k. [(Suc n choose k)] \<cdot> (a [^] k \<otimes> b [^] (Suc n - k))" n] assms by simp
  finally show ?thesis
    using add.m_assoc[of "a [^] Suc n" "b [^] Suc n"] assms by simp
qed

abbreviation prime' :: "int \<Rightarrow> bool"
  where "prime' \<equiv> Factorial_Ring.prime"

lemma prime_choose_k:
  assumes "Factorial_Ring.prime p" "k \<in> {Suc 0..< p}"
  shows "p dvd (p choose k)"
proof -
  have "fact k * fact (p - k) * (p choose k) = fact p"
    using binomial_fact_lemma assms by simp
  hence "p dvd  (fact k * fact (p - k) * (p choose k))"
    using assms(2) dvd_fact by auto
  moreover have "\<not> p dvd (fact k)" "\<not> p dvd (fact (p - k))"
    using prime_dvd_fact_iff[of p k]
          prime_dvd_fact_iff[of p "p - k"] assms by auto
  ultimately show ?thesis
    using assms(1) prime_dvd_multD by blast
qed

subsection \<open>The Morphism\<close>

definition frobenius :: " _ \<Rightarrow> 'a \<Rightarrow> 'a"
  where "frobenius R a = a [^]\<^bsub>R\<^esub> (char R)"

lemma (in cring) freshman_dream:
  assumes "Factorial_Ring.prime (char R)"
    and "a \<in> carrier R" "b \<in> carrier R"
  shows "(a \<oplus> b) [^] (char R) = (a [^] (char R)) \<oplus> (b [^] (char R))"
proof -
  obtain n :: nat where n: "char R = Suc n"
    using prime_gt_Suc_0_nat[OF assms(1)] Suc_lessE by auto
  hence "(a \<oplus> b) [^] (char R) = (a [^] (char R)) \<oplus> (b [^] (char R)) \<oplus>
           (\<Oplus> k \<in> {Suc 0.. n}. [((char R) choose k)] \<cdot> (a [^] k \<otimes> b [^] ((char R) - k)))"
    using binomial_simp[OF assms(2-3)] by simp

  moreover
  let ?f = "\<lambda>k. a [^] k \<otimes> b [^] ((char R) - k)"
  have "\<And>k. k \<in> {Suc 0.. n} \<Longrightarrow> [((char R) choose k)] \<cdot> ?f k = \<zero>"
  proof -
    fix k assume "k \<in> {Suc 0.. n}"
    hence "int (char R) dvd int ((char R) choose k)"
      using n prime_choose_k[OF assms(1)] int_dvd_int_iff
            atLeastLessThanSuc_atLeastAtMost by presburger
    hence "\<lbrakk> int ((char R) choose k) \<rbrakk> = \<zero>"
      using add_pow_eq_zero_iff[of "int ((char R) choose k)"] by simp
    moreover have "[ int ((char R) choose k)] \<cdot> ?f k = \<lbrakk> int ((char R) choose k) \<rbrakk> \<otimes> ?f k"
      using elt_of_int_def'[of "a [^] k \<otimes> b [^] ((char R) - k)"] assms(2-3) by simp
    hence "[((char R) choose k)] \<cdot> ?f k = \<lbrakk> int ((char R) choose k) \<rbrakk> \<otimes> ?f k"
      using add.int_pow_def2 by simp
    ultimately show "[((char R) choose k)] \<cdot> ?f k = \<zero>"
      using assms(2-3) by simp
  qed
  hence "(\<Oplus> k \<in> {Suc 0.. n}. [((char R) choose k)] \<cdot> (a [^] k \<otimes> b [^] ((char R) - k))) = \<zero>"
    using add.finprod_one[of "{Suc 0.. n}"] by auto

  ultimately show ?thesis
    using assms(2-3) by simp
qed

lemma (in cring) frobenius_hom:
  assumes "Factorial_Ring.prime (char R)"
  shows "frobenius R \<in> ring_hom R R"
  unfolding frobenius_def ring_hom_def
  using freshman_dream[OF assms] nat_pow_distr by auto

end