(*
  File:    RatFPS.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Rational formal power series\<close>
theory RatFPS
imports
  Complex_Main
  "HOL-Computational_Algebra.Computational_Algebra"
  "HOL-Computational_Algebra.Polynomial_Factorial"
begin

subsection \<open>Some auxiliary\<close>

abbreviation constant_term :: "'a poly \<Rightarrow> 'a::zero"
  where "constant_term p \<equiv> coeff p 0"

lemma coeff_0_mult: "coeff (p * q) 0 = coeff p 0 * coeff q 0"
  by (simp add: coeff_mult)

lemma coeff_0_div:
  assumes "coeff p 0 \<noteq> 0"
  assumes "(q :: 'a :: field poly) dvd p"
  shows   "coeff (p div q) 0 = coeff p 0 div coeff q 0"
proof (cases "q = 0")
  case False
  from assms have "p = p div q * q" by simp
  also have "coeff \<dots> 0 = coeff (p div q) 0 * coeff q 0" by (simp add: coeff_0_mult)
  finally show ?thesis using assms by auto
qed simp_all

lemma coeff_0_add_fract_nonzero:
  assumes "coeff (snd (quot_of_fract x)) 0 \<noteq> 0" "coeff (snd (quot_of_fract y)) 0 \<noteq> 0"
  shows   "coeff (snd (quot_of_fract (x + y))) 0 \<noteq> 0"
proof -
  define num where "num = fst (quot_of_fract x) * snd (quot_of_fract y) +
    snd (quot_of_fract x) * fst (quot_of_fract y)"
  define denom where "denom = snd (quot_of_fract x) * snd (quot_of_fract y)"
  define z where "z = (num, denom)"
  from assms have "snd z \<noteq> 0" by (auto simp: denom_def z_def)
  then obtain d where d:
    "fst z = fst (normalize_quot z) * d"
    "snd z = snd (normalize_quot z) * d"
    "d dvd fst z"
    "d dvd snd z"
    "d \<noteq> 0"
    by (rule normalize_quotE')
  from assms have z: "coeff (snd z) 0 \<noteq> 0" by (simp add: z_def denom_def coeff_0_mult)

  have "coeff (snd (quot_of_fract (x + y))) 0 = coeff (snd (normalize_quot z)) 0"
    by (simp add: quot_of_fract_add Let_def case_prod_unfold z_def num_def denom_def)
  also from z have "\<dots> \<noteq> 0" using d by (simp add: d coeff_0_mult)
  finally show ?thesis .
qed

lemma coeff_0_normalize_quot_nonzero [simp]:
  assumes "coeff (snd x) 0 \<noteq> 0"
  shows   "coeff (snd (normalize_quot x)) 0 \<noteq> 0"
proof -
  from assms have "snd x \<noteq> 0" by auto
  then obtain 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"
    by (rule normalize_quotE')
  with assms show ?thesis by (auto simp: coeff_0_mult)
qed

abbreviation numerator :: "'a fract \<Rightarrow> 'a::{ring_gcd,idom_divide,semiring_gcd_mult_normalize}"
  where "numerator x \<equiv> fst (quot_of_fract x)"

abbreviation denominator :: "'a fract \<Rightarrow> 'a::{ring_gcd,idom_divide,semiring_gcd_mult_normalize}"
  where "denominator x \<equiv> snd (quot_of_fract x)"

declare unit_factor_snd_quot_of_fract [simp]
  normalize_snd_quot_of_fract [simp]

lemma constant_term_denominator_nonzero_imp_constant_term_denominator_div_gcd_nonzero:
  "constant_term (denominator x div gcd a (denominator x)) \<noteq> 0"
  if "constant_term (denominator x) \<noteq> 0"
  using that coeff_0_normalize_quot_nonzero [of "(a, denominator x)"]
  normalize_quot_proj(2) [of "denominator x" a]
  by simp

subsection \<open>The type of rational formal power series\<close>

typedef (overloaded) 'a :: field_gcd ratfps =
  "{x :: 'a poly fract. constant_term (denominator x) \<noteq> 0}"
  by (rule exI [of _ 0]) simp

setup_lifting type_definition_ratfps

instantiation ratfps :: (field_gcd) idom
begin

lift_definition zero_ratfps :: "'a ratfps" is "0" by simp

lift_definition one_ratfps :: "'a ratfps" is "1" by simp

lift_definition uminus_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" is "uminus"
  by (simp add: quot_of_fract_uminus case_prod_unfold Let_def)

lift_definition plus_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is "(+)"
  by (rule coeff_0_add_fract_nonzero)

lift_definition minus_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is "(-)"
  by (simp only: diff_conv_add_uminus, rule coeff_0_add_fract_nonzero)
     (simp_all add: quot_of_fract_uminus Let_def case_prod_unfold)

lift_definition times_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is "(*)"
  by (simp add: quot_of_fract_mult Let_def case_prod_unfold coeff_0_mult
    constant_term_denominator_nonzero_imp_constant_term_denominator_div_gcd_nonzero)

instance
  by (standard; transfer) (simp_all add: ring_distribs)

end

fun ratfps_nth_aux :: "('a::field) poly \<Rightarrow> nat \<Rightarrow> 'a"
where
  "ratfps_nth_aux p 0 = inverse (coeff p 0)"
| "ratfps_nth_aux p n =
     - inverse (coeff p 0) * sum (\<lambda>i. coeff p i * ratfps_nth_aux p (n - i)) {1..n}"

lemma ratfps_nth_aux_correct: "ratfps_nth_aux p n = natfun_inverse (fps_of_poly p) n"
  by (induction p n rule: ratfps_nth_aux.induct) simp_all

lift_definition ratfps_nth :: "'a :: field_gcd ratfps \<Rightarrow> nat \<Rightarrow> 'a" is
  "\<lambda>x n. let (a,b) = quot_of_fract x
         in  (\<Sum>i = 0..n. coeff a i * ratfps_nth_aux b (n - i))" .

lift_definition ratfps_subdegree :: "'a :: field_gcd ratfps \<Rightarrow> nat" is
  "\<lambda>x. poly_subdegree (fst (quot_of_fract x))" .

context
includes lifting_syntax
begin

lemma RatFPS_parametric: "(rel_prod (=) (=) ===> (=))
  (\<lambda>(p,q). if coeff q 0 = 0 then 0 else quot_to_fract (p, q))
  (\<lambda>(p,q). if coeff q 0 = 0 then 0 else quot_to_fract (p, q))"
  by transfer_prover

end

lemma normalize_quot_quot_of_fract [simp]:
  "normalize_quot (quot_of_fract x) = quot_of_fract x"
  by (rule normalize_quot_id, rule quot_of_fract_in_normalized_fracts)

context
assumes "SORT_CONSTRAINT('a::field_gcd)"
begin

lift_definition quot_of_ratfps :: "'a ratfps \<Rightarrow> ('a poly \<times> 'a poly)" is
  "quot_of_fract :: 'a poly fract \<Rightarrow> ('a poly \<times> 'a poly)" .

lift_definition quot_to_ratfps :: "('a poly \<times> 'a poly) \<Rightarrow> 'a ratfps" is
  "\<lambda>(x,y). let (x',y') = normalize_quot (x,y)
           in  if coeff y' 0 = 0 then 0 else quot_to_fract (x',y')"
  by (simp add: case_prod_unfold Let_def quot_of_fract_quot_to_fract)

lemma quot_to_ratfps_quot_of_ratfps [code abstype]:
  "quot_to_ratfps (quot_of_ratfps x) = x"
  by transfer (simp add: case_prod_unfold Let_def)

lemma coeff_0_snd_quot_of_ratfps_nonzero [simp]:
  "coeff (snd (quot_of_ratfps x)) 0 \<noteq> 0"
  by transfer simp

lemma quot_of_ratfps_quot_to_ratfps:
  "coeff (snd x) 0 \<noteq> 0 \<Longrightarrow> x \<in> normalized_fracts \<Longrightarrow> quot_of_ratfps (quot_to_ratfps x) = x"
  by transfer (simp add: Let_def case_prod_unfold coeff_0_normalize_quot_nonzero
                 quot_of_fract_quot_to_fract normalize_quot_id)

lemma quot_of_ratfps_0 [simp, code abstract]: "quot_of_ratfps 0 = (0, 1)"
  by transfer simp_all

lemma quot_of_ratfps_1 [simp, code abstract]: "quot_of_ratfps 1 = (1, 1)"
  by transfer simp_all

lift_definition ratfps_of_poly :: "'a poly \<Rightarrow> 'a ratfps" is
  "to_fract :: 'a poly \<Rightarrow> _"
  by transfer simp

lemma ratfps_of_poly_code [code abstract]:
  "quot_of_ratfps (ratfps_of_poly p) = (p, 1)"
  by transfer' simp

lemmas zero_ratfps_code = quot_of_ratfps_0

lemmas one_ratfps_code = quot_of_ratfps_1

lemma uminus_ratfps_code [code abstract]:
  "quot_of_ratfps (- x) = (let (a, b) = quot_of_ratfps x in (-a, b))"
  by transfer (rule quot_of_fract_uminus)

lemma plus_ratfps_code [code abstract]:
  "quot_of_ratfps (x + y) =
     (let (a,b) = quot_of_ratfps x; (c,d) = quot_of_ratfps y
      in  normalize_quot (a * d + b * c, b * d))"
  by transfer' (rule quot_of_fract_add)

lemma minus_ratfps_code [code abstract]:
  "quot_of_ratfps (x - y) =
     (let (a,b) = quot_of_ratfps x; (c,d) = quot_of_ratfps y
      in  normalize_quot (a * d - b * c, b * d))"
  by transfer' (rule quot_of_fract_diff)

definition ratfps_cutoff :: "nat \<Rightarrow> 'a :: field_gcd ratfps \<Rightarrow> 'a poly" where
  "ratfps_cutoff n x = poly_of_list (map (ratfps_nth x) [0..<n])"

definition ratfps_shift :: "nat \<Rightarrow> 'a :: field_gcd ratfps \<Rightarrow> 'a ratfps" where
  "ratfps_shift n x = (let (a, b) = quot_of_ratfps (x - ratfps_of_poly (ratfps_cutoff n x))
                       in  quot_to_ratfps (poly_shift n a, b))"

lemma times_ratfps_code [code abstract]:
  "quot_of_ratfps (x * y) =
     (let (a,b) = quot_of_ratfps x; (c,d) = quot_of_ratfps y;
          (e,f) = normalize_quot (a,d); (g,h) = normalize_quot (c,b)
      in  (e*g, f*h))"
  by transfer' (rule quot_of_fract_mult)

lemma ratfps_nth_code [code]:
  "ratfps_nth x n =
    (let (a,b) = quot_of_ratfps x
     in  \<Sum>i = 0..n. coeff a i * ratfps_nth_aux b (n - i))"
  by transfer' simp

lemma ratfps_subdegree_code [code]:
  "ratfps_subdegree x = poly_subdegree (fst (quot_of_ratfps x))"
  by transfer simp

end

instantiation ratfps :: ("field_gcd") inverse
begin

lift_definition inverse_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" is
  "\<lambda>x. let (a,b) = quot_of_fract x
       in  if coeff a 0 = 0 then 0 else inverse x"
  by (auto simp: case_prod_unfold Let_def quot_of_fract_inverse)

lift_definition divide_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is
  "\<lambda>f g. (if g = 0 then 0 else
           let n = ratfps_subdegree g; h = ratfps_shift n g
           in  ratfps_shift n (f * inverse h))" .

instance ..
end

lemma ratfps_inverse_code [code abstract]:
  "quot_of_ratfps (inverse x) =
     (let (a,b) = quot_of_ratfps x
      in  if coeff a 0 = 0 then (0, 1)
          else let u = unit_factor a in (b div u, a div u))"
  by transfer' (simp_all add: Let_def case_prod_unfold quot_of_fract_inverse)

instantiation ratfps :: (equal) equal
begin

definition equal_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> bool" where
  [simp]: "equal_ratfps x y \<longleftrightarrow> x = y"

instance by standard simp

end

lemma quot_of_fract_eq_iff [simp]: "quot_of_fract x = quot_of_fract y \<longleftrightarrow> x = y"
  by transfer (auto simp: normalize_quot_eq_iff)

lemma equal_ratfps_code [code]: "HOL.equal x y \<longleftrightarrow> quot_of_ratfps x = quot_of_ratfps y"
  unfolding equal_ratfps_def by transfer simp

lemma fps_of_poly_quot_normalize_quot [simp]:
  "fps_of_poly (fst (normalize_quot x)) / fps_of_poly (snd (normalize_quot x)) =
     fps_of_poly (fst x) / fps_of_poly (snd x)"
  if "(snd x :: 'a :: field_gcd poly) \<noteq> 0"
proof -
  from that obtain d where "fst x = fst (normalize_quot x) * d"
    and "snd x = snd (normalize_quot x) * d" and "d \<noteq> 0"
    by (rule normalize_quotE')
  then show ?thesis
    by (simp add: fps_of_poly_mult)
qed

lemma fps_of_poly_quot_normalize_quot' [simp]:
  "fps_of_poly (fst (normalize_quot x)) / fps_of_poly (snd (normalize_quot x)) =
     fps_of_poly (fst x) / fps_of_poly (snd x)"
  if "coeff (snd x) 0 \<noteq> (0 :: 'a :: field_gcd)"
  using that by (auto intro: fps_of_poly_quot_normalize_quot)

lift_definition fps_of_ratfps :: "'a :: field_gcd ratfps \<Rightarrow> 'a fps" is
  "\<lambda>x. fps_of_poly (numerator x) / fps_of_poly (denominator x)" .

lemma fps_of_ratfps_altdef:
  "fps_of_ratfps x = (case quot_of_ratfps x of (a, b) \<Rightarrow> fps_of_poly a / fps_of_poly b)"
  by transfer (simp add: case_prod_unfold)

lemma fps_of_ratfps_ratfps_of_poly [simp]: "fps_of_ratfps (ratfps_of_poly p) = fps_of_poly p"
  by transfer simp

lemma fps_of_ratfps_0 [simp]: "fps_of_ratfps 0 = 0"
  by transfer simp

lemma fps_of_ratfps_1 [simp]: "fps_of_ratfps 1 = 1"
  by transfer simp

lemma fps_of_ratfps_uminus [simp]: "fps_of_ratfps (-x) = - fps_of_ratfps x"
  by transfer (simp add: quot_of_fract_uminus case_prod_unfold Let_def fps_of_poly_simps dvd_neg_div)

lemma fps_of_ratfps_add [simp]: "fps_of_ratfps (x + y) = fps_of_ratfps x + fps_of_ratfps y"
  by transfer (simp add: quot_of_fract_add Let_def case_prod_unfold fps_of_poly_simps)

lemma fps_of_ratfps_diff [simp]: "fps_of_ratfps (x - y) = fps_of_ratfps x - fps_of_ratfps y"
  by transfer (simp add: quot_of_fract_diff Let_def case_prod_unfold fps_of_poly_simps)

lemma is_unit_div_div_commute: "is_unit b \<Longrightarrow> is_unit c \<Longrightarrow> a div b div c = a div c div b"
  by (metis is_unit_div_mult2_eq mult.commute)

lemma fps_of_ratfps_mult [simp]: "fps_of_ratfps (x * y) = fps_of_ratfps x * fps_of_ratfps y"
proof (transfer, goal_cases)
  case (1 x y)
  moreover define x' y' where "x' = quot_of_fract x" and "y' = quot_of_fract y"
  ultimately have assms: "coeff (snd x') 0 \<noteq> 0" "coeff (snd y') 0 \<noteq> 0"
    by simp_all
  moreover define w z where "w = normalize_quot (fst x', snd y')" and "z = normalize_quot (fst y', snd x')"
  ultimately have unit: "coeff (snd x') 0 \<noteq> 0" "coeff (snd y') 0 \<noteq> 0"
    "coeff (snd w) 0 \<noteq> 0" "coeff (snd z) 0 \<noteq> 0"
    by (simp_all add: coeff_0_normalize_quot_nonzero)
  have "fps_of_poly (fst w * fst z) / fps_of_poly (snd w * snd z) =
          (fps_of_poly (fst w) / fps_of_poly (snd w)) *
          (fps_of_poly (fst z) / fps_of_poly (snd z))" (is "_ = ?A * ?B")
    by (simp add: is_unit_div_mult2_eq fps_of_poly_mult unit_div_mult_swap unit_div_commute unit)
  also have "\<dots> = (fps_of_poly (fst x') / fps_of_poly (snd x')) *
                    (fps_of_poly (fst y') / fps_of_poly (snd y'))" using unit
    by (simp add: w_def z_def unit_div_commute unit_div_mult_swap is_unit_div_div_commute)
  finally show ?case
    by (simp add: w_def z_def x'_def y'_def Let_def case_prod_unfold quot_of_fract_mult mult_ac)
qed

lemma div_const_unit_poly: "is_unit c \<Longrightarrow> p div [:c:] = smult (1 div c) p"
  by (simp add: is_unit_const_poly_iff unit_eq_div1)

lemma normalize_field:
  "normalize (x :: 'a :: {normalization_semidom,field}) = (if x = 0 then 0 else 1)"
  by (auto simp: normalize_1_iff dvd_field_iff)

lemma unit_factor_field [simp]:
  "unit_factor (x :: 'a :: {normalization_semidom,field}) = x"
  using unit_factor_mult_normalize[of x] normalize_field[of x]
  by (simp split: if_splits)

lemma fps_of_poly_normalize_field:
  "fps_of_poly (normalize (p :: 'a :: {field, normalization_semidom} poly)) =
     fps_of_poly p * fps_const (inverse (lead_coeff p))"
  by (cases "p = 0")
     (simp_all add: normalize_poly_def div_const_unit_poly divide_simps dvd_field_iff)

lemma unit_factor_poly_altdef: "unit_factor p = monom (unit_factor (lead_coeff p)) 0"
  by (simp add: unit_factor_poly_def monom_altdef)

lemma div_const_poly: "p div [:c::'a::field:] = smult (inverse c) p"
  by (cases "c = 0") (simp_all add: unit_eq_div1 is_unit_triv)

lemma fps_of_ratfps_inverse [simp]: "fps_of_ratfps (inverse x) = inverse (fps_of_ratfps x)"
proof (transfer, goal_cases)
  case (1 x)
  hence "smult (lead_coeff (fst (quot_of_fract x))) (snd (quot_of_fract x)) div
           unit_factor (fst (quot_of_fract x)) = snd (quot_of_fract x)"
    if "fst (quot_of_fract x) \<noteq> 0" using that
    by (simp add: unit_factor_poly_altdef monom_0 div_const_poly)
  with 1 show ?case
    by (auto simp: Let_def case_prod_unfold fps_divide_unit fps_inverse_mult
          quot_of_fract_inverse mult_ac
          fps_of_poly_simps fps_const_inverse
          fps_of_poly_normalize_field div_smult_left [symmetric])
qed

context
  includes fps_notation
begin

lemma ratfps_nth_altdef: "ratfps_nth x n = fps_of_ratfps x $ n"
  by transfer
     (simp_all add: case_prod_unfold fps_divide_unit fps_times_def fps_inverse_def
        ratfps_nth_aux_correct Let_def)

lemma fps_of_ratfps_is_unit: "fps_of_ratfps a $ 0 \<noteq> 0 \<longleftrightarrow> ratfps_nth a 0 \<noteq> 0"
  by (simp add: ratfps_nth_altdef)

lemma ratfps_nth_0 [simp]: "ratfps_nth 0 n = 0"
  by (simp add: ratfps_nth_altdef)

lemma fps_of_ratfps_cases:
  obtains p q where "coeff q 0 \<noteq> 0" "fps_of_ratfps f = fps_of_poly p / fps_of_poly q"
  by (rule that[of "snd (quot_of_ratfps f)" "fst (quot_of_ratfps f)"])
     (simp_all add: fps_of_ratfps_altdef case_prod_unfold)

lemma fps_of_ratfps_cutoff [simp]:
    "fps_of_poly (ratfps_cutoff n x) = fps_cutoff n (fps_of_ratfps x)"
  by (simp add: fps_eq_iff ratfps_cutoff_def nth_default_def ratfps_nth_altdef)

lemma subdegree_fps_of_ratfps:
  "subdegree (fps_of_ratfps x) = ratfps_subdegree x"
  by transfer (simp_all add: case_prod_unfold subdegree_div_unit poly_subdegree_def)

lemma ratfps_subdegree_altdef:
  "ratfps_subdegree x = subdegree (fps_of_ratfps x)"
  using subdegree_fps_of_ratfps ..

end

code_datatype fps_of_ratfps

lemma fps_zero_code [code]: "0 = fps_of_ratfps 0" by simp

lemma fps_one_code [code]: "1 = fps_of_ratfps 1" by simp

lemma fps_const_code [code]: "fps_const c = fps_of_poly [:c:]" by simp

lemma fps_of_poly_code [code]: "fps_of_poly p = fps_of_ratfps (ratfps_of_poly p)" by simp

lemma fps_X_code [code]: "fps_X = fps_of_ratfps (ratfps_of_poly [:0,1:])" by simp

lemma fps_nth_code [code]: "fps_nth (fps_of_ratfps x) n = ratfps_nth x n"
  by (simp add: ratfps_nth_altdef)

lemma fps_uminus_code [code]: "- fps_of_ratfps x = fps_of_ratfps (-x)" by simp

lemma fps_add_code [code]: "fps_of_ratfps x + fps_of_ratfps y = fps_of_ratfps (x + y)" by simp

lemma fps_diff_code [code]: "fps_of_ratfps x - fps_of_ratfps y = fps_of_ratfps (x - y)" by simp

lemma fps_mult_code [code]: "fps_of_ratfps x * fps_of_ratfps y = fps_of_ratfps (x * y)" by simp

lemma fps_inverse_code [code]: "inverse (fps_of_ratfps x) = fps_of_ratfps (inverse x)"
  by simp

lemma fps_cutoff_code [code]: "fps_cutoff n (fps_of_ratfps x) = fps_of_poly (ratfps_cutoff n x)"
  by simp

lemmas subdegree_code [code] = subdegree_fps_of_ratfps

lemma fractrel_normalize_quot:
  "fractrel p p \<Longrightarrow> fractrel q q \<Longrightarrow>
     fractrel (normalize_quot p) (normalize_quot q) \<longleftrightarrow> fractrel p q"
  by (subst fractrel_normalize_quot_left fractrel_normalize_quot_right, simp)+ (rule refl)

lemma fps_of_ratfps_eq_iff [simp]:
  "fps_of_ratfps p = fps_of_ratfps q \<longleftrightarrow> p = q"
proof -
  {
    fix p q :: "'a poly fract"
    assume "fractrel (quot_of_fract p) (quot_of_fract q)"
    hence "p = q" by transfer (simp only: fractrel_normalize_quot)
  } note A = this
  show ?thesis
    by transfer (auto simp: case_prod_unfold unit_eq_div1 unit_eq_div2 unit_div_commute intro: A)
qed

lemma fps_of_ratfps_eq_zero_iff [simp]:
  "fps_of_ratfps p = 0 \<longleftrightarrow> p = 0"
  by (simp del: fps_of_ratfps_0 add: fps_of_ratfps_0 [symmetric])

lemma unit_factor_snd_quot_of_ratfps [simp]:
  "unit_factor (snd (quot_of_ratfps x)) = 1"
  by transfer simp

lemma poly_shift_times_monom_le:
  "n \<le> m \<Longrightarrow> poly_shift n (monom c m * p) = monom c (m - n) * p"
  by (intro poly_eqI) (auto simp: coeff_monom_mult coeff_poly_shift)

lemma poly_shift_times_monom_ge:
  "n \<ge> m \<Longrightarrow> poly_shift n (monom c m * p) = smult c (poly_shift (n - m) p)"
  by (intro poly_eqI) (auto simp: coeff_monom_mult coeff_poly_shift)

lemma poly_shift_times_monom:
  "poly_shift n (monom c n * p) = smult c p"
  by (intro poly_eqI) (auto simp: coeff_monom_mult coeff_poly_shift)

lemma monom_times_poly_shift:
  assumes "poly_subdegree p \<ge> n"
  shows   "monom c n * poly_shift n p = smult c p" (is "?lhs = ?rhs")
proof (intro poly_eqI)
  fix k
  show "coeff ?lhs k = coeff ?rhs k"
  proof (cases "k < n")
    case True
    with assms have "k < poly_subdegree p" by simp
    hence "coeff p k = 0" by (simp add: coeff_less_poly_subdegree)
    thus ?thesis by (auto simp: coeff_monom_mult coeff_poly_shift)
  qed (auto simp: coeff_monom_mult coeff_poly_shift)
qed

lemma monom_times_poly_shift':
  assumes "poly_subdegree p \<ge> n"
  shows   "monom (1 :: 'a :: comm_semiring_1) n * poly_shift n p = p"
  by (simp add: monom_times_poly_shift[OF assms])

lemma subdegree_minus_cutoff_ge:
  assumes "f - fps_cutoff n (f :: 'a :: ab_group_add fps) \<noteq> 0"
  shows   "subdegree (f - fps_cutoff n f) \<ge> n"
  using assms by (rule subdegree_geI) simp_all

lemma fps_shift_times_X_power'': "fps_shift n (fps_X ^ n * f :: 'a :: comm_ring_1 fps) = f"
  using fps_shift_times_fps_X_power'[of n f] by (simp add: mult.commute)

lemma
  ratfps_shift_code [code abstract]:
    "quot_of_ratfps (ratfps_shift n x) =
       (let (a, b) = quot_of_ratfps (x - ratfps_of_poly (ratfps_cutoff n x))
        in  (poly_shift n a, b))" (is "?lhs1 = ?rhs1") and
  fps_of_ratfps_shift [simp]:
    "fps_of_ratfps (ratfps_shift n x) = fps_shift n (fps_of_ratfps x)"
proof -
  include fps_notation
  define x' where "x' = ratfps_of_poly (ratfps_cutoff n x)"
  define y where "y = quot_of_ratfps (x - x')"

  have "coprime (fst y) (snd y)" unfolding y_def
    by transfer (rule coprime_quot_of_fract)
  also have fst_y: "fst y = monom 1 n * poly_shift n (fst y)"
  proof (cases "x = x'")
    case False
    have "poly_subdegree (fst y) = subdegree (fps_of_poly (fst y))"
      by (simp add: poly_subdegree_def)
    also have "\<dots> = subdegree (fps_of_poly (fst y) / fps_of_poly (snd y))"
      by (subst subdegree_div_unit) (simp_all add: y_def)
    also have "fps_of_poly (fst y) / fps_of_poly (snd y) = fps_of_ratfps (x - x')"
      unfolding y_def by transfer (simp add: case_prod_unfold)
    also from False have "subdegree \<dots> \<ge> n"
    proof (intro subdegree_geI)
      fix k assume "k < n"
      thus "fps_of_ratfps (x - x') $ k = 0" by (simp add: x'_def)
    qed simp_all
    finally show ?thesis by (rule monom_times_poly_shift' [symmetric])
  qed (simp_all add: y_def)
  finally have coprime: "coprime (poly_shift n (fst y)) (snd y)"
    by simp

  have "quot_of_ratfps (ratfps_shift n x) =
          quot_of_ratfps (quot_to_ratfps (poly_shift n (fst y), snd y))"
    by (simp add: ratfps_shift_def Let_def case_prod_unfold x'_def y_def)
  also from coprime have "\<dots> = (poly_shift n (fst y), snd y)"
    by (intro quot_of_ratfps_quot_to_ratfps) (simp_all add: y_def normalized_fracts_def)
  also have "\<dots> = ?rhs1" by (simp add: case_prod_unfold Let_def y_def x'_def)
  finally show eq: "?lhs1 = ?rhs1" .

  have "fps_shift n (fps_of_ratfps x) = fps_shift n (fps_of_ratfps (x - x'))"
    by (intro fps_ext) (simp_all add: x'_def)
  also have "fps_of_ratfps (x - x') = fps_of_poly (fst y) / fps_of_poly (snd y)"
    by (simp add: fps_of_ratfps_altdef y_def case_prod_unfold)
  also have "fps_shift n \<dots> = fps_of_ratfps (ratfps_shift n x)"
    by (subst fst_y, subst fps_of_poly_mult, subst unit_div_mult_swap [symmetric])
       (simp_all add: y_def fps_of_poly_monom fps_shift_times_X_power'' eq
          fps_of_ratfps_altdef case_prod_unfold Let_def x'_def)
  finally show "fps_of_ratfps (ratfps_shift n x) = fps_shift n (fps_of_ratfps x)" ..
qed

lemma fps_shift_code [code]: "fps_shift n (fps_of_ratfps x) = fps_of_ratfps (ratfps_shift n x)"
  by simp

instantiation fps :: (equal) equal
begin

definition equal_fps :: "'a fps \<Rightarrow> 'a fps \<Rightarrow> bool" where
  [simp]: "equal_fps f g \<longleftrightarrow> f = g"

instance by standard simp_all

end

lemma equal_fps_code [code]: "HOL.equal (fps_of_ratfps f) (fps_of_ratfps g) \<longleftrightarrow> f = g"
  by simp

lemma fps_of_ratfps_divide [simp]:
  "fps_of_ratfps (f div g) = fps_of_ratfps f div fps_of_ratfps g"
  unfolding fps_divide_def Let_def by transfer' (simp add: Let_def ratfps_subdegree_altdef)

lemma ratfps_eqI: "fps_of_ratfps x = fps_of_ratfps y \<Longrightarrow> x = y" by simp

instance ratfps :: ("field_gcd") algebraic_semidom
  by standard (auto intro: ratfps_eqI)

lemma fps_of_ratfps_dvd [simp]:
  "fps_of_ratfps x dvd fps_of_ratfps y \<longleftrightarrow> x dvd y"
proof
  assume "fps_of_ratfps x dvd fps_of_ratfps y"
  hence "fps_of_ratfps y = fps_of_ratfps y div fps_of_ratfps x * fps_of_ratfps x" by simp
  also have "\<dots> = fps_of_ratfps (y div x * x)" by simp
  finally have "y = y div x * x" by (subst (asm) fps_of_ratfps_eq_iff)
  thus "x dvd y" by (intro dvdI[of _ _ "y div x"]) (simp add: mult_ac)
next
  assume "x dvd y"
  hence "y = y div x * x" by simp
  also have "fps_of_ratfps \<dots> = fps_of_ratfps (y div x) * fps_of_ratfps x" by simp
  finally show "fps_of_ratfps x dvd fps_of_ratfps y" by (simp del: fps_of_ratfps_divide)
qed

lemma is_unit_ratfps_iff [simp]:
  "is_unit x \<longleftrightarrow> ratfps_nth x 0 \<noteq> 0"
proof
  assume "is_unit x"
  then obtain y where "1 = x * y" by (auto elim!: dvdE)
  hence "1 = fps_of_ratfps (x * y)" by (simp del: fps_of_ratfps_mult)
  also have "\<dots> = fps_of_ratfps x * fps_of_ratfps y" by simp
  finally have "is_unit (fps_of_ratfps x)" by (rule dvdI[of _ _ "fps_of_ratfps y"])
  thus "ratfps_nth x 0 \<noteq> 0" by (simp add: ratfps_nth_altdef)
next
  assume "ratfps_nth x 0 \<noteq> 0"
  hence "fps_of_ratfps (x * inverse x) = 1"
    by (simp add: ratfps_nth_altdef inverse_mult_eq_1')
  also have "\<dots> = fps_of_ratfps 1" by simp
  finally have "x * inverse x = 1" by (subst (asm) fps_of_ratfps_eq_iff)
  thus "is_unit x" by (intro dvdI[of _ _ "inverse x"]) simp_all
qed

instantiation ratfps :: ("field_gcd") normalization_semidom
begin

definition unit_factor_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" where
  "unit_factor x = ratfps_shift (ratfps_subdegree x) x"

definition normalize_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps" where
  "normalize x = (if x = 0 then 0 else ratfps_of_poly (monom 1 (ratfps_subdegree x)))"

lemma fps_of_ratfps_unit_factor [simp]:
  "fps_of_ratfps (unit_factor x) = unit_factor (fps_of_ratfps x)"
  unfolding unit_factor_ratfps_def by (simp add: ratfps_subdegree_altdef)

lemma fps_of_ratfps_normalize [simp]:
  "fps_of_ratfps (normalize x) = normalize (fps_of_ratfps x)"
  unfolding normalize_ratfps_def by (simp add: fps_of_poly_monom ratfps_subdegree_altdef)

instance proof
  show "unit_factor x * normalize x = x" "normalize (0 :: 'a ratfps) = 0"
       "unit_factor (0 :: 'a ratfps) = 0" for x :: "'a ratfps"
    by (rule ratfps_eqI, simp add: ratfps_subdegree_code
          del: fps_of_ratfps_eq_iff fps_unit_factor_def fps_normalize_def)+
  show "is_unit (unit_factor a)" if "a \<noteq> 0" for a :: "'a ratfps"
    using that by (auto simp: ratfps_nth_altdef)
  fix a b :: "'a ratfps"
  assume "is_unit a"
  thus "unit_factor (a * b) = a * unit_factor b"
    by (intro ratfps_eqI, unfold fps_of_ratfps_unit_factor fps_of_ratfps_mult,
        subst unit_factor_mult_unit_left) (auto simp: ratfps_nth_altdef)
  show "unit_factor a = a" if "is_unit a" for a :: "'a ratfps"
    by (rule ratfps_eqI) (insert that, auto simp: fps_of_ratfps_is_unit)
qed

end

instance ratfps :: ("field_gcd") normalization_semidom_multiplicative
proof
  show "unit_factor (a * b) = unit_factor a * unit_factor b" for a b :: "'a ratfps"
    by (rule ratfps_eqI, insert unit_factor_mult[of "fps_of_ratfps a" "fps_of_ratfps b"])
       (simp del: fps_of_ratfps_eq_iff)
qed

instantiation ratfps :: ("field_gcd") semidom_modulo
begin

lift_definition modulo_ratfps :: "'a ratfps \<Rightarrow> 'a ratfps \<Rightarrow> 'a ratfps" is
  "\<lambda>f g. if g = 0 then f else
           let n = ratfps_subdegree g; h = ratfps_shift n g
           in  ratfps_of_poly (ratfps_cutoff n (f * inverse h)) * h" .

lemma fps_of_ratfps_mod [simp]:
   "fps_of_ratfps (f mod g :: 'a ratfps) = fps_of_ratfps f mod fps_of_ratfps g"
  unfolding fps_mod_def by transfer' (simp add: Let_def ratfps_subdegree_altdef)

instance
  by standard (auto intro: ratfps_eqI)

end

instantiation ratfps :: ("field_gcd") euclidean_ring
begin

definition euclidean_size_ratfps :: "'a ratfps \<Rightarrow> nat" where
  "euclidean_size_ratfps x = (if x = 0 then 0 else 2 ^ ratfps_subdegree x)"

lemma fps_of_ratfps_euclidean_size [simp]:
  "euclidean_size x = euclidean_size (fps_of_ratfps x)"
  unfolding euclidean_size_ratfps_def fps_euclidean_size_def
  by (simp add: ratfps_subdegree_altdef)

instance proof
  show "euclidean_size (0 :: 'a ratfps) = 0" by simp
  show "euclidean_size (a mod b) < euclidean_size b"
       "euclidean_size a \<le> euclidean_size (a * b)" if "b \<noteq> 0" for a b :: "'a ratfps"
    using that by (simp_all add: mod_size_less size_mult_mono)
qed

end

instantiation ratfps :: ("field_gcd") euclidean_ring_cancel
begin

instance
  by standard (auto intro: ratfps_eqI)

end

lemma quot_of_ratfps_eq_iff [simp]: "quot_of_ratfps x = quot_of_ratfps y \<longleftrightarrow> x = y"
  by transfer simp

lemma ratfps_eq_0_code: "x = 0 \<longleftrightarrow> fst (quot_of_ratfps x) = 0"
proof
  assume "fst (quot_of_ratfps x) = 0"
  moreover have "coprime (fst (quot_of_ratfps x)) (snd (quot_of_ratfps x))"
    by transfer (simp add: coprime_quot_of_fract)
  moreover have "normalize (snd (quot_of_ratfps x)) = snd (quot_of_ratfps x)"
    by (simp add: div_unit_factor [symmetric] del: div_unit_factor)
  ultimately have "quot_of_ratfps x = (0,1)"
    by (simp add: prod_eq_iff normalize_idem_imp_is_unit_iff)
  also have "\<dots> = quot_of_ratfps 0" by simp
  finally show "x = 0" by (subst (asm) quot_of_ratfps_eq_iff)
qed simp_all

lemma ratfps_dvd_code [code_unfold]:
  "x dvd y \<longleftrightarrow> y = 0 \<or> (x \<noteq> 0 \<and> ratfps_subdegree x \<le> ratfps_subdegree y)"
  using fps_dvd_code [of "fps_of_ratfps x" "fps_of_ratfps y"]
  by (simp add: ratfps_subdegree_altdef)

instance ratfps :: ("field_gcd") normalization_euclidean_semiring ..

instantiation ratfps :: ("field_gcd") euclidean_ring_gcd
begin

definition "gcd_ratfps = (Euclidean_Algorithm.gcd :: 'a ratfps \<Rightarrow> _)"
definition "lcm_ratfps = (Euclidean_Algorithm.lcm :: 'a ratfps \<Rightarrow> _)"
definition "Gcd_ratfps = (Euclidean_Algorithm.Gcd :: 'a ratfps set \<Rightarrow> _)"
definition "Lcm_ratfps = (Euclidean_Algorithm.Lcm:: 'a ratfps set \<Rightarrow> _)"

instance by standard (simp_all add: gcd_ratfps_def lcm_ratfps_def Gcd_ratfps_def Lcm_ratfps_def)
end

lemma ratfps_eq_0_iff: "x = 0 \<longleftrightarrow> fps_of_ratfps x = 0"
  using fps_of_ratfps_eq_iff[of x 0] unfolding fps_of_ratfps_0 by simp

lemma ratfps_of_poly_eq_0_iff: "ratfps_of_poly x = 0 \<longleftrightarrow> x = 0"
  by (auto simp: ratfps_eq_0_iff)

lemma ratfps_gcd:
  assumes [simp]: "f \<noteq> 0" "g \<noteq> 0"
  shows   "gcd f g = ratfps_of_poly (monom 1 (min (ratfps_subdegree f) (ratfps_subdegree g)))"
  by (rule sym, rule gcdI)
     (auto simp: ratfps_subdegree_altdef ratfps_dvd_code subdegree_fps_of_poly
         ratfps_of_poly_eq_0_iff normalize_ratfps_def)

lemma ratfps_gcd_altdef: "gcd (f :: 'a :: field_gcd ratfps) g =
  (if f = 0 \<and> g = 0 then 0 else
   if f = 0 then ratfps_of_poly (monom 1 (ratfps_subdegree g)) else
   if g = 0 then ratfps_of_poly (monom 1 (ratfps_subdegree f)) else
     ratfps_of_poly (monom 1 (min (ratfps_subdegree f) (ratfps_subdegree g))))"
  by (simp add: ratfps_gcd normalize_ratfps_def)

lemma ratfps_lcm:
  assumes [simp]: "f \<noteq> 0" "g \<noteq> 0"
  shows   "lcm f g = ratfps_of_poly (monom 1 (max (ratfps_subdegree f) (ratfps_subdegree g)))"
  by (rule sym, rule lcmI)
     (auto simp: ratfps_subdegree_altdef ratfps_dvd_code subdegree_fps_of_poly
         ratfps_of_poly_eq_0_iff normalize_ratfps_def)

lemma ratfps_lcm_altdef: "lcm (f :: 'a :: field_gcd ratfps) g =
  (if f = 0 \<or> g = 0 then 0 else
     ratfps_of_poly (monom 1 (max (ratfps_subdegree f) (ratfps_subdegree g))))"
  by (simp add: ratfps_lcm)

lemma ratfps_Gcd:
  assumes "A - {0} \<noteq> {}"
  shows   "Gcd A = ratfps_of_poly (monom 1 (INF f\<in>A-{0}. ratfps_subdegree f))"
proof (rule sym, rule GcdI)
  fix f assume "f \<in> A"
  thus "ratfps_of_poly (monom 1 (INF f\<in>A - {0}. ratfps_subdegree f)) dvd f"
    by (cases "f = 0") (auto simp: ratfps_dvd_code ratfps_of_poly_eq_0_iff ratfps_subdegree_altdef
                          subdegree_fps_of_poly intro!: cINF_lower)
next
  fix d assume d: "\<And>f. f \<in> A \<Longrightarrow> d dvd f"
  from assms obtain f where "f \<in> A - {0}" by auto
  with d[of f] have [simp]: "d \<noteq> 0" by auto
  from d assms have "ratfps_subdegree d \<le> (INF f\<in>A-{0}. ratfps_subdegree f)"
    by (intro cINF_greatest) (auto simp: ratfps_dvd_code)
  with d assms show "d dvd ratfps_of_poly (monom 1 (INF f\<in>A-{0}. ratfps_subdegree f))"
    by (simp add: ratfps_dvd_code ratfps_subdegree_altdef subdegree_fps_of_poly)
qed (simp_all add: ratfps_subdegree_altdef subdegree_fps_of_poly normalize_ratfps_def)

lemma ratfps_Gcd_altdef: "Gcd (A :: 'a :: field_gcd ratfps set) =
  (if A \<subseteq> {0} then 0 else ratfps_of_poly (monom 1 (INF f\<in>A-{0}. ratfps_subdegree f)))"
  using ratfps_Gcd by auto

lemma ratfps_Lcm:
  assumes "A \<noteq> {}" "0 \<notin> A" "bdd_above (ratfps_subdegree`A)"
  shows   "Lcm A = ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f))"
proof (rule sym, rule LcmI)
  fix f assume "f \<in> A"
  moreover from assms(3) have "bdd_above (ratfps_subdegree ` A)" by auto
  ultimately show "f dvd ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f))" using assms(2)
    by (cases "f = 0") (auto simp: ratfps_dvd_code ratfps_of_poly_eq_0_iff subdegree_fps_of_poly
                          ratfps_subdegree_altdef [abs_def] intro!: cSUP_upper)
next
  fix d assume d: "\<And>f. f \<in> A \<Longrightarrow> f dvd d"
  from assms obtain f where f: "f \<in> A" "f \<noteq> 0" by auto
  show "ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f)) dvd d"
  proof (cases "d = 0")
    assume "d \<noteq> 0"
    moreover from d have "\<And>f. f \<in> A \<Longrightarrow> f \<noteq> 0 \<Longrightarrow> f dvd d" by blast
    ultimately have "ratfps_subdegree d \<ge> (SUP f\<in>A. ratfps_subdegree f)" using assms
      by (intro cSUP_least) (auto simp: ratfps_dvd_code)
    with \<open>d \<noteq> 0\<close> show ?thesis by (simp add: ratfps_dvd_code ratfps_of_poly_eq_0_iff
          ratfps_subdegree_altdef subdegree_fps_of_poly)
  qed simp_all
qed (simp_all add: ratfps_subdegree_altdef subdegree_fps_of_poly normalize_ratfps_def)

lemma ratfps_Lcm_altdef:
  "Lcm (A :: 'a :: field_gcd ratfps set) =
     (if 0 \<in> A \<or> \<not>bdd_above (ratfps_subdegree`A) then 0 else
      if A = {} then 1 else ratfps_of_poly (monom 1 (SUP f\<in>A. ratfps_subdegree f)))"
proof (cases "bdd_above (ratfps_subdegree`A)")
  assume unbounded: "\<not>bdd_above (ratfps_subdegree`A)"
  have "Lcm A = 0"
  proof (rule ccontr)
    assume "Lcm A \<noteq> 0"
    from unbounded obtain f where f: "f \<in> A" "ratfps_subdegree (Lcm A) < ratfps_subdegree f"
      unfolding bdd_above_def by (auto simp: not_le)
    moreover from this and \<open>Lcm A \<noteq> 0\<close> have "ratfps_subdegree f \<le> ratfps_subdegree (Lcm A)"
      using dvd_Lcm[of f A] by (auto simp: ratfps_dvd_code)
    ultimately show False by simp
  qed
  with unbounded show ?thesis by simp
qed (simp_all add: ratfps_Lcm Lcm_eq_0_I)

lemma fps_of_ratfps_quot_to_ratfps:
  "coeff y 0 \<noteq> 0 \<Longrightarrow> fps_of_ratfps (quot_to_ratfps (x,y)) = fps_of_poly x / fps_of_poly y"
proof (transfer, goal_cases)
  case (1 y x)
  define x' y' where "x' = fst (normalize_quot (x,y))" and "y' = snd (normalize_quot (x,y))"
  from 1 have nz: "y \<noteq> 0" by auto
  have eq: "normalize_quot (x', y') = (x', y')" by (simp add: x'_def y'_def)
  from normalize_quotE[OF nz, 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 [folded x'_def y'_def] = this
  have "(case quot_of_fract (if coeff y' 0 = 0 then 0 else quot_to_fract (x', y')) of
          (a, b) \<Rightarrow> fps_of_poly a / fps_of_poly b) = fps_of_poly x / fps_of_poly y"
    using d eq 1 by (auto simp: case_prod_unfold fps_of_poly_simps quot_of_fract_quot_to_fract
                                Let_def coeff_0_mult)
  thus ?case by (auto simp add: Let_def case_prod_unfold x'_def y'_def)
qed

lemma fps_of_ratfps_quot_to_ratfps_code_post1:
  "fps_of_ratfps (quot_to_ratfps (x,pCons 1 y)) = fps_of_poly x / fps_of_poly (pCons 1 y)"
  "fps_of_ratfps (quot_to_ratfps (x,pCons (-1) y)) = fps_of_poly x / fps_of_poly (pCons (-1) y)"
  by (simp_all add: fps_of_ratfps_quot_to_ratfps)

lemma fps_of_ratfps_quot_to_ratfps_code_post2:
  "fps_of_ratfps (quot_to_ratfps (x'::'a::{field_char_0,field_gcd} poly,pCons (numeral n) y')) =
     fps_of_poly x' / fps_of_poly (pCons (numeral n) y')"
  "fps_of_ratfps (quot_to_ratfps (x'::'a::{field_char_0,field_gcd} poly,pCons (-numeral n) y')) =
     fps_of_poly x' / fps_of_poly (pCons (-numeral n) y')"
  by (simp_all add: fps_of_ratfps_quot_to_ratfps)

lemmas fps_of_ratfps_quot_to_ratfps_code_post [code_post] =
  fps_of_ratfps_quot_to_ratfps_code_post1
  fps_of_ratfps_quot_to_ratfps_code_post2

lemma fps_dehorner:
  fixes a b c :: "'a :: semiring_1 fps" and d e f :: "'b :: ring_1 fps"
  shows
  "(b + c) * fps_X = b * fps_X + c * fps_X" "(a * fps_X) * fps_X = a * fps_X ^ 2"
  "a * fps_X ^ m * fps_X = a * fps_X ^ (Suc m)" "a * fps_X * fps_X ^ m = a * fps_X ^ (Suc m)"
  "a * fps_X^m * fps_X^n = a * fps_X^(m+n)" "a + (b + c) = a + b + c" "a * 1 = a" "1 * a = a"
  "d + - e = d - e" "(-d) * e = - (d * e)" "d + (e - f) = d + e - f"
  "(d - e) * fps_X = d * fps_X - e * fps_X" "fps_X * fps_X = fps_X^2" "fps_X * fps_X^m = fps_X^(Suc m)" "fps_X^m * fps_X = fps_X^Suc m"
  "fps_X^m * fps_X^n = fps_X^(m + n)"
  by (simp_all add: algebra_simps power2_eq_square power_add power_commutes)

lemma fps_divide_1: "(a :: 'a :: field fps) / 1 = a" by simp

lemmas fps_of_poly_code_post [code_post] =
  fps_of_poly_simps fps_const_0_eq_0 fps_const_1_eq_1 numeral_fps_const [symmetric]
  fps_const_neg [symmetric] fps_const_divide [symmetric]
  fps_dehorner Suc_numeral arith_simps fps_divide_1

context
  includes term_syntax
begin

definition
  valterm_ratfps ::
    "'a ::{field_gcd, typerep} poly \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow>
     'a poly \<times> (unit \<Rightarrow> Code_Evaluation.term) \<Rightarrow> 'a ratfps \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
  [code_unfold]: "valterm_ratfps k l =
    Code_Evaluation.valtermify (/) {\<cdot>}
      (Code_Evaluation.valtermify ratfps_of_poly {\<cdot>} k) {\<cdot>}
      (Code_Evaluation.valtermify ratfps_of_poly {\<cdot>} l)"

end

instantiation ratfps :: ("{field_gcd,random}") random
begin

context
  includes state_combinator_syntax term_syntax
begin

definition
  "Quickcheck_Random.random i =
     Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>num::'a poly \<times> (unit \<Rightarrow> term).
       Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>denom::'a poly \<times> (unit \<Rightarrow> term).
         Pair (let denom = (if fst denom = 0 then Code_Evaluation.valtermify 1 else denom)
               in  valterm_ratfps num denom)))"

instance ..

end

end

instantiation ratfps :: ("{field,factorial_ring_gcd,exhaustive}") exhaustive
begin

definition
  "exhaustive_ratfps f d =
     Quickcheck_Exhaustive.exhaustive (\<lambda>num.
       Quickcheck_Exhaustive.exhaustive (\<lambda>denom. f (
         let denom = if denom = 0 then 1 else denom
         in  ratfps_of_poly num / ratfps_of_poly denom)) d) d"

instance ..

end

instantiation ratfps :: ("{field_gcd,full_exhaustive}") full_exhaustive
begin

definition
  "full_exhaustive_ratfps f d =
     Quickcheck_Exhaustive.full_exhaustive (\<lambda>num::'a poly \<times> (unit \<Rightarrow> term).
       Quickcheck_Exhaustive.full_exhaustive (\<lambda>denom::'a poly \<times> (unit \<Rightarrow> term).
         f (let denom = if fst denom = 0 then Code_Evaluation.valtermify 1 else denom
            in  valterm_ratfps num denom)) d) d"

instance ..

end

quickcheck_generator fps constructors: fps_of_ratfps

end


(*  Title:      Fast Fourier Transform
    Author:     Clemens Ballarin <ballarin at in.tum.de>, started 12 April 2005
    Maintainer: Clemens Ballarin <ballarin at in.tum.de>
*)

theory FFT
imports Complex_Main
begin

text \<open>We formalise a functional implementation of the FFT algorithm
  over the complex numbers, and its inverse.  Both are shown
  equivalent to the usual definitions
  of these operations through Vandermonde matrices.  They are also
  shown to be inverse to each other, more precisely, that composition
  of the inverse and the transformation yield the identity up to a
  scalar.

  The presentation closely follows Section 30.2 of Cormen \textit{et
  al.}, \emph{Introduction to Algorithms}, 2nd edition, MIT Press,
  2003.\<close>

section \<open>Preliminaries\<close>

text \<open>The following two lemmas are useful for experimenting with the
  transformations, at a vector length of four.\<close>

lemma Ivl4:
  "{0..<4::nat} = {0, 1, 2, 3}"
proof -
  have "{0..<4::nat} = {0..<Suc (Suc (Suc (Suc 0)))}" by (simp add: eval_nat_numeral)
  also have "... = {0, 1, 2, 3}"
    by (simp add: atLeastLessThanSuc eval_nat_numeral insert_commute)
  finally show ?thesis .
qed

lemma Sum4:
  "(\<Sum>i=0..<4::nat. x i) = x 0 + x 1 + x 2 + x 3"
  by (simp add: Ivl4 eval_nat_numeral)

text \<open>A number of specialised lemmas for the summation operator,
  where the index set is the natural numbers\<close>

lemma sum_add_nat_ivl_singleton:
  assumes less: "m < (n::nat)"
  shows "f m + sum f {m<..<n} = sum f {m..<n}"
proof -
  have "f m + sum f {m<..<n} = sum f ({m} \<union> {m<..<n})"
    by (simp add: sum.union_disjoint ivl_disj_int)
  also from less have "... = sum f {m..<n}"
    by (simp only: ivl_disj_un)
  finally show ?thesis .
qed

lemma sum_add_split_nat_ivl_singleton:
  assumes less: "m < (n::nat)"
    and g: "!!i. [| m < i; i < n |] ==> g i = f i"
  shows "f m + sum g {m<..<n} = sum f {m..<n}"
  using less g
  by(simp add: sum_add_nat_ivl_singleton cong: sum.cong_simp)

lemma sum_add_split_nat_ivl:
  assumes le: "m <= (k::nat)" "k <= n"
    and g: "!!i. [| m <= i; i < k |] ==> g i = f i"
    and h: "!!i. [| k <= i; i < n |] ==> h i = f i"
  shows "sum g {m..<k} + sum h {k..<n} = sum f {m..<n}"
  using le g h by (simp add: sum.atLeastLessThan_concat cong: sum.cong_simp)

lemma ivl_splice_Un:
  "{0..<2*n::nat} = ((*) 2 ` {0..<n}) \<union> ((%i. Suc (2*i)) ` {0..<n})"
  apply (unfold image_def Bex_def)
  apply auto
  apply arith
  done

lemma ivl_splice_Int:
  "((*) 2 ` {0..<n}) \<inter> ((%i. Suc (2*i)) ` {0..<n}) = {}"
  by auto arith

lemma double_inj_on:
  "inj_on (%i. 2*i::nat) A"
  by (simp add: inj_onI)

lemma Suc_double_inj_on:
  "inj_on (%i. Suc (2*i)) A"
  by (rule inj_onI) simp

lemma sum_splice:
  "(\<Sum>i::nat = 0..<2*n. f i) = (\<Sum>i = 0..<n. f (2*i)) + (\<Sum>i = 0..<n. f (2*i+1))"
proof -
  have "(\<Sum>i::nat = 0..<2*n. f i) =
    sum f ((*) 2 ` {0..<n}) + sum f ((%i. 2*i+1) ` {0..<n})"
    by (simp add: ivl_splice_Un ivl_splice_Int sum.union_disjoint)
  also have "... = (\<Sum>i = 0..<n. f (2*i)) + (\<Sum>i = 0..<n. f (2*i+1))"
    by (simp add: sum.reindex [OF double_inj_on]
      sum.reindex [OF Suc_double_inj_on])
  finally show ?thesis .
qed

section \<open>Complex Roots of Unity\<close>

text \<open>The function @{term cis} from the complex library returns the
  point on the unity circle corresponding to the argument angle.  It
  is the base for our definition of \<open>root\<close>.  The main property,
  De Moirve's formula is already there in the library.\<close>

definition root :: "nat => complex" where
  "root n == cis (2*pi/(real (n::nat)))"

lemma sin_periodic_pi_diff: "sin (x - pi) = - sin x"
  by (fact sin_minus_pi)

lemma sin_cos_between_zero_two_pi:
  assumes 0: "0 < x" and pi: "x < 2 * pi"
  shows "sin x \<noteq> 0 \<or> cos x \<noteq> 1"
proof -
  { assume "0 < x" and "x < pi"
    then have "sin x \<noteq> 0" by (auto dest: sin_gt_zero) }
  moreover
  { assume "x = pi"
    then have "cos x \<noteq> 1" by simp }
  moreover
  { assume pi1: "pi < x" and pi2: "x < 2 * pi"
    then have "0 < x - pi" and "x - pi < pi" by arith+
    then have "sin (x - pi) \<noteq> 0" using sin_gt_zero by fastforce
    with pi1 pi2 have "sin x \<noteq> 0" by simp }
  ultimately show ?thesis using 0 pi by arith
qed

subsection \<open>Basic Lemmas\<close>

lemma root_nonzero: "root n \<noteq> 0"
  by (auto simp add: complex_eq_iff root_def dest: sin_zero_abs_cos_one)

lemma root_unity: "root n ^ n = 1"
  by (simp add: complex_eq_iff root_def DeMoivre)

lemma root_cancel: "0 < d ==> root (d * n) ^ (d * k) = root n ^ k"
  apply (unfold root_def)
  apply (simp add: DeMoivre)
  done

lemma root_summation:
  assumes k: "0 < k" "k < n"
  shows "(\<Sum>i=0..<n. (root n ^ k) ^ i) = 0"
proof -
  from k have real0: "0 < real k * (2 * pi) / real n"
    by (simp add: zero_less_divide_iff
      mult_strict_right_mono [where a = 0, simplified])
  from k mult_strict_right_mono [where a = "real k" and
    b = "real n" and c = "2 * pi / real n", simplified]
  have realk: "real k * (2 * pi) / real n < 2 * pi"
    by (simp add: zero_less_divide_iff)
  txt \<open>Main part of the proof\<close>
  have "(\<Sum>i=0..<n. (root n ^ k) ^ i) =
    ((root n ^ k) ^ n - 1) / (root n ^ k - 1)"
    unfolding atLeast0LessThan
    apply (rule geometric_sum)
    apply (unfold root_def)
    apply (simp add: DeMoivre)
    using real0 realk sin_cos_between_zero_two_pi
    apply (auto simp add: complex_eq_iff)
    done
  also have "... = ((root n ^ n) ^ k - 1) / (root n ^ k - 1)"
    by (simp add: power_mult [THEN sym] ac_simps)
  also have "... = 0"
    by (simp add: root_unity)
  finally show ?thesis .
qed

lemma root_summation_inv:
  assumes k: "0 < k" "k < n"
  shows "(\<Sum>i=0..<n. ((1 / root n) ^ k) ^ i) = 0"
proof -
  from k have real0: "0 < real k * (2 * pi) / real n"
    by (simp add: zero_less_divide_iff
      mult_strict_right_mono [where a = 0, simplified])
  from k mult_strict_right_mono [where a = "real k" and
    b = "real n" and c = "2 * pi / real n", simplified]
  have realk: "real k * (2 * pi) / real n < 2 * pi"
    by (simp add: zero_less_divide_iff)
  txt \<open>Main part of the proof\<close>
  have "(\<Sum>i=0..<n. ((1 / root n) ^ k) ^ i) =
    (((1 / root n) ^ k) ^ n - 1) / ((1 / root n) ^ k - 1)"
    unfolding atLeast0LessThan
    apply (rule geometric_sum)
    apply (simp add: nonzero_inverse_eq_divide [THEN sym] root_nonzero)
    apply (unfold root_def)
    apply (simp add: DeMoivre)
    using real0 realk sin_cos_between_zero_two_pi
    apply (auto simp add: complex_eq_iff)
    done
  also have "... = (((1 / root n) ^ n) ^ k - 1) / ((1 / root n) ^ k - 1)"
    by (simp add: power_mult [THEN sym] ac_simps)
  also have "... = 0"
    by (simp add: power_divide root_unity)
  finally show ?thesis .
qed

lemma root0 [simp]:
  "root 0 = 1"
  by (simp add: complex_eq_iff root_def)

lemma root1 [simp]:
  "root 1 = 1"
  by (simp add: complex_eq_iff root_def)

lemma root2 [simp]:
  "root 2 = -1"
  by (simp add: complex_eq_iff root_def)

lemma root4 [simp]:
  "root 4 = \<i>"
  by (simp add: complex_eq_iff root_def)

subsection \<open>Derived Lemmas\<close>

lemma root_cancel1:
  "root (2 * m) ^ (i * (2 * j)) = root m ^ (i * j)"
proof -
  have "root (2 * m) ^ (i * (2 * j)) = root (2 * m) ^ (2 * (i * j))"
    by (simp add: ac_simps)
  also have "... = root m ^ (i * j)"
    by (simp add: root_cancel)
  finally show ?thesis .
qed

lemma root_cancel2:
  "0 < n ==> root (2 * n) ^ n = - 1"
  txt \<open>Note the space between \<open>-\<close> and \<open>1\<close>.\<close>
  using root_cancel [where n = 2 and k = 1]
  by (simp add: complex_eq_iff ac_simps)

section \<open>Discrete Fourier Transformation\<close>

text \<open>
  We define operations  \<open>DFT\<close> and \<open>IDFT\<close> for the discrete
  Fourier Transform and its inverse.  Vectors are simply functions of
  type \<open>nat => complex\<close>.\<close>

text \<open>
  \<open>DFT n a\<close> is the transform of vector \<open>a\<close>
  of length \<open>n\<close>, \<open>IDFT\<close> its inverse.\<close>

definition DFT :: "nat => (nat => complex) => (nat => complex)" where
  "DFT n a == (%i. \<Sum>j=0..<n. (root n) ^ (i * j) * (a j))"

definition IDFT :: "nat => (nat => complex) => (nat => complex)" where
  "IDFT n a == (%i. (\<Sum>k=0..<n. (a k) / (root n) ^ (i * k)))"

schematic_goal "map (DFT 4 a) [0, 1, 2, 3] = ?x"
  by(simp add: DFT_def Sum4)

text \<open>Lemmas for the correctness proof.\<close>

lemma DFT_lower:
  "DFT (2 * m) a i =
  DFT m (%i. a (2 * i)) i +
  (root (2 * m)) ^ i * DFT m (%i. a (2 * i + 1)) i"
proof (unfold DFT_def)
  have "(\<Sum>j = 0..<2 * m. root (2 * m) ^ (i * j) * a j) =
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j)) * a (2 * j)) +
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j + 1)) * a (2 * j + 1))"
    (is "?s = _")
    by (simp add: sum_splice)
  also have "... = (\<Sum>j = 0..<m. root m ^ (i * j) * a (2 * j)) +
    root (2 * m) ^ i *
    (\<Sum>j = 0..<m. root m ^ (i * j) * a (2 * j + 1))"
    (is "_ = ?t")
    txt \<open>First pair of sums\<close>
    apply (simp add: root_cancel1)
    txt \<open>Second pair of sums\<close>
    apply (simp add: sum_distrib_left)
    apply (simp add: power_add)
    apply (simp add: root_cancel1)
    apply (simp add: ac_simps)
    done
  finally show "?s = ?t" .
