(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

header {* Recursive Definitions *}

theory OrdinalRec
imports OrdinalCont
begin

definition
  oPrec :: "ordinal \<Rightarrow> ordinal" where
  "oPrec x = (THE p. x = oSuc p)"

lemma oPrec_oSuc [simp]: "oPrec (oSuc x) = x"
by (unfold oPrec_def, rule the_equality, simp_all)

lemma oPrec_less: "\<exists>p. x = oSuc p \<Longrightarrow> oPrec x < x"
by clarsimp

definition
  ordinal_rec0 ::
    "['a, ordinal \<Rightarrow> 'a \<Rightarrow> 'a, (nat \<Rightarrow> 'a) \<Rightarrow> 'a, ordinal] \<Rightarrow> 'a" where
  "ordinal_rec0 z s l \<equiv> wfrec {(x,y). x < y} (\<lambda>F x.
    if x = 0 then z else
    if (\<exists>p. x = oSuc p) then s (oPrec x) (F (oPrec x)) else
    (THE y. \<forall>f. (\<forall>n. f n < oLimit f) \<and> oLimit f = x
            \<longrightarrow> l (\<lambda>n. F (f n)) = y))"

lemma ordinal_rec0_0:
"ordinal_rec0 z s l 0 = z"
 apply (rule trans[OF def_wfrec[OF ordinal_rec0_def wf]])
 apply simp
done

lemma ordinal_rec0_oSuc:
"ordinal_rec0 z s l (oSuc x) = s x (ordinal_rec0 z s l x)"
 apply (rule trans[OF def_wfrec[OF ordinal_rec0_def wf]])
 apply (simp add: cut_apply)
done

lemma limit_ordinal_not_0: "limit_ordinal x \<Longrightarrow> x \<noteq> 0"
by (clarsimp)

lemma limit_ordinal_not_oSuc: "limit_ordinal x \<Longrightarrow> x \<noteq> oSuc p"
by (clarsimp)

lemma ordinal_rec0_limit_ordinal:
"limit_ordinal x \<Longrightarrow> ordinal_rec0 z s l x =
 (THE y. \<forall>f. (\<forall>n. f n < oLimit f) \<and> oLimit f = x \<longrightarrow>
   l (\<lambda>n. ordinal_rec0 z s l (f n)) = y)"
 apply (rule trans[OF def_wfrec[OF ordinal_rec0_def wf]])
 apply (simp add: limit_ordinal_not_oSuc limit_ordinal_not_0)
 apply (rule_tac f=The in arg_cong, rule ext)
 apply (rule_tac f=All in arg_cong, rule ext)
 apply safe
  apply (simp add: cut_apply)
 apply (simp add: cut_apply)
done

subsection {* Partial orders *}

locale porder =
  fixes le  :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<<" 55)
assumes po_refl:    "\<And>x. x << x"
    and po_trans:   "\<And>x y z. \<lbrakk>x << y; y << z\<rbrakk> \<Longrightarrow> x << z"
    and po_antisym: "\<And>x y. \<lbrakk>x << y; y << x\<rbrakk> \<Longrightarrow> x = y"

lemma porder_order: "porder (op \<le> :: 'a::order \<Rightarrow> 'a \<Rightarrow> bool)"
 apply (rule porder.intro)
   apply (rule order_refl)
  apply (rule order_trans, assumption+)
 apply (rule order_antisym, assumption+)
done

lemma (in porder) flip: "porder (\<lambda>x y. y << x)"
 apply (rule porder.intro)
   apply (rule po_refl)
  apply (rule po_trans, assumption+)
 apply (rule po_antisym, assumption+)
done

locale omega_complete = porder +
fixes lub :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
assumes is_ub_lub: "\<And>f n. f n << lub f"
assumes is_lub_lub: "\<And>f x. \<forall>n. f n << x \<Longrightarrow> lub f << x"

lemma (in omega_complete) lub_cong_lemma:
"\<lbrakk>\<forall>n. f n < oLimit f; \<forall>m. g m < oLimit g; oLimit f \<le> oLimit g;
 \<forall>y<oLimit g. \<forall>x\<le>y. F x << F y\<rbrakk>
 \<Longrightarrow> lub (\<lambda>n. F (f n)) << lub (\<lambda>n. F (g n))"
 apply (rule is_lub_lub[rule_format])
 apply (subgoal_tac "f n < oLimit g")
  apply (drule less_oLimitD, clarify, rename_tac m)
  apply (drule_tac x="g m" in spec, drule mp)
   apply (erule spec)
  apply (drule_tac x="f n" in spec, drule mp)
   apply (erule order_less_imp_le)
  apply (erule po_trans)
  apply (rule is_ub_lub)
 apply (rule order_less_le_trans)
  apply (erule spec)
 apply assumption
done

lemma (in omega_complete) lub_cong:
"\<lbrakk>\<forall>n. f n < oLimit f; \<forall>m. g m < oLimit g; oLimit f = oLimit g;
 \<forall>y<oLimit g. \<forall>x\<le>y. F x << F y\<rbrakk>
 \<Longrightarrow> lub (\<lambda>n. F (f n)) = lub (\<lambda>n. F (g n))"
 apply (rule po_antisym)
  apply (rule lub_cong_lemma, assumption+)
   apply (simp add: po_refl)
  apply assumption
 apply (rule lub_cong_lemma, assumption+)
  apply (simp add: po_refl)
 apply (drule sym, simp)
done

