theory Compress

imports Kyber_spec
        Mod_Plus_Minus
        Abs_Qr
        "HOL-Analysis.Finite_Cartesian_Product"

begin

lemma prime_half:
  assumes "prime (p::int)"
          "p > 2"
  shows "\<lceil>p / 2\<rceil> > \<lfloor>p / 2\<rfloor>"
proof -
  have "odd p" using prime_odd_int[OF assms] .
  then have "\<lceil>p / 2\<rceil> > p/2"
  by (smt (verit, best) cos_npi_int cos_zero_iff_int
    le_of_int_ceiling mult.commute times_divide_eq_right)
  then have "\<lfloor>p / 2\<rfloor> < p/2"
  by (meson floor_less_iff less_ceiling_iff)
  then show ?thesis using \<open>\<lceil>p / 2\<rceil> > p/2\<close> by auto
qed

lemma ceiling_int:
  "\<lceil>of_int a + b\<rceil> = a + \<lceil>b\<rceil>"
unfolding ceiling_def by (simp add: add.commute)

lemma deg_Poly':
  assumes "Poly xs \<noteq> 0"
  shows "degree (Poly xs) \<le> length xs - 1"
proof (induct xs)
  case (Cons a xs)
  then show ?case
    by simp (metis Poly.simps(1) Suc_le_eq Suc_pred
    le_imp_less_Suc length_greater_0_conv)
qed simp

context kyber_spec begin

section \<open>Compress and Decompress Functions\<close>

text \<open>Properties of the \<open>mod+-\<close> function.\<close>

lemma two_mid_lt_q:
  "2 * \<lfloor>real_of_int q/2\<rfloor> < q"
using oddE[OF prime_odd_int[OF q_prime q_gt_two]] by fastforce

lemma mod_plus_minus_range_q:
  assumes "y \<in> {-\<lfloor>q/2\<rfloor>..\<lfloor>q/2\<rfloor>}"
  shows "y mod+- q = y"
using assms mod_plus_minus_rangeE q_gt_zero q_odd by presburger

text \<open>Compression only works for $x \in \mathbb{Z}_q$ and outputs an integer
  in $\{0,\dots, 2^d-1\}$ , where $d$ is a positive integer with
  $d < \rceil\log_2 (q)\lceil$.
  For compression we omit the least important bits.
  Decompression rescales to the modulus q.\<close>

definition compress :: "nat \<Rightarrow> int \<Rightarrow> int" where
  "compress d x =
  round (real_of_int (2^d * x) / real_of_int q) mod (2^d)"

definition decompress :: "nat \<Rightarrow> int \<Rightarrow> int" where
  "decompress d x =
  round (real_of_int q * real_of_int x / real_of_int 2^d)"

lemma compress_zero: "compress d 0 = 0"
unfolding compress_def by auto

lemma compress_less:
  \<open>compress d x < 2 ^ d\<close>
  by (simp add: compress_def)

lemma decompress_zero: "decompress d 0 = 0"
unfolding decompress_def by auto

text \<open>Properties of the exponent $d$.\<close>

lemma d_lt_logq:
  assumes "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "d< log 2 q"
using assms by linarith

lemma twod_lt_q:
  assumes "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "2 powr (real d) < of_int q"
using assms less_log_iff[of 2 q d] d_lt_logq q_gt_zero
by auto

lemma break_point_gt_q_div_two:
  assumes "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "\<lceil>q-(q/(2*2^d))\<rceil> > \<lfloor>q/2\<rfloor>"
proof -
  have "1/((2::real)^d) \<le> (1::real)"
    using one_le_power[of 2 d] by simp
  have "\<lceil>q-(q/(2*2^d))\<rceil> \<ge> q-(q/2)* (1/(2^d))" by simp
  moreover have "q-(q/2)* (1/(2^d)) \<ge> q - q/2"
    using \<open>1/((2::real)^d) \<le> (1::real)\<close>
    by (smt (z3) calculation divide_le_eq divide_nonneg_nonneg
      divide_self_if mult_left_mono of_int_nonneg
      times_divide_eq_right q_gt_zero)
  ultimately have "\<lceil>q-(q/(2*2^d))\<rceil> \<ge> \<lceil>q/2\<rceil> " by linarith
  moreover have "\<lceil>q/2\<rceil> > \<lfloor>q/2\<rfloor>"
    using prime_half[OF q_prime q_gt_two] .
  ultimately show ?thesis by auto
qed

lemma decompress_zero_unique:
  assumes "decompress d s = 0"
          "s \<in> {0..2^d - 1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "s = 0"
proof -
  let ?x = "real_of_int q * real_of_int s /
    real_of_int 2^d + 1/2"
  have "0 \<le> ?x \<and> ?x < 1" using assms(1)
     unfolding decompress_def round_def
    using floor_correct[of ?x] by auto
  then have "real_of_int q * real_of_int s /
    real_of_int 2^d < 1/2" by linarith
  moreover have "real_of_int q / real_of_int 2^d > 1"
    using twod_lt_q[OF assms(3)]
    by (simp add: powr_realpow)
  ultimately have "real_of_int s < 1/2"
  by (smt (verit, best) divide_less_eq_1_pos field_sum_of_halves
    pos_divide_less_eq times_divide_eq_left)
  then show ?thesis using assms(2) by auto
qed

text \<open>Range of compress and decompress functions\<close>

lemma range_compress:
  assumes "x\<in>{0..q-1}" "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "compress d x \<in> {0..2^d - 1}"
using compress_def by auto

lemma range_decompress:
  assumes "x\<in>{0..2^d - 1}" "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "decompress d x \<in> {0..q-1}"
using decompress_def assms
proof (auto, goal_cases)
case 1
  then show ?case
  by (smt (verit, best) divide_eq_0_iff divide_numeral_1
    less_divide_eq_1_pos mult_of_int_commute
    nonzero_mult_div_cancel_right of_int_eq_0_iff
    of_int_less_1_iff powr_realpow q_gt_zero q_nonzero
    round_0 round_mono twod_lt_q zero_less_power)
next
case 2
  have "real_of_int q/2^d > 1" using twod_lt_q[OF assms(2)]
    by (simp add: powr_realpow)
  then have log: "real_of_int q - real_of_int q/2^d \<le> q-1" by simp
  have "x \<le> 2^d-1" using assms(1) by simp
  then have "real_of_int x \<le> 2^d - 1" by (simp add: int_less_real_le)
  then have "real_of_int q * real_of_int x / 2^d \<le>
    real_of_int q * (2^d-1) / 2^d"
    by (smt (verit, best) divide_strict_right_mono
      mult_less_cancel_left_pos of_int_pos q_gt_zero
      zero_less_power)
  also have "\<dots> = real_of_int q * 2^d /2^d - real_of_int q/2^d"
    by (simp add: diff_divide_distrib right_diff_distrib)
  finally have "real_of_int q * real_of_int x / 2^d \<le>
    real_of_int q - real_of_int q/2^d" by simp
  then have "round (real_of_int q * real_of_int x / 2^d) \<le>
    round (real_of_int q - real_of_int q/2^d)"
    using round_mono by blast
  also have "\<dots> \<le> q - 1"
    using log by (metis round_mono round_of_int)
  finally show ?case by auto
qed

text \<open>Compression is a function qrom $\mathbb{Z} / q\mathbb{Z}$ to
  $\mathbb{Z} / (2^d)\mathbb{Z}$.\<close>

lemma compress_in_range:
  assumes "x\<in>{0..\<lceil>q-(q/(2*2^d))\<rceil>-1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "round (real_of_int (2^d * x) / real_of_int q) < 2^d "
proof -
  have "(2::int)^d \<noteq> 0" by simp
  have "real_of_int x < real_of_int q - real_of_int q / (2 * 2^d)"
    using assms(1) less_ceiling_iff by auto
  then have "2^d * real_of_int x / real_of_int q <
    2^d * (real_of_int q - real_of_int q / (2 * 2^d)) /
    real_of_int q"
    by (simp add: divide_strict_right_mono q_gt_zero)
  also have "\<dots> = 2^d * ((real_of_int q / real_of_int q) -
    (real_of_int q / real_of_int q) / (2 * 2^d))"
  by (simp add:algebra_simps diff_divide_distrib)
  also have "\<dots> = 2^d * (1 - 1/(2*2^d))"
    using q_nonzero by simp
  also have "\<dots> = 2^d - 1/2"
    using \<open>2^d \<noteq> 0\<close> by (simp add: right_diff_distrib')
  finally have "2^d * real_of_int x / real_of_int q <
    2^d - (1::real)/(2::real)"
    by auto
  then show ?thesis unfolding round_def
    using floor_less_iff by fastforce
qed

text \<open>When does the modulo operation in the compression function change the output?
  Only when  \<open>x \<ge> \<lceil>q-(q / (2*2^d))\<rceil>\<close>. Then we can determine that the compress function
  maps to zero. This is why we need the \<open>mod+-\<close> in the definition of Compression.
  Otherwise the error bound would not hold.\<close>

lemma compress_no_mod:
  assumes "x\<in>{0..\<lceil>q-(q / (2*2^d))\<rceil>-1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "compress d x =
    round (real_of_int (2^d * x) / real_of_int q)"
unfolding compress_def
using compress_in_range[OF assms] assms(1) q_gt_zero
by (smt (z3) atLeastAtMost_iff divide_nonneg_nonneg
  mod_pos_pos_trivial mult_less_cancel_left_pos
  of_int_nonneg of_nat_0_less_iff right_diff_distrib'
  round_0 round_mono zero_less_power)

lemma compress_2d:
  assumes "x\<in>{\<lceil>q-(q/(2*2^d))\<rceil>..q-1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "round (real_of_int (2^d * x) / real_of_int q) = 2^d "
using assms proof -
  have "(2::int)^d \<noteq> 0" by simp
  have "round (real_of_int (2^d * x) / real_of_int q) \<ge> 2^d"
  proof -
    have "real_of_int x \<ge> real_of_int q - real_of_int q / (2 * 2^d)"
      using assms(1) ceiling_le_iff by auto
    then have "2^d * real_of_int x / real_of_int q \<ge>
      2^d * (real_of_int q - real_of_int q / (2 * 2^d)) /
      real_of_int q"
      using q_gt_zero by (simp add: divide_right_mono)
    also have "2^d * (real_of_int q - real_of_int q /
      (2 * 2^d)) / real_of_int q
      = 2^d * ((real_of_int q / real_of_int q) -
      (real_of_int q / real_of_int q) / (2 * 2^d))"
      by (simp add:algebra_simps diff_divide_distrib)
    also have "\<dots> = 2^d * (1 - 1/(2*2^d))"
      using q_nonzero by simp
    also have "\<dots> = 2^d - 1/2"
      using \<open>2^d \<noteq> 0\<close> by (simp add: right_diff_distrib')
    finally have "2^d * real_of_int x / real_of_int q \<ge>
      2^d - (1::real)/(2::real)"
      by auto
    then show ?thesis unfolding round_def using le_floor_iff by force
  qed
  moreover have "round (real_of_int (2^d * x) / real_of_int q) \<le> 2^d"
  proof -
    have "d < log 2 q" using assms(2) by linarith
    then have "2 powr (real d) < of_int q"
      using less_log_iff[of 2 q d] q_gt_zero by auto
    have "x < q" using assms(1) by auto
    then have "real_of_int x/ real_of_int q < 1"
      by (simp add: q_gt_zero)
    then have "real_of_int (2^d * x) / real_of_int q <
      real_of_int (2^d)"
      by (auto) (smt (verit, best) divide_less_eq_1_pos
        nonzero_mult_div_cancel_left times_divide_eq_right
        zero_less_power)
    then show ?thesis unfolding round_def by linarith
  qed
  ultimately show ?thesis by auto
qed

lemma compress_mod:
  assumes "x\<in>{\<lceil>q-(q/(2*2^d))\<rceil>..q-1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "compress d x = 0"
unfolding compress_def using compress_2d[OF assms] by simp

text \<open>Error after compression and decompression of data.
  To prove the error bound, we distinguish the cases where the \<open>mod+-\<close> is relevant or not.\<close>

text \<open>First let us look at the error bound for no \<open>mod+-\<close> reduction.\<close>

lemma decompress_compress_no_mod:
  assumes "x\<in>{0..\<lceil>q-(q/(2*2^d))\<rceil>-1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "abs (decompress d (compress d x) - x) \<le>
    round ( real_of_int q / real_of_int (2^(d+1)))"
proof -
  have "abs (decompress d (compress d x) - x) =
    abs (real_of_int (decompress d (compress d x)) -
    real_of_int q / real_of_int (2^d) *
    (real_of_int (2^d * x) / real_of_int q))"
    using q_gt_zero by force
  also have "\<dots> \<le> abs (real_of_int (decompress d (compress d x)) -
    real_of_int q / real_of_int (2^d) * real_of_int (compress d x)) +
    abs (real_of_int q / real_of_int (2^d) *
    real_of_int (compress d x) - real_of_int q / real_of_int (2^d) *
    real_of_int (2^d) / real_of_int q * x)"
    using abs_triangle_ineq[of
      "real_of_int (decompress d (compress d x)) -
       real_of_int q / real_of_int (2^d) * real_of_int (compress d x)"
      "real_of_int q / real_of_int (2^d) * real_of_int (compress d x)
       - real_of_int q / real_of_int (2^d) * real_of_int (2^d) /
       real_of_int q * real_of_int x"] by auto
  also have "\<dots> \<le> 1/2 + abs (real_of_int q / real_of_int (2^d) *
    (real_of_int (compress d x) -
     real_of_int (2^d) / real_of_int q * real_of_int x))"
    proof -
      have part_one:
        "abs (real_of_int (decompress d (compress d x)) -
        real_of_int q / real_of_int (2^d) * real_of_int (compress d x))
        \<le> 1/2"
        unfolding decompress_def
        using of_int_round_abs_le[of "real_of_int q *
          real_of_int (compress d x) / real_of_int 2^d"] by simp
      have "real_of_int q * real_of_int (compress d x) / 2^d -
        real_of_int x =
        real_of_int q * (real_of_int (compress d x) -
        2^d * real_of_int x / real_of_int q) / 2^d"
        by (smt (verit, best) divide_cancel_right
        nonzero_mult_div_cancel_left of_int_eq_0_iff
        q_nonzero right_diff_distrib times_divide_eq_left
        zero_less_power)
      then have part_two:
        "abs (real_of_int q / real_of_int (2^d) *
        real_of_int (compress d x) -
        real_of_int q / real_of_int (2^d) * real_of_int (2^d) /
        real_of_int q * x) =
        abs (real_of_int q / real_of_int (2^d) *
        (real_of_int (compress d x) - real_of_int (2^d) /
        real_of_int q * x)) " by auto
      show ?thesis using part_one part_two by auto
   qed
  also have "\<dots> = 1/2 + (real_of_int q / real_of_int (2^d)) *
      abs (real_of_int (compress d x) - real_of_int (2^d) /
      real_of_int q * real_of_int x)"
    by (subst abs_mult) (smt (verit, best) assms(2)
      less_divide_eq_1_pos of_int_add of_int_hom.hom_one
      of_int_power powr_realpow twod_lt_q zero_less_power)
  also have "\<dots> \<le> 1/2 + (real_of_int q / real_of_int (2^d)) * (1/2) "
    using compress_no_mod[OF assms]
    using of_int_round_abs_le[of "real_of_int (2^d) *
      real_of_int x / real_of_int q"]
    by (smt (verit, ccfv_SIG) divide_nonneg_nonneg left_diff_distrib
      mult_less_cancel_left_pos of_int_mult of_int_nonneg q_gt_zero
      times_divide_eq_left zero_le_power)
  finally have "real_of_int (abs (decompress d (compress d x) - x)) \<le>
                real_of_int q / real_of_int (2*2^d) + 1/2"
    by simp
  then show ?thesis unfolding round_def using le_floor_iff
    by fastforce
qed

lemma no_mod_plus_minus:
  assumes "abs y \<le> round ( real_of_int q / real_of_int (2^(d+1)))"
          "d>0"
  shows "abs y = abs (y mod+- q)"
proof -
  have "round (real_of_int q / real_of_int (2^(d+1))) \<le> \<lfloor>q/2\<rfloor>"
  unfolding round_def
  proof -
    have "real_of_int q/real_of_int (2^d) \<le> real_of_int q/2"
    using \<open>d>0\<close>
    proof -
      have "1 / real_of_int (2^d) \<le> 1/2"
        using \<open>d>0\<close> inverse_of_nat_le[of 2 "2^d"]
        by (simp add: self_le_power)
      then show ?thesis using q_gt_zero
        by (smt (verit, best) frac_less2 of_int_le_0_iff zero_less_power)
    qed
    moreover have "real_of_int q/2 + 1 \<le> real_of_int q"
      using q_gt_two by auto
    ultimately have "real_of_int q / real_of_int (2^d) + 1 \<le>
      real_of_int q" by linarith
    then have fact: "real_of_int q / real_of_int (2 ^ (d + 1)) +
      1/2 \<le> real_of_int q/2"
      by auto
    then show "\<lfloor>real_of_int q / real_of_int (2 ^ (d + 1)) + 1/2\<rfloor> \<le>
      \<lfloor>real_of_int q/2\<rfloor>"
      using floor_mono[OF fact] by auto
  qed
  then have "abs y \<le> \<lfloor>q/2\<rfloor>" using assms by auto
  then show ?thesis using mod_plus_minus_range_odd[OF q_gt_zero q_odd]
  by (smt (verit, del_insts) mod_plus_minus_def mod_pos_pos_trivial neg_mod_plus_minus
    q_odd two_mid_lt_q)
qed

lemma decompress_compress_no_mod_plus_minus:
  assumes "x\<in>{0..\<lceil>q-(q/(2*2^d))\<rceil>-1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
          "d>0"
  shows "abs ((decompress d (compress d x) - x) mod+- q) \<le>
          round ( real_of_int q / real_of_int (2^(d+1)))"
proof -
  have "abs ((decompress d (compress d x) - x) mod+- q) =
        abs ((decompress d (compress d x) - x)) "
    using no_mod_plus_minus[OF decompress_compress_no_mod
      [OF assms(1) assms(2)] assms(3)] by auto
  then show ?thesis using decompress_compress_no_mod
    [OF assms(1) assms(2)] by auto
qed

text \<open>Now lets look at what happens when the \<open>mod+-\<close> reduction comes into action.\<close>

lemma decompress_compress_mod:
  assumes "x\<in>{\<lceil>q-(q/(2*2^d))\<rceil>..q-1}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
  shows "abs ((decompress d (compress d x) - x) mod+- q) \<le>
         round ( real_of_int q / real_of_int (2^(d+1)))"
proof -
  have "(decompress d (compress d x) - x) = - x"
    using compress_mod[OF assms] unfolding decompress_def
    by auto
  moreover have "-x mod+- q = -x+q"
  proof -
    have range_x: "x \<in> {\<lfloor>real_of_int q / 2\<rfloor><..q - 1}" using assms(1)
      break_point_gt_q_div_two[OF assms(2)] by auto
    then have *: "- x \<in> {-q + 1..< -\<lfloor>real_of_int q / 2\<rfloor>}" by auto
    have **: "-x + q \<in>{0..<q-\<lfloor>real_of_int q / 2\<rfloor>}" using * by auto
    have "-x + q \<in>{0..<q}"
    proof (subst atLeastLessThan_iff)
      have "q-\<lfloor>real_of_int q / 2\<rfloor> \<le> q" using q_gt_zero by auto
      moreover have "0 \<le> - x + q \<and> - x + q < q-\<lfloor>real_of_int q / 2\<rfloor>" using ** by auto
      ultimately show "0 \<le> - x + q \<and> - x + q < q" by linarith
    qed
    then have rew: "-x mod q = -x + q" using mod_rangeE by fastforce
    have "-x mod q < q - \<lfloor>real_of_int q / 2\<rfloor>" using ** by (subst rew)(auto simp add: * range_x)
    then have "\<lfloor>real_of_int q / 2\<rfloor> \<ge> - x mod q" by linarith
    then show ?thesis unfolding mod_plus_minus_def using rew by auto
  qed
  moreover have "abs (q - x) \<le> round ( real_of_int q /
    real_of_int (2^(d+1)))"
  proof -
    have "abs (q-x) = q-x"
      using assms(1) by auto
    also have "\<dots> \<le> q - \<lceil>q - q/(2*2^d)\<rceil>"
      using assms(1) by simp
    also have "\<dots> = - \<lceil>- q/(2*2^d)\<rceil>"
      using ceiling_int[of q "- q/(2*2^d)"] by auto
    also have "\<dots> = \<lfloor>q/(2*2^d)\<rfloor>"
      by (simp add: ceiling_def)
    also have "\<dots> \<le> round (q/(2*2^d))"
      using floor_le_round by blast
    finally have "abs (q-x) \<le> round (q/(2^(d+1)))" by auto
    then show ?thesis by auto
  qed
  ultimately show ?thesis by auto