qed

lemma DFT_upper:
  assumes mbound: "0 < m" and ibound: "m <= i"
  shows "DFT (2 * m) a i =
    DFT m (%i. a (2 * i)) (i - m) -
    root (2 * m) ^ (i - m) * DFT m (%i. a (2 * i + 1)) (i - m)"
proof (unfold DFT_def)
  have "(\<Sum>j = 0..<2 * m. root (2 * m) ^ (i * j) * a j) =
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j)) * a (2 * j)) +
    (\<Sum>j = 0..<m. root (2 * m) ^ (i * (2 * j + 1)) * a (2 * j + 1))"
    (is "?s = _")
    by (simp add: sum_splice)
  also have "... =
    (\<Sum>j = 0..<m. root m ^ ((i - m) * j) * a (2 * j)) -
    root (2 * m) ^ (i - m) *
    (\<Sum>j = 0..<m. root m ^ ((i - m) * j) * a (2 * j + 1))"
    (is "_ = ?t")
    txt \<open>First pair of sums\<close>
    apply (simp add: root_cancel1)
    apply (simp add: root_unity ibound root_nonzero power_diff power_mult)
    txt \<open>Second pair of sums\<close>
    apply (simp add: mbound root_cancel2)
    apply (simp add: sum_distrib_left)
    apply (simp add: power_add)
    apply (simp add: root_cancel1)
    apply (simp add: power_mult)
    apply (simp add: ac_simps)
    done
  finally show "?s = ?t" .
