theory NTT_Scheme

imports Crypto_Scheme
  Mod_Ring_Numeral
  "Number_Theoretic_Transform.NTT"

begin
section \<open>Number Theoretic Transform for Kyber\<close>

lemma Poly_strip_while:
"Poly (strip_while ((=) 0) x) = Poly x"
by (metis Poly_coeffs coeffs_Poly)

locale kyber_ntt = kyber_spec "TYPE('a :: qr_spec)" "TYPE('k::finite)" +
fixes type_a :: "('a :: qr_spec) itself"
  and type_k :: "('k ::finite) itself"
  and \<omega> :: "('a::qr_spec) mod_ring"
  and \<mu> :: "'a mod_ring"
  and \<psi> :: "'a mod_ring"
  and \<psi>inv :: "'a mod_ring"
  and ninv :: "'a mod_ring"
  and mult_factor :: int
assumes
      omega_properties: "\<omega>^n = 1" "\<omega> \<noteq> 1" "(\<forall> m. \<omega>^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n)"
  and mu_properties: "\<mu> * \<omega> = 1" "\<mu> \<noteq> 1"
  and psi_properties: "\<psi>^2 = \<omega>" "\<psi>^n = -1"
  and psi_psiinv: "\<psi> * \<psi>inv = 1"
  and n_ninv: "(of_int_mod_ring n) * ninv = 1"
  and q_split: "q = mult_factor * n + 1"
begin
text \<open>Some properties of the roots $\omega$ and $\psi$ and their inverses $\mu$ and $\psi_inv$.\<close>
lemma mu_prop:
  "(\<forall> m. \<mu>^m = 1 \<and> m\<noteq>0 \<longrightarrow> m \<ge> n)"
by (metis mu_properties(1) mult.commute mult.right_neutral
  omega_properties(3) power_mult_distrib power_one)

lemma mu_prop':
assumes "\<mu>^m' = 1" "m'\<noteq>0" shows "m' \<ge> n"
using mu_prop  assms by blast

lemma omega_prop':
assumes "\<omega>^m' = 1" "m'\<noteq>0" shows "m' \<ge> n"
using omega_properties(3)  assms by blast

lemma psi_props:
shows "\<psi>^(2*n) = 1"
      "\<psi>^(n*(2*a+1)) = -1"
      "\<psi>\<noteq>1"
proof -
  show "\<psi>^(2*n) = 1"
  by (simp add: omega_properties(1) power_mult psi_properties)
  show "\<psi>^(n*(2*a+1)) = -1"
  by (metis (no_types, lifting) mult.commute mult_1 power_add
    power_minus1_even power_mult psi_properties(2))
  show "\<psi>\<noteq>1"
  using omega_properties(2) one_power2 psi_properties(1) by blast
qed

lemma psi_inv_exp:
"\<psi>^i * \<psi>inv ^i = 1"
using left_right_inverse_power psi_psiinv by blast

lemma inv_psi_exp:
"\<psi>inv^i * \<psi> ^i = 1"
by (simp add: mult.commute psi_inv_exp)

lemma negative_psi:
assumes "i<j"
shows "\<psi>^j * \<psi>inv ^i = \<psi>^(j-i)"
proof -
  have j: "\<psi>^j = \<psi>^(j-i) * \<psi>^i" using assms
  by (metis add.commute le_add_diff_inverse nat_less_le power_add)
  show ?thesis unfolding j
  by (simp add: left_right_inverse_power psi_psiinv)
qed

lemma negative_psi':
assumes "i\<le>j"
shows "\<psi>inv^i * \<psi> ^j = \<psi>^(j-i)"
proof -
  have j: "\<psi>^j = \<psi>^i * \<psi>^(j-i)" using assms
  by (metis le_add_diff_inverse power_add)
  show ?thesis unfolding j mult.assoc[symmetric] using inv_psi_exp[of i] by simp
qed

lemma psiinv_prop:
shows "\<psi>inv^2 = \<mu>"
proof -
  show "\<psi>inv^2 = \<mu>"
  by (metis (mono_tags, lifting) mu_properties(1) mult.commute
    mult_cancel_right mult_cancel_right2 power_mult_distrib psi_properties(1) psi_psiinv)
qed

lemma n_ninv':
"ninv * (of_int_mod_ring n) = 1"
using n_ninv
by (simp add: mult.commute)

text \<open>The \<open>map2\<close> function for polynomials.\<close>
definition map2_poly :: "('a mod_ring \<Rightarrow> 'a mod_ring \<Rightarrow> 'a mod_ring) \<Rightarrow>
    'a mod_ring poly \<Rightarrow> 'a mod_ring poly \<Rightarrow> 'a mod_ring poly" where
"map2_poly f p1 p2 =
  Poly (map2 f (map (poly.coeff p1) [0..<nat n]) (map (poly.coeff p2) [0..<nat n]))"

text \<open>Additional lemmas on polynomials.\<close>
lemma Poly_map_coeff:
assumes "degree f < num"
shows "Poly (map (poly.coeff (f)) [0..<num]) = f"
proof (subst poly_eq_iff, safe)
  fix j
  show "poly.coeff (Poly (map (poly.coeff f) [0..<num])) j = poly.coeff f j"
  proof (cases "j<num")
    case True
    then show ?thesis
    unfolding coeff_Poly by (subst nth_default_nth, auto)
  next
    case False
    then have "j>degree f" using assms by auto
    then show ?thesis unfolding coeff_Poly using False
    by (simp add: coeff_eq_0 nth_default_beyond)
  qed
qed

lemma map_upto_n_mod:
"(Poly (map f [0..<n]) mod qr_poly) = (Poly (map f [0..<n]) :: 'a mod_ring poly)"
proof -
  have "degree (Poly (map f [0::nat..<n])) < n"
  by (metis Suc_pred' deg_Poly' deg_qr_n deg_qr_pos degree_0 diff_zero le_imp_less_Suc
    length_map length_upt nat_int)
  then show ?thesis
  by (subst deg_mod_qr_poly, use deg_qr_n in \<open>auto\<close>)
qed

lemma coeff_of_qr_zero:
assumes "i\<ge>n"
shows "poly.coeff (of_qr (f :: 'a qr)) i = 0"
proof -
  have "degree (of_qr f) < i"
    using deg_of_qr deg_qr_n assms order_less_le_trans by auto
  then show ?thesis by (subst coeff_eq_0, auto)
qed

text \<open>Definition of NTT on polynomials.
  In contrast to the ordinary NTT, we use a different exponent on the root of unity $\psi$.\<close>
definition ntt_coeff_poly :: "'a qr \<Rightarrow> nat \<Rightarrow> 'a mod_ring" where
  "ntt_coeff_poly g i = (\<Sum>j\<in>{0..<n}. (poly.coeff (of_qr g) j) * \<psi>^(j * (2*i+1)))"

definition ntt_coeffs :: "'a qr \<Rightarrow> 'a mod_ring list" where
  "ntt_coeffs g = map (ntt_coeff_poly g) [0..<n]"

definition ntt_poly :: "'a qr \<Rightarrow> 'a qr" where
"ntt_poly g = to_qr (Poly (ntt_coeffs g))"

text \<open>Definition of inverse NTT on polynomials.
  The inverse transformed is already scaled such that it is the true inverse of the NTT.\<close>
