section \<open>Two Polynomials\<close>

theory Two_Polynomials
  imports Binomials Binom_Mult Power_Products_PM
begin

(* FIXME: Theory "Binom_Mult" is only needed because of constant "associated". Restructuring that
  theory could thereby save the import. *)

subsection \<open>Preliminaries\<close>

lemma idealI_2: "q1 * f1 + q2 * f2 \<in> ideal {f1, f2::'a::comm_powerprod \<Rightarrow>\<^sub>0 'b::comm_ring_1}"
  by (rule ideal.span_add, rule ideal.span_scale, rule ideal.span_base,
      simp, rule ideal.span_scale, rule ideal.span_base, simp)

lemma idealE_2:
  assumes "f \<in> ideal {f1, f2}"
  obtains q1 q2 where "f = q1 * f1 + q2 * f2"
  using assms
proof (induct f arbitrary: thesis rule: ideal.span_induct')
  case base
  show ?case
  proof (rule base)
    show "0 = 0 * f1 + 0 * f2" by simp
  qed
next
  case (step f' c g)
  obtain q1 q2 where f'_eq: "f' = q1 * f1 + q2 * f2" by (rule step(2))
  from step(3) have "g = f1 \<or> g = f2" by simp
  thus ?case
  proof
    assume "g = f1"
    show ?case
    proof (rule step(5))
      show "f' + c * g = (q1 + c) * f1 + q2 * f2" by (simp add: f'_eq \<open>g = f1\<close> algebra_simps)
    qed
  next
    assume "g = f2"
    show ?case
    proof (rule step(5))
      show "f' + c * g = q1 * f1 + (q2 + c) * f2" by (simp add: f'_eq \<open>g = f2\<close> algebra_simps)
    qed
  qed
qed

lemma ideal_iff_2:
  "f \<in> ideal {f1, f2} \<longleftrightarrow> (\<exists>q1 q2. f = q1 * f1 + q2 * (f2::'a::comm_powerprod \<Rightarrow>\<^sub>0 'b::comm_ring_1))"
proof
  assume "f \<in> ideal {f1, f2}"
  then obtain q1 q2 where "f = q1 * f1 + q2 * f2" by (rule idealE_2)
  show "\<exists>q1 q2. f = q1 * f1 + q2 * f2" by (intro exI, fact)
next
  assume "\<exists>q1 q2. f = q1 * f1 + q2 * f2"
  then obtain q1 q2 where f_eq: "f = q1 * f1 + q2 * f2" by auto
  show "f \<in> ideal {f1, f2}" unfolding f_eq by (rule idealI_2)
qed

lemma map_scale_binomial:
  "a \<cdot> binomial c s d t = binomial (a * c) s (a * (d::_::semiring_0)) (t::_::comm_powerprod)"
  by (simp add: punit.map_scale_eq_monom_mult punit.monom_mult_binomial)

lemma map_scale_two_left: "(2::_::semiring_1) \<cdot> v = v + v"
proof -
  have "2 \<cdot> v = (1 + 1) \<cdot> v" by simp
  also have "\<dots> = v + v" by (simp only: map_scale_distrib_right map_scale_one_left)
  finally show ?thesis .
qed

definition is_nat_pm_pair :: "(('x \<Rightarrow>\<^sub>0 'b) * ('x \<Rightarrow>\<^sub>0 'b::floor_ceiling)) \<Rightarrow> bool" where
  "is_nat_pm_pair pp = (is_nat_pm (fst pp) \<and> is_nat_pm (snd pp))"

definition is_int_pm_pair :: "(('x \<Rightarrow>\<^sub>0 'b) * ('x \<Rightarrow>\<^sub>0 'b::floor_ceiling)) \<Rightarrow> bool" where
  "is_int_pm_pair pp = (is_int_pm (fst pp) \<and> is_int_pm (snd pp))"

lemma is_nat_pm_pairI: "is_nat_pm (fst pp) \<Longrightarrow> is_nat_pm (snd pp) \<Longrightarrow> is_nat_pm_pair pp"
  unfolding is_nat_pm_pair_def ..

lemma is_nat_pm_pairD:
  assumes "is_nat_pm_pair pp"
  shows "is_nat_pm (fst pp)" and "is_nat_pm (snd pp)"
  using assms by (simp_all add: is_nat_pm_pair_def)

lemma is_nat_pm_pair_swap [iff]: "is_nat_pm_pair (prod.swap pp) \<longleftrightarrow> is_nat_pm_pair pp"
  by (auto simp: is_nat_pm_pair_def)

lemma is_int_pm_pairI: "is_int_pm (fst pp) \<Longrightarrow> is_int_pm (snd pp) \<Longrightarrow> is_int_pm_pair pp"
  unfolding is_int_pm_pair_def ..

lemma is_int_pm_pairD:
  assumes "is_int_pm_pair pp"
  shows "is_int_pm (fst pp)" and "is_int_pm (snd pp)"
  using assms by (simp_all add: is_int_pm_pair_def)

lemma nat_pm_pair_is_int_pm_pair: "is_nat_pm_pair pp \<Longrightarrow> is_int_pm_pair pp"
  by (auto intro: is_int_pm_pairI dest: is_nat_pm_pairD nat_pm_is_int_pm)

abbreviation "rat \<equiv> rat_of_nat"

type_synonym 'x point = "('x \<Rightarrow>\<^sub>0 rat)"

context pm_powerprod
begin

lemma binomial_lpp_in_ideal_iff:
  assumes "f \<in> ideal F" and "is_binomial f"
  shows "monomial 1 (lpp f) \<in> ideal F \<longleftrightarrow> monomial (1::_::field) (tpp f) \<in> ideal F"
proof (cases "is_monomial f")
  case True
  hence "lpp f = tpp f" by (rule punit.lt_eq_tt_monomial)
  thus ?thesis by simp
next
  case False
  with assms(2) have "is_proper_binomial f" by (simp add: is_binomial_alt)
  hence "tpp f \<prec> lpp f" by (rule punit.lt_gr_tt_binomial)
  hence "lpp f \<noteq> tpp f" by simp
  from assms(2) have "keys f = {lpp f, tpp f}" by (rule punit.keys_binomial)
  moreover have "monomial 1 u \<in> ideal F" if "monomial 1 v \<in> ideal F" and "keys f = {u, v}" for u v
  proof -
    from \<open>keys f = {lpp f, tpp f}\<close> that(2) \<open>lpp f \<noteq> tpp f\<close> have "u \<noteq> v" by auto
    hence "monomial (lookup f u) u + monomial (lookup f v) v = f"
      by (auto intro!: poly_mapping_eqI simp: lookup_add lookup_single when_def \<open>keys f = {u, v}\<close>
              simp flip: in_keys_iff)
    moreover define c where "c = lookup f u"
    moreover define d where "d = lookup f v"
    ultimately have f: "f = monomial c u + punit.monom_mult d 0 (monomial 1 v)"
      by (simp add: punit.monom_mult_monomial)
    from that(1) have "punit.monom_mult d 0 (monomial 1 v) \<in> ideal F"
      by (rule punit.pmdl_closed_monom_mult[simplified])
    with assms(1) have "f - punit.monom_mult d 0 (monomial 1 v) \<in> ideal F" by (rule ideal.span_diff)
    hence "monomial c u \<in> ideal F" by (simp add: f)
    hence "punit.monom_mult (1 / c) 0 (monomial c u) \<in> ideal F"
      by (rule punit.pmdl_closed_monom_mult[simplified])
    moreover have "c \<noteq> 0" by (simp add: c_def \<open>keys f = {u, v}\<close> flip: in_keys_iff)
    ultimately show ?thesis by (simp add: punit.monom_mult_monomial)
  qed
  ultimately show ?thesis by blast
qed

lemma lem_3_3_12:
  assumes "f \<in> ideal F" and "f' \<in> ideal F" and "is_proper_binomial f" and "monomial 1 (tpp f) \<notin> ideal F"
    and "keys f = keys f'"
  obtains c where "c \<noteq> (0::_::field)" and "f = punit.monom_mult c 0 f'"
proof -
  define c where "c = lcf f / lcf f'"
  from assms(3, 5) have f'_pbinomial: "is_proper_binomial f'" by (simp only: is_proper_binomial_def)
  hence "f' \<noteq> 0" by (rule proper_binomial_not_0)
  hence "lcf f' \<noteq> 0" by (rule punit.lc_not_0)
  hence eq1: "c * lcf f' = lcf f" by (simp add: c_def)
  from f'_pbinomial have "binomial (lcf f') (lpp f') (tcf f') (tpp f') = f'"
    by (rule punit.binomial_eq_itself)
  moreover from assms(5) have "lpp f' = lpp f"
    by (metis lookup_zero not_in_keys_iff_lookup_eq_zero punit.lt_def punit.lt_in_keys)
  moreover from assms(5) have "tpp f' = tpp f"
    by (metis lookup_zero not_in_keys_iff_lookup_eq_zero punit.tt_def punit.tt_in_keys)
  ultimately have f': "binomial (lcf f') (lpp f) (tcf f') (tpp f) = f'" by simp
  also note assms(2)
  finally have "monomial c 0 * binomial (lcf f') (lpp f) (tcf f') (tpp f) \<in> ideal F"
    by (rule ideal.span_scale)
  with \<open>lcf f' \<noteq> 0\<close> have 1: "binomial (lcf f) (lpp f) (c * tcf f') (tpp f) \<in> ideal F"
    by (simp add: times_monomial_left punit.monom_mult_binomial c_def)
  from assms(3) have "binomial (lcf f) (lpp f) (tcf f) (tpp f) = f" by (rule punit.binomial_eq_itself)
  also note assms(1)
  finally have "binomial (lcf f) (lpp f) (tcf f) (tpp f) - binomial (lcf f) (lpp f) (c * tcf f') (tpp f) \<in> ideal F"
    using 1 by (rule ideal.span_diff)
  hence 2: "monomial (tcf f - c * tcf f') (tpp f) \<in> ideal F" by (simp add: binomial_def single_diff)
  have eq2: "c * tcf f' = tcf f"
  proof (rule ccontr)
    assume "c * tcf f' \<noteq> tcf f"
    hence "tcf f - c * tcf f' \<noteq> 0" by simp
    moreover from 2 have "monomial (1 / (tcf f - c * tcf f')) 0 * monomial (tcf f - c * tcf f') (tpp f) \<in> ideal F"
      by (rule ideal.span_scale)
    ultimately have "monomial 1 (tpp f) \<in> ideal F" by (simp add: times_monomial_monomial)
    with assms(4) show False ..
  qed
  show ?thesis
  proof
    from assms(3) have "f \<noteq> 0" by (rule proper_binomial_not_0)
    hence "lcf f \<noteq> 0" by (rule punit.lc_not_0)
    with \<open>lcf f' \<noteq> 0\<close> show "c \<noteq> 0" by (simp add: c_def)
  next
    have "punit.monom_mult c 0 f' = punit.monom_mult c 0 (binomial (lcf f') (lpp f) (tcf f') (tpp f))"
      by (simp only: f')
    also have "\<dots> = binomial (lcf f) (lpp f) (tcf f) (tpp f)"
      by (simp add: punit.monom_mult_binomial eq1 eq2)
    also have "\<dots> = f" by fact
    finally show "f = punit.monom_mult c 0 f'" by (rule sym)
  qed
qed

lemma map_scale_mono:
  assumes "m \<le> n"
  shows "m \<cdot> t \<preceq> n \<cdot> t"
proof -
  have "m \<cdot> t \<preceq> m \<cdot> t + (n - m) \<cdot> t" using zero_min plus_monotone_left by fastforce
  also have "\<dots> = (m + (n - m)) \<cdot> t" by (simp only: map_scale_distrib_right)
  also from assms have "\<dots> = n \<cdot> t" by simp
  finally show ?thesis .
qed

lemma map_scale_mono_left:
  assumes "s \<preceq> t"
  shows "m \<cdot> s \<preceq> m \<cdot> t"
proof (induct m)
  case 0
  show ?case by simp
next
  case (Suc m)
  have "Suc m \<cdot> s = (m + 1) \<cdot> s" by simp
  also have "\<dots> = m \<cdot> s + s" by (simp only: map_scale_distrib_right map_scale_one_left)
  also from Suc have "\<dots> \<preceq> m \<cdot> t + s" by (rule plus_monotone)
  also from assms have "\<dots> \<preceq> m \<cdot> t + t" by (rule plus_monotone_left)
  also have "\<dots> = (m + 1) \<cdot> t" by (simp only: map_scale_distrib_right map_scale_one_left)
  also have "\<dots> = Suc m \<cdot> t" by simp
  finally show ?case .
qed

lemma map_scale_mono_strict:
  assumes "m < n" and "t \<noteq> 0"
  shows "m \<cdot> t \<prec> n \<cdot> t"
proof -
  from assms(1) have "m \<le> n" by simp
  hence "m \<cdot> t \<preceq> n \<cdot> t" by (rule map_scale_mono)
  moreover have "m \<cdot> t \<noteq> n \<cdot> t"
  proof
    from assms(2) obtain x where "0 < lookup t x" using aux by auto
    assume "m \<cdot> t = n \<cdot> t"
    hence "lookup (m \<cdot> t) x = lookup (n \<cdot> t) x" by simp
    with \<open>0 < lookup t x\<close> assms(1) show False by simp
  qed
  ultimately show ?thesis by simp
qed

lemma map_scale_mono_strict_left:
  assumes "s \<prec> t" and "0 < m"
  shows "m \<cdot> s \<prec> m \<cdot> t"
proof -
  from assms(1) have "s \<preceq> t" by simp
  hence "m \<cdot> s \<preceq> m \<cdot> t" by (rule map_scale_mono_left)
  moreover have "m \<cdot> s \<noteq> m \<cdot> t"
  proof
    from assms(1) have "s \<noteq> t" by simp
    then obtain x where "lookup s x \<noteq> lookup t x" by (meson poly_mapping_eqI)
    with assms(2) have "lookup (m \<cdot> s) x \<noteq> lookup (m \<cdot> t) x" by simp
    moreover assume "m \<cdot> s = m \<cdot> t"
    ultimately show False by simp
  qed
  ultimately show ?thesis by simp
qed

definition poly_point :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> ('x point \<times> 'x point)" where
  "poly_point p = (of_nat_pm (lpp p), of_nat_pm (tpp p))"

definition vect :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::zero) \<Rightarrow> ('x point)"
  where "vect p = fst (poly_point p) - snd (poly_point p)"

definition pos_comps :: "'x point \<Rightarrow> 'x point" ("(_\<^sub>+)" [1000] 999)
  where "pos_comps p = lcs p 0"

definition neg_comps :: "'x point \<Rightarrow> 'x point" ("(_\<^sub>-)" [1000] 999)
  where "neg_comps p = lcs (- p) 0"

lemma fst_poly_point: "fst (poly_point p) = of_nat_pm (lpp p)"
  by (simp add: poly_point_def)

lemma snd_poly_point: "snd (poly_point p) = of_nat_pm (tpp p)"
  by (simp add: poly_point_def)

lemma poly_point_is_nat_pm_pair: "is_nat_pm_pair (poly_point p)"
  unfolding poly_point_def by (rule is_nat_pm_pairI, simp_all, (rule of_nat_pm_is_nat_pm)+)

lemma poly_point_is_int_pm_pair: "is_int_pm_pair (poly_point p)"
  using poly_point_is_nat_pm_pair by (rule nat_pm_pair_is_int_pm_pair)

lemma swap_poly_point_not_eq:
  assumes "is_proper_binomial p"
  shows "prod.swap (poly_point p) \<noteq> poly_point q"
proof
  assume "prod.swap (poly_point p) = poly_point q"
  hence 1: "lpp p = tpp q" and 2: "tpp p = lpp q" by (simp_all add: poly_point_def)
  from assms(1) have "tpp p \<prec> lpp p" by (rule punit.lt_gr_tt_binomial)
  hence "lpp q \<prec> tpp q" by (simp only: 1 2)
  with punit.lt_ge_tt[of q] show False by simp
qed

corollary swap_poly_point_not_eq':
  assumes "is_proper_binomial q"
  shows "prod.swap (poly_point p) \<noteq> poly_point q"
proof
  assume *: "prod.swap (poly_point p) = poly_point q"
  from assms have "prod.swap (poly_point q) \<noteq> poly_point p" by (rule swap_poly_point_not_eq)
  moreover from *[symmetric] have "prod.swap (poly_point q) = poly_point p" by simp
  ultimately show False ..
qed

lemma fst_eq_snd_poly_point_iff: "fst (poly_point p) = snd (poly_point p) \<longleftrightarrow> card (keys p) \<le> 1"
proof -
  have "fst (poly_point p) = snd (poly_point p) \<longleftrightarrow> lpp p = tpp p"
    by (simp add: poly_point_def)
  also have "\<dots> \<longleftrightarrow> card (keys p) \<le> 1" by (simp only: punit.lt_eq_tt_iff has_bounded_keys_def)
  finally show ?thesis .
qed

lemma vect_alt: "vect p = of_nat_pm (lpp p) - of_nat_pm (tpp p)"
  by (simp only: vect_def fst_poly_point snd_poly_point)

lemma vect_is_int_pm: "is_int_pm (vect p)"
  by (simp add: vect_def is_int_pm_pairD[OF poly_point_is_int_pm_pair] is_int_pm_pairD minus_is_int_pm)

lemma associated_alt_rat:
  "associated q s t k \<longleftrightarrow> of_nat_pm s = ((of_nat_pm t)::'x point) + rat k \<cdot> vect q" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  show ?R unfolding vect_alt
  proof (rule poly_mapping_eqI, simp add: lookup_of_nat_pm lookup_add lookup_minus)
    fix x
    from \<open>?L\<close> have "lookup t x + k * lookup (lpp q) x = lookup s x + k * lookup (tpp q) x"
      by (rule associatedD_lookup)
    hence "rat (lookup t x + k * lookup (lpp q) x) = rat (lookup s x + k * lookup (tpp q) x)" by simp
    thus "rat (lookup s x) = rat (lookup t x) + rat k * (rat (lookup (lpp q) x) - rat (lookup (tpp q) x))"
      by (simp add: right_diff_distrib)
  qed
next
  assume ?R
  show ?L
  proof (rule associatedI_lookup)
    fix x
    from \<open>?R\<close> have "lookup (of_nat_pm t + rat k \<cdot> vect q) x = lookup (of_nat_pm s) x" by simp
    hence "rat (lookup t x) + rat k * (rat (lookup (lpp q) x) - rat (lookup (tpp q) x)) = rat (lookup s x)"
      by (simp add: vect_alt lookup_of_nat_pm lookup_add lookup_minus)
    hence "rat (lookup t x + k * lookup (lpp q) x) = rat (lookup s x + k * lookup (tpp q) x)"
      by (simp add: right_diff_distrib)
    thus "lookup t x + k * lookup (lpp q) x = lookup s x + k * lookup (tpp q) x"
      using of_nat_eq_iff by blast
  qed
qed

lemma pos_minus_neg_comps [simp]: "p\<^sub>+ - p\<^sub>- = p"
  by (rule poly_mapping_eqI) (simp add: pos_comps_def neg_comps_def lookup_minus lookup_lcs_fun lcs_fun_def)

lemma pos_comps_is_int_pm: "is_int_pm p \<Longrightarrow> is_int_pm (p\<^sub>+)"
  unfolding pos_comps_def by (intro lcs_is_int_pm zero_is_int_pm)

lemma pos_comps_ge_zero: "0 \<unlhd> p\<^sub>+"
  unfolding pos_comps_def by (rule lcs_ge_pm)

lemma pos_comps_ge_self: "p \<unlhd> p\<^sub>+"
  unfolding pos_comps_def by (rule lcs_ge_pm)

lemma pos_comps_is_nat_pm: "is_int_pm p \<Longrightarrow> is_nat_pm (p\<^sub>+)"
  by (auto intro: int_pm_is_nat_pmI pos_comps_is_int_pm pos_comps_ge_zero zero_is_nat_pm)

lemma pos_comps_zero [simp]: "0\<^sub>+ = 0"
  by (simp add: pos_comps_def lcs_ge_pm(1) lcs_le_pm le_pm_antisym)

lemma pos_comps_zero_iff [iff]: "p\<^sub>+ = 0 \<longleftrightarrow> p \<unlhd> 0"
  by (metis lcs_comm lcs_ge_pm(1) lcs_le_pm le_pm_antisym le_pm_refl pos_comps_def)

lemma pos_comps_uminus [simp]: "(- p)\<^sub>+ = p\<^sub>-"
  by (simp only: pos_comps_def neg_comps_def)

lemma pos_comps_plus_le: "(p + q)\<^sub>+ \<unlhd> p\<^sub>+ + q\<^sub>+"
  by (rule le_pmI) (simp add: pos_comps_def lookup_add lookup_lcs_fun lcs_fun_def)

lemma pos_comps_minus_le: "(p - q)\<^sub>+ \<unlhd> p\<^sub>+ + q\<^sub>-"
proof -
  have "(p + (- q))\<^sub>+ \<unlhd> p\<^sub>+ + (- q)\<^sub>+" by (rule pos_comps_plus_le)
  thus ?thesis by simp
qed

lemma pos_comps_map_scale: "(c \<cdot> p)\<^sub>+ = (if 0 \<le> c then c \<cdot> p\<^sub>+ else - c \<cdot> p\<^sub>-)"
  by (rule poly_mapping_eqI)
    (simp add: pos_comps_def neg_comps_def lookup_lcs_fun lcs_fun_def max_mult_distrib_left)

lemma neg_comps_is_int_pm: "is_int_pm p \<Longrightarrow> is_int_pm (p\<^sub>-)"
  unfolding neg_comps_def by (intro lcs_is_int_pm uminus_is_int_pm zero_is_int_pm)

lemma neg_comps_ge_zero: "0 \<unlhd> p\<^sub>-"
  unfolding neg_comps_def by (rule lcs_ge_pm)

lemma neg_comps_ge_self: "- p \<unlhd> p\<^sub>-"
  unfolding neg_comps_def by (rule lcs_ge_pm)

lemma neg_comps_is_nat_pm: "is_int_pm p \<Longrightarrow> is_nat_pm (p\<^sub>-)"
  by (auto intro: int_pm_is_nat_pmI neg_comps_is_int_pm neg_comps_ge_zero zero_is_nat_pm)

lemma neg_comps_zero [simp]: "0\<^sub>- = 0"
  by (simp add: neg_comps_def lcs_ge_pm(1) lcs_le_pm le_pm_antisym)

lemma neg_comps_zero_iff [iff]: "p\<^sub>- = 0 \<longleftrightarrow> 0 \<unlhd> p"
  by (metis add.right_inverse diff_zero le_pm_increasing le_pm_refl pos_comps_ge_zero
      pos_comps_uminus pos_comps_zero_iff pos_minus_neg_comps)

lemma neg_comps_uminus [simp]: "(- p)\<^sub>- = p\<^sub>+"
  by (simp add: pos_comps_def neg_comps_def)

lemma neg_comps_plus_le: "(p + q)\<^sub>- \<unlhd> p\<^sub>- + q\<^sub>-"
  by (rule le_pmI) (simp add: neg_comps_def lookup_add lookup_minus lookup_lcs_fun lcs_fun_def)

lemma neg_comps_minus_le: "(p - q)\<^sub>- \<unlhd> p\<^sub>- + q\<^sub>+"
proof -
  have "(p + (- q))\<^sub>- \<unlhd> p\<^sub>- + (- q)\<^sub>-" by (rule neg_comps_plus_le)
  thus ?thesis by simp
qed

lemma neg_comps_map_scale: "(c \<cdot> p)\<^sub>- = (if 0 \<le> c then c \<cdot> p\<^sub>- else - c \<cdot> p\<^sub>+)"
  by (rule poly_mapping_eqI)
    (simp add: pos_comps_def neg_comps_def lookup_lcs_fun lcs_fun_def max_mult_distrib_left)

end (* pm_powerprod *)

subsection \<open>Overlap\<close>

locale two_polys =
  pm_powerprod ord ord_strict
  for ord::"('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x::{countable,linorder} \<Rightarrow>\<^sub>0 nat) \<Rightarrow> bool" (infixl "\<preceq>" 50)
  and ord_strict (infixl "\<prec>" 50) +
  fixes f1 f2 :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::field"
begin

definition overlap :: "'x point"
  where "overlap = lcs (gcs (fst (poly_point f1)) (snd (poly_point f1)))
                       (gcs (fst (poly_point f2)) (snd (poly_point f2)))"

lemma overlap_alt:
  "overlap = lcs (gcs (of_nat_pm (lpp f1)) (of_nat_pm (tpp f1)))
                 (gcs (of_nat_pm (lpp f2)) (of_nat_pm (tpp f2)))"
  by (simp only: overlap_def fst_poly_point snd_poly_point)

lemma overlap_alt': "overlap = of_nat_pm (lcs (gcs (lpp f1) (tpp f1)) (gcs (lpp f2) (tpp f2)))"
  by (simp add: overlap_alt gcs_of_nat_pm lcs_of_nat_pm)

lemma overlap_is_nat_pm: "is_nat_pm overlap"
  by (simp add: overlap_def is_nat_pm_pairD[OF poly_point_is_nat_pm_pair] gcs_is_nat_pm lcs_is_nat_pm)

lemma gcs_le_overlap:
  shows "gcs (of_nat_pm (lpp f1)) (of_nat_pm (tpp f1)) \<unlhd> overlap"
    and "gcs (of_nat_pm (lpp f2)) (of_nat_pm (tpp f2)) \<unlhd> overlap"
  by (simp_all add: overlap_alt le_pm_def lookup_lcs_fun leq_lcs_fun_1 leq_lcs_fun_2)

lemma gcs_le_overlap':
  shows "of_nat_pm (gcs (lpp f1) (tpp f1)) \<unlhd> overlap" and "of_nat_pm (gcs (lpp f2) (tpp f2)) \<unlhd> overlap"
  using gcs_le_overlap by (simp_all add: gcs_of_nat_pm)

lemma overlap_is_int_pm: "is_int_pm overlap"
  using overlap_is_nat_pm by (rule nat_pm_is_int_pm)

lemma overlap_leI:
  "gcs (lpp f1) (tpp f1) adds t \<Longrightarrow> gcs (lpp f2) (tpp f2) adds t \<Longrightarrow> overlap \<unlhd> of_nat_pm t"
  unfolding overlap_alt' le_of_nat_pm adds_pm[symmetric] by (rule lcs_adds)

lemma overlap_leD:
  assumes "overlap \<unlhd> of_nat_pm t"
  shows "gcs (lpp f1) (tpp f1) adds t" and "gcs (lpp f2) (tpp f2) adds t"
  using assms by (auto simp: overlap_alt' le_of_nat_pm adds_pm[symmetric]
                       intro: adds_trans[OF adds_lcs] adds_trans[OF adds_lcs_2])

lemma lem_3_1_13:
  assumes "of_nat_pm (tpp f1) \<unlhd> p" and "of_nat_pm (tpp f2) \<unlhd> p"
  shows "overlap \<unlhd> p"
  unfolding overlap_alt lookup_lcs_fun le_pm_def
proof (rule lcs_leq_fun)
  let ?t = "of_nat_pm (lpp f1)"
  let ?s = "of_nat_pm (tpp f1)"
  have "lookup (gcs ?t ?s) \<le> lookup ?s" unfolding lookup_gcs_fun by (fact gcs_leq_fun_2)
  also from assms(1) have "... \<le> lookup p" by (simp only: le_pm_def)
  finally show "lookup (gcs ?t ?s) \<le> lookup p" .
next
  let ?t = "of_nat_pm (lpp f2)"
  let ?s = "of_nat_pm (tpp f2)"
  have "lookup (gcs ?t ?s) \<le> lookup ?s" unfolding lookup_gcs_fun by (fact gcs_leq_fun_2)
  also from assms(2) have "... \<le> lookup p" by (simp only: le_pm_def)
  finally show "lookup (gcs ?t ?s) \<le> lookup p" .
qed

lemma line_above_overlapD:
  assumes "overlap \<unlhd> p" and "overlap \<unlhd> p + l \<cdot> vect f" and "f \<in> {f1, f2}" and "1 \<le> l"
  shows "of_nat_pm (tpp f) \<unlhd> p" and "tpp f \<unlhd> to_nat_pm p" and "of_nat_pm (lpp f) \<unlhd> p + l \<cdot> vect f"
    and "lpp f \<unlhd> to_nat_pm (p + l \<cdot> vect f)"
proof -
  define q where "q = p + l \<cdot> vect f"
  let ?l = "of_nat_pm (lpp f) :: _ \<Rightarrow>\<^sub>0 rat"
  let ?t = "of_nat_pm (tpp f) :: _ \<Rightarrow>\<^sub>0 rat"
  let ?p = "to_nat_pm p"
  let ?q = "to_nat_pm q"

  from assms(1, 3) have 1: "gcs ?l ?t \<unlhd> p" by (auto simp: overlap_alt intro: le_pm_trans lcs_ge_pm)
  from assms(1) have "overlap \<unlhd> p + 0 \<cdot> vect f" by simp
  hence "overlap \<unlhd> p + 1 \<cdot> vect f" using assms(2) _ assms(4) by (rule map_scale_le_interval) simp
  hence "overlap \<unlhd> p + vect f" by simp
  with assms(3) have 2: "gcs ?l ?t \<unlhd> p + vect f"
    by (auto simp: overlap_alt intro: le_pm_trans lcs_ge_pm)

  show "?t \<unlhd> p"
  proof (rule le_pmI)
    fix x
    show "lookup ?t x \<le> lookup p x"
    proof (rule ccontr)
      assume "\<not> lookup ?t x \<le> lookup p x"
      hence 3: "lookup p x < lookup ?t x" by simp
      hence "lookup (p + vect f) x < lookup (?t + vect f) x" by (simp only: lookup_add)
      also have "\<dots> = lookup ?l x" by (simp add: vect_alt)
      finally have 4: "lookup (p + vect f) x < lookup ?l x" .
      have *: "min (lookup ?l x) (lookup ?t x) = lookup (gcs ?l ?t) x"
        by (simp only: lookup_gcs_fun gcs_fun)
      also from 1 have "\<dots> \<le> lookup p x" by (rule le_pmD)
      finally have **: "lookup ?l x < lookup ?t x" using 3 by simp
      note *
      also from 2 have "lookup (gcs ?l ?t) x \<le> lookup (p + vect f) x" by (rule le_pmD)
      finally have "lookup ?t x < lookup ?l x" using 4 by simp
      with ** show False by simp
    qed
  qed

  hence "to_nat_pm ?t \<unlhd> ?p" by (rule to_nat_pm_mono)
  thus "tpp f \<unlhd> ?p" by simp

  from assms(2, 3) have 1: "gcs ?l ?t \<unlhd> q" by (auto simp: q_def overlap_alt intro: le_pm_trans lcs_ge_pm)
  from assms(1) have "overlap \<unlhd> p + 0 \<cdot> vect f" by simp
  hence "overlap \<unlhd> p + (l - 1) \<cdot> vect f" using assms(2)
    by (rule map_scale_le_interval) (simp_all add: assms(4))
  hence "overlap \<unlhd> q -  vect f" by (simp add: q_def algebra_simps)
  with assms(3) have 2: "gcs ?l ?t \<unlhd> q - vect f"
    by (auto simp: overlap_alt intro: le_pm_trans lcs_ge_pm)

  show "?l \<unlhd> q"
  proof (rule le_pmI)
    fix x
    show "lookup ?l x \<le> lookup q x"
    proof (rule ccontr)
      assume "\<not> lookup ?l x \<le> lookup q x"
      hence 3: "lookup q x < lookup ?l x" by simp
      hence "lookup (q - vect f) x < lookup (?l - vect f) x" by (simp only: lookup_minus)
      also have "\<dots> = lookup ?t x" by (simp add: vect_alt)
      finally have 4: "lookup (q - vect f) x < lookup ?t x" .
      have *: "min (lookup ?l x) (lookup ?t x) = lookup (gcs ?l ?t) x"
        by (simp only: lookup_gcs_fun gcs_fun)
      also from 1 have "\<dots> \<le> lookup q x" by (rule le_pmD)
      finally have **: "lookup ?t x < lookup ?l x" using 3 by simp
      note *
      also from 2 have "lookup (gcs ?l ?t) x \<le> lookup (q - vect f) x" by (rule le_pmD)
      finally have "lookup ?l x < lookup ?t x" using 4 by simp
      with ** show False by simp
    qed
  qed

  hence "to_nat_pm ?l \<unlhd> ?q" by (rule to_nat_pm_mono)
  thus "lpp f \<unlhd> ?q" by simp
qed

lemma line_above_tpp_overlapD:
  assumes "of_nat_pm (tpp f) \<unlhd> p" and "overlap \<unlhd> p + l \<cdot> vect f" and "f \<in> {f1, f2}" and "1 \<le> l"
  shows "of_nat_pm (lpp f) \<unlhd> p + l \<cdot> vect f" and "lpp f \<unlhd> to_nat_pm (p + l \<cdot> vect f)"
proof -
  define q where "q = p + l \<cdot> vect f"
  let ?l = "of_nat_pm (lpp f) :: _ \<Rightarrow>\<^sub>0 rat"
  let ?t = "of_nat_pm (tpp f) :: _ \<Rightarrow>\<^sub>0 rat"
  let ?q = "to_nat_pm q"

  from assms(2, 3) have 1: "gcs ?l ?t \<unlhd> q" by (auto simp: q_def overlap_alt intro: le_pm_trans lcs_ge_pm)

  show "?l \<unlhd> q"
  proof (rule le_pmI)
    fix x
    show "lookup ?l x \<le> lookup q x"
    proof (rule ccontr)
      assume "\<not> lookup ?l x \<le> lookup q x"
      hence 3: "lookup q x < lookup ?l x" by simp
      hence "lookup (q - vect f) x < lookup (?l - vect f) x" by (simp only: lookup_minus)
      also have "\<dots> = lookup ?t x" by (simp add: vect_alt)
      also from assms(1) have "\<dots> \<le> lookup p x" by (rule le_pmD)
      finally have "lookup (q - vect f) x < lookup p x" .
      hence "(l - 1) * lookup (vect f) x < 0" by (simp add: q_def lookup_add lookup_minus algebra_simps)
      with assms(4) have "lookup (vect f) x < 0" by (simp add: mult_less_0_iff)

      have "min (lookup ?l x) (lookup ?t x) = lookup (gcs ?l ?t) x"
        by (simp only: lookup_gcs_fun gcs_fun)
      also from 1 have "\<dots> \<le> lookup q x" by (rule le_pmD)
      finally have "lookup ?t x < lookup ?l x" using 3 by simp
      hence "0 < lookup (vect f) x" by (simp add: vect_alt lookup_minus)
      also have "\<dots> < 0" by fact
      finally show False ..
    qed
  qed

  hence "to_nat_pm ?l \<unlhd> ?q" by (rule to_nat_pm_mono)
  thus "lpp f \<unlhd> ?q" by simp
qed

lemma line_above_lpp_overlapD:
  assumes "overlap \<unlhd> p" and "of_nat_pm (lpp f) \<unlhd> p + l \<cdot> vect f" and "f \<in> {f1, f2}" and "1 \<le> l"
  shows "of_nat_pm (tpp f) \<unlhd> p" and "tpp f \<unlhd> to_nat_pm p"
proof -
  let ?l = "of_nat_pm (lpp f) :: _ \<Rightarrow>\<^sub>0 rat"
  let ?t = "of_nat_pm (tpp f) :: _ \<Rightarrow>\<^sub>0 rat"
  let ?p = "to_nat_pm p"

  from assms(1, 3) have 1: "gcs ?l ?t \<unlhd> p" by (auto simp: overlap_alt intro: le_pm_trans lcs_ge_pm)

  show "?t \<unlhd> p"
  proof (rule le_pmI)
    fix x
    show "lookup ?t x \<le> lookup p x"
    proof (rule ccontr)
      assume "\<not> lookup ?t x \<le> lookup p x"
      hence 3: "lookup p x < lookup ?t x" by simp
      hence "lookup (p + vect f) x < lookup (?t + vect f) x" by (simp only: lookup_add)
      also have "\<dots> = lookup ?l x" by (simp add: vect_alt)
      also from assms(2) have "\<dots> \<le> lookup (p + l \<cdot> vect f) x" by (rule le_pmD)
      finally have "lookup (p + vect f) x < lookup (p + l \<cdot> vect f) x" .
      hence "0 < (l - 1) * lookup (vect f) x" by (simp add: lookup_add algebra_simps)
      with assms(4) have "0 < lookup (vect f) x" by (simp add: zero_less_mult_iff)

      have "min (lookup ?l x) (lookup ?t x) = lookup (gcs ?l ?t) x"
        by (simp only: lookup_gcs_fun gcs_fun)
      also from 1 have "\<dots> \<le> lookup p x" by (rule le_pmD)
      finally have "lookup ?l x < lookup ?t x" using 3 by simp
      hence "lookup (vect f) x < 0" by (simp add: vect_alt lookup_minus)
      also have "\<dots> < lookup (vect f) x" by fact
      finally show False ..
    qed
  qed

  hence "to_nat_pm ?t \<unlhd> ?p" by (rule to_nat_pm_mono)
  thus "tpp f \<unlhd> ?p" by simp
qed

definition step_p' :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'x point \<Rightarrow> nat" where
  "step_p' f p = Max ({nat \<lceil>(lookup overlap x - lookup p x) / lookup (vect f) x\<rceil> |
                      x::'x. 0 < lookup (vect f) x \<and> lookup p x < lookup overlap x} \<union> {0})"

text \<open>Note that the original definition of @{term step_p'} requires @{term \<open>lookup (vect f) x \<noteq> 0\<close>} instead
      of @{term \<open>0 < lookup (vect f) x\<close>}. One can easily prove, however, that both formulations are equivalent.\<close>

definition step_p :: "'x point \<Rightarrow> nat" where
  "step_p p =
    (if (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) then
      step_p' (SOME f. f \<in> {f1, f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) p
    else 0)"

definition overlapshift_p' :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b) \<Rightarrow> 'x point \<Rightarrow> 'x point" where
  "overlapshift_p' f p = p + rat (step_p' f p) \<cdot> vect f"

definition overlapshift_p :: "'x point \<Rightarrow> 'x point" where
  "overlapshift_p p =
    (if (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) then
      overlapshift_p' (SOME f. f \<in> {f1,f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) p
    else p)"

definition step' :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> nat" where
  "step' f t = step_p' f (of_nat_pm t)"

definition step :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> nat" where
  "step t = step_p (of_nat_pm t)"

definition overlapshift' :: "(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat)" where
  "overlapshift' f p = to_nat_pm (overlapshift_p' f (of_nat_pm p))"

definition overlapshift :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x \<Rightarrow>\<^sub>0 nat)" where
  "overlapshift = to_nat_pm o overlapshift_p o of_nat_pm"

lemma finite_step_p'_carrier: "finite {x::'x. 0 < lookup (vect f) x \<and> lookup p x < lookup overlap x}"
proof (rule finite_subset)
  show "{x. 0 < lookup (vect f) x \<and> lookup p x < lookup overlap x} \<subseteq> keys (vect f)"
  proof (rule, simp, elim conjE)
    fix x
    assume "0 < lookup (vect f) x"
    hence "lookup (vect f) x \<noteq> 0" by simp
    thus "x \<in> keys (vect f)" by (simp add: in_keys_iff)
  qed
qed (fact finite_keys)

lemma step_p'_alt:
  "step_p' f p = nat \<lceil>Max ({(lookup overlap x - lookup p x) / lookup (vect f) x |
                          x::'x. 0 < lookup (vect f) x \<and> lookup p x < lookup overlap x} \<union> {0::rat})\<rceil>"
proof -
  let ?ol = "lookup overlap"
  let ?vc = "lookup (vect f)"
  have "\<lceil>Max ({(?ol x - lookup p x) / ?vc x | x::'x. 0 < ?vc x \<and> lookup p x < ?ol x} \<union> {0::rat})\<rceil> =
        Max (ceiling ` ({(?ol x - lookup p x) / ?vc x | x::'x. 0 < ?vc x \<and> lookup p x < ?ol x} \<union> {0::rat}))"
    by (rule mono_Max_commute, rule, fact ceiling_mono, simp_all add: finite_step_p'_carrier)
  also have "\<dots> = Max ({\<lceil>(?ol x - lookup p x) / ?vc x\<rceil> | x::'x. 0 < ?vc x \<and> lookup p x < ?ol x} \<union> {0::int})"
    by (simp add: image_image_Collect)
  also have "nat \<dots> = Max (nat ` ({\<lceil>(?ol x - lookup p x) / ?vc x\<rceil> |
                      x::'x. 0 < ?vc x \<and> lookup p x < ?ol x} \<union> {0::int}))"
    by (rule mono_Max_commute, rule, simp_all add: finite_step_p'_carrier)
  also have "\<dots> = step_p' f p" by (simp add: step_p'_def image_image_Collect)
  finally show ?thesis by (rule sym)
qed

lemma int_step_p':
  "int (step_p' f p) = \<lceil>Max ({(lookup overlap x - lookup p x) / lookup (vect f) x |
                          x::'x. 0 < lookup (vect f) x \<and> lookup p x < lookup overlap x} \<union> {0})\<rceil>"
  (is "?l = \<lceil>?r\<rceil>")
proof -
  define c where "c = ?r"
  have "0 \<le> c" by (simp only: c_def, rule Max_ge, simp_all add: finite_step_p'_carrier)
  hence "0 \<le> \<lceil>c\<rceil>" by simp
  hence "int (nat \<lceil>c\<rceil>) = \<lceil>c\<rceil>" by simp
  thus ?thesis by (simp only: step_p'_alt c_def)
qed

lemma step_p'_above_overlap:
  assumes "overlap \<unlhd> p"
  shows "step_p' f p = 0"
proof -
  let ?A = "{nat \<lceil>(lookup overlap x - lookup p x) / lookup (vect f) x\<rceil> |
                      x::'x. 0 < lookup (vect f) x \<and> lookup p x < lookup overlap x}"
  have eq: "?A = {}"
  proof (simp, intro allI impI)
    fix x
    assume "0 < lookup (vect f) x"
    from assms have "lookup overlap x \<le> lookup p x"
      by (simp add: le_pm_def le_fun_def of_nat_pm.rep_eq of_nat_fun_def)
    thus "\<not> lookup p x < lookup overlap x" by simp
  qed
  show ?thesis unfolding step_p'_def eq by simp
qed

lemma step_p_welldefined:
  assumes "of_nat_pm (tpp f1) \<unlhd> p" and "of_nat_pm (tpp f2) \<unlhd> p"
  shows "step_p p = 0"
  unfolding step_p_def
proof (split if_split, intro conjI impI)
  from assms have "overlap \<unlhd> p" by (rule lem_3_1_13)
  thus "step_p' (SOME f. f\<in> {f1, f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) p = 0"
    by (rule step_p'_above_overlap)
qed rule

lemma some_step_p_eqI:
  assumes "f \<in> {f1, f2}" and "is_proper_binomial f" and "of_nat_pm (tpp f) \<unlhd> p"
    and "\<exists>g\<in>{f1,f2}. \<not> of_nat_pm (tpp g) \<unlhd> p"
  shows "(SOME f. f \<in> {f1, f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) = f"
proof (rule some_equality)
  from assms show "f \<in> {f1, f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p" by simp
next
  fix f'
  assume "f' \<in> {f1, f2} \<and> is_proper_binomial f' \<and> of_nat_pm (tpp f') \<unlhd> p"
  hence "f' \<in> {f1, f2}" and "of_nat_pm (tpp f') \<unlhd> p" by simp_all
  show "f' = f"
  proof (rule ccontr)
    assume "f' \<noteq> f"
    have "\<forall>g\<in>{f1, f2}. of_nat_pm (tpp g) \<unlhd> p"
    proof
      fix g
      assume "g \<in> {f1, f2}"
      with \<open>f \<in> {f1, f2}\<close> \<open>f' \<in> {f1, f2}\<close> \<open>f' \<noteq> f\<close> have "g = f \<or> g = f'" by auto
      with \<open>of_nat_pm (tpp f) \<unlhd> p\<close> \<open>of_nat_pm (tpp f') \<unlhd> p\<close> show "of_nat_pm (tpp g) \<unlhd> p" by auto
    qed
    with assms(4) show False by simp
  qed
qed

lemma step_p_alt1:
  assumes "f \<in> {f1, f2}" and "is_proper_binomial f" and "of_nat_pm (tpp f) \<unlhd> p"
  shows "step_p p = step_p' f p"
proof (cases "\<forall>g\<in>{f1, f2}. of_nat_pm (tpp g) \<unlhd> p")
  case True
  hence "of_nat_pm (tpp f1) \<unlhd> p" and "of_nat_pm (tpp f2) \<unlhd> p" by simp_all
  hence "step_p p = 0" and "overlap \<unlhd> p" by (rule step_p_welldefined, rule lem_3_1_13)
  from this(2) have "step_p' f p = 0" by (rule step_p'_above_overlap)
  with \<open>step_p p = 0\<close> show ?thesis by simp
next
  case False
  hence "\<exists>g\<in>{f1,f2}. \<not> of_nat_pm (tpp g) \<unlhd> p" by simp
  with assms have eq: "(SOME f. f \<in> {f1, f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) = f"
    by (rule some_step_p_eqI)
  show ?thesis unfolding step_p_def eq
  proof (split if_split, intro conjI impI, rule)
    assume "\<not> (\<exists>g\<in>{f1, f2}.is_proper_binomial g \<and> of_nat_pm (tpp g) \<unlhd> p)"
    hence "\<forall>g\<in>{f1,f2}. (\<not> is_proper_binomial g) \<or> \<not> of_nat_pm (tpp g) \<unlhd> p" by simp
    from this \<open>f \<in> {f1, f2}\<close> have "(\<not> is_proper_binomial f) \<or> \<not> of_nat_pm (tpp f) \<unlhd> p" ..
    with assms(2) assms(3) show "0 = step_p' f p" by simp
  qed
qed

lemma step_p_alt2: "\<not> (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) \<Longrightarrow> step_p p = 0"
  by (auto simp: step_p_def)

lemma overlapshift_p'_is_int_pm: "is_int_pm p \<Longrightarrow> is_int_pm (overlapshift_p' f p)"
  unfolding overlapshift_p'_def by (intro plus_is_int_pm map_scale_is_int_pm Ints_of_nat vect_is_int_pm)

lemma overlapshift_p'_above_overlap: "overlap \<unlhd> p \<Longrightarrow> overlapshift_p' f p = p"
  by (simp add: overlapshift_p'_def step_p'_above_overlap)

lemma overlapshift_p_welldefined:
  assumes "of_nat_pm (tpp f1) \<unlhd> p" and "of_nat_pm (tpp f2) \<unlhd> p"
  shows "overlapshift_p p = p"
  unfolding overlapshift_p_def
proof (split if_split, intro conjI impI)
  from assms have "overlap \<unlhd> p" by (rule lem_3_1_13)
  thus "overlapshift_p' (SOME f. f \<in> {f1, f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) p = p"
    by (rule overlapshift_p'_above_overlap)
qed rule

lemma overlapshift_p_alt0:
  assumes "f \<in> {f1, f2}" and "is_proper_binomial f" and "of_nat_pm (tpp f) \<unlhd> p"
  shows "overlapshift_p p = p + rat (step_p p) \<cdot> vect f"
proof (cases "\<forall>g\<in>{f1, f2}. of_nat_pm (tpp g) \<unlhd> p")
  case True
  hence "of_nat_pm (tpp f1) \<unlhd> p" and "of_nat_pm (tpp f2) \<unlhd> p" by simp_all
  hence "overlapshift_p p = p" and "step_p p = 0" by (rule overlapshift_p_welldefined, rule step_p_welldefined)
  thus ?thesis by simp
next
  case False
  hence "\<exists>g\<in>{f1,f2}. \<not> of_nat_pm (tpp g) \<unlhd> p" by simp
  with assms have eq: "(SOME f. f \<in> {f1, f2} \<and> is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) = f"
    by (rule some_step_p_eqI)
  show ?thesis unfolding overlapshift_p_def eq
  proof (split if_split, intro conjI impI)
    from assms have "step_p p = step_p' f p" by (rule step_p_alt1)
    thus "overlapshift_p' f p = p + rat (step_p p) \<cdot> vect f" by (simp add: overlapshift_p'_def)
  next
    assume "\<not> (\<exists>f\<in>{f1, f2}. is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p)"
    hence "\<forall>f\<in>{f1,f2}. (\<not> is_proper_binomial f) \<or> \<not> of_nat_pm (tpp f) \<unlhd> p" by simp
    from this \<open>f \<in> {f1, f2}\<close> have "(\<not> is_proper_binomial f) \<or> \<not> of_nat_pm (tpp f) \<unlhd> p" ..
    with assms(2) assms(3) show "p = p + rat (step_p p) \<cdot> vect f" by simp
  qed
qed

lemma overlapshift_p_alt1:
  "f \<in> {f1, f2} \<Longrightarrow> is_proper_binomial f \<Longrightarrow> of_nat_pm (tpp f) \<unlhd> p \<Longrightarrow> overlapshift_p p = overlapshift_p' f p"
  by (simp only: overlapshift_p'_def overlapshift_p_alt0 step_p_alt1)

lemma overlapshift_p_alt2:
  "\<not> (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> of_nat_pm (tpp f) \<unlhd> p) \<Longrightarrow> overlapshift_p p = p"
  by (auto simp: overlapshift_p_def)

lemma overlapshift_p_is_int_pm:
  assumes "is_int_pm p"
  shows "is_int_pm (overlapshift_p p)"
  unfolding overlapshift_p_def
  by (split if_split, intro conjI impI, rule overlapshift_p'_is_int_pm, (rule assms)+)

lemma step_p'_min:
  assumes "overlap \<unlhd> p + rat k \<cdot> vect f"
  shows "step_p' f p \<le> k"
proof (simp add: step_p'_alt finite_step_p'_carrier ceiling_le_iff nat_le_iff, intro allI impI, elim exE)
  fix a x
  assume "a = (lookup overlap x - lookup p x) / lookup (vect f) x \<and>
              0 < lookup (vect f) x \<and> lookup p x < lookup overlap x"
  hence a_eq: "a = (lookup overlap x - lookup p x) / lookup (vect f) x"
    and "0 < lookup (vect f) x" and "lookup p x < lookup overlap x" by simp_all
  show "a \<le> rat k"
  proof (simp only: a_eq pos_divide_le_eq[OF \<open>0 < lookup (vect f) x\<close>])
    from assms have "lookup overlap x \<le> lookup p x + rat k * lookup (vect f) x"
      by (simp add: le_pm_def of_nat_pm.rep_eq plus_poly_mapping.rep_eq lookup_of_int_pm le_fun_def of_nat_fun_def)
    thus "lookup overlap x - lookup p x \<le> rat k * lookup (vect f) x" by simp
  qed
qed

lemma overlapshift_p'_is_above_overlap:
  assumes "overlap \<unlhd> p + rat k \<cdot> vect f"
  shows "overlap \<unlhd> overlapshift_p' f p"
proof -
  let ?ol = "lookup overlap"
  let ?os = "lookup (overlapshift_p' f p)"
  let ?vc = "lookup (vect f)"
  let ?p = "lookup p"
  show ?thesis
  proof (simp only: le_pm_def le_fun_def lookup_of_nat_pm of_nat_fun_def o_def, rule)
    fix x
    show "?ol x \<le> ?os x"
    proof (cases "0 < ?vc x \<and> ?p x < ?ol x")
      case True
      hence "0 < ?vc x" and "?p x < ?ol x" by simp_all
      have "(?ol x - ?p x) / ?vc x \<le> Max ({(?ol x - ?p x) / ?vc x | x. 0 < ?vc x \<and> ?p x < ?ol x} \<union> {0})"
        by (rule Max_ge, simp add: finite_step_p'_carrier, rule, rule, rule, rule conjI, rule refl, rule True)
      hence "\<lceil>(?ol x - ?p x) / ?vc x\<rceil> \<le> int (step_p' f p)" unfolding int_step_p' by (rule ceiling_mono)
      hence "(?ol x - ?p x) / ?vc x \<le> rat_of_int (int (step_p' f p))" by linarith
      hence "?ol x - ?p x \<le> rat_of_int (int (step_p' f p)) * ?vc x"
        by (simp only: pos_divide_le_eq[OF \<open>0 < ?vc x\<close>])
      thus ?thesis by (simp add: overlapshift_p'_def lookup_add lookup_of_int_pm)
    next
      case False
      hence disj: "?vc x \<le> 0 \<or> ?ol x \<le> ?p x" by auto
      show ?thesis
      proof (cases "?vc x \<le> 0")
        case True
        from assms have "step_p' f p \<le> k" by (rule step_p'_min)
        hence "rat (step_p' f p) \<le> rat k" by simp
        from this True have "rat k * ?vc x \<le> rat (step_p' f p) * ?vc x"
          by (rule mult_right_mono_neg)
        hence "?p x + rat k * ?vc x \<le> ?p x + rat (step_p' f p) * ?vc x" by linarith
        hence "lookup (p + rat k \<cdot> vect f) x \<le> lookup (p + rat (step_p' f p) \<cdot> vect f) x"
          by (simp add: lookup_add lookup_of_int_pm)
        moreover from assms have "?ol x \<le> lookup (p + rat k \<cdot> vect f) x"
          by (simp only: le_pm_def le_fun_def lookup_of_nat_pm)
        ultimately show ?thesis by (simp add: overlapshift_p'_def)
      next
        case False
        with disj have "0 < ?vc x" and *: "?ol x \<le> ?p x" by simp_all
        from this(1) have "0 \<le> rat (step_p' f p) * ?vc x" by simp
        hence "?p x \<le> ?p x + rat (step_p' f p) * ?vc x" by linarith
        hence "?p x \<le> lookup (p + rat (step_p' f p) \<cdot> vect f) x"
          by (simp add: lookup_add lookup_of_int_pm)
        with * show ?thesis by (simp add: overlapshift_p'_def)
      qed
    qed
  qed
qed

lemma step'_alt:
  "step' f p = Max ({nat \<lceil>(lookup overlap x - of_nat (lookup p x)) / lookup (vect f) x\<rceil> |
                      x::'x. 0 < lookup (vect f) x \<and> of_nat (lookup p x) < lookup overlap x} \<union> {0})"
  by (simp only: step'_def step_p'_def lookup_of_nat_pm)

lemma step_alt:
  "step p =
    (if (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> tpp f \<unlhd> p) then
      step' (SOME f. f \<in> {f1, f2} \<and> is_proper_binomial f \<and> tpp f \<unlhd> p) p
    else 0)"
  by (simp only: le_pm_def step_def step_p_def step'_def[symmetric] leq_of_nat_fun of_nat_pm.rep_eq)

lemma step_alt1:
  assumes "f \<in> {f1, f2}" and "is_proper_binomial f" and "tpp f \<unlhd> p"
  shows "step p = step' f p"
  unfolding step_def step'_def
  by (rule step_p_alt1, fact, fact, simp only: le_of_nat_pm, fact)

lemma step_alt2:
  assumes "\<not> (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> tpp f \<unlhd> p)"
  shows "step p = 0"
  unfolding step_def
  by (rule step_p_alt2, simp only: le_of_nat_pm, fact)

lemma overlapshift'_alt:
  "lookup (overlapshift' f p) = to_nat \<circ> (lookup (of_nat_pm p + rat (step' f p) \<cdot> vect f))"
  by (simp add: overlapshift'_def overlapshift_p'_def to_nat_pm.rep_eq plus_poly_mapping.rep_eq
      lookup_of_nat_pm to_nat_fun_def flip: step'_def)

lemma overlapshift_alt:
  "overlapshift p =
    (if (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> tpp f \<unlhd> p) then
      overlapshift' (SOME f. f \<in> {f1,f2} \<and> is_proper_binomial f \<and> tpp f \<unlhd> p) p
    else p)"
  by (simp only: overlapshift_def o_def overlapshift_p_def le_of_nat_pm if_distrib[of to_nat_pm]
      overlapshift'_def[symmetric] to_nat_pm_comp_of_nat_pm)

lemma overlapshift_alt1:
  assumes "f \<in> {f1, f2}" and "is_proper_binomial f" and "tpp f \<unlhd> p"
  shows "overlapshift p = overlapshift' f p"
proof -
  have "overlapshift_p (of_nat_pm p) = overlapshift_p' f (of_nat_pm p)"
    by (rule overlapshift_p_alt1, fact, fact, simp only: le_of_nat_pm, fact)
  thus ?thesis by (simp add: overlapshift_def overlapshift'_def)
qed

lemma overlapshift_alt2:
  assumes "\<not> (\<exists>f\<in>{f1,f2}. is_proper_binomial f \<and> tpp f \<unlhd> p)"
  shows "overlapshift p = p"
proof -
  have "overlapshift_p (of_nat_pm p) = of_nat_pm p"
    by (rule overlapshift_p_alt2, simp_all only: le_of_nat_pm, fact+)
  thus ?thesis by (simp add: overlapshift_def to_nat_fun_comp_of_nat_fun)
qed

lemma overlapshift_step_idI:
  assumes "step p = 0"
  shows "overlapshift p = p"
proof (cases "\<exists>f\<in>{f1, f2}. is_proper_binomial f \<and> tpp f \<unlhd> p")
  case True
  then obtain f where "f \<in> {f1, f2}" and "is_proper_binomial f" and "tpp f \<unlhd> p" by auto
  hence eq: "step p = step' f p" and "overlapshift p = overlapshift' f p"
    by (rule step_alt1, rule overlapshift_alt1)
  note this(2)
  also have "lookup \<dots> = to_nat \<circ> lookup (of_nat_pm p + rat (step' f p) \<cdot> vect f)"
    by (fact overlapshift'_alt)
  also have "\<dots> = to_nat \<circ> lookup ((of_nat_pm p)::_ \<Rightarrow>\<^sub>0 rat)" by (simp add: eq[symmetric] assms)
  finally show ?thesis by (simp add: to_nat_comp_of_nat_fun of_nat_pm.rep_eq)
next
  case False
  thus ?thesis by (rule overlapshift_alt2)
qed

lemma step'_min:
  assumes "associated f p q k" and "overlap \<unlhd> of_nat_pm p"
  shows "step' f q \<le> k"
  unfolding step'_def
proof (rule step_p'_min)
  from assms(1) have eq: "(of_nat_pm p = ((of_nat_pm q)::'x \<Rightarrow>\<^sub>0 rat) + rat k \<cdot> vect f)"
    by (simp only: associated_alt_rat)
  from assms(2) show "overlap \<unlhd> ((of_nat_pm q)::'x \<Rightarrow>\<^sub>0 rat) + rat k \<cdot> vect f" by (simp only: eq)
qed

lemma overlapshift'_is_above_overlap:
  assumes "associated f p q k" and "overlap \<unlhd> of_nat_pm p"
  shows "overlap \<unlhd> of_nat_pm (overlapshift' f q)"
proof -
  have "overlap \<unlhd> overlapshift_p' f (of_nat_pm q)"
  proof (rule overlapshift_p'_is_above_overlap)
    from assms(1) have eq: "(of_nat_pm p = ((of_nat_pm q)::'x \<Rightarrow>\<^sub>0 rat) + rat k \<cdot> vect f)"
      by (simp only: associated_alt_rat)
    from assms(2) show "overlap \<unlhd> ((of_nat_pm q)::'x \<Rightarrow>\<^sub>0 rat) + rat k \<cdot> vect f" by (simp only: eq)
  qed
  also have "\<dots> \<unlhd> of_nat_pm (overlapshift' f q)"
  proof (rule leD_to_int_pm)
    show "to_int_pm (overlapshift_p' f (of_nat_pm q)) \<unlhd> to_int_pm (of_nat_pm (overlapshift' f q))"
      by (simp add: overlapshift'_def le_pm_def le_fun_def lookup_to_int_pm lookup_of_nat_pm
          lookup_to_nat_pm to_nat_def)
  next
    show "is_int_pm (overlapshift_p' f (of_nat_pm q))"
      by (intro overlapshift_p'_is_int_pm nat_pm_is_int_pm of_nat_pm_is_nat_pm)
  next
    from of_nat_pm_is_nat_pm show "is_int_pm (of_nat_pm (overlapshift' f q))" by (rule nat_pm_is_int_pm)
  qed
  finally show ?thesis .
qed

context
  fixes f p q k
  assumes f_in: "f \<in> {f1, f2}"
    and f_pbinomial: "is_proper_binomial f"
    and tpp_adds: "tpp f adds q"
    and assoc: "associated f p q k"
    and overlap_le: "overlap \<unlhd> of_nat_pm p"
begin

lemma step_min: "step q \<le> k"
proof -
  from tpp_adds have "tpp f \<unlhd> q" by (simp only: adds_pm)
  from assoc overlap_le have "step' f q \<le> k" by (rule step'_min)
  thus ?thesis by (simp only: step_alt1[OF f_in f_pbinomial \<open>tpp f \<unlhd> q\<close>])
qed

lemma overlapshift_is_above_overlap: "overlap \<unlhd> of_nat_pm (overlapshift q)"
proof -
  from tpp_adds have "tpp f \<unlhd> q" by (simp only: adds_pm)
  from assoc overlap_le have "overlap \<unlhd> of_nat_pm (overlapshift' f q)"
    by (rule overlapshift'_is_above_overlap)
  thus ?thesis by (simp only: overlapshift_alt1[OF f_in f_pbinomial \<open>tpp f \<unlhd> q\<close>])
qed

lemma overlapshift_p_is_nat_pm: "is_nat_pm (overlapshift_p (of_nat_pm q))"
proof (rule int_pm_is_nat_pm, rule overlapshift_p_is_int_pm, rule nat_pm_is_int_pm,
        rule of_nat_pm_is_nat_pm)
  fix x
  note overlap_le
  also have "of_nat_pm p = of_nat_pm q + rat k \<cdot> vect f" using assoc
    by (simp add: associated_alt_rat)
  finally have "overlap \<unlhd> overlapshift_p' f (of_nat_pm q)"
    by (rule overlapshift_p'_is_above_overlap)
  hence "lookup overlap x \<le> lookup (overlapshift_p' f (of_nat_pm q)) x" by (rule le_pmD)
  have eq: "overlapshift_p (of_nat_pm q) = overlapshift_p' f (of_nat_pm q)"
    by (rule overlapshift_p_alt1, fact f_in, fact f_pbinomial,
        simp only: le_of_nat_pm adds_pm[symmetric], fact tpp_adds)
  from overlap_is_nat_pm have "lookup overlap x \<in> \<nat>" by (rule is_nat_pmD)
  hence "(0::rat) \<le> lookup overlap x" by (rule Nats_ge_0)
  also have "\<dots> \<le> lookup (overlapshift_p' f (of_nat_pm q)) x" by fact
  finally show "0 \<le> lookup (overlapshift_p (of_nat_pm q)) x" by (simp only: eq)
qed

lemma of_nat_pm_overlapshift: "of_nat_pm (overlapshift q) = overlapshift_p (of_nat_pm q)"
  using overlapshift_p_is_nat_pm by (simp only: overlapshift_def o_def of_nat_pm_comp_to_nat_pm)

lemma of_nat_pm_overlapshift': "of_nat_pm (overlapshift q) = of_nat_pm q + rat (step q) \<cdot> vect f"
  unfolding of_nat_pm_overlapshift step_def
  by (rule overlapshift_p_alt0, fact f_in, fact f_pbinomial,
      simp only: le_of_nat_pm adds_pm[symmetric], fact tpp_adds)

lemma associated_overlapshift: "associated f (overlapshift q) q (step q)"
  by (simp only: associated_alt_rat of_nat_pm_overlapshift')

end

end (* two_polys *)

locale two_binoms =
  two_polys ord ord_strict f1 f2
  for ord :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow> ('x::{countable,linorder} \<Rightarrow>\<^sub>0 nat) \<Rightarrow> bool" (infixl "\<preceq>" 50)
  and ord_strict (infixl "\<prec>" 50)
  and f1 f2 :: "('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::field" +
  assumes f1_pbinomial: "is_proper_binomial f1"
  and f2_pbinomial: "is_proper_binomial f2"

end (* theory *)


(*  Author:  Sébastien Gouëzel   sebastien.gouezel@univ-rennes1.fr
    License: BSD
*)

section \<open>The metric completion of a metric space\<close>

theory Metric_Completion
  imports Isometries
begin

text \<open>Any metric space can be completed, by adding the missing limits of Cauchy sequences.
Formally, there exists an isometric embedding of the space in a complete space, with dense image.
In this paragraph, we construct this metric completion. This is exactly the same construction
as the way in which real numbers are constructed from rational numbers.\<close>

subsection \<open>Definition of the metric completion\<close>

quotient_type (overloaded) 'a metric_completion =
  "nat \<Rightarrow> ('a::metric_space)" / partial: "\<lambda>u v. (Cauchy u) \<and> (Cauchy v) \<and> (\<lambda>n. dist (u n) (v n)) \<longlonglongrightarrow> 0"
unfolding part_equivp_def proof(auto intro!: ext)
  show "\<exists>x. Cauchy x"
    by (rule exI[of _ "\<lambda>_. undefined"]) (simp add: convergent_Cauchy convergent_const)
  fix x y z::"nat \<Rightarrow> 'a" assume H: "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0"
                                   "(\<lambda>n. dist (x n) (z n)) \<longlonglongrightarrow> 0"
  have *: "(\<lambda>n. dist (x n) (y n) + dist (x n) (z n)) \<longlonglongrightarrow> 0 + 0"
    by (rule tendsto_add) (auto simp add: H)
  show "(\<lambda>n. dist (y n) (z n)) \<longlonglongrightarrow> 0"
    apply (rule tendsto_sandwich[of "\<lambda>_. 0" _ _ "\<lambda>n. dist (x n) (y n) + dist (x n) (z n)"])
    using * by (auto simp add: dist_triangle3)
next
  fix x y z::"nat \<Rightarrow> 'a" assume H: "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0"
                                   "(\<lambda>n. dist (y n) (z n)) \<longlonglongrightarrow> 0"
  have *: "(\<lambda>n. dist (x n) (y n) + dist (y n) (z n)) \<longlonglongrightarrow> 0 + 0"
    by (rule tendsto_add) (auto simp add: H)
  show "(\<lambda>n. dist (x n) (z n)) \<longlonglongrightarrow> 0"
    apply (rule tendsto_sandwich[of "\<lambda>_. 0" _ _ "\<lambda>n. dist (x n) (y n) + dist (y n) (z n)"])
    using * by (auto simp add: dist_triangle)
next
  fix x y::"nat \<Rightarrow> 'a" assume H: "Cauchy x"
    "(\<lambda>v. Cauchy v \<and> (\<lambda>n. dist (x n) (v n)) \<longlonglongrightarrow> 0) = (\<lambda>v. Cauchy v \<and> (\<lambda>n. dist (y n) (v n)) \<longlonglongrightarrow> 0)"
  have "Cauchy x \<and> (\<lambda>n. dist (x n) (x n)) \<longlonglongrightarrow> 0" using H by auto
  then have "(\<lambda>n. dist (y n) (x n))\<longlonglongrightarrow> 0" using H by meson
  moreover have "dist (x n) (y n) = dist (y n) (x n)" for n using dist_commute by auto
  ultimately show "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0" by auto
qed

text \<open>We have to show that the metric completion is indeed a metric space, that
the original space embeds isometrically into it, and that it is complete. Before we prove these
statements, we start with two simple lemmas that will be needed later on.\<close>

lemma convergent_Cauchy_dist:
  fixes u v::"nat \<Rightarrow> ('a::metric_space)"
  assumes "Cauchy u" "Cauchy v"
  shows "convergent (\<lambda>n. dist (u n) (v n))"
proof (rule real_Cauchy_convergent, intro CauchyI)
  fix e::real assume "e > 0"
  obtain Nu where Nu: "\<forall>n \<ge> Nu. \<forall>m \<ge> Nu. dist (u n) (u m) < e/2" using assms(1)
    by (metis \<open>0 < e\<close> less_divide_eq_numeral1(1) metric_CauchyD mult_zero_left)
  obtain Nv where Nv: "\<forall>n \<ge> Nv. \<forall>m \<ge> Nv. dist (v n) (v m) < e/2" using assms(2)
    by (metis \<open>0 < e\<close> less_divide_eq_numeral1(1) metric_CauchyD mult_zero_left)
  define M where "M = max Nu Nv"
  {
    fix n m assume H: "n \<ge> M" "m \<ge> M"
    have *: "dist (u n) (u m) < e/2" "dist (v n) (v m) < e/2"
      using Nu Nv H unfolding M_def by auto
    have "dist (u m) (v m) - dist (u n) (v n) \<le> dist (u m) (u n) + dist (v n) (v m)"
      by (simp add: algebra_simps) (metis add_le_cancel_left dist_commute dist_triangle2 dist_triangle_le)
    also have "... < e/2 + e/2"
      using * by (simp add: dist_commute)
    finally have A: "dist (u m) (v m) - dist (u n) (v n) < e" by simp

    have "dist (u n) (v n) - dist (u m) (v m) \<le> dist (u m) (u n) + dist (v n) (v m)"
      by (simp add: algebra_simps) (metis add_le_cancel_left dist_commute dist_triangle2 dist_triangle_le)
    also have "... < e/2 + e/2"
      using * by (simp add: dist_commute)
    finally have "dist (u n) (v n) - dist (u m) (v m) < e" by simp
    then have "norm(dist (u m) (v m) - dist (u n) (v n)) < e" using A by auto
  }
  then show "\<exists>M. \<forall>m \<ge> M. \<forall>n \<ge> M. norm (dist (u m) (v m) - dist (u n) (v n)) < e"
    by auto
qed

lemma convergent_add_null:
  fixes u v::"nat \<Rightarrow> ('a::real_normed_vector)"
  assumes "convergent u"
          "(\<lambda>n. v n - u n) \<longlonglongrightarrow> 0"
  shows "convergent v" "lim v = lim u"
proof -
  have "(\<lambda>n. u n + (v n - u n)) \<longlonglongrightarrow> lim u + 0"
    apply (rule tendsto_add) using assms convergent_LIMSEQ_iff by auto
  then have *: "v \<longlonglongrightarrow> lim u" by auto
  show "convergent v" using * by (simp add: Lim_def convergentI)
  show "lim v = lim u" using * by (simp add: limI)
qed

text \<open>Let us now prove that the metric completion is a metric space: the distance between two
Cauchy sequences is the limit of the distances of points in the sequence. The convergence follows
from Lemma~\verb+convergent_Cauchy_dist+ above.\<close>

instantiation metric_completion :: (metric_space) metric_space
begin

lift_definition dist_metric_completion::"('a::metric_space) metric_completion \<Rightarrow> 'a metric_completion \<Rightarrow> real"
  is "\<lambda>x y. lim (\<lambda>n. dist (x n) (y n))"
proof -
  fix x y z t::"nat \<Rightarrow> 'a" assume H: "Cauchy x \<and> Cauchy y \<and> (\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> 0"
                                     "Cauchy z \<and> Cauchy t \<and> (\<lambda>n. dist (z n) (t n)) \<longlonglongrightarrow> 0"
  show "lim (\<lambda>n. dist (x n) (z n)) = lim (\<lambda>n. dist (y n) (t n))"
  proof (rule convergent_add_null(2))
    show "convergent (\<lambda>n. dist (y n) (t n))"
      apply (rule convergent_Cauchy_dist) using H by auto

    have a: "(\<lambda>n. - dist (t n) (z n) - dist (x n) (y n)) \<longlonglongrightarrow> -0 -0"
      apply (intro tendsto_intros) using H by (auto simp add: dist_commute)
    have b:"(\<lambda>n. dist (t n) (z n) + dist (x n) (y n)) \<longlonglongrightarrow> 0 + 0"
      apply (rule tendsto_add) using H by (auto simp add: dist_commute)
    have I: "dist (x n) (z n) \<le> dist (t n) (y n) + (dist (t n) (z n) + dist (x n) (y n))" for n
      using dist_triangle[of "x n" "z n" "y n"] dist_triangle[of "y n" "z n" "t n"]
      by (auto simp add: dist_commute add.commute)
    show "(\<lambda>n. dist (x n) (z n) - dist (y n) (t n)) \<longlonglongrightarrow> 0"
      apply (rule tendsto_sandwich[of "\<lambda>n. -(dist (x n) (y n) + dist (z n) (t n))" _ _ "\<lambda>n. dist (x n) (y n) + dist (z n) (t n)"])
      apply (auto intro!: always_eventually simp add: algebra_simps dist_commute I)
      apply (meson add_left_mono dist_triangle3 dist_triangle_le)
      using a b by auto
  qed
qed

lemma dist_metric_completion_limit:
  fixes x y::"'a metric_completion"
  shows "(\<lambda>n. dist (rep_metric_completion x n) (rep_metric_completion y n)) \<longlonglongrightarrow> dist x y"
proof -
  have C: "Cauchy (rep_metric_completion x)" "Cauchy (rep_metric_completion y)"
    using Quotient3_metric_completion Quotient3_rep_reflp by fastforce+
  show ?thesis
    unfolding dist_metric_completion_def using C apply auto
    using convergent_Cauchy_dist[OF C] convergent_LIMSEQ_iff by force
qed

lemma dist_metric_completion_limit':
  fixes x y::"nat \<Rightarrow> 'a"
  assumes "Cauchy x" "Cauchy y"
  shows "(\<lambda>n. dist (x n) (y n)) \<longlonglongrightarrow> dist (abs_metric_completion x) (abs_metric_completion y)"
apply (subst dist_metric_completion.abs_eq)
using assms convergent_Cauchy_dist[OF assms] by (auto simp add: convergent_LIMSEQ_iff)

text \<open>To define a metric space in the current library of Isabelle/HOL, one should also introduce
a uniformity structure and a topology, as follows (they are prescribed by the distance):\<close>

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

definition open_metric_completion :: "'a metric_completion set \<Rightarrow> bool"
  where "open_metric_completion U = (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"

instance proof
  fix x y::"'a metric_completion"
  have C: "Cauchy (rep_metric_completion x)" "Cauchy (rep_metric_completion y)"
    using Quotient3_metric_completion Quotient3_rep_reflp by fastforce+
  show "(dist x y = 0) = (x = y)"
    apply (subst Quotient3_rel_rep[OF Quotient3_metric_completion, symmetric])
    unfolding dist_metric_completion_def using C apply auto
    using convergent_Cauchy_dist[OF C] convergent_LIMSEQ_iff apply force
    by (simp add: limI)
next
  fix x y z::"'a metric_completion"
  have a: "(\<lambda>n. dist (rep_metric_completion x n) (rep_metric_completion y n)) \<longlonglongrightarrow> dist x y"
    using dist_metric_completion_limit by auto
  have b: "(\<lambda>n. dist (rep_metric_completion x n) (rep_metric_completion z n) + dist (rep_metric_completion y n) (rep_metric_completion z n))
      \<longlonglongrightarrow> dist x z + dist y z"
    apply (rule tendsto_add) using dist_metric_completion_limit by auto
  show "dist x y \<le> dist x z + dist y z"
    by (rule LIMSEQ_le[OF a b], rule exI[of _ 0], auto simp add: dist_triangle2)
qed (auto simp add: uniformity_metric_completion_def open_metric_completion_def)
end

text \<open>Let us now show that the distance thus defined on the metric completion is indeed complete.
This is essentially by design.\<close>

instance metric_completion :: (metric_space) complete_space
proof
  fix X::"nat \<Rightarrow> 'a metric_completion" assume "Cauchy X"
  have *: "\<exists>N. \<forall>n \<ge> N. dist (rep_metric_completion (X k) N) (rep_metric_completion (X k) n) < (1/Suc k)" for k
  proof -
    have "Cauchy (rep_metric_completion (X k))"
      using Quotient3_metric_completion Quotient3_rep_reflp by fastforce+
    then have "\<exists>N. \<forall>m \<ge> N. \<forall>n \<ge> N. dist (rep_metric_completion (X k) m) (rep_metric_completion (X k) n) < (1/Suc k)"
      unfolding Cauchy_def by auto
    then show ?thesis by auto
  qed
  have "\<exists>N. \<forall>k. \<forall>n \<ge> N k. dist (rep_metric_completion (X k) (N k)) (rep_metric_completion (X k) n) < (1/Suc k)"
    apply (rule choice) using * by auto
  then obtain N::"nat \<Rightarrow> nat" where
    N: "dist (rep_metric_completion (X k) (N k)) (rep_metric_completion (X k) n) < (1/Suc k)" if "n \<ge> N k" for n k
    by auto
  define u where "u = (\<lambda>k. rep_metric_completion (X k) (N k))"

  have "Cauchy u"
  proof (rule metric_CauchyI)
    fix e::real assume "e > 0"
    obtain K::nat where "K > 4/e" using reals_Archimedean2 by blast
    obtain L::nat where L: "\<forall>m \<ge> L. \<forall>n \<ge> L. dist (X m) (X n) < e/2"
      using metric_CauchyD[OF \<open>Cauchy X\<close>, of "e/2"] \<open>e > 0\<close> by auto
    {
      fix m n assume "m \<ge> max K L" "n \<ge> max K L"
      then have "dist (X m) (X n) < e/2" using L by auto
      then have "eventually (\<lambda>p. dist (rep_metric_completion (X m) p) (rep_metric_completion (X n) p) < e/2) sequentially"
        using dist_metric_completion_limit[of "X m" "X n"] by (metis order_tendsto_iff)
      then obtain p where p: "p \<ge> max (N m) (N n)" "dist (rep_metric_completion (X m) p) (rep_metric_completion (X n) p) < e/2"
        using eventually_False_sequentially eventually_elim2 eventually_ge_at_top by blast
      have "dist (u m) (rep_metric_completion (X m) p) < 1 / real (Suc m)"
        unfolding u_def using N[of m p] p(1) by auto
      also have "... < e/4"
        using \<open>m \<ge> max K L\<close> \<open>K > 4/e\<close> \<open>e > 0\<close> apply (auto simp add: divide_simps algebra_simps)
        by (metis leD le_less_trans less_add_same_cancel2 linear of_nat_le_iff real_mult_le_cancel_iff2)
      finally have Im: "dist (u m) (rep_metric_completion (X m) p) < e/4" by simp
      have "dist (u n) (rep_metric_completion (X n) p) < 1 / real (Suc n)"
        unfolding u_def using N[of n p] p(1) by auto
      also have "... < e/4"
        using \<open>n \<ge> max K L\<close> \<open>K > 4/e\<close> \<open>e > 0\<close> apply (auto simp add: divide_simps algebra_simps)
        by (metis leD le_less_trans less_add_same_cancel2 linear of_nat_le_iff real_mult_le_cancel_iff2)
      finally have In: "dist (u n) (rep_metric_completion (X n) p) < e/4" by simp

      have "dist (u m) (u n) \<le> dist (u m) (rep_metric_completion (X m) p)
          + dist (rep_metric_completion (X m) p) (rep_metric_completion (X n) p) + dist (rep_metric_completion (X n) p) (u n)"
        by (metis add.commute add_left_mono dist_commute dist_triangle_le dist_triangle)
      also have "... < e/4 + e/2 + e/4"
        using In Im p(2) by (simp add: dist_commute)
      also have "... = e" by auto
      finally have "dist (u m) (u n) < e" by auto
    }
    then show "\<exists>M. \<forall>m \<ge> M. \<forall>n \<ge> M. dist (u m) (u n) < e" by meson
  qed
  have *: "(\<lambda>n. dist (abs_metric_completion u) (X n)) \<longlonglongrightarrow> 0"
  proof (rule order_tendstoI, auto simp add: less_le_trans eventually_sequentially)
    fix e::real assume "e > 0"
    obtain K::nat where "K > 4/e" using reals_Archimedean2 by blast
    obtain L::nat where L: "\<forall>m \<ge> L. \<forall>n \<ge> L. dist (u m) (u n) < e/4"
      using metric_CauchyD[OF \<open>Cauchy u\<close>, of "e/4"] \<open>e > 0\<close> by auto
    {
      fix n assume n: "n \<ge> max K L"
      {
        fix p assume p: "p \<ge> max (N n) L"
        have "dist (u n) (rep_metric_completion (X n) p) < 1/(Suc n)"
          unfolding u_def using N p by simp
        also have "... < e/4"
          using \<open>n \<ge> max K L\<close> \<open>K > 4/e\<close> \<open>e > 0\<close> apply (auto simp add: divide_simps algebra_simps)
          by (metis leD le_less_trans less_add_same_cancel2 linear of_nat_le_iff real_mult_le_cancel_iff2)
        finally have *: "dist (u n) (rep_metric_completion (X n) p) < e/4"
          by fastforce

        have "dist (u p) (rep_metric_completion (X n) p) \<le> dist (u p) (u n) + dist (u n) (rep_metric_completion (X n) p)"
          using dist_triangle by auto
        also have "... < e/4 + e/4" using * L n p by force
        finally have "dist (u p) (rep_metric_completion (X n) p) \<le> e/2" by auto
      }
      then have A: "eventually (\<lambda>p. dist (u p) (rep_metric_completion (X n) p) \<le> e/2) sequentially"
        using eventually_at_top_linorder by blast
      have B: "(\<lambda>p. dist (u p) (rep_metric_completion (X n) p)) \<longlonglongrightarrow> dist (abs_metric_completion u) (X n)"
        using dist_metric_completion_limit'[OF \<open>Cauchy u\<close>, of "rep_metric_completion (X n)"]
        unfolding Quotient3_abs_rep[OF Quotient3_metric_completion, of "X n"]
        using Quotient3_rep_reflp[OF Quotient3_metric_completion] by auto
      have "dist (abs_metric_completion u) (X n) \<le> e/2"
        apply (rule LIMSEQ_le_const2[OF B]) using A unfolding eventually_sequentially by auto
      then have "dist (abs_metric_completion u) (X n) < e" using \<open>e > 0\<close> by auto
    }
    then show "\<exists>N. \<forall>n \<ge> N. dist (abs_metric_completion u) (X n) < e"
      by blast
  qed
  have "X \<longlonglongrightarrow> abs_metric_completion u"
    apply (rule tendstoI) using * by (auto simp add: order_tendsto_iff dist_commute)
  then show "convergent X" unfolding convergent_def by auto
qed

subsection \<open>Isometric embedding of a space in its metric completion\<close>

text \<open>The canonical embedding of a space into its metric completion is obtained by taking
the Cauchy sequence which is constant, equal to the given point. This is indeed an isometric
embedding with dense image, as we prove in the lemmas below.\<close>

definition to_metric_completion::"('a::metric_space) \<Rightarrow> 'a metric_completion"
  where "to_metric_completion x = abs_metric_completion (\<lambda>n. x)"

lemma to_metric_completion_dense:
  assumes "open U" "U \<noteq> {}"
  shows "\<exists>x. to_metric_completion x \<in> U"
proof -
  obtain y where "y \<in> U" using \<open>U \<noteq> {}\<close> by auto
  obtain e::real where e: "e > 0" "\<And>z. dist z y < e \<Longrightarrow> z \<in> U"
    using \<open>y \<in> U\<close> \<open>open U\<close> by (metis open_dist)
  have *: "Cauchy (rep_metric_completion y)"
    using Quotient3_metric_completion Quotient3_rep_reflp by fastforce
  then obtain N where N: "\<forall>n \<ge> N. \<forall>m \<ge> N. dist (rep_metric_completion y n) (rep_metric_completion y m) < e/2"
    using \<open>e > 0\<close> unfolding Cauchy_def by (meson divide_pos_pos zero_less_numeral)
  define x where "x = rep_metric_completion y N"
  have "(\<lambda>n. dist x (rep_metric_completion y n)) \<longlonglongrightarrow> dist (to_metric_completion x) (abs_metric_completion (rep_metric_completion y))"
    unfolding to_metric_completion_def apply (rule dist_metric_completion_limit')
    using * unfolding Cauchy_def by auto
  then have "(\<lambda>n. dist x (rep_metric_completion y n)) \<longlonglongrightarrow> dist (to_metric_completion x) y"
    unfolding Quotient3_abs_rep[OF Quotient3_metric_completion] by simp
  moreover have "eventually (\<lambda>n. dist x (rep_metric_completion y n) \<le> e/2) sequentially"
    unfolding eventually_sequentially x_def apply (rule exI[of _ N]) using N less_imp_le by auto
  ultimately have "dist (to_metric_completion x) y \<le> e/2"
    using LIMSEQ_le_const2 unfolding eventually_sequentially by metis
  then have "to_metric_completion x \<in> U"
    using e by auto
  then show ?thesis by auto
qed

lemma to_metric_completion_dense':
  "closure (range to_metric_completion) = UNIV"
apply (auto simp add: closure_iff_nhds_not_empty) using to_metric_completion_dense by fastforce

text \<open>The main feature of the completion is that a uniformly continuous function on the original space can be extended
to a uniformly continuous function on the completion, i.e., it can be written as the composition of
a new function and of the inclusion \verb+to_metric_completion+.\<close>

lemma lift_to_metric_completion:
  fixes f::"('a::metric_space) \<Rightarrow> ('b::complete_space)"
  assumes "uniformly_continuous_on UNIV f"
  shows "\<exists>g. (uniformly_continuous_on UNIV g)
            \<and> (f = g o to_metric_completion)
            \<and> (\<forall>x \<in> range to_metric_completion. g x = f (inv to_metric_completion x))"
proof -
  define I::"'a metric_completion \<Rightarrow> 'a" where "I = inv to_metric_completion"
  have "uniformly_continuous_on (range to_metric_completion) I"
    using isometry_on_uniformly_continuous[OF isometry_on_inverse(1)[OF to_metric_completion_isometry]] I_def
    by auto
  then have UC: "uniformly_continuous_on (range to_metric_completion) (\<lambda>x. f (I x))"
    using assms uniformly_continuous_on_compose
    by (metis I_def bij_betw_imp_surj_on bij_betw_inv_into isometry_on_inverse(4) to_metric_completion_isometry)
  obtain g where g: "uniformly_continuous_on (closure(range to_metric_completion)) g"
                    "\<And>x. x \<in> range to_metric_completion \<Longrightarrow> f (I x) = g x"
    using uniformly_continuous_on_extension_on_closure[OF UC] by metis
  have "uniformly_continuous_on UNIV g"
    using to_metric_completion_dense' g(1) by metis
  moreover have "f x = g (to_metric_completion x)" for x
    using g(2) by (metis I_def UNIV_I isometry_on_inverse(2) range_eqI to_metric_completion_isometry)
  moreover have "g x = f (inv to_metric_completion x)" if "x \<in> range to_metric_completion" for x
    using I_def g(2) that by auto
  ultimately show ?thesis unfolding comp_def by auto
qed

text \<open>When the function is an isometry, the lifted function is also an isometry (and its range is
the closure of the range of the original function).
This shows that the metric completion is unique, up to isometry:\<close>

lemma lift_to_metric_completion_isometry:
  fixes f::"('a::metric_space) \<Rightarrow> ('b::complete_space)"
  assumes "isometry_on UNIV f"
  shows "\<exists>g. isometry_on UNIV g
          \<and> range g = closure(range f)
          \<and> f = g o to_metric_completion
          \<and> (\<forall>x \<in> range to_metric_completion. g x = f (inv to_metric_completion x))"
proof -
  have *: "uniformly_continuous_on UNIV f" using assms isometry_on_uniformly_continuous by force
  obtain g where g: "uniformly_continuous_on UNIV g"
                    "f = g o to_metric_completion"
                    "\<And>x. x \<in> range to_metric_completion \<Longrightarrow> g x = f (inv to_metric_completion x)"
    using lift_to_metric_completion[OF *] by blast
  have *: "isometry_on (range to_metric_completion) g"
    apply (rule isometry_on_cong[OF _ g(3)], rule isometry_on_compose[of _ _ f])
    using assms isometry_on_inverse[OF to_metric_completion_isometry] isometry_on_subset by (auto) (fastforce)
  then have "isometry_on UNIV g"
    unfolding to_metric_completion_dense'[symmetric] apply (rule isometry_on_closure)
    using continuous_on_subset[OF uniformly_continuous_imp_continuous[OF g(1)]] by auto

  have "g`(range to_metric_completion) \<subseteq> range f"
    using g unfolding comp_def by auto
  moreover have "g`(closure (range to_metric_completion)) \<subseteq> closure (g`(range to_metric_completion))"
    using uniformly_continuous_imp_continuous[OF g(1)]
    by (meson closed_closure closure_subset continuous_on_subset image_closure_subset top_greatest)
  ultimately have "range g \<subseteq> closure (range f)"
    unfolding to_metric_completion_dense' by (simp add: g(2) image_comp)

  have "range f \<subseteq> range g"
    using g(2) by auto
  moreover have "closed (range g)"
    using isometry_on_complete_image[OF \<open>isometry_on UNIV g\<close>] by (simp add: complete_eq_closed)
  ultimately have "closure (range f) \<subseteq> range g"
    by (simp add: closure_minimal)
  then have "range g = closure (range f)"
    using \<open>range g \<subseteq> closure (range f)\<close> by auto
  then show ?thesis using \<open>isometry_on UNIV g\<close> g by metis
qed

subsection \<open>The metric completion of a second countable space is second countable\<close>

text \<open>We want to show that the metric completion of a second countable space is still
second countable. This is most easily expressed using the fact that a metric
space is second countable if and only if there exists a dense countable subset. We prove
the equivalence in the next lemma, and use it then to prove that the metric completion is
still second countable.\<close>

lemma second_countable_iff_dense_countable_subset:
  "(\<exists>B::'a::metric_space set set. countable B \<and> topological_basis B)
    \<longleftrightarrow> (\<exists>A::'a set. countable A \<and> closure A = UNIV)"
proof
  assume "\<exists>B::'a set set. countable B \<and> topological_basis B"
  then obtain B::"'a set set" where "countable B" "topological_basis B" by auto
  define A where "A = (\<lambda>U. SOME x. x \<in> U)`B"
  have "countable A" unfolding A_def using \<open>countable B\<close> by auto
  moreover have "closure A = UNIV"
  proof (auto simp add: closure_approachable)
    fix x::'a and e::real assume "e > 0"
    obtain U where "U \<in> B" "x \<in> U" "U \<subseteq> ball x e"
      by (rule topological_basisE[OF \<open>topological_basis B\<close>, of "ball x e" x], auto simp add: \<open>e > 0\<close>)
    define y where "y = (\<lambda>U. SOME x. x \<in> U) U"
    have "y \<in> U" unfolding y_def using \<open>x \<in> U\<close> some_in_eq by fastforce
    then have "dist y x < e"
      using \<open>U \<subseteq> ball x e\<close> by (metis dist_commute mem_ball subset_iff)
    moreover have "y \<in> A" unfolding A_def y_def using \<open>U \<in> B\<close> by auto
    ultimately show "\<exists>y\<in>A. dist y x < e" by auto
  qed
  ultimately show "\<exists>A::'a set. countable A \<and> closure A = UNIV" by auto
next
  assume "\<exists>A::'a set. countable A \<and> closure A = UNIV"
  then obtain A::"'a set" where "countable A" "closure A = UNIV" by auto
  define B where "B = (\<lambda>(x, (n::nat)). ball x (1/n))`(A \<times> UNIV)"
  have "countable B" unfolding B_def using \<open>countable A\<close> by auto
  moreover have "topological_basis B"
  proof (rule topological_basisI)
    fix x::'a and U assume "x \<in> U" "open U"
    then obtain e where "e > 0" "ball x e \<subseteq> U"
      using openE by blast
    obtain n::nat where "n > 2/e" using reals_Archimedean2 by auto
    then have "n > 0" using \<open>e > 0\<close> not_less by fastforce
    then have "1/n > 0" using zero_less_divide_iff by fastforce
    then obtain y where y: "y \<in> A" "dist x y < 1/n"
      by (metis \<open>closure A = UNIV\<close> UNIV_I closure_approachable dist_commute)
    then have "ball y (1/n) \<in> B" unfolding B_def by auto
    moreover have "x \<in> ball y (1/n)" using y(2) by (auto simp add: dist_commute)
    moreover have "ball y (1/n) \<subseteq> U"
    proof (auto)
      fix z assume z: "dist y z < 1/n"
      have "dist z x \<le> dist z y + dist y x" using dist_triangle by auto
      also have "... < 1/n + 1/n" using z y(2) by (auto simp add: dist_commute)
      also have "... < e"
        using \<open>n > 2/e\<close> \<open>e > 0\<close> \<open>n > 0\<close> by (auto simp add: divide_simps mult.commute)
      finally have "z \<in> ball x e" by (auto simp add: dist_commute)
      then show "z \<in> U" using \<open>ball x e \<subseteq> U\<close> by auto
    qed
    ultimately show "\<exists>V\<in>B. x \<in> V \<and> V \<subseteq> U" by metis
  qed (auto simp add: B_def)
  ultimately show "\<exists>B::'a set set. countable B \<and> topological_basis B" by auto
qed

lemma second_countable_metric_dense_subset:
  "\<exists>A::'a::{metric_space, second_countable_topology} set. countable A \<and> closure A = UNIV"
using ex_countable_basis by (auto simp add: second_countable_iff_dense_countable_subset[symmetric])

instance metric_completion::("{metric_space, second_countable_topology}") second_countable_topology
proof
  obtain A::"'a set" where "countable A" "closure A = UNIV"
    using second_countable_metric_dense_subset by auto
  define Ab where "Ab = to_metric_completion`A"
  have "range to_metric_completion \<subseteq> closure Ab"
    unfolding Ab_def
    by (metis \<open>closure A = UNIV\<close> isometry_on_continuous[OF to_metric_completion_isometry] closed_closure closure_subset image_closure_subset)
  then have "closure Ab = UNIV"
    by (metis (no_types) to_metric_completion_dense'[symmetric] \<open>range to_metric_completion \<subseteq> closure Ab\<close> closure_closure closure_mono top.extremum_uniqueI)
  moreover have "countable Ab" unfolding Ab_def using \<open>countable A\<close> by auto
  ultimately have "\<exists>Ab::'a metric_completion set. countable Ab \<and> closure Ab = UNIV"
    by auto
  then show "\<exists>B::'a metric_completion set set. countable B \<and> open = generate_topology B"
    using second_countable_iff_dense_countable_subset topological_basis_imp_subbasis by auto
qed

instance metric_completion::("{metric_space, second_countable_topology}") polish_space
by standard

end (*of theory Metric_Completion*)


(*  Title:      HOL/SMT_Examples/SMT_Examples.thy
    Author:     Sascha Boehme, TU Muenchen
*)

section \<open>Examples for the SMT binding\<close>

theory SMT_Examples
imports Complex_Main
begin

external_file \<open>SMT_Examples.certs\<close>
declare [[smt_certificates = "SMT_Examples.certs"]]
declare [[smt_read_only_certificates = true]]

section \<open>Propositional and first-order logic\<close>

lemma "True" by smt
lemma "p \<or> \<not>p" by smt
lemma "(p \<and> True) = p" by smt
lemma "(p \<or> q) \<and> \<not>p \<Longrightarrow> q" by smt
lemma "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)" by smt
lemma "(p1 \<and> p2) \<or> p3 \<longrightarrow> (p1 \<longrightarrow> (p3 \<and> p2) \<or> (p1 \<and> p3)) \<or> p1" by smt
lemma "P = P = P = P = P = P = P = P = P = P" by smt

lemma
  assumes "a \<or> b \<or> c \<or> d"
      and "e \<or> f \<or> (a \<and> d)"
      and "\<not> (a \<or> (c \<and> ~c)) \<or> b"
      and "\<not> (b \<and> (x \<or> \<not> x)) \<or> c"
      and "\<not> (d \<or> False) \<or> c"
      and "\<not> (c \<or> (\<not> p \<and> (p \<or> (q \<and> \<not> q))))"
  shows False
  using assms by smt

axiomatization symm_f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  symm_f: "symm_f x y = symm_f y x"

lemma "a = a \<and> symm_f a b = symm_f b a"
  by (smt symm_f)

(*
Taken from ~~/src/HOL/ex/SAT_Examples.thy.
Translated from TPTP problem library: PUZ015-2.006.dimacs
*)
lemma
  assumes "~x0"
  and "~x30"
  and "~x29"
  and "~x59"
  and "x1 \<or> x31 \<or> x0"
  and "x2 \<or> x32 \<or> x1"
  and "x3 \<or> x33 \<or> x2"
  and "x4 \<or> x34 \<or> x3"
  and "x35 \<or> x4"
  and "x5 \<or> x36 \<or> x30"
  and "x6 \<or> x37 \<or> x5 \<or> x31"
  and "x7 \<or> x38 \<or> x6 \<or> x32"
  and "x8 \<or> x39 \<or> x7 \<or> x33"
  and "x9 \<or> x40 \<or> x8 \<or> x34"
  and "x41 \<or> x9 \<or> x35"
  and "x10 \<or> x42 \<or> x36"
  and "x11 \<or> x43 \<or> x10 \<or> x37"
  and "x12 \<or> x44 \<or> x11 \<or> x38"
  and "x13 \<or> x45 \<or> x12 \<or> x39"
  and "x14 \<or> x46 \<or> x13 \<or> x40"
  and "x47 \<or> x14 \<or> x41"
  and "x15 \<or> x48 \<or> x42"
  and "x16 \<or> x49 \<or> x15 \<or> x43"
  and "x17 \<or> x50 \<or> x16 \<or> x44"
  and "x18 \<or> x51 \<or> x17 \<or> x45"
  and "x19 \<or> x52 \<or> x18 \<or> x46"
  and "x53 \<or> x19 \<or> x47"
  and "x20 \<or> x54 \<or> x48"
  and "x21 \<or> x55 \<or> x20 \<or> x49"
  and "x22 \<or> x56 \<or> x21 \<or> x50"
  and "x23 \<or> x57 \<or> x22 \<or> x51"
  and "x24 \<or> x58 \<or> x23 \<or> x52"
  and "x59 \<or> x24 \<or> x53"
  and "x25 \<or> x54"
  and "x26 \<or> x25 \<or> x55"
  and "x27 \<or> x26 \<or> x56"
  and "x28 \<or> x27 \<or> x57"
  and "x29 \<or> x28 \<or> x58"
  and "~x1 \<or> ~x31"
  and "~x1 \<or> ~x0"
  and "~x31 \<or> ~x0"
  and "~x2 \<or> ~x32"
  and "~x2 \<or> ~x1"
  and "~x32 \<or> ~x1"
  and "~x3 \<or> ~x33"
  and "~x3 \<or> ~x2"
  and "~x33 \<or> ~x2"
  and "~x4 \<or> ~x34"
  and "~x4 \<or> ~x3"
  and "~x34 \<or> ~x3"
  and "~x35 \<or> ~x4"
  and "~x5 \<or> ~x36"
  and "~x5 \<or> ~x30"
  and "~x36 \<or> ~x30"
  and "~x6 \<or> ~x37"
  and "~x6 \<or> ~x5"
  and "~x6 \<or> ~x31"
  and "~x37 \<or> ~x5"
  and "~x37 \<or> ~x31"
  and "~x5 \<or> ~x31"
  and "~x7 \<or> ~x38"
  and "~x7 \<or> ~x6"
  and "~x7 \<or> ~x32"
  and "~x38 \<or> ~x6"
  and "~x38 \<or> ~x32"
  and "~x6 \<or> ~x32"
  and "~x8 \<or> ~x39"
  and "~x8 \<or> ~x7"
  and "~x8 \<or> ~x33"
  and "~x39 \<or> ~x7"
  and "~x39 \<or> ~x33"
  and "~x7 \<or> ~x33"
  and "~x9 \<or> ~x40"
  and "~x9 \<or> ~x8"
  and "~x9 \<or> ~x34"
  and "~x40 \<or> ~x8"
  and "~x40 \<or> ~x34"
  and "~x8 \<or> ~x34"
  and "~x41 \<or> ~x9"
  and "~x41 \<or> ~x35"
  and "~x9 \<or> ~x35"
  and "~x10 \<or> ~x42"
  and "~x10 \<or> ~x36"
  and "~x42 \<or> ~x36"
  and "~x11 \<or> ~x43"
  and "~x11 \<or> ~x10"
  and "~x11 \<or> ~x37"
  and "~x43 \<or> ~x10"
  and "~x43 \<or> ~x37"
  and "~x10 \<or> ~x37"
  and "~x12 \<or> ~x44"
  and "~x12 \<or> ~x11"
  and "~x12 \<or> ~x38"
  and "~x44 \<or> ~x11"
  and "~x44 \<or> ~x38"
  and "~x11 \<or> ~x38"
  and "~x13 \<or> ~x45"
  and "~x13 \<or> ~x12"
  and "~x13 \<or> ~x39"
  and "~x45 \<or> ~x12"
  and "~x45 \<or> ~x39"
  and "~x12 \<or> ~x39"
  and "~x14 \<or> ~x46"
  and "~x14 \<or> ~x13"
  and "~x14 \<or> ~x40"
  and "~x46 \<or> ~x13"
  and "~x46 \<or> ~x40"
  and "~x13 \<or> ~x40"
  and "~x47 \<or> ~x14"
  and "~x47 \<or> ~x41"
  and "~x14 \<or> ~x41"
  and "~x15 \<or> ~x48"
  and "~x15 \<or> ~x42"
  and "~x48 \<or> ~x42"
  and "~x16 \<or> ~x49"
  and "~x16 \<or> ~x15"
  and "~x16 \<or> ~x43"
  and "~x49 \<or> ~x15"
  and "~x49 \<or> ~x43"
  and "~x15 \<or> ~x43"
  and "~x17 \<or> ~x50"
  and "~x17 \<or> ~x16"
  and "~x17 \<or> ~x44"
  and "~x50 \<or> ~x16"
  and "~x50 \<or> ~x44"
  and "~x16 \<or> ~x44"
  and "~x18 \<or> ~x51"
  and "~x18 \<or> ~x17"
  and "~x18 \<or> ~x45"
  and "~x51 \<or> ~x17"
  and "~x51 \<or> ~x45"
  and "~x17 \<or> ~x45"
  and "~x19 \<or> ~x52"
  and "~x19 \<or> ~x18"
  and "~x19 \<or> ~x46"
  and "~x52 \<or> ~x18"
  and "~x52 \<or> ~x46"
  and "~x18 \<or> ~x46"
  and "~x53 \<or> ~x19"
  and "~x53 \<or> ~x47"
  and "~x19 \<or> ~x47"
  and "~x20 \<or> ~x54"
  and "~x20 \<or> ~x48"
  and "~x54 \<or> ~x48"
  and "~x21 \<or> ~x55"
  and "~x21 \<or> ~x20"
  and "~x21 \<or> ~x49"
  and "~x55 \<or> ~x20"
  and "~x55 \<or> ~x49"
  and "~x20 \<or> ~x49"
  and "~x22 \<or> ~x56"
  and "~x22 \<or> ~x21"
  and "~x22 \<or> ~x50"
  and "~x56 \<or> ~x21"
  and "~x56 \<or> ~x50"
  and "~x21 \<or> ~x50"
  and "~x23 \<or> ~x57"
  and "~x23 \<or> ~x22"
  and "~x23 \<or> ~x51"
  and "~x57 \<or> ~x22"
  and "~x57 \<or> ~x51"
  and "~x22 \<or> ~x51"
  and "~x24 \<or> ~x58"
  and "~x24 \<or> ~x23"
  and "~x24 \<or> ~x52"
  and "~x58 \<or> ~x23"
  and "~x58 \<or> ~x52"
  and "~x23 \<or> ~x52"
  and "~x59 \<or> ~x24"
  and "~x59 \<or> ~x53"
  and "~x24 \<or> ~x53"
  and "~x25 \<or> ~x54"
  and "~x26 \<or> ~x25"
  and "~x26 \<or> ~x55"
  and "~x25 \<or> ~x55"
  and "~x27 \<or> ~x26"
  and "~x27 \<or> ~x56"
  and "~x26 \<or> ~x56"
  and "~x28 \<or> ~x27"
  and "~x28 \<or> ~x57"
  and "~x27 \<or> ~x57"
  and "~x29 \<or> ~x28"
  and "~x29 \<or> ~x58"
  and "~x28 \<or> ~x58"
  shows False
  using assms by smt

lemma "\<forall>x::int. P x \<longrightarrow> (\<forall>y::int. P x \<or> P y)"
  by smt

lemma
  assumes "(\<forall>x y. P x y = x)"
  shows "(\<exists>y. P x y) = P x c"
  using assms by smt

lemma
  assumes "(\<forall>x y. P x y = x)"
  and "(\<forall>x. \<exists>y. P x y) = (\<forall>x. P x c)"
  shows "(\<exists>y. P x y) = P x c"
  using assms by smt

lemma
  assumes "if P x then \<not>(\<exists>y. P y) else (\<forall>y. \<not>P y)"
  shows "P x \<longrightarrow> P y"
  using assms by smt

section \<open>Arithmetic\<close>

subsection \<open>Linear arithmetic over integers and reals\<close>

lemma "(3::int) = 3" by smt
lemma "(3::real) = 3" by smt
lemma "(3 :: int) + 1 = 4" by smt
lemma "x + (y + z) = y + (z + (x::int))" by smt
lemma "max (3::int) 8 > 5" by smt
lemma "\<bar>x :: real\<bar> + \<bar>y\<bar> \<ge> \<bar>x + y\<bar>" by smt
lemma "P ((2::int) < 3) = P True" by smt
lemma "x + 3 \<ge> 4 \<or> x < (1::int)" by smt

lemma
  assumes "x \<ge> (3::int)" and "y = x + 4"
  shows "y - x > 0"
  using assms by smt

lemma "let x = (2 :: int) in x + x \<noteq> 5" by smt

lemma
  fixes x :: real
  assumes "3 * x + 7 * a < 4" and "3 < 2 * x"
  shows "a < 0"
  using assms by smt

lemma "(0 \<le> y + -1 * x \<or> \<not> 0 \<le> x \<or> 0 \<le> (x::int)) = (\<not> False)" by smt

lemma "
  (n < m \<and> m < n') \<or> (n < m \<and> m = n') \<or> (n < n' \<and> n' < m) \<or>
  (n = n' \<and> n' < m) \<or> (n = m \<and> m < n') \<or>
  (n' < m \<and> m < n) \<or> (n' < m \<and> m = n) \<or>
  (n' < n \<and> n < m) \<or> (n' = n \<and> n < m) \<or> (n' = m \<and> m < n) \<or>
  (m < n \<and> n < n') \<or> (m < n \<and> n' = n) \<or> (m < n' \<and> n' < n) \<or>
  (m = n \<and> n < n') \<or> (m = n' \<and> n' < n) \<or>
  (n' = m \<and> m = (n::int))"
  by smt

text\<open>
The following example was taken from HOL/ex/PresburgerEx.thy, where it says:

  This following theorem proves that all solutions to the
  recurrence relation $x_{i+2} = |x_{i+1}| - x_i$ are periodic with
  period 9.  The example was brought to our attention by John
  Harrison. It does does not require Presburger arithmetic but merely
  quantifier-free linear arithmetic and holds for the rationals as well.

  Warning: it takes (in 2006) over 4.2 minutes!

There, it is proved by "arith". SMT is able to prove this within a fraction
of one second. With proof reconstruction, it takes about 13 seconds on a Core2
processor.
\<close>

lemma "\<lbrakk> x3 = \<bar>x2\<bar> - x1; x4 = \<bar>x3\<bar> - x2; x5 = \<bar>x4\<bar> - x3;
         x6 = \<bar>x5\<bar> - x4; x7 = \<bar>x6\<bar> - x5; x8 = \<bar>x7\<bar> - x6;
         x9 = \<bar>x8\<bar> - x7; x10 = \<bar>x9\<bar> - x8; x11 = \<bar>x10\<bar> - x9 \<rbrakk>
 \<Longrightarrow> x1 = x10 \<and> x2 = (x11::int)"
  by smt

lemma "let P = 2 * x + 1 > x + (x::real) in P \<or> False \<or> P" by smt

lemma "x + (let y = x mod 2 in 2 * y + 1) \<ge> x + (1::int)"
  using [[z3_extensions]] by smt

lemma "x + (let y = x mod 2 in y + y) < x + (3::int)"
  using [[z3_extensions]] by smt

lemma
  assumes "x \<noteq> (0::real)"
  shows "x + x \<noteq> (let P = (\<bar>x\<bar> > 1) in if P \<or> \<not> P then 4 else 2) * x"
  using assms [[z3_extensions]] by smt

subsection \<open>Linear arithmetic with quantifiers\<close>

lemma "~ (\<exists>x::int. False)" by smt
lemma "~ (\<exists>x::real. False)" by smt

lemma "\<exists>x::int. 0 < x" by smt

lemma "\<exists>x::real. 0 < x"
  using [[smt_oracle=true]] (* no Z3 proof *)
  by smt

lemma "\<forall>x::int. \<exists>y. y > x" by smt

lemma "\<forall>x y::int. (x = 0 \<and> y = 1) \<longrightarrow> x \<noteq> y" by smt
lemma "\<exists>x::int. \<forall>y. x < y \<longrightarrow> y < 0 \<or> y >= 0" by smt
lemma "\<forall>x y::int. x < y \<longrightarrow> (2 * x + 1) < (2 * y)" by smt
lemma "\<forall>x y::int. (2 * x + 1) \<noteq> (2 * y)" by smt
lemma "\<forall>x y::int. x + y > 2 \<or> x + y = 2 \<or> x + y < 2" by smt
lemma "\<forall>x::int. if x > 0 then x + 1 > 0 else 1 > x" by smt
lemma "if (\<forall>x::int. x < 0 \<or> x > 0) then False else True" by smt
lemma "(if (\<forall>x::int. x < 0 \<or> x > 0) then -1 else 3) > (0::int)" by smt
lemma "~ (\<exists>x y z::int. 4 * x + -6 * y = (1::int))" by smt
lemma "\<exists>x::int. \<forall>x y. 0 < x \<and> 0 < y \<longrightarrow> (0::int) < x + y" by smt
lemma "\<exists>u::int. \<forall>(x::int) y::real. 0 < x \<and> 0 < y \<longrightarrow> -1 < x" by smt
lemma "\<exists>x::int. (\<forall>y. y \<ge> x \<longrightarrow> y > 0) \<longrightarrow> x > 0" by smt
lemma "\<forall>(a::int) b::int. 0 < b \<or> b < 1" by smt

subsection \<open>Non-linear arithmetic over integers and reals\<close>

lemma "a > (0::int) \<Longrightarrow> a*b > 0 \<Longrightarrow> b > 0"
  using [[smt_oracle, z3_extensions]]
  by smt

lemma  "(a::int) * (x + 1 + y) = a * x + a * (y + 1)"
  using [[z3_extensions]]
  by smt

lemma "((x::real) * (1 + y) - x * (1 - y)) = (2 * x * y)"
  using [[z3_extensions]]
  by smt

lemma
  "(U::int) + (1 + p) * (b + e) + p * d =
   U + (2 * (1 + p) * (b + e) + (1 + p) * d + d * p) - (1 + p) * (b + d + e)"
  using [[z3_extensions]] by smt

lemma [z3_rule]:
  fixes x :: "int"
  assumes "x * y \<le> 0" and "\<not> y \<le> 0" and "\<not> x \<le> 0"
  shows False
  using assms by (metis mult_le_0_iff)

subsection \<open>Linear arithmetic for natural numbers\<close>

declare [[smt_nat_as_int]]

lemma "2 * (x::nat) \<noteq> 1" by smt

lemma "a < 3 \<Longrightarrow> (7::nat) > 2 * a" by smt

lemma "let x = (1::nat) + y in x - y > 0 * x" by smt

lemma
  "let x = (1::nat) + y in
   let P = (if x > 0 then True else False) in
   False \<or> P = (x - 1 = y) \<or> (\<not>P \<longrightarrow> False)"
  by smt

lemma "int (nat \<bar>x::int\<bar>) = \<bar>x\<bar>" by (smt int_nat_eq)

definition prime_nat :: "nat \<Rightarrow> bool" where
  "prime_nat p = (1 < p \<and> (\<forall>m. m dvd p --> m = 1 \<or> m = p))"

lemma "prime_nat (4*m + 1) \<Longrightarrow> m \<ge> (1::nat)" by (smt prime_nat_def)

declare [[smt_nat_as_int = false]]

section \<open>Pairs\<close>

lemma "fst (x, y) = a \<Longrightarrow> x = a"
  using fst_conv by smt

lemma "p1 = (x, y) \<and> p2 = (y, x) \<Longrightarrow> fst p1 = snd p2"
  using fst_conv snd_conv by smt

section \<open>Higher-order problems and recursion\<close>

lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> (f (i1 := v1, i2 := v2)) i = f i"
  using fun_upd_same fun_upd_apply by smt

lemma "(f g (x::'a::type) = (g x \<and> True)) \<or> (f g x = True) \<or> (g x = True)"
  by smt

lemma "id x = x \<and> id True = True"
  by (smt id_def)

lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> ((f (i1 := v1)) (i2 := v2)) i = f i"
  using fun_upd_same fun_upd_apply by smt

lemma
  "f (\<exists>x. g x) \<Longrightarrow> True"
  "f (\<forall>x. g x) \<Longrightarrow> True"
  by smt+

lemma True using let_rsp by smt
lemma "le = (\<le>) \<Longrightarrow> le (3::int) 42" by smt
lemma "map (\<lambda>i::int. i + 1) [0, 1] = [1, 2]" by (smt list.map)
lemma "(\<forall>x. P x) \<or> \<not> All P" by smt

fun dec_10 :: "int \<Rightarrow> int" where
  "dec_10 n = (if n < 10 then n else dec_10 (n - 10))"

lemma "dec_10 (4 * dec_10 4) = 6" by (smt dec_10.simps)

axiomatization
  eval_dioph :: "int list \<Rightarrow> int list \<Rightarrow> int"
where
  eval_dioph_mod: "eval_dioph ks xs mod n = eval_dioph ks (map (\<lambda>x. x mod n) xs) mod n"
and
  eval_dioph_div_mult:
  "eval_dioph ks (map (\<lambda>x. x div n) xs) * n +
   eval_dioph ks (map (\<lambda>x. x mod n) xs) = eval_dioph ks xs"

lemma
  "(eval_dioph ks xs = l) =
   (eval_dioph ks (map (\<lambda>x. x mod 2) xs) mod 2 = l mod 2 \<and>
    eval_dioph ks (map (\<lambda>x. x div 2) xs) = (l - eval_dioph ks (map (\<lambda>x. x mod 2) xs)) div 2)"
  using [[smt_oracle = true]] (*FIXME*)
  using [[z3_extensions]]
  by (smt eval_dioph_mod[where n=2] eval_dioph_div_mult[where n=2])

context complete_lattice
begin

lemma
  assumes "Sup {a | i::bool. True} \<le> Sup {b | i::bool. True}"
  and "Sup {b | i::bool. True} \<le> Sup {a | i::bool. True}"
  shows "Sup {a | i::bool. True} \<le> Sup {a | i::bool. True}"
  using assms by (smt order_trans)

end

section \<open>Monomorphization examples\<close>

definition Pred :: "'a \<Rightarrow> bool" where
  "Pred x = True"

lemma poly_Pred: "Pred x \<and> (Pred [x] \<or> \<not> Pred [x])"
  by (simp add: Pred_def)

lemma "Pred (1::int)"
  by (smt poly_Pred)

axiomatization g :: "'a \<Rightarrow> nat"
axiomatization where
  g1: "g (Some x) = g [x]" and
  g2: "g None = g []" and
  g3: "g xs = length xs"

lemma "g (Some (3::int)) = g (Some True)" by (smt g1 g2 g3 list.size)

end