qed

lemma IDFT_lower:
  "IDFT (2 * m) a i =
  IDFT m (%i. a (2 * i)) i +
  (1 / root (2 * m)) ^ i * IDFT m (%i. a (2 * i + 1)) i"
proof (unfold IDFT_def)
  have "(\<Sum>j = 0..<2 * m. a j / root (2 * m) ^ (i * j)) =
    (\<Sum>j = 0..<m. a (2 * j) / root (2 * m) ^ (i * (2 * j))) +
    (\<Sum>j = 0..<m. a (2 * j + 1) / root (2 * m) ^ (i * (2 * j + 1)))"
    (is "?s = _")
    by (simp add: sum_splice)
  also have "... = (\<Sum>j = 0..<m. a (2 * j) / root m ^ (i * j)) +
    (1 / root (2 * m)) ^ i *
    (\<Sum>j = 0..<m. a (2 * j + 1) / root m ^ (i * j))"
    (is "_ = ?t")
    txt \<open>First pair of sums\<close>
    apply (simp add: root_cancel1)
    txt \<open>Second pair of sums\<close>
    apply (simp add: sum_distrib_left)
    apply (simp add: power_add)
    apply (simp add: power_divide root_nonzero)
    apply (simp add: root_cancel1)
    done
  finally show "?s = ?t" .