qed

text \<open>Together, we can determine the general error bound on
  decompression of compression of the data.
  This error needs to be small enough not to disturb the encryption and decryption process.\<close>

lemma decompress_compress:
  assumes "x\<in>{0..<q}"
          "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
          "d>0"
  shows "let x' = decompress d (compress d x) in
         abs ((x' - x) mod+- q) \<le>
          round ( real_of_int q / real_of_int (2^(d+1)) )"
proof (cases "x<\<lceil>q-(q/(2*2^d))\<rceil>")
case True
  then have range_x: "x\<in>{0..\<lceil>q-(q/(2*2^d))\<rceil>-1}"
    using assms(1) by auto
  show ?thesis unfolding Let_def
    using decompress_compress_no_mod_plus_minus[OF
    range_x assms(2) assms(3)] by auto
next
case False
  then have range_x: "x\<in>{\<lceil>q-(q/(2*2^d))\<rceil>..q-1}"
    using assms(1) by auto
  show ?thesis unfolding Let_def
    using decompress_compress_mod[OF range_x assms(2)]
    by auto
qed

text \<open>We have now defined compression only on integers (ie \<open>{0..<q}\<close>, corresponding to \<open>\<int>_q\<close>).
  We need to extend this notion to the ring \<open>\<int>_q[X]/(X^n+1)\<close>. Here, a compressed polynomial
  is the compression on every coefficient.\<close>

text \<open>
How to channel through the types
\begin{itemize}
\item \<open>to_qr :: 'a mod_ring poly \<Rightarrow> 'a qr\<close>
\item \<open>Poly ::  'a mod_ring list \<Rightarrow> 'a mod_ring poly\<close>
\item \<open>map of_int_mod_ring :: int list \<Rightarrow> 'a mod_ring list\<close>
\item \<open>map compress :: int list \<Rightarrow> int list\<close>
\item \<open>map to_int_mod_ring :: 'a mod_ring list \<Rightarrow> int list\<close>
\item \<open>coeffs :: 'a mod_ring poly \<Rightarrow> 'a mod_ring list\<close>
\item \<open>of_qr :: 'a qr \<Rightarrow> 'a mod_ring poly\<close>
\end{itemize}
\<close>
definition compress_poly :: "nat \<Rightarrow> 'a qr \<Rightarrow> 'a qr" where
  "compress_poly d =
        to_qr \<circ>
        Poly \<circ>
        (map of_int_mod_ring) \<circ>
        (map (compress d)) \<circ>
        (map to_int_mod_ring) \<circ>
        coeffs \<circ>
        of_qr"

definition decompress_poly :: "nat \<Rightarrow> 'a qr \<Rightarrow> 'a qr" where
  "decompress_poly d =
        to_qr \<circ>
        Poly \<circ>
        (map of_int_mod_ring) \<circ>
        (map (decompress d)) \<circ>
        (map to_int_mod_ring) \<circ>
        coeffs \<circ>
        of_qr"

text \<open>Lemmas for compression error for polynomials. Lemma telescope to go qrom module level
    down to integer coefficients and back up again.\<close>

lemma of_int_mod_ring_eq_0:
  "((of_int_mod_ring x :: 'a mod_ring) = 0) \<longleftrightarrow>
    (x mod q = 0)"
by (metis CARD_a mod_0 of_int_code(2)
  of_int_mod_ring.abs_eq of_int_mod_ring.rep_eq
  of_int_of_int_mod_ring)

lemma dropWhile_mod_ring:
  "dropWhile ((=)0) (map of_int_mod_ring xs :: 'a mod_ring list) =
   map of_int_mod_ring (dropWhile (\<lambda>x. x mod q = 0) xs)"
proof (induct xs)
  case (Cons x xs)
  have "dropWhile ((=) 0) (map of_int_mod_ring (x # xs)) =
        dropWhile ((=) 0) ((of_int_mod_ring x :: 'a mod_ring) #
        (map of_int_mod_ring xs))"
    by auto
  also have "\<dots> = (if 0 = (of_int_mod_ring x :: 'a mod_ring)
    then dropWhile ((=) 0) (map of_int_mod_ring xs)
    else map of_int_mod_ring (x # xs))"
    unfolding dropWhile.simps(2)[of "((=) 0)"
      "of_int_mod_ring x :: 'a mod_ring" "map of_int_mod_ring xs"]
    by auto
  also have "\<dots> = (if x mod q = 0
    then map of_int_mod_ring (dropWhile (\<lambda>x. x mod q = 0) xs)
    else map of_int_mod_ring (x # xs))"
    using of_int_mod_ring_eq_0 unfolding Cons.hyps by auto
  also have "\<dots> = map of_int_mod_ring (dropWhile (\<lambda>x. x mod q = 0)
    (x # xs))"
    unfolding dropWhile.simps(2) by auto
  finally show ?case by blast
qed simp

lemma strip_while_mod_ring:
"(strip_while ((=) 0) (map of_int_mod_ring xs :: 'a mod_ring list)) =
  map of_int_mod_ring (strip_while (\<lambda>x. x mod q = 0)  xs)"
unfolding strip_while_def comp_def rev_map dropWhile_mod_ring by auto

lemma of_qr_to_qr_Poly:
  assumes "length (xs :: int list) < Suc (nat n)"
          "xs \<noteq> []"
  shows "of_qr (to_qr
    (Poly (map (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) xs))) =
     Poly (map (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) xs)"
    (is "_ = ?Poly")
proof -
  have deg: "degree (?Poly) < n"
    using deg_Poly'[of "map of_int_mod_ring xs"] assms
    by (smt (verit, del_insts) One_nat_def Suc_pred degree_0
      length_greater_0_conv length_map less_Suc_eq_le
      order_less_le_trans zless_nat_eq_int_zless)
  then show ?thesis
    using of_qr_to_qr[of "?Poly"] deg_mod_qr_poly[of "?Poly"]
      deg_qr_n by (smt (verit, best) of_nat_less_imp_less)
qed

lemma telescope_stripped:
  assumes "length (xs :: int list) < Suc (nat n)"
    "strip_while (\<lambda>x. x mod q = 0) xs = xs"
    "set xs \<subseteq> {0..<q}"
  shows "(map to_int_mod_ring)
    (coeffs (of_qr (to_qr (Poly
    (map (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) xs))))) = xs"
proof (cases "xs = []")
case False
  have ge_zero: "0\<le>x" and lt_q:"x < int CARD ('a)"
    if "x\<in>set xs" for x
    using assms(3) CARD_a atLeastLessThan_iff that by auto
  have to_int_of_int: "map (to_int_mod_ring \<circ>
    (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring)) xs = xs"
    using to_int_mod_ring_of_int_mod_ring[OF ge_zero lt_q]
    by (simp add: map_idI)
  show ?thesis using assms(2)
    of_qr_to_qr_Poly[OF assms(1) False]
    by (auto simp add: to_int_of_int strip_while_mod_ring)
qed (simp)

lemma map_to_of_mod_ring:
  assumes "set xs \<subseteq> {0..<q}"
  shows "map (to_int_mod_ring \<circ>
    (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring)) xs = xs"
using assms by (induct xs) (simp_all add: CARD_a)

lemma telescope:
  assumes "length (xs :: int list) < Suc (nat n)"
    "set xs \<subseteq> {0..<q}"
  shows "(map to_int_mod_ring)
    (coeffs (of_qr (to_qr (Poly
    (map (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) xs))))) =
    strip_while (\<lambda>x. x mod q = 0) xs"
proof (cases "xs = strip_while (\<lambda>x. x mod q = 0) xs")
case True
  then show ?thesis using telescope_stripped assms
    by auto
next
case False
  let ?of_int = "(map (of_int_mod_ring ::
    int \<Rightarrow> 'a mod_ring) xs)"
  have "xs \<noteq> []" using False by auto
  then have "(map to_int_mod_ring)
    (coeffs (of_qr (to_qr (Poly ?of_int)))) =
    (map to_int_mod_ring) (coeffs (Poly ?of_int))"
    using of_qr_to_qr_Poly[OF assms(1)] by auto
  also have "\<dots> = (map to_int_mod_ring)
    (strip_while ((=) 0) ?of_int)"
    by auto
  also have "\<dots> = map (to_int_mod_ring \<circ>
    (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring))
    (strip_while (\<lambda>x. x mod q = 0) xs)"
    using strip_while_mod_ring by auto
  also have "\<dots> = strip_while (\<lambda>x. x mod q = 0) xs"
  using assms(2) proof (induct xs rule: rev_induct)
  case (snoc y ys)
    let ?to_of_mod_ring = "to_int_mod_ring \<circ>
      (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring)"
    have "map ?to_of_mod_ring
      (strip_while (\<lambda>x. x mod q = 0) (ys @ [y])) =
      (if y mod q = 0
       then map ?to_of_mod_ring (strip_while (\<lambda>x. x mod q = 0) ys)
       else map ?to_of_mod_ring ys @ [?to_of_mod_ring y])"
      by (subst strip_while_snoc) auto
    also have "\<dots> = (if y mod q = 0
        then strip_while (\<lambda>x. x mod q = 0) ys
        else map ?to_of_mod_ring ys @ [?to_of_mod_ring y])"
    using snoc by fastforce
    also have "\<dots> = (if y mod q = 0
        then strip_while (\<lambda>x. x mod q = 0) ys
        else ys @ [y])"
      using map_to_of_mod_ring[OF snoc(2)] by auto
    also have "\<dots> = strip_while (\<lambda>x. x mod q = 0) (ys @ [y])"
      by auto
    finally show ?case .
  qed simp
  finally show ?thesis by auto