definition inv_ntt_coeff_poly :: "'a qr \<Rightarrow> nat \<Rightarrow> 'a mod_ring" where
  "inv_ntt_coeff_poly g' i = ninv *
    (\<Sum>j\<in>{0..<n}. (poly.coeff (of_qr g') j) * \<psi>inv^(i*(2*j+1)))"

definition inv_ntt_coeffs :: "'a qr \<Rightarrow> 'a mod_ring list" where
  "inv_ntt_coeffs g' = map (inv_ntt_coeff_poly g') [0..<n]"

definition inv_ntt_poly :: "'a qr \<Rightarrow> 'a qr" where
  "inv_ntt_poly g = to_qr (Poly (inv_ntt_coeffs g))"

text \<open>Kyber is indeed in the NTT-domain with root of unity $\omega$.
Note, that our ntt on polynomials uses a slightly different exponent.
The root of unity $\omega$ defines an alternative NTT in Kyber.\<close>
text \<open>Have $7681 = 30*256 + 1$ and $3329 = 13 * 256 + 1$.\<close>
interpretation kyber_ntt: ntt "nat q" "nat n" "nat mult_factor" \<omega> \<mu>
proof (unfold_locales, goal_cases)
  case 2
  then show ?case  using q_gt_two by linarith
next
  case 3
  then show ?case
    by (smt (verit, del_insts) int_nat_eq mult.commute nat_int_add
    nat_mult_distrib of_nat_1 q_gt_two q_split zadd_int_left)
next
  case 4
  then show ?case using n_gt_1 by linarith
qed (use CARD_a nat_int in \<open>auto simp add: omega_properties mu_properties\<close>)

text \<open>Multiplication in of polynomials in $R_q$ is a negacyclic convolution
(because we factored by $x^n + 1$, thus $x^n\equiv -1 \mod x^n+1$).
This is the reason why we needed to adapt the exponent in the NTT.\<close>
definition qr_mult_coeffs :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr" (infixl "\<star>" 70) where
  "qr_mult_coeffs f g = to_qr (map2_poly (*) (of_qr f) (of_qr g))"

text \<open>The definition of the exponentiation \<open>^\<close> only allows for natural exponents,
thus we need to cheat a bit by introducing \<open>conv_sign x\<close>$\equiv (-1)^x$.\<close>
definition conv_sign :: "int \<Rightarrow> 'a mod_ring" where
"conv_sign x = (if x mod 2 = 0 then 1 else -1)"

text \<open>The definition of the negacyclic convolution.\<close>
definition negacycl_conv :: "'a qr \<Rightarrow> 'a qr \<Rightarrow> 'a qr" where
"negacycl_conv f g =
  to_qr (Poly (map
  (\<lambda>i. \<Sum>j<n. conv_sign ((int i - int j) div n) *
    poly.coeff (of_qr f) j * poly.coeff (of_qr g) (nat ((int i - int j) mod n)))
  [0..<n]))"

lemma negacycl_conv_mod_qr_poly:
"of_qr (negacycl_conv f g) mod qr_poly = of_qr (negacycl_conv f g)"
unfolding negacycl_conv_def of_qr_to_qr by auto

text \<open>Representation of f modulo \<open>qr_poly\<close>.\<close>
lemma mod_div_qr_poly:
"(f :: 'a mod_ring poly) = (f mod qr_poly) + qr_poly * (f div qr_poly)"
by simp

text \<open>\<open>take_deg\<close> returns the first $n$ coefficients of a polynomial.\<close>
definition take_deg :: "nat \<Rightarrow> ('b::zero) poly \<Rightarrow> 'b poly"  where
"take_deg = (\<lambda>n. \<lambda>f. Poly (take n (coeffs f)))"

text \<open>\<open>drop_deg\<close> returns the coefficients of a polynomial strarting from the $n$-th coefficient.\<close>
definition drop_deg :: "nat \<Rightarrow> ('b::zero) poly \<Rightarrow> 'b poly"  where
"drop_deg = (\<lambda>n. \<lambda>f. Poly (drop n (coeffs f)))"

text \<open>\<open>take_deg\<close> and \<open>drop_deg\<close> return the modulo and divisor representants.\<close>
lemma take_deg_monom_drop_deg:
assumes "degree f \<ge> n"
shows "(f :: 'a mod_ring poly) = take_deg n f + (Polynomial.monom 1 n) * drop_deg n f"
proof -
  have "min (length (coeffs f)) n = n" using assms
  by (metis bot_nat_0.not_eq_extremum degree_0 le_imp_less_Suc
    length_coeffs_degree min.absorb1 min.absorb4)
  then show ?thesis
    unfolding take_deg_def drop_deg_def
    apply (subst Poly_coeffs[of f,symmetric])
    apply (subst append_take_drop_id[of n "coeffs f", symmetric])
    apply (subst Poly_append)
    by (auto)
qed

lemma split_mod_qr_poly:
assumes "degree f \<ge> n"
shows "(f :: 'a mod_ring poly) = take_deg n f - drop_deg n f + qr_poly * drop_deg n f"
proof -
  have "(Polynomial.monom 1 n + 1) * drop_deg n f =
    Polynomial.monom 1 n *  drop_deg n f + drop_deg n f"
    by (simp add: mult_poly_add_left)
  then show ?thesis
    apply (subst take_deg_monom_drop_deg[OF assms])
    apply (unfold qr_poly_def qr_poly'_eq of_int_hom.map_poly_hom_add)
    by auto
qed

text \<open>Lemmas on the degrees of \<open>take_deg\<close> and \<open>drop_deg\<close>.\<close>
lemma degree_drop_n:
"degree (drop_deg n f) = degree f - n"
unfolding drop_deg_def
by (simp add: degree_eq_length_coeffs)

lemma degree_drop_2n:
assumes "degree f < 2*n"
shows "degree (drop_deg n f) < n"
using assms unfolding degree_drop_n by auto

lemma degree_take_n:
"degree (take_deg n f) < n"
unfolding take_deg_def
by (metis coeff_Poly_eq deg_qr_n deg_qr_pos degree_0 leading_coeff_0_iff
  nth_default_take of_nat_eq_iff)

lemma deg_mult_of_qr:
"degree (of_qr (f ::'a qr) * of_qr g) < 2 * n"
by (metis add_less_mono deg_of_qr deg_qr_n degree_0 degree_mult_eq
  mult_2 mult_eq_0_iff nat_int_comparison(1))

text \<open>Representation of a polynomial modulo \<open>qr_poly\<close> using \<open>take_deg\<close> and \<open>drop_deg\<close>.\<close>
lemma mod_qr_poly:
assumes "degree f \<ge> n" "degree f < 2*n"
shows "(f :: 'a mod_ring poly) mod qr_poly = take_deg n f - drop_deg n f "
proof -
  have "degree (take_deg n f - drop_deg n f) < deg_qr TYPE('a)"
    using degree_diff_le_max[of "take_deg n f" "drop_deg n f"]
     degree_drop_2n[OF assms(2)]  degree_take_n
     by (metis deg_qr_n degree_diff_less nat_int)
  then have "(take_deg n f - drop_deg n f) mod qr_poly =
    take_deg n f - drop_deg n f" by (subst deg_mod_qr_poly, auto)
  then show ?thesis
    by (subst split_mod_qr_poly[OF assms(1)], auto)
qed

text \<open>Coefficients of \<open>take_deg\<close>, \<open>drop_deg\<close> and the modulo representant.\<close>
lemma coeff_take_deg:
assumes "i<n"
shows "poly.coeff (take_deg n f) i = poly.coeff (f::'a mod_ring poly) i"
using assms unfolding take_deg_def
by (simp add: nth_default_coeffs_eq nth_default_take)

lemma coeff_drop_deg:
assumes "i<n"
shows "poly.coeff (drop_deg n f) i = poly.coeff (f::'a mod_ring poly) (i+n)"
using assms unfolding drop_deg_def
by (simp add: nth_default_coeffs_eq nth_default_drop)

lemma coeff_mod_qr_poly:
assumes "degree (f::'a mod_ring poly) \<ge> n" "degree f < 2*n" "i<n"
shows "poly.coeff (f mod qr_poly) i = poly.coeff f i - poly.coeff f (i+n)"
apply (subst mod_qr_poly[OF assms(1) assms(2)])
apply (subst coeff_diff)
apply (unfold coeff_take_deg[OF assms(3)] coeff_drop_deg[OF assms(3)])
by auto

text \<open>More lemmas on the splitting of sums.\<close>

lemma sum_leq_split:
"(\<Sum>ia\<le>i+n. f ia) = (\<Sum>ia<n. f ia) + (\<Sum>ia\<in>{n..i+n}. f ia)"
proof -
  have *: "{..i + n} - {..<n} = {n..i + n}"
  by (metis atLeastLessThanSuc_atLeastAtMost lessThan_Suc_atMost lessThan_minus_lessThan)
  show ?thesis
  by (subst sum.subset_diff[of "{..<n}" "{..i+n}" f]) (auto simp add: * add.commute)
qed

lemma less_diff:
assumes "l1<l2"
shows "{..<l2} - {..l1} = {l1<..<l2::nat}"
by (metis atLeastSucLessThan_greaterThanLessThan lessThan_Suc_atMost lessThan_minus_lessThan)

lemma sum_less_split:
assumes "l1<(l2::nat)"
shows "sum f {..<l2} = sum f {..l1} + sum f {l1<..<l2}"
by (subst sum.subset_diff[of "{..l1}" "{..<l2}" f])
   (auto simp add: assms add.commute order_le_less_trans less_diff[OF assms])

lemma div_minus_1:
assumes "(x::int) \<in> {-b..<0}"
shows "x div b = -1"
using assms
by (smt (verit, ccfv_SIG) atLeastLessThan_iff div_minus_minus div_pos_neg_trivial)

text \<open>A coefficient of polynomial multiplication is a coefficient of the negacyclic convolution.\<close>
lemma coeff_conv:
fixes f :: "'a qr"
assumes "i<n"
shows "poly.coeff ((of_qr f) * (of_qr g) mod qr_poly) i =
    (\<Sum>j<n. conv_sign ((int i - int j) div n) *
      poly.coeff (of_qr f) j * poly.coeff (of_qr g) (nat ((int i - int j) mod n)))"
proof (cases "degree (of_qr f) + degree (of_qr g)<n")
  case True
  then have True':"degree ((of_qr f) * (of_qr g)) <n" using degree_mult_le
  using order_le_less_trans by blast
  have "poly.coeff ((of_qr f) * (of_qr g) mod qr_poly) i =
    poly.coeff ((of_qr f) * (of_qr g)) i" using True'
  by (metis deg_qr_n degree_qr_poly mod_poly_less nat_int)
  also have "\<dots> = (\<Sum>ia\<le>i. poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (i - ia))"
    unfolding coeff_mult by auto
  also have "\<dots> = (\<Sum>ia\<le>i. conv_sign ((int i - int ia) div int n) *
    poly.coeff (of_qr f) ia *
    poly.coeff (of_qr g) (nat ((int i - int ia) mod n)))"
  proof -
    have "i-ia = nat ((int i - int ia) mod n)" if "ia \<le> i" for ia
    using assms that by force
    moreover have "conv_sign ((int i - int ia) div int n) = 1"
      if "ia \<le> i" for ia unfolding conv_sign_def
      using assms that by force
    ultimately show ?thesis by auto
  qed
  also have "\<dots> = (\<Sum>ia<n. conv_sign ((int i - int ia) div int n) *
    poly.coeff (of_qr f) ia *
    poly.coeff (of_qr g) (nat ((int i - int ia) mod n)))"
  proof -
    have "poly.coeff (of_qr f) ia *
       poly.coeff (of_qr g) (nat ((int i - int ia) mod int n)) = 0"
      if "ia \<in> {i<..<n}" for ia
    proof (subst mult_eq_0_iff, safe, goal_cases)
      case 1
      have deg_g: "nat ((int i - int ia) mod int n) \<le> degree (of_qr g)"
        using le_degree[OF 1] by auto
      have "ia > degree (of_qr f)"
      proof (rule ccontr)
        assume "\<not> degree (of_qr f) < ia"
        then have as: "ia \<le> degree (of_qr f)" by auto
        then have ni: "nat ((int i - int ia) mod int n) + ia = n + i"
          using that  by (smt (verit, ccfv_threshold) True deg_g
          greaterThanLessThan_iff int_nat_eq less_imp_of_nat_less
          mod_add_self1 mod_pos_pos_trivial of_nat_0_le_iff of_nat_add
          of_nat_mono)
        have "n + i \<le> degree (of_qr f) + degree (of_qr g)"
          unfolding ni[symmetric] using as deg_g by auto
        then show False using True by auto
      qed
      then show ?case
      using coeff_eq_0 by blast
    qed
    then show ?thesis
      by (subst sum_less_split[OF \<open>i<n\<close>]) (simp add: sum.neutral)
  qed
  finally show ?thesis by blast
next
  case False
  then have *: "degree (of_qr f * of_qr g) \<ge> n"
  by (metis add.right_neutral add_0 deg_of_qr deg_qr_n degree_0 degree_mult_eq
      linorder_not_le nat_int)
  have "poly.coeff (of_qr f * of_qr g) (i + n) = (\<Sum>ia<n.
        poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (i + n - ia))"
    unfolding coeff_mult using coeff_of_qr_zero
    by (subst sum_leq_split[of _ i]) (auto)
  also have "\<dots> = (\<Sum>ia\<in>{i<..<n}.
        poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (i + n - ia))"
    using coeff_of_qr_zero by (subst sum_less_split[OF \<open>i<n\<close>]) auto
  also have "\<dots> = (\<Sum>ia\<in>{i<..<n}.
        poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (nat ((int i - ia) mod n)))"
  proof -
    have "int i - int ia + int n \<in>{0..<n}" if "ia \<in> {i<..<n}" for ia using assms that by auto
    then have "int i + n-ia = (int i-ia) mod n" if "ia\<in>{i<..<n}" for ia
     using \<open>i<n\<close> that by (smt (verit, best) mod_add_self1 mod_rangeE)
    then have "i+n-ia = nat ((int i - ia) mod n)" if "ia\<in>{i<..<n}" for ia
    by (metis int_minus nat_int of_nat_add that)
    then show ?thesis by fastforce
  qed
  also have "\<dots> = - (\<Sum>ia\<in>{i<..<n}. conv_sign ((int i - int ia) div n) *
        poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (nat ((int i - ia) mod n)))"
  proof -
    have negative:"(int i - int ia) \<in> {-n..<0}" if "ia \<in>{i<..<n}" for ia
      using that by auto
    have "(int i - int ia) div n = -1" if "ia \<in>{i<..<n}" for ia
      using div_minus_1[OF negative[OF that]] .
    then have "conv_sign ((int i - int ia) div n) = -1" if "ia \<in>{i<..<n}" for ia
      unfolding conv_sign_def using that by auto
    then have *: "(\<Sum>ia\<in>{i<..<n}. foo ia) =
      (\<Sum>x\<in>{i<..<n}. - (conv_sign ((int i - int x) div int n) * foo x))"
    for foo by auto
    show ?thesis
    by (subst sum_negf[symmetric], subst *) (simp add: mult.assoc)
  qed
  finally have i_n: "poly.coeff (of_qr f * of_qr g) (i + n) =
    - (\<Sum>ia\<in>{i<..<n}. conv_sign ((int i - int ia) div n) *
        poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (nat ((int i - ia) mod n)))"
    by blast
  have i_n': "poly.coeff (of_qr f * of_qr g) i =
      (\<Sum>ia\<le>i. conv_sign ((int i - int ia) div n) *
        poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (nat ((int i - ia) mod n)))"
  proof -
    have "conv_sign ((int i - int ia) div n) = 1" if "ia \<le>i" for ia
      using that assms conv_sign_def by force
    moreover have "i-ia \<in>{0..<n}" if "ia \<le>i" for ia using that assms by auto
    then have "i-ia = (nat ((int i - ia) mod n))" if "ia\<le>i" for ia
      using assms that by force
    ultimately show ?thesis unfolding coeff_mult
    using assms less_imp_diff_less mod_less by auto
  qed
  have calc: "poly.coeff (of_qr f * of_qr g) i - poly.coeff (of_qr f * of_qr g) (i + n) =
    (\<Sum>ia<n. conv_sign ((int i - int ia) div n) *
        poly.coeff (of_qr f) ia * poly.coeff (of_qr g) (nat ((int i - ia) mod n)))"
    by (subst i_n, subst i_n')
       (metis (no_types, lifting) assms diff_minus_eq_add sum_less_split)
  show ?thesis unfolding coeff_mod_qr_poly[OF * deg_mult_of_qr assms] calc
    by auto
qed

text \<open>Polynomial multiplication in $R_q$ is the negacyclic convolution.\<close>

lemma mult_negacycl:
"f * g = negacycl_conv f g"
proof -
  have f_times_g: "f * g = to_qr ((of_qr f) * (of_qr g) mod qr_poly)"
    by (metis of_qr_mult to_qr_of_qr)
  have conv: "poly.coeff ((of_qr f) * (of_qr g) mod qr_poly) i =
    (\<Sum>j<n. conv_sign ((int i - int j) div n) *
    poly.coeff (of_qr f) j * poly.coeff (of_qr g) (nat ((int i - j) mod n)))"
  if "i<n" for i using coeff_conv[OF that] by auto
  have "poly.coeff (of_qr (f*g)) i =
    poly.coeff (of_qr (negacycl_conv f g)) i" for i
  proof (cases "i<n")
    case True
    then show ?thesis unfolding negacycl_conv_def f_times_g of_qr_to_qr
      map_upto_n_mod mod_mod_trivial coeff_Poly_eq
      using conv[OF True] by (subst nth_default_nth[of i], auto)
  next
    case False
    then show ?thesis using coeff_of_qr_zero[of i "f*g"]
      coeff_of_qr_zero[of i "negacycl_conv f g"] by auto
  qed
  then show ?thesis
    using poly_eq_iff [of "of_qr (f * g)" "of_qr (negacycl_conv f g)"]
    by (metis to_qr_of_qr)
qed

text \<open>Additional lemmas on \<open>ntt_coeffs\<close>.\<close>

lemma length_ntt_coeffs:
"length (ntt_coeffs f) \<le> n"
unfolding ntt_coeffs_def by auto

lemma degree_Poly_ntt_coeffs:
"degree (Poly (ntt_coeffs f)) < n"
using length_ntt_coeffs
by (smt (verit) deg_Poly' degree_0 degree_take_n diff_diff_cancel
  diff_is_0_eq le_neq_implies_less less_nat_zero_code nat_le_linear
  order.strict_trans1 power_0_left power_eq_0_iff)

lemma Poly_ntt_coeffs_mod_qr_poly:
  "Poly (ntt_coeffs f) mod qr_poly = Poly (ntt_coeffs f)"
using map_upto_n_mod ntt_coeffs_def by presburger

lemma nth_default_map:
assumes "i<na"
shows "nth_default x (map f [0..<na]) i = f i"
using assms
by (simp add: nth_default_nth)

lemma nth_coeffs_negacycl:
assumes "j<n"
shows "poly.coeff (of_qr (negacycl_conv f g)) j =
  (\<Sum>i<n. conv_sign ((int j - int i) div int n) * poly.coeff (of_qr f) i *
   poly.coeff (of_qr g) (nat ((int j - int i) mod int n)))"
unfolding negacycl_conv_def of_qr_to_qr map_upto_n_mod coeff_Poly_eq
 nth_default_map[OF assms] by auto

text \<open>Writing the convolution sign as a conditional if statement.\<close>
lemma conv_sign_if:
assumes "x<n" "y<n"
shows "conv_sign ((int x - int y) div int n) = (if int x - int y < 0 then -1 else 1)"
unfolding conv_sign_def
proof (split if_splits, safe, goal_cases)
  case 1
  then have "int x - int y \<in> {-n..<0}" using assms by simp
  then have "(int x - int y) div int n mod 2 = 1"
    using div_minus_1 by presburger
  then show ?case by auto
next
  case 2
  then have "(int x - int y) div int n mod 2 = 0"
  using assms(1) by force
  then show ?case by auto
qed

text \<open>The convolution theorem on coefficients.\<close>

lemma ntt_coeff_poly_mult:
assumes "l<n"
shows "ntt_coeff_poly (f*g) l = ntt_coeff_poly f l * ntt_coeff_poly g l"
proof -
  define f1 where "f1 = (\<lambda>x. \<lambda> y.
        conv_sign ((int x - int y) div int n) *
        poly.coeff (of_qr f) y *
        poly.coeff (of_qr g) (nat ((int x - int y) mod int n)))"
  have "ntt_coeff_poly (f*g) l = (\<Sum>j = 0..<n. poly.coeff (of_qr (negacycl_conv f g)) j *
        \<psi>^(j*(2*l+1)))" unfolding ntt_coeff_poly_def mult_negacycl by auto
  also have "\<dots> = (\<Sum>j=0..<n. (\<Sum>i<n. f1 j i * \<psi>^(j*(2*l+1))))"
  proof (subst sum.cong[of "{0..<n}" "{0..<n}"
      "(\<lambda>j. poly.coeff (of_qr (negacycl_conv f g)) j * \<psi>^(j*(2*l+1)))"
      "(\<lambda>j. (\<Sum>i<n. f1 j i * \<psi>^(j*(2*l+1))))"],
      goal_cases)
    case (2 j)
    then have "j<n" by auto
    have "poly.coeff (of_qr (negacycl_conv f g)) j * \<psi> ^ (j * (2 * l + 1)) =
      (\<Sum>na<n. (conv_sign ((int j - int na) div int n) *
         poly.coeff (of_qr f) na * poly.coeff (of_qr g) (nat ((int j - int na) mod int n))) *
        \<psi> ^ (j * (2 * l + 1)))"
      apply (subst nth_coeffs_negacycl[OF \<open>j<n\<close>])
      apply (subst sum_distrib_right)
      by auto
    also have "\<dots> = (\<Sum>na<n. f1 j na * \<psi> ^ (j * (2 * l + 1)))"
      unfolding f1_def by auto
    finally show ?case by blast
  qed auto
  also have "\<dots> = (\<Sum>i<n. \<Sum>j<n. f1 j i * \<psi> ^ (j * (2 * l + 1))) "
    by (subst atLeast0LessThan, subst sum.swap, auto)
  also have "\<dots> = (\<Sum>i<n. poly.coeff (of_qr f) i * \<psi> ^ (i * (2 * l + 1)) *
    (\<Sum>j<n. poly.coeff (of_qr g) (nat ((int j - int i) mod int n)) *
        (if int j - int i < 0 then -1 else 1) *
         \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1))))"
  proof (subst sum.cong[of "{..<n}" "{..<n}" "(\<lambda>i. (\<Sum>j<n. f1 j i * \<psi> ^ (j * (2 * l + 1))))"
    "(\<lambda>i. poly.coeff (of_qr f) i * \<psi> ^ (i * (2 * l + 1)) *
        (\<Sum>j<n. poly.coeff (of_qr g) (nat ((int j - int i) mod int n)) *
        (if int j - int i < 0 then -1 else 1) *
         \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1))))"], goal_cases)
    case (2 i)
    then show ?case
    proof (subst sum_distrib_left, subst sum.cong[of "{..<n}" "{..<n}"
      "(\<lambda>j. f1 j i * \<psi> ^ (j * (2 * l + 1)))"
      "(\<lambda>j. poly.coeff (of_qr f) i * \<psi> ^ (i * (2 * l + 1)) *
        (poly.coeff (of_qr g) (nat ((int j - int i) mod int n)) *
        (if int j - int i < 0 then - 1 else 1) *
        \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1))))"], goal_cases)
      case (2 j)
      then have *: "conv_sign ((int j - int i) div int n) =
        (if int j - int i < 0 then - 1 else 1)" using conv_sign_if by auto
      have "f1 j i * \<psi> ^ (j * (2 * l + 1)) =
        \<psi> ^ (i * (2 * l + 1)) * f1 j i * \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1))"
        using psi_psiinv
        by (simp add: left_right_inverse_power)
      also have "\<dots> = poly.coeff (of_qr f) i * \<psi> ^ (i * (2 * l + 1)) *
      (poly.coeff (of_qr g) (nat ((int j - int i) mod int n)) *
      (if int j - int i < 0 then - 1 else 1) * \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1)))"
        unfolding f1_def mult.assoc
        by (simp add: "*" mult.left_commute)
      finally show ?case  by blast
    qed auto
  qed auto
  also have "\<dots> = (\<Sum>i<n. poly.coeff (of_qr f) i * \<psi> ^ (i * (2 * l + 1)) *
    (\<Sum>x<n. poly.coeff (of_qr g) x * \<psi> ^ (x * (2 * l + 1))))"
  proof -
    define x' where "x' = (\<lambda>j i. nat ((int j - int i) mod int n))"
    let ?if_inv = "(\<lambda>i j. (if int j - int i < 0 then - 1 else 1) *
      \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1)))"
    have rewrite: "(if int j - int i < 0 then - 1 else 1) *
      \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1)) =
      \<psi> ^ ((x' j i) * (2 * l + 1))"  if "i<n" "j<n" for i j
    proof (cases "int j - int i <0")
      case True
      have lt: "i * (2 * l + 1) < n * (2 * l + 1)" using \<open>i<n\<close>
      by (metis One_nat_def add_gr_0 lessI mult_less_mono1)
      have "?if_inv i j = (-1) * \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1))"
        using True by (auto split: if_splits)
      also have "\<dots> = \<psi>^((n-i+j)* (2 * l + 1))" unfolding psi_props(2)[of l, symmetric]
         negative_psi[OF lt]
         by (metis comm_semiring_class.distrib diff_mult_distrib power_add)
      also have "\<dots> = \<psi> ^ ((x' j i) * (2 * l + 1))" unfolding x'_def
      by (smt (verit, best) True mod_add_self2 mod_pos_pos_trivial nat_int_add
        nat_less_le of_nat_0_le_iff of_nat_diff that(1))
      finally show ?thesis by blast
    next
      case False
      then have "i\<le>j" by auto
      have lt: "i * (2 * l + 1) \<le> j * (2 * l + 1)" using \<open>i\<le>j\<close>
      using add_gr_0 less_one mult_less_mono1
      using mult_le_cancel2 by presburger
      have "?if_inv i j = \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1))"
        using False by (auto split: if_splits)
      also have "\<dots> = \<psi>^((j-i)* (2 * l + 1))"
        using negative_psi'[OF lt]  diff_mult_distrib by presburger
      also have "\<dots> = \<psi> ^ ((x' j i) * (2 * l + 1))" unfolding x'_def
        by (metis \<open>i \<le> j\<close> less_imp_diff_less mod_pos_pos_trivial nat_int
          of_nat_0_le_iff of_nat_diff of_nat_less_iff that(2))
      finally show ?thesis by blast
    qed
    then have "(\<Sum>j<n. poly.coeff (of_qr g) (nat ((int j - int i) mod int n)) *
      (if int j - int i < 0 then - 1 else 1) *
      \<psi>inv ^ (i * (2 * l + 1)) * \<psi> ^ (j * (2 * l + 1))) =
      (\<Sum>x<n. poly.coeff (of_qr g) x * \<psi> ^ (x * (2 * l + 1)))"
      (is "(\<Sum>j<n. ?left j i) = _") if "i<n" for i
    proof -
      have *: "(\<Sum>j<n. ?left j i) =
        (\<Sum>j<n. poly.coeff (of_qr g) (x' j i) * \<psi> ^ ((x' j i) * (2 * l + 1)))"
        using rewrite[OF that] x'_def
        by (smt (verit, ccfv_SIG) lessThan_iff mult.assoc sum.cong)
      have eq: "(\<lambda>j. x' j i) ` {..<n} = {..<n}" unfolding x'_def
      proof (safe, goal_cases)
        case (1 _ j)
        then show ?case
        using Euclidean_Division.pos_mod_bound Euclidean_Division.pos_mod_sign
        n_gt_zero nat_less_iff by blast
      next
        case (2 x)
        define j where "j = (x+i) mod n"
        have "j\<in>{..<n}"
        by (metis j_def lessThan_iff mod_less_divisor n_gt_zero of_nat_0_less_iff)
        moreover have "x = nat ((int j - int i) mod int n)" unfolding j_def
        by (simp add: "2" mod_diff_cong zmod_int)
        ultimately show ?case by auto
      qed
      have inj: "inj_on (\<lambda>j. x' j i) {..<n}" unfolding x'_def inj_on_def
      proof (safe, goal_cases)
        case (1 x y)
        then show ?case
        by (smt (verit, best) Euclidean_Division.pos_mod_sign int_nat_eq
          less_imp_le_nat mod_diff_cong mod_pos_pos_trivial of_nat_0_less_iff
          of_nat_diff of_nat_eq_iff of_nat_less_0_iff zero_less_diff)
      qed
      show ?thesis unfolding * by (subst sum.reindex_cong[OF inj eq[symmetric],
        of "(\<lambda>x. poly.coeff (of_qr g) x * \<psi> ^ (x * (2 * l + 1)))"
        "(\<lambda>j. poly.coeff (of_qr g) (x' j i) * \<psi> ^ (x' j i * (2 * l + 1)))"], auto)
    qed
    then show ?thesis by force
  qed
  also have "\<dots> = (\<Sum>i<n. poly.coeff (of_qr f) i * \<psi> ^ (i * (2 * l + 1))) *
    (\<Sum>x'<n. poly.coeff (of_qr g) x' * \<psi> ^ (x' * (2 * l + 1)))"
    unfolding sum_distrib_right by auto
  also have "\<dots> = ntt_coeff_poly f l * ntt_coeff_poly g l"
    unfolding ntt_coeff_poly_def atLeast0LessThan by auto
  finally show ?thesis by blast
qed

lemma ntt_coeffs_mult:
assumes "i<n"
shows "ntt_coeffs (f*g) !i = ntt_coeffs f! i * ntt_coeffs g ! i"
unfolding ntt_coeffs_def using ntt_coeff_poly_mult[OF assms]
by (simp add: assms)

text \<open>Steps towards the convolution theorem.\<close>

lemma nth_default_ntt_coeff_mult:
"nth_default 0 (ntt_coeffs (f * g)) i =
 nth_default 0 (map2 (*)
  (map (poly.coeff (Poly (ntt_coeffs f))) [0..<nat (int n)])
  (map (poly.coeff (Poly (ntt_coeffs g))) [0..<nat (int n)])) i"
(is "?left i = ?right i")
proof (cases "i\<in>{0..<n}")
  case True
  then have l: "?left i = ntt_coeffs (f * g) ! i"
    by (simp add: nth_default_nth ntt_coeffs_def)
  have *: "?right i = (poly.coeff (Poly (ntt_coeffs f)) i) * (poly.coeff (Poly (ntt_coeffs g)) i)"
    using True
    by (metis (no_types, lifting) coeff_Poly_eq diff_zero length_map length_upt
      map_nth_default mult_hom.hom_zero nat_int nth_default_map2 ntt_coeffs_def)
  then have r: "?right i = (ntt_coeffs f) ! i * (ntt_coeffs g) ! i"
    unfolding * unfolding coeff_Poly using nth_default_nth
    by (metis True atLeastLessThan_iff diff_zero length_map length_upt ntt_coeffs_def)
  show ?thesis unfolding l r using ntt_coeffs_mult True by auto
next
  case False
  then have "?left i = 0" unfolding ntt_coeffs_def
    by (simp add: nth_default_beyond)
  moreover have "?right i = 0" using False
  by (simp add: nth_default_def)
  ultimately show ?thesis by presburger
qed

lemma Poly_ntt_coeffs_mult:
"Poly (ntt_coeffs (f * g)) = Poly (map2 (*)
  (map (poly.coeff (Poly (ntt_coeffs f))) [0..<nat (int n)])
  (map (poly.coeff (Poly (ntt_coeffs g))) [0..<nat (int n)]))"
apply (intro poly_eqI) apply (unfold coeff_Poly)
using nth_default_ntt_coeff_mult[of f g] by auto

text \<open>Convolution theorem for NTT\<close>
lemma ntt_mult:
"ntt_poly (f * g) = qr_mult_coeffs (ntt_poly f) (ntt_poly g)"
proof -
  have "Poly (ntt_coeffs (f*g)) mod qr_poly =
    Poly (ntt_coeffs (f*g))"
    using Poly_ntt_coeffs_mod_qr_poly by force
  also have "\<dots> = Poly (coeffs (map2_poly (*) (Poly (ntt_coeffs f)) (Poly (ntt_coeffs g))))"
    unfolding map2_poly_def coeffs_Poly Poly_strip_while
    using Poly_ntt_coeffs_mult by auto
  also have "\<dots> = (map2_poly (*) (of_qr (to_qr (Poly (ntt_coeffs f))))
         (of_qr (to_qr (Poly (ntt_coeffs g))))) mod qr_poly"
  unfolding of_qr_to_qr map_poly_def Poly_ntt_coeffs_mod_qr_poly
  by (metis Poly_coeffs Poly_ntt_coeffs_mod_qr_poly calculation)
  finally have "[Poly (ntt_coeffs (f * g)) =
       (map2_poly (*) (of_qr (to_qr (Poly (ntt_coeffs f))))
         (of_qr (to_qr (Poly (ntt_coeffs g)))))] (mod qr_poly)"
  using cong_def by blast
  then have "to_qr (Poly (ntt_coeffs (f * g))) =
    to_qr (map2_poly (*) (of_qr (to_qr (Poly (ntt_coeffs f))))
         (of_qr (to_qr (Poly (ntt_coeffs g)))))"
  using of_qr_to_qr by auto
  then show ?thesis
    unfolding ntt_poly_def qr_mult_coeffs_def
    by auto