qed

lemma IDFT_upper:
  assumes mbound: "0 < m" and ibound: "m <= i"
  shows "IDFT (2 * m) a i =
    IDFT m (%i. a (2 * i)) (i - m) -
    (1 / root (2 * m)) ^ (i - m) *
    IDFT m (%i. a (2 * i + 1)) (i - m)"
proof (unfold IDFT_def)
  have "(\<Sum>j = 0..<2 * m. a j / root (2 * m) ^ (i * j)) =
    (\<Sum>j = 0..<m. a (2 * j) / root (2 * m) ^ (i * (2 * j))) +
    (\<Sum>j = 0..<m. a (2 * j + 1) / root (2 * m) ^ (i * (2 * j + 1)))"
    (is "?s = _")
    by (simp add: sum_splice)
  also have "... =
    (\<Sum>j = 0..<m. a (2 * j) / root m ^ ((i - m) * j)) -
    (1 / root (2 * m)) ^ (i - m) *
    (\<Sum>j = 0..<m. a (2 * j + 1) / root m ^ ((i - m) * j))"
    (is "_ = ?t")
    txt \<open>First pair of sums\<close>
    apply (simp add: root_cancel1)
    apply (simp add: root_unity ibound root_nonzero power_diff power_mult)
    txt \<open>Second pair of sums\<close>
    apply (simp add: power_divide root_nonzero)
    apply (simp add: mbound root_cancel2)
    apply (simp add: sum_divide_distrib)
    apply (simp add: power_add)
    apply (simp add: root_cancel1)
    apply (simp add: power_mult)
    apply (simp add: ac_simps)
    done
  finally show "?s = ?t" .