qed

lemma length_coeffs_of_qr:
  "length (coeffs (of_qr (x ::'a qr))) < Suc (nat n)"
proof (cases "x=0")
case False
  then have "of_qr x \<noteq> 0" by simp
  then show ?thesis
    using length_coeffs_degree[of "of_qr x"] deg_of_qr[of x]
    using deg_qr_n by fastforce
qed  (auto simp add: n_gt_zero)
end

lemma strip_while_change:
  assumes "\<And>x. P x \<longrightarrow> S x" "\<And>x. (\<not> P x) \<longrightarrow> (\<not> S x)"
  shows "strip_while P xs = strip_while S xs"
proof (induct xs rule: rev_induct)
case (snoc x xs)
  have "P x = S x" using assms[of x] by blast
  then show ?case by (simp add: snoc.hyps)
qed simp

lemma strip_while_change_subset:
  assumes "set xs \<subseteq> s"
    "\<forall>x\<in>s. P x \<longrightarrow> S x"
    "\<forall>x\<in>s. (\<not> P x) \<longrightarrow> (\<not> S x)"
  shows "strip_while P xs = strip_while S xs"
using assms(1) proof (induct xs rule: rev_induct)
case (snoc x xs)
  have "x\<in>s" using snoc(2) by simp
  then have "P x \<longrightarrow> S x" and "(\<not> P x) \<longrightarrow> (\<not> S x)"
    using assms(2) assms(3) by auto
  then have "P x = S x" by blast
  then show ?case
  using snoc.hyps snoc.prems by auto
qed simp

text \<open>Estimate for decompress compress for polynomials. Using the inequality for integers,
  chain it up to the level of polynomials.\<close>
context kyber_spec
begin
lemma decompress_compress_poly:
  assumes "of_nat d < \<lceil>(log 2 q)::real\<rceil>"
          "d>0"
  shows "let x' = decompress_poly d (compress_poly d x) in
    abs_infty_poly (x - x') \<le>
    round ( real_of_int q / real_of_int (2^(d+1)) )"
proof -
  let ?x' = "decompress_poly d (compress_poly d x)"
  have "abs_infty_q (poly.coeff (of_qr (x - ?x')) xa)
       \<le> round (real_of_int q / real_of_int (2 ^ (d + 1)))"
  for xa
  proof -
    let ?telescope = "(\<lambda>xs. (map to_int_mod_ring)
      (coeffs (of_qr (to_qr (Poly
      (map (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) xs))))))"
    define compress_x where
      "compress_x =  map (compress d \<circ> to_int_mod_ring)
      (coeffs (of_qr x))"
    let ?to_Poly = "(\<lambda>a. Poly (map ((of_int_mod_ring ::
      int \<Rightarrow> 'a mod_ring) \<circ> decompress d) a))"
    have "abs_infty_q (poly.coeff (of_qr x) xa -
      poly.coeff (of_qr (to_qr (?to_Poly
      (?telescope compress_x)))) xa ) =
      abs_infty_q (poly.coeff (of_qr x) xa -
      poly.coeff (of_qr (to_qr (?to_Poly
      (strip_while (\<lambda>x. x = 0) compress_x)))) xa )"
    proof (cases "x = 0")
    case True
      then have "compress_x = []"
        unfolding compress_x_def by auto
      then show ?thesis by simp
    next
    case False
      then have nonempty:"compress_x \<noteq> []"
        unfolding compress_x_def by simp
      have "length compress_x < Suc (nat n)"
         by (auto simp add: compress_x_def length_coeffs_of_qr)
      moreover have "set compress_x \<subseteq> {0..<q}"
      proof -
        have to: "to_int_mod_ring (s::'a mod_ring) \<in>
            {0..q - 1}" for s
          using to_int_mod_ring_range by auto
        have "compress d (to_int_mod_ring (s::'a mod_ring)) \<in>
          {0..<q}" for s
          using range_compress[OF to assms(1), of s]
          twod_lt_q[OF assms(1)]
          by (simp add: powr_realpow)
        then show ?thesis unfolding compress_x_def by auto
      qed
      ultimately have "?telescope compress_x =
        strip_while (\<lambda>x. x mod q = 0) compress_x"
        by (intro telescope[of "compress_x"]) simp
      moreover have "strip_while (\<lambda>x. x mod q = 0) compress_x =
        strip_while (\<lambda>x. x = 0) compress_x"
      proof -
        have \<open>compress d s = 0\<close> if \<open>compress d s mod q = 0\<close> for s
        proof -
          from \<open>int d < \<lceil>log 2 (real_of_int q)\<rceil>\<close> twod_lt_q [of d]
          have \<open>2 ^ d < q\<close>
            by (simp add: powr_realpow)
          with compress_less [of d s] have \<open>compress d s < q\<close>
            by simp
          then have \<open>compress d s = compress d s mod q\<close>
            by (simp add: compress_def)
          with that show ?thesis
            by simp
        qed
        then have right: "\<And>s. compress d s mod q = 0 \<longrightarrow>
          compress d s = 0" by simp
        have  "\<not> (compress d s = 0)"
          if "\<not> (compress d s mod q = 0)" for s
          using twod_lt_q compress_def that by force
        then have left: "\<And>s. \<not> (compress d s mod q = 0) \<longrightarrow>
          \<not> (compress d s = 0)" by simp
        have "strip_while (\<lambda>x. x mod q = 0) compress_x =
          strip_while (\<lambda>x. x mod q = 0) (map (compress d)
          (map to_int_mod_ring (coeffs (of_qr x))))"
          (is "_ = strip_while (\<lambda>x. x mod q = 0)
            (map (compress d) ?rest)")
          unfolding compress_x_def by simp
        also have "\<dots> = map (compress d)
          (strip_while ((\<lambda>y. y mod q = 0) \<circ> compress d)
          (map to_int_mod_ring (coeffs (of_qr x))))"
          using strip_while_map[of "\<lambda>y. y mod q = 0" "compress d"]
          by blast
        also have "\<dots> = map (compress d)
          (strip_while ((\<lambda>y. y = 0) \<circ> compress d)
          (map to_int_mod_ring (coeffs (of_qr x))))"
          by (smt (verit, best) comp_eq_dest_lhs left right
            strip_while_change)
        also have "\<dots> = strip_while (\<lambda>x. x = 0)
          (map (compress d) ?rest)"
          using strip_while_map[of "\<lambda>y. y = 0"
            "compress d", symmetric] by blast
        finally show ?thesis
          unfolding compress_x_def by auto
      qed
      ultimately show ?thesis by auto
    qed
    also have "\<dots> = abs_infty_q (poly.coeff (of_qr x) xa -
      poly.coeff (?to_Poly (strip_while (\<lambda>x. x = 0) compress_x)) xa)"
    proof (cases "?to_Poly (strip_while (\<lambda>x. x = 0) compress_x) = 0")
    case False
      have "degree (?to_Poly (strip_while (\<lambda>x. x = 0) compress_x)) \<le>
        length (map ((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ>
        decompress d) (strip_while (\<lambda>x. x = 0) compress_x)) - 1"
        using deg_Poly'[OF False] .
      moreover have "length (map (of_int_mod_ring \<circ> decompress d)
          (strip_while (\<lambda>x. x = 0) compress_x)) \<le>
          length (coeffs (of_qr x))"
        unfolding compress_x_def
        by (metis length_map length_strip_while_le)
      moreover have "length (coeffs (of_qr x)) - 1 < deg_qr TYPE('a)"
        using deg_of_qr degree_eq_length_coeffs by metis
      ultimately have deg:
        "degree (?to_Poly (strip_while (\<lambda>x. x = 0) compress_x)) <
        deg_qr TYPE('a)" by auto
      show ?thesis using of_qr_to_qr'
        by (simp add: of_qr_to_qr'[OF deg])
    qed simp
    also have "\<dots> = abs_infty_q (poly.coeff (of_qr x) xa -
      poly.coeff (Poly (map of_int_mod_ring (strip_while (\<lambda>x. x = 0)
        (map (decompress d) compress_x)))) xa )"
    proof -
      have  "s = 0" if "decompress d s = 0" "s \<in> {0..2^d - 1}" for s
        using decompress_zero_unique[OF that assms(1)] .
      then have right: "\<forall>s \<in> {0..2^d-1}. decompress d s = 0 \<longrightarrow>
        s = 0" by simp
      have left: "\<forall> s \<in> {0..2^d-1}. decompress d s \<noteq> 0 \<longrightarrow> s \<noteq> 0"
        using decompress_zero[of d] by auto
      have compress_x_range: "set compress_x \<subseteq> {0..2^d - 1}"
        unfolding compress_x_def compress_def by auto
      have "map (decompress d) (strip_while (\<lambda>x. x = 0) compress_x) =
        map (decompress d) (strip_while (\<lambda>x. decompress d x = 0)
          compress_x)"
      using strip_while_change_subset[OF compress_x_range right left]
        by auto
      also have "\<dots> = strip_while (\<lambda>x. x = 0)
        (map (decompress d) compress_x)"
      proof -
        have "(\<lambda>x. x = 0) \<circ> decompress d = (\<lambda>x. decompress d x = 0)"
          using comp_def by blast
        then show ?thesis
          using strip_while_map[symmetric, of "decompress d"
            "\<lambda>x. x=0" compress_x] by auto
      qed
      finally have "map (decompress d) (strip_while (\<lambda>x. x = 0)
        compress_x) =  strip_while (\<lambda>x. x = 0) (map (decompress d)
        compress_x)" by auto
      then show ?thesis by (metis map_map)
    qed
    also have "\<dots> = abs_infty_q (poly.coeff (of_qr x) xa -
      poly.coeff (Poly (map of_int_mod_ring (strip_while
      (\<lambda>x. x mod q = 0) (map (decompress d) compress_x)))) xa )"
    proof -
      have range: "set (map (decompress d) compress_x) \<subseteq> {0..<q}"
        unfolding compress_x_def compress_def
        using range_decompress[OF _ assms(1)] by auto
      have right: " \<forall>x\<in>{0..<q}. x = 0 \<longrightarrow> x mod q = 0" by auto
      have left: "\<forall>x\<in>{0..<q}. \<not> x = 0 \<longrightarrow> \<not> x mod q = 0" by auto
      have "strip_while (\<lambda>x. x = 0) (map (decompress d) compress_x) =
        strip_while (\<lambda>x. x mod q = 0) (map (decompress d) compress_x)"
      using strip_while_change_subset[OF range right left] by auto
      then show ?thesis by auto
    qed
    also have "\<dots> = abs_infty_q (poly.coeff (of_qr x) xa -
      poly.coeff (Poly (map of_int_mod_ring
      (map (decompress d) compress_x))) xa )"
      by (metis Poly_coeffs coeffs_Poly strip_while_mod_ring)
    also have "\<dots> = abs_infty_q (poly.coeff (of_qr x) xa -
      ((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ> decompress d \<circ>
        compress d \<circ> to_int_mod_ring) (poly.coeff (of_qr x) xa))"
    using coeffs_Poly
    proof (cases "xa < length (coeffs (?to_Poly  compress_x))")
    case True
      have "poly.coeff (?to_Poly compress_x) xa =
            coeffs (?to_Poly compress_x) ! xa"
      using nth_coeffs_coeff[OF True] by simp
      also have "\<dots> = strip_while ((=) 0) (map (
        (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ> decompress d)
        compress_x) ! xa"
        using coeffs_Poly by auto
      also have "\<dots> = (map ((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ>
        decompress d) compress_x) ! xa"
        using True by (metis coeffs_Poly nth_strip_while)
      also have "\<dots> = ((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ>
        decompress d \<circ> compress d \<circ> to_int_mod_ring)
        (coeffs (of_qr x) ! xa)"
        unfolding compress_x_def
        by (smt (z3) True coeffs_Poly compress_x_def length_map
          length_strip_while_le map_map not_less nth_map order_trans)
      also have "\<dots> = ((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ>
        decompress d \<circ> compress d \<circ> to_int_mod_ring)
        (poly.coeff (of_qr x) xa)"
        by (metis (no_types, lifting) True coeffs_Poly compress_x_def
          length_map length_strip_while_le not_less nth_coeffs_coeff
          order.trans)
      finally have no_coeff: "poly.coeff (?to_Poly compress_x) xa =
          ((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ> decompress d \<circ>
          compress d \<circ> to_int_mod_ring) (poly.coeff (of_qr x) xa)"
        by auto
      show ?thesis unfolding compress_x_def
      by (metis compress_x_def map_map no_coeff)
    next
    case False
      then have "poly.coeff (?to_Poly compress_x) xa = 0"
        by (metis Poly_coeffs coeff_Poly_eq nth_default_def)
      moreover have "((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ>
        decompress d \<circ> compress d \<circ> to_int_mod_ring)
        (poly.coeff (of_qr x) xa) = 0"
      proof (cases "poly.coeff (of_qr x) xa = 0")
      case True
        then show ?thesis using compress_zero decompress_zero
          by auto
      next
      case False
        then show ?thesis
        proof (subst ccontr, goal_cases)
        case 1
          then have "poly.coeff (?to_Poly compress_x) xa \<noteq> 0"
            by (subst coeff_Poly) (metis (no_types, lifting) comp_apply
              compress_x_def compress_zero decompress_zero map_map
              nth_default_coeffs_eq nth_default_map_eq
              of_int_mod_ring_hom.hom_zero to_int_mod_ring_hom.hom_zero)
          then show ?case using \<open>poly.coeff (?to_Poly compress_x) xa = 0\<close>
            by auto
        qed auto
      qed
      ultimately show ?thesis by auto
    qed
    also have "\<dots> = abs_infty_q (
      ((of_int_mod_ring :: int \<Rightarrow> 'a mod_ring) \<circ> decompress d \<circ>
        compress d \<circ> to_int_mod_ring) (poly.coeff (of_qr x) xa) -
        poly.coeff (of_qr x) xa)"
      using abs_infty_q_minus by (metis minus_diff_eq)
    also have "\<dots> = \<bar>((decompress d \<circ> compress d \<circ> to_int_mod_ring)
      (poly.coeff (of_qr x) xa) -
       to_int_mod_ring (poly.coeff (of_qr x) xa)) mod+- q\<bar>"
      unfolding abs_infty_q_def
      using to_int_mod_ring_of_int_mod_ring
      by (smt (verit, best) CARD_a comp_apply mod_plus_minus_def
        of_int_diff of_int_mod_ring.rep_eq
        of_int_mod_ring_to_int_mod_ring of_int_of_int_mod_ring)
    also have "\<dots> \<le> round (real_of_int q / real_of_int (2 ^ (d + 1)))"
    proof -
      have range_to_int_mod_ring:
        "to_int_mod_ring (poly.coeff (of_qr x) xa) \<in> {0..<q}"
        using to_int_mod_ring_range by auto
      then show ?thesis
        unfolding abs_infty_q_def Let_def
        using decompress_compress[OF range_to_int_mod_ring assms]
        by simp
    qed
    finally have "abs_infty_q (poly.coeff (of_qr x) xa - poly.coeff
      (of_qr (to_qr (?to_Poly (?telescope compress_x)))) xa )
      \<le> round (real_of_int q / real_of_int (2 ^ (d + 1)))" by auto
    then show ?thesis unfolding compress_x_def decompress_poly_def
      compress_poly_def by (auto simp add: o_assoc)
  qed
  moreover have finite:
    "finite (range (abs_infty_q \<circ> poly.coeff (of_qr (x - ?x'))))"
    by (metis finite_Max image_comp image_image)
  ultimately show ?thesis unfolding abs_infty_poly_def
    using Max_le_iff[OF finite] by auto