lemma (in omega_complete) ordinal_rec0_mono_lemma:
assumes s: "\<forall>p x. x << s p x"
shows "\<forall>y\<le>w. \<forall>x\<le>y. ordinal_rec0 z s lub x << ordinal_rec0 z s lub y"
 apply (rule_tac a=w in oLimit_induct)
   apply (simp add: po_refl)
  apply clarify
  apply (erule le_oSucE, simp, clarsimp)
  apply (erule le_oSucE)
   apply (drule spec, drule mp, rule order_refl)
   apply (drule spec, drule mp, assumption)
   apply (erule po_trans)
   apply (simp add: ordinal_rec0_oSuc s)
  apply (simp add: po_refl)
 apply clarify
 apply (erule le_oLimitE)
  apply simp
 apply clarsimp
 apply (subgoal_tac "ordinal_rec0 z s lub (oLimit f) =
                     lub (\<lambda>n. ordinal_rec0 z s lub (f n))")
  apply (erule le_oLimitE)
   apply (drule_tac x=n in spec)
   apply (drule spec, drule mp, rule order_refl)
   apply (drule spec, drule mp, assumption)
   apply (erule po_trans)
   apply (simp, rule is_ub_lub)
  apply (simp add: po_refl)
 apply (simp only: ordinal_rec0_limit_ordinal strict_mono_limit_ordinal)
 apply (rule the_equality, clarify)
  apply (rule lub_cong, assumption)
    apply (simp add: strict_mono_less_oLimit)
   apply assumption
  apply clarify
  apply (drule less_oLimitD, clarify)
  apply (drule order_less_imp_le)
  apply simp
 apply (drule_tac x=f in spec, simp add: strict_mono_less_oLimit)
done

lemma (in omega_complete) ordinal_rec0_mono:
assumes s: "\<forall>p x. x << s p x"
shows "x \<le> y \<Longrightarrow> ordinal_rec0 z s lub x << ordinal_rec0 z s lub y"
 apply (rule ordinal_rec0_mono_lemma[OF s, rule_format])
  apply (rule order_refl)
 apply assumption
done

lemma (in omega_complete) ordinal_rec0_oLimit:
assumes s: "\<forall>p x. x << s p x"
shows "ordinal_rec0 z s lub (oLimit f) =
         lub (\<lambda>n. ordinal_rec0 z s lub (f n))"
 apply (case_tac "\<forall>n. f n < oLimit f")
  apply (simp add: ordinal_rec0_limit_ordinal limit_ordinal_oLimitI)
  apply (rule the_equality, clarify)
   apply (rule lub_cong, assumption+)
   apply clarify
   apply (erule ordinal_rec0_mono[OF s])
  apply (drule_tac x=f in spec, simp)
 apply (simp add: linorder_not_less, clarify)
 apply (rule po_antisym)
  apply (erule po_trans[OF ordinal_rec0_mono[OF s]])
  apply (rule is_ub_lub)
 apply (rule is_lub_lub[rule_format])
 apply (rule ordinal_rec0_mono[OF s le_oLimit])
done

subsection {* Recursive definitions for @{typ "ordinal => ordinal"} *}

definition
  ordinal_rec ::
    "[ordinal, ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal, ordinal] \<Rightarrow> ordinal" where
  "ordinal_rec z s = ordinal_rec0 z s oLimit"

lemma omega_complete_oLimit: "omega_complete (op \<le>) oLimit"
 apply (rule omega_complete.intro)
  apply (rule porder_order)
 apply (rule omega_complete_axioms.intro)
  apply (rule le_oLimit)
 apply (erule oLimit_leI)
done

lemma ordinal_rec_0 [simp]: "ordinal_rec z s 0 = z"
by (unfold ordinal_rec_def, rule ordinal_rec0_0)

lemma ordinal_rec_oSuc [simp]:
"ordinal_rec z s (oSuc x) = s x (ordinal_rec z s x)"
by (unfold ordinal_rec_def, rule ordinal_rec0_oSuc)

lemma ordinal_rec_oLimit:
assumes s: "\<forall>p x. x \<le> s p x"
shows "ordinal_rec z s (oLimit f) = oLimit (\<lambda>n. ordinal_rec z s (f n))"
 apply (unfold ordinal_rec_def)
 apply (rule omega_complete.ordinal_rec0_oLimit)
  apply (rule omega_complete_oLimit)
 apply (rule s)
done

lemma continuous_ordinal_rec:
assumes s: "\<forall>p x. x \<le> s p x"
shows "continuous (ordinal_rec z s)"
 apply (rule continuousI)
  apply (rule ordinal_rec_oLimit[OF s])
 apply (simp add: s)
done

lemma mono_ordinal_rec:
assumes s: "\<forall>p x. x \<le> s p x"
shows "mono (ordinal_rec z s)"
 apply (rule continuous.mono)
 apply (rule continuous_ordinal_rec[OF s])
done

lemma normal_ordinal_rec:
assumes s: "\<forall>p x. x < s p x"
shows "normal (ordinal_rec z s)"
 apply (rule normalI)
  apply (rule ordinal_rec_oLimit)
  apply (simp add: s order_less_imp_le)
 apply (simp add: s)
done

end


(*  Title:      ZF/Int_ZF.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge
*)

section\<open>The Integers as Equivalence Classes Over Pairs of Natural Numbers\<close>

theory Int_ZF imports EquivClass ArithSimp begin

definition
  intrel :: i  where
    "intrel == {p \<in> (nat*nat)*(nat*nat).
                \<exists>x1 y1 x2 y2. p=<<x1,y1>,<x2,y2>> & x1#+y2 = x2#+y1}"

definition
  int :: i  where
    "int == (nat*nat)//intrel"

definition
  int_of :: "i=>i" \<comment>\<open>coercion from nat to int\<close>    ("$# _" [80] 80)  where
    "$# m == intrel `` {<natify(m), 0>}"

definition
  intify :: "i=>i" \<comment>\<open>coercion from ANYTHING to int\<close>  where
    "intify(m) == if m \<in> int then m else $#0"

definition
  raw_zminus :: "i=>i"  where
    "raw_zminus(z) == \<Union><x,y>\<in>z. intrel``{<y,x>}"

definition
  zminus :: "i=>i"                                 ("$- _" [80] 80)  where
    "$- z == raw_zminus (intify(z))"

definition
  znegative   ::      "i=>o"  where
    "znegative(z) == \<exists>x y. x<y & y\<in>nat & <x,y>\<in>z"

definition
  iszero      ::      "i=>o"  where
    "iszero(z) == z = $# 0"

definition
  raw_nat_of  :: "i=>i"  where
  "raw_nat_of(z) == natify (\<Union><x,y>\<in>z. x#-y)"

definition
  nat_of  :: "i=>i"  where
  "nat_of(z) == raw_nat_of (intify(z))"

definition
  zmagnitude  ::      "i=>i"  where
  \<comment>\<open>could be replaced by an absolute value function from int to int?\<close>
    "zmagnitude(z) ==
     THE m. m\<in>nat & ((~ znegative(z) & z = $# m) |
                       (znegative(z) & $- z = $# m))"

definition
  raw_zmult   ::      "[i,i]=>i"  where
    (*Cannot use UN<x1,y2> here or in zadd because of the form of congruent2.
      Perhaps a "curried" or even polymorphic congruent predicate would be
      better.*)
     "raw_zmult(z1,z2) ==
       \<Union>p1\<in>z1. \<Union>p2\<in>z2.  split(%x1 y1. split(%x2 y2.
                   intrel``{<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}, p2), p1)"

definition
  zmult       ::      "[i,i]=>i"      (infixl "$*" 70)  where
     "z1 $* z2 == raw_zmult (intify(z1),intify(z2))"

definition
  raw_zadd    ::      "[i,i]=>i"  where
     "raw_zadd (z1, z2) ==
       \<Union>z1\<in>z1. \<Union>z2\<in>z2. let <x1,y1>=z1; <x2,y2>=z2
                           in intrel``{<x1#+x2, y1#+y2>}"

definition
  zadd        ::      "[i,i]=>i"      (infixl "$+" 65)  where
     "z1 $+ z2 == raw_zadd (intify(z1),intify(z2))"

definition
  zdiff        ::      "[i,i]=>i"      (infixl "$-" 65)  where
     "z1 $- z2 == z1 $+ zminus(z2)"

definition
  zless        ::      "[i,i]=>o"      (infixl "$<" 50)  where
     "z1 $< z2 == znegative(z1 $- z2)"

definition
  zle          ::      "[i,i]=>o"      (infixl "$\<le>" 50)  where
     "z1 $\<le> z2 == z1 $< z2 | intify(z1)=intify(z2)"

declare quotientE [elim!]

subsection\<open>Proving that @{term intrel} is an equivalence relation\<close>

(** Natural deduction for intrel **)

lemma intrel_iff [simp]:
    "<<x1,y1>,<x2,y2>>: intrel \<longleftrightarrow>
     x1\<in>nat & y1\<in>nat & x2\<in>nat & y2\<in>nat & x1#+y2 = x2#+y1"
by (simp add: intrel_def)

lemma intrelI [intro!]:
    "[| x1#+y2 = x2#+y1; x1\<in>nat; y1\<in>nat; x2\<in>nat; y2\<in>nat |]
     ==> <<x1,y1>,<x2,y2>>: intrel"
by (simp add: intrel_def)

lemma intrelE [elim!]:
  "[| p \<in> intrel;
      !!x1 y1 x2 y2. [| p = <<x1,y1>,<x2,y2>>;  x1#+y2 = x2#+y1;
                        x1\<in>nat; y1\<in>nat; x2\<in>nat; y2\<in>nat |] ==> Q |]
   ==> Q"
by (simp add: intrel_def, blast)

lemma int_trans_lemma:
     "[| x1 #+ y2 = x2 #+ y1; x2 #+ y3 = x3 #+ y2 |] ==> x1 #+ y3 = x3 #+ y1"
apply (rule sym)
apply (erule add_left_cancel)+
apply (simp_all (no_asm_simp))
done

lemma equiv_intrel: "equiv(nat*nat, intrel)"
apply (simp add: equiv_def refl_def sym_def trans_def)
apply (fast elim!: sym int_trans_lemma)
done

lemma image_intrel_int: "[| m\<in>nat; n\<in>nat |] ==> intrel `` {<m,n>} \<in> int"
by (simp add: int_def)

declare equiv_intrel [THEN eq_equiv_class_iff, simp]
declare conj_cong [cong]

lemmas eq_intrelD = eq_equiv_class [OF _ equiv_intrel]

(** int_of: the injection from nat to int **)

lemma int_of_type [simp,TC]: "$#m \<in> int"
by (simp add: int_def quotient_def int_of_def, auto)

lemma int_of_eq [iff]: "($# m = $# n) \<longleftrightarrow> natify(m)=natify(n)"
by (simp add: int_of_def)

lemma int_of_inject: "[| $#m = $#n;  m\<in>nat;  n\<in>nat |] ==> m=n"
by (drule int_of_eq [THEN iffD1], auto)

(** intify: coercion from anything to int **)

lemma intify_in_int [iff,TC]: "intify(x) \<in> int"
by (simp add: intify_def)

lemma intify_ident [simp]: "n \<in> int ==> intify(n) = n"
by (simp add: intify_def)

subsection\<open>Collapsing rules: to remove @{term intify}
            from arithmetic expressions\<close>

lemma intify_idem [simp]: "intify(intify(x)) = intify(x)"
by simp

lemma int_of_natify [simp]: "$# (natify(m)) = $# m"
by (simp add: int_of_def)

lemma zminus_intify [simp]: "$- (intify(m)) = $- m"
by (simp add: zminus_def)

(** Addition **)

lemma zadd_intify1 [simp]: "intify(x) $+ y = x $+ y"
by (simp add: zadd_def)

lemma zadd_intify2 [simp]: "x $+ intify(y) = x $+ y"
by (simp add: zadd_def)

(** Subtraction **)

lemma zdiff_intify1 [simp]:"intify(x) $- y = x $- y"
by (simp add: zdiff_def)

lemma zdiff_intify2 [simp]:"x $- intify(y) = x $- y"
by (simp add: zdiff_def)

(** Multiplication **)

lemma zmult_intify1 [simp]:"intify(x) $* y = x $* y"
by (simp add: zmult_def)

lemma zmult_intify2 [simp]:"x $* intify(y) = x $* y"
by (simp add: zmult_def)

(** Orderings **)

lemma zless_intify1 [simp]:"intify(x) $< y \<longleftrightarrow> x $< y"
by (simp add: zless_def)

lemma zless_intify2 [simp]:"x $< intify(y) \<longleftrightarrow> x $< y"
by (simp add: zless_def)

lemma zle_intify1 [simp]:"intify(x) $\<le> y \<longleftrightarrow> x $\<le> y"
by (simp add: zle_def)

lemma zle_intify2 [simp]:"x $\<le> intify(y) \<longleftrightarrow> x $\<le> y"
by (simp add: zle_def)

subsection\<open>@{term zminus}: unary negation on @{term int}\<close>

lemma zminus_congruent: "(%<x,y>. intrel``{<y,x>}) respects intrel"
by (auto simp add: congruent_def add_ac)

lemma raw_zminus_type: "z \<in> int ==> raw_zminus(z) \<in> int"
apply (simp add: int_def raw_zminus_def)
apply (typecheck add: UN_equiv_class_type [OF equiv_intrel zminus_congruent])
done

lemma zminus_type [TC,iff]: "$-z \<in> int"
by (simp add: zminus_def raw_zminus_type)

lemma raw_zminus_inject:
     "[| raw_zminus(z) = raw_zminus(w);  z \<in> int;  w \<in> int |] ==> z=w"
apply (simp add: int_def raw_zminus_def)
apply (erule UN_equiv_class_inject [OF equiv_intrel zminus_congruent], safe)
apply (auto dest: eq_intrelD simp add: add_ac)
done

lemma zminus_inject_intify [dest!]: "$-z = $-w ==> intify(z) = intify(w)"
apply (simp add: zminus_def)
apply (blast dest!: raw_zminus_inject)
done

lemma zminus_inject: "[| $-z = $-w;  z \<in> int;  w \<in> int |] ==> z=w"
by auto

lemma raw_zminus:
    "[| x\<in>nat;  y\<in>nat |] ==> raw_zminus(intrel``{<x,y>}) = intrel `` {<y,x>}"
apply (simp add: raw_zminus_def UN_equiv_class [OF equiv_intrel zminus_congruent])
done

lemma zminus:
    "[| x\<in>nat;  y\<in>nat |]
     ==> $- (intrel``{<x,y>}) = intrel `` {<y,x>}"
by (simp add: zminus_def raw_zminus image_intrel_int)

lemma raw_zminus_zminus: "z \<in> int ==> raw_zminus (raw_zminus(z)) = z"
by (auto simp add: int_def raw_zminus)

lemma zminus_zminus_intify [simp]: "$- ($- z) = intify(z)"
by (simp add: zminus_def raw_zminus_type raw_zminus_zminus)

lemma zminus_int0 [simp]: "$- ($#0) = $#0"
by (simp add: int_of_def zminus)

lemma zminus_zminus: "z \<in> int ==> $- ($- z) = z"
by simp

subsection\<open>@{term znegative}: the test for negative integers\<close>

lemma znegative: "[| x\<in>nat; y\<in>nat |] ==> znegative(intrel``{<x,y>}) \<longleftrightarrow> x<y"
apply (cases "x<y")
apply (auto simp add: znegative_def not_lt_iff_le)
apply (subgoal_tac "y #+ x2 < x #+ y2", force)
apply (rule add_le_lt_mono, auto)
done

(*No natural number is negative!*)
lemma not_znegative_int_of [iff]: "~ znegative($# n)"
by (simp add: znegative int_of_def)

lemma znegative_zminus_int_of [simp]: "znegative($- $# succ(n))"
by (simp add: znegative int_of_def zminus natify_succ)

lemma not_znegative_imp_zero: "~ znegative($- $# n) ==> natify(n)=0"
by (simp add: znegative int_of_def zminus Ord_0_lt_iff [THEN iff_sym])

subsection\<open>@{term nat_of}: Coercion of an Integer to a Natural Number\<close>

lemma nat_of_intify [simp]: "nat_of(intify(z)) = nat_of(z)"
by (simp add: nat_of_def)

lemma nat_of_congruent: "(\<lambda>x. (\<lambda>\<langle>x,y\<rangle>. x #- y)(x)) respects intrel"
by (auto simp add: congruent_def split: nat_diff_split)

lemma raw_nat_of:
    "[| x\<in>nat;  y\<in>nat |] ==> raw_nat_of(intrel``{<x,y>}) = x#-y"
by (simp add: raw_nat_of_def UN_equiv_class [OF equiv_intrel nat_of_congruent])

lemma raw_nat_of_int_of: "raw_nat_of($# n) = natify(n)"
by (simp add: int_of_def raw_nat_of)

lemma nat_of_int_of [simp]: "nat_of($# n) = natify(n)"
by (simp add: raw_nat_of_int_of nat_of_def)

lemma raw_nat_of_type: "raw_nat_of(z) \<in> nat"
by (simp add: raw_nat_of_def)

lemma nat_of_type [iff,TC]: "nat_of(z) \<in> nat"
by (simp add: nat_of_def raw_nat_of_type)

subsection\<open>zmagnitude: magnitide of an integer, as a natural number\<close>

lemma zmagnitude_int_of [simp]: "zmagnitude($# n) = natify(n)"
by (auto simp add: zmagnitude_def int_of_eq)

lemma natify_int_of_eq: "natify(x)=n ==> $#x = $# n"
apply (drule sym)
apply (simp (no_asm_simp) add: int_of_eq)
done

lemma zmagnitude_zminus_int_of [simp]: "zmagnitude($- $# n) = natify(n)"
apply (simp add: zmagnitude_def)
apply (rule the_equality)
apply (auto dest!: not_znegative_imp_zero natify_int_of_eq
            iff del: int_of_eq, auto)
done

lemma zmagnitude_type [iff,TC]: "zmagnitude(z)\<in>nat"
apply (simp add: zmagnitude_def)
apply (rule theI2, auto)
done

lemma not_zneg_int_of:
     "[| z \<in> int; ~ znegative(z) |] ==> \<exists>n\<in>nat. z = $# n"
apply (auto simp add: int_def znegative int_of_def not_lt_iff_le)
apply (rename_tac x y)
apply (rule_tac x="x#-y" in bexI)
apply (auto simp add: add_diff_inverse2)
done

lemma not_zneg_mag [simp]:
     "[| z \<in> int; ~ znegative(z) |] ==> $# (zmagnitude(z)) = z"
by (drule not_zneg_int_of, auto)

lemma zneg_int_of:
     "[| znegative(z); z \<in> int |] ==> \<exists>n\<in>nat. z = $- ($# succ(n))"
by (auto simp add: int_def znegative zminus int_of_def dest!: less_imp_succ_add)

lemma zneg_mag [simp]:
     "[| znegative(z); z \<in> int |] ==> $# (zmagnitude(z)) = $- z"
by (drule zneg_int_of, auto)

lemma int_cases: "z \<in> int ==> \<exists>n\<in>nat. z = $# n | z = $- ($# succ(n))"
apply (case_tac "znegative (z) ")
prefer 2 apply (blast dest: not_zneg_mag sym)
apply (blast dest: zneg_int_of)
done

lemma not_zneg_raw_nat_of:
     "[| ~ znegative(z); z \<in> int |] ==> $# (raw_nat_of(z)) = z"
apply (drule not_zneg_int_of)
apply (auto simp add: raw_nat_of_type raw_nat_of_int_of)
done

lemma not_zneg_nat_of_intify:
     "~ znegative(intify(z)) ==> $# (nat_of(z)) = intify(z)"
by (simp (no_asm_simp) add: nat_of_def not_zneg_raw_nat_of)

lemma not_zneg_nat_of: "[| ~ znegative(z); z \<in> int |] ==> $# (nat_of(z)) = z"
apply (simp (no_asm_simp) add: not_zneg_nat_of_intify)
done

lemma zneg_nat_of [simp]: "znegative(intify(z)) ==> nat_of(z) = 0"
apply (subgoal_tac "intify(z) \<in> int")
apply (simp add: int_def)
apply (auto simp add: znegative nat_of_def raw_nat_of
            split: nat_diff_split)
done

subsection\<open>@{term zadd}: addition on int\<close>

text\<open>Congruence Property for Addition\<close>
lemma zadd_congruent2:
    "(%z1 z2. let <x1,y1>=z1; <x2,y2>=z2
                            in intrel``{<x1#+x2, y1#+y2>})
     respects2 intrel"
apply (simp add: congruent2_def)
(*Proof via congruent2_commuteI seems longer*)
apply safe
apply (simp (no_asm_simp) add: add_assoc Let_def)
(*The rest should be trivial, but rearranging terms is hard
  add_ac does not help rewriting with the assumptions.*)
apply (rule_tac m1 = x1a in add_left_commute [THEN ssubst])
apply (rule_tac m1 = x2a in add_left_commute [THEN ssubst])
apply (simp (no_asm_simp) add: add_assoc [symmetric])
done

lemma raw_zadd_type: "[| z \<in> int;  w \<in> int |] ==> raw_zadd(z,w) \<in> int"
apply (simp add: int_def raw_zadd_def)
apply (rule UN_equiv_class_type2 [OF equiv_intrel zadd_congruent2], assumption+)
apply (simp add: Let_def)
done

lemma zadd_type [iff,TC]: "z $+ w \<in> int"
by (simp add: zadd_def raw_zadd_type)

lemma raw_zadd:
  "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
   ==> raw_zadd (intrel``{<x1,y1>}, intrel``{<x2,y2>}) =
       intrel `` {<x1#+x2, y1#+y2>}"
apply (simp add: raw_zadd_def
             UN_equiv_class2 [OF equiv_intrel equiv_intrel zadd_congruent2])
apply (simp add: Let_def)
done

lemma zadd:
  "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
   ==> (intrel``{<x1,y1>}) $+ (intrel``{<x2,y2>}) =
       intrel `` {<x1#+x2, y1#+y2>}"
by (simp add: zadd_def raw_zadd image_intrel_int)

lemma raw_zadd_int0: "z \<in> int ==> raw_zadd ($#0,z) = z"
by (auto simp add: int_def int_of_def raw_zadd)

lemma zadd_int0_intify [simp]: "$#0 $+ z = intify(z)"
by (simp add: zadd_def raw_zadd_int0)

lemma zadd_int0: "z \<in> int ==> $#0 $+ z = z"
by simp

lemma raw_zminus_zadd_distrib:
     "[| z \<in> int;  w \<in> int |] ==> $- raw_zadd(z,w) = raw_zadd($- z, $- w)"
by (auto simp add: zminus raw_zadd int_def)

lemma zminus_zadd_distrib [simp]: "$- (z $+ w) = $- z $+ $- w"
by (simp add: zadd_def raw_zminus_zadd_distrib)

lemma raw_zadd_commute:
     "[| z \<in> int;  w \<in> int |] ==> raw_zadd(z,w) = raw_zadd(w,z)"
by (auto simp add: raw_zadd add_ac int_def)

lemma zadd_commute: "z $+ w = w $+ z"
by (simp add: zadd_def raw_zadd_commute)

lemma raw_zadd_assoc:
    "[| z1: int;  z2: int;  z3: int |]
     ==> raw_zadd (raw_zadd(z1,z2),z3) = raw_zadd(z1,raw_zadd(z2,z3))"
by (auto simp add: int_def raw_zadd add_assoc)

lemma zadd_assoc: "(z1 $+ z2) $+ z3 = z1 $+ (z2 $+ z3)"
by (simp add: zadd_def raw_zadd_type raw_zadd_assoc)

(*For AC rewriting*)
lemma zadd_left_commute: "z1$+(z2$+z3) = z2$+(z1$+z3)"
apply (simp add: zadd_assoc [symmetric])
apply (simp add: zadd_commute)
done

(*Integer addition is an AC operator*)
lemmas zadd_ac = zadd_assoc zadd_commute zadd_left_commute

lemma int_of_add: "$# (m #+ n) = ($#m) $+ ($#n)"
by (simp add: int_of_def zadd)

lemma int_succ_int_1: "$# succ(m) = $# 1 $+ ($# m)"
by (simp add: int_of_add [symmetric] natify_succ)

lemma int_of_diff:
     "[| m\<in>nat;  n \<le> m |] ==> $# (m #- n) = ($#m) $- ($#n)"
apply (simp add: int_of_def zdiff_def)
apply (frule lt_nat_in_nat)
apply (simp_all add: zadd zminus add_diff_inverse2)
done

lemma raw_zadd_zminus_inverse: "z \<in> int ==> raw_zadd (z, $- z) = $#0"
by (auto simp add: int_def int_of_def zminus raw_zadd add_commute)

lemma zadd_zminus_inverse [simp]: "z $+ ($- z) = $#0"
apply (simp add: zadd_def)
apply (subst zminus_intify [symmetric])
apply (rule intify_in_int [THEN raw_zadd_zminus_inverse])
done

lemma zadd_zminus_inverse2 [simp]: "($- z) $+ z = $#0"
by (simp add: zadd_commute zadd_zminus_inverse)

lemma zadd_int0_right_intify [simp]: "z $+ $#0 = intify(z)"
by (rule trans [OF zadd_commute zadd_int0_intify])

lemma zadd_int0_right: "z \<in> int ==> z $+ $#0 = z"
by simp

subsection\<open>@{term zmult}: Integer Multiplication\<close>

text\<open>Congruence property for multiplication\<close>
lemma zmult_congruent2:
    "(%p1 p2. split(%x1 y1. split(%x2 y2.
                    intrel``{<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}, p2), p1))
     respects2 intrel"
apply (rule equiv_intrel [THEN congruent2_commuteI], auto)
(*Proof that zmult is congruent in one argument*)
apply (rename_tac x y)
apply (frule_tac t = "%u. x#*u" in sym [THEN subst_context])
apply (drule_tac t = "%u. y#*u" in subst_context)
apply (erule add_left_cancel)+
apply (simp_all add: add_mult_distrib_left)
done

lemma raw_zmult_type: "[| z \<in> int;  w \<in> int |] ==> raw_zmult(z,w) \<in> int"
apply (simp add: int_def raw_zmult_def)
apply (rule UN_equiv_class_type2 [OF equiv_intrel zmult_congruent2], assumption+)
apply (simp add: Let_def)
done

lemma zmult_type [iff,TC]: "z $* w \<in> int"
by (simp add: zmult_def raw_zmult_type)

lemma raw_zmult:
     "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
      ==> raw_zmult(intrel``{<x1,y1>}, intrel``{<x2,y2>}) =
          intrel `` {<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}"
by (simp add: raw_zmult_def
           UN_equiv_class2 [OF equiv_intrel equiv_intrel zmult_congruent2])

lemma zmult:
     "[| x1\<in>nat; y1\<in>nat;  x2\<in>nat; y2\<in>nat |]
      ==> (intrel``{<x1,y1>}) $* (intrel``{<x2,y2>}) =
          intrel `` {<x1#*x2 #+ y1#*y2, x1#*y2 #+ y1#*x2>}"
by (simp add: zmult_def raw_zmult image_intrel_int)

lemma raw_zmult_int0: "z \<in> int ==> raw_zmult ($#0,z) = $#0"
by (auto simp add: int_def int_of_def raw_zmult)

lemma zmult_int0 [simp]: "$#0 $* z = $#0"
by (simp add: zmult_def raw_zmult_int0)

lemma raw_zmult_int1: "z \<in> int ==> raw_zmult ($#1,z) = z"
by (auto simp add: int_def int_of_def raw_zmult)

lemma zmult_int1_intify [simp]: "$#1 $* z = intify(z)"
by (simp add: zmult_def raw_zmult_int1)

lemma zmult_int1: "z \<in> int ==> $#1 $* z = z"
by simp

lemma raw_zmult_commute:
     "[| z \<in> int;  w \<in> int |] ==> raw_zmult(z,w) = raw_zmult(w,z)"
by (auto simp add: int_def raw_zmult add_ac mult_ac)

lemma zmult_commute: "z $* w = w $* z"
by (simp add: zmult_def raw_zmult_commute)

lemma raw_zmult_zminus:
     "[| z \<in> int;  w \<in> int |] ==> raw_zmult($- z, w) = $- raw_zmult(z, w)"
by (auto simp add: int_def zminus raw_zmult add_ac)

lemma zmult_zminus [simp]: "($- z) $* w = $- (z $* w)"
apply (simp add: zmult_def raw_zmult_zminus)
apply (subst zminus_intify [symmetric], rule raw_zmult_zminus, auto)
done

lemma zmult_zminus_right [simp]: "w $* ($- z) = $- (w $* z)"
by (simp add: zmult_commute [of w])

lemma raw_zmult_assoc:
    "[| z1: int;  z2: int;  z3: int |]
     ==> raw_zmult (raw_zmult(z1,z2),z3) = raw_zmult(z1,raw_zmult(z2,z3))"
by (auto simp add: int_def raw_zmult add_mult_distrib_left add_ac mult_ac)

lemma zmult_assoc: "(z1 $* z2) $* z3 = z1 $* (z2 $* z3)"
by (simp add: zmult_def raw_zmult_type raw_zmult_assoc)

(*For AC rewriting*)
lemma zmult_left_commute: "z1$*(z2$*z3) = z2$*(z1$*z3)"
apply (simp add: zmult_assoc [symmetric])
apply (simp add: zmult_commute)
done

(*Integer multiplication is an AC operator*)
lemmas zmult_ac = zmult_assoc zmult_commute zmult_left_commute

lemma raw_zadd_zmult_distrib:
    "[| z1: int;  z2: int;  w \<in> int |]
     ==> raw_zmult(raw_zadd(z1,z2), w) =
         raw_zadd (raw_zmult(z1,w), raw_zmult(z2,w))"
by (auto simp add: int_def raw_zadd raw_zmult add_mult_distrib_left add_ac mult_ac)

lemma zadd_zmult_distrib: "(z1 $+ z2) $* w = (z1 $* w) $+ (z2 $* w)"
by (simp add: zmult_def zadd_def raw_zadd_type raw_zmult_type
              raw_zadd_zmult_distrib)

lemma zadd_zmult_distrib2: "w $* (z1 $+ z2) = (w $* z1) $+ (w $* z2)"
by (simp add: zmult_commute [of w] zadd_zmult_distrib)

lemmas int_typechecks =
  int_of_type zminus_type zmagnitude_type zadd_type zmult_type

(*** Subtraction laws ***)

lemma zdiff_type [iff,TC]: "z $- w \<in> int"
by (simp add: zdiff_def)

lemma zminus_zdiff_eq [simp]: "$- (z $- y) = y $- z"
by (simp add: zdiff_def zadd_commute)

lemma zdiff_zmult_distrib: "(z1 $- z2) $* w = (z1 $* w) $- (z2 $* w)"
apply (simp add: zdiff_def)
apply (subst zadd_zmult_distrib)
apply (simp add: zmult_zminus)
done

lemma zdiff_zmult_distrib2: "w $* (z1 $- z2) = (w $* z1) $- (w $* z2)"
by (simp add: zmult_commute [of w] zdiff_zmult_distrib)

lemma zadd_zdiff_eq: "x $+ (y $- z) = (x $+ y) $- z"
by (simp add: zdiff_def zadd_ac)

lemma zdiff_zadd_eq: "(x $- y) $+ z = (x $+ z) $- y"
by (simp add: zdiff_def zadd_ac)

subsection\<open>The "Less Than" Relation\<close>

(*"Less than" is a linear ordering*)
lemma zless_linear_lemma:
     "[| z \<in> int; w \<in> int |] ==> z$<w | z=w | w$<z"
apply (simp add: int_def zless_def znegative_def zdiff_def, auto)
apply (simp add: zadd zminus image_iff Bex_def)
apply (rule_tac i = "xb#+ya" and j = "xc #+ y" in Ord_linear_lt)
apply (force dest!: spec simp add: add_ac)+
done

lemma zless_linear: "z$<w | intify(z)=intify(w) | w$<z"
apply (cut_tac z = " intify (z) " and w = " intify (w) " in zless_linear_lemma)
apply auto
done

lemma zless_not_refl [iff]: "~ (z$<z)"
by (auto simp add: zless_def znegative_def int_of_def zdiff_def)

lemma neq_iff_zless: "[| x \<in> int; y \<in> int |] ==> (x \<noteq> y) \<longleftrightarrow> (x $< y | y $< x)"
by (cut_tac z = x and w = y in zless_linear, auto)

lemma zless_imp_intify_neq: "w $< z ==> intify(w) \<noteq> intify(z)"
apply auto
apply (subgoal_tac "~ (intify (w) $< intify (z))")
apply (erule_tac [2] ssubst)
apply (simp (no_asm_use))
apply auto
done

(*This lemma allows direct proofs of other <-properties*)
lemma zless_imp_succ_zadd_lemma:
    "[| w $< z; w \<in> int; z \<in> int |] ==> (\<exists>n\<in>nat. z = w $+ $#(succ(n)))"
apply (simp add: zless_def znegative_def zdiff_def int_def)
apply (auto dest!: less_imp_succ_add simp add: zadd zminus int_of_def)
apply (rule_tac x = k in bexI)
apply (erule_tac i="succ (v)" for v in add_left_cancel, auto)
done

lemma zless_imp_succ_zadd:
     "w $< z ==> (\<exists>n\<in>nat. w $+ $#(succ(n)) = intify(z))"
apply (subgoal_tac "intify (w) $< intify (z) ")
apply (drule_tac w = "intify (w) " in zless_imp_succ_zadd_lemma)
apply auto
done

lemma zless_succ_zadd_lemma:
    "w \<in> int ==> w $< w $+ $# succ(n)"
apply (simp add: zless_def znegative_def zdiff_def int_def)
apply (auto simp add: zadd zminus int_of_def image_iff)
apply (rule_tac x = 0 in exI, auto)
done

lemma zless_succ_zadd: "w $< w $+ $# succ(n)"
by (cut_tac intify_in_int [THEN zless_succ_zadd_lemma], auto)

lemma zless_iff_succ_zadd:
     "w $< z \<longleftrightarrow> (\<exists>n\<in>nat. w $+ $#(succ(n)) = intify(z))"
apply (rule iffI)
apply (erule zless_imp_succ_zadd, auto)
apply (rename_tac "n")
apply (cut_tac w = w and n = n in zless_succ_zadd, auto)
done

lemma zless_int_of [simp]: "[| m\<in>nat; n\<in>nat |] ==> ($#m $< $#n) \<longleftrightarrow> (m<n)"
apply (simp add: less_iff_succ_add zless_iff_succ_zadd int_of_add [symmetric])
apply (blast intro: sym)
done

lemma zless_trans_lemma:
    "[| x $< y; y $< z; x \<in> int; y \<in> int; z \<in> int |] ==> x $< z"
apply (simp add: zless_def znegative_def zdiff_def int_def)
apply (auto simp add: zadd zminus image_iff)
apply (rename_tac x1 x2 y1 y2)
apply (rule_tac x = "x1#+x2" in exI)
apply (rule_tac x = "y1#+y2" in exI)
apply (auto simp add: add_lt_mono)
apply (rule sym)
apply hypsubst_thin
apply (erule add_left_cancel)+
apply auto
done

lemma zless_trans [trans]: "[| x $< y; y $< z |] ==> x $< z"
apply (subgoal_tac "intify (x) $< intify (z) ")
apply (rule_tac [2] y = "intify (y) " in zless_trans_lemma)
apply auto
done

lemma zless_not_sym: "z $< w ==> ~ (w $< z)"
by (blast dest: zless_trans)

(* [| z $< w; ~ P ==> w $< z |] ==> P *)
lemmas zless_asym = zless_not_sym [THEN swap]

lemma zless_imp_zle: "z $< w ==> z $\<le> w"
by (simp add: zle_def)

lemma zle_linear: "z $\<le> w | w $\<le> z"
apply (simp add: zle_def)
apply (cut_tac zless_linear, blast)
done

subsection\<open>Less Than or Equals\<close>

lemma zle_refl: "z $\<le> z"
by (simp add: zle_def)

lemma zle_eq_refl: "x=y ==> x $\<le> y"
by (simp add: zle_refl)

lemma zle_anti_sym_intify: "[| x $\<le> y; y $\<le> x |] ==> intify(x) = intify(y)"
apply (simp add: zle_def, auto)
apply (blast dest: zless_trans)
done

lemma zle_anti_sym: "[| x $\<le> y; y $\<le> x; x \<in> int; y \<in> int |] ==> x=y"
by (drule zle_anti_sym_intify, auto)

lemma zle_trans_lemma:
     "[| x \<in> int; y \<in> int; z \<in> int; x $\<le> y; y $\<le> z |] ==> x $\<le> z"
apply (simp add: zle_def, auto)
apply (blast intro: zless_trans)
done

lemma zle_trans [trans]: "[| x $\<le> y; y $\<le> z |] ==> x $\<le> z"
apply (subgoal_tac "intify (x) $\<le> intify (z) ")
apply (rule_tac [2] y = "intify (y) " in zle_trans_lemma)
apply auto
done

lemma zle_zless_trans [trans]: "[| i $\<le> j; j $< k |] ==> i $< k"
apply (auto simp add: zle_def)
apply (blast intro: zless_trans)
apply (simp add: zless_def zdiff_def zadd_def)
done

lemma zless_zle_trans [trans]: "[| i $< j; j $\<le> k |] ==> i $< k"
apply (auto simp add: zle_def)
apply (blast intro: zless_trans)
apply (simp add: zless_def zdiff_def zminus_def)
done

lemma not_zless_iff_zle: "~ (z $< w) \<longleftrightarrow> (w $\<le> z)"
apply (cut_tac z = z and w = w in zless_linear)
apply (auto dest: zless_trans simp add: zle_def)
apply (auto dest!: zless_imp_intify_neq)
done

lemma not_zle_iff_zless: "~ (z $\<le> w) \<longleftrightarrow> (w $< z)"
by (simp add: not_zless_iff_zle [THEN iff_sym])

subsection\<open>More subtraction laws (for \<open>zcompare_rls\<close>)\<close>

lemma zdiff_zdiff_eq: "(x $- y) $- z = x $- (y $+ z)"
by (simp add: zdiff_def zadd_ac)

lemma zdiff_zdiff_eq2: "x $- (y $- z) = (x $+ z) $- y"
by (simp add: zdiff_def zadd_ac)

lemma zdiff_zless_iff: "(x$-y $< z) \<longleftrightarrow> (x $< z $+ y)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zless_zdiff_iff: "(x $< z$-y) \<longleftrightarrow> (x $+ y $< z)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zdiff_eq_iff: "[| x \<in> int; z \<in> int |] ==> (x$-y = z) \<longleftrightarrow> (x = z $+ y)"
by (auto simp add: zdiff_def zadd_assoc)

lemma eq_zdiff_iff: "[| x \<in> int; z \<in> int |] ==> (x = z$-y) \<longleftrightarrow> (x $+ y = z)"
by (auto simp add: zdiff_def zadd_assoc)

lemma zdiff_zle_iff_lemma:
     "[| x \<in> int; z \<in> int |] ==> (x$-y $\<le> z) \<longleftrightarrow> (x $\<le> z $+ y)"
by (auto simp add: zle_def zdiff_eq_iff zdiff_zless_iff)

lemma zdiff_zle_iff: "(x$-y $\<le> z) \<longleftrightarrow> (x $\<le> z $+ y)"
by (cut_tac zdiff_zle_iff_lemma [OF intify_in_int intify_in_int], simp)

lemma zle_zdiff_iff_lemma:
     "[| x \<in> int; z \<in> int |] ==>(x $\<le> z$-y) \<longleftrightarrow> (x $+ y $\<le> z)"
apply (auto simp add: zle_def zdiff_eq_iff zless_zdiff_iff)
apply (auto simp add: zdiff_def zadd_assoc)
done

lemma zle_zdiff_iff: "(x $\<le> z$-y) \<longleftrightarrow> (x $+ y $\<le> z)"
by (cut_tac zle_zdiff_iff_lemma [ OF intify_in_int intify_in_int], simp)

text\<open>This list of rewrites simplifies (in)equalities by bringing subtractions
  to the top and then moving negative terms to the other side.
  Use with \<open>zadd_ac\<close>\<close>
lemmas zcompare_rls =
     zdiff_def [symmetric]
     zadd_zdiff_eq zdiff_zadd_eq zdiff_zdiff_eq zdiff_zdiff_eq2
     zdiff_zless_iff zless_zdiff_iff zdiff_zle_iff zle_zdiff_iff
     zdiff_eq_iff eq_zdiff_iff

subsection\<open>Monotonicity and Cancellation Results for Instantiation
     of the CancelNumerals Simprocs\<close>

lemma zadd_left_cancel:
     "[| w \<in> int; w': int |] ==> (z $+ w' = z $+ w) \<longleftrightarrow> (w' = w)"
apply safe
apply (drule_tac t = "%x. x $+ ($-z) " in subst_context)
apply (simp add: zadd_ac)
done

lemma zadd_left_cancel_intify [simp]:
     "(z $+ w' = z $+ w) \<longleftrightarrow> intify(w') = intify(w)"
apply (rule iff_trans)
apply (rule_tac [2] zadd_left_cancel, auto)
done

lemma zadd_right_cancel:
     "[| w \<in> int; w': int |] ==> (w' $+ z = w $+ z) \<longleftrightarrow> (w' = w)"
apply safe
apply (drule_tac t = "%x. x $+ ($-z) " in subst_context)
apply (simp add: zadd_ac)
done

lemma zadd_right_cancel_intify [simp]:
     "(w' $+ z = w $+ z) \<longleftrightarrow> intify(w') = intify(w)"
apply (rule iff_trans)
apply (rule_tac [2] zadd_right_cancel, auto)
done

lemma zadd_right_cancel_zless [simp]: "(w' $+ z $< w $+ z) \<longleftrightarrow> (w' $< w)"
by (simp add: zdiff_zless_iff [THEN iff_sym] zdiff_def zadd_assoc)

lemma zadd_left_cancel_zless [simp]: "(z $+ w' $< z $+ w) \<longleftrightarrow> (w' $< w)"
by (simp add: zadd_commute [of z] zadd_right_cancel_zless)

lemma zadd_right_cancel_zle [simp]: "(w' $+ z $\<le> w $+ z) \<longleftrightarrow> w' $\<le> w"
by (simp add: zle_def)

lemma zadd_left_cancel_zle [simp]: "(z $+ w' $\<le> z $+ w) \<longleftrightarrow>  w' $\<le> w"
by (simp add: zadd_commute [of z]  zadd_right_cancel_zle)

(*"v $\<le> w ==> v$+z $\<le> w$+z"*)
lemmas zadd_zless_mono1 = zadd_right_cancel_zless [THEN iffD2]

(*"v $\<le> w ==> z$+v $\<le> z$+w"*)
lemmas zadd_zless_mono2 = zadd_left_cancel_zless [THEN iffD2]

(*"v $\<le> w ==> v$+z $\<le> w$+z"*)
lemmas zadd_zle_mono1 = zadd_right_cancel_zle [THEN iffD2]

(*"v $\<le> w ==> z$+v $\<le> z$+w"*)
lemmas zadd_zle_mono2 = zadd_left_cancel_zle [THEN iffD2]

lemma zadd_zle_mono: "[| w' $\<le> w; z' $\<le> z |] ==> w' $+ z' $\<le> w $+ z"
by (erule zadd_zle_mono1 [THEN zle_trans], simp)

lemma zadd_zless_mono: "[| w' $< w; z' $\<le> z |] ==> w' $+ z' $< w $+ z"
by (erule zadd_zless_mono1 [THEN zless_zle_trans], simp)

subsection\<open>Comparison laws\<close>

lemma zminus_zless_zminus [simp]: "($- x $< $- y) \<longleftrightarrow> (y $< x)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zminus_zle_zminus [simp]: "($- x $\<le> $- y) \<longleftrightarrow> (y $\<le> x)"
by (simp add: not_zless_iff_zle [THEN iff_sym])

subsubsection\<open>More inequality lemmas\<close>

lemma equation_zminus: "[| x \<in> int;  y \<in> int |] ==> (x = $- y) \<longleftrightarrow> (y = $- x)"
by auto

lemma zminus_equation: "[| x \<in> int;  y \<in> int |] ==> ($- x = y) \<longleftrightarrow> ($- y = x)"
by auto

lemma equation_zminus_intify: "(intify(x) = $- y) \<longleftrightarrow> (intify(y) = $- x)"
apply (cut_tac x = "intify (x) " and y = "intify (y) " in equation_zminus)
apply auto
done

lemma zminus_equation_intify: "($- x = intify(y)) \<longleftrightarrow> ($- y = intify(x))"
apply (cut_tac x = "intify (x) " and y = "intify (y) " in zminus_equation)
apply auto
done

subsubsection\<open>The next several equations are permutative: watch out!\<close>

lemma zless_zminus: "(x $< $- y) \<longleftrightarrow> (y $< $- x)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zminus_zless: "($- x $< y) \<longleftrightarrow> ($- y $< x)"
by (simp add: zless_def zdiff_def zadd_ac)

lemma zle_zminus: "(x $\<le> $- y) \<longleftrightarrow> (y $\<le> $- x)"
by (simp add: not_zless_iff_zle [THEN iff_sym] zminus_zless)

lemma zminus_zle: "($- x $\<le> y) \<longleftrightarrow> ($- y $\<le> x)"
by (simp add: not_zless_iff_zle [THEN iff_sym] zless_zminus)

end


(*<*)
theory ExtendedDDL
  imports CJDDLplus
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]
(*>*)

section \<open>Extending the Carmo and Jones DDL Logical Framework\<close>
text\<open>\noindent{In the last section, we have modelled Kaplanian contexts by introducing a new type of object (type c) and modelled
sentence meanings as so-called "characters", i.e. functions from contexts to sets of worlds (type \<open>c\<Rightarrow>w\<Rightarrow>o\<close>).
We also made the corresponding adjustments to the original semantic embedding of Carmo and Jones' DDL \<^cite>\<open>"C71"\<close> \<^cite>\<open>"BenzmuellerDDL"\<close>.
So far we haven't said much about what these Kaplanian contexts are or which effect they should have on the evaluation
of logical validity. We restricted ourselves to illustrating that their introduction does not have any influence
on the (classical) modal validity of several DDL key theorems.
In this section we introduce an alternative notion of logical validity suited for working with contexts:
indexical validity \<^cite>\<open>"Kaplan1979"\<close> \<^cite>\<open>"Kaplan1989"\<close>.}\<close>

subsection \<open>Context Features\<close>
text\<open>\noindent{Kaplan's theory ("Logic of Demonstratives" \<^cite>\<open>"Kaplan1979"\<close>) aims at modelling the behaviour of
certain context-sensitive linguistic expressions like
the pronouns 'I', 'my', 'you', 'he', 'his', 'she', 'it', the demonstrative pronouns 'that', 'this', the adverbs 'here', 'now',
'tomorrow', 'yesterday', the adjectives 'actual', 'present', and others. Such expressions are known as "indexicals"
and so Kaplan's logical system (among others) is usually referred to as a "logic of indexicals" (although
in his seminal work he referred to it as a "logic of demonstratives" (LD)) \<^cite>\<open>"Kaplan1979"\<close>.
In the following we will refer to Kaplan's logic as the logic "LD".
It is characteristic of an indexical that its content varies with context, i.e. they have a context-sensitive character.
Non-indexicals have a fixed character. The same content is invoked in all contexts.
Kaplan's logical system models context-sensitivity by representing contexts as tuples of features
(\<open>\<langle>Agent(c), Position(c), World(c), Time(c)\<rangle>\<close>). The agent and the position of context c can be seen as the actual speaker
and place of the utterance respectively, while c's world and time stand for the circumstances of evaluation of the
expression's content and allow for the interaction of indexicals with alethic and tense modalities respectively.}\<close>

text\<open>\noindent{To keep things simple (and relevant for our task) we restrict ourselves to representing a context c as the pair: \<open>\<langle>Agent(c), World(c)\<rangle>\<close>.
For this purpose we represent the functional concepts "Agent" and "World" as logical constants.}\<close>
consts Agent::"c\<Rightarrow>e"  \<comment> \<open> function retrieving the agent corresponding to context c \<close>
consts World::"c\<Rightarrow>w"  \<comment> \<open> function retrieving the world corresponding to context c \<close>

subsection \<open>Logical Validity\<close>

text\<open>\noindent{Kaplan's notion of (context-dependent) logical truth for a sentence corresponds to its (context-sensitive) formula
(of type \<open>c\<Rightarrow>w\<Rightarrow>bool\<close> i.e. m) being true in the given context and at its corresponding world.}\<close>
abbreviation ldtruectx::"m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>_") where "\<lfloor>\<phi>\<rfloor>\<^sub>c \<equiv> \<phi> c (World c)" \<comment> \<open>  truth in the given context \<close>

text\<open>\noindent{Kaplan's LD notion of logical validity for a sentence corresponds to its being true in all contexts.
This notion is also known as indexical validity.}\<close>
abbreviation ldvalid::"m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sup>D") where "\<lfloor>\<phi>\<rfloor>\<^sup>D \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sub>c" \<comment> \<open> LD validity (true in every context) \<close>

text\<open>\noindent{Here we show that indexical validity is indeed weaker than its classical modal counterpart (truth at all worlds for all contexts):}\<close>
lemma "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>A\<rfloor>\<^sup>D" by simp
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>A\<rfloor>" nitpick oops \<comment> \<open> countermodel found \<close>

text\<open>\noindent{Here we show that the interplay between indexical validity and the DDL modal and deontic operators does not
result in modal collapse.}\<close>
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>aP\<rfloor>\<^sup>D" nitpick oops
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aP\<rfloor>\<^sup>D" nitpick oops

text\<open>\noindent{Next we show that the necessitation rule does not work for indexical validity (in contrast to classical modal validity as defined for DDL).}\<close>
lemma NecLDa: "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>\<^sup>D"  nitpick oops
lemma NecLDp:  "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>pA\<rfloor>\<^sup>D" nitpick oops

text\<open>\noindent{The following can be seen as a kind of 'analytic/a priori necessity' operator (to be contrasted to the more
traditional alethic necessity).
In Kaplan's framework, a sentence being logically (i.e. indexically) valid means its being true \emph{a priori}: it is guaranteed to be true
in every possible context in which it is uttered, even though it may express distinct propositions in different contexts. This correlation
between indexical validity and \emph{a prioricity} has also been claimed in other two-dimensional semantic frameworks \<^cite>\<open>"SEP2DSem"\<close>.}\<close>
abbreviation ldvalidbox :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sup>D_" [52]53) where "\<^bold>\<box>\<^sup>D\<phi> \<equiv> \<lambda>c w. \<lfloor>\<phi>\<rfloor>\<^sup>D" \<comment> \<open> notice the D superscript \<close>
lemma "\<lfloor>\<^bold>\<box>\<^sup>D\<phi>\<rfloor>\<^sub>C \<equiv> \<forall>c.\<lfloor>\<phi>\<rfloor>\<^sub>c" by simp \<comment> \<open>  this operator works analogously to the box operator in modal logic S5 \<close>

text\<open>\noindent{Quite trivially, the necessitation rule works for the combination of indexical validity with the previous operator.}\<close>
lemma NecLD: "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sup>DA\<rfloor>\<^sup>D"  by simp

text\<open>\noindent{The operator above is not part of the original Kaplan's LD (\<^cite>\<open>"Kaplan1979"\<close>) and has been added
by us in order to better highlight some semantic features of our formalisation of Gewirth's argument in the next section and to being able to
use the necessitation rule for some inference steps.}\<close>

subsection \<open>Quantification\<close>
text\<open>\noindent{ We also enrich our logic with (higher-order) quantifiers (using parameterised types).}\<close>
abbreviation mforall::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>c w.\<forall>x. (\<Phi> x c w)"
abbreviation mexists::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>c w.\<exists>x. (\<Phi> x c w)"
abbreviation mforallBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. (\<phi> x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexistsBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. (\<phi> x) \<equiv> \<^bold>\<exists>\<phi>"
(*<*)
end
(*>*)


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)
        with n_gt_zero show ?case
          by (simp add: nat_less_iff)
      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 have "((int x - int i) mod int n) = ((int y - int i) mod int n)"
          by (meson eq_nat_nat_iff mod_int_pos_iff n_gt_zero)
        then have "int x mod int n = int y mod int n"
          by (smt (z3) mod_diff_cong)
        then show ?case using 1 by auto
      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