qed

text \<open>\<open>DFT\<close> und \<open>IDFT\<close> are inverses.\<close>

declare divide_divide_eq_right [simp del]
  divide_divide_eq_left [simp del]

lemma power_diff_inverse:
  assumes nz: "(a::'a::field) ~= 0"
  shows "m <= n ==> (inverse a) ^ (n-m) = (a^m) / (a^n)"
  apply (induct n m rule: diff_induct)
    apply (simp add: power_inverse
      nonzero_inverse_eq_divide [THEN sym] nz)
   apply simp
  apply (simp add: nz)
  done

lemma power_diff_rev_if:
  assumes nz: "(a::'a::field) ~= 0"
  shows "(a^m) / (a^n) = (if n <= m then a ^ (m-n) else (1/a) ^ (n-m))"
proof (cases "n <= m")
  case True with nz show ?thesis
    by (simp add: power_diff)
next
  case False with nz show ?thesis
    by (simp add: power_diff_inverse nonzero_inverse_eq_divide [THEN sym])
qed

lemma power_divides_special:
  "(a::'a::field) ~= 0 ==>
  a ^ (i * j) / a ^ (k * i) = (a ^ j / a ^ k) ^ i"
  by (simp add: power_divide power_mult [THEN sym] ac_simps)

theorem DFT_inverse:
  assumes i_less: "i < n"
  shows  "IDFT n (DFT n a) i = of_nat n * a i"
  using [[linarith_split_limit = 0]]
  apply (unfold DFT_def IDFT_def)
  apply (simp add: sum_divide_distrib)
  apply (subst sum.swap)
  apply (simp only: times_divide_eq_left [THEN sym])
  apply (simp only: power_divides_special [OF root_nonzero])
  apply (simp add: power_diff_rev_if root_nonzero)
  apply (simp add: sum_divide_distrib [THEN sym]
    sum_distrib_right [THEN sym])
  proof -
    from i_less have i_diff: "!!k. i - k < n" by arith
    have diff_i: "!!k. k < n ==> k - i < n" by arith

    let ?sum = "%i j n. sum ((^) (if i <= j then root n ^ (j - i)
                  else (1 / root n) ^ (i - j))) {0..<n} * a j"
    let ?sum1 = "%i j n. sum ((^) (root n ^ (j - i))) {0..<n} * a j"
    let ?sum2 = "%i j n. sum ((^) ((1 / root n) ^ (i - j))) {0..<n} * a j"

    from i_less have "(\<Sum>j = 0..<n. ?sum i j n) =
      (\<Sum>j = 0..<i. ?sum2 i j n) + (\<Sum>j = i..<n. ?sum1 i j n)"
      (is "?s = _")
      by (simp add: root_summation_inv nat_dvd_not_less
        sum_add_split_nat_ivl [where f = "%j. ?sum i j n"])
    also from i_less i_diff
    have "... = (\<Sum>j = i..<n. ?sum1 i j n)"
      by (simp add: root_summation_inv nat_dvd_not_less)
    also from i_less have "... =
      (\<Sum>j\<in>{i} \<union> {i<..<n}. ?sum1 i j n)"
      by (simp only: ivl_disj_un)
    also have "... =
      (?sum1 i i n + (\<Sum>j\<in>{i<..<n}. ?sum1 i j n))"
      by (simp add: sum.union_disjoint ivl_disj_int)
    also from i_less diff_i have "... = ?sum1 i i n"
      by (simp add: root_summation nat_dvd_not_less)
    also from i_less have "... = of_nat n * a i" (is "_ = ?t")
      by simp
    finally show "?s = ?t" .
  qed

section \<open>Discrete, Fast Fourier Transformation\<close>

text \<open>\<open>FFT k a\<close> is the transform of vector \<open>a\<close>
  of length \<open>2 ^ k\<close>, \<open>IFFT\<close> its inverse.\<close>

primrec FFT :: "nat => (nat => complex) => (nat => complex)" where
  "FFT 0 a = a"
| "FFT (Suc k) a =
     (let (x, y) = (FFT k (%i. a (2*i)), FFT k (%i. a (2*i+1)))
      in (%i. if i < 2^k
            then x i + (root (2 ^ (Suc k))) ^ i * y i
            else x (i- 2^k) - (root (2 ^ (Suc k))) ^ (i- 2^k) * y (i- 2^k)))"

primrec IFFT :: "nat => (nat => complex) => (nat => complex)" where
  "IFFT 0 a = a"
| "IFFT (Suc k) a =
     (let (x, y) = (IFFT k (%i. a (2*i)), IFFT k (%i. a (2*i+1)))
      in (%i. if i < 2^k
            then x i + (1 / root (2 ^ (Suc k))) ^ i * y i
            else x (i - 2^k) -
              (1 / root (2 ^ (Suc k))) ^ (i - 2^k) * y (i - 2^k)))"

text \<open>Finally, for vectors of length \<open>2 ^ k\<close>,
  \<open>DFT\<close> and \<open>FFT\<close>, and \<open>IDFT\<close> and
  \<open>IFFT\<close> are equivalent.\<close>

theorem DFT_FFT:
  "!!a i. i < 2 ^ k ==> DFT (2 ^ k) a i = FFT k a i"
proof (induct k)
  case 0
  then show ?case by (simp add: DFT_def)
next
  case (Suc k)
  assume i: "i < 2 ^ Suc k"
  show ?case proof (cases "i < 2 ^ k")
    case True
    then show ?thesis apply simp apply (simp add: DFT_lower)
      apply (simp add: Suc) done
  next
    case False
    from i have "i - 2 ^ k < 2 ^ k" by simp
    with False i show ?thesis apply simp apply (simp add: DFT_upper)
      apply (simp add: Suc) done
  qed