qed

text \<open>More properties of compress and decompress, used for returning message at the end.\<close>

lemma compress_1:
  shows "compress 1 x \<in> {0,1}"
unfolding compress_def by auto

lemma compress_poly_1:
  shows "\<forall>i. poly.coeff (of_qr (compress_poly 1 x)) i \<in> {0,1}"
proof -
  have "poly.coeff (of_qr (compress_poly 1 x)) i \<in> {0,1}"
    for i
  proof -
    have "set (map (compress 1)
      ((map to_int_mod_ring \<circ> coeffs \<circ> of_qr) x)) \<subseteq> {0,1}"
      using compress_1 by auto
    then have "set ((map (compress 1) \<circ> map to_int_mod_ring \<circ>
      coeffs \<circ> of_qr) x) \<subseteq> {0,1}"
      (is "set (?compressed_1) \<subseteq> _")
      by auto
    then have "set (map (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring)
      ?compressed_1) \<subseteq> {0,1}"
      (is "set (?of_int_compressed_1)\<subseteq>_")
      by (smt (verit, best) imageE insert_iff of_int_mod_ring_hom.hom_zero
        of_int_mod_ring_to_int_mod_ring set_map singletonD subsetD subsetI
        to_int_mod_ring_hom.hom_one)
    then have "nth_default 0 (?of_int_compressed_1) i
       \<in> {0,1}"
       by (smt (verit, best) comp_apply compress_1 compress_zero
        insert_iff nth_default_map_eq of_int_mod_ring_hom.hom_zero
        of_int_mod_ring_to_int_mod_ring singleton_iff
        to_int_mod_ring_hom.hom_one)
    moreover have "Poly (?of_int_compressed_1)
      = Poly (?of_int_compressed_1) mod qr_poly"
    proof -
      have "degree (Poly (?of_int_compressed_1)) < deg_qr TYPE('a)"
      proof (cases "Poly ?of_int_compressed_1 \<noteq> 0")
      case True
        have "degree (Poly ?of_int_compressed_1) \<le>
          length (map (of_int_mod_ring :: int \<Rightarrow> 'a mod_ring)
          ?compressed_1) - 1"
          using deg_Poly'[OF True] by simp
        also have "\<dots> = length ((coeffs \<circ> of_qr) x) - 1"
          by simp
        also have "\<dots> < n" unfolding comp_def
          using length_coeffs_of_qr
          by (metis deg_qr_n deg_of_qr degree_eq_length_coeffs
          nat_int zless_nat_conj)
        finally have "degree (Poly ?of_int_compressed_1) < n"
        using True \<open>int (length ((coeffs \<circ> of_qr) x) - 1) < n\<close>
          deg_Poly' by fastforce
        then show ?thesis using deg_qr_n by simp
      next
      case False
        then show ?thesis
        using deg_qr_pos by auto
      qed
      then show ?thesis
        using deg_mod_qr_poly[of "Poly (?of_int_compressed_1)",
          symmetric] by auto
    qed
    ultimately show ?thesis unfolding compress_poly_def comp_def
      using of_qr_to_qr[of "Poly (?of_int_compressed_1)"]
      by auto
  qed
  then show ?thesis by auto
qed
end

lemma of_int_mod_ring_mult:
  "of_int_mod_ring (a*b) = of_int_mod_ring a * of_int_mod_ring b"
unfolding of_int_mod_ring_def
by (metis (mono_tags, lifting) Rep_mod_ring_inverse mod_mult_eq
  of_int_mod_ring.rep_eq of_int_mod_ring_def times_mod_ring.rep_eq)

context kyber_spec
begin
lemma decompress_1:
  assumes "a\<in>{0,1}"
  shows "decompress 1 a = round(real_of_int q/2) * a"
unfolding decompress_def using assms by auto

lemma decompress_poly_1:
  assumes "\<forall>i. poly.coeff (of_qr x) i \<in> {0,1}"
  shows "decompress_poly 1 x =
    to_module (round((real_of_int q)/2)) * x"
proof -
  have "poly.coeff (of_qr (decompress_poly 1 x)) i =
   poly.coeff (of_qr (to_module (round((real_of_int q)/2)) * x)) i"
  for i
  proof -
    have "set (map to_int_mod_ring (coeffs (of_qr x))) \<subseteq> {0,1}"
    (is "set (?int_coeffs) \<subseteq> _")
    proof -
      have "set (coeffs (of_qr x)) \<subseteq> {0,1}" using assms
      by (meson forall_coeffs_conv insert_iff subset_code(1))
      then show ?thesis by auto
    qed
    then have "map (decompress 1) (?int_coeffs) =
      map ((*) (round (real_of_int q/2))) (?int_coeffs)"
    proof (induct "?int_coeffs")
    case (Cons a xa)
      then show ?case using decompress_1
      by (meson map_eq_conv subsetD)
    qed simp
    then have "poly.coeff (of_qr (decompress_poly 1 x)) i =
      poly.coeff (of_qr (to_qr (Poly (map of_int_mod_ring
        (map (\<lambda>a. round(real_of_int q/2) * a)
        (?int_coeffs)))))) i"
      unfolding decompress_poly_def comp_def by presburger
    also have "\<dots> = poly.coeff (of_qr (to_qr (Poly
        (map (\<lambda>a. of_int_mod_ring ((round(real_of_int q/2)) * a))
        (?int_coeffs))))) i"
      using map_map[of of_int_mod_ring "((*) (round (real_of_int q/2)))"]
      by (smt (z3) map_eq_conv o_apply)
    also have "\<dots> = poly.coeff (of_qr (to_qr (Poly
        (map (\<lambda>a. of_int_mod_ring (round(real_of_int q/2)) *
        of_int_mod_ring a) (?int_coeffs))))) i"
      by (simp add: of_int_mod_ring_mult[of "(round(real_of_int q/2))"])
    also have "\<dots> = poly.coeff (of_qr (to_qr (Poly
        (map (\<lambda>a. of_int_mod_ring (round(real_of_int q/2)) * a)
        (map of_int_mod_ring (?int_coeffs)))))) i"
      using map_map[symmetric, of
        "(\<lambda>a. of_int_mod_ring (round (real_of_int q/2)) * a ::'a mod_ring)"
        "of_int_mod_ring"] unfolding comp_def by presburger
    also have "\<dots> = poly.coeff (of_qr (to_qr
        (Polynomial.smult (of_int_mod_ring (round(real_of_int q/2)))
        (Poly (map of_int_mod_ring (?int_coeffs)))))) i"
      using smult_Poly[symmetric, of
        "(of_int_mod_ring (round (real_of_int q/2)))"]
      by metis
    also have "\<dots> = poly.coeff (of_qr ((to_module
      (round (real_of_int q/2)) *
      to_qr (Poly (map of_int_mod_ring (?int_coeffs)))))) i"
      unfolding to_module_def
      using to_qr_smult_to_module
        [of "of_int_mod_ring (round (real_of_int q/2))"]
      by metis
    also have "\<dots> = poly.coeff (of_qr
       (to_module (round (real_of_int q/2)) *
        to_qr (Poly (coeffs (of_qr x)))))i"
      by (subst map_map[of of_int_mod_ring to_int_mod_ring],
        unfold comp_def)(subst of_int_mod_ring_to_int_mod_ring, auto)
    also have "\<dots> = poly.coeff (of_qr
       (to_module (round (real_of_int q/2)) * x))i"
      by (subst Poly_coeffs) (subst to_qr_of_qr, simp)
    finally show ?thesis by auto
  qed
  then have eq: "of_qr (decompress_poly 1 x) =
    of_qr (to_module (round((real_of_int q)/2)) * x)"
    by (simp add: poly_eq_iff)
  show ?thesis using arg_cong[OF eq, of "to_qr"]
    to_qr_of_qr[of "decompress_poly 1 x"]
    to_qr_of_qr[of "to_module (round (real_of_int q/2)) * x"]
    by auto
qed
end
text \<open>Compression and decompression for vectors.\<close>

definition map_vector ::
  "('b \<Rightarrow> 'c) \<Rightarrow> ('b, 'n) vec \<Rightarrow> ('c, 'n::finite) vec" where
  "map_vector f v = (\<chi> i. f (vec_nth v i))"

context kyber_spec
begin
text \<open>Compression and decompression of vectors in \<open>\<int>_q[X]/(X^n+1)\<close>.\<close>

definition compress_vec ::
  "nat \<Rightarrow> ('a qr, 'k) vec \<Rightarrow> ('a qr, 'k) vec" where
  "compress_vec d = map_vector (compress_poly d)"

definition decompress_vec ::
  "nat \<Rightarrow> ('a qr, 'k) vec \<Rightarrow> ('a qr, 'k) vec" where
  "decompress_vec d = map_vector (decompress_poly d)"

end

end


theory Treaps
  imports Main "HOL.Real" "HOL.List"
begin

