(*  Author:     Steven Obua, TU Muenchen *)

section \<open>Various algebraic structures combined with a lattice\<close>

theory Lattice_Algebras
imports Complex_Main
begin

class semilattice_inf_ab_group_add = ordered_ab_group_add + semilattice_inf
begin

lemma add_inf_distrib_left: "a + inf b c = inf (a + b) (a + c)"
  apply (rule antisym)
  apply (simp_all add: le_infI)
  apply (rule add_le_imp_le_left [of "uminus a"])
  apply (simp only: add.assoc [symmetric], simp add: diff_le_eq add.commute)
  done

lemma add_inf_distrib_right: "inf a b + c = inf (a + c) (b + c)"
proof -
  have "c + inf a b = inf (c + a) (c + b)"
    by (simp add: add_inf_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class semilattice_sup_ab_group_add = ordered_ab_group_add + semilattice_sup
begin

lemma add_sup_distrib_left: "a + sup b c = sup (a + b) (a + c)"
  apply (rule antisym)
  apply (rule add_le_imp_le_left [of "uminus a"])
  apply (simp only: add.assoc [symmetric], simp)
  apply (simp add: le_diff_eq add.commute)
  apply (rule le_supI)
  apply (rule add_le_imp_le_left [of "a"], simp only: add.assoc[symmetric], simp)+
  done

lemma add_sup_distrib_right: "sup a b + c = sup (a + c) (b + c)"
proof -
  have "c + sup a b = sup (c+a) (c+b)"
    by (simp add: add_sup_distrib_left)
  then show ?thesis
    by (simp add: add.commute)
qed

end

class lattice_ab_group_add = ordered_ab_group_add + lattice
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

lemma inf_eq_neg_sup: "inf a b = - sup (- a) (- b)"
proof (rule inf_unique)
  fix a b c :: 'a
  show "- sup (- a) (- b) \<le> a"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  show "- sup (-a) (-b) \<le> b"
    by (rule add_le_imp_le_right [of _ "sup (uminus a) (uminus b)"])
      (simp, simp add: add_sup_distrib_left)
  assume "a \<le> b" "a \<le> c"
  then show "a \<le> - sup (-b) (-c)"
    by (subst neg_le_iff_le [symmetric]) (simp add: le_supI)
qed

lemma sup_eq_neg_inf: "sup a b = - inf (- a) (- b)"
proof (rule sup_unique)
  fix a b c :: 'a
  show "a \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  show "b \<le> - inf (- a) (- b)"
    by (rule add_le_imp_le_right [of _ "inf (uminus a) (uminus b)"])
      (simp, simp add: add_inf_distrib_left)
  assume "a \<le> c" "b \<le> c"
  then show "- inf (- a) (- b) \<le> c"
    by (subst neg_le_iff_le [symmetric]) (simp add: le_infI)
qed

lemma neg_inf_eq_sup: "- inf a b = sup (- a) (- b)"
  by (simp add: inf_eq_neg_sup)

lemma diff_inf_eq_sup: "a - inf b c = a + sup (- b) (- c)"
  using neg_inf_eq_sup [of b c, symmetric] by simp

lemma neg_sup_eq_inf: "- sup a b = inf (- a) (- b)"
  by (simp add: sup_eq_neg_inf)

lemma diff_sup_eq_inf: "a - sup b c = a + inf (- b) (- c)"
  using neg_sup_eq_inf [of b c, symmetric] by simp

lemma add_eq_inf_sup: "a + b = sup a b + inf a b"
proof -
  have "0 = - inf 0 (a - b) + inf (a - b) 0"
    by (simp add: inf_commute)
  then have "0 = sup 0 (b - a) + inf (a - b) 0"
    by (simp add: inf_eq_neg_sup)
  then have "0 = (- a + sup a b) + (inf a b + (- b))"
    by (simp only: add_sup_distrib_left add_inf_distrib_right) simp
  then show ?thesis
    by (simp add: algebra_simps)
qed

subsection \<open>Positive Part, Negative Part, Absolute Value\<close>

definition nprt :: "'a \<Rightarrow> 'a"
  where "nprt x = inf x 0"

definition pprt :: "'a \<Rightarrow> 'a"
  where "pprt x = sup x 0"

lemma pprt_neg: "pprt (- x) = - nprt x"
proof -
  have "sup (- x) 0 = sup (- x) (- 0)"
    unfolding minus_zero ..
  also have "\<dots> = - inf x 0"
    unfolding neg_inf_eq_sup ..
  finally have "sup (- x) 0 = - inf x 0" .
  then show ?thesis
    unfolding pprt_def nprt_def .
qed

lemma nprt_neg: "nprt (- x) = - pprt x"
proof -
  from pprt_neg have "pprt (- (- x)) = - nprt (- x)" .
  then have "pprt x = - nprt (- x)" by simp
  then show ?thesis by simp
qed

lemma prts: "a = pprt a + nprt a"
  by (simp add: pprt_def nprt_def add_eq_inf_sup[symmetric])

lemma zero_le_pprt[simp]: "0 \<le> pprt a"
  by (simp add: pprt_def)

lemma nprt_le_zero[simp]: "nprt a \<le> 0"
  by (simp add: nprt_def)

lemma le_eq_neg: "a \<le> - b \<longleftrightarrow> a + b \<le> 0"
  (is "?l = ?r")
proof
  assume ?l
  then show ?r
    apply -
    apply (rule add_le_imp_le_right[of _ "uminus b" _])
    apply (simp add: add.assoc)
    done
next
  assume ?r
  then show ?l
    apply -
    apply (rule add_le_imp_le_right[of _ "b" _])
    apply simp
    done
qed

lemma pprt_0[simp]: "pprt 0 = 0" by (simp add: pprt_def)
lemma nprt_0[simp]: "nprt 0 = 0" by (simp add: nprt_def)

lemma pprt_eq_id [simp, no_atp]: "0 \<le> x \<Longrightarrow> pprt x = x"
  by (simp add: pprt_def sup_absorb1)

lemma nprt_eq_id [simp, no_atp]: "x \<le> 0 \<Longrightarrow> nprt x = x"
  by (simp add: nprt_def inf_absorb1)

lemma pprt_eq_0 [simp, no_atp]: "x \<le> 0 \<Longrightarrow> pprt x = 0"
  by (simp add: pprt_def sup_absorb2)

lemma nprt_eq_0 [simp, no_atp]: "0 \<le> x \<Longrightarrow> nprt x = 0"
  by (simp add: nprt_def inf_absorb2)

lemma sup_0_imp_0:
  assumes "sup a (- a) = 0"
  shows "a = 0"
proof -
  have p: "0 \<le> a" if "sup a (- a) = 0" for a :: 'a
  proof -
    from that have "sup a (- a) + a = a"
      by simp
    then have "sup (a + a) 0 = a"
      by (simp add: add_sup_distrib_right)
    then have "sup (a + a) 0 \<le> a"
      by simp
    then show ?thesis
      by (blast intro: order_trans inf_sup_ord)
  qed
  from assms have **: "sup (-a) (-(-a)) = 0"
    by (simp add: sup_commute)
  from p[OF assms] p[OF **] show "a = 0"
    by simp
qed

lemma inf_0_imp_0: "inf a (- a) = 0 \<Longrightarrow> a = 0"
  apply (simp add: inf_eq_neg_sup)
  apply (simp add: sup_commute)
  apply (erule sup_0_imp_0)
  done

lemma inf_0_eq_0 [simp, no_atp]: "inf a (- a) = 0 \<longleftrightarrow> a = 0"
  apply rule
  apply (erule inf_0_imp_0)
  apply simp
  done

lemma sup_0_eq_0 [simp, no_atp]: "sup a (- a) = 0 \<longleftrightarrow> a = 0"
  apply rule
  apply (erule sup_0_imp_0)
  apply simp
  done

lemma zero_le_double_add_iff_zero_le_single_add [simp]: "0 \<le> a + a \<longleftrightarrow> 0 \<le> a"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show ?rhs if ?lhs
  proof -
    from that have a: "inf (a + a) 0 = 0"
      by (simp add: inf_commute inf_absorb1)
    have "inf a 0 + inf a 0 = inf (inf (a + a) 0) a"  (is "?l = _")
      by (simp add: add_sup_inf_distribs inf_aci)
    then have "?l = 0 + inf a 0"
      by (simp add: a, simp add: inf_commute)
    then have "inf a 0 = 0"
      by (simp only: add_right_cancel)
    then show ?thesis
      unfolding le_iff_inf by (simp add: inf_commute)
  qed
  show ?lhs if ?rhs
    by (simp add: add_mono[OF that that, simplified])
qed

lemma double_zero [simp]: "a + a = 0 \<longleftrightarrow> a = 0"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  show ?rhs if ?lhs
  proof -
    from that have "a + a + - a = - a"
      by simp
    then have "a + (a + - a) = - a"
      by (simp only: add.assoc)
    then have a: "- a = a"
      by simp
    show ?thesis
      apply (rule antisym)
      apply (unfold neg_le_iff_le [symmetric, of a])
      unfolding a
      apply simp
      unfolding zero_le_double_add_iff_zero_le_single_add [symmetric, of a]
      unfolding that
      unfolding le_less
      apply simp_all
      done
  qed
  show ?lhs if ?rhs
    using that by simp
qed

lemma zero_less_double_add_iff_zero_less_single_add [simp]: "0 < a + a \<longleftrightarrow> 0 < a"
proof (cases "a = 0")
  case True
  then show ?thesis by auto
next
  case False
  then show ?thesis
    unfolding less_le
    apply simp
    apply rule
    apply clarify
    apply rule
    apply assumption
    apply (rule notI)
    unfolding double_zero [symmetric, of a]
    apply blast
    done
qed

lemma double_add_le_zero_iff_single_add_le_zero [simp]: "a + a \<le> 0 \<longleftrightarrow> a \<le> 0"
proof -
  have "a + a \<le> 0 \<longleftrightarrow> 0 \<le> - (a + a)"
    by (subst le_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a \<le> 0"
    by (simp only: minus_add_distrib zero_le_double_add_iff_zero_le_single_add) simp
  ultimately show ?thesis
    by blast
qed

lemma double_add_less_zero_iff_single_less_zero [simp]: "a + a < 0 \<longleftrightarrow> a < 0"
proof -
  have "a + a < 0 \<longleftrightarrow> 0 < - (a + a)"
    by (subst less_minus_iff) simp
  moreover have "\<dots> \<longleftrightarrow> a < 0"
    by (simp only: minus_add_distrib zero_less_double_add_iff_zero_less_single_add) simp
  ultimately show ?thesis
    by blast
qed

declare neg_inf_eq_sup [simp] neg_sup_eq_inf [simp] diff_inf_eq_sup [simp] diff_sup_eq_inf [simp]

lemma le_minus_self_iff: "a \<le> - a \<longleftrightarrow> a \<le> 0"
proof -
  from add_le_cancel_left [of "uminus a" "plus a a" zero]
  have "a \<le> - a \<longleftrightarrow> a + a \<le> 0"
    by (simp add: add.assoc[symmetric])
  then show ?thesis
    by simp
qed

lemma minus_le_self_iff: "- a \<le> a \<longleftrightarrow> 0 \<le> a"
proof -
  have "- a \<le> a \<longleftrightarrow> 0 \<le> a + a"
    using add_le_cancel_left [of "uminus a" zero "plus a a"]
    by (simp add: add.assoc[symmetric])
  then show ?thesis
    by simp
qed

lemma zero_le_iff_zero_nprt: "0 \<le> a \<longleftrightarrow> nprt a = 0"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma le_zero_iff_zero_pprt: "a \<le> 0 \<longleftrightarrow> pprt a = 0"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma le_zero_iff_pprt_id: "0 \<le> a \<longleftrightarrow> pprt a = a"
  unfolding le_iff_sup by (simp add: pprt_def sup_commute)

lemma zero_le_iff_nprt_id: "a \<le> 0 \<longleftrightarrow> nprt a = a"
  unfolding le_iff_inf by (simp add: nprt_def inf_commute)

lemma pprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> pprt a \<le> pprt b"
  unfolding le_iff_sup by (simp add: pprt_def sup_aci sup_assoc [symmetric, of a])

lemma nprt_mono [simp, no_atp]: "a \<le> b \<Longrightarrow> nprt a \<le> nprt b"
  unfolding le_iff_inf by (simp add: nprt_def inf_aci inf_assoc [symmetric, of a])

end

lemmas add_sup_inf_distribs =
  add_inf_distrib_right add_inf_distrib_left add_sup_distrib_right add_sup_distrib_left

class lattice_ab_group_add_abs = lattice_ab_group_add + abs +
  assumes abs_lattice: "\<bar>a\<bar> = sup a (- a)"
begin

lemma abs_prts: "\<bar>a\<bar> = pprt a - nprt a"
proof -
  have "0 \<le> \<bar>a\<bar>"
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show ?thesis
      by (rule add_mono [OF a b, simplified])
  qed
  then have "0 \<le> sup a (- a)"
    unfolding abs_lattice .
  then have "sup (sup a (- a)) 0 = sup a (- a)"
    by (rule sup_absorb1)
  then show ?thesis
    by (simp add: add_sup_inf_distribs ac_simps pprt_def nprt_def abs_lattice)
qed

subclass ordered_ab_group_add_abs
proof
  have abs_ge_zero [simp]: "0 \<le> \<bar>a\<bar>" for a
  proof -
    have a: "a \<le> \<bar>a\<bar>" and b: "- a \<le> \<bar>a\<bar>"
      by (auto simp add: abs_lattice)
    show "0 \<le> \<bar>a\<bar>"
      by (rule add_mono [OF a b, simplified])
  qed
  have abs_leI: "a \<le> b \<Longrightarrow> - a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" for a b
    by (simp add: abs_lattice le_supI)
  fix a b
  show "0 \<le> \<bar>a\<bar>"
    by simp
  show "a \<le> \<bar>a\<bar>"
    by (auto simp add: abs_lattice)
  show "\<bar>-a\<bar> = \<bar>a\<bar>"
    by (simp add: abs_lattice sup_commute)
  show "- a \<le> b \<Longrightarrow> \<bar>a\<bar> \<le> b" if "a \<le> b"
    using that by (rule abs_leI)
  show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
  proof -
    have g: "\<bar>a\<bar> + \<bar>b\<bar> = sup (a + b) (sup (- a - b) (sup (- a + b) (a + (- b))))"
      (is "_ = sup ?m ?n")
      by (simp add: abs_lattice add_sup_inf_distribs ac_simps)
    have a: "a + b \<le> sup ?m ?n"
      by simp
    have b: "- a - b \<le> ?n"
      by simp
    have c: "?n \<le> sup ?m ?n"
      by simp
    from b c have d: "- a - b \<le> sup ?m ?n"
      by (rule order_trans)
    have e: "- a - b = - (a + b)"
      by simp
    from a d e have "\<bar>a + b\<bar> \<le> sup ?m ?n"
      apply -
      apply (drule abs_leI)
      apply (simp_all only: algebra_simps minus_add)
      apply (metis add_uminus_conv_diff d sup_commute uminus_add_conv_diff)
      done
    with g[symmetric] show ?thesis by simp
  qed
qed

end

lemma sup_eq_if:
  fixes a :: "'a::{lattice_ab_group_add,linorder}"
  shows "sup a (- a) = (if a < 0 then - a else a)"
  using add_le_cancel_right [of a a "- a", symmetric, simplified]
    and add_le_cancel_right [of "-a" a a, symmetric, simplified]
  by (auto simp: sup_max max.absorb1 max.absorb2)

lemma abs_if_lattice:
  fixes a :: "'a::{lattice_ab_group_add_abs,linorder}"
  shows "\<bar>a\<bar> = (if a < 0 then - a else a)"
  by auto

lemma estimate_by_abs:
  fixes a b c :: "'a::lattice_ab_group_add_abs"
  assumes "a + b \<le> c"
  shows "a \<le> c + \<bar>b\<bar>"
proof -
  from assms have "a \<le> c + (- b)"
    by (simp add: algebra_simps)
  have "- b \<le> \<bar>b\<bar>"
    by (rule abs_ge_minus_self)
  then have "c + (- b) \<le> c + \<bar>b\<bar>"
    by (rule add_left_mono)
  with \<open>a \<le> c + (- b)\<close> show ?thesis
    by (rule order_trans)
qed

class lattice_ring = ordered_ring + lattice_ab_group_add_abs
begin

subclass semilattice_inf_ab_group_add ..
subclass semilattice_sup_ab_group_add ..

end

lemma abs_le_mult:
  fixes a b :: "'a::lattice_ring"
  shows "\<bar>a * b\<bar> \<le> \<bar>a\<bar> * \<bar>b\<bar>"
proof -
  let ?x = "pprt a * pprt b - pprt a * nprt b - nprt a * pprt b + nprt a * nprt b"
  let ?y = "pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
  have a: "\<bar>a\<bar> * \<bar>b\<bar> = ?x"
    by (simp only: abs_prts[of a] abs_prts[of b] algebra_simps)
  have bh: "u = a \<Longrightarrow> v = b \<Longrightarrow>
            u * v = pprt a * pprt b + pprt a * nprt b +
                    nprt a * pprt b + nprt a * nprt b" for u v :: 'a
    apply (subst prts[of u], subst prts[of v])
    apply (simp add: algebra_simps)
    done
  note b = this[OF refl[of a] refl[of b]]
  have xy: "- ?x \<le> ?y"
    apply simp
    apply (metis (full_types) add_increasing add_uminus_conv_diff
      lattice_ab_group_add_class.minus_le_self_iff minus_add_distrib mult_nonneg_nonneg
      mult_nonpos_nonpos nprt_le_zero zero_le_pprt)
    done
  have yx: "?y \<le> ?x"
    apply simp
    apply (metis (full_types) add_nonpos_nonpos add_uminus_conv_diff
      lattice_ab_group_add_class.le_minus_self_iff minus_add_distrib mult_nonneg_nonpos
      mult_nonpos_nonneg nprt_le_zero zero_le_pprt)
    done
  have i1: "a * b \<le> \<bar>a\<bar> * \<bar>b\<bar>"
    by (simp only: a b yx)
  have i2: "- (\<bar>a\<bar> * \<bar>b\<bar>) \<le> a * b"
    by (simp only: a b xy)
  show ?thesis
    apply (rule abs_leI)
    apply (simp add: i1)
    apply (simp add: i2[simplified minus_le_iff])
    done
qed

instance lattice_ring \<subseteq> ordered_ring_abs
proof
  fix a b :: "'a::lattice_ring"
  assume a: "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0)"
  show "\<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
  proof -
    have s: "(0 \<le> a * b) \<or> (a * b \<le> 0)"
      apply auto
      apply (rule_tac split_mult_pos_le)
      apply (rule_tac contrapos_np[of "a * b \<le> 0"])
      apply simp
      apply (rule_tac split_mult_neg_le)
      using a
      apply blast
      done
    have mulprts: "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
      by (simp add: prts[symmetric])
    show ?thesis
    proof (cases "0 \<le> a * b")
      case True
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        using a
        apply (auto simp add:
          algebra_simps
          iffD1[OF zero_le_iff_zero_nprt] iffD1[OF le_zero_iff_zero_pprt]
          iffD1[OF le_zero_iff_pprt_id] iffD1[OF zero_le_iff_nprt_id])
        apply(drule (1) mult_nonneg_nonpos[of a b], simp)
        apply(drule (1) mult_nonneg_nonpos2[of b a], simp)
        done
    next
      case False
      with s have "a * b \<le> 0"
        by simp
      then show ?thesis
        apply (simp_all add: mulprts abs_prts)
        apply (insert a)
        apply (auto simp add: algebra_simps)
        apply(drule (1) mult_nonneg_nonneg[of a b],simp)
        apply(drule (1) mult_nonpos_nonpos[of a b],simp)
        done
    qed
  qed
qed

lemma mult_le_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<le>
    pprt a2 * pprt b2 + pprt a1 * nprt b2 + nprt a2 * pprt b1 + nprt a1 * nprt b1"
proof -
  have "a * b = (pprt a + nprt a) * (pprt b + nprt b)"
    by (subst prts[symmetric])+ simp
  then have "a * b = pprt a * pprt b + pprt a * nprt b + nprt a * pprt b + nprt a * nprt b"
    by (simp add: algebra_simps)
  moreover have "pprt a * pprt b \<le> pprt a2 * pprt b2"
    by (simp_all add: assms mult_mono)
  moreover have "pprt a * nprt b \<le> pprt a1 * nprt b2"
  proof -
    have "pprt a * nprt b \<le> pprt a * nprt b2"
      by (simp add: mult_left_mono assms)
    moreover have "pprt a * nprt b2 \<le> pprt a1 * nprt b2"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * pprt b \<le> nprt a2 * pprt b1"
  proof -
    have "nprt a * pprt b \<le> nprt a2 * pprt b"
      by (simp add: mult_right_mono assms)
    moreover have "nprt a2 * pprt b \<le> nprt a2 * pprt b1"
      by (simp add: mult_left_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  moreover have "nprt a * nprt b \<le> nprt a1 * nprt b1"
  proof -
    have "nprt a * nprt b \<le> nprt a * nprt b1"
      by (simp add: mult_left_mono_neg assms)
    moreover have "nprt a * nprt b1 \<le> nprt a1 * nprt b1"
      by (simp add: mult_right_mono_neg assms)
    ultimately show ?thesis
      by simp
  qed
  ultimately show ?thesis
    by - (rule add_mono | simp)+
qed

lemma mult_ge_prts:
  fixes a b :: "'a::lattice_ring"
  assumes "a1 \<le> a"
    and "a \<le> a2"
    and "b1 \<le> b"
    and "b \<le> b2"
  shows "a * b \<ge>
    nprt a1 * pprt b2 + nprt a2 * nprt b2 + pprt a1 * pprt b1 + pprt a2 * nprt b1"
proof -
  from assms have a1: "- a2 \<le> -a"
    by auto
  from assms have a2: "- a \<le> -a1"
    by auto
  from mult_le_prts[of "- a2" "- a" "- a1" "b1" b "b2",
    OF a1 a2 assms(3) assms(4), simplified nprt_neg pprt_neg]
  have le: "- (a * b) \<le>
    - nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
    - pprt a1 * pprt b1 + - pprt a2 * nprt b1"
    by simp
  then have "- (- nprt a1 * pprt b2 + - nprt a2 * nprt b2 +
      - pprt a1 * pprt b1 + - pprt a2 * nprt b1) \<le> a * b"
    by (simp only: minus_le_iff)
  then show ?thesis
    by (simp add: algebra_simps)
qed

instance int :: lattice_ring
proof
  fix k :: int
  show "\<bar>k\<bar> = sup k (- k)"
    by (auto simp add: sup_int_def)
qed

instance real :: lattice_ring
proof
  fix a :: real
  show "\<bar>a\<bar> = sup a (- a)"
    by (auto simp add: sup_real_def)
qed

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.
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_prop_45
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
"zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

theorem property0 :
  "((zip (cons2 x xs) (cons2 y ys)) = (cons2 (pair2 x y) (zip xs ys)))"
  find_proof DInd
  apply (induct arbitrary: xs)
  apply auto
  done

theorem property0' :
  "((zip (cons2 x xs) (cons2 y ys)) = (cons2 (pair2 x y) (zip xs ys)))"
  (*Why "induct xs"?
    Because of "(zip xs ys)" on the right-hand side.*)
  apply (induct xs)
  apply auto
  done

end


theory IMP
  imports Main
begin

(* Data type definitions *)

(* Arithmetic expression (i.e. aexp) primitives from 3.1.1 *)
type_synonym vname = string
datatype aexp =
  N int
  | V vname
  | Plus aexp aexp

(* Variable state primitives from 3.1.2 *)
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

(* Boolean expression (i.e. bexp) primitive from 3.2 *)
datatype bexp =
  Bc bool
  | Not bexp
  | And bexp bexp
  | Less aexp aexp

(* IMP language command (i.e. com) specification from 7.1 *)
datatype com =
  SKIP
  | Assign vname aexp ("_ ::= _")
  | Seq com com ("_ ;; _")
  | If bexp com com ("IF _ THEN _ ELSE _")
  | While bexp com ("WHILE _ DO _")

(* Convenient helpers *)
fun Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or a b = (Not (And (Not a) (Not b)))"

fun Cond :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Cond a b = (Or (Not a) b)"

fun VarEq :: "vname \<Rightarrow> aexp \<Rightarrow> bexp" where
"VarEq x a = (And (Not (Less (V x) a)) (Not (Less a (V x))))"

(* Semantic definitions *)

(* Arithmetic expression evaluation from 3.1.2 *)
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s= s x" |
"aval (Plus a1 a2) s = aval a1 s + aval a2 s"

(* Boolean expression evaluation from 3.2 *)
fun bval :: "bexp \<Rightarrow> state \<Rightarrow> bool" where
"bval (Bc v) s = v" |
"bval (Not b) s = (\<not> bval b s)" |
"bval (And b1 b2) s = (bval b1 s \<and> bval b2 s)" |
"bval (Less a1 a2) s = (aval a1 s < aval a2 s)"

(* Big-step semantics for IMP from 7.2.1 *)
inductive big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool"
  (infix "\<Rightarrow>" 55) where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "
  \<lbrakk> (c1,s1) \<Rightarrow> s2; (c2,s2) \<Rightarrow> s3 \<rbrakk>
  \<Longrightarrow> (c1;;c2,s1) \<Rightarrow> s3
" |
IfTrue: "
  \<lbrakk> bval b s; (c1,s) \<Rightarrow>t \<rbrakk>
  \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<Rightarrow> t
" |
IfFalse: "
  \<lbrakk> \<not>bval b s; (c2,s) \<Rightarrow> t \<rbrakk>
  \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<Rightarrow> t
" |
WhileFalse: "
  \<not>bval b s
  \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s
" |
WhileTrue: "
  \<lbrakk> bval b s1; (c,s1) \<Rightarrow> s2; (WHILE b DO c,s2) \<Rightarrow> s3 \<rbrakk>
  \<Longrightarrow> (WHILE b DO c,s1) \<Rightarrow> s3
"

(* Big step tweaks to simplify usage as found in
   the implementation included in the Isabelle source *)
declare big_step.intros [intro]
lemmas big_step_induct = big_step.induct[split_format(complete)]
inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
inductive_cases AssignE[elim!]: "(x ::= c,s) \<Rightarrow> t"
inductive_cases SeqE[elim!]: "(c1 ;; c2,s) \<Rightarrow> t"
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"

(* Small-step semantic rules from 7.3 *)
inductive small_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool"
  (infix "\<rightarrow>" 55) where
Assign: "(x ::= a,s) \<rightarrow> (SKIP,s(x := aval a s))" |
Seq1: "(SKIP;;c2,s) \<rightarrow> (c2,s)" |
Seq2: "(c1,s) \<rightarrow> (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow> (c1';;c2,s')" |
IfTrue: "bval b s \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c1 ELSE c2,s) \<rightarrow> (c2,s)" |
While: "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;;WHILE b DO c ELSE SKIP,s)"

(* Semantic helpers *)

(* Rule inversion equivalence lemmas from 7.2.3 *)
lemma skip_state_equiv:
  "(SKIP,s) \<Rightarrow> t \<longleftrightarrow> t = s" (is "?LHS \<longleftrightarrow> ?RHS")
proof
  assume "?LHS"
  thus "?RHS" by cases
next
  assume "?RHS"
  thus "?LHS" by (simp add: Skip)
qed

lemma assign_state:
  "(x ::= a,s) \<Rightarrow> t \<longleftrightarrow> t = s(x := aval a s)"
  (is "?LHS \<longleftrightarrow> ?RHS")
proof
  assume "?LHS"
  thus "?RHS" by cases
next
  assume "?RHS"
  thus "?LHS" using big_step.Assign by blast
qed

lemma inter_seq:
  "(c1 ;; c2,s1) \<Rightarrow> s3
    \<longleftrightarrow> (\<exists>s2. ((c1,s1) \<Rightarrow> s2 \<and> (c2,s2) \<Rightarrow> s3))"
  (is "?LHS \<longleftrightarrow> ?RHS")
proof
  assume "?LHS"
  thus "?RHS"
  proof cases
    case Seq thus ?thesis by auto
  qed
next
  assume "?RHS"
  thus "?LHS" using Seq by blast
qed

lemma while_split:
  "(WHILE b DO c,s) \<Rightarrow> t
    \<longleftrightarrow> (
      \<not> bval b s \<and> t = s
      \<or> bval b s
        \<and> (\<exists>s'. (c,s) \<Rightarrow> s'
            \<and> (WHILE b DO c,s') \<Rightarrow> t))"
  (is "?LHS \<longleftrightarrow> ?RHS")
proof
  assume "?LHS"
  thus "?RHS"
  proof cases
    case WhileFalse
    thus ?thesis by auto
  next
    case WhileTrue
    thus ?thesis by auto
  qed
next
  assume "?RHS"
  thus "?LHS"
    using WhileFalse WhileTrue by blast
qed

(* Associativity of Seq from 7.2.3 *)
lemma seq_assoc:
  "((c1 ;; c2) ;; c3,s) \<Rightarrow> s'
   \<longleftrightarrow> (c1 ;; (c2 ;; c3),s) \<Rightarrow> s'"
  (is "?LHS \<longleftrightarrow> ?RHS")
proof
  assume "?LHS"
  then obtain s1 s2 where
    "(c1,s) \<Rightarrow> s1" and
    "(c2,s1) \<Rightarrow> s2" and
    "(c3,s2) \<Rightarrow> s'"
    using inter_seq by blast
  thus "?RHS" by (simp add: Seq)
next
  assume "?RHS"
  then obtain s1 s2 where
    "(c1,s) \<Rightarrow> s1" and
    "(c2,s1) \<Rightarrow> s2" and
    "(c3,s2) \<Rightarrow> s'"
    using inter_seq by blast
  thus "?LHS"
    using Seq by blast
qed

(* Big-step equivalence from 7.2.4 *)
abbreviation equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool"
  (infix "\<sim>" 50) where
"c \<sim> c' \<equiv> (\<forall>s. \<forall>t. ((c,s) \<Rightarrow> t = (c',s) \<Rightarrow> t))"

(* While is equivalent to a single unfold of itself *)
lemma while_is_unfolded_while:
  "(WHILE b DO c)
    \<sim> (IF b THEN c ;; WHILE b DO c ELSE SKIP)"
  (is "?LHS \<sim> ?RHS")
proof -
  have "(?RHS,s) \<Rightarrow> t" if assm: "(?LHS,s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases
      case WhileTrue
      from this `bval b s` `(?LHS,s) \<Rightarrow> t`
      obtain s'
        where "(c,s) \<Rightarrow> s'" and "(?LHS,s') \<Rightarrow> t"
        by blast
      hence "(c ;; ?LHS,s) \<Rightarrow> t" by (rule Seq)
      thus ?thesis using `bval b s` by auto
    next
      case WhileFalse
      thus ?thesis by auto
    qed
  qed
  moreover
  have "(?LHS,s) \<Rightarrow> t" if assm: "(?RHS,s) \<Rightarrow> t" for s t
  proof -
    from assm show ?thesis
    proof cases
      case IfTrue
      from this inter_seq obtain s'
        where "(c,s) \<Rightarrow> s'" and "(?LHS,s') \<Rightarrow> t"
        by blast
      thus ?thesis using IfTrue by blast
    next
      case IfFalse
      hence "s = t" using skip_state_equiv by simp
      thus ?thesis using IfFalse by blast
    qed
  qed
  ultimately
  show ?thesis by blast
qed

(* The previous proof is likely clearer,
   but all that inductive_case stuff allows
   full auto here *)
lemma "(WHILE b DO c) \<sim> (IF b THEN c ;; WHILE b DO c ELSE SKIP)"
  by blast

(* A command in both if clauses is equivalent
   to the command (from 7.2.4) *)
lemma if_both_com_is_com:
  "(IF b THEN c ELSE c) \<sim> c"
  by blast

(* Equivalent commands yeild equivalent while loops
   (from 7.2.4) *)
lemma while_equiv_complex:
  "\<lbrakk> (WHILE b DO c,s) \<Rightarrow> t ; c \<sim> c' \<rbrakk>
    \<Longrightarrow> (WHILE b DO c',s) \<Rightarrow> t"
  apply (induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
   apply blast
  apply blast
  done

corollary while_equiv:
  "c \<sim> c' \<Longrightarrow> ((WHILE b DO c) \<sim> (WHILE b DO c'))"
  by (meson while_equiv_complex)

(* Big-step equivalence is an equivalence relation *)
theorem refl_equiv_c: "c \<sim> c" by auto
theorem sym_equiv_c: "c1 \<sim> c2 \<Longrightarrow> c2 \<sim> c1" by auto
theorem trans_equiv_c: "c1 \<sim> c2 \<and> c2 \<sim> c3 \<Longrightarrow> c1 \<sim> c3"
  by auto

(* IMP is deterministic from 7.2.5 *)
theorem imp_deterministic:
  "(c,s) \<Rightarrow> t \<Longrightarrow> (c,s) \<Rightarrow> t' \<Longrightarrow> t' = t"
proof (induction arbitrary: t' rule: big_step.induct)
  fix b c s s1 t t'
  assume "bval b s"
    and "(c,s) \<Rightarrow> s1"
    and "(WHILE b DO c,s1) \<Rightarrow> t"
  assume IHc: "\<And>t'. (c,s) \<Rightarrow> t' \<Longrightarrow> t' = s1"
  assume IHw: "\<And>t'. (WHILE b DO c,s1) \<Rightarrow> t' \<Longrightarrow> t' = t"
  assume "(WHILE b DO c,s) \<Rightarrow> t'"
  with `bval b s` obtain s1' where
    c: "(c,s) \<Rightarrow> s1'" and
    w: "(WHILE b DO c,s1') \<Rightarrow> t'"
    by auto
  from c IHc have "s1' = s1" by blast
  with w IHw show "t' = t" by blast
qed blast+

(* Reflexive transitive closure from 4.5.2 *)
(* Needed for closure of small-step semantic *)
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
  for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

(* Closure of small-step sequences from 7.3 *)
abbreviation small_step_closure :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool"
  (infix "\<rightarrow>*" 55) where
"x \<rightarrow>* y \<equiv> star small_step x y"

end


(*
  File:     Furstenberg_Topology.thy
  Author:   Manuel Eberl, TU München
*)
section \<open>Furstenberg's topology and his proof of the infinitude of primes\<close>
theory Furstenberg_Topology
  imports
    "HOL-Real_Asymp.Real_Asymp"
    "HOL-Analysis.Analysis"
    "HOL-Number_Theory.Number_Theory"
begin

text \<open>
  This article gives a formal version of Furstenberg's topological proof of the infinitude of
  primes~\cite{furstenberg}. He defines a topology on the integers based on arithmetic progressions
  (or, equivalently, residue classes).

  Apart from yielding a short proof of the infinitude of primes, this topology is also fairly
  `nice' in general: it is second countable, metrizable, and perfect. All of these (well-known)
  facts will be formally proven below.
\<close>

subsection \<open>Arithmetic progressions of integers\<close>

text \<open>
  We first define `bidirectional infinite arithmetic progressions' on \<open>\<int>\<close> in the sense that
  to an integer \<open>a\<close> and a positive integer \<open>b\<close>, we associate all the integers \<open>x\<close> such that
  $x \equiv a\ (\text{mod}\ b)$, or, equivalently, $\{a + nb\mid n\in\mathbb{Z}\}$.
\<close>

definition arith_prog :: "int \<Rightarrow> nat \<Rightarrow> int set" where
  "arith_prog a b = {x. [x = a] (mod int b)}"

lemma arith_prog_0_right [simp]: "arith_prog a 0 = {a}"
  by (simp add: arith_prog_def)

lemma arith_prog_Suc_0_right [simp]: "arith_prog a (Suc 0) = UNIV"
  by (auto simp: arith_prog_def)

lemma in_arith_progI [intro]: "[x = a] (mod b) \<Longrightarrow> x \<in> arith_prog a b"
  by (auto simp: arith_prog_def)

text \<open>
  Two arithmetic progressions with the same period and noncongruent starting points are
  disjoint.
\<close>
lemma arith_prog_disjoint:
  assumes "[a \<noteq> a'] (mod int b)" and "b > 0"
  shows   "arith_prog a b \<inter> arith_prog a' b = {}"
  using assms by (auto simp: arith_prog_def cong_def)

text \<open>
  Multiplying the period gives us a subset of the original progression.
\<close>
lemma arith_prog_dvd_mono: "b dvd b' \<Longrightarrow> arith_prog a b' \<subseteq> arith_prog a b"
  by (auto simp: arith_prog_def cong_dvd_modulus)

text \<open>
  The following proves the alternative definition mentioned above.
\<close>
lemma bij_betw_arith_prog:
  assumes "b > 0"
  shows   "bij_betw (\<lambda>n. a + int b * n) UNIV (arith_prog a b)"
proof (rule bij_betwI[of _ _ _ "\<lambda>x. (x - a) div int b"], goal_cases)
  case 1
  thus ?case
    by (auto simp: arith_prog_def cong_add_lcancel_0 cong_mult_self_right mult_of_nat_commute)
next
  case 4
  thus ?case
    by (auto simp: arith_prog_def cong_iff_lin)
qed (use \<open>b > 0\<close> in \<open>auto simp: arith_prog_def\<close>)

lemma arith_prog_altdef: "arith_prog a b = range (\<lambda>n. a + int b * n)"
proof (cases "b = 0")
  case False
  thus ?thesis
    using bij_betw_arith_prog[of b] by (auto simp: bij_betw_def)
qed auto

text \<open>
  A simple corollary from this is also that any such arithmetic progression is infinite.
\<close>
lemma infinite_arith_prog: "b > 0 \<Longrightarrow> infinite (arith_prog a b)"
  using bij_betw_finite[OF bij_betw_arith_prog[of b]] by simp

subsection \<open>The Furstenberg topology on \<open>\<int>\<close>\<close>

text \<open>
  The typeclass-based topology is somewhat nicer to use in Isabelle/HOL, but the integers,
  of course, already have a topology associated to them. We therefore need to introduce a type
  copy of the integers and furnish them with the new topology. We can easily convert between
  them and the `proper' integers using Lifting and Transfer.
\<close>
typedef fbint = "UNIV :: int set"
  morphisms int_of_fbint fbint ..

setup_lifting type_definition_fbint

lift_definition arith_prog_fb :: "int \<Rightarrow> nat \<Rightarrow> fbint set" is "arith_prog" .

instantiation fbint :: topological_space
begin

text \<open>
  Furstenberg defined the topology as the one generated by all arithmetic progressions.
  We use a slightly more explicit equivalent formulation that exploits the fact that
  the intersection of two arithmetic progressions is again an arithmetic progression (or empty).
\<close>
lift_definition open_fbint :: "fbint set \<Rightarrow> bool" is
  "\<lambda>U. (\<forall>x\<in>U. \<exists>b>0. arith_prog x b \<subseteq> U)" .

text \<open>
  We now prove that this indeed forms a topology.
\<close>
instance proof
  show "open (UNIV :: fbint set)"
    by transfer auto
next
  fix U V :: "fbint set"
  assume "open U" and "open V"
  show "open (U \<inter> V)"
  proof (use \<open>open U\<close> \<open>open V\<close> in transfer, safe)
    fix U V :: "int set" and x :: int
    assume U: "\<forall>x\<in>U. \<exists>b>0. arith_prog x b \<subseteq> U" and V: "\<forall>x\<in>V. \<exists>b>0. arith_prog x b \<subseteq> V"
    assume x: "x \<in> U" "x \<in> V"
    from U x obtain b1 where b1: "b1 > 0" "arith_prog x b1 \<subseteq> U" by auto
    from V x obtain b2 where b2: "b2 > 0" "arith_prog x b2 \<subseteq> V" by auto
    from b1 b2 have "lcm b1 b2 > 0" "arith_prog x (lcm b1 b2) \<subseteq> U \<inter> V"
      using arith_prog_dvd_mono[of b1 "lcm b1 b2" x] arith_prog_dvd_mono[of b2 "lcm b1 b2" x]
      by (auto simp: lcm_pos_nat)
    thus "\<exists>b>0. arith_prog x b \<subseteq> U \<inter> V" by blast
  qed
next
  fix F :: "fbint set set"
  assume *: "\<forall>U\<in>F. open U"
  show "open (\<Union>F)"
  proof (use * in transfer, safe)
    fix F :: "int set set" and U :: "int set" and x :: int
    assume F: "\<forall>U\<in>F. \<forall>x\<in>U. \<exists>b>0. arith_prog x b \<subseteq> U"
    assume "x \<in> U" "U \<in> F"
    with F obtain b where b: "b > 0" "arith_prog x b \<subseteq> U" by blast
    with \<open>U \<in> F\<close> show "\<exists>b>0. arith_prog x b \<subseteq> \<Union>F"
      by blast
  qed
qed

end

text \<open>
  Since any non-empty open set contains an arithmetic progression and arithmetic progressions
  are infinite, we obtain that all nonempty open sets are infinite.
\<close>
lemma open_fbint_imp_infinite:
  fixes U :: "fbint set"
  assumes "open U" and "U \<noteq> {}"
  shows   "infinite U"
  using assms
proof transfer
  fix U :: "int set"
  assume *: "\<forall>x\<in>U. \<exists>b>0. arith_prog x b \<subseteq> U" and "U \<noteq> {}"
  from \<open>U \<noteq> {}\<close> obtain x where "x \<in> U" by auto
  with * obtain b where b: "b > 0" "arith_prog x b \<subseteq> U" by auto
  from b have "infinite (arith_prog x b)"
    using infinite_arith_prog by blast
  with b show "infinite U"
    using finite_subset by blast
qed

lemma not_open_finite_fbint [simp]:
  assumes "finite (U :: fbint set)" "U \<noteq> {}"
  shows   "\<not>open U"
  using open_fbint_imp_infinite assms by blast

text \<open>
  More or less by definition, any arithmetic progression is open.
\<close>
lemma open_arith_prog_fb [intro]:
  assumes "b > 0"
  shows   "open (arith_prog_fb a b)"
  using assms
proof transfer
  fix a :: int and b :: nat
  assume "b > 0"
  show "\<forall>x\<in>arith_prog a b. \<exists>b'>0. arith_prog x b' \<subseteq> arith_prog a b"
  proof (intro ballI exI[of _ b] conjI)
    fix x assume "x \<in> arith_prog a b"
    thus "arith_prog x b \<subseteq> arith_prog a b"
      using cong_trans by (auto simp: arith_prog_def )
  qed (use \<open>b > 0\<close> in auto)
qed

text \<open>
  Slightly less obviously, any arithmetic progression is also closed.
  This can be seen by realising that for a period \<open>b\<close>, we can partition the integers
  into \<open>b\<close> congruence classes and then the complement of each congruence class is the
  union of the other \<open>b - 1\<close> classes, and unions of open sets are open.
\<close>
lemma closed_arith_prog_fb [intro]:
  assumes "b > 0"
  shows   "closed (arith_prog_fb a b)"
proof -
  have "open (-arith_prog_fb a b)"
  proof -
    have "-arith_prog_fb a b = (\<Union>i\<in>{1..<b}. arith_prog_fb (a+i) b)"
    proof (transfer fixing: b)
      fix a :: int
      have disjoint: "x \<notin> arith_prog a b" if "x \<in> arith_prog (a + int i) b" "i \<in> {1..<b}" for x i
      proof -
        have "[a \<noteq> a + int i] (mod int b)"
        proof
          assume "[a = a + int i] (mod int b)"
          hence "[a + 0 = a + int i] (mod int b)" by simp
          hence "[0 = int i] (mod int b)" by (subst (asm) cong_add_lcancel) auto
          with that show False by (auto simp: cong_def)
        qed
        thus ?thesis using arith_prog_disjoint[of a "a + int i" b] \<open>b > 0\<close> that by auto
      qed

      have covering: "x \<in> arith_prog a b \<or> x \<in> (\<Union>i\<in>{1..<b}. arith_prog (a + int i) b)" for x
      proof -
        define i where "i = nat ((x - a) mod (int b))"
        have "[a + int i = a + (x - a) mod int b] (mod int b)"
          unfolding i_def using \<open>b > 0\<close> by simp
        also have "[a + (x - a) mod int b = a + (x - a)] (mod int b)"
          by (intro cong_add) auto
        finally have "[x = a + int i] (mod int b)"
          by (simp add: cong_sym_eq)
        hence "x \<in> arith_prog (a + int i) b"
          using \<open>b > 0\<close> by (auto simp: arith_prog_def)
        moreover have "i < b" using \<open>b > 0\<close>
          by (auto simp: i_def nat_less_iff)
        ultimately show ?thesis using \<open>b > 0\<close>
          by (cases "i = 0") auto
      qed

      from disjoint and covering show "- arith_prog a b = (\<Union>i\<in>{1..<b}. arith_prog (a + int i) b)"
        by blast
    qed
    also from \<open>b > 0\<close> have "open \<dots>"
      by auto
    finally show ?thesis .
  qed
  thus ?thesis by (simp add: closed_def)
qed

subsection \<open>The infinitude of primes\<close>

text \<open>
  The infinite of the primes now follows quite obviously: The multiples of any prime form a
  closed set, so if there were only finitely many primes, the union of all of these would also
  be open. However, since any number other than \<open>\<plusminus>1\<close> has a prime divisor, the union of all these
  sets is simply \<open>\<int>\<setminus>{\<plusminus>1}\<close>, which is obviously \<^emph>\<open>not\<close> closed since the finite set \<open>{\<plusminus>1}\<close> is not
  open.
\<close>
theorem "infinite {p::nat. prime p}"
proof
  assume fin: "finite {p::nat. prime p}"
  define A where "A = (\<Union>p\<in>{p::nat. prime p}. arith_prog_fb 0 p)"
  have "closed A"
    unfolding A_def using fin by (intro closed_Union) (auto simp: prime_gt_0_nat)
  hence "open (-A)"
    by (simp add: closed_def)
  also have "A = -{fbint 1, fbint (-1)}"
    unfolding A_def
  proof transfer
    show "(\<Union>p\<in>{p::nat. prime p}. arith_prog 0 p) = - {1, - 1}"
    proof (intro equalityI subsetI)
      fix x :: int assume x: "x \<in> -{1, -1}"
      hence "\<bar>x\<bar> \<noteq> 1" by auto
      show "x \<in> (\<Union>p\<in>{p::nat. prime p}. arith_prog 0 p)"
      proof (cases "x = 0")
        case True
        thus ?thesis
          by (auto simp: A_def intro!: exI[of _ 2])
      next
        case [simp]: False
        obtain p where p: "prime p" "p dvd x"
          using prime_divisor_exists[of x] and \<open>\<bar>x\<bar> \<noteq> 1\<close> by auto
        hence "x \<in> arith_prog 0 (nat p)" using prime_gt_0_int[of p]
          by (auto simp: arith_prog_def cong_0_iff)
        thus ?thesis using p
          by (auto simp: A_def intro!: exI[of _ "nat p"])
      qed
    qed (auto simp: A_def arith_prog_def cong_0_iff)
  qed
  also have "-(-{fbint 1, fbint (-1)}) = {fbint 1, fbint (-1)}"
    by simp
  finally have "open {fbint 1, fbint (-1)}" .
  thus False by simp
qed

subsection \<open>Additional topological properties\<close>

text \<open>
  Just for fun, let us also show a few more properties of Furstenberg's topology.
  First, we show the equivalence to the above to Furstenberg's original definition
  (the topology generated by all arithmetic progressions).
\<close>

text \<open>
  From this, we can immediately see that it is second countable:
\<close>
instance fbint :: second_countable_topology
proof
  have "countable ((\<lambda>(a,b). arith_prog_fb a b) ` (UNIV \<times> {b. b > 0}))"
    by (intro countable_image) auto
  also have "\<dots> = {arith_prog_fb a b |a b. b > 0}"
    by auto
  ultimately show "\<exists>B::fbint set set. countable B \<and> open = generate_topology B"
    unfolding open_fbint_altdef by auto
qed

text \<open>
  A trivial consequence of the fact that nonempty open sets in this topology are infinite
  is that it is a perfect space:
\<close>
instance fbint :: perfect_space
  by standard auto

text \<open>
  It is also Hausdorff, since given any two distinct integers, we can easily
  construct two non-overlapping arithmetic progressions that each contain one of them.
  We do not \<^emph>\<open>really\<close> have to prove this since we will get it for free later on when we
  show that it is a metric space, but here is the proof anyway:
\<close>
instance fbint :: t2_space
proof
  fix x y :: fbint
  assume "x \<noteq> y"
  define d where "d = nat \<bar>int_of_fbint x - int_of_fbint y\<bar> + 1"
  from \<open>x \<noteq> y\<close> have "d > 0"
    unfolding d_def by transfer auto
  define U where "U = arith_prog_fb (int_of_fbint x) d"
  define V where "V = arith_prog_fb (int_of_fbint y) d"

  have "U \<inter> V = {}" unfolding U_def V_def d_def
  proof (use \<open>x \<noteq> y\<close> in transfer, rule arith_prog_disjoint)
    fix x y :: int
    assume "x \<noteq> y"
    show "[x \<noteq> y] (mod int (nat \<bar>x - y\<bar> + 1))"
    proof
      assume "[x = y] (mod int (nat \<bar>x - y\<bar> + 1))"
      hence "\<bar>x - y\<bar> + 1 dvd \<bar>x - y\<bar>"
        by (auto simp: cong_iff_dvd_diff algebra_simps)
      hence "\<bar>x - y\<bar> + 1 \<le> \<bar>x - y\<bar>"
        by (rule zdvd_imp_le) (use \<open>x \<noteq> y\<close> in auto)
      thus False by simp
    qed
  qed auto
  moreover have "x \<in> U" "y \<in> V"
    unfolding U_def V_def by (use \<open>d > 0\<close> in transfer, fastforce)+
  moreover have "open U" "open V"
    using \<open>d > 0\<close> by (auto simp: U_def V_def)
  ultimately show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}" by blast
qed

(* TODO Move? *)
text \<open>
  Next, we need a small lemma: Given an additional assumption, a $T_2$ space is also $T_3$:
\<close>
lemma t2_space_t3_spaceI:
  assumes "\<And>(x :: 'a :: t2_space) U. x \<in> U \<Longrightarrow> open U \<Longrightarrow>
             \<exists>V. x \<in> V \<and> open V \<and> closure V \<subseteq> U"
  shows   "OFCLASS('a, t3_space_class)"
proof
  fix X :: "'a set" and z :: 'a
  assume X: "closed X" "z \<notin> X"
  with assms[of z "-X"] obtain V where V: "z \<in> V" "open V" "closure V \<subseteq> -X"
    by auto
  show "\<exists>U V. open U \<and> open V \<and> z \<in> U \<and> X \<subseteq> V \<and> U \<inter> V = {}"
    by (rule exI[of _ V], rule exI[of _ "-closure V"])
       (use X V closure_subset[of V] in auto)
qed

text \<open>
  Since the Furstenberg topology is $T_2$ and every arithmetic progression is also closed,
  we can now easily show that it is also $T_3$ (i.\,e.\ regular).
  Again, we do not really need this proof, but here it is:
\<close>
instance fbint :: t3_space
proof (rule t2_space_t3_spaceI)
  fix x :: fbint and U :: "fbint set"
  assume "x \<in> U" and "open U"
  then obtain b where b: "b > 0" "arith_prog_fb (int_of_fbint x) b \<subseteq> U"
    by transfer blast
  define V where "V = arith_prog_fb (int_of_fbint x) b"
  have "x \<in> V"
    unfolding V_def by transfer auto
  moreover have "open V" "closed V"
    using \<open>b > 0\<close> by (auto simp: V_def)
  ultimately show "\<exists>V. x \<in> V \<and> open V \<and> closure V \<subseteq> U"
    using b by (intro exI[of _ V]) (auto simp: V_def)
qed

subsection \<open>Metrizability\<close>

text \<open>
  The metrizability of Furstenberg's topology (i.\,e.\ that it is induced by some metric) can
  be shown from the fact that it is second countable and $T_3$ using Urysohn's Metrization Theorem,
  but this is not available in Isabelle yet. Let us therefore give an \<^emph>\<open>explicit\<close> metric,
  as described by Zulfeqarr~\cite{zulfeqarr}. We follow the exposition by Dirmeier~\cite{dirmeier}.

  First, we define a kind of norm on the integers. The norm depends on a real parameter \<open>q > 1\<close>.
  The value of \<open>q\<close> does not matter in the sense that all values induce the same topology
  (which we will show). For the final definition, we then simply pick \<open>q = 2\<close>.
\<close>

locale fbnorm =
  fixes q :: "real"
  assumes q_gt_1: "q > 1"
begin

definition N :: "int \<Rightarrow> real" where
  "N n = (\<Sum>k. if k = 0 \<or> int k dvd n then 0 else 1 / q ^ k)"

lemma N_summable: "summable (\<lambda>k. if k = 0 \<or> int k dvd n then 0 else 1 / q ^ k)"
  by (rule summable_comparison_test[OF _ summable_geometric[of "1/q"]])
     (use q_gt_1 in \<open>auto intro!: exI[of _ 0] simp: power_divide\<close>)

lemma N_sums: "(\<lambda>k. if k = 0 \<or> int k dvd n then 0 else 1 / q ^ k) sums N n"
  using N_summable unfolding N_def by (rule summable_sums)

lemma N_nonneg: "N n \<ge> 0"
  by (rule sums_le[OF _ sums_zero N_sums]) (use q_gt_1 in auto)

lemma N_uminus [simp]: "N (-n) = N n"
  by (simp add: N_def)

lemma N_minus_commute: "N (x - y) = N (y - x)"
  using N_uminus[of "x - y"] by (simp del: N_uminus)

lemma N_zero [simp]: "N 0 = 0"
  by (simp add: N_def)

lemma not_dvd_imp_N_ge:
  assumes "\<not>n dvd a" "n > 0"
  shows   "N a \<ge> 1 / q ^ n"
  by (rule sums_le[OF _ sums_single[of n] N_sums]) (use q_gt_1 assms in auto)

lemma N_lt_imp_dvd:
  assumes "N a < 1 / q ^ n" and "n > 0"
  shows   "n dvd a"
  using not_dvd_imp_N_ge[of n a] assms by auto

lemma N_pos:
  assumes "n \<noteq> 0"
  shows   "N n > 0"
proof -
  have "0 < 1 / q ^ (nat \<bar>n\<bar>+1)"
    using q_gt_1 by simp
  also have "\<not>1 + \<bar>n\<bar> dvd \<bar>n\<bar>"
    using zdvd_imp_le[of "1 + \<bar>n\<bar>" "\<bar>n\<bar>"] assms by auto
  hence "1 / q ^ (nat \<bar>n\<bar>+1) \<le> N n"
    by (intro not_dvd_imp_N_ge) (use assms in auto)
  finally show ?thesis .
qed

lemma N_zero_iff [simp]: "N n = 0 \<longleftrightarrow> n = 0"
  using N_pos[of n] by (cases "n = 0") auto

lemma N_triangle_ineq: "N (n + m) \<le> N n + N m"
proof (rule sums_le)
  let ?I = "\<lambda>n k. if k = 0 \<or> int k dvd n then 0 else 1 / q ^ k"
  show "?I (n + m) sums N (n + m)"
    by (rule N_sums)
  show "(\<lambda>k. ?I n k + ?I m k) sums (N n + N m)"
    by (intro sums_add N_sums)
  show "\<forall>k. ?I (n + m) k \<le> ?I n k + ?I m k"
    using q_gt_1 by auto
qed

lemma N_1: "N 1 = 1 / (q * (q - 1))"
proof (rule sums_unique2)
  have "(\<lambda>k. if k = 0 \<or> int k dvd 1 then 0 else 1 / q ^ k) sums N 1"
    by (rule N_sums)
  also have "(\<lambda>k. if k = 0 \<or> int k dvd 1 then 0 else 1 / q ^ k) =
               (\<lambda>k. if k \<in> {0, 1} then 0 else (1 / q) ^ k)"
    by (simp add: power_divide cong: if_cong)
  finally show "(\<lambda>k. if k \<in> {0, 1} then 0 else (1 / q) ^ k) sums N 1" .

  have "(\<lambda>k. if k \<in> {0, 1} then 0 else (1 / q) ^ k) sums
                 (1 / (1 - 1 / q) + (- (1 / q) - 1))"
    by (rule sums_If_finite_set'[OF geometric_sums]) (use q_gt_1 in auto)
  also have "\<dots> = 1 / (q * (q - 1))"
    using q_gt_1 by (simp add: field_simps)
  finally show "(\<lambda>k. if k \<in> {0, 1} then 0 else (1 / q) ^ k) sums \<dots>" .
qed

text \<open>
  It follows directly from the definition that norms fulfil a kind of monotonicity property
  with respect to divisibility: the norm of a number is at most as large as the norm of any of
  its factors:
\<close>
lemma N_dvd_mono:
  assumes "m dvd n"
  shows   "N n \<le> N m"
proof (rule sums_le[OF allI N_sums N_sums])
  fix k :: nat
  show "(if k = 0 \<or> int k dvd n then 0 else 1 / q ^ k) \<le>
        (if k = 0 \<or> int k dvd m then 0 else 1 / q ^ k)"
    using q_gt_1 assms by auto
qed

text \<open>
  In particular, this means that 1 and -1 have the greatest norm.
\<close>
lemma N_le_N_1: "N n \<le> N 1"
  by (rule N_dvd_mono) auto

text \<open>
  Primes have relatively large norms, almost reaching the norm of 1:
\<close>
lemma N_prime:
  assumes "prime p"
  shows   "N p = N 1 - 1 / q ^ nat p"
proof (rule sums_unique2)
  define p' where "p' = nat p"
  have p: "p = int p'"
    using assms by (auto simp: p'_def prime_ge_0_int)
  have "prime p'"
    using assms by (simp add: p)

  have "(\<lambda>k. if k = 0 \<or> int k dvd p then 0 else 1 / q ^ k) sums N p"
    by (rule N_sums)
  also have "int k dvd p \<longleftrightarrow> k \<in> {1, p'}" for k
    using assms by (auto simp: p prime_nat_iff)
  hence "(\<lambda>k. if k = 0 \<or> int k dvd p then 0 else 1 / q ^ k) =
         (\<lambda>k. if k \<in> {0, 1, p'} then 0 else (1 / q) ^ k)"
    using assms q_gt_1 by (simp add: power_divide cong: if_cong)
  finally show "\<dots> sums N p" .

  have "(\<lambda>k. if k \<in> {0, 1, p'} then 0 else (1 / q) ^ k) sums
                 (1 / (1 - 1 / q) + (- (1 / q) - (1 / q) ^ p' - 1))"
    by (rule sums_If_finite_set'[OF geometric_sums])
       (use \<open>prime p'\<close> q_gt_1 prime_gt_Suc_0_nat[of p'] in \<open>auto simp: \<close>)
  also have "\<dots> = N 1 - 1 / q ^ p'"
    using q_gt_1 by (simp add: field_simps N_1)
  finally show "(\<lambda>k. if k \<in> {0, 1, p'} then 0 else (1 / q) ^ k) sums \<dots>" .
qed

lemma N_2: "N 2 = 1 / (q ^ 2 * (q - 1))"
  using q_gt_1 by (auto simp: N_prime N_1 field_simps power2_eq_square)

lemma N_less_N_1:
  assumes "n \<noteq> 1" "n \<noteq> -1"
  shows   "N n < N 1"
proof (cases "n = 0")
  case False
  then obtain p where p: "prime p" "p dvd n"
    using prime_divisor_exists[of n] assms by force
  hence "N n \<le> N p" by (intro N_dvd_mono)
  also from p have "N p < N 1"
    using q_gt_1 by (simp add: N_prime)
  finally show ?thesis .
qed (use q_gt_1 in \<open>auto simp: N_1\<close>)

text \<open>
  Composites, on the other hand, do not achieve this:
\<close>
lemma nonprime_imp_N_lt:
  assumes "\<not>prime_elem n" "\<bar>n\<bar> \<noteq> 1" "n \<noteq> 0"
  shows   "N n < N 1 - 1 / q ^ nat \<bar>n\<bar>"
proof -
  obtain p where p: "prime p" "p dvd n"
    using prime_divisor_exists[of n] assms by auto
  define p' where "p' = nat p"
  have p': "p = int p'"
    using p by (auto simp: p'_def prime_ge_0_int)
  have "prime p'"
    using p by (simp add: p')

  define n' where "n' = nat \<bar>n\<bar>"
  have "n' > 1"
    using assms by (auto simp: n'_def)

  have "N n \<le> 1 / (q * (q - 1)) - 1 / q ^ p' - 1 / q ^ n'"
  proof (rule sums_le)
    show "(\<lambda>k. if k = 0 \<or> int k dvd n then 0 else 1 / q ^ k) sums N n"
      by (rule N_sums)
  next
    from assms p have "n' \<noteq> p'"
      by (auto simp: n'_def p'_def nat_eq_iff)
    hence "(\<lambda>k. if k \<in> {0, 1, p', n'} then 0 else (1 / q) ^ k) sums
                   (1 / (1 - 1 / q) + (- (1 / q) - (1 / q) ^ p' - (1 / q) ^ n' - 1))"
      by (intro sums_If_finite_set'[OF geometric_sums])
         (use \<open>prime p'\<close> q_gt_1 prime_gt_Suc_0_nat[of p'] \<open>n' > 1\<close> in \<open>auto simp: \<close>)
    also have "\<dots> = 1 / (q * (q - 1)) - 1 / q ^ p' - 1 / q ^ n'"
      using q_gt_1 by (simp add: field_simps)
    finally show "(\<lambda>k. if k \<in> {0, 1, p', n'} then 0 else (1 / q) ^ k) sums \<dots>" .
  next
    show " \<forall>na. (if na = 0 \<or> int na dvd n then 0 else 1 / q ^ na)
         \<le> (if na \<in> {0, 1, p', n'} then 0 else (1 / q) ^ na)"
      using q_gt_1 assms p by (auto simp: p'_def n'_def power_divide)
  qed
  also have "\<dots> < 1 / (q * (q - 1)) - 1 / q ^ n'"
    using q_gt_1 by simp
  finally show ?thesis by (simp add: n'_def N_1)
qed

text \<open>
  This implies that one can use the norm as a primality test:
\<close>
lemma prime_iff_N_eq:
  assumes "n \<noteq> 0"
  shows   "prime_elem n \<longleftrightarrow> N n = N 1 - 1 / q ^ nat \<bar>n\<bar>"
proof -
  have *: "prime_elem n \<longleftrightarrow> N n = N 1 - 1 / q ^ nat \<bar>n\<bar>" if "n > 0" for n
  proof -
    consider "n = 1" | "prime n" | "\<not>prime n" "n > 1"
      using \<open>n > 0\<close> by force
    thus ?thesis
    proof cases
      assume "n = 1"
      thus ?thesis using q_gt_1
        by (auto simp: N_1)
    next
      assume n: "\<not>prime n" "n > 1"
      with nonprime_imp_N_lt[of n] show ?thesis by simp
    qed (auto simp: N_prime prime_ge_0_int)
  qed

  show ?thesis
  proof (cases "n > 0")
    case True
    with * show ?thesis by blast
  next
    case False
    with *[of "-n"] assms show ?thesis by simp
  qed
qed

text \<open>
  Factorials, on the other hand, have very small norms:
\<close>
lemma N_fact_le: "N (fact m) \<le> 1 / (q - 1) * 1 / q ^ m"
proof (rule sums_le[OF allI N_sums])
  have "(\<lambda>k. 1 / q ^ k / q ^ Suc m) sums (q / (q - 1) / q ^ Suc m)"
    using geometric_sums[of "1 / q"] q_gt_1
    by (intro sums_divide) (auto simp: field_simps)
  also have "(q / (q - 1) / q ^ Suc m) = 1 / (q - 1) * 1 / q ^ m"
    using q_gt_1 by (simp add: field_simps)
  also have "(\<lambda>k. 1 / q ^ k / q ^ Suc m) = (\<lambda>k. 1 / q ^ (k + Suc m))"
    using q_gt_1 by (simp add: field_simps power_add)
  also have "\<dots> = (\<lambda>k. if k + Suc m \<le> m then 0 else 1 / q ^ (k + Suc m))"
    by auto
  finally have "\<dots> sums (1 / (q - 1) * 1 / q ^ m)" .
  also have "?this \<longleftrightarrow> (\<lambda>k. if k \<le> m then 0 else 1 / q ^ k) sums (1 / (q - 1) * 1 / q ^ m)"
    by (rule sums_zero_iff_shift) auto
  finally show \<dots> .
next
  fix k :: nat
  have "int k dvd fact m" if "k > 0" "k \<le> m"
  proof -
    have "int k dvd int (fact m)"
      unfolding int_dvd_int_iff using that by (simp add: dvd_fact)
    thus "int k dvd fact m"
      unfolding of_nat_fact by simp
  qed
  thus "(if k = 0 \<or> int k dvd fact m then 0 else 1 / q ^ k) \<le>
        (if k \<le> m then 0 else 1 / q ^ k)" using q_gt_1 by auto
qed

lemma N_prime_mono:
  assumes "prime p" "prime p'" "p \<le> p'"
  shows   "N p \<le> N p'"
  using assms q_gt_1 by (auto simp add: N_prime field_simps nat_le_iff prime_ge_0_int)

lemma N_prime_ge:
  assumes "prime p"
  shows   "N p \<ge> 1 / (q\<^sup>2 * (q - 1))"
proof -
  have "1 / (q ^ 2 * (q - 1)) = N 2"
    using q_gt_1 by (auto simp: N_prime N_1 field_simps power2_eq_square)
  also have "\<dots> \<le> N p"
    using assms by (intro N_prime_mono) (auto simp: prime_ge_2_int)
  finally show ?thesis .
qed

lemma N_prime_elem_ge:
  assumes "prime_elem p"
  shows   "N p \<ge> 1 / (q\<^sup>2 * (q - 1))"
proof (cases "p \<ge> 0")
  case True
  with assms N_prime_ge show ?thesis by auto
next
  case False
  with assms N_prime_ge[of "-p"] show ?thesis by auto
qed

text \<open>
  Next, we use this norm to derive a metric:
\<close>

lift_definition dist :: "fbint \<Rightarrow> fbint \<Rightarrow> real" is
  "\<lambda>x y. N (x - y)" .

lemma dist_self [simp]: "dist x x = 0"
  by transfer simp

lemma dist_sym [simp]: "dist x y = dist y x"
  by transfer (simp add: N_minus_commute)

lemma dist_pos: "x \<noteq> y \<Longrightarrow> dist x y > 0"
  by transfer (use N_pos in simp)

lemma dist_eq_0_iff [simp]: "dist x y = 0 \<longleftrightarrow> x = y"
  using dist_pos[of x y] by (cases "x = y") auto

lemma dist_triangle_ineq: "dist x z \<le> dist x y + dist y z"
proof transfer
  fix x y z :: int
  show "N (x - z) \<le> N (x - y) + N (y - z)"
    using N_triangle_ineq[of "x - y" "y - z"] by simp
qed

text \<open>
  Lastly, we show that the metric we defined indeed induces the Furstenberg topology.
\<close>
theorem dist_induces_open:
  "open U \<longleftrightarrow> (\<forall>x\<in>U. \<exists>e>0. \<forall>y. dist x y < e \<longrightarrow> y \<in> U)"
proof (transfer, safe)
  fix U :: "int set" and x :: int
  assume *: "\<forall>x\<in>U. \<exists>b>0. arith_prog x b \<subseteq> U"
  assume "x \<in> U"
  with * obtain b where b: "b > 0" "arith_prog x b \<subseteq> U" by blast
  define e where "e = 1 / q ^ b"

  show "\<exists>e>0. \<forall>y. N (x - y) < e \<longrightarrow> y \<in> U"
  proof (rule exI; safe?)
    show "e > 0" using q_gt_1 by (simp add: e_def)
  next
    fix y assume "N (x - y) < e"
    also have "\<dots> = 1 / q ^ b" by fact
    finally have "b dvd (x - y)"
      by (rule N_lt_imp_dvd) fact
    hence "y \<in> arith_prog x b"
      by (auto simp: arith_prog_def cong_iff_dvd_diff dvd_diff_commute)
    with b show "y \<in> U" by blast
  qed

next

  fix U :: "int set" and x :: int
  assume *: "\<forall>x\<in>U. \<exists>e>0. \<forall>y. N (x - y) < e \<longrightarrow> y \<in> U"
  assume "x \<in> U"
  with * obtain e where e: "e > 0" "\<forall>y. N (x - y) < e \<longrightarrow> y \<in> U" by blast
  have "eventually (\<lambda>N. 1 / (q - 1) * 1 / q ^ N < e) at_top"
    using q_gt_1 \<open>e > 0\<close> by real_asymp
  then obtain m where m: "1 / (q - 1) * 1 / q ^ m < e"
    by (auto simp: eventually_at_top_linorder)
  define b :: nat where "b = fact m"

  have "arith_prog x b \<subseteq> U"
  proof
    fix y assume "y \<in> arith_prog x b"
    show "y \<in> U"
    proof (cases "y = x")
      case False
      from \<open>y \<in> arith_prog x b\<close> obtain n where y: "y = x + int b * n"
        by (auto simp: arith_prog_altdef)
      from y and \<open>y \<noteq> x\<close> have [simp]: "n \<noteq> 0" by auto
      have "N (x - y) = N (int b * n)" by (simp add: y)
      also have "\<dots> \<le> N (int b)"
        by (rule N_dvd_mono) auto
      also have "\<dots> \<le> 1 / (q - 1) * 1 / q ^ m"
        using N_fact_le by (simp add: b_def)
      also have "\<dots> < e" by fact
      finally show "y \<in> U" using e by auto
    qed (use \<open>x \<in> U\<close> in auto)
  qed
  moreover have "b > 0" by (auto simp: b_def)
  ultimately show "\<exists>b>0. arith_prog x b \<subseteq> U"
    by blast
qed

end

text \<open>
  We now show that the Furstenberg space is a metric space with this metric (with \<open>q = 2\<close>),
  which essentially only amounts to plugging together all the results from above.
\<close>

interpretation fb: fbnorm 2
  by standard auto

instantiation fbint :: dist
begin

definition dist_fbint where "dist_fbint = fb.dist"

instance ..

end

instantiation fbint :: uniformity_dist
begin

definition uniformity_fbint :: "(fbint \<times> fbint) filter" where
  "uniformity_fbint = (INF e\<in>{0 <..}. principal {(x, y). dist x y < e})"

instance by standard (simp add: uniformity_fbint_def)

end

instance fbint :: open_uniformity
proof
  fix U :: "fbint set"
  show "open U = (\<forall>x\<in>U. eventually (\<lambda>(x',y). x' = x \<longrightarrow> y \<in> U) uniformity)"
    unfolding eventually_uniformity_metric dist_fbint_def
    using fb.dist_induces_open by simp
qed

instance fbint :: metric_space
  by standard (use fb.dist_triangle_ineq in \<open>auto simp: dist_fbint_def\<close>)

text \<open>
  In particular, we can now show that the sequence \<open>n!\<close> tends to 0 in the Furstenberg topology:
\<close>
lemma tendsto_fbint_fact: "(\<lambda>n. fbint (fact n)) \<longlonglongrightarrow> fbint 0"
proof -
  have "(\<lambda>n. dist (fbint (fact n)) (fbint 0)) \<longlonglongrightarrow> 0"
  proof (rule tendsto_sandwich[OF always_eventually always_eventually]; safe?)
    fix n :: nat
    show "dist (fbint (fact n)) (fbint 0) \<le> 1 / 2 ^ n"
      unfolding dist_fbint_def by (transfer fixing: n) (use fb.N_fact_le[of n] in simp)
    show "dist (fbint (fact n)) (fbint 0) \<ge> 0"
      by simp
    show "(\<lambda>n. 1 / 2 ^ n :: real) \<longlonglongrightarrow> 0"
      by real_asymp
  qed simp_all
  thus ?thesis
    using tendsto_dist_iff by metis
qed

end


section \<open>Introduction and Definition\<close>

theory Definitions
  imports "HOL-Probability.Independent_Family"
begin

text \<open>Universal hash families are commonly used in randomized algorithms and data structures to
randomize the input of algorithms, such that probabilistic methods can be employed without requiring
any assumptions about the input distribution.

If we regard a family of hash functions from a domain $D$ to a finite range $R$ as a uniform probability
space, then the family is $k$-universal if:
\begin{itemize}
\item For each $x \in D$ the evaluation of the functions at $x$ forms a uniformly distributed random variable on $R$.
\item The evaluation random variables for $k$ or fewer distinct domain elements form an
independent family of random variables.
\end{itemize}

This definition closely follows the definition from Vadhan~\<^cite>\<open>\<open>\textsection 3.5.5\<close> in "vadhan2012"\<close>, with the minor
modification that independence is required not only for exactly $k$, but also for \emph{fewer} than $k$ distinct
domain elements. The correction is due to the fact that in the corner case where $D$ has fewer than $k$ elements,
the second part of their definition becomes void. In the formalization this helps avoid an unnecessary assumption in
the theorems.

The following definition introduces the notion of $k$-wise independent random variables:\<close>

definition (in prob_space) k_wise_indep_vars where
  "k_wise_indep_vars k M' X I =
    (\<forall>J \<subseteq> I. card J \<le> k \<longrightarrow> finite J \<longrightarrow> indep_vars M' X J)"

lemma (in prob_space) k_wise_indep_vars_subset:
  assumes "k_wise_indep_vars k M' X I"
  assumes "J \<subseteq> I"
  assumes "finite J"
  assumes "card J \<le> k"
  shows "indep_vars M' X J"
  using assms
  by (simp add:k_wise_indep_vars_def)

text \<open>Similarly for a finite non-empty set $A$ the predicate @{term "uniform_on X A"} indicates that
the random variable is uniformly distributed on $A$:\<close>

definition (in prob_space) "uniform_on X A = (
  distr M (count_space UNIV) X = uniform_measure (count_space UNIV) A \<and>
  A \<noteq> {} \<and> finite A \<and> random_variable (count_space UNIV) X)"

lemma (in prob_space) uniform_onD:
  assumes "uniform_on X A"
  shows "prob {\<omega> \<in> space M. X \<omega> \<in> B} = card (A \<inter> B) / card A"
proof -
  have "prob {\<omega> \<in> space M. X \<omega> \<in> B} = prob (X -` B \<inter> space M)"
    by (subst Int_commute, simp add:vimage_def Int_def)
  also have "... = measure (distr M (count_space UNIV) X) B"
    using assms by (subst measure_distr, auto simp:uniform_on_def)
  also have "... = measure (uniform_measure (count_space UNIV) A) B"
    using assms by (simp add:uniform_on_def)
  also have "... = card (A \<inter> B) / card A"
    using assms by (subst measure_uniform_measure, auto simp:uniform_on_def)+
  finally show ?thesis by simp
qed

text \<open>With the two previous definitions it is possible to define the $k$-universality condition for a family
of hash functions from $D$ to $R$:\<close>

definition (in prob_space) "k_universal k X D R = (
  k_wise_indep_vars k (\<lambda>_. count_space UNIV) X D \<and>
  (\<forall>i \<in> D. uniform_on (X i) R))"

text \<open>Note: The definition is slightly more generic then the informal specification from above.
This is because usually a family is formed by a single function with a variable seed parameter. Instead of
choosing a random function from a probability space, a random seed is chosen from the probability space
which parameterizes the hash function.

The following section contains some preliminary results about independent families
of random variables.
Section~\ref{sec:carter_wegman} introduces the Carter-Wegman hash family, which is an
explicit construction of $k$-universal families for arbitrary $k$ using polynomials over finite fields.
The last section contains a proof that the factor ring of the integers modulo a prime ideal is a finite field,
followed by an isomorphic construction of prime fields over an initial segment of the natural numbers.\<close>

end


section \<open>Well-foundedness of Relations Defined as Predicate Functions\<close>

theory Well_founded
  imports Main
begin

locale well_founded =
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 70)
  assumes
    wf: "wfP (\<sqsubset>)"
begin

lemmas induct = wfP_induct_rule[OF wf]

end

subsection \<open>Lexicographic product\<close>

context
  fixes
    r1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and
    r2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
begin

definition lex_prodp :: "'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" where
  "lex_prodp x y \<equiv> r1 (fst x) (fst y) \<or> fst x = fst y \<and> r2 (snd x) (snd y)"

lemma lex_prodp_lex_prod:
  shows "lex_prodp x y \<longleftrightarrow> (x, y) \<in> lex_prod { (x, y). r1 x y } { (x, y). r2 x y }"
  by (auto simp: lex_prod_def lex_prodp_def)

lemma lex_prodp_wfP:
  assumes
    "wfP r1" and
    "wfP r2"
  shows "wfP lex_prodp"
proof (rule wfPUNIVI)
  show "\<And>P. \<forall>x. (\<forall>y. lex_prodp y x \<longrightarrow> P y) \<longrightarrow> P x \<Longrightarrow> (\<And>x. P x)"
  proof -
    fix P
    assume "\<forall>x. (\<forall>y. lex_prodp y x \<longrightarrow> P y) \<longrightarrow> P x"
    hence hyps: "(\<And>y1 y2. lex_prodp (y1, y2) (x1, x2) \<Longrightarrow> P (y1, y2)) \<Longrightarrow> P (x1, x2)" for x1 x2
      by fast
    show "(\<And>x. P x)"
      apply (simp only: split_paired_all)
      apply (atomize (full))
      apply (rule allI)
      apply (rule wfP_induct_rule[OF assms(1), of "\<lambda>y. \<forall>b. P (y, b)"])
      apply (rule allI)
      apply (rule wfP_induct_rule[OF assms(2), of "\<lambda>b. P (x, b)" for x])
      using hyps[unfolded lex_prodp_def, simplified]
      by blast
  qed
qed

end

lemma lex_prodp_well_founded:
  assumes
    "well_founded r1" and
    "well_founded r2"
  shows "well_founded (lex_prodp r1 r2)"
  using well_founded.intro lex_prodp_wfP assms[THEN well_founded.wf] by auto

subsection \<open>Lexicographic list\<close>

context
  fixes order :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

inductive lexp :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
  lexp_head: "order x y \<Longrightarrow> length xs = length ys \<Longrightarrow> lexp (x # xs) (y # ys)" |
  lexp_tail: "lexp xs ys \<Longrightarrow> lexp (x # xs) (x # ys)"

end

lemma lexp_prepend: "lexp order ys zs \<Longrightarrow> lexp order (xs @ ys) (xs @ zs)"
  by (induction xs) (simp_all add: lexp_tail)

lemma lexp_lex: "lexp order xs ys \<longleftrightarrow> (xs, ys) \<in> lex {(x, y). order x y}"
proof
  assume "lexp order xs ys"
  thus "(xs, ys) \<in> lex {(x, y). order x y}"
    by (induction xs ys rule: lexp.induct) simp_all
next
  assume "(xs, ys) \<in> lex {(x, y). order x y}"
  thus "lexp order xs ys"
    by (auto intro!: lexp_prepend intro: lexp_head simp: lex_conv)
qed

lemma lex_list_wfP: "wfP order \<Longrightarrow> wfP (lexp order)"
  by (simp add: lexp_lex wf_lex wfP_def)

lemma lex_list_well_founded:
  assumes "well_founded order"
  shows "well_founded (lexp order)"
  using well_founded.intro assms(1)[THEN well_founded.wf, THEN lex_list_wfP] by auto

end


(* 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_sort_nat_ISortSorts
imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

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

fun ordered :: "Nat list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((le y y2) & (ordered (cons2 y2 xs)))"

fun insert :: "Nat => Nat list => Nat list" where
"insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if le x z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "Nat list => Nat list" where
"isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

theorem property0 :
  "ordered (isort xs)"
  oops

end


theory BDD
  imports Main
begin

datatype bdd = Leaf bool | Branch bdd bdd

primrec eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool" where
"eval e i (Leaf v) = v" |
"eval e i (Branch b1 b2) =
  (if e i then eval e (Suc i) b2 else eval e (Suc i) b2)"

primrec bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_unop f (Leaf v) = Leaf (f v)" |
"bdd_unop f (Branch b1 b2) = Branch (bdd_unop f b1) (bdd_unop f b2)"

primrec bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_binop f (Leaf v) b = bdd_unop (f v) b" |
"bdd_binop f (Branch b1 b2) b = (case b of
    Leaf v \<Rightarrow> Branch (bdd_binop f b1 (Leaf v)) (bdd_binop f b2 (Leaf v))
  | Branch b1' b2' \<Rightarrow> Branch (bdd_binop f b1 b1') (bdd_binop f b2 b2'))"

theorem bdd_unop_correct: "\<forall>i. eval e i (bdd_unop f b) = f (eval e i b)"
  apply (induction b)
   apply (auto)
  done

theorem bdd_binop_correct: "\<forall>i b2. eval e i (bdd_binop f b1 b2) = f (eval e i b1) (eval e i b2)"
  apply (induction b1)
   apply (auto split: bdd.split)
   apply (auto simp add: bdd_unop_correct)
  done

end


(* 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_sort_MSortBU2IsSort
  imports "../../Test_Base"
begin

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

fun risers :: "int list => (int list) list" where
  "risers (nil2) = nil2"
| "risers (cons2 y (nil2)) = cons2 (cons2 y (nil2)) (nil2)"
| "risers (cons2 y (cons2 y2 xs)) =
     (if y <= y2 then
        (case risers (cons2 y2 xs) of
           nil2 => nil2
           | cons2 ys yss => cons2 (cons2 y ys) yss)
        else
        cons2 (cons2 y (nil2)) (risers (cons2 y2 xs)))"

fun lmerge :: "int list => int list => int list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if z <= x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun pairwise :: "(int list) list => (int list) list" where
  "pairwise (nil2) = nil2"
| "pairwise (cons2 xs (nil2)) = cons2 xs (nil2)"
| "pairwise (cons2 xs (cons2 ys xss)) =
     cons2 (lmerge xs ys) (pairwise xss)"

(*fun did not finish the proof*)
function mergingbu2 :: "(int list) list => int list" where
  "mergingbu2 (nil2) = nil2"
| "mergingbu2 (cons2 xs (nil2)) = xs"
| "mergingbu2 (cons2 xs (cons2 z x2)) =
     mergingbu2 (pairwise (cons2 xs (cons2 z x2)))"
  by pat_completeness auto

fun msortbu2 :: "int list => int list" where
  "msortbu2 x = mergingbu2 (risers x)"

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

theorem property0 :
  "((msortbu2 xs) = (isort xs))"
  oops

end


(*
  Title: Lucas_Theorem.thy
  Author: Chelsea Edmonds, University of Cambridge
*)

theory Lucas_Theorem
  imports Main "HOL-Computational_Algebra.Computational_Algebra"
begin

notation fps_nth (infixl "$" 75)

section \<open>Extensions on Formal Power Series (FPS) Library\<close>

text \<open>This section presents a few extensions on the Formal Power Series (FPS) library, described in \<^cite>\<open>"Chaieb2011"\<close> \<close>

subsection \<open>FPS Equivalence Relation \<close>

text \<open> This proof requires reasoning around the equivalence of coefficients mod some prime number.
This section defines an equivalence relation on FPS using the pattern described by Paulson
in \<^cite>\<open>"paulsonDefiningFunctionsEquivalence2006"\<close>, as well as some basic lemmas for reasoning around
how the equivalence holds after common operations are applied \<close>

definition "fpsmodrel p \<equiv> { (f, g). \<forall> n. (f $ n) mod p = (g $ n) mod p }"

lemma fpsrel_iff [simp]: "(f, g) \<in> fpsmodrel p \<longleftrightarrow> (\<forall>n. (f $ n) mod p = (g $ n) mod p)"
  by (simp add: fpsmodrel_def)

lemma fps_equiv: "equiv UNIV (fpsmodrel p)"
proof (rule equivI)
  show "refl (fpsmodrel p)" by (simp add: refl_on_def fpsmodrel_def)
  show "sym (fpsmodrel p)" by (simp add: sym_def fpsmodrel_def)
  show "trans (fpsmodrel p)" by (intro transI) (simp add: fpsmodrel_def)
qed

text \<open> Equivalence relation over multiplication \<close>

lemma fps_mult_equiv_coeff:
  fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
  assumes "(f, g) \<in> fpsmodrel p"
  shows "(f*h)$n mod p = (g*h)$n mod p"
proof -
  have "((f*h) $ n) mod p =(\<Sum>i=0..n. (f$i mod p * h$(n - i) mod p) mod p) mod p"
    using mod_sum_eq mod_mult_left_eq
    by (simp add: fps_mult_nth mod_sum_eq mod_mult_left_eq)
  also have "... = (\<Sum>i=0..n. (g$i mod p * h$(n - i) mod p) mod p) mod p"
    using assms by auto
  also have "... = ((g*h) $ n) mod p"
    by (simp add: mod_mult_left_eq mod_sum_eq fps_mult_nth)
  thus ?thesis by (simp add: calculation)
qed

lemma fps_mult_equiv:
  fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
  assumes "(f, g) \<in> fpsmodrel p"
  shows "(f*h, g*h) \<in> fpsmodrel p"
  using fpsmodrel_def fps_mult_equiv_coeff assms by blast

text \<open> Equivalence relation over power operator \<close>
lemma fps_power_equiv:
  fixes f g :: "('a :: {euclidean_ring_cancel}) fps"
  fixes x :: nat
  assumes "(f, g) \<in> fpsmodrel p"
  shows "(f^x, g^x) \<in> fpsmodrel p"
  using assms
proof (induct x)
  case 0
  thus ?case by (simp add: fpsmodrel_def)
next
  case (Suc x)
  then have hyp: " \<forall>n. f^x $ n mod p = g ^x $ n mod p"
    using fpsrel_iff by blast
  thus ?case
  proof -
    have fact: "\<forall>n h. (g * h) $ n mod p = (f * h) $ n mod p"
      by (metis assms fps_mult_equiv_coeff)
    have "\<forall>n h. (g ^ x * h) $ n mod p = (f ^ x * h) $ n mod p"
      by (simp add: fps_mult_equiv_coeff hyp)
    then have "\<forall>n h. (h * g ^ x) $ n mod p = (h * f ^ x) $ n mod p"
      by (simp add: mult.commute)
    thus ?thesis
      using fact by force
  qed
qed

subsection \<open>Binomial Coefficients \<close>

text \<open>The @{term "fps_binomial"} definition in the formal power series uses the @{term "n gchoose k"} operator. It's
defined as being of type @{typ "'a :: field_char_0 fps"}, however the equivalence relation requires a type @{typ 'a}
that supports the modulo operator.
The proof of the binomial theorem based on FPS coefficients below uses the choose operator and does
not put bounds on the type of @{term "fps_X"}.\<close>

lemma binomial_coeffs_induct:
  fixes n k :: nat
  shows "(1 + fps_X)^n $ k = of_nat(n choose k)"
proof (induct n arbitrary: k)
  case 0
  thus ?case
    by (metis binomial_eq_0_iff binomial_n_0 fps_nth_of_nat not_gr_zero of_nat_0 of_nat_1 power_0)
next
  case h: (Suc n)
  fix k
  have start: "(1 + fps_X)^(n + 1) = (1 + fps_X) * (1 + fps_X)^n" by auto
  show ?case
    using One_nat_def Suc_eq_plus1 Suc_pred add.commute binomial_Suc_Suc binomial_n_0
        fps_mult_fps_X_plus_1_nth h.hyps neq0_conv start by (smt of_nat_add)
qed

subsection \<open>Freshman's Dream Lemma on FPS \<close>
text \<open> The Freshman's dream lemma modulo a prime number $p$ is a well known proof that $(1 + x^p) \equiv (1 + x)^p \mod p$\<close>

text \<open> First prove that $\binom{p^n}{k} \equiv 0 \mod p$ for $k \ge 1$ and $k < p^n$. The eventual
proof only ended up requiring this with $n = 1$\<close>

lemma pn_choose_k_modp_0:
  fixes n k::nat
  assumes "prime p"
          "k \<ge> 1 \<and> k \<le> p^n - 1"
          "n > 0"
  shows "(p^n choose k) mod p = 0"
proof -
  have inequality: "k \<le> p^n" using assms (2) by arith
  have choose_take_1: "((p^n - 1) choose ( k - 1))= fact (p^n - 1) div (fact (k - 1) * fact (p^n - k))"
    using binomial_altdef_nat diff_le_mono inequality assms(2) by auto
  have "k * (p^n choose k) = k * ((fact (p^n)) div (fact k * fact((p^n) - k)))"
    using assms binomial_fact'[OF inequality] by auto
  also have "... = k * fact (p^n) div (fact k * fact((p^n) - k))"
    using binomial_fact_lemma div_mult_self_is_m fact_gt_zero inequality mult.assoc mult.commute
          nat_0_less_mult_iff by smt
  also have "... = k * fact (p^n) div (k * fact (k - 1) * fact((p^n) - k))"
    by (metis assms(2) fact_nonzero fact_num_eq_if le0 le_antisym of_nat_id)
  also have "... = fact (p^n) div (fact (k - 1) * fact((p^n) - k))"
    using assms by auto
  also have "... = ((p^n) * fact (p^n - 1)) div (fact (k - 1) * fact((p^n) - k))"
    by (metis assms(2) fact_nonzero fact_num_eq_if inequality le0 le_antisym of_nat_id)
  also have "... = (p^n) * (fact (p^n - 1) div (fact (k - 1) * fact((p^n) - k)))"
    by (metis assms(2) calculation choose_take_1 neq0_conv not_one_le_zero times_binomial_minus1_eq)
  finally have equality: "k * (p^n choose k) = p^n * ((p^n - 1) choose (k - 1))"
    using assms(2) times_binomial_minus1_eq by auto
  then have dvd_result: "p^n dvd (k * (p^n choose k))" by simp
  have "\<not> (p^n dvd k)"
    using assms (2) binomial_n_0 diff_diff_cancel nat_dvd_not_less neq0_conv by auto
  then have "p dvd (p^n choose k)"
    using mult.commute prime_imp_prime_elem prime_power_dvd_multD assms dvd_result by metis
  thus "?thesis" by simp
qed

text \<open> Applying the above lemma to the coefficients of $(1 + X)^p$, it is easy to show that all
coefficients other than the $0$th and $p$th will be $0$ \<close>

lemma fps_middle_coeffs:
  assumes "prime p"
          "n \<noteq> 0 \<and> n \<noteq> p"
  shows "((1 + fps_X :: int fps) ^p) $ n mod p = 0 mod p"
proof -
  let ?f = "(1 + fps_X :: int fps)^p"
  have "\<forall> n. n > 0 \<and> n < p \<longrightarrow> (p choose n) mod p = 0" using pn_choose_k_modp_0
    by (metis (no_types, lifting) add_le_imp_le_diff assms(1) diff_diff_cancel diff_is_0_eq'
        discrete le_add_diff_inverse le_numeral_extra(4) power_one_right zero_le_one zero_less_one)
  then have middle_0: "\<forall> n. n > 0 \<and> n < p \<longrightarrow> (?f $ n) mod p = 0"
    using binomial_coeffs_induct by (metis of_nat_0 zmod_int)
  have "\<forall> n. n > p \<longrightarrow> ?f $ n mod p = 0"
    using binomial_eq_0_iff binomial_coeffs_induct mod_0 by (metis of_nat_eq_0_iff)
  thus ?thesis using middle_0 assms(2) nat_neq_iff by auto
qed

text \<open>It follows that $(1+ X)^p$ is equivalent to $(1 + X^p)$ under our equivalence relation,
as required to prove the freshmans dream lemma. \<close>

lemma fps_freshmans_dream:
  assumes "prime p"
  shows "(((1 + fps_X :: int fps ) ^p), (1 + (fps_X)^(p))) \<in> fpsmodrel p"
proof -
  let ?f = "(1 + fps_X :: int fps)^p"
  let ?g = "(1 + (fps_X :: int fps)^p)"
  have all_f_coeffs: "\<forall> n. n \<noteq> 0 \<and> n \<noteq> p \<longrightarrow> ?f $ n mod p = 0 mod p"
    using fps_middle_coeffs assms by blast
  have "?g $ 0 = 1" using assms by auto
  then have "?g $ 0 mod p = 1 mod p"
    using int_ops(2) zmod_int assms by presburger
  then have "?g $ p mod p = 1 mod p" using assms by auto
  then have "\<forall> n . ?f $ n mod p = ?g $ n mod p"
    using all_f_coeffs by (simp add: binomial_coeffs_induct)
  thus ?thesis using fpsrel_iff by blast
qed

section \<open>Lucas's Theorem Proof\<close>

text \<open>A formalisation of Lucas's theorem based on a generating function proof using the existing formal power series (FPS) Isabelle library\<close>

subsection \<open>Reasoning about Coefficients Helpers\<close>

text \<open>A generating function proof of Lucas's theorem relies on direct comparison between coefficients of FPS which requires a number
of helper lemmas to prove formally. In particular it compares the coefficients of
$(1 + X)^n \mod p$ to $(1 + X^p)^N * (1 + X) ^rn \mod p$, where $N = n / p$, and $rn = n \mod p$.
This section proves that the $k$th coefficient of $(1 + X^p)^N * (1 + X) ^rn = (N choose K) * (rn choose rk)$\<close>

text \<open>Applying the @{term "fps_compose"} operator enables reasoning about the coefficients of $(1 + X^p)^n$
using the existing binomial theorem proof with $X^p$ instead of $X$.\<close>

lemma fps_binomial_p_compose:
  assumes "p \<noteq> 0"
  shows "(1 + (fps_X:: ('a :: {idom} fps))^p)^n = ((1 + fps_X)^n) oo (fps_X^p)"
proof -
  have "(1::'a fps) + fps_X ^ p = 1 + fps_X oo fps_X ^ p"
    by (simp add: assms fps_compose_add_distrib)
  then show ?thesis
    by (simp add: assms fps_compose_power)
qed

text \<open> Next the proof determines the value of the $k$th coefficient of $(1 + X^p)^N$. \<close>

lemma fps_X_pow_binomial_coeffs:
  assumes "prime p"
  shows "(1 + (fps_X ::int fps)^p)^N $k = (if p dvd k then (N choose (k div p)) else 0)"
proof -
  let ?fx = "(fps_X :: int fps)"
  have "(1 + ?fx^p)^N $ k  = (((1 + ?fx)^N) oo (?fx^p)) $k"
    by (metis assms fps_binomial_p_compose not_prime_0)
  also have "... = (\<Sum>i=0..k.((1 + ?fx)^N)$i * ((?fx^p)^i$k))"
    by (simp add: fps_compose_nth)
  finally have coeffs: "(1 + ?fx^p)^N $ k = (\<Sum>i=0..k. (N choose i) * ((?fx^(p*i))$k))"
    using binomial_coeffs_induct sum.cong by (metis (no_types, lifting) power_mult)
  thus ?thesis
  proof (cases "p dvd k")
    case False \<comment> \<open>$p$ does not divide $k$ implies the $k$th term has a coefficient of 0\<close>
    have "\<forall> i. \<not>(p dvd k) \<longrightarrow> (?fx^(p*i)) $ k = 0"
      by auto
    thus ?thesis using coeffs by (simp add: False)
  next
    case True \<comment> \<open>$p$ divides $k$ implies the $k$th term has a non-zero coefficient\<close>
    have contained: "k div p \<in> {0.. k}" by simp
    have "\<forall> i. i \<noteq> k div p \<longrightarrow> (?fx^(p*i)) $ k = 0" using assms by auto
    then have notdivpis0: "\<forall> i \<in> ({0 .. k} - {k div p}). (?fx^(p*i)) $ k = 0" by simp
    have "(1 + ?fx^p)^N $ k = (N choose (k div p)) * (?fx^(p * (k div p))) $ k + (\<Sum>i\<in>({0..k} -{k div p}). (N choose i) * ((?fx^(p*i))$k))"
      using contained coeffs sum.remove by (metis (no_types, lifting) finite_atLeastAtMost)
    thus ?thesis using notdivpis0 True by simp
  qed
qed

text \<open> The final helper lemma proves the $k$th coefficient is equivalent to $\binom{?N}{?K}*\binom{?rn}{?rk}$ as required.\<close>
lemma fps_div_rep_coeffs:
  assumes "prime p"
  shows "((1 + (fps_X::int fps)^p)^(n div p) * (1 + fps_X)^(n mod p)) $ k =
          ((n div p) choose (k div p)) * ((n mod p) choose (k mod p))"
    (is "((1 + (fps_X::int fps)^p)^?N * (1 + fps_X)^?rn) $ k = (?N choose ?K) * (?rn choose ?rk)")
proof -
  \<comment> \<open>Initial facts with results around representation and 0 valued terms\<close>
  let ?fx = "fps_X :: int fps"
  have krep: "k - ?rk = ?K*p"
    by (simp add: minus_mod_eq_mult_div)
  have rk_in_range: "?rk \<in> {0..k}" by simp
  have "\<forall> i \<ge> p. (?rn choose i) = 0"
    using binomial_eq_0_iff
    by (metis assms(1) leD le_less_trans linorder_cases mod_le_divisor mod_less_divisor prime_gt_0_nat)
  then have ptok0: "\<forall> i \<in> {p..k}. ((?rn choose i) * (1 + ?fx^p)^?N $ (k - i)) = 0"
    by simp
  then have notrkis0: "\<forall>i \<in> {0.. k}. i \<noteq> ?rk \<longrightarrow> (?rn choose i) * (1 + ?fx^p)^?N $ (k - i) = 0"
  proof (cases "k < p")
    case True \<comment> \<open>When $k < p$, it presents a side case with regards to range of reasoning\<close>
    then have k_value: "k = ?rk" by simp
    then have "\<forall> i < k. \<not> (p dvd (k - i))"
       using True by (metis diff_diff_cancel diff_is_0_eq dvd_imp_mod_0 less_imp_diff_less less_irrefl_nat mod_less)
    then show ?thesis using fps_X_pow_binomial_coeffs assms(1) k_value by simp
  next
    case False
    then have "\<forall> i < p. i \<noteq> ?rk \<longrightarrow> \<not>(p dvd (k - i))"
      using mod_nat_eqI by auto
    then have "\<forall> i \<in> {0..<p}. i \<noteq> ?rk \<longrightarrow> (1 + ?fx^p)^?N $ (k - i) = 0"
      using assms fps_X_pow_binomial_coeffs by simp
    then show ?thesis using ptok0 by auto
  qed
  \<comment> \<open>Main body of the proof, using helper facts above\<close>
  have "((1 + fps_X^p)^?N * (1 + fps_X)^?rn) $ k = (((1 + fps_X)^?rn) * (1 + fps_X^p)^?N) $ k"
    by (metis (no_types, opaque_lifting) distrib_left distrib_right fps_mult_fps_X_commute fps_one_mult(1)
        fps_one_mult(2) power_commuting_commutes)
  also have "... = (\<Sum>i=0..k.(of_nat(?rn choose i)) * ((1 + (fps_X)^p)^?N $ (k - i)))"
    by (simp add: fps_mult_nth binomial_coeffs_induct)
  also have "... =  ((?rn choose ?rk) * (1 + ?fx^p)^?N $ (k - ?rk)) + (\<Sum>i\<in>({0..k} - {?rk}). (?rn choose i) * (1 + ?fx^p)^?N $ (k - i))"
    using rk_in_range sum.remove by (metis (no_types, lifting) finite_atLeastAtMost)
  finally have "((1 + ?fx^p)^?N * (1 + ?fx)^?rn) $ k = ((?rn choose ?rk) * (1 + ?fx^p)^?N $ (k - ?rk))"
    using notrkis0 by simp
  thus ?thesis using fps_X_pow_binomial_coeffs assms krep by auto
qed

(* Lucas theorem proof *)
subsection \<open>Lucas Theorem Proof\<close>

text \<open> The proof of Lucas's theorem combines a generating function approach, based off \<^cite>\<open>"Fine"\<close> with induction.
For formalisation purposes, it was easier to first prove a well known corollary of the main theorem (also
often presented as an alternative statement for Lucas's theorem), which can itself be used to backwards
prove the the original statement by induction.
This approach was adapted from P. Cameron's lecture notes on combinatorics \<^cite>\<open>"petercameronNotesCombinatorics2007"\<close> \<close>

subsubsection \<open> Proof of the Corollary \<close>
text \<open> This step makes use of the coefficient equivalence arguments proved in the previous sections \<close>
corollary lucas_corollary:
  fixes n k :: nat
  assumes "prime p"
  shows "(n choose k) mod p = (((n div p) choose (k div p)) * ((n mod p) choose (k mod p))) mod p"
    (is "(n choose k) mod p = ((?N choose ?K) * (?rn choose ?rk)) mod p")
proof -
  let ?fx = "fps_X :: int fps"
  have n_rep: "n = ?N * p  + ?rn"
    by simp
  have k_rep: "k =?K * p + ?rk" by simp
  have rhs_coeffs: "((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn)) $ k = (?N choose ?K) * (?rn choose ?rk)"
    using assms fps_div_rep_coeffs k_rep n_rep by blast \<comment> \<open>Application of coefficient reasoning\<close>
  have "((((1 + ?fx)^p)^(?N) * (1 + ?fx)^(?rn)),
          ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn))) \<in> fpsmodrel p"
    using fps_freshmans_dream assms fps_mult_equiv fps_power_equiv by blast \<comment> \<open>Application of equivalence facts and freshmans dream lemma\<close>
  then have modrel2: "((1 + ?fx)^n, ((1 + ?fx^p)^(?N) * (1 + ?fx)^(?rn)))
                          \<in> fpsmodrel p"
    by (metis (mono_tags, opaque_lifting) mult_div_mod_eq power_add power_mult)
  thus ?thesis
    using fpsrel_iff binomial_coeffs_induct rhs_coeffs by (metis of_nat_eq_iff zmod_int)
qed

subsubsection \<open> Proof of the Theorem \<close>

text \<open>The theorem statement requires a formalised way of referring to the base $p$ representation of a number.
We use a definition that specifies the $i$th digit of the base $p$ representation. This definition is originally
from the Hilbert's 10th Problem Formalisation project \<^cite>\<open>"bayerDPRMTheoremIsabelle2019"\<close> which this work contributes to.\<close>
definition nth_digit_general :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "nth_digit_general num i base = (num div (base ^ i)) mod base"

text \<open>Applying induction on $d$, where $d$ is the highest power required in either $n$ or $k$'s base $p$
representation, @{thm lucas_corollary} can be used to prove the original theorem.\<close>

theorem lucas_theorem:
  fixes n k d::nat
assumes "n < p ^ (Suc d)"
assumes "k < p ^ (Suc d)"
assumes "prime p"
shows "(n choose k) mod p = (\<Prod>i\<le>d. ((nth_digit_general n i p) choose (nth_digit_general k i p))) mod p"
  using assms
proof (induct d arbitrary: n k)
  case 0
  thus ?case using nth_digit_general_def assms by simp
next
  case (Suc d)
  \<comment> \<open>Representation Variables\<close>
  let ?N = "n div p"
  let ?K = "k div p"
  let ?nr = "n mod p"
  let ?kr = "k mod p"
  \<comment> \<open>Required assumption facts\<close>
  have Mlessthan: "?N < p ^ (Suc d)"
    using less_mult_imp_div_less power_Suc2 assms(3) prime_ge_2_nat Suc.prems(1) by metis
  have Nlessthan: "?K < p ^ (Suc d)"
    using less_mult_imp_div_less power_Suc2 prime_ge_2_nat Suc.prems(2) assms(3) by metis
  have shift_bounds_fact: "(\<Prod>i=(Suc 0)..(Suc (d )). ((nth_digit_general n i p) choose (nth_digit_general k i p))) =
                            (\<Prod>i=0..(d).  (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p))"
    using prod.shift_bounds_cl_Suc_ivl by blast \<comment> \<open>Product manipulation helper fact\<close>
  have "(n choose k ) mod p = ((?N choose ?K) * (?nr choose ?kr)) mod p"
    using lucas_corollary assms(3) by blast \<comment> \<open>Application of corollary\<close>
  also have "...= ((\<Prod>i\<le>d. ((nth_digit_general ?N i p) choose (nth_digit_general ?K i p))) * (?nr choose ?kr)) mod p"
    using Mlessthan Nlessthan Suc.hyps mod_mult_cong assms(3) by blast \<comment> \<open>Using Inductive Hypothesis\<close>
  \<comment> \<open>Product manipulation steps\<close>
  also have "... = ((\<Prod>i=0..(d). (nth_digit_general n (Suc i) p) choose (nth_digit_general k (Suc i) p)) * (?nr choose ?kr)) mod p"
    using  atMost_atLeast0 nth_digit_general_def div_mult2_eq by auto
  also have "... = ((\<Prod>i=1..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p)) *
                            ((nth_digit_general n 0 p) choose (nth_digit_general k 0 p))) mod p"
    using nth_digit_general_def shift_bounds_fact by simp
  finally have "(n choose k ) mod p = ((\<Prod>i=0..(d+1). (nth_digit_general n i p) choose (nth_digit_general k i p))) mod p"
    using One_nat_def atMost_atLeast0 mult.commute prod.atLeast1_atMost_eq prod.atMost_shift
    by (smt Suc_eq_plus1 shift_bounds_fact)
  thus ?case
    using Suc_eq_plus1 atMost_atLeast0 by presburger
qed

end