qed

theorem IDFT_IFFT:
  "!!a i. i < 2 ^ k ==> IDFT (2 ^ k) a i = IFFT k a i"
proof (induct k)
  case 0
  then show ?case by (simp add: IDFT_def)
next
  case (Suc k)
  assume i: "i < 2 ^ Suc k"
  show ?case proof (cases "i < 2 ^ k")
    case True
    then show ?thesis apply simp apply (simp add: IDFT_lower)
      apply (simp add: Suc) done
  next
    case False
    from i have "i - 2 ^ k < 2 ^ k" by simp
    with False i show ?thesis apply simp apply (simp add: IDFT_upper)
      apply (simp add: Suc) done
  qed
qed

schematic_goal "map (FFT (Suc (Suc 0)) a) [0, 1, 2, 3] = ?x"
  by simp

end


section \<open>Integral and Bounded Matrices and Vectors\<close>

text \<open>We define notions of integral vectors and matrices and bounded vectors and matrices
  and prove some preservation lemmas. Moreover, we prove two bounds on determinants.\<close>
theory Integral_Bounded_Vectors
  imports
    Missing_VS_Connect
    Sum_Vec_Set
    LLL_Basis_Reduction.Gram_Schmidt_2 (* for some simp-rules *)
begin

(* TODO: move into theory Norms *)
lemma sq_norm_unit_vec[simp]: assumes i: "i < n"
  shows "\<parallel>unit_vec n i\<parallel>\<^sup>2 = (1 :: 'a :: {comm_ring_1,conjugatable_ring})"
proof -
  from i have id: "[0..<n] = [0..<i] @ [i] @ [Suc i ..< n]"
    by (metis append_Cons append_Nil diff_zero length_upt list_trisect)
  show ?thesis unfolding sq_norm_vec_def unit_vec_def
    by (auto simp: o_def id, subst (1 2) sum_list_0, auto)
qed

definition Ints_vec ("\<int>\<^sub>v") where
  "\<int>\<^sub>v = {x. \<forall> i < dim_vec x. x $ i \<in> \<int>}"

definition indexed_Ints_vec  where
  "indexed_Ints_vec I = {x. \<forall> i < dim_vec x. i \<in> I \<longrightarrow> x $ i \<in> \<int>}"

lemma indexed_Ints_vec_UNIV: "\<int>\<^sub>v = indexed_Ints_vec UNIV"
  unfolding Ints_vec_def indexed_Ints_vec_def by auto

lemma indexed_Ints_vec_subset: "\<int>\<^sub>v \<subseteq> indexed_Ints_vec I"
  unfolding Ints_vec_def indexed_Ints_vec_def by auto

lemma Ints_vec_vec_set: "v \<in> \<int>\<^sub>v = (vec_set v \<subseteq> \<int>)"
  unfolding Ints_vec_def vec_set_def by auto

definition Ints_mat ("\<int>\<^sub>m") where
  "\<int>\<^sub>m = {A. \<forall> i < dim_row A. \<forall> j < dim_col A. A $$ (i,j) \<in> \<int>}"

lemma Ints_mat_elements_mat: "A \<in> \<int>\<^sub>m = (elements_mat A \<subseteq> \<int>)"
  unfolding Ints_mat_def elements_mat_def by force

lemma minus_in_Ints_vec_iff[simp]: "(-x) \<in> \<int>\<^sub>v \<longleftrightarrow> (x :: 'a :: ring_1 vec) \<in> \<int>\<^sub>v"
  unfolding Ints_vec_vec_set by (auto simp: minus_in_Ints_iff)

lemma minus_in_Ints_mat_iff[simp]: "(-A) \<in> \<int>\<^sub>m \<longleftrightarrow> (A :: 'a :: ring_1 mat) \<in> \<int>\<^sub>m"
  unfolding Ints_mat_elements_mat by (auto simp: minus_in_Ints_iff)

lemma Ints_vec_rows_Ints_mat[simp]: "set (rows A) \<subseteq> \<int>\<^sub>v \<longleftrightarrow> A \<in> \<int>\<^sub>m"
  unfolding rows_def Ints_vec_def Ints_mat_def by force

lemma unit_vec_integral[simp,intro]: "unit_vec n i \<in> \<int>\<^sub>v"
  unfolding Ints_vec_def by (auto simp: unit_vec_def)

lemma diff_indexed_Ints_vec:
  "x \<in> carrier_vec n \<Longrightarrow> y \<in> carrier_vec n \<Longrightarrow> x \<in> indexed_Ints_vec I \<Longrightarrow> y \<in> indexed_Ints_vec I
  \<Longrightarrow> x - y \<in> indexed_Ints_vec I"
  unfolding indexed_Ints_vec_def by auto

lemma smult_indexed_Ints_vec: "x \<in> \<int> \<Longrightarrow> v \<in> indexed_Ints_vec I \<Longrightarrow> x \<cdot>\<^sub>v v \<in> indexed_Ints_vec I"
  unfolding indexed_Ints_vec_def smult_vec_def by simp

lemma (in vec_space) lincomb_indexed_Ints_vec: assumes cI: "\<And> x. x \<in> C \<Longrightarrow> c x \<in> \<int>"
  and C: "C \<subseteq> carrier_vec n"
  and CI: "C \<subseteq> indexed_Ints_vec I"
shows "lincomb c C \<in> indexed_Ints_vec I"
proof -
  from C have id: "dim_vec (lincomb c C) = n" by auto
  show ?thesis unfolding indexed_Ints_vec_def mem_Collect_eq id
  proof (intro allI impI)
    fix i
    assume i: "i < n" and iI: "i \<in> I"
    have "lincomb c C $ i = (\<Sum>x\<in>C. c x * x $ i)"
      by (rule lincomb_index[OF i C])
    also have "\<dots> \<in> \<int>"
      by (intro Ints_sum Ints_mult cI, insert i iI CI[unfolded indexed_Ints_vec_def] C, force+)
    finally show "lincomb c C $ i \<in> \<int>" .
  qed
qed

definition "Bounded_vec (b :: 'a :: linordered_idom) = {x . \<forall> i < dim_vec x . abs (x $ i) \<le> b}"

lemma Bounded_vec_vec_set: "v \<in> Bounded_vec b \<longleftrightarrow> (\<forall> x \<in> vec_set v. abs x \<le> b)"
  unfolding Bounded_vec_def vec_set_def by auto

definition "Bounded_mat (b :: 'a :: linordered_idom) =
  {A . (\<forall> i < dim_row A . \<forall> j < dim_col A. abs (A $$ (i,j)) \<le> b)}"

lemma Bounded_mat_elements_mat: "A \<in> Bounded_mat b \<longleftrightarrow> (\<forall> x \<in> elements_mat A. abs x \<le> b)"
  unfolding Bounded_mat_def elements_mat_def by auto

lemma Bounded_vec_rows_Bounded_mat[simp]: "set (rows A) \<subseteq> Bounded_vec B \<longleftrightarrow> A \<in> Bounded_mat B"
  unfolding rows_def Bounded_vec_def Bounded_mat_def by force

lemma unit_vec_Bounded_vec[simp,intro]: "unit_vec n i \<in> Bounded_vec (max 1 Bnd)"
  unfolding Bounded_vec_def unit_vec_def by auto

lemma unit_vec_int_bounds: "set (unit_vecs n) \<subseteq> \<int>\<^sub>v \<inter> Bounded_vec (of_int (max 1 Bnd))"
  unfolding unit_vecs_def by (auto simp: Bounded_vec_def)

lemma Bounded_matD: assumes "A \<in> Bounded_mat b"
  "A \<in> carrier_mat nr nc"
shows "i < nr \<Longrightarrow> j < nc \<Longrightarrow> abs (A $$ (i,j)) \<le> b"
  using assms unfolding Bounded_mat_def by auto

lemma Bounded_vec_mono: "b \<le> B \<Longrightarrow> Bounded_vec b \<subseteq> Bounded_vec B"
  unfolding Bounded_vec_def by auto

lemma Bounded_mat_mono: "b \<le> B \<Longrightarrow> Bounded_mat b \<subseteq> Bounded_mat B"
  unfolding Bounded_mat_def by force

lemma finite_Bounded_vec_Max:
  assumes A: "A \<subseteq> carrier_vec n"
    and fin: "finite A"
  shows "A \<subseteq> Bounded_vec (Max { abs (a $ i) | a i. a \<in> A \<and> i < n})"
proof
  let ?B = "{ abs (a $ i) | a i. a \<in> A \<and> i < n}"
  have fin: "finite ?B"
    by (rule finite_subset[of _ "(\<lambda> (a,i). abs (a $ i)) ` (A \<times> {0 ..< n})"], insert fin, auto)
  fix a
  assume a: "a \<in> A"
  show "a \<in> Bounded_vec (Max ?B)"
    unfolding Bounded_vec_def
    by (standard, intro allI impI Max_ge[OF fin], insert a A, force)
qed

definition is_det_bound :: "(nat \<Rightarrow> 'a :: linordered_idom \<Rightarrow> 'a) \<Rightarrow> bool" where
  "is_det_bound f = (\<forall> A n x. A \<in> carrier_mat n n \<longrightarrow> A \<in> Bounded_mat x \<longrightarrow> abs (det A) \<le> f n x)"

lemma is_det_bound_ge_zero: assumes "is_det_bound f"
  and "x \<ge> 0"
  shows "f n x \<ge> 0"
  using assms(1)[unfolded is_det_bound_def, rule_format, of "0\<^sub>m n n" n x]
  using assms(2) unfolding Bounded_mat_def by auto

definition det_bound_fact :: "nat \<Rightarrow> 'a :: linordered_idom \<Rightarrow> 'a" where
  "det_bound_fact n x = fact n * (x^n)"

lemma det_bound_fact: "is_det_bound det_bound_fact"
  unfolding is_det_bound_def
proof (intro allI impI)
  fix A :: "'a :: linordered_idom mat" and n x
  assume A: "A \<in> carrier_mat n n"
    and x: "A \<in> Bounded_mat x"
  show "abs (det A) \<le> det_bound_fact n x"
  proof -
    have "abs (det A) = abs (\<Sum>p | p permutes {0..<n}. signof p * (\<Prod>i = 0..<n. A $$ (i, p i)))"
      unfolding det_def'[OF A] ..
    also have "\<dots> \<le> (\<Sum>p | p permutes {0..<n}. abs (signof p * (\<Prod>i = 0..<n. A $$ (i, p i))))"
      by (rule sum_abs)
    also have "\<dots> = (\<Sum>p | p permutes {0..<n}. (\<Prod>i = 0..<n. abs (A $$ (i, p i))))"
      by (rule sum.cong[OF refl], auto simp: abs_mult abs_prod sign_def simp flip: of_int_abs)
    also have "\<dots> \<le> (\<Sum>p | p permutes {0..<n}. (\<Prod>i = 0..<n. x))"
      by (intro sum_mono prod_mono conjI Bounded_matD[OF x A], auto)
    also have "\<dots> = fact n * x^n" by (auto simp add: card_permutations)
    finally show "abs (det A) \<le> det_bound_fact n x" unfolding det_bound_fact_def by auto
  qed
qed

lemma (in gram_schmidt_fs) Gramian_determinant_det: assumes A: "A \<in> carrier_mat n n"
  shows "Gramian_determinant (rows A) n = det A * det A"
proof -
  have [simp]: "mat_of_rows n (rows A) = A" using A
    by (intro eq_matI, auto)
  show ?thesis using A
  unfolding Gramian_determinant_def
  by (subst Gramian_matrix_alt_def, force, simp add: Let_def, subst det_mult[of _ n],
    auto simp: det_transpose)
qed

lemma (in gram_schmidt_fs_lin_indpt) det_bound_main: assumes rows: "rows A = fs"
  and A: "A \<in> carrier_mat n n"
  and n0: "n > 0"
  and Bnd: "A \<in> Bounded_mat c"
shows
  "(abs (det A))^2 \<le> of_nat n ^ n * c ^ (2 * n)"
proof -
  from n0 A Bnd have "abs (A $$ (0,0)) \<le> c" by (auto simp: Bounded_mat_def)
  hence c0: "c \<ge> 0" by auto
  from n0 A rows have fs: "set fs \<noteq> {}" by (auto simp: rows_def)
  from rows A have len: "length fs = n" by auto
  have "(abs (det A))^2 = det A * det A" unfolding power2_eq_square by simp
  also have "\<dots> = d n" using Gramian_determinant_det[OF A] unfolding rows by simp
  also have "\<dots> = (\<Prod>j<n. \<parallel>gso j\<parallel>\<^sup>2)"
    by (rule Gramian_determinant(1), auto simp: len)
  also have "\<dots> \<le> (\<Prod>j<n. N)"
    by (rule prod_mono, insert N_gso, auto simp: len)
  also have "\<dots> = N^n" by simp
  also have "\<dots> \<le> (of_nat n * c^2)^n"
  proof (rule power_mono)
    show "0 \<le> N" using N_ge_0 len n0 by auto
    show "N \<le> of_nat n * c^2" unfolding N_def
    proof (intro Max.boundedI, force, use fs in force, clarify)
      fix f
      assume "f \<in> set fs"
      from this[folded rows] obtain i where i: "i < n" and f: "f = row A i"
        using A unfolding rows_def by auto
      have "\<parallel>f\<parallel>\<^sup>2 = (\<Sum>x\<leftarrow>list_of_vec (row A i). x^2)"
        unfolding f sq_norm_vec_def power2_eq_square by simp
      also have "list_of_vec (row A i) = map (\<lambda> j. A $$ (i,j)) [0..<n]"
        using i A by (intro nth_equalityI, auto)
      also have "sum_list (map power2 (map (\<lambda>j. A $$ (i, j)) [0..<n])) \<le>
          sum_list (map (\<lambda> j. c^2) [0..<n])" unfolding map_map o_def
      proof (intro sum_list_mono)
        fix j
        assume "j \<in> set [0 ..< n]"
        hence j: "j < n" by auto
        from Bnd i j A have "\<bar>A $$ (i, j)\<bar> \<le> c" by (auto simp: Bounded_mat_def)
        thus "(A $$ (i, j))\<^sup>2 \<le> c\<^sup>2"
          by (meson abs_ge_zero order_trans power2_le_iff_abs_le)
      qed
      also have "\<dots> = (\<Sum>j <n. c\<^sup>2)"
        unfolding interv_sum_list_conv_sum_set_nat by auto
      also have "\<dots> = of_nat n * c\<^sup>2" by auto
      finally show "\<parallel>f\<parallel>\<^sup>2 \<le> of_nat n * c\<^sup>2" .
    qed
  qed
  also have "\<dots> = (of_nat n)^n * (c\<^sup>2 ^ n)" by (auto simp: algebra_simps)
  also have "\<dots> =  of_nat n ^n * c^(2 * n)" unfolding power_mult[symmetric]
    by (simp add: ac_simps)
  finally show ?thesis .