qed

text \<open>Correctness of NTT on polynomials.\<close>

lemma inv_ntt_poly_correct:
"inv_ntt_poly (ntt_poly f) = f"
proof -
  have rew_sum: "(\<Sum>j = 0..<n. nth_default 0
    (map (\<lambda>i. \<Sum>j = 0..<n. poly.coeff (of_qr f) j * \<psi> ^ (j * (2 * i + 1))) [0..<n])
     j * \<psi>inv ^ (i * (2 * j + 1))) =
    (\<Sum>j = 0..<n. (\<Sum>j' = 0..<n. poly.coeff (of_qr f) j' * \<psi> ^ (j' * (2 * j + 1)))
     * \<psi>inv ^ (i * (2 * j + 1)))"
    (is "(\<Sum>j = 0..<n. ?left j) = (\<Sum>j = 0..<n. ?right j)") for i
  proof (subst sum.cong[of "{0..<n}" "{0..<n}" ?left ?right], goal_cases)
    case (2 x)
    then show ?case by (subst nth_default_map[of x n], auto)
  qed auto
  have  "(\<Sum>j = 0..<n. \<Sum>j' = 0..<n. poly.coeff (of_qr f) j' *
    \<psi> ^ (j' * (2 * j + 1)) * \<psi>inv ^ (i * (2 * j + 1))) =
    (of_int_mod_ring n) * poly.coeff (of_qr f) i" if "i<n" for i
  proof -
    have rew_psi: "\<psi> ^ (j * (2 * j' + 1)) * \<psi>inv ^ (i * (2 * j' + 1)) =
      \<psi> ^ j * \<psi>inv ^ i * (\<psi> ^ (j * 2) * \<psi>inv ^ (i * 2)) ^ j'"
      if "j'<n" "j<n" for j' j
    by (smt (verit, ccfv_threshold) kyber_ntt.exp_rule mult.commute
      power_add power_mult power_one_right)
    have "(\<Sum>j = 0..<n. \<Sum>j' = 0..<n. poly.coeff (of_qr f) j' *
        \<psi> ^ (j' * (2 * j + 1)) * \<psi>inv ^ (i * (2 * j + 1))) =
      (\<Sum>j' = 0..<n. poly.coeff (of_qr f) j' * \<psi>^j' * \<psi>inv^i *
        (\<Sum>j = 0..<n. (\<psi> ^ (j' * 2) * \<psi>inv ^ (i * 2))^j))"
    apply (subst sum_distrib_left, subst sum.swap)
     proof (subst sum.cong[of "{0..<n}" "{0..<n}"
      "(\<lambda>j. \<Sum>ia = 0..<n. poly.coeff (of_qr f) j * \<psi> ^ (j * (2 * ia + 1)) *
           \<psi>inv ^ (i * (2 * ia + 1)))"
      "(\<lambda>j. \<Sum>ia = 0..<n. poly.coeff (of_qr f) j * \<psi> ^ j * \<psi>inv ^ i *
           (\<psi> ^ (j * 2) * \<psi>inv ^ (i * 2)) ^ ia)"], goal_cases)
      case (2 j)
      then show ?case proof (subst sum.cong[of "{0..<n}" "{0..<n}"
      "(\<lambda>ia. poly.coeff (of_qr f) j * \<psi> ^ (j * (2 * ia + 1)) *
        \<psi>inv ^ (i * (2 * ia + 1)))"
      "(\<lambda>ia. poly.coeff (of_qr f) j * \<psi> ^ j * \<psi>inv ^ i *
        (\<psi> ^ (j * 2) * \<psi>inv ^ (i * 2)) ^ ia)"], goal_cases)
        case (2 j')
        then show ?case using rew_psi[of j' j] by simp
      qed auto
    qed auto
    also have "\<dots> = (\<Sum>j' = 0..<n.
      (if j' = i then poly.coeff (of_qr f) j' * \<psi>^j' * \<psi>inv^i * (of_int_mod_ring n) else 0))"
    proof (subst sum.cong[of "{0..<n}" "{0..<n}"
      "(\<lambda>j'. poly.coeff (of_qr f) j' * \<psi> ^ j' * \<psi>inv ^ i *
        (\<Sum>j=0..<n. (\<psi> ^ (j' * 2) * \<psi>inv ^ (i * 2))^j))"
      "(\<lambda>j'. (if j' = i then poly.coeff (of_qr f) j' * \<psi>^j' * \<psi>inv^i *
        (of_int_mod_ring n) else 0))"], goal_cases)
      case (2 j')
      then show ?case proof (cases "j' = i")
        case True
        then have "(\<Sum>j=0..<n. (\<psi> ^ (j' * 2) * \<psi>inv ^ (i * 2))^j) = of_int_mod_ring n"
          unfolding True psi_inv_exp
          by (metis kyber_ntt.sum_rules(5) mult.right_neutral power_one sum.cong)
        then show ?thesis using True by auto
      next
        case False
        have not1: "\<psi> ^ (j' * 2) * \<psi>inv ^ (i * 2) \<noteq> 1"
        proof -
          have "\<omega>^j' * \<mu> ^i \<noteq> 1"
          proof (cases "j'<i")
            case True
            have *: "\<omega>^j' * \<mu> ^i = \<mu>^(i-j')" using True
            by (metis (no_types, lifting) le_add_diff_inverse less_or_eq_imp_le
              mult.assoc mult_cancel_right2 power_add power_mult psi_inv_exp
              psi_properties(1) psiinv_prop)
            show ?thesis proof (unfold *, rule ccontr)
              assume "\<not> \<mu> ^ (i - j') \<noteq> 1"
              then have 1: "\<mu> ^ (i - j') = 1" by auto
              show False using mu_prop'[OF 1] \<open>j'\<noteq>i\<close>
              using True less_imp_diff_less that diff_is_0_eq leD by blast
            qed
          next
            case False
            have 2: "\<omega>^j' * \<mu> ^i = \<omega>^(j'-i)" using False
            by (smt (verit) Nat.add_diff_assoc ab_semigroup_mult_class.mult_ac(1)
              add_diff_cancel_left' left_right_inverse_power linorder_not_less
              mu_properties(1) mult.commute mult_numeral_1_right numeral_One power_add)
            show ?thesis proof (unfold 2, rule ccontr)
              assume "\<not> \<omega> ^ (j' - i) \<noteq> 1"
              then have 1: "\<omega> ^ (j' - i) = 1" by auto
              have "n > j' - i" using \<open>j' \<in> {0..<n}\<close> by auto
              then show False using omega_prop'[OF 1] \<open>j'\<noteq>i\<close>
              using False
              by (meson diff_is_0_eq leD order_le_imp_less_or_eq)
            qed
          qed
          then show ?thesis
          by (metis mult.commute power_mult psi_properties(1) psiinv_prop)
        qed
        have "(1 - \<psi> ^ (j' * 2) * \<psi>inv ^ (i * 2)) *
          (\<Sum>j=0..<n. (\<psi> ^ (j' * 2) * \<psi>inv ^ (i * 2))^j) = 0"
        proof (subst kyber_ntt.geo_sum, goal_cases)
          case 1
          then show ?case using not1 by auto
        next
          case 2
          then show ?case
          by (metis (no_types, opaque_lifting) cancel_comm_monoid_add_class.diff_cancel
            mu_properties(1) mult.commute omega_properties(1) power_mult power_mult_distrib
            power_one psi_properties(1) psiinv_prop)
        qed
        then have "(\<Sum>j=0..<n. (\<psi> ^ (j' * 2) * \<psi>inv ^ (i * 2))^j) = 0"
          using not1 by auto
        then show ?thesis using False by auto
      qed
    qed auto
    also have "\<dots> = poly.coeff (of_qr f) i * \<psi>^i * \<psi>inv^i * (of_int_mod_ring n)"
      by (subst sum.delta[of "{0..<n}" i], use \<open>i<n\<close> in auto)
    also have "\<dots> = (of_int_mod_ring n) * poly.coeff (of_qr f) i"
      by (simp add: psi_inv_exp)
    finally show ?thesis by blast
  qed
  then have rew_coeff: "(map (\<lambda>i. ninv * (\<Sum>j = 0..<n. \<Sum>n = 0..<n.
    poly.coeff (of_qr f) n * \<psi> ^ (n * (2 * j + 1)) * \<psi>inv ^ (i * (2 * j + 1)))) [0..<n]) =
    map (\<lambda>i. ninv * (of_int_mod_ring (int n) * poly.coeff (of_qr f) i)) [0..<n]"
  unfolding map_eq_conv by auto
  show ?thesis unfolding inv_ntt_poly_def ntt_poly_def inv_ntt_coeffs_def ntt_coeffs_def
    inv_ntt_coeff_poly_def ntt_coeff_poly_def of_qr_to_qr map_upto_n_mod coeff_Poly
    apply (subst rew_sum)
    apply (subst sum_distrib_right)
    apply (subst rew_coeff)
    apply (subst mult.assoc[symmetric])
    apply (subst n_ninv')
    apply (subst mult_1)
    apply (subst Poly_map_coeff)
    subgoal using deg_of_qr deg_qr_n by fastforce
    subgoal unfolding to_qr_of_qr by auto
  done
qed

lemma ntt_inv_poly_correct:
"ntt_poly (inv_ntt_poly f) = f"
proof -
  have rew_sum: "(\<Sum>j = 0..<n. nth_default 0 (map (\<lambda>i. ninv *
    (\<Sum>j' = 0..<n. poly.coeff (of_qr f) j' * \<psi>inv ^ (i * (2 * j' + 1)))) [0..<n]) j *
      \<psi> ^ (j * (2 * i + 1))) =
    (\<Sum>j = 0..<n. ninv * (\<Sum>j' = 0..<n. poly.coeff (of_qr f) j' * \<psi>inv ^ (j * (2 * j' + 1)))
     * \<psi> ^ (j * (2 * i + 1)))"
    (is "(\<Sum>j = 0..<n. ?left j) = (\<Sum>j = 0..<n. ?right j)") for i
  proof (subst sum.cong[of "{0..<n}" "{0..<n}" ?left ?right], goal_cases)
    case (2 x)
    then show ?case by (subst nth_default_map[of x n], auto)
  qed auto
  have  "(\<Sum>j = 0..<n. \<Sum>n = 0..<n. ninv * (poly.coeff (of_qr f) n *
    \<psi>inv ^ (j * (2 * n + 1))) * \<psi> ^ (j * (2 * i + 1))) =
    ninv * (of_int_mod_ring (int n) * poly.coeff (of_qr f) i)" if "i<n" for i
  proof -
    have rew_psi: "\<psi>inv ^ (j' * (2 * j + 1)) * \<psi> ^ (j' * (2 * i + 1)) =
      (\<psi>inv ^ (j * 2) * \<psi> ^ (i * 2)) ^ j'"
      if "j'<n" "j<n" for j' j
    proof -
      have "\<psi>inv ^ (j' * (2 * j + 1)) * \<psi> ^ (j' * (2 * i + 1)) =
        \<psi>inv ^ (j' * (2 * j)) * \<psi> ^ (j' * (2 * i)) * \<psi>inv ^ j'  * \<psi> ^ j' "
      by (simp add: power_add)
      also have "\<dots> = (\<psi>inv ^ (2 * j) * \<psi> ^ (2 * i))^ j'"
      by (smt (verit, best) inv_psi_exp kyber_ntt.exp_rule mult.assoc
        mult.commute mult.right_neutral power_mult)
      also have "\<dots> = (\<psi>inv ^ (j * 2) * \<psi> ^ (i * 2)) ^ j'"
      by (simp add: mult.commute)
      finally show ?thesis by blast
    qed
    have "(\<Sum>j = 0..<n. \<Sum>j' = 0..<n. ninv * (poly.coeff (of_qr f) j' *
    \<psi>inv ^ (j * (2 * j' + 1))) * \<psi> ^ (j * (2 * i + 1))) =
      (\<Sum>j' = 0..<n. ninv * poly.coeff (of_qr f) j' *
        (\<Sum>j = 0..<n. (\<psi>inv ^ (j' * 2) * \<psi> ^ (i * 2))^j))"
    apply (subst sum_distrib_left, subst sum.swap, unfold mult.assoc[symmetric])
    proof (subst sum.cong[of "{0..<n}" "{0..<n}"
      "(\<lambda>j. \<Sum>ia = 0..<n. ninv * poly.coeff (of_qr f) j * \<psi>inv ^ (ia * (2 * j + 1)) *
           \<psi> ^ (ia * (2 * i + 1)))"
      "(\<lambda>j. \<Sum>n = 0..<n. ninv * poly.coeff (of_qr f) j *
           (\<psi>inv ^ (j * 2) * \<psi> ^ (i * 2)) ^ n)"], goal_cases)
      case (2 j)
      then show ?case
      proof (subst sum.cong[of "{0..<n}" "{0..<n}"
      "(\<lambda>ia. ninv * poly.coeff (of_qr f) j * \<psi>inv ^ (ia * (2 * j + 1)) *
        \<psi> ^ (ia * (2 * i + 1)))"
      "(\<lambda>ia. ninv * poly.coeff (of_qr f) j *
        (\<psi>inv ^ (j * 2) * \<psi> ^ (i * 2)) ^ ia)"], goal_cases)
        case (2 j')
        then show ?case using rew_psi[of j' j] by simp
      qed auto
    qed auto
    also have "\<dots> = (\<Sum>j' = 0..<n.
      (if j' = i then ninv * poly.coeff (of_qr f) j' *
        \<psi>inv^j' * \<psi>^i * (of_int_mod_ring n) else 0))"
    (is "(\<Sum>j' = 0..<n. ?right j') = (\<Sum>j' = 0..<n. ?left j')")
    proof (subst sum.cong[of "{0..<n}" "{0..<n}" "?right" "?left"], goal_cases)
      case (2 j')
      then show ?case proof (cases "j' = i")
        case True
        then have "(\<Sum>j=0..<n. (\<psi>inv ^ (j' * 2) * \<psi> ^ (i * 2))^j) = of_int_mod_ring n"
          unfolding True psi_inv_exp
          by (metis kyber_ntt.sum_const mult.commute mult.right_neutral
          power_one psi_inv_exp sum.cong)
        then show ?thesis using True
        by (simp add: inv_psi_exp)
      next
        case False
        have not1: "\<psi>inv ^ (j' * 2) * \<psi> ^ (i * 2) \<noteq> 1"
        proof -
          have "\<mu>^j' * \<omega> ^i \<noteq> 1"
          proof (cases "j'<i")
            case True
            have *: "\<mu>^j' * \<omega> ^i = \<omega>^(i-j')" using True
            by (smt (verit, best) add.commute kyber_ntt.omega_properties(1)
              le_add_diff_inverse left_right_inverse_power less_or_eq_imp_le
              mu_properties(1) mult.left_commute mult_cancel_right1 power_add)
            show ?thesis proof (unfold *, rule ccontr)
              assume "\<not> \<omega> ^ (i - j') \<noteq> 1"
              then have 1: "\<omega> ^ (i - j') = 1" by auto
              show False using omega_prop'[OF 1] \<open>j'\<noteq>i\<close>
              using True less_imp_diff_less that diff_is_0_eq leD by blast
            qed
          next
            case False
            have 2: "\<mu>^j' * \<omega> ^i = \<mu>^(j'-i)" using False
            by (smt (verit) Nat.add_diff_assoc ab_semigroup_mult_class.mult_ac(1)
              add_diff_cancel_left' left_right_inverse_power linorder_not_less
              mu_properties(1) mult.commute mult_numeral_1_right numeral_One power_add)
            show ?thesis proof (unfold 2, rule ccontr)
              assume "\<not> \<mu> ^ (j' - i) \<noteq> 1"
              then have 1: "\<mu> ^ (j' - i) = 1" by auto
              have "n > j' - i" using \<open>j' \<in> {0..<n}\<close> by auto
              then show False using mu_prop'[OF 1] \<open>j'\<noteq>i\<close>
              using False
              by (meson diff_is_0_eq leD order_le_imp_less_or_eq)
            qed
          qed
          then show ?thesis
          by (metis mult.commute power_mult psi_properties(1) psiinv_prop)
        qed
        have "(1 - \<psi>inv ^ (j' * 2) * \<psi> ^ (i * 2)) *
          (\<Sum>j=0..<n. (\<psi>inv ^ (j' * 2) * \<psi> ^ (i * 2))^j) = 0"
        proof (subst kyber_ntt.geo_sum, goal_cases)
          case 1
          then show ?case using not1 by auto
        next
          case 2
          then show ?case
          by (metis (no_types, opaque_lifting) cancel_comm_monoid_add_class.diff_cancel
            mu_properties(1) mult.commute omega_properties(1) power_mult power_mult_distrib
            power_one psi_properties(1) psiinv_prop)
        qed
        then have "(\<Sum>j=0..<n. (\<psi>inv ^ (j' * 2) * \<psi> ^ (i * 2))^j) = 0"
          using not1 by auto
        then show ?thesis using False by auto
      qed
    qed auto
    also have "\<dots> = ninv * poly.coeff (of_qr f) i * \<psi>inv^i * \<psi>^i * (of_int_mod_ring n)"
      by (subst sum.delta[of "{0..<n}" i], use \<open>i<n\<close> in auto)
    also have "\<dots> = ninv * ((of_int_mod_ring n) * poly.coeff (of_qr f) i)"
      by (simp add: psi_inv_exp mult.commute)
    finally show ?thesis by blast
  qed
  then have rew_coeff: "(map (\<lambda>i. \<Sum>j = 0..<n. \<Sum>n = 0..<n. ninv * (poly.coeff (of_qr f) n *
    \<psi>inv ^ (j * (2 * n + 1))) * \<psi> ^ (j * (2 * i + 1))) [0..<n]) =
    map (\<lambda>i. ninv * (of_int_mod_ring (int n) * poly.coeff (of_qr f) i)) [0..<n]"
  unfolding map_eq_conv by auto
  show ?thesis unfolding inv_ntt_poly_def ntt_poly_def inv_ntt_coeffs_def ntt_coeffs_def
    inv_ntt_coeff_poly_def ntt_coeff_poly_def of_qr_to_qr map_upto_n_mod coeff_Poly
    apply (subst rew_sum)
    apply (subst sum_distrib_left)
    apply (subst sum_distrib_right)
    apply (subst rew_coeff)
    apply (subst mult.assoc[symmetric])
    apply (subst n_ninv')
    apply (subst mult_1)
    apply (subst Poly_map_coeff)
    subgoal using deg_of_qr deg_qr_n by fastforce
    subgoal unfolding to_qr_of_qr by auto
  done
qed

text \<open>The multiplication of two polynomials can be computed by the NTT.\<close>

lemma convolution_thm_ntt_poly:
  "f*g = inv_ntt_poly (qr_mult_coeffs (ntt_poly f) (ntt_poly g))"
unfolding ntt_mult[symmetric] inv_ntt_poly_correct by auto

end
end


theory Auxiliary
  imports Main "HOL-Library.Extended_Nonnegative_Real"
begin

section \<open>Auxiliary Material\<close>

syntax
  "_MAX" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3MAX_\<in>_./ _)" [0, 0, 10] 10)

translations
  "MAX x\<in>A. B"  \<rightleftharpoons> "CONST Max ((\<lambda>x. B) ` A)"

context
  fixes S :: "'s set"
  assumes "finite S"
begin

lemma Max_image_commute:
  "(MAX x \<in> S. MAX y \<in> S. f x y) = (MAX y \<in> S. MAX x \<in> S. f x y)"
proof (rule Max_eq_if, goal_cases)
  case 3
  { fix a assume "a \<in> S"
    with Max_in[OF finite_imageI[OF \<open>finite S\<close>], of "f a"] have "Max (f a ` S) \<in> f a ` S"
      by auto
    then obtain b where "f a b = Max (f a ` S)" "b \<in> S"
      by auto
    from \<open>a \<in> S\<close> have "f a b \<le> (MAX a \<in> S. f a b)"
      by (auto intro: Max_ge finite_imageI[OF \<open>finite S\<close>])
    with \<open>f a b = _\<close> \<open>b \<in> S\<close> have "\<exists>b\<in>S. Max (f a ` S) \<le> (MAX a \<in> S. f a b)"
      by auto
  }
  then show ?case
    by auto
next
  case 4
  { fix b assume "b \<in> S"
    with Max_in[OF finite_imageI[OF \<open>finite S\<close>], of "\<lambda> a. f a b"] have
      "(MAX a \<in> S. f a b) \<in> (\<lambda>a. f a b) ` S"
      by auto
    then obtain a where "f a b = (MAX a \<in> S. f a b)" "a \<in> S"
      by auto
    from \<open>b \<in> S\<close> have "f a b \<le> Max (f a ` S)"
      by (auto intro: Max_ge finite_imageI[OF \<open>finite S\<close>])
    with \<open>f a b = _\<close> \<open>a \<in> S\<close> have "\<exists>a\<in>S. (MAX a \<in> S. f a b) \<le> Max (f a ` S)"
      by auto
  }
    then show ?case
      by auto
  qed (use \<open>finite S\<close> in auto)

lemma Max_image_left_mult:
  "(MAX x \<in> S. c * f x) = (c :: ennreal) * (MAX x \<in> S. f x)" if "S \<noteq> {}"
  apply (rule Max_eqI)
  subgoal
    using \<open>finite S\<close> by auto
  subgoal for y
    using \<open>finite S\<close> by (auto intro: mult_left_mono)
  subgoal
    using Max_in[OF finite_imageI[OF \<open>finite S\<close>], of f] \<open>S \<noteq> {}\<close> by auto
  done

end (* Finite set *)

lemma Max_to_image:
  "Max {f t | t. t \<in> S} = Max (f ` S)"
  by (rule arg_cong[where f = Max]) auto

lemma Max_to_image2:
  "Max {f t | t. P t} = Max (f ` {t. P t})"
  by (rule arg_cong[where f = Max]) auto

lemma Max_image_cong:
  "Max (f ` S) = Max (g ` T)" if "S = T" "\<And>x. x \<in> T \<Longrightarrow> f x = g x"
  by (intro arg_cong[where f = Max] image_cong[OF that])

lemma Max_image_cong_simp:
  "Max (f ` S) = Max (g ` T)" if "S = T" "\<And>x. x \<in> T =simp=> f x = g x"
  using Max_image_cong[OF that[unfolded simp_implies_def]] .

lemma Max_eq_image_if:
  assumes
    "finite S" "finite T" "\<forall>x \<in> S. \<exists>y \<in> T. f x \<le> g y" "\<forall>x \<in> T. \<exists>y \<in> S. g x \<le> f y"
  shows "Max (f ` S) = Max (g ` T)"
  using assms by (auto intro: Max_eq_if)

theorem Max_in_image:
  assumes "finite A" and "A \<noteq> {}"
  obtains x where "x \<in> A" and "Max (f ` A) = f x"
proof -
  from Max_in[of "f ` A"] assms have "Max (f ` A) \<in> f ` A"
    by auto
  then show ?thesis
    by (auto intro: that)
qed

lemma Max_ge_image:
  "Max (f ` S) \<ge> f x" if "finite S" "x \<in> S"
  using that by (auto intro: Max_ge)

lemma Max_image_pair:
  assumes "finite S" "finite T" "T \<noteq> {}"
  shows "(MAX s \<in> S. MAX t \<in> T. f s t) = (MAX (s, t) \<in> S \<times> T. f s t)"
proof ((rule Max_eq_image_if; clarsimp?), goal_cases)
  case (3 x)
  from \<open>finite T\<close> \<open>T \<noteq> {}\<close> obtain y where "y \<in> T" and "Max (f x ` T) = f x y"
    by (rule Max_in_image)
  with \<open>x \<in> S\<close> show ?case
    by auto
next
  case (4 a b)
  with \<open>finite T\<close> show ?case
    by force
qed (use assms in auto)

fun argmax where
  "argmax f (x # xs) =
    List.fold (\<lambda> a (b, v). let w = f a in if w > v then (a, w) else (b, v)) xs (x, f x)"

lemma list_cases:
  assumes "xs = [] \<Longrightarrow> P []"
      and "\<And> x. xs = [x] \<Longrightarrow> P [x]"
      and "\<And> x y ys. xs = (x # y # ys) \<Longrightarrow> P (x # y # ys)"
    shows "P xs"
  apply (cases xs)
   apply (simp add: assms)
  subgoal for y ys
    by (cases ys; simp add: assms)
  done

lemma argmax:
  assumes "xs \<noteq> []"
  shows
    "fst (argmax f xs) \<in> set xs" (is "?A")
    "f (fst (argmax f xs)) = snd (argmax f xs)" (is "?B")
    "snd (argmax f xs) = (MAX x \<in> set xs. f x)" (is "?C")
proof -
  let ?f = "\<lambda> a (b, v). let w = f a in if w > v then (a, w) else (b, v)"
  have "fst (List.fold ?f xs (x, f x)) \<in> {x} \<union> set xs" if "xs \<noteq> []" for x xs
    using that by (induction xs arbitrary: x rule: list_nonempty_induct)(auto simp: Let_def max_def)
  with \<open>xs \<noteq> []\<close> show ?A
    by (cases xs rule: list_cases; fastforce)
  have "f (fst (List.fold ?f xs (x, f x))) = snd (List.fold ?f xs (x, f x))" if "xs \<noteq> []" for x xs
    using that by (induction xs arbitrary: x rule: list_nonempty_induct)(auto simp: Let_def max_def)
  with \<open>xs \<noteq> []\<close> show ?B
    by (cases xs rule: list_cases; fastforce)
  have "snd (List.fold ?f xs (x, f x)) = (MAX x \<in> {x} \<union> set xs. f x)"if "xs \<noteq> []" for x xs
    using that by (induction xs arbitrary: x rule: list_nonempty_induct)(auto simp: Let_def max_def)
  with \<open>xs \<noteq> []\<close> show ?C
    by (cases xs rule: list_cases; fastforce)
qed

end (* Theory *)


(*  Title:      FOL/ex/Foundation.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1991  University of Cambridge
*)

section "Intuitionistic FOL: Examples from The Foundation of a Generic Theorem Prover"

theory Foundation
imports IFOL
begin

lemma "A&B  --> (C-->A&C)"
apply (rule impI)
apply (rule impI)
apply (rule conjI)
prefer 2 apply assumption
apply (rule conjunct1)
apply assumption
done

text {*A form of conj-elimination*}
lemma
  assumes "A & B"
    and "A ==> B ==> C"
  shows C
apply (rule assms)
apply (rule conjunct1)
apply (rule assms)
apply (rule conjunct2)
apply (rule assms)
done

lemma
  assumes "!!A. ~ ~A ==> A"
  shows "B | ~B"
apply (rule assms)
apply (rule notI)
apply (rule_tac P = "~B" in notE)
apply (rule_tac [2] notI)
apply (rule_tac [2] P = "B | ~B" in notE)
prefer 2 apply assumption
apply (rule_tac [2] disjI1)
prefer 2 apply assumption
apply (rule notI)
apply (rule_tac P = "B | ~B" in notE)
apply assumption
apply (rule disjI2)
apply assumption
done

lemma
  assumes "!!A. ~ ~A ==> A"
  shows "B | ~B"
apply (rule assms)
apply (rule notI)
apply (rule notE)
apply (rule_tac [2] notI)
apply (erule_tac [2] notE)
apply (erule_tac [2] disjI1)
apply (rule notI)
apply (erule notE)
apply (erule disjI2)
done

lemma
  assumes "A | ~A"
    and "~ ~A"
  shows A
apply (rule disjE)
apply (rule assms)
apply assumption
apply (rule FalseE)
apply (rule_tac P = "~A" in notE)
apply (rule assms)
apply assumption
done

subsection "Examples with quantifiers"

lemma
  assumes "ALL z. G(z)"
  shows "ALL z. G(z)|H(z)"
apply (rule allI)
apply (rule disjI1)
apply (rule assms [THEN spec])
done

lemma "ALL x. EX y. x=y"
apply (rule allI)
apply (rule exI)
apply (rule refl)
done

lemma "EX y. ALL x. x=y"
apply (rule exI)
apply (rule allI)
apply (rule refl)?
oops

text {* Parallel lifting example. *}
lemma "EX u. ALL x. EX v. ALL y. EX w. P(u,x,v,y,w)"
apply (rule exI allI)
apply (rule exI allI)
apply (rule exI allI)
apply (rule exI allI)
apply (rule exI allI)
oops

lemma
  assumes "(EX z. F(z)) & B"
  shows "EX z. F(z) & B"
apply (rule conjE)
apply (rule assms)
apply (rule exE)
apply assumption
apply (rule exI)
apply (rule conjI)
apply assumption
apply assumption
done

text {* A bigger demonstration of quantifiers -- not in the paper. *}
lemma "(EX y. ALL x. Q(x,y)) -->  (ALL x. EX y. Q(x,y))"
apply (rule impI)
apply (rule allI)
apply (rule exE, assumption)
apply (rule exI)
apply (rule allE, assumption)
apply assumption
done

end


theory Lambda_Example
imports "~~/src/HOL/Library/Code_Prolog"
begin

subsection \<open>Lambda\<close>

datatype type =
    Atom nat
  | Fun type type    (infixr "\<Rightarrow>" 200)

datatype dB =
    Var nat
  | App dB dB (infixl "\<degree>" 200)
  | Abs type dB

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>" [90, 0] 91)
where
  "[]\<langle>i\<rangle> = None"
| "(x # xs)\<langle>i\<rangle> = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>)"

inductive nth_el1 :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> bool"
where
  "nth_el1 (x # xs) 0 x"
| "nth_el1 xs i y \<Longrightarrow> nth_el1 (x # xs) (Suc i) y"

inductive typing :: "type list \<Rightarrow> dB \<Rightarrow> type \<Rightarrow> bool"  ("_ \<turnstile> _ : _" [50, 50, 50] 50)
  where
    Var [intro!]: "nth_el1 env x T \<Longrightarrow> env \<turnstile> Var x : T"
  | Abs [intro!]: "T # env \<turnstile> t : U \<Longrightarrow> env \<turnstile> Abs T t : (T \<Rightarrow> U)"
  | App [intro!]: "env \<turnstile> s : U \<Rightarrow> T \<Longrightarrow> env \<turnstile> t : T \<Longrightarrow> env \<turnstile> (s \<degree> t) : U"

primrec
  lift :: "[dB, nat] => dB"
where
    "lift (Var i) k = (if i < k then Var i else Var (i + 1))"
  | "lift (s \<degree> t) k = lift s k \<degree> lift t k"
  | "lift (Abs T s) k = Abs T (lift s (k + 1))"

primrec pred :: "nat => nat"
where
  "pred (Suc i) = i"

primrec
  subst :: "[dB, dB, nat] => dB"  ("_[_'/_]" [300, 0, 0] 300)
where
    subst_Var: "(Var i)[s/k] =
      (if k < i then Var (pred i) else if i = k then s else Var i)"
  | subst_App: "(t \<degree> u)[s/k] = t[s/k] \<degree> u[s/k]"
  | subst_Abs: "(Abs T t)[s/k] = Abs T (t[lift s 0 / k+1])"

inductive beta :: "[dB, dB] => bool"  (infixl "\<rightarrow>\<^sub>\<beta>" 50)
  where
    beta [simp, intro!]: "Abs T s \<degree> t \<rightarrow>\<^sub>\<beta> s[t/0]"
  | appL [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> s \<degree> u \<rightarrow>\<^sub>\<beta> t \<degree> u"
  | appR [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> u \<degree> s \<rightarrow>\<^sub>\<beta> u \<degree> t"
  | abs [simp, intro!]: "s \<rightarrow>\<^sub>\<beta> t ==> Abs T s \<rightarrow>\<^sub>\<beta> Abs T t"

subsection \<open>Inductive definitions for ordering on naturals\<close>

inductive less_nat
where
  "less_nat 0 (Suc y)"
| "less_nat x y ==> less_nat (Suc x) (Suc y)"

lemma less_nat[code_pred_inline]:
  "x < y = less_nat x y"
apply (rule iffI)
apply (induct x arbitrary: y)
apply (case_tac y) apply (auto intro: less_nat.intros)
apply (case_tac y)
apply (auto intro: less_nat.intros)
apply (induct rule: less_nat.induct)
apply auto
done

lemma [code_pred_inline]: "(x::nat) + 1 = Suc x"
by simp

section \<open>Manual setup to find counterexample\<close>

setup \<open>
  Context.theory_map
    (Quickcheck.add_tester ("prolog", (Code_Prolog.active, Code_Prolog.test_goals)))
\<close>

setup \<open>Code_Prolog.map_code_options (K
  { ensure_groundness = true,
    limit_globally = NONE,
    limited_types = [(@{typ nat}, 1), (@{typ "type"}, 1), (@{typ dB}, 1), (@{typ "type list"}, 1)],
    limited_predicates = [(["typing"], 2), (["nthel1"], 2)],
    replacing = [(("typing", "limited_typing"), "quickcheck"),
                 (("nthel1", "limited_nthel1"), "lim_typing")],
    manual_reorder = []})\<close>

lemma
  "\<Gamma> \<turnstile> t : U \<Longrightarrow> t \<rightarrow>\<^sub>\<beta> t' \<Longrightarrow> \<Gamma> \<turnstile> t' : U"
quickcheck[tester = prolog, iterations = 1, expect = counterexample]
oops

text \<open>Verifying that the found counterexample really is one by means of a proof\<close>

lemma
assumes
  "t' = Var 0"
  "U = Atom 0"
  "\<Gamma> = [Atom 1]"
  "t = App (Abs (Atom 0) (Var 1)) (Var 0)"
shows
  "\<Gamma> \<turnstile> t : U"
  "t \<rightarrow>\<^sub>\<beta> t'"
  "\<not> \<Gamma> \<turnstile> t' : U"
proof -
  from assms show "\<Gamma> \<turnstile> t : U"
    by (auto intro!: typing.intros nth_el1.intros)
next
  from assms have "t \<rightarrow>\<^sub>\<beta> (Var 1)[Var 0/0]"
    by (auto simp only: intro: beta.intros)
  moreover
  from assms have "(Var 1)[Var 0/0] = t'" by simp
  ultimately show "t \<rightarrow>\<^sub>\<beta> t'" by simp
next
  from assms show "\<not> \<Gamma> \<turnstile> t' : U"
    by (auto elim: typing.cases nth_el1.cases)
qed

end


header {* \isaheader{Auxiliary lemmas} *}

theory AuxLemmas imports Main begin

text {* Lemma concerning maps and @{text @} *}

lemma map_append_append_maps:
  assumes map:"map f xs = ys@zs"
  obtains xs' xs'' where "map f xs' = ys" and "map f xs'' = zs" and "xs=xs'@xs''"
by (metis append_eq_conv_conj append_take_drop_id assms drop_map take_map that)

text {* Lemma concerning splitting of @{term list}s *}

lemma  path_split_general:
assumes all:"\<forall>zs. xs \<noteq> ys@zs"
obtains j zs where "xs = (take j ys)@zs" and "j < length ys"
  and "\<forall>k > j. \<forall>zs'. xs \<noteq> (take k ys)@zs'"
proof(atomize_elim)
  from `\<forall>zs. xs \<noteq> ys@zs`
  show "\<exists>j zs. xs = take j ys @ zs \<and> j < length ys \<and>
               (\<forall>k>j. \<forall>zs'. xs \<noteq> take k ys @ zs')"
  proof(induct ys arbitrary:xs)
    case Nil thus ?case by auto
  next
    case (Cons y' ys')
    note IH = `\<And>xs. \<forall>zs. xs \<noteq> ys' @ zs \<Longrightarrow>
      \<exists>j zs. xs = take j ys' @ zs \<and> j < length ys' \<and>
      (\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs \<noteq> take k ys' @ zs'))`
    show ?case
    proof(cases xs)
      case Nil thus ?thesis by simp
    next
      case (Cons x' xs')
      with `\<forall>zs. xs \<noteq> (y' # ys') @ zs` have "x' \<noteq> y' \<or> (\<forall>zs. xs' \<noteq> ys' @ zs)"
        by simp
      show ?thesis
      proof(cases "x' = y'")
        case True
        with `x' \<noteq> y' \<or> (\<forall>zs. xs' \<noteq> ys' @ zs)` have "\<forall>zs. xs' \<noteq> ys' @ zs" by simp
        from IH[OF this] have "\<exists>j zs. xs' = take j ys' @ zs \<and> j < length ys' \<and>
          (\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs' \<noteq> take k ys' @ zs'))" .
        then obtain j zs where "xs' = take j ys' @ zs"
          and "j < length ys'"
          and all_sub:"\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs' \<noteq> take k ys' @ zs')"
          by blast
        from `xs' = take j ys' @ zs` True
          have "(x'#xs') = take (Suc j) (y' # ys') @ zs"
          by simp
        from all_sub True have all_imp:"\<forall>k. j < k \<longrightarrow>
          (\<forall>zs'. (x'#xs') \<noteq> take (Suc k) (y' # ys') @ zs')"
          by auto
        { fix l assume "(Suc j) < l"
          then obtain k where [simp]:"l = Suc k" by(cases l) auto
          with `(Suc j) < l` have "j < k" by simp
          with all_imp
          have "\<forall>zs'. (x'#xs') \<noteq> take (Suc k) (y' # ys') @ zs'"
            by simp
          hence "\<forall>zs'. (x'#xs') \<noteq> take l (y' # ys') @ zs'"
            by simp }
        with `(x'#xs') = take (Suc j) (y' # ys') @ zs` `j < length ys'` Cons
        show ?thesis by (metis Suc_length_conv less_Suc_eq_0_disj)
      next
        case False
        with Cons have "\<forall>i zs'. i > 0 \<longrightarrow> xs \<noteq> take i (y' # ys') @ zs'"
          by auto(case_tac i,auto)
        moreover
        have "\<exists>zs. xs = take 0 (y' # ys') @ zs" by simp
        ultimately show ?thesis by(rule_tac x="0" in exI,auto)
      qed
    qed
  qed
qed

end


(*
  File:    Minkowskis_Theorem.thy
  Author:  Manuel Eberl <manuel@pruvisto.org>

  A proof of Blichfeldt's and Minkowski's theorem about the relation between
  subsets of the Euclidean space, the Lebesgue measure, and the integer lattice.
*)
section \<open>Minkowski's theorem\<close>
theory Minkowskis_Theorem
  imports "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
begin

(* Could be generalised to arbitrary euclidean spaces and full-dimensional lattices *)

subsection \<open>Miscellaneous material\<close>

lemma bij_betw_UN:
  assumes "bij_betw f A B"
  shows   "(\<Union>n\<in>A. g (f n)) = (\<Union>n\<in>B. g n)"
  using assms by (auto simp: bij_betw_def)

definition of_int_vec where
  "of_int_vec v = (\<chi> i. of_int (v $ i))"

lemma of_int_vec_nth [simp]: "of_int_vec v $ n = of_int (v $ n)"
  by (simp add: of_int_vec_def)

lemma of_int_vec_eq_iff [simp]:
  "(of_int_vec a :: ('a :: ring_char_0) ^ 'n) = of_int_vec b \<longleftrightarrow> a = b"
  by (simp add: of_int_vec_def vec_eq_iff)

lemma inj_axis:
  assumes "c \<noteq> 0"
  shows   "inj (\<lambda>k. axis k c :: ('a :: {zero}) ^ 'n)"
proof
  fix x y :: 'n
  assume *: "axis x c = axis y c"
  have "axis x c $ x = axis x c $ y"
    by (subst *) simp
  thus "x = y" using assms
    by (auto simp: axis_def split: if_splits)
qed

lemma compactD:
  assumes "compact (A :: 'a :: metric_space set)" "range f \<subseteq> A"
  shows   "\<exists>h l. strict_mono (h::nat\<Rightarrow>nat) \<and> (f \<circ> h) \<longlonglongrightarrow> l"
  using assms unfolding compact_def by blast

lemma closed_lattice:
  fixes A :: "(real ^ 'n) set"
  assumes "\<And>v i. v \<in> A \<Longrightarrow> v $ i \<in> \<int>"
  shows   "closed A"
proof (rule discrete_imp_closed[OF zero_less_one], safe, goal_cases)
  case (1 x y)
  have "x $ i = y $ i" for i
  proof -
    from 1 and assms have "x $ i - y $ i \<in> \<int>"
      by auto
    then obtain m where m: "of_int m = (x $ i - y $ i)"
      by (elim Ints_cases) auto
    hence "of_int (abs m) = abs ((x - y) $ i)"
      by simp
    also have "\<dots> \<le> norm (x - y)"
      by (rule component_le_norm_cart)
    also have "\<dots> < of_int 1"
      using 1 by (simp add: dist_norm norm_minus_commute)
    finally have "abs m < 1"
      by (subst (asm) of_int_less_iff)
    thus "x $ i = y $ i"
      using m by simp
  qed
  thus "y = x"
    by (simp add: vec_eq_iff)
qed

subsection \<open>Auxiliary theorems about measure theory\<close>

lemma emeasure_lborel_cbox_eq':
  "emeasure lborel (cbox a b) = ennreal (\<Prod>e\<in>Basis. max 0 ((b - a) \<bullet> e))"
proof (cases "\<forall>ba\<in>Basis. a \<bullet> ba \<le> b \<bullet> ba")
  case True
  hence "emeasure lborel (cbox a b) = ennreal (prod ((\<bullet>) (b - a)) Basis)"
    unfolding emeasure_lborel_cbox_eq by auto
  also have "prod ((\<bullet>) (b - a)) Basis = (\<Prod>e\<in>Basis. max 0 ((b - a) \<bullet> e))"
    using True by (intro prod.cong refl) (auto simp: max_def inner_simps)
  finally show ?thesis .
next
  case False
  hence "emeasure lborel (cbox a b) = ennreal 0"
    by (auto simp: emeasure_lborel_cbox_eq)
  also from False have "0 = (\<Prod>e\<in>Basis. max 0 ((b - a) \<bullet> e))"
    by (auto simp: max_def inner_simps)
  finally show ?thesis .
qed

lemma emeasure_lborel_cbox_cart_eq:
  fixes a b :: "real ^ ('n :: finite)"
  shows "emeasure lborel (cbox a b) = ennreal (\<Prod>i \<in> UNIV. max 0 ((b - a) $ i))"
proof -
  have "emeasure lborel (cbox a b) = ennreal (\<Prod>e\<in>Basis. max 0 ((b - a) \<bullet> e))"
    unfolding emeasure_lborel_cbox_eq' ..
  also have "(Basis :: (real ^ 'n) set) = range (\<lambda>k. axis k 1)"
    unfolding Basis_vec_def by auto
  also have "(\<Prod>e\<in>\<dots>. max 0 ((b - a) \<bullet> e)) = (\<Prod> i \<in> UNIV . max 0 ((b - a) $ i))"
    by (subst prod.reindex) (auto intro!: inj_axis simp: algebra_simps inner_axis)
  finally show ?thesis .
qed

lemma sum_emeasure':
  assumes [simp]: "finite A"
  assumes [measurable]: "\<And>x. x \<in> A \<Longrightarrow> B x \<in> sets M"
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> emeasure M (B x \<inter> B y) = 0"
  shows   "(\<Sum>x\<in>A. emeasure M (B x)) = emeasure M (\<Union>x\<in>A. B x)"
proof -
  define C where "C = (\<Union>x\<in>A. \<Union>y\<in>(A-{x}). B x \<inter> B y)"
  have C: "C \<in> null_sets M"
    unfolding C_def using assms
    by (intro null_sets.finite_UN) (auto simp: null_sets_def)
  hence [measurable]: "C \<in> sets M" and [simp]: "emeasure M C = 0"
    by (simp_all add: null_sets_def)
  have "(\<Union>x\<in>A. B x) = (\<Union>x\<in>A. B x - C) \<union> C"
    by (auto simp: C_def)
  also have "emeasure M \<dots> = emeasure M (\<Union>x\<in>A. B x - C)"
    by (subst emeasure_Un_null_set) (auto intro!: sets.Un sets.Diff)
  also from assms have "\<dots> = (\<Sum>x\<in>A. emeasure M (B x - C))"
    by (subst sum_emeasure)
       (auto simp: disjoint_family_on_def C_def intro!: sets.Diff sets.finite_UN)
  also have "\<dots> = (\<Sum>x\<in>A. emeasure M (B x))"
    by (intro sum.cong refl emeasure_Diff_null_set) auto
  finally show ?thesis ..
qed

lemma sums_emeasure':
  assumes [measurable]: "\<And>x. B x \<in> sets M"
  assumes "\<And>x y. x \<noteq> y \<Longrightarrow> emeasure M (B x \<inter> B y) = 0"
  shows   "(\<lambda>x. emeasure M (B x)) sums emeasure M (\<Union>x. B x)"
proof -
  define C where "C = (\<Union>x. \<Union>y\<in>-{x}. B x \<inter> B y)"
  have C: "C \<in> null_sets M"
    unfolding C_def using assms
    by (intro null_sets_UN') (auto simp: null_sets_def)
  hence [measurable]: "C \<in> sets M" and [simp]: "emeasure M C = 0"
    by (simp_all add: null_sets_def)
  have "(\<Union>x. B x) = (\<Union>x. B x - C) \<union> C"
    by (auto simp: C_def)
  also have "emeasure M \<dots> = emeasure M (\<Union>x. B x - C)"
    by (subst emeasure_Un_null_set) (auto intro!: sets.Un sets.Diff)
  also from assms have "(\<lambda>x. emeasure M (B x - C)) sums \<dots>  "
    by (intro sums_emeasure)
       (auto simp: disjoint_family_on_def C_def intro!: sets.Diff sets.finite_UN)
  also have "(\<lambda>x. emeasure M (B x - C)) = (\<lambda>x. emeasure M (B x))"
    by (intro ext emeasure_Diff_null_set) auto
  finally show ?thesis .
qed

subsection \<open>Blichfeldt's theorem\<close>

text \<open>
  Blichfeldt's theorem states that, given a subset of $\mathbb{R}^n$ with $n > 0$ and a
  volume of more than 1, there exist two different points in that set whose difference
  vector has integer components.

  This will be the key ingredient in proving Minkowski's theorem.

  Note that in the HOL Light version, it is additionally required -- both for
  Blichfeldt's theorem and for Minkowski's theorem -- that the set is bounded,
  which we do not need.
\<close>
proposition blichfeldt:
  fixes S :: "(real ^ 'n) set"
  assumes [measurable]: "S \<in> sets lebesgue"
  assumes "emeasure lebesgue S > 1"
  obtains x y where "x \<noteq> y" and "x \<in> S" and "y \<in> S" and "\<And>i. (x - y) $ i \<in> \<int>"
proof -
  \<comment> \<open>We define for each lattice point in $\mathbb{Z}^n$ the corresponding cell in $\mathbb{R}^n$.\<close>
  define R :: "int ^ 'n \<Rightarrow> (real ^ 'n) set"
    where "R = (\<lambda>a. cbox (of_int_vec a) (of_int_vec (a + 1)))"

  \<comment> \<open>For each lattice point, we can intersect the cell it defines with our set @{term S}
      to obtain a partitioning of @{term S}.\<close>
  define T :: "int ^ 'n \<Rightarrow> (real ^ 'n) set"
    where "T = (\<lambda>a. S \<inter> R a)"

  \<comment> \<open>We can then translate each such partition into the cell at the origin, i.\,e. the
      unit box @{term "R 0"}.\<close>
  define T' :: "int ^ 'n \<Rightarrow> (real ^ 'n) set"
    where "T' = (\<lambda>a. (\<lambda>x. x - of_int_vec a) ` T a)"
  have T'_altdef: "T' a = (\<lambda>x. x + of_int_vec a) -` T a" for a
    unfolding T'_def by force

  \<comment> \<open>We need to show measurability of all the defined sets.\<close>
  have [measurable, simp]: "R a \<in> sets lebesgue" for a
    unfolding R_def by simp
  have [measurable, simp]: "T a \<in> sets lebesgue" for a
    unfolding T_def by auto
  have "(\<lambda>x::real^'n. x + of_int_vec a) \<in> lebesgue \<rightarrow>\<^sub>M lebesgue" for a
    using lebesgue_affine_measurable[of "\<lambda>_. 1" "of_int_vec a"]
    by (auto simp: euclidean_representation add_ac)
  from measurable_sets[OF this, of "T a" a for a]
    have [measurable, simp]: "T' a \<in> sets lebesgue" for a
      unfolding T'_altdef by simp

  \<comment> \<open>Obviously, the original set @{term S} is the union of all the lattice
      point cell partitions.\<close>
  have S_decompose: "S = (\<Union>a. T a)" unfolding T_def
  proof safe
    fix x assume x: "x \<in> S"
    define a where "a = (\<chi> i. \<lfloor>x $ i\<rfloor>)"
    have "x \<in> R a"
      unfolding R_def
      by (auto simp: cbox_interval less_eq_vec_def of_int_vec_def a_def)
    with x show "x \<in> (\<Union>a. S \<inter> R a)" by auto
  qed

  \<comment> \<open>Translating the partitioned subsets does not change their volume.\<close>
  have emeasure_T': "emeasure lebesgue (T' a) = emeasure lebesgue (T a)" for a
  proof -
    have "T' a = (\<lambda>x. 1 *\<^sub>R x + (- of_int_vec a)) ` T a"
      by (simp add: T'_def)
    also have "emeasure lebesgue \<dots> = emeasure lebesgue (T a)"
      by (subst emeasure_lebesgue_affine) auto
    finally show ?thesis
      by simp
  qed

  \<comment> \<open>Each translated partition of @{term S} is a subset of the unit cell at the origin.\<close>
  have T'_subset: "T' a \<subseteq> cbox 0 1" for a
    unfolding T'_def T_def R_def
    by (auto simp: algebra_simps cbox_interval of_int_vec_def less_eq_vec_def)

  \<comment> \<open>It is clear that the intersection of two different lattice point cells is a null set.\<close>
  have R_Int: "R a \<inter> R b \<in> null_sets lebesgue" if "a \<noteq> b" for a b
  proof -
    from that obtain i where i: "a $ i \<noteq> b $ i"
      by (auto simp: vec_eq_iff)
    have "R a \<inter> R b = cbox (\<chi> i. max (a $ i) (b $ i)) (\<chi> i. min (a $ i + 1) (b $ i + 1))"
      unfolding Int_interval_cart R_def interval_cbox
      by (simp add: of_int_vec_def max_def min_def if_distrib cong: if_cong)
    hence "emeasure lebesgue (R a \<inter> R b) = emeasure lborel \<dots>"
      by simp
    also have "\<dots> = ennreal (\<Prod>i\<in>UNIV. max 0 (((\<chi> x. real_of_int (min (a $ x + 1) (b $ x + 1))) -
                                  (\<chi> x. real_of_int (max (a $ x) (b $ x)))) $ i))"
      (is "_ = ennreal ?P")
      unfolding emeasure_lborel_cbox_cart_eq by simp
    also have "?P = 0"
      using i by (auto simp: max_def intro!: exI[of _ i])
    finally show ?thesis
      by (auto simp: null_sets_def R_def)
  qed

  \<comment> \<open>Therefore, the intersection of two lattice point cell partitionings of @{term S} is
      also a null set.\<close>
  have T_Int: "T a \<inter> T b \<in> null_sets lebesgue" if "a \<noteq> b" for a b
  proof -
    have "T a \<inter> T b = (R a \<inter> R b) \<inter> S"
      by (auto simp: T_def)
    also have "\<dots> \<in> null_sets lebesgue"
      by (rule null_set_Int2) (insert that, auto intro: R_Int assms)
    finally show ?thesis .
  qed
  have emeasure_T_Int: "emeasure lebesgue (T a \<inter> T b) = 0" if "a \<noteq> b" for a b
    using T_Int[OF that] unfolding null_sets_def by blast

  \<comment> \<open>The set of lattice points $\mathbb{Z}^n$ is countably infinite, so there exists
      a bijection $f: \mathbb{N} \to \mathbb{Z}^n$. We need this for summing over all
      lattice points.\<close>
  define f :: "nat \<Rightarrow> int ^ 'n" where "f = from_nat_into UNIV"
  have "countable (UNIV :: (int ^ 'n) set)" "infinite (UNIV :: (int ^ 'n) set)"
    using infinite_UNIV_char_0 by simp_all
  from bij_betw_from_nat_into [OF this] have f: "bij f"
    by (simp add: f_def)

  \<comment> \<open>Suppose all the translated cell partitions @{term T'} are disjoint.\<close>
  {
    assume disjoint: "\<And>a b. a \<noteq> b \<Longrightarrow> T' a \<inter> T' b = {}"
    \<comment> \<open>We know by assumption that the volume of @{term S} is greater than 1.\<close>
    have "1 < emeasure lebesgue S" by fact
    also have "emeasure lebesgue S = emeasure lebesgue (\<Union>n. T' (f n))"
    proof -
      \<comment> \<open>The sum of the volumes of all the @{term T'} is precisely the volume
          of their union, which is @{term "S"}.\<close>
      have "S = (\<Union>a. T a)" by (rule S_decompose)
      also have "\<dots> = (\<Union>n. T (f n))"
        by (rule bij_betw_UN [OF f, symmetric])
      also have "(\<lambda>n. emeasure lebesgue (T (f n))) sums emeasure lebesgue \<dots>"
        by (intro sums_emeasure' emeasure_T_Int) (insert f, auto simp: bij_betw_def inj_on_def)
      also have "(\<lambda>n. emeasure lebesgue (T (f n))) = (\<lambda>n. emeasure lebesgue (T' (f n)))"
        by (simp add: emeasure_T')
      finally have "(\<lambda>n. emeasure lebesgue (T' (f n))) sums emeasure lebesgue S" .
      moreover have "(\<lambda>n. emeasure lebesgue (T' (f n))) sums emeasure lebesgue (\<Union>n. T' (f n))"
        using disjoint by (intro sums_emeasure)
                          (insert f, auto simp: disjoint_family_on_def bij_betw_def inj_on_def)
      ultimately show ?thesis
        by (auto simp: sums_iff)
    qed
    \<comment> \<open>On the other hand, all the translated partitions lie in the unit cell
        @{term "cbox (0 :: real ^ 'n) 1"}, so their combined volume cannot be
        greater than 1.\<close>
    also have "emeasure lebesgue (\<Union>n. T' (f n)) \<le> emeasure lebesgue (cbox 0 (1 :: real ^ 'n))"
      using T'_subset by (intro emeasure_mono) auto
    also have "\<dots> = 1"
      by (simp add: emeasure_lborel_cbox_cart_eq)
    \<comment> \<open>This leads to a contradiction.\<close>
    finally have False by simp
  }
  \<comment> \<open>Therefore, there exists a point that lies in two different translated partitions,
      which obviously corresponds two two points in the non-translated partitions
      whose difference is the difference between two lattice points and therefore
      has integer components.\<close>
  then obtain a b x where "a \<noteq> b" "x \<in> T' a" "x \<in> T' b"
    by auto
  thus ?thesis
    by (intro that[of "x + of_int_vec a" "x + of_int_vec b"])
       (auto simp: T'_def T_def algebra_simps)
qed

subsection \<open>Minkowski's theorem\<close>

text \<open>
  Minkowski's theorem now states that, given a convex subset of $\mathbb{R}^n$ that is
  symmetric around the origin and has a volume greater than $2^n$, that set must contain
  a non-zero point with integer coordinates.
\<close>
theorem minkowski:
  fixes B :: "(real ^ 'n) set"
  assumes "convex B" and symmetric: "uminus ` B \<subseteq> B"
  assumes meas_B [measurable]: "B \<in> sets lebesgue"
  assumes measure_B: "emeasure lebesgue B > 2 ^ CARD('n)"
  obtains x where "x \<in> B" and "x \<noteq> 0" and "\<And>i. x $ i \<in> \<int>"
proof -
  \<comment> \<open>We scale @{term B} with $\frac{1}{2}$.\<close>
  define B' where "B' = (\<lambda>x. 2 *\<^sub>R x) -` B"
  have meas_B' [measurable]: "B' \<in> sets lebesgue"
    using measurable_sets[OF lebesgue_measurable_scaling[of 2] meas_B]
    by (simp add: B'_def)
  have B'_altdef: "B' = (\<lambda>x. (1/2) *\<^sub>R x) ` B"
    unfolding B'_def by force

  \<comment> \<open>The volume of the scaled set is $2^n$ times smaller than the original set, and
      therefore still has a volume greater than 1.\<close>
  have "1 < ennreal ((1 / 2) ^ CARD('n)) * emeasure lebesgue B"
  proof (cases "emeasure lebesgue B")
    case (real x)
    have "ennreal (2 ^ CARD('n)) = 2 ^ CARD('n)"
      by (subst ennreal_power [symmetric]) auto
    also from measure_B and real have "\<dots> < ennreal x" by simp
    finally have "(2 ^ CARD('n)) < x"
      by (subst (asm) ennreal_less_iff) auto
    thus ?thesis
      using real by (simp add: ennreal_1 [symmetric] ennreal_mult' [symmetric]
                       ennreal_less_iff field_simps del: ennreal_1)
  qed (simp_all add: ennreal_mult_top)
  also have "\<dots> = emeasure lebesgue B'"
    unfolding B'_altdef using emeasure_lebesgue_affine[of "1/2" 0 B] by simp
  finally have *: "emeasure lebesgue B' > 1" .

  \<comment> \<open>We apply Blichfeldt's theorem to get two points whose difference vector has
      integer coefficients. It only remains to show that that difference vector is
      itself a point in the original set.\<close>
  obtain x y
    where xy: "x \<noteq> y" "x \<in> B'" "y \<in> B'" "\<And>i. (x - y) $ i \<in> \<int>"
    by (erule blichfeldt [OF meas_B' *])
  hence "2 *\<^sub>R x \<in> B" "2 *\<^sub>R y \<in> B" by (auto simp: B'_def)
  \<comment> \<open>Exploiting the symmetric of @{term B}, the reflection of @{term "2 *\<^sub>R y"} is
      also in @{term B}.\<close>
  moreover from this and symmetric have "-(2 *\<^sub>R y) \<in> B" by blast
  \<comment> \<open>Since @{term B} is convex, the mid-point between @{term "2 *\<^sub>R x"} and @{term "-2 *\<^sub>R y"}
      is also in @{term B}, and that point is simply @{term "x - y"} as desired.\<close>
  ultimately have "(1 / 2) *\<^sub>R 2 *\<^sub>R x + (1 / 2) *\<^sub>R (- 2 *\<^sub>R y) \<in> B"
    using \<open>convex B\<close> by (intro convexD) auto
  also have "(1 / 2) *\<^sub>R 2 *\<^sub>R x + (1 / 2) *\<^sub>R (- 2 *\<^sub>R y) = x - y"
    by simp
  finally show ?thesis using xy
    by (intro that[of "x - y"]) auto
qed

text \<open>
  If the set in question is compact, the restriction to the volume can be weakened
  to ``at least 1'' from ``greater than 1''.
\<close>
theorem minkowski_compact:
  fixes B :: "(real ^ 'n) set"
  assumes "convex B" and "compact B" and symmetric: "uminus ` B \<subseteq> B"
  assumes measure_B: "emeasure lebesgue B \<ge> 2 ^ CARD('n)"
  obtains x where "x \<in> B" and "x \<noteq> 0" and "\<And>i. x $ i \<in> \<int>"
proof (cases "emeasure lebesgue B = 2 ^ CARD('n)")
  \<comment> \<open>If the volume is greater than 1, we can just apply the theorem from before.\<close>
  case False
  with measure_B have less: "emeasure lebesgue B > 2 ^ CARD('n)"
    by simp
  from \<open>compact B\<close> have meas: "B \<in> sets lebesgue"
    by (intro sets_completionI_sets lborelD borel_closed compact_imp_closed)
  from minkowski[OF assms(1) symmetric meas less] and that
    show ?thesis by blast
next
  case True
  \<comment> \<open>If the volume is precisely one, we look at what happens when @{term B} is
      scaled with a factor of $1 + \varepsilon$.\<close>
  define B' where "B' = (\<lambda>\<epsilon>. (*\<^sub>R) (1 + \<epsilon>) ` B)"
  from \<open>compact B\<close> have compact': "compact (B' \<epsilon>)" for \<epsilon>
    unfolding B'_def by (intro compact_scaling)
  have B'_altdef: "B' \<epsilon> = (*\<^sub>R) (inverse (1 + \<epsilon>)) -` B" if \<epsilon>: "\<epsilon> > 0" for \<epsilon>
    using \<epsilon> unfolding B'_def by force

  \<comment> \<open>Since the scaled sets are convex, they are stable under scaling.\<close>
  have B_scale: "a *\<^sub>R x \<in> B" if "x \<in> B" "a \<in> {0..1}" for a x
  proof -
    have "((a + 1) / 2) *\<^sub>R x + (1 - ((a + 1) / 2)) *\<^sub>R (-x) \<in> B"
      using that and \<open>convex B\<close> and symmetric by (intro convexD) auto
    also have "((a + 1) / 2) *\<^sub>R x + (1 - ((a + 1) / 2)) *\<^sub>R (-x) =
                 (1 + a) *\<^sub>R ((1/2) *\<^sub>R (x + x)) - x"
      by (simp add: algebra_simps del: scaleR_half_double)
    also have "\<dots> = a *\<^sub>R x"
      by (subst scaleR_half_double) (simp add: algebra_simps)
    finally show "\<dots> \<in> B" .
  qed

  \<comment> \<open>This means that @{term B'} is monotonic.\<close>
  have B'_subset: "B' a \<subseteq> B' b" if "0 \<le> a" "a \<le> b" for a b
  proof
    fix x assume "x \<in> B' a"
    then obtain y where "x = (1 + a) *\<^sub>R y" "y \<in> B"
      by (auto simp: B'_def)
    moreover then have "(inverse (1 + b) * (1 + a)) *\<^sub>R y \<in> B"
      using that by (intro B_scale) (auto simp: field_simps)
    ultimately show "x \<in> B' b"
      using that by (force simp: B'_def)
  qed

  \<comment> \<open>We obtain some upper bound on the norm of @{term B}.\<close>
  from \<open>compact B\<close> have "bounded B"
    by (rule compact_imp_bounded)
  then obtain C where C: "norm x \<le> C" if "x \<in> B" for x
    unfolding bounded_iff by blast

  \<comment> \<open>We can then bound the distance of any point in a scaled set to the original set.\<close>
  have setdist_le: "setdist {x} B \<le> \<epsilon> * C" if "x \<in> B' \<epsilon>" and "\<epsilon> \<ge> 0" for x \<epsilon>
  proof -
    from that obtain y where y: "y \<in> B" and [simp]: "x = (1 + \<epsilon>) *\<^sub>R y"
      by (auto simp: B'_def)
    from y have "setdist {x} B \<le> dist x y"
      by (intro setdist_le_dist) auto
    also from that have "dist x y = \<epsilon> * norm y"
      by (simp add: dist_norm algebra_simps)
    also from y have "norm y \<le> C"
      by (rule C)
    finally show "setdist {x} B \<le> \<epsilon> * C"
      using that by (simp add: mult_left_mono)
  qed

  \<comment> \<open>By applying the standard Minkowski theorem to the a scaled set, we can see that
      any scaled set contains a non-zero point with integer coordinates.\<close>
  have "\<exists>v. v \<in> B' \<epsilon> - {0} \<and> (\<forall>i. v $ i \<in> \<int>)" if \<epsilon>: "\<epsilon> > 0" for \<epsilon>
  proof -
    from \<open>convex B\<close> have convex': "convex (B' \<epsilon>)"
      unfolding B'_def by (rule convex_scaling)
    from \<open>compact B\<close> have meas: "B' \<epsilon> \<in> sets lebesgue" unfolding B'_def
      by (intro sets_completionI_sets lborelD borel_closed compact_imp_closed compact_scaling)
    from symmetric have symmetric': "uminus ` B' \<epsilon> \<subseteq> B' \<epsilon>"
      by (auto simp: B'_altdef[OF \<epsilon>])

    have "2 ^ CARD('n) = ennreal (2 ^ CARD('n))"
      by (subst ennreal_power [symmetric]) auto
    hence "1 * emeasure lebesgue B < ennreal ((1 + \<epsilon>) ^ CARD('n)) * emeasure lebesgue B"
      using True and \<epsilon> by (intro ennreal_mult_strict_right_mono) (auto)
    also have "\<dots> = emeasure lebesgue (B' \<epsilon>)"
      using emeasure_lebesgue_affine[of "1+\<epsilon>" 0 B] and \<epsilon> by (simp add: B'_def)
    finally have measure_B': "emeasure lebesgue (B' \<epsilon>) > 2 ^ CARD('n)"
      using True by simp

    obtain v where "v \<in> B' \<epsilon>" "v \<noteq> 0" "\<And>i. v $ i \<in> \<int>"
      by (erule minkowski[OF convex' symmetric' meas measure_B'])
    thus ?thesis
      by blast
  qed
  hence "\<forall>n. \<exists>v. v \<in> B' (1/Suc n) - {0} \<and> (\<forall>i. v $ i \<in> \<int>)"
    by auto
  \<comment> \<open>In particular, this means we can choose some sequence tending to zero
      -- say $\frac{1}{n+1}$ -- and always find a lattice point in the scaled set.\<close>
  hence "\<exists>v. \<forall>n. v n \<in> B' (1/Suc n) - {0} \<and> (\<forall>i. v n $ i \<in> \<int>)"
    by (subst (asm) choice_iff)
  then obtain v where v: "v n \<in> B' (1/Suc n) - {0}" "v n $ i \<in> \<int>" for i n
    by blast

  \<comment> \<open>By the Bolzano--Weierstra{\ss} theorem, there exists a convergent subsequence of @{term v}.\<close>
  have "\<exists>h l. strict_mono (h::nat\<Rightarrow>nat) \<and> (v \<circ> h) \<longlonglongrightarrow> l"
  proof (rule compactD)
    show "compact (B' 1)" by (rule compact')
    show "range v \<subseteq> B' 1"
      using B'_subset[of "1/Suc n" 1 for n] and v by auto
  qed
  then obtain h l where h: "strict_mono h" and l: "(v \<circ> h) \<longlonglongrightarrow> l"
    by blast

  \<comment> \<open>Since the convergent subsequence tends to @{term l}, the distance of the
      sequence elements to @{term B} tends to the distance of @{term l} and @{term B}.
      Furthermore, the distance of the sequence elements is bounded by $(1+\varepsilon)C$,
      which tends to 0, so the distance of @{term l} to @{term B} must be 0.\<close>
  have "setdist {l} B \<le> 0"
  proof (rule tendsto_le)
    show "((\<lambda>x. setdist {x} B) \<circ> (v \<circ> h)) \<longlonglongrightarrow> setdist {l} B"
      by (intro continuous_imp_tendsto l continuous_at_setdist)
    show "(\<lambda>n. inverse (Suc (h n)) * C) \<longlonglongrightarrow> 0"
      by (intro tendsto_mult_left_zero filterlim_compose[OF _ filterlim_subseq[OF h]]
                LIMSEQ_inverse_real_of_nat)
    show "\<forall>\<^sub>F x in sequentially. ((\<lambda>x. setdist {x} B) \<circ> (v \<circ> h)) x
                                  \<le> inverse (real (Suc (h x))) * C"
      using setdist_le and v unfolding o_def
      by (intro always_eventually allI setdist_le) (auto simp: field_simps)
  qed auto
  hence "setdist {l} B = 0"
    by (intro antisym setdist_pos_le)
  with assms and \<open>compact B\<close> have "l \<in> B"
    by (subst (asm) setdist_eq_0_closed) (auto intro: compact_imp_closed)

  \<comment> \<open>It is also easy to see that, since the lattice is a closed set and all sequence
      elements lie on it, the limit @{term l} also lies on it.\<close>
  moreover have "l \<in> {l. \<forall>i. l $ i \<in> \<int>} - {0}"
    using v by (intro closed_sequentially[OF closed_lattice _ l]) auto
  ultimately show ?thesis using that by blast
qed

end


theory ex5_04 imports Main begin

inductive ev :: "nat \<Rightarrow> bool" where
ev0 : "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

lemma "\<not> ev (Suc (Suc (Suc 0)))" (is "\<not> ?e3")
proof
  assume ?e3 thus False
    proof cases
      assume "ev (Suc 0)" thus False
      proof cases qed
    qed
qed
end


(* Authors: F. Maric, M. Spasic, R. Thiemann *)
theory Linear_Poly_Maps
  imports Abstract_Linear_Poly
    "HOL-Library.Finite_Map"
    "HOL-Library.Monad_Syntax"
begin

(* ************************************************************************** *)
(* Executable implementation                                                  *)
(* ************************************************************************** *)
definition get_var_coeff :: "(var, rat) fmap \<Rightarrow> var \<Rightarrow> rat" where
  "get_var_coeff lp v == case fmlookup lp v of None \<Rightarrow> 0 | Some c \<Rightarrow> c"

definition set_var_coeff :: "var \<Rightarrow> rat \<Rightarrow> (var, rat) fmap \<Rightarrow> (var, rat) fmap" where
  "set_var_coeff v c lp ==
      if c = 0 then fmdrop v lp else fmupd v c lp"

lift_definition LinearPoly :: "(var, rat) fmap \<Rightarrow> linear_poly" is get_var_coeff
proof -
  fix fmap
  show "inv (get_var_coeff fmap)" unfolding inv_def
    by (rule finite_subset[OF _ dom_fmlookup_finite[of fmap]],
        auto intro: fmdom'I simp: get_var_coeff_def split: option.splits)
qed

definition ordered_keys :: "('a :: linorder, 'b)fmap \<Rightarrow> 'a list" where
  "ordered_keys m = sorted_list_of_set (fset (fmdom m))"

context includes fmap.lifting lifting_syntax
begin

lemma [transfer_rule]: "(pcr_fmap (=) (=) ===> pcr_linear_poly) (\<lambda> f x. case f x of None \<Rightarrow> 0 | Some x \<Rightarrow> x) LinearPoly"
  by (standard, transfer, auto simp:get_var_coeff_def fmap.pcr_cr_eq cr_fmap_def)

lift_definition linear_poly_map :: "linear_poly \<Rightarrow> (var, rat) fmap" is
  "\<lambda> lp x. if lp x = 0 then None else Some (lp x)" by (auto simp: dom_def)

lemma certificate[code abstype]:
  "LinearPoly (linear_poly_map lp) = lp"
  by (transfer, auto)

text\<open>Zero\<close>
definition zero :: "(var, rat)fmap" where "zero = fmempty"

lemma [code abstract]:
  "linear_poly_map 0 = zero" unfolding zero_def
  by (transfer, auto)

text\<open>Addition\<close>

definition add_monom :: "rat \<Rightarrow> var \<Rightarrow> (var, rat) fmap \<Rightarrow> (var, rat) fmap" where
  "add_monom c v lp == set_var_coeff v (c + get_var_coeff lp v) lp"

definition add :: "(var, rat) fmap \<Rightarrow> (var, rat) fmap \<Rightarrow> (var, rat) fmap" where
  "add lp1 lp2 = foldl (\<lambda> lp v. add_monom (get_var_coeff lp1 v) v lp) lp2 (ordered_keys lp1)"

lemma fmlookup_fold_not_mem: "x \<notin> set k1 \<Longrightarrow>
  fmlookup (foldl (\<lambda>lp v. add_monom (get_var_coeff P1 v) v lp) P2 k1) x
    = fmlookup P2 x"
  by (induct k1 arbitrary: P2, auto simp: lookup_add_monom)

lemma [code abstract]:
  "linear_poly_map (p1 + p2) = add (linear_poly_map p1) (linear_poly_map p2)"
proof (rule fmap_ext)
  fix x :: nat (* index *)
  let ?p1 = "fmlookup (linear_poly_map p1) x"
  let ?p2 = "fmlookup (linear_poly_map p2) x"
  define P1 where "P1 = linear_poly_map p1"
  define P2 where "P2 = linear_poly_map p2"
  define k1 where "k1 = ordered_keys P1"
  have k1: "distinct k1 \<and> fset (fmdom P1) = set k1" unfolding k1_def P1_def ordered_keys_def
    by auto
  have id: "fmlookup (linear_poly_map (p1 + p2)) x = (case ?p1 of None \<Rightarrow> ?p2 | Some y1 \<Rightarrow>
    (case ?p2 of None \<Rightarrow> Some y1 | Some y2 \<Rightarrow> if y1 + y2 = 0 then None else Some (y1 + y2)))"
    by (transfer, auto)
  show "fmlookup (linear_poly_map (p1 + p2)) x = fmlookup (add (linear_poly_map p1) (linear_poly_map p2)) x"
  proof (cases "fmlookup P1 x")
    case None
    from fmdom_notI[OF None] have "x \<notin> fset (fmdom P1)" by (meson notin_fset)
    with k1 have x: "x \<notin> set k1" by auto
    show ?thesis unfolding id P1_def[symmetric] P2_def[symmetric] None
      unfolding add_def k1_def[symmetric] fmlookup_fold_not_mem[OF x] by auto
  next
    case (Some y1)
    from fmdomI[OF this] have "x \<in> fset (fmdom P1)" by (meson notin_fset)
    with k1 have "x \<in> set k1" by auto
    from split_list[OF this] obtain bef aft where k1_id: "k1 = bef @ x # aft" by auto
    with k1 have x: "x \<notin> set bef" "x \<notin> set aft" by auto
    have xy1: "get_var_coeff P1 x = y1" using Some unfolding get_var_coeff_def by auto
    let ?P = "foldl (\<lambda>lp v. add_monom (get_var_coeff P1 v) v lp) P2 bef"
    show ?thesis unfolding id P1_def[symmetric] P2_def[symmetric] Some option.simps
      unfolding add_def k1_def[symmetric] k1_id foldl_append foldl_Cons
      unfolding fmlookup_fold_not_mem[OF x(2)] xy1
    proof -
      show "(case fmlookup P2 x of None \<Rightarrow> Some y1 | Some y2 \<Rightarrow> if y1 + y2 = 0 then None else Some (y1 + y2))
        = fmlookup (add_monom y1 x ?P) x"
      proof (cases "get_var_coeff ?P x + y1 = 0")
        case True
        from Some[unfolded P1_def] have y1: "y1 \<noteq> 0"
          by (transfer, auto split: if_splits)
        then show ?thesis unfolding lookup_add_monom(2)[OF True] using True
          unfolding get_var_coeff_def[of _ x] fmlookup_fold_not_mem[OF x(1)]
          by (auto split: option.splits)
      next
        case False
        show ?thesis unfolding lookup_add_monom(1)[OF False] using False
          unfolding get_var_coeff_def[of _ x] fmlookup_fold_not_mem[OF x(1)]
          by (auto split: option.splits)
      qed
    qed
  qed
qed

text\<open>Scaling\<close>
definition scale :: "rat \<Rightarrow> (var, rat) fmap \<Rightarrow> (var, rat) fmap" where
  "scale r lp = (if r = 0 then fmempty else (fmmap ((*) r) lp))"

lemma [code abstract]:
  "linear_poly_map (r *R p) = scale r (linear_poly_map p)"
proof (cases "r = 0")
  case True
  then have *: "(r = 0) = True" by simp
  show ?thesis unfolding scale_def * if_True using True
    by (transfer, auto)
next
  case False
  then have *: "(r = 0) = False" by simp
  show ?thesis unfolding scale_def * if_False using False
    by (transfer, auto)
qed

(* Coeff *)
lemma coeff_code [code]:
  "coeff lp = get_var_coeff (linear_poly_map lp)"
  by (rule ext, unfold get_var_coeff_def, transfer, auto)

(* Var *)
lemma Var_code[code abstract]:
  "linear_poly_map (Var x) = set_var_coeff x 1 fmempty"
  unfolding set_var_coeff_def
  by (transfer, auto split: if_splits simp: fun_eq_iff map_upd_def)

(* vars *)
lemma vars_code[code]: "vars lp = fset (fmdom (linear_poly_map lp))"
  by (transfer, auto simp: Transfer.Rel_def rel_fun_def pcr_fset_def cr_fset_def)

(* vars_list *)
lemma vars_list_code[code]: "vars_list lp = ordered_keys (linear_poly_map lp)"
  unfolding ordered_keys_def vars_code[symmetric]
  by (transfer, auto)

(* valuate *)
lemma valuate_code[code]:  "valuate lp val = (
  let lpm = linear_poly_map lp
  in sum_list (map (\<lambda> x. (the (fmlookup lpm x)) *R (val x)) (vars_list lp)))"
  unfolding Let_def
proof (subst sum_list_distinct_conv_sum_set)
  show "distinct (vars_list lp)"
    by (transfer, auto)
next
  show "lp \<lbrace> val \<rbrace> =
        (\<Sum>x\<in>set (vars_list lp). the (fmlookup (linear_poly_map lp) x) *R val x)"
    unfolding set_vars_list
    by (transfer, auto)
qed

end

lemma lp_monom_code[code]: "linear_poly_map (lp_monom c x) = (if c = 0 then fmempty else fmupd x c fmempty)"
proof (rule fmap_ext, goal_cases)
  case (1 y)
  include fmap.lifting
  show ?case by (cases "c = 0", (transfer, auto)+)
qed

instantiation linear_poly :: equal
begin

definition "equal_linear_poly x y = (linear_poly_map x = linear_poly_map y)"

instance
proof (standard, unfold equal_linear_poly_def, standard)
  fix x y
  assume "linear_poly_map x = linear_poly_map y"
  from arg_cong[OF this, of LinearPoly, unfolded certificate]
  show "x = y" .
qed auto
end

end