datatype ('a::linorder) treap =
  Leaf ("\<langle>\<rangle>") |
  Node "'a treap" ("key": 'a) ("prio": real) "'a treap" ("(1\<langle>_,/ _,/ _,/ _\<rangle>)")

primrec key :: "('a::linorder) treap \<Rightarrow> 'a" where
  "key \<langle>l, k, p, r\<rangle> = k" |
  "key \<langle>\<rangle> = undefined"

primrec prio :: "('a::linorder) treap \<Rightarrow> real" where
  "prio \<langle>l, k, p, r\<rangle> = p" |
  "prio \<langle>\<rangle> = 1"

primrec left :: "('a::linorder) treap \<Rightarrow> 'a treap" where
  "left \<langle>l, k, p, r\<rangle> = l" |
  "left \<langle>\<rangle> = \<langle>\<rangle>"

primrec right :: "('a::linorder) treap \<Rightarrow> 'a treap" where
  "right \<langle>l, k, p, r\<rangle> = r" |
  "right \<langle>\<rangle> = \<langle>\<rangle>"

fun height :: "('a::linorder) treap \<Rightarrow> nat" where
  "height \<langle>\<rangle> = 0" |
  "height \<langle>l, k, p, r\<rangle> = max (height l) (height r) + 1"

fun min_height :: "('a::linorder) treap \<Rightarrow> nat" where
  "min_height \<langle>\<rangle> = 0" |
  "min_height \<langle>l, k, p, r\<rangle> = min (height l) (height r) + 1"

fun size :: "('a::linorder) treap \<Rightarrow> nat" where
  "size \<langle>\<rangle> = 0" |
  "size \<langle>l, k, p, r\<rangle> = (size l) + (size r) + 1"

fun set :: "('a::linorder) treap \<Rightarrow> ('a \<times> real) set" where
  Leaf: "set \<langle>\<rangle> = {}" |
  Node: "set \<langle>l, k, p, r\<rangle> = {(k, p)} \<union> set l \<union> set r"

lemma set_finite: "finite (set t)" by(induction t, auto)
lemma child_subset: "set (left t) \<subseteq> set t" "set (right t) \<subseteq> set t" by(induction t, auto)
lemma not_in_set_not_in_tree1:
  assumes "t \<noteq> \<langle>\<rangle>"
      and "(k, p) \<notin> set t"
    shows "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<notin> set (left t) \<and> (k, p) \<notin> set (right t)"
  using assms by(induction t, auto)

inductive descendant_of :: "('a::linorder) treap \<Rightarrow> ('a::linorder) treap \<Rightarrow> bool" where
  Left: "descendant_of l \<langle>l, k, p, r\<rangle>" |
  Right: "descendant_of r \<langle>l, k, p, r\<rangle>" |
  Cont: "\<lbrakk> descendant_of a b; descendant_of b c \<rbrakk> \<Longrightarrow> descendant_of a c"

lemma descendant_subset:
  "descendant_of c t \<Longrightarrow> set c \<subseteq> set t"
  by(induction c t rule: descendant_of.induct, auto)

lemma not_in_set_not_in_tree2:
  assumes "descendant_of c t"
      and "t \<noteq> \<langle>\<rangle>"
      and "c \<noteq> \<langle>\<rangle>"
      and "(k, p) \<notin> set t"
    shows "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<noteq> (key c, prio c)"
  using assms proof(induction c t rule: descendant_of.induct)
  case (Left l k p r)
  then show ?case using not_in_set_not_in_tree1 by auto
next
  case (Right r l k p)
  then show ?case using not_in_set_not_in_tree1 by auto
next
  case (Cont a b c)
  then have "descendant_of a c"
    using descendant_of.Cont by blast
  with Cont.prems show ?case using descendant_subset not_in_set_not_in_tree1 by blast
qed

lemma not_in_set_not_in_tree3:
  assumes "descendant_of c t"
      and "c \<noteq> \<langle>\<rangle>"
      and "(k, p) \<notin> set t"
    shows "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<noteq> (key c, prio c)"
proof-
  have "t \<noteq> \<langle>\<rangle>"
    using assms(1,2) descendant_subset not_in_set_not_in_tree1 by fastforce
  then show "(k, p) \<noteq> (key t, prio t) \<and> (k, p) \<noteq> (key c, prio c)"
    using assms(1,2,3) not_in_set_not_in_tree2 by blast
qed

inductive distinct_keys :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "distinct_keys \<langle>\<rangle> " |
  Node: "\<lbrakk> distinct_keys l; distinct_keys r;
        \<forall>(x\<^sub>k, x\<^sub>p) \<in> set l . x\<^sub>k \<noteq> k; \<forall>(x\<^sub>k, x\<^sub>p) \<in> set r . x\<^sub>k \<noteq> k;
        \<forall>(l\<^sub>k, l\<^sub>p) \<in> set l. \<forall>(r\<^sub>k, r\<^sub>p) \<in> set r. l\<^sub>k \<noteq> r\<^sub>k \<rbrakk>
        \<Longrightarrow> distinct_keys \<langle>l, k, p, r\<rangle>"

lemma distinct_keys_rev: "distinct_keys \<langle>l, k, p, r\<rangle> \<Longrightarrow> distinct_keys l \<and> distinct_keys r"
  by(induction "\<langle>l, k, p, r\<rangle>" rule: distinct_keys.induct, auto)

inductive distinct_prios :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "distinct_prios \<langle>\<rangle> " |
  Node: "\<lbrakk> distinct_prios l; distinct_prios r;
        \<forall>(x\<^sub>k, x\<^sub>p) \<in> set l. x\<^sub>p \<noteq> p; \<forall>(x\<^sub>k, x\<^sub>p) \<in> set r. x\<^sub>p \<noteq> p;
        \<forall>(l\<^sub>k, l\<^sub>p) \<in> set l. \<forall>(r\<^sub>k, r\<^sub>p) \<in> set r. l\<^sub>p \<noteq> r\<^sub>p \<rbrakk>
        \<Longrightarrow> distinct_prios \<langle>l, k, p, r\<rangle>"

lemma distinct_prios_rev: "distinct_prios \<langle>l, k, p, r\<rangle> \<Longrightarrow> distinct_prios l \<and> distinct_prios r"
  by(induction "\<langle>l, k, p, r\<rangle>" rule: distinct_prios.induct, auto)

definition is_distinct :: "('a::linorder) treap \<Rightarrow> bool" where
  "is_distinct t \<equiv> distinct_keys t \<and> distinct_prios t"

lemma distinct_rev: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> is_distinct l \<and> is_distinct r"
  using distinct_keys_rev distinct_prios_rev is_distinct_def by blast

lemma distinct_root_key: "distinct_keys \<langle>l, k, p, r\<rangle> \<Longrightarrow> (k, p) \<notin> set l \<union> set r"
  by(induction "\<langle>l, k, p, r\<rangle>" arbitrary: k p rule: distinct_keys.induct, auto)

lemma distinct_root: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> (k, p) \<notin> set l \<union> set r"
  using distinct_root_key is_distinct_def by blast

lemma child_dist_if_parent_dist:
  assumes "descendant_of c p"
      and "is_distinct p"
    shows "is_distinct c"
  using assms distinct_rev by(induction c p rule: descendant_of.induct, auto)

lemma lrchilds_disjoint_key: "distinct_keys \<langle>l, k, p, r\<rangle> \<Longrightarrow> set l \<inter> set r = {}"
  by(induction "\<langle>l, k, p, r\<rangle>" arbitrary: k p rule: distinct_keys.induct, auto)

lemma lrchilds_disjoint: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> set l \<inter> set r = {}"
  using lrchilds_disjoint_key is_distinct_def by blast

lemma size_correct: "is_distinct t \<Longrightarrow> size t = card (set t)"
proof(induction t)
  case (Node l k p r)
  then have "is_distinct l"
    using distinct_rev by auto
  then have "size l = card (set l)"
    by (simp add: Node.IH(1))
  moreover from Node.prems have "is_distinct r"
    using distinct_rev by auto
  then have "size r = card (set r)"
    by (simp add: Node.IH(2))
  ultimately have "size \<langle>l, k, p, r\<rangle> = card (set l) + card (set r) + 1"
    by simp
  also have "... = card (set l \<union> set r) + 1"
    using Node.prems lrchilds_disjoint set_finite card_Un_disjoint
    by metis
  also have "... = card (set \<langle>l, k, p, r\<rangle> - {(k, p)}) + 1"
    using Node.prems distinct_root by fastforce
  also have "... = card (set \<langle>l, k, p, r\<rangle> - {(k, p)}) + card ({(k, p)})"
    by simp
  also have "... = card (set \<langle>l, k, p, r\<rangle> - {(k, p)} \<union> {(k, p)})"
    by (metis Diff_disjoint add.commute card_Un_disjoint finite.emptyI finite.insertI finite_Diff2 set_finite sup_commute)
  also have "... = card (set \<langle>l, k, p, r\<rangle>)"
    by simp
  finally show ?case .
qed(simp)

lemma set_of_childs:
  assumes "is_distinct t"
  shows "set t - {(key t, prio t)} = set (left t) \<union> set (right t)"
using assms proof(induction t rule: set.induct)
  case (2 l k p r)
  let ?t = "\<langle>l, k, p, r\<rangle>"
  from "2.prems" have "(k, p) \<notin> set l \<union> set r"
    using is_distinct_def distinct_root by blast
  then show ?case by simp
qed(simp)

lemma distinct_set_rev: "is_distinct \<langle>l, k, p, r\<rangle> \<Longrightarrow> {(k,p)} \<union> set (l) \<union> set (r) = set \<langle>l, k, p, r\<rangle>"
  by(induction "\<langle>l, k, p, r\<rangle>", auto)

inductive is_bst :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "is_bst \<langle>\<rangle>" |
  Node: "\<lbrakk> is_bst l; is_bst r;
        \<forall>(x\<^sub>k, x\<^sub>p) \<in> set l. x\<^sub>k < k; \<forall>(x\<^sub>k, x\<^sub>p) \<in> set r. k < x\<^sub>k \<rbrakk>
        \<Longrightarrow> is_bst \<langle>l, k, p, r\<rangle>"

lemma bst_rev:
  "is_bst \<langle>l, k, p, r\<rangle> \<Longrightarrow> is_bst l \<and> is_bst r \<and> (\<forall>(x\<^sub>k, x\<^sub>p) \<in> set l . x\<^sub>k < k) \<and> (\<forall>(x\<^sub>k, x\<^sub>p) \<in> set r . k < x\<^sub>k)"
  by(induction "\<langle>l, k, p, r\<rangle>" rule: is_bst.induct, blast)

lemma uni_bst[simp]: "is_bst \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
proof-
  let ?l = "\<langle>\<rangle>" let ?r = "\<langle>\<rangle>"
  have "set \<langle>\<rangle> = {}" by simp
  have "is_bst ?l" by (simp add: is_bst.Leaf)
  moreover have "is_bst ?r" by (simp add: is_bst.Leaf)
  moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set ?l. x\<^sub>k < k" by simp
  moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set ?r. k < x\<^sub>k" by simp
  ultimately have "is_bst \<langle>?l, k, p, ?r\<rangle>"
    using is_bst.simps by fastforce
  then show "is_bst \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" by simp
qed

lemma smaller_key_is_left_child:
  assumes "is_bst t"
and "is_distinct t"
  and "(k, d) \<in> set t"
shows "k < key t \<Longrightarrow> (k, d) \<in> set (left t)"
  using assms by(induction t arbitrary: k d rule: is_bst.induct, auto)

lemma larger_key_is_right_child:
  assumes "is_bst t"
and "is_distinct t"
  and "(k, d) \<in> set t"
shows "key t < k \<Longrightarrow> (k, d) \<in> set (right t)"
  using assms by(induction t arbitrary: k d rule: is_bst.induct, auto)

definition is_valid_prio :: "real \<Rightarrow> bool" where
  "is_valid_prio p \<equiv> 0 < p \<and> p < 1"

inductive is_heap :: "('a::linorder) treap \<Rightarrow> bool" where
  Leaf: "is_heap \<langle>\<rangle>" |
  Node: "\<lbrakk>is_heap l; is_heap r; prio l > p; prio r > p; is_valid_prio p \<rbrakk>
        \<Longrightarrow> is_heap \<langle>l, k, p, r\<rangle>"

lemma uni_heap[simp]: "is_valid_prio p \<Longrightarrow> is_heap \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
proof-
  assume p_valid: "is_valid_prio p"
  let ?l = "\<langle>\<rangle>" let ?r = "\<langle>\<rangle>"
  have "set \<langle>\<rangle> = {}" by simp
  have "is_heap ?l" by (simp add: is_heap.Leaf)
  moreover have "is_heap ?r" by (simp add: is_heap.Leaf)
  moreover have "prio ?l = 1"
    by simp
  then have "prio ?l > p" using p_valid by (simp add: is_valid_prio_def)
  moreover have "prio ?r = 1"
    by simp
  then have "prio ?r > p" using p_valid by (simp add: is_valid_prio_def)
  ultimately have "is_heap \<langle>?l, k, p, ?r\<rangle>"
    using is_heap.Node p_valid by blast
  then show "is_heap \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" by simp
qed

lemma heap_root_prio_lower_bound:
  assumes "is_heap t"
      and "is_distinct t"
    shows "\<forall>(k', p') \<in> set t. prio t \<le> p'"
using assms proof(induction t arbitrary: p rule: is_heap.induct)
  case (Node l r p k)
  then have
    "\<forall>(k', p') \<in> set l. prio l \<le> p'"
    "\<forall>(k', p') \<in> set r. prio r \<le> p'"
    using distinct_rev by blast+
  then have
    "\<forall>(k', p') \<in>  set l. p < p'"
    "\<forall>(k', p') \<in>  set r. p < p'"
    using Node.hyps(3,4) by fastforce+
  then have "\<forall>(k', p') \<in>  set l \<union> set r. p < p'"
    by blast
  then have "\<forall>(k', p') \<in>  set l \<union> set r. p \<le> p'"
    using less_eq_real_def by auto
  then show ?case
    by simp
qed(simp)

lemma heap_root_has_smallest_prio:
  assumes "is_heap t"
      and "is_distinct t"
    shows "\<forall>(k', p') \<in> set (left t) \<union> set (right t). prio t < p'"
using assms proof(induction t arbitrary: p rule: is_heap.induct)
  case (Node l r p k)
  obtain p\<^sub>l p\<^sub>r where p_defs: "p\<^sub>l = prio l" "p\<^sub>r = prio r" by blast
  have p_less_pl: "p < p\<^sub>l"
    using Node.hyps(3) Node.prems p_defs(1) by auto
  moreover have "p < p\<^sub>r"
    using Node.hyps(4) Node.prems p_defs(2) by auto
  moreover have
    "\<forall>(k', p') \<in> set (left l) \<union> set (right l). p\<^sub>l < p'"
    "\<forall>(k', p') \<in> set (left r) \<union> set (right r). p\<^sub>r < p'"
    using Node.IH(1, 2) Node.prems Treaps.distinct_rev p_defs by blast+
  ultimately have
    "\<forall>(k', p') \<in> set (left l) \<union> set (right l). p < p'"
    "\<forall>(k', p') \<in> set (left r) \<union> set (right r). p < p'"
    by (smt (verit, ccfv_SIG) case_prodD case_prodI2)+
  then have
    "\<forall>(k', p') \<in> set l. p < p'"
    "\<forall>(k', p') \<in> set r. p < p'"
    using p_less_pl Node.hyps(3,4) Node.prems distinct_rev set_of_childs by blast+
  then show ?case
    by force
qed(simp)

definition is_treap :: "('a::linorder) treap \<Rightarrow> bool" where
  "is_treap t \<equiv> is_bst t \<and> is_heap t"

lemma empty_treap_is_leaf:
"set t = {} \<longleftrightarrow> t = \<langle>\<rangle>"
proof
  assume empty_set: "set t = {}"
  then show "t = \<langle>\<rangle>" by(cases t, auto)
qed(simp)

text \<open>Any two treaps (each with distinct key-priority-pairs) have the same structure.
In other words: For (k\<^sub>1,p\<^sub>1) ... (k\<^sub>n,p\<^sub>n), there exists a unique treap.\<close>
theorem treap_is_unique:
  assumes distinct:      "is_distinct t\<^sub>1" "is_distinct t\<^sub>2"
      and treaps:        "is_treap t\<^sub>1" "is_treap t\<^sub>2"
      and equal_entries[simp]: "set t\<^sub>1 = set t\<^sub>2"
    shows "t\<^sub>1 = t\<^sub>2"
using assms proof(induction t\<^sub>1 arbitrary: t\<^sub>2 rule:treap.induct)
  case Leaf
    then have "set t\<^sub>2 = {}"
      by simp
    then have "t\<^sub>2 = \<langle>\<rangle>"
      using empty_treap_is_leaf by auto
    then show ?case
      by simp
next
  case (Node l\<^sub>1 k\<^sub>1 p\<^sub>1 r\<^sub>1)
  let ?t\<^sub>1 = "\<langle>l\<^sub>1, k\<^sub>1, p\<^sub>1, r\<^sub>1\<rangle>"
  let ?entries = "set ?t\<^sub>1"
  have not_leaf: "t\<^sub>2 \<noteq> \<langle>\<rangle>"
    using Node.prems(5) by force
  then obtain l\<^sub>2 k\<^sub>2 p\<^sub>2 r\<^sub>2 where t2_def: "t\<^sub>2 = \<langle>l\<^sub>2, k\<^sub>2, p\<^sub>2, r\<^sub>2\<rangle>"
    using height.cases by blast
  let ?t\<^sub>2 = "\<langle>l\<^sub>2, k\<^sub>2, p\<^sub>2, r\<^sub>2\<rangle>"
  have "is_treap l\<^sub>2" "is_treap r\<^sub>2"
    using Node.prems(4) is_heap.cases is_bst.cases is_treap_def t2_def by fastforce+

  (* roots equal *)
  have "\<forall>(k', p') \<in> set (left ?t\<^sub>1) \<union> set (right ?t\<^sub>1). prio ?t\<^sub>1 < p'"
    using Node.prems(1, 3) heap_root_has_smallest_prio is_treap_def by blast
  then have "\<forall>(k', p') \<in> ?entries - {(k\<^sub>1, p\<^sub>1)}. prio ?t\<^sub>1 < p'"
    by simp
  then have "\<forall>(k', p') \<in> ?entries - {(k\<^sub>1, p\<^sub>1)}. prio ?t\<^sub>1 \<le> p'"
    using less_imp_le by blast
  then have "\<forall>(k', p') \<in> set ?t\<^sub>1. prio ?t\<^sub>1 \<le> p'" by auto
  moreover have "\<forall>(k', p') \<in> set (left ?t\<^sub>2) \<union> set (right ?t\<^sub>2). prio ?t\<^sub>2 < p'"
    using Node.prems(2, 4) heap_root_has_smallest_prio is_treap_def t2_def by blast
  then have root2_smallest_prio: "\<forall>(k', p') \<in> set ?t\<^sub>2 - {(k\<^sub>2, p\<^sub>2)}. prio ?t\<^sub>2 < p'"
    by simp
  then have "\<forall>(k', p') \<in> set ?t\<^sub>2 - {(k\<^sub>2, p\<^sub>2)}. prio ?t\<^sub>2 \<le> p'"
    using less_imp_le by blast
  then have "\<forall>(k', p') \<in> ?entries. prio ?t\<^sub>2 \<le> p'"
    using Node.prems(5) t2_def by auto
  moreover have root1_in_set: "(k\<^sub>1, p\<^sub>1) \<in> ?entries"
    by force
  moreover have root2_in_set: "(k\<^sub>2, p\<^sub>2) \<in> ?entries"
    using Node.prems(5) t2_def by auto
  ultimately have equal_prio:  "prio ?t\<^sub>1 = prio ?t\<^sub>2"
    by fastforce
  then have roots_eq_prios: "p\<^sub>1 = p\<^sub>2" by simp
  then have roots_eq_keys: "k\<^sub>1 = k\<^sub>2"
    using Node.prems(5) case_prodD root1_in_set root2_smallest_prio t2_def by fastforce

  (* left subtree equal *)
  have "\<forall>(k', p') \<in> ?entries. k' < key ?t\<^sub>1 \<longrightarrow> (k', p') \<in> set (left ?t\<^sub>1)"
    using Node.prems(1,3) is_treap_def smaller_key_is_left_child by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>k' < key ?t\<^sub>1 \<longrightarrow> (k', p') \<notin> set (left ?t\<^sub>1)"
    using Node.prems(3) bst_rev is_treap_def by force
  moreover have "set (left ?t\<^sub>1) \<subseteq> ?entries"
    by auto
  ultimately have left1: "{(k', p') \<in> ?entries. k' < key ?t\<^sub>1} = set (left ?t\<^sub>1)"
    by blast

  have "\<forall>(k', p') \<in> ?entries. k' < key ?t\<^sub>2 \<longrightarrow> (k', p') \<in> set (left ?t\<^sub>2)"
    using Node.prems(2,4,5) is_treap_def smaller_key_is_left_child t2_def by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>k' < key ?t\<^sub>2 \<longrightarrow> (k', p') \<notin> set (left ?t\<^sub>2)"
    using Node.prems(4) bst_rev is_treap_def t2_def
    by (metis (no_types, lifting) case_prodD case_prodI2 key.simps(1) left.simps(1))
  moreover have "set (left ?t\<^sub>2) \<subseteq> ?entries"
    using Node.prems(5) t2_def by auto
  ultimately have left2: "{(k', p') \<in> ?entries. k' < key ?t\<^sub>2} = set (left ?t\<^sub>2)"
    by blast

  from left1 left2 have "set (left ?t\<^sub>1) = set (left ?t\<^sub>2)"
    by (simp add: roots_eq_keys)
  then have left_subtrees_eq: "l\<^sub>1 = l\<^sub>2"
    using Node.IH(1) \<open>is_treap l\<^sub>2\<close> Node.prems distinct_rev bst_rev is_heap.cases is_treap_def t2_def
    by (metis left.simps(1) treap.distinct(1))

  (* right subtree equal *)
  have "\<forall>(k', p') \<in> ?entries. key ?t\<^sub>1 < k' \<longrightarrow> (k', p') \<in> set (right ?t\<^sub>1)"
    using Node.prems(1,3) is_treap_def larger_key_is_right_child by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>key ?t\<^sub>1 < k' \<longrightarrow> (k', p') \<notin> set (right ?t\<^sub>1)"
    using Node.prems(3) bst_rev is_treap_def by force
  moreover have "set (right ?t\<^sub>1) \<subseteq> ?entries"
    by auto
  ultimately have right1: "{(k', p') \<in> ?entries. key ?t\<^sub>1 < k'} = set (right ?t\<^sub>1)"
    by blast

  have "\<forall>(k', p') \<in> ?entries.  key ?t\<^sub>2 < k' \<longrightarrow> (k', p') \<in> set (right ?t\<^sub>2)"
    using Node.prems(2,4,5) is_treap_def larger_key_is_right_child t2_def by fastforce
  moreover have "\<forall>(k', p') \<in> ?entries.  \<not>key ?t\<^sub>2 < k' \<longrightarrow> (k', p') \<notin> set (right ?t\<^sub>2)"
    using Node.prems(4) bst_rev is_treap_def t2_def
    by (metis (no_types, lifting) case_prodD case_prodI2 key.simps(1) right.simps(1))
  moreover have "set (right ?t\<^sub>2) \<subseteq> ?entries"
    using Node.prems(5) t2_def by auto
  ultimately have right2: "{(k', p') \<in> ?entries. key ?t\<^sub>2 < k'} = set (right ?t\<^sub>2)"
    by blast

  from right1 right2 have "set (right ?t\<^sub>1) = set (right ?t\<^sub>2)"
    by (simp add: roots_eq_keys)
  then have right_subtrees_eq: "r\<^sub>1 = r\<^sub>2"
    using Node.IH(2) \<open>is_treap r\<^sub>2\<close> Node.prems distinct_rev bst_rev is_heap.cases is_treap_def t2_def
    by (metis right.simps(1) treap.distinct(1))

  from left_subtrees_eq right_subtrees_eq show ?case
    by (simp add: roots_eq_keys roots_eq_prios t2_def)
qed

fun bst_insert :: "('a::linorder) \<Rightarrow> real \<Rightarrow> 'a treap \<Rightarrow> 'a treap" where
  "bst_insert k p \<langle>\<rangle> = \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" |
  "bst_insert k p \<langle>l, k', p', r\<rangle> = (if k < k' then \<langle>bst_insert k p l, k', p', r\<rangle> else \<langle>l, k', p', bst_insert k p r\<rangle>)"

lemma bst_insert_inserts: "is_bst t \<Longrightarrow> set (bst_insert k p t) = set t \<union> {(k, p)}"
  by(induction t  rule: is_bst.induct, cases "k < k'", auto)

lemma bst_insert_maintains_inv: "is_bst t \<Longrightarrow> \<forall>p. (k, p) \<notin> set t \<Longrightarrow> is_bst (bst_insert k p t)"
proof(induction t arbitrary: k p rule: is_bst.induct)
  case (Node l r k' p')
  then have "k \<noteq> k'" by auto
  then show ?case
  proof(cases "k < k'")
    case True
    then have "\<forall>p. (k, p) \<notin> set l" using Node.prems by auto
    then have lih: "is_bst (bst_insert k p l)" by (simp add: Node.IH(1))
    from True have "bst_insert k p \<langle>l, k', p', r\<rangle> = \<langle>bst_insert k p l, k', p', r\<rangle>" by simp
    moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set l. x\<^sub>k < k'" by (simp add: Node.hyps(3))
    then have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set (bst_insert k p l). x\<^sub>k < k'"
      by (simp add: Node.hyps(1) True bst_insert_inserts)
    ultimately show ?thesis
      by (simp add: Node.hyps(2) Node.hyps(4) is_bst.Node lih)
  next
    case False
    then have "k' < k" using \<open>k \<noteq> k'\<close> by auto
    then have "\<forall>p. (k, p) \<notin> set r" using Node.prems by auto
    then have rih: "is_bst (bst_insert k p r)" by (simp add: Node.IH(2))
    from False have "bst_insert k p \<langle>l, k', p', r\<rangle> = \<langle>l, k', p', bst_insert k p r\<rangle>" by simp
    moreover have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set r. k' < x\<^sub>k" by (simp add: Node.hyps(4))
    then have "\<forall>(x\<^sub>k, x\<^sub>p) \<in> set (bst_insert k p r). k' < x\<^sub>k"
      by (simp add: Node.hyps(2) \<open>k' < k\<close> bst_insert_inserts)
    ultimately show ?thesis
      by (simp add: Node.hyps(1) Node.hyps(3) is_bst.Node rih)
  qed
qed(simp)

lemma bst_insert_root_key_same:
  assumes "is_bst t"
      and "t \<noteq> \<langle>\<rangle>"
    shows "key t = key (bst_insert k p t)"
  using assms by(induction t rule: is_bst.induct, cases "k < k'", auto)

lemma bst_insert_root_prio_same:
  assumes "is_bst t"
      and "t \<noteq> \<langle>\<rangle>"
    shows "prio t = prio (bst_insert k p t)"
  using assms by(induction t rule: is_bst.induct, cases "k < k'", auto)

lemma bst_insert_maintains_heap:
  assumes "is_bst t"
      and "is_heap t"
      and "\<forall>(k', p') \<in> set t. p' < p"
      and "is_valid_prio p"
    shows "is_heap (bst_insert k p t)"
using assms proof(induction t rule: is_bst.induct)
  case (Node l r k' p')
  then have subheaps: "is_heap l" "is_heap r"
    using is_heap.cases by auto
  have sub_larger_prios: "prio l > p'" "prio r > p'"
    using Node.prems(1) is_heap.cases by auto
  then show ?case
  proof(cases "k < k'")
    case True
    then show ?thesis
    proof(cases l)
      case Leaf
      let ?l = "\<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
      have "is_heap ?l"  by (simp add: assms(4))
      moreover have "prio ?l > p'" using Node.prems(2) by auto
      ultimately have "is_heap \<langle>?l, k', p', r\<rangle>"
        using subheaps(2) sub_larger_prios(2) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with True Leaf show ?thesis by simp
    next
      case Node
      let ?l = "bst_insert k p l"
      have "\<forall>(k', p') \<in> set l. p' < p" using Node.prems(2) by auto
      then have "is_heap ?l"
        by (simp add: Node.IH(1) assms(4) subheaps(1))
      moreover have "prio ?l > p'" using Node sub_larger_prios(1) by auto
      ultimately have "is_heap \<langle>?l, k', p', r\<rangle>"
        using subheaps(2) sub_larger_prios(2) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with True show ?thesis by simp
    qed
  next
    case False
    then show ?thesis
    proof(cases r)
      case Leaf
      let ?r = "\<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>"
      have "is_heap ?r"  by (simp add: assms(4))
      moreover have "prio ?r > p'" using Node.prems(2) by auto
      ultimately have "is_heap \<langle>l, k', p', ?r\<rangle>"
        using subheaps(1) sub_larger_prios(1) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with False Leaf show ?thesis by simp
    next
      case Node
      let ?r = "bst_insert k p r"
      have "\<forall>(k', p') \<in> set r. p' < p" using Node.prems(2) by auto
      then have "is_heap ?r"
        by (simp add: Node.IH(2) assms(4) subheaps(2))
      moreover have "prio ?r > p'" using Node sub_larger_prios(2) by auto
      ultimately have "is_heap \<langle>l, k', p', ?r\<rangle>"
        using subheaps(1) sub_larger_prios(1) Node.prems(1,3) Node.prems(1)
          is_heap.Node is_heap.simps by blast
      with False show ?thesis by simp
    qed
  qed
qed(simp)

lemma bst_insert_maintains_treap:
  assumes "is_treap t"
      and "\<forall>(k', p') \<in> set t. p' < p"
      and "\<forall>(k', p') \<in> set t. k \<noteq> k'"
      and "is_valid_prio p"
    shows "is_treap (bst_insert k p t)"
proof-
  have "is_bst t" using assms(1) is_treap_def by blast
  then have "is_bst (bst_insert k p t)"
    using assms(3) bst_insert_maintains_inv by fastforce
  moreover have "is_heap t" using assms(1) is_treap_def by blast
  then have "is_heap (bst_insert k p t)"
    using \<open>is_bst t\<close> assms(2) assms(4) bst_insert_maintains_heap by blast
  ultimately show "is_treap (bst_insert k p t)" by (simp add: is_treap_def)
qed

lemma foldr_bst_insert_is_bst:
  assumes "t = foldr (\<lambda> (k, p) t. bst_insert k p t) x \<langle>\<rangle>"
      and "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set x. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set x. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    shows "is_bst t"
using assms proof(induction x arbitrary: t)
  case (Cons x xs)
  let ?tinter = "foldr (\<lambda> (k, p) t. bst_insert k p t) xs \<langle>\<rangle>"
  obtain k p where kpdef: "x = (k, p)" by fastforce
  then have "t = bst_insert k p ?tinter" by (simp add: Cons.prems(1))
  have "is_bst ?tinter"
    using Cons.IH Cons.prems(2) by fastforce
  moreover have "\<forall>p. (k, p) \<notin> set ?tinter" sorry
  ultimately show ?case
    by (simp add: \<open>t = bst_insert k p (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close> bst_insert_maintains_inv)
qed(simp add: is_bst.Leaf)

lemma foldr_bst_insert_sets_eq:
  assumes "t = foldr (\<lambda> (k, p) t. bst_insert k p t) x \<langle>\<rangle>"
      and "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set x. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set x. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    shows "set t = List.set x"
using assms proof(induction x arbitrary: t)
  case (Cons x xs)
  let ?tinter = "foldr (\<lambda> (k, p) t. bst_insert k p t) xs \<langle>\<rangle>"
  have "List.set xs \<subseteq> List.set (x#xs)" by auto
  then have "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set xs. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set xs. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    using Cons.prems(2) by auto
  then have "is_bst ?tinter" using foldr_bst_insert_is_bst by blast
  obtain k p where kpdef: "x = (k, p)" by fastforce
  have "set ?tinter = List.set xs"
    using Cons.IH Cons.prems(2) list.set_intros(2) by force
  from kpdef have "t = bst_insert k p ?tinter" by (simp add: Cons.prems(1))
  then have "set (bst_insert k p ?tinter) = set ?tinter \<union> {(k, p)}"
    by (simp add: \<open>is_bst (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close> bst_insert_inserts)
  then show ?case
    using \<open>Treaps.set (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>) = list.set xs\<close>
          \<open>t = bst_insert k p (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close> kpdef
    by auto
qed(simp)

text \<open>Any treap has the same tree structure that would result if elements were inserted in the order of their priorities\<close>
lemma treap_has_special_structure1:
  assumes "sorted_wrt (\<lambda> (k\<^sub>1, p\<^sub>1) (k\<^sub>2, p\<^sub>2). p\<^sub>1 > p\<^sub>2) x"
      and "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set x. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set x. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
      and "\<forall>(k, p) \<in> List.set x. is_valid_prio p"
      and "t = foldr (\<lambda> (k, p) t. bst_insert k p t) x \<langle>\<rangle>"
    shows "is_treap t"
  using assms proof(induction x arbitrary: t)
  case Nil
  then have "t = \<langle>\<rangle>"
    by auto
  then show ?case
    by (simp add: is_bst.Leaf is_heap.Leaf is_treap_def)
next
  case (Cons x xs)
  let ?tinter = "foldr (\<lambda> (k, p) t. bst_insert k p t) xs \<langle>\<rangle>"
  have "List.set xs \<subseteq> List.set (x#xs)" by auto
  then have subkeyid: "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set xs. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set xs. k\<^sub>1 = k\<^sub>2 \<longleftrightarrow> p\<^sub>1 = p\<^sub>2"
    using Cons.prems(2) by auto
  obtain k p where kpdef: "x = (k, p)" by fastforce
  then have "t = bst_insert k p ?tinter" by (simp add: Cons.prems(4))
  have "is_treap ?tinter"
    using Cons.IH Cons.prems(1) Cons.prems(3) subkeyid by auto
  moreover
  have "\<forall> (k', p') \<in> List.set xs. p > p'"
    using Cons.prems(1) kpdef by auto
  then have "\<forall> (k', p') \<in> set ?tinter. p > p'"
    using foldr_bst_insert_sets_eq subkeyid by blast
  then have "\<forall>(k', p') \<in> set ?tinter. p' < p"
    by simp
  moreover
  have "\<forall>(k\<^sub>1, p\<^sub>1) \<in> List.set xs. \<forall> (k\<^sub>2, p\<^sub>2) \<in> List.set xs. p\<^sub>1 \<noteq> p\<^sub>2 \<longrightarrow> k\<^sub>1 \<noteq> k\<^sub>2"
    using subkeyid by force
  moreover have "\<forall>(k', p') \<in> List.set xs. k \<noteq> k'"
    using Cons.prems(2) \<open>\<forall>(k', p')\<in>list.set xs. p' < p\<close> kpdef by fastforce
  then have "\<forall>(k', p') \<in> set ?tinter. k \<noteq> k'"
    by (simp add: foldr_bst_insert_sets_eq subkeyid)
  moreover
  from \<open>\<forall>(k, p) \<in> List.set (x#xs). is_valid_prio p\<close> have "is_valid_prio p"
    by (simp add: kpdef)
  ultimately have "is_treap (bst_insert k p ?tinter)"
    using bst_insert_maintains_treap by blast
  then show ?case
    by (simp add: \<open>t = bst_insert k p (foldr (\<lambda>(k, p). bst_insert k p) xs \<langle>\<rangle>)\<close>)
qed

(* Runtime of several operations - Not complete *)

fun search :: "('a::linorder) \<Rightarrow> 'a treap \<Rightarrow> bool" where
  "search k \<langle>\<rangle> = False" |
  "search k \<langle>l, k', _, r\<rangle> = (if k = k' then True else if k < k' then search k l else search k r)"

lemma search_correct:
  assumes "is_bst t"
  shows "search k t \<longleftrightarrow> (\<exists>p. (k, p) \<in> set t)"
proof
  from assms have "\<forall>p. (k, p) \<notin> set t \<Longrightarrow> \<not>search k t"
    by(induction t arbitrary: k rule: is_bst.induct, auto)
  then show "search k t \<Longrightarrow> \<exists>p. (k, p) \<in> Treaps.set t"
    by auto
next
  show "\<exists>p. (k, p) \<in> Treaps.set t \<Longrightarrow> search k t"
  using assms by(induction t arbitrary: k rule: is_bst.induct, auto)
qed

fun insert_prio :: "('a::linorder) \<Rightarrow> real \<Rightarrow> 'a treap \<Rightarrow> 'a treap" where
  "insert_prio k p \<langle>\<rangle> = \<langle>\<langle>\<rangle>, k, p, \<langle>\<rangle>\<rangle>" |
  "insert_prio k p \<langle>l\<^sub>r, k\<^sub>r, p\<^sub>r, r\<^sub>r\<rangle> =
    (if k < k\<^sub>r then
      (case insert_prio k p l\<^sub>r of
        \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle> \<Rightarrow>
          (if p\<^sub>r > p\<^sub>c then \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, \<langle>r\<^sub>c, k\<^sub>r, p\<^sub>r, r\<^sub>r\<rangle>\<rangle>
          else \<langle>\<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle>, k\<^sub>r, p\<^sub>r, r\<^sub>r\<rangle>) |
        _ \<Rightarrow> undefined)
    else
      (case insert_prio k p r\<^sub>r of
        \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle> \<Rightarrow>
          (if p\<^sub>r > p\<^sub>c then\<langle>\<langle>l\<^sub>r, k\<^sub>r, p\<^sub>r, l\<^sub>c\<rangle>, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle>
          else \<langle>l\<^sub>r, k\<^sub>r, p\<^sub>r, \<langle>l\<^sub>c, k\<^sub>c, p\<^sub>c, r\<^sub>c\<rangle>\<rangle>) |
        _ \<Rightarrow> undefined)
    )"

end


(*  Title:      HOL/Computational_Algebra/Normalized_Fraction.thy
    Author:     Manuel Eberl
*)

theory Normalized_Fraction
imports
  Main
  Euclidean_Algorithm
  Fraction_Field
begin

lemma unit_factor_1_imp_normalized: "unit_factor x = 1 \<Longrightarrow> normalize x = x"
  using unit_factor_mult_normalize [of x] by simp

definition quot_to_fract :: "'a \<times> 'a \<Rightarrow> 'a :: idom fract" where
  "quot_to_fract = (\<lambda>(a,b). Fraction_Field.Fract a b)"

definition normalize_quot :: "'a :: {ring_gcd,idom_divide,semiring_gcd_mult_normalize} \<times> 'a \<Rightarrow> 'a \<times> 'a" where
  "normalize_quot =
     (\<lambda>(a,b). if b = 0 then (0,1) else let d = gcd a b * unit_factor b in (a div d, b div d))"

lemma normalize_quot_zero [simp]:
  "normalize_quot (a, 0) = (0, 1)"
  by (simp add: normalize_quot_def)

lemma normalize_quot_proj:
  "fst (normalize_quot (a, b)) = a div (gcd a b * unit_factor b)"
  "snd (normalize_quot (a, b)) = normalize b div gcd a b" if "b \<noteq> 0"
  using that by (simp_all add: normalize_quot_def Let_def mult.commute [of _ "unit_factor b"] dvd_div_mult2_eq mult_unit_dvd_iff')

definition normalized_fracts :: "('a :: {ring_gcd,idom_divide} \<times> 'a) set" where
  "normalized_fracts = {(a,b). coprime a b \<and> unit_factor b = 1}"

lemma not_normalized_fracts_0_denom [simp]: "(a, 0) \<notin> normalized_fracts"
  by (auto simp: normalized_fracts_def)

lemma unit_factor_snd_normalize_quot [simp]:
  "unit_factor (snd (normalize_quot x)) = 1"
  by (simp add: normalize_quot_def case_prod_unfold Let_def dvd_unit_factor_div
                mult_unit_dvd_iff unit_factor_mult unit_factor_gcd)

lemma snd_normalize_quot_nonzero [simp]: "snd (normalize_quot x) \<noteq> 0"
  using unit_factor_snd_normalize_quot[of x]
  by (auto simp del: unit_factor_snd_normalize_quot)

lemma normalize_quot_aux:
  fixes a b
  assumes "b \<noteq> 0"
  defines "d \<equiv> gcd a b * unit_factor b"
  shows   "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
          "d dvd a" "d dvd b" "d \<noteq> 0"
proof -
  from assms show "d dvd a" "d dvd b"
    by (simp_all add: d_def mult_unit_dvd_iff)
  thus "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d" "d \<noteq> 0"
    by (auto simp: normalize_quot_def Let_def d_def \<open>b \<noteq> 0\<close>)
qed

lemma normalize_quotE:
  assumes "b \<noteq> 0"
  obtains d where "a = fst (normalize_quot (a,b)) * d" "b = snd (normalize_quot (a,b)) * d"
                  "d dvd a" "d dvd b" "d \<noteq> 0"
  using that[OF normalize_quot_aux[OF assms]] .

lemma normalize_quotE':
  assumes "snd x \<noteq> 0"
  obtains d where "fst x = fst (normalize_quot x) * d" "snd x = snd (normalize_quot x) * d"
                  "d dvd fst x" "d dvd snd x" "d \<noteq> 0"
proof -
  from normalize_quotE[OF assms, of "fst x"] obtain d where
    "fst x = fst (normalize_quot (fst x, snd x)) * d"
    "snd x = snd (normalize_quot (fst x, snd x)) * d"
    "d dvd fst x"
    "d dvd snd x"
    "d \<noteq> 0" .
  then show ?thesis unfolding prod.collapse by (intro that[of d])
qed

lemma coprime_normalize_quot:
  "coprime (fst (normalize_quot x)) (snd (normalize_quot x))"
  by (simp add: normalize_quot_def case_prod_unfold div_mult_unit2)
    (metis coprime_mult_self_right_iff div_gcd_coprime unit_div_mult_self unit_factor_is_unit)

lemma normalize_quot_in_normalized_fracts [simp]: "normalize_quot x \<in> normalized_fracts"
  by (simp add: normalized_fracts_def coprime_normalize_quot case_prod_unfold)

lemma normalize_quot_eq_iff:
  assumes "b \<noteq> 0" "d \<noteq> 0"
  shows   "normalize_quot (a,b) = normalize_quot (c,d) \<longleftrightarrow> a * d = b * c"
proof -
  define x y where "x = normalize_quot (a,b)" and "y = normalize_quot (c,d)"
  from normalize_quotE[OF assms(1), of a] normalize_quotE[OF assms(2), of c]
    obtain d1 d2
      where "a = fst x * d1" "b = snd x * d1" "c = fst y * d2" "d = snd y * d2" "d1 \<noteq> 0" "d2 \<noteq> 0"
    unfolding x_def y_def by metis
  hence "a * d = b * c \<longleftrightarrow> fst x * snd y = snd x * fst y" by simp
  also have "\<dots> \<longleftrightarrow> fst x = fst y \<and> snd x = snd y"
    by (intro coprime_crossproduct') (simp_all add: x_def y_def coprime_normalize_quot)
  also have "\<dots> \<longleftrightarrow> x = y" using prod_eqI by blast
  finally show "x = y \<longleftrightarrow> a * d = b * c" ..
qed

lemma normalize_quot_eq_iff':
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot x = normalize_quot y \<longleftrightarrow> fst x * snd y = snd x * fst y"
  using assms by (cases x, cases y, hypsubst) (subst normalize_quot_eq_iff, simp_all)

lemma normalize_quot_id: "x \<in> normalized_fracts \<Longrightarrow> normalize_quot x = x"
  by (auto simp: normalized_fracts_def normalize_quot_def case_prod_unfold)

lemma normalize_quot_idem [simp]: "normalize_quot (normalize_quot x) = normalize_quot x"
  by (rule normalize_quot_id) simp_all

lemma fractrel_iff_normalize_quot_eq:
  "fractrel x y \<longleftrightarrow> normalize_quot x = normalize_quot y \<and> snd x \<noteq> 0 \<and> snd y \<noteq> 0"
  by (cases x, cases y) (auto simp: fractrel_def normalize_quot_eq_iff)

lemma fractrel_normalize_quot_left:
  assumes "snd x \<noteq> 0"
  shows   "fractrel (normalize_quot x) y \<longleftrightarrow> fractrel x y"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lemma fractrel_normalize_quot_right:
  assumes "snd x \<noteq> 0"
  shows   "fractrel y (normalize_quot x) \<longleftrightarrow> fractrel y x"
  using assms by (subst (1 2) fractrel_iff_normalize_quot_eq) auto

lift_definition quot_of_fract ::
  "'a :: {ring_gcd,idom_divide,semiring_gcd_mult_normalize} fract \<Rightarrow> 'a \<times> 'a"
    is normalize_quot
  by (subst (asm) fractrel_iff_normalize_quot_eq) simp_all

lemma quot_to_fract_quot_of_fract [simp]: "quot_to_fract (quot_of_fract x) = x"
  unfolding quot_to_fract_def
proof transfer
  fix x :: "'a \<times> 'a" assume rel: "fractrel x x"
  define x' where "x' = normalize_quot x"
  obtain a b where [simp]: "x = (a, b)" by (cases x)
  from rel have "b \<noteq> 0" by simp
  from normalize_quotE[OF this, of a] obtain d
    where
      "a = fst (normalize_quot (a, b)) * d"
      "b = snd (normalize_quot (a, b)) * d"
      "d dvd a"
      "d dvd b"
      "d \<noteq> 0" .
  hence "a = fst x' * d" "b = snd x' * d" "d \<noteq> 0" "snd x' \<noteq> 0" by (simp_all add: x'_def)
  thus "fractrel (case x' of (a, b) \<Rightarrow> if b = 0 then (0, 1) else (a, b)) x"
    by (auto simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract: "quot_of_fract (quot_to_fract x) = normalize_quot x"
proof (cases "snd x = 0")
  case True
  thus ?thesis unfolding quot_to_fract_def
    by transfer (simp add: case_prod_unfold normalize_quot_def)
next
  case False
  thus ?thesis unfolding quot_to_fract_def by transfer (simp add: case_prod_unfold)
qed

lemma quot_of_fract_quot_to_fract':
  "x \<in> normalized_fracts \<Longrightarrow> quot_of_fract (quot_to_fract x) = x"
  unfolding quot_to_fract_def by transfer (auto simp: normalize_quot_id)

lemma quot_of_fract_in_normalized_fracts [simp]: "quot_of_fract x \<in> normalized_fracts"
  by transfer simp

lemma normalize_quotI:
  assumes "a * d = b * c" "b \<noteq> 0" "(c, d) \<in> normalized_fracts"
  shows   "normalize_quot (a, b) = (c, d)"
proof -
  from assms have "normalize_quot (a, b) = normalize_quot (c, d)"
    by (subst normalize_quot_eq_iff) auto
  also have "\<dots> = (c, d)" by (intro normalize_quot_id) fact
  finally show ?thesis .
qed

lemma td_normalized_fract:
  "type_definition quot_of_fract quot_to_fract normalized_fracts"
  by standard (simp_all add: quot_of_fract_quot_to_fract')

lemma quot_of_fract_add_aux:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "(fst x * snd y + fst y * snd x) * (snd (normalize_quot x) * snd (normalize_quot y)) =
             snd x * snd y * (fst (normalize_quot x) * snd (normalize_quot y) +
             snd (normalize_quot x) * fst (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] obtain d
    where d:
      "fst x = fst (normalize_quot x) * d"
      "snd x = snd (normalize_quot x) * d"
      "d dvd fst x"
      "d dvd snd x"
      "d \<noteq> 0" .
  from normalize_quotE'[OF assms(2)] obtain e
    where e:
      "fst y = fst (normalize_quot y) * e"
      "snd y = snd (normalize_quot y) * e"
      "e dvd fst y"
      "e dvd snd y"
      "e \<noteq> 0" .
  show ?thesis by (simp_all add: d e algebra_simps)
qed

locale fract_as_normalized_quot
begin
setup_lifting td_normalized_fract
end

lemma quot_of_fract_add:
  "quot_of_fract (x + y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d + b * c, b * d))"
  by transfer (insert quot_of_fract_add_aux,
               simp_all add: Let_def case_prod_unfold normalize_quot_eq_iff)

lemma quot_of_fract_uminus:
  "quot_of_fract (-x) = (let (a,b) = quot_of_fract x in (-a, b))"
  by transfer (auto simp: case_prod_unfold Let_def normalize_quot_def dvd_neg_div mult_unit_dvd_iff)

lemma quot_of_fract_diff:
  "quot_of_fract (x - y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y
      in  normalize_quot (a * d - b * c, b * d))" (is "_ = ?rhs")
proof -
  have "x - y = x + -y" by simp
  also have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_add quot_of_fract_uminus Let_def case_prod_unfold) simp_all
  finally show ?thesis .
qed

lemma normalize_quot_mult_coprime:
  assumes "coprime a b" "coprime c d" "unit_factor b = 1" "unit_factor d = 1"
  defines "e \<equiv> fst (normalize_quot (a, d))" and "f \<equiv> snd (normalize_quot (a, d))"
     and  "g \<equiv> fst (normalize_quot (c, b))" and "h \<equiv> snd (normalize_quot (c, b))"
  shows   "normalize_quot (a * c, b * d) = (e * g, f * h)"
proof (rule normalize_quotI)
  from assms have "gcd a b = 1" "gcd c d = 1"
    by simp_all
  from assms have "b \<noteq> 0" "d \<noteq> 0" by auto
  with assms have "normalize b = b" "normalize d = d"
    by (auto intro: normalize_unit_factor_eqI)
  from normalize_quotE [OF \<open>b \<noteq> 0\<close>, of c] obtain k
    where
      "c = fst (normalize_quot (c, b)) * k"
      "b = snd (normalize_quot (c, b)) * k"
      "k dvd c" "k dvd b" "k \<noteq> 0" .
  note k = this [folded \<open>gcd a b = 1\<close> \<open>gcd c d = 1\<close> assms(3) assms(4)]
  from normalize_quotE [OF \<open>d \<noteq> 0\<close>, of a] obtain l
    where "a = fst (normalize_quot (a, d)) * l"
      "d = snd (normalize_quot (a, d)) * l"
      "l dvd a" "l dvd d" "l \<noteq> 0" .
  note l = this [folded \<open>gcd a b = 1\<close> \<open>gcd c d = 1\<close> assms(3) assms(4)]
  from k l show "a * c * (f * h) = b * d * (e * g)"
    by (metis e_def f_def g_def h_def mult.commute mult.left_commute)
  from assms have [simp]: "unit_factor f = 1" "unit_factor h = 1"
    by simp_all
  from assms have "coprime e f" "coprime g h" by (simp_all add: coprime_normalize_quot)
  with k l assms(1,2) \<open>b \<noteq> 0\<close> \<open>d \<noteq> 0\<close> \<open>unit_factor b = 1\<close> \<open>unit_factor d = 1\<close>
    \<open>normalize b = b\<close> \<open>normalize d = d\<close>
  show "(e * g, f * h) \<in> normalized_fracts"
    by (simp add: normalized_fracts_def unit_factor_mult e_def f_def g_def h_def
      coprime_normalize_quot dvd_unit_factor_div unit_factor_gcd)
      (metis coprime_mult_left_iff coprime_mult_right_iff)
qed (insert assms(3,4), auto)

lemma normalize_quot_mult:
  assumes "snd x \<noteq> 0" "snd y \<noteq> 0"
  shows   "normalize_quot (fst x * fst y, snd x * snd y) = normalize_quot
             (fst (normalize_quot x) * fst (normalize_quot y),
              snd (normalize_quot x) * snd (normalize_quot y))"
proof -
  from normalize_quotE'[OF assms(1)] obtain d where d:
    "fst x = fst (normalize_quot x) * d"
    "snd x = snd (normalize_quot x) * d"
    "d dvd fst x"
    "d dvd snd x"
    "d \<noteq> 0" .
  from normalize_quotE'[OF assms(2)] obtain e where e:
    "fst y = fst (normalize_quot y) * e"
    "snd y = snd (normalize_quot y) * e"
    "e dvd fst y"
    "e dvd snd y"
    "e \<noteq> 0" .
  show ?thesis by (simp_all add: d e algebra_simps normalize_quot_eq_iff)
qed

lemma quot_of_fract_mult:
  "quot_of_fract (x * y) =
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,d); (g,h) = normalize_quot (c,b)
      in  (e*g, f*h))"
  by transfer
     (simp add: split_def Let_def coprime_normalize_quot normalize_quot_mult normalize_quot_mult_coprime)

lemma normalize_quot_0 [simp]:
    "normalize_quot (0, x) = (0, 1)" "normalize_quot (x, 0) = (0, 1)"
  by (simp_all add: normalize_quot_def)

lemma normalize_quot_eq_0_iff [simp]: "fst (normalize_quot x) = 0 \<longleftrightarrow> fst x = 0 \<or> snd x = 0"
  by (auto simp: normalize_quot_def case_prod_unfold Let_def div_mult_unit2 dvd_div_eq_0_iff)

lemma fst_quot_of_fract_0_imp: "fst (quot_of_fract x) = 0 \<Longrightarrow> snd (quot_of_fract x) = 1"
  by transfer auto

lemma normalize_quot_swap:
  assumes "a \<noteq> 0" "b \<noteq> 0"
  defines "a' \<equiv> fst (normalize_quot (a, b))" and "b' \<equiv> snd (normalize_quot (a, b))"
  shows   "normalize_quot (b, a) = (b' div unit_factor a', a' div unit_factor a')"
proof (rule normalize_quotI)
  from normalize_quotE[OF assms(2), of a] obtain d where
    "a = fst (normalize_quot (a, b)) * d"
    "b = snd (normalize_quot (a, b)) * d"
    "d dvd a" "d dvd b" "d \<noteq> 0" .
  note d = this [folded assms(3,4)]
  show "b * (a' div unit_factor a') = a * (b' div unit_factor a')"
    using assms(1,2) d
    by (simp add: div_unit_factor [symmetric] unit_div_mult_swap mult_ac del: div_unit_factor)
  have "coprime a' b'" by (simp add: a'_def b'_def coprime_normalize_quot)
  thus "(b' div unit_factor a', a' div unit_factor a') \<in> normalized_fracts"
    using assms(1,2) d
    by (auto simp add: normalized_fracts_def ac_simps dvd_div_unit_iff elim: coprime_imp_coprime)
qed fact+

lemma quot_of_fract_inverse:
  "quot_of_fract (inverse x) =
     (let (a,b) = quot_of_fract x; d = unit_factor a
      in  if d = 0 then (0, 1) else (b div d, a div d))"
proof (transfer, goal_cases)
  case (1 x)
  from normalize_quot_swap[of "fst x" "snd x"] show ?case
    by (auto simp: Let_def case_prod_unfold)
qed

lemma normalize_quot_div_unit_left:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x div u, y) = (x' div u, y')"
proof (cases "y = 0")
  case False
  define v where "v = 1 div u"
  with \<open>is_unit u\<close> have "is_unit v" and u: "\<And>a. a div u = a * v"
    by simp_all
  from \<open>is_unit v\<close> have "coprime v = top"
    by (simp add: fun_eq_iff is_unit_left_imp_coprime)
  from normalize_quotE[OF False, of x] obtain d where
    "x = fst (normalize_quot (x, y)) * d"
    "y = snd (normalize_quot (x, y)) * d"
    "d dvd x" "d dvd y" "d \<noteq> 0" .
  note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1"
    by (simp_all add: coprime_normalize_quot)
  with d \<open>coprime v = top\<close> have "normalize_quot (x * v, y) = (x' * v, y')"
    by (auto simp: normalized_fracts_def intro: normalize_quotI)
  then show ?thesis
    by (simp add: u)
qed (simp_all add: assms)

lemma normalize_quot_div_unit_right:
  fixes x y u
  assumes "is_unit u"
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, y div u) = (x' * u, y')"
proof (cases "y = 0")
  case False
  from normalize_quotE[OF this, of x]
  obtain d where d:
    "x = fst (normalize_quot (x, y)) * d"
    "y = snd (normalize_quot (x, y)) * d"
    "d dvd x" "d dvd y" "d \<noteq> 0" .
  note d = this[folded assms(2,3)]
  from assms have "coprime x' y'" "unit_factor y' = 1" by (simp_all add: coprime_normalize_quot)
  with d \<open>is_unit u\<close> show ?thesis
    by (auto simp add: normalized_fracts_def is_unit_left_imp_coprime unit_div_eq_0_iff intro: normalize_quotI)
qed (simp_all add: assms)

lemma normalize_quot_normalize_left:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (normalize x, y) = (x' div unit_factor x, y')"
  using normalize_quot_div_unit_left[of "unit_factor x" x y]
  by (cases "x = 0") (simp_all add: assms)

lemma normalize_quot_normalize_right:
  fixes x y u
  defines "x' \<equiv> fst (normalize_quot (x, y))" and "y' \<equiv> snd (normalize_quot (x, y))"
  shows "normalize_quot (x, normalize y) = (x' * unit_factor y, y')"
  using normalize_quot_div_unit_right[of "unit_factor y" x y]
  by (cases "y = 0") (simp_all add: assms)

lemma quot_of_fract_0 [simp]: "quot_of_fract 0 = (0, 1)"
  by transfer auto

lemma quot_of_fract_1 [simp]: "quot_of_fract 1 = (1, 1)"
  by transfer (rule normalize_quotI, simp_all add: normalized_fracts_def)

lemma quot_of_fract_divide:
  "quot_of_fract (x / y) = (if y = 0 then (0, 1) else
     (let (a,b) = quot_of_fract x; (c,d) = quot_of_fract y;
          (e,f) = normalize_quot (a,c); (g,h) = normalize_quot (d,b)
      in  (e * g, f * h)))" (is "_ = ?rhs")
proof (cases "y = 0")
  case False
  hence A: "fst (quot_of_fract y) \<noteq> 0" by transfer auto
  have "x / y = x * inverse y" by (simp add: divide_inverse)
  also from False A have "quot_of_fract \<dots> = ?rhs"
    by (simp only: quot_of_fract_mult quot_of_fract_inverse)
       (simp_all add: Let_def case_prod_unfold fst_quot_of_fract_0_imp
          normalize_quot_div_unit_left normalize_quot_div_unit_right
          normalize_quot_normalize_right normalize_quot_normalize_left)
  finally show ?thesis .
qed simp_all

lemma snd_quot_of_fract_nonzero [simp]: "snd (quot_of_fract x) \<noteq> 0"
  by transfer simp

lemma Fract_quot_of_fract [simp]: "Fract (fst (quot_of_fract x)) (snd (quot_of_fract x)) = x"
  by transfer (simp del: fractrel_iff, subst fractrel_normalize_quot_left, simp)

lemma snd_quot_of_fract_Fract_whole:
  assumes "y dvd x"
  shows   "snd (quot_of_fract (Fract x y)) = 1"
  using assms by transfer (auto simp: normalize_quot_def Let_def gcd_proj2_if_dvd)

lemma fst_quot_of_fract_eq_0_iff [simp]: "fst (quot_of_fract x) = 0 \<longleftrightarrow> x = 0"
  by transfer simp

lemma coprime_quot_of_fract:
  "coprime (fst (quot_of_fract x)) (snd (quot_of_fract x))"
  by transfer (simp add: coprime_normalize_quot)

lemma unit_factor_snd_quot_of_fract: "unit_factor (snd (quot_of_fract x)) = 1"
  using quot_of_fract_in_normalized_fracts[of x]
  by (simp add: normalized_fracts_def case_prod_unfold)

lemma normalize_snd_quot_of_fract: "normalize (snd (quot_of_fract x)) = snd (quot_of_fract x)"
  by (intro unit_factor_1_imp_normalized unit_factor_snd_quot_of_fract)

end