qed

lemma det_bound_hadamard_squared: fixes A::"'a :: trivial_conjugatable_linordered_field mat"
  assumes A: "A \<in> carrier_mat n n"
    and Bnd: "A \<in> Bounded_mat c"
  shows "(abs (det A))^2 \<le> of_nat n ^ n * c ^ (2 * n)"
proof (cases "n > 0")
  case n: True
  from n A Bnd have "abs (A $$ (0,0)) \<le> c" by (auto simp: Bounded_mat_def)
  hence c0: "c \<ge> 0" by auto
  let ?us = "map (row A) [0 ..< n]"
  interpret gso: gram_schmidt_fs n ?us .
  have len: "length ?us = n" by simp
  have us: "set ?us \<subseteq> carrier_vec n" using A by auto
  let ?vs = "map gso.gso [0..<n]"
  show ?thesis
  proof (cases "carrier_vec n \<subseteq> gso.span (set ?us)")
    case False
    from mat_of_rows_rows[unfolded rows_def,of A] A gram_schmidt.non_span_det_zero[OF len False us]
    have zero: "det A = 0" by auto
    show ?thesis unfolding zero using c0 by simp
  next
    case True
    with us len have basis: "gso.basis_list ?us" unfolding gso.basis_list_def by auto
    note in_dep = gso.basis_list_imp_lin_indpt_list[OF basis]
    interpret gso: gram_schmidt_fs_lin_indpt n ?us
      by (standard) (use in_dep gso.lin_indpt_list_def in auto)
    from gso.det_bound_main[OF _ A n Bnd]
    show ?thesis using A by (auto simp: rows_def)
  qed
next
  case False
  with A show ?thesis by auto
qed

definition det_bound_hadamard :: "nat \<Rightarrow> int \<Rightarrow> int" where
  "det_bound_hadamard n c = (sqrt_int_floor ((int n * c^2)^n))"

lemma det_bound_hadamard_altdef[code]:
  "det_bound_hadamard n c = (if n = 1 \<or> even n then int n ^ (n div 2) * (abs c)^n else sqrt_int_floor ((int n * c^2)^n))"
proof (cases "n = 1 \<or> even n")
  case False
  thus ?thesis unfolding det_bound_hadamard_def by auto
next
  case True
  define thesis where "thesis = ?thesis"
  have "thesis \<longleftrightarrow> sqrt_int_floor ((int n * c^2)^n) = int n ^ (n div 2) * abs c^n"
    using True unfolding thesis_def det_bound_hadamard_def by auto
  also have "(int n * c^2)^n = int n^n * c^(2 * n)"
    unfolding power_mult[symmetric] power_mult_distrib by (simp add: ac_simps)
  also have "int n^n = int n ^ (2 * (n div 2))" using True by auto
  also have "\<dots> * c^(2 * n) = (int n ^ (n div 2) * c^n)^2"
    unfolding power_mult_distrib power_mult[symmetric] by (simp add: ac_simps)
  also have "sqrt_int_floor \<dots> = int n ^ (n div 2) * \<bar>c\<bar> ^ n"
    unfolding sqrt_int_floor of_int_power real_sqrt_abs of_int_abs[symmetric] floor_of_int
     abs_mult power_abs by simp
  finally have thesis by auto
  thus ?thesis unfolding thesis_def by auto
qed

lemma det_bound_hadamard: "is_det_bound det_bound_hadamard"
  unfolding is_det_bound_def
proof (intro allI impI)
  fix A :: "int mat" and n c
  assume A: "A \<in> carrier_mat n n" and BndA: "A \<in> Bounded_mat c"
  let ?h = rat_of_int
  let ?hA = "map_mat ?h A"
  let ?hc = "?h c"
  from A have hA: "?hA \<in> carrier_mat n n" by auto
  from BndA have Bnd: "?hA \<in> Bounded_mat ?hc"
    unfolding Bounded_mat_def
    by (auto, unfold of_int_abs[symmetric] of_int_le_iff, auto)
  have sqrt: "sqrt ((real n * (real_of_int c)\<^sup>2) ^ n) \<ge> 0"
    by simp
  from det_bound_hadamard_squared[OF hA Bnd, unfolded of_int_hom.hom_det of_int_abs[symmetric]]
  have "?h ( \<bar>det A\<bar>^2) \<le> ?h (int n ^ n * c ^ (2 * n))" by simp
  from this[unfolded of_int_le_iff]
  have "\<bar>det A\<bar>^2 \<le> int n ^ n * c ^ (2 * n)" .
  also have "\<dots> = (int n * c^2)^n" unfolding power_mult power_mult_distrib by simp
  finally have "\<bar>det A\<bar>\<^sup>2 \<le> (int n * c\<^sup>2) ^ n" by simp
  hence "sqrt_int_floor (\<bar>det A\<bar>\<^sup>2) \<le> sqrt_int_floor ((int n * c\<^sup>2) ^ n)"
    unfolding sqrt_int_floor by (intro floor_mono real_sqrt_le_mono, linarith)
  also have "sqrt_int_floor (\<bar>det A\<bar>\<^sup>2) = \<bar>det A\<bar>" by (simp del: of_int_abs add: of_int_abs[symmetric])
  finally show "\<bar>det A\<bar> \<le> det_bound_hadamard n c" unfolding det_bound_hadamard_def by simp
qed

lemma n_pow_n_le_fact_square: "n ^ n \<le> (fact n)^2"
proof -
  define ii where "ii (i :: nat) = (n + 1 - i)" for i
  have id: "ii ` {1..n} = {1..n}" unfolding ii_def
  proof (auto, goal_cases)
    case (1 i)
    hence i: "i = (-) (Suc n) (ii i)" unfolding ii_def by auto
    show ?case by (subst i, rule imageI, insert 1, auto simp: ii_def)
  qed
  have "(fact n) = (\<Prod>{1..n})"
    by (simp add: fact_prod)
  hence "(fact n)^2 = ((\<Prod>{1..n}) * (\<Prod>{1..n}))" by (auto simp: power2_eq_square)
  also have "\<dots> = ((\<Prod>{1..n}) * prod (\<lambda> i. i) (ii ` {1..n}))"
    by (rule arg_cong[of _ _ "\<lambda> x. (_ * x)"], rule prod.cong[OF id[symmetric]], auto)
  also have "\<dots> = ((\<Prod>{1..n}) * prod ii {1..n})"
    by (subst prod.reindex, auto simp: ii_def inj_on_def)
  also have "\<dots> = (prod (\<lambda> i. i * ii i) {1..n})"
    by (subst prod.distrib, auto)
  also have "\<dots> \<ge> (prod (\<lambda> i. n) {1..n})"
  proof (intro prod_mono conjI, simp)
    fix i
    assume i: "i \<in> {1 .. n}"
    let ?j = "ii i"
    show "n \<le> i * ?j"
    proof (cases "i = 1 \<or> i = n")
      case True
      thus ?thesis unfolding ii_def by auto
    next
      case False
      hence min: "min i ?j \<ge> 2" using i by (auto simp: ii_def)
      have max: "n \<le> 2 * max i ?j" using i by (auto simp: ii_def)
      also have "\<dots> \<le> min i ?j * max i ?j" using min
        by (intro mult_mono, auto)
      also have "\<dots> = i * ?j" by (cases "i < ?j", auto simp: ac_simps)
      finally show ?thesis .
    qed
  qed
  finally show ?thesis by simp
qed

lemma sqrt_int_floor_bound: "0 \<le> x \<Longrightarrow> (sqrt_int_floor x)^2 \<le> x"
  unfolding sqrt_int_floor_def
  using root_int_floor_def root_int_floor_pos_lower by auto

lemma det_bound_hadamard_improves_det_bound_fact: assumes c: "c \<ge> 0"
  shows "det_bound_hadamard n c \<le> det_bound_fact n c"
proof -
  have "(det_bound_hadamard n c)^2 \<le> (int n * c\<^sup>2) ^ n" unfolding det_bound_hadamard_def
    by (rule sqrt_int_floor_bound, auto)
  also have "\<dots> = int (n ^ n) * c^(2 * n)" by (simp add: power_mult power_mult_distrib)
  also have "\<dots> \<le> int ((fact n)^2) * c^(2 * n)"
    by (intro mult_right_mono, unfold of_nat_le_iff, rule n_pow_n_le_fact_square, auto)
  also have "\<dots> = (det_bound_fact n c)^2" unfolding det_bound_fact_def
    by (simp add: power_mult_distrib power_mult[symmetric] ac_simps)
  finally have "abs (det_bound_hadamard n c) \<le> abs (det_bound_fact n c)"
    unfolding abs_le_square_iff .
  hence "det_bound_hadamard n c \<le> abs (det_bound_fact n c)" by simp
  also have "\<dots> = det_bound_fact n c" unfolding det_bound_fact_def using c by auto
  finally show ?thesis .
qed

context
begin
private fun syl :: "int \<Rightarrow> nat \<Rightarrow> int mat" where
  "syl c 0 = mat 1 1 (\<lambda> _. c)"
| "syl c (Suc n) = (let A = syl c n in
     four_block_mat A A (-A) A)"

private lemma syl: assumes c: "c \<ge> 0"
  shows "syl c n \<in> Bounded_mat c \<and> syl c n \<in> carrier_mat (2^n) (2^n)
    \<and> det (syl c n) = det_bound_hadamard (2^n) c"
proof (cases "n = 0")
  case True
  thus ?thesis using c
    unfolding det_bound_hadamard_altdef
    by (auto simp: Bounded_mat_def det_single)
next
  case False
  then obtain m where n: "n = Suc m" by (cases n, auto)
  show ?thesis unfolding n
  proof (induct m)
    case 0
    show ?case unfolding syl.simps Let_def using c
      apply (subst det_four_block_mat[of _ 1]; force?)
      apply (subst det_single,
        auto simp: Bounded_mat_def scalar_prod_def det_bound_hadamard_altdef power2_eq_square)
      done
  next
    case (Suc m)
    define A where "A = syl c (Suc m)"
    let ?FB = "four_block_mat A A (- A) A"
    define n :: nat where "n = 2 ^ Suc m"
    from Suc[folded A_def n_def]
    have Bnd: "A \<in> Bounded_mat c"
      and A: "A \<in> carrier_mat n n"
      and detA: "det A = det_bound_hadamard n c"
      by auto
    have n2: "2 ^ Suc (Suc m) = 2 * n" unfolding n_def by auto
    show ?case unfolding syl.simps(2)[of _ "Suc m"] A_def[symmetric] Let_def n2
    proof (intro conjI)
      show "?FB \<in> carrier_mat (2 * n) (2 * n)" using A by auto
      show "?FB \<in> Bounded_mat c" using Bnd A unfolding Bounded_mat_elements_mat
        by (subst elements_four_block_mat_id, auto)
      have ev: "even n" and sum: "n div 2 + n div 2 = n" unfolding n_def by auto
      have n2: "n * 2 = n + n" by simp
      have "det ?FB = det (A * A - A * - A)"
        by (rule det_four_block_mat[OF A A _ A], insert A, auto)
      also have "A * A - A * - A = A * A + A * A" using A by auto
      also have "\<dots> = 2 \<cdot>\<^sub>m (A * A)" using A by auto
      also have "det \<dots> = 2^n * det (A * A)"
        by (subst det_smult, insert A, auto)
      also have "det (A * A) = det A * det A" by (rule det_mult[OF A A])
      also have "2^n * \<dots> = det_bound_hadamard (2 * n) c" unfolding detA
        unfolding det_bound_hadamard_altdef by (simp add: ev ac_simps power_add[symmetric] sum n2)
      finally show "det ?FB = det_bound_hadamard (2 * n) c" .
    qed
  qed
qed

lemma det_bound_hadamard_tight:
    assumes c: "c \<ge> 0"
      and "n = 2^m"
    shows "\<exists> A. A \<in> carrier_mat n n \<and> A \<in> Bounded_mat c \<and> det A = det_bound_hadamard n c"
  by (rule exI[of _ "syl c m"], insert syl[OF c, of m, folded assms(2)], auto)
end

lemma Ints_matE: assumes "A \<in> \<int>\<^sub>m"
  shows "\<exists> B. A = map_mat of_int B"
proof -
  have "\<forall> ij. \<exists> x. fst ij < dim_row A \<longrightarrow> snd ij < dim_col A \<longrightarrow> A $$ ij = of_int x"
    using assms unfolding Ints_mat_def Ints_def by auto
  from choice[OF this] obtain f where
    f: "\<forall> i j. i < dim_row A \<longrightarrow> j < dim_col A \<longrightarrow> A $$ (i,j) = of_int (f (i,j))"
    by auto
  show ?thesis
    by (intro exI[of _ "mat (dim_row A) (dim_col A) f"] eq_matI, insert f, auto)
qed

lemma is_det_bound_of_int: fixes A :: "'a :: linordered_idom mat"
  assumes db: "is_det_bound db"
  and A: "A \<in> carrier_mat n n"
  and "A \<in> \<int>\<^sub>m \<inter> Bounded_mat (of_int bnd)"
shows "abs (det A) \<le> of_int (db n bnd)"
proof -
  from assms have "A \<in> \<int>\<^sub>m" by auto
  from Ints_matE[OF this] obtain B where
    AB: "A = map_mat of_int B" by auto
  from assms have "A \<in> Bounded_mat (of_int bnd)" by auto
  hence "B \<in> Bounded_mat bnd" unfolding AB Bounded_mat_elements_mat
    by (auto simp flip: of_int_abs)
  from db[unfolded is_det_bound_def, rule_format, OF _ this, of n] AB A
  have "\<bar>det B\<bar> \<le> db n bnd" by auto
  thus ?thesis unfolding AB of_int_hom.hom_det
    by (simp flip: of_int_abs)
qed

lemma minus_in_Bounded_vec[simp]:
  "(-x) \<in> Bounded_vec b \<longleftrightarrow> x \<in> Bounded_vec b"
  unfolding Bounded_vec_def by auto

lemma sum_in_Bounded_vecI[intro]: assumes
  xB: "x \<in> Bounded_vec B1" and
  yB: "y \<in> Bounded_vec B2" and
  x: "x \<in> carrier_vec n" and
  y: "y \<in> carrier_vec n"
shows "x + y \<in> Bounded_vec (B1 + B2)"
proof -
  from x y have id: "dim_vec (x + y) = n" by auto
  show ?thesis unfolding Bounded_vec_def mem_Collect_eq id
  proof (intro allI impI)
    fix i
    assume i: "i < n"
    with x y xB yB have *: "abs (x $ i) \<le> B1" "abs (y $ i) \<le> B2"
      unfolding Bounded_vec_def by auto
    thus "\<bar>(x + y) $ i\<bar> \<le> B1 + B2" using i x y by simp
  qed
qed

lemma (in gram_schmidt) lincomb_card_bound: assumes XBnd: "X \<subseteq> Bounded_vec Bnd"
  and X: "X \<subseteq> carrier_vec n"
  and Bnd: "Bnd \<ge> 0"
  and c: "\<And> x. x \<in> X \<Longrightarrow> abs (c x) \<le> 1"
  and card: "card X \<le> k"
shows "lincomb c X \<in> Bounded_vec (of_nat k * Bnd)"
proof -
  from X have dim: "dim_vec (lincomb c X) = n" by auto
  show ?thesis unfolding Bounded_vec_def mem_Collect_eq dim
  proof (intro allI impI)
    fix i
    assume i: "i < n"
    have "abs (lincomb c X $ i) = abs (\<Sum>x\<in>X. c x * x $ i)"
      by (subst lincomb_index[OF i X], auto)
    also have "\<dots> \<le> (\<Sum>x\<in>X. abs (c x * x $ i))" by auto
    also have "\<dots> = (\<Sum>x\<in>X. abs (c x) * abs (x $ i))" by (auto simp: abs_mult)
    also have "\<dots> \<le> (\<Sum>x\<in>X. 1 * abs (x $ i))"
      by (rule sum_mono[OF mult_right_mono], insert c, auto)
    also have "\<dots> = (\<Sum>x\<in>X. abs (x $ i))" by simp
    also have "\<dots> \<le> (\<Sum>x\<in>X. Bnd)"
      by (rule sum_mono, insert i XBnd[unfolded Bounded_vec_def] X, force)
    also have "\<dots> = of_nat (card X) * Bnd" by simp
    also have "\<dots> \<le> of_nat k * Bnd"
      by (rule mult_right_mono[OF _ Bnd], insert card, auto)
    finally show "abs (lincomb c X $ i) \<le> of_nat k * Bnd" by auto
  qed
qed

lemma bounded_vecset_sum:
  assumes Acarr: "A \<subseteq> carrier_vec n"
    and Bcarr: "B \<subseteq> carrier_vec n"
    and sum: "C = A + B"
    and Cbnd: "\<exists> bndC. C \<subseteq> Bounded_vec bndC"
  shows "A \<noteq> {} \<Longrightarrow> (\<exists> bndB. B \<subseteq> Bounded_vec bndB)"
    and "B \<noteq> {} \<Longrightarrow> (\<exists> bndA. A \<subseteq> Bounded_vec bndA)"
proof -
  {
    fix A B :: "'a vec set"
    assume Acarr: "A \<subseteq> carrier_vec n"
    assume Bcarr: "B \<subseteq> carrier_vec n"
    assume sum: "C = A + B"
    assume Ane: "A \<noteq> {}"
    have "\<exists> bndB. B \<subseteq> Bounded_vec bndB"
    proof(cases "B = {}")
      case Bne: False
      from Cbnd obtain bndC where bndC: "C \<subseteq> Bounded_vec bndC" by auto
      from Ane obtain a where aA: "a \<in> A" and acarr: "a \<in> carrier_vec n" using Acarr by auto
      let ?M = "{abs (a $ i) | i. i < n}"
      have finM: "finite ?M" by simp
      define nb where "nb = abs bndC + Max ?M"
      {
        fix b
        assume bB: "b \<in> B" and bcarr: "b \<in> carrier_vec n"
        have ab: "a + b \<in> Bounded_vec bndC" using aA bB bndC sum by auto
        {
          fix i
          assume i_lt_n: "i < n"
          hence ai_le_max: "abs(a $ i) \<le> Max ?M" using acarr finM Max_ge by blast
          hence "abs(a $ i + b $ i) \<le> abs bndC"
            using ab bcarr acarr index_add_vec(1) i_lt_n unfolding Bounded_vec_def by auto
          hence "abs(b $ i) \<le> abs bndC + abs(a $ i)" by simp
          hence "abs(b $ i) \<le> nb" using i_lt_n bcarr ai_le_max unfolding nb_def by simp
        }
        hence "b \<in> Bounded_vec nb" unfolding Bounded_vec_def using bcarr carrier_vecD by blast
      }
      hence "B \<subseteq> Bounded_vec nb" unfolding Bounded_vec_def using Bcarr by auto
      thus ?thesis by auto
    qed auto
  } note theor = this
  show "A \<noteq> {} \<Longrightarrow> (\<exists> bndB. B \<subseteq> Bounded_vec bndB)" using theor[OF Acarr Bcarr sum] by simp
  have CBA: "C = B + A" unfolding sum by (rule comm_add_vecset[OF Acarr Bcarr])
  show "B \<noteq> {} \<Longrightarrow> \<exists> bndA. A \<subseteq> Bounded_vec bndA" using theor[OF Bcarr Acarr CBA] by simp
qed

end


(*  Title:      HOL/ZF/Zet.thy
    Author:     Steven Obua

    Introduces a type 'a zet of ZF representable sets.
    See "Partizan Games in Isabelle/HOLZF", available from http://www4.in.tum.de/~obua/partizan
*)

theory Zet
imports HOLZF
begin

definition "zet = {A :: 'a set | A f z. inj_on f A \<and> f ` A \<subseteq> explode z}"

typedef 'a zet = "zet :: 'a set set"
  unfolding zet_def by blast

definition zin :: "'a \<Rightarrow> 'a zet \<Rightarrow> bool" where
  "zin x A == x \<in> (Rep_zet A)"

lemma zet_ext_eq: "(A = B) = (\<forall>x. zin x A = zin x B)"
  by (auto simp add: Rep_zet_inject[symmetric] zin_def)

definition zimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a zet \<Rightarrow> 'b zet" where
  "zimage f A == Abs_zet (image f (Rep_zet A))"

lemma zet_def': "zet = {A :: 'a set | A f z. inj_on f A \<and> f ` A = explode z}"
  apply (rule set_eqI)
  apply (auto simp add: zet_def)
  apply (rule_tac x=f in exI)
  apply auto
  apply (rule_tac x="Sep z (\<lambda> y. y \<in> (f ` x))" in exI)
  apply (auto simp add: explode_def Sep)
  done

lemma image_zet_rep: "A \<in> zet \<Longrightarrow> \<exists>z . g ` A = explode z"
  apply (auto simp add: zet_def')
  apply (rule_tac x="Repl z (g o (inv_into A f))" in exI)
  apply (simp add: explode_Repl_eq)
  apply (subgoal_tac "explode z = f ` A")
  apply (simp_all add: image_image cong: image_cong_simp)
  done

lemma zet_image_mem:
  assumes Azet: "A \<in> zet"
  shows "g ` A \<in> zet"
proof -
  from Azet have "\<exists>(f :: _ \<Rightarrow> ZF). inj_on f A"
    by (auto simp add: zet_def')
  then obtain f where injf: "inj_on (f :: _ \<Rightarrow> ZF) A"
    by auto
  let ?w = "f o (inv_into A g)"
  have subset: "(inv_into A g) ` (g ` A) \<subseteq> A"
    by (auto simp add: inv_into_into)
  have "inj_on (inv_into A g) (g ` A)" by (simp add: inj_on_inv_into)
  then have injw: "inj_on ?w (g ` A)"
    apply (rule comp_inj_on)
    apply (rule subset_inj_on[where B=A])
    apply (auto simp add: subset injf)
    done
  show ?thesis
    apply (simp add: zet_def' image_comp)
    apply (rule exI[where x="?w"])
    apply (simp add: injw image_zet_rep Azet)
    done
qed

lemma Rep_zimage_eq: "Rep_zet (zimage f A) = image f (Rep_zet A)"
  apply (simp add: zimage_def)
  apply (subst Abs_zet_inverse)
  apply (simp_all add: Rep_zet zet_image_mem)
  done

lemma zimage_iff: "zin y (zimage f A) = (\<exists>x. zin x A \<and> y = f x)"
  by (auto simp add: zin_def Rep_zimage_eq)

definition zimplode :: "ZF zet \<Rightarrow> ZF" where
  "zimplode A == implode (Rep_zet A)"

definition zexplode :: "ZF \<Rightarrow> ZF zet" where
  "zexplode z == Abs_zet (explode z)"

lemma Rep_zet_eq_explode: "\<exists>z. Rep_zet A = explode z"
  by (rule image_zet_rep[where g="\<lambda> x. x",OF Rep_zet, simplified])

lemma zexplode_zimplode: "zexplode (zimplode A) = A"
  apply (simp add: zimplode_def zexplode_def)
  apply (simp add: implode_def)
  apply (subst f_inv_into_f[where y="Rep_zet A"])
  apply (auto simp add: Rep_zet_inverse Rep_zet_eq_explode image_def)
  done

lemma explode_mem_zet: "explode z \<in> zet"
  apply (simp add: zet_def')
  apply (rule_tac x="% x. x" in exI)
  apply (auto simp add: inj_on_def)
  done

lemma zimplode_zexplode: "zimplode (zexplode z) = z"
  apply (simp add: zimplode_def zexplode_def)
  apply (subst Abs_zet_inverse)
  apply (auto simp add: explode_mem_zet)
  done

lemma zin_zexplode_eq: "zin x (zexplode A) = Elem x A"
  apply (simp add: zin_def zexplode_def)
  apply (subst Abs_zet_inverse)
  apply (simp_all add: explode_Elem explode_mem_zet)
  done

lemma comp_zimage_eq: "zimage g (zimage f A) = zimage (g o f) A"
  apply (simp add: zimage_def)
  apply (subst Abs_zet_inverse)
  apply (simp_all add: image_comp zet_image_mem Rep_zet)
  done

definition zunion :: "'a zet \<Rightarrow> 'a zet \<Rightarrow> 'a zet" where
  "zunion a b \<equiv> Abs_zet ((Rep_zet a) \<union> (Rep_zet b))"

definition zsubset :: "'a zet \<Rightarrow> 'a zet \<Rightarrow> bool" where
  "zsubset a b \<equiv> \<forall>x. zin x a \<longrightarrow> zin x b"

lemma explode_union: "explode (union a b) = (explode a) \<union> (explode b)"
  apply (rule set_eqI)
  apply (simp add: explode_def union)
  done

lemma Rep_zet_zunion: "Rep_zet (zunion a b) = (Rep_zet a) \<union> (Rep_zet b)"
proof -
  from Rep_zet[of a] have "\<exists>f z. inj_on f (Rep_zet a) \<and> f ` (Rep_zet a) = explode z"
    by (auto simp add: zet_def')
  then obtain fa za where a:"inj_on fa (Rep_zet a) \<and> fa ` (Rep_zet a) = explode za"
    by blast
  from a have fa: "inj_on fa (Rep_zet a)" by blast
  from a have za: "fa ` (Rep_zet a) = explode za" by blast
  from Rep_zet[of b] have "\<exists>f z. inj_on f (Rep_zet b) \<and> f ` (Rep_zet b) = explode z"
    by (auto simp add: zet_def')
  then obtain fb zb where b:"inj_on fb (Rep_zet b) \<and> fb ` (Rep_zet b) = explode zb"
    by blast
  from b have fb: "inj_on fb (Rep_zet b)" by blast
  from b have zb: "fb ` (Rep_zet b) = explode zb" by blast
  let ?f = "(\<lambda> x. if x \<in> (Rep_zet a) then Opair (fa x) (Empty) else Opair (fb x) (Singleton Empty))"
  let ?z = "CartProd (union za zb) (Upair Empty (Singleton Empty))"
  have se: "Singleton Empty \<noteq> Empty"
    apply (auto simp add: Ext Singleton)
    apply (rule exI[where x=Empty])
    apply (simp add: Empty)
    done
  show ?thesis
    apply (simp add: zunion_def)
    apply (subst Abs_zet_inverse)
    apply (auto simp add: zet_def)
    apply (rule exI[where x = ?f])
    apply (rule conjI)
    apply (auto simp add: inj_on_def Opair inj_onD[OF fa] inj_onD[OF fb] se se[symmetric])
    apply (rule exI[where x = ?z])
    apply (insert za zb)
    apply (auto simp add: explode_def CartProd union Upair Opair)
    done
qed

lemma zunion: "zin x (zunion a b) = ((zin x a) \<or> (zin x b))"
  by (auto simp add: zin_def Rep_zet_zunion)

lemma zimage_zexplode_eq: "zimage f (zexplode z) = zexplode (Repl z f)"
  by (simp add: zet_ext_eq zin_zexplode_eq Repl zimage_iff)

lemma range_explode_eq_zet: "range explode = zet"
  apply (rule set_eqI)
  apply (auto simp add: explode_mem_zet)
  apply (drule image_zet_rep)
  apply (simp add: image_def)
  apply auto
  apply (rule_tac x=z in exI)
  apply auto
  done

lemma Elem_zimplode: "(Elem x (zimplode z)) = (zin x z)"
  apply (simp add: zimplode_def)
  apply (subst Elem_implode)
  apply (simp_all add: zin_def Rep_zet range_explode_eq_zet)
  done

definition zempty :: "'a zet" where
  "zempty \<equiv> Abs_zet {}"

lemma zempty[simp]: "\<not> (zin x zempty)"
  by (auto simp add: zin_def zempty_def Abs_zet_inverse zet_def)

lemma zimage_zempty[simp]: "zimage f zempty = zempty"
  by (auto simp add: zet_ext_eq zimage_iff)

lemma zunion_zempty_left[simp]: "zunion zempty a = a"
  by (simp add: zet_ext_eq zunion)

lemma zunion_zempty_right[simp]: "zunion a zempty = a"
  by (simp add: zet_ext_eq zunion)

lemma zimage_id[simp]: "zimage id A = A"
  by (simp add: zet_ext_eq zimage_iff)

lemma zimage_cong[fundef_cong]: "\<lbrakk> M = N; !! x. zin x N \<Longrightarrow> f x = g x \<rbrakk> \<Longrightarrow> zimage f M = zimage g N"
  by (auto simp add: zet_ext_eq zimage_iff)

end