(*  Title:      HOL/Library/Quotient_Set.thy
    Author:     Cezary Kaliszyk and Christian Urban
*)

section \<open>Quotient infrastructure for the set type\<close>

theory Quotient_Set
imports Quotient_Syntax
begin

subsection \<open>Contravariant set map (vimage) and set relator, rules for the Quotient package\<close>

definition "rel_vset R xs ys \<equiv> \<forall>x y. R x y \<longrightarrow> x \<in> xs \<longleftrightarrow> y \<in> ys"

lemma rel_vset_eq [id_simps]:
  "rel_vset (=) = (=)"
  by (subst fun_eq_iff, subst fun_eq_iff) (simp add: set_eq_iff rel_vset_def)

lemma rel_vset_equivp:
  assumes e: "equivp R"
  shows "rel_vset R xs ys \<longleftrightarrow> xs = ys \<and> (\<forall>x y. x \<in> xs \<longrightarrow> R x y \<longrightarrow> y \<in> xs)"
  unfolding rel_vset_def
  using equivp_reflp[OF e]
  by auto (metis, metis equivp_symp[OF e])

lemma set_quotient [quot_thm]:
  assumes "Quotient3 R Abs Rep"
  shows "Quotient3 (rel_vset R) (vimage Rep) (vimage Abs)"
proof (rule Quotient3I)
  from assms have "\<And>x. Abs (Rep x) = x" by (rule Quotient3_abs_rep)
  then show "\<And>xs. Rep -` (Abs -` xs) = xs"
    unfolding vimage_def by auto
next
  show "\<And>xs. rel_vset R (Abs -` xs) (Abs -` xs)"
    unfolding rel_vset_def vimage_def
    by auto (metis Quotient3_rel_abs[OF assms])+
next
  fix r s
  show "rel_vset R r s = (rel_vset R r r \<and> rel_vset R s s \<and> Rep -` r = Rep -` s)"
    unfolding rel_vset_def vimage_def set_eq_iff
    by auto (metis rep_abs_rsp[OF assms] assms[simplified Quotient3_def])+
qed

declare [[mapQ3 set = (rel_vset, set_quotient)]]

lemma empty_set_rsp[quot_respect]:
  "rel_vset R {} {}"
  unfolding rel_vset_def by simp

lemma collect_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "((R ===> (=)) ===> rel_vset R) Collect Collect"
  by (intro rel_funI) (simp add: rel_fun_def rel_vset_def)

lemma collect_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "((Abs ---> id) ---> (-`) Rep) Collect = Collect"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF assms])

lemma union_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "(rel_vset R ===> rel_vset R ===> rel_vset R) (\<union>) (\<union>)"
  by (intro rel_funI) (simp add: rel_vset_def)

lemma union_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "((-`) Abs ---> (-`) Abs ---> (-`) Rep) (\<union>) = (\<union>)"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF set_quotient[OF assms]])

lemma diff_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "(rel_vset R ===> rel_vset R ===> rel_vset R) (-) (-)"
  by (intro rel_funI) (simp add: rel_vset_def)

lemma diff_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "((-`) Abs ---> (-`) Abs ---> (-`) Rep) (-) = (-)"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF set_quotient[OF assms]] vimage_Diff)

lemma inter_rsp[quot_respect]:
  assumes "Quotient3 R Abs Rep"
  shows "(rel_vset R ===> rel_vset R ===> rel_vset R) (\<inter>) (\<inter>)"
  by (intro rel_funI) (auto simp add: rel_vset_def)

lemma inter_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "((-`) Abs ---> (-`) Abs ---> (-`) Rep) (\<inter>) = (\<inter>)"
  unfolding fun_eq_iff
  by (simp add: Quotient3_abs_rep[OF set_quotient[OF assms]])

lemma mem_prs[quot_preserve]:
  assumes "Quotient3 R Abs Rep"
  shows "(Rep ---> (-`) Abs ---> id) (\<in>) = (\<in>)"
  by (simp add: fun_eq_iff Quotient3_abs_rep[OF assms])

lemma mem_rsp[quot_respect]:
  shows "(R ===> rel_vset R ===> (=)) (\<in>) (\<in>)"
  by (intro rel_funI) (simp add: rel_vset_def)

end


theory Nielson_Sqrt
imports Nielson_VCGi "HOL-Library.Discrete"
begin

subsection \<open>Example: discrete square root in Nielson's logic\<close>

text \<open>As an example, consider the following program that computes the discrete square root:\<close>

definition c :: com where "c=
         ''l''::= N 0 ;;
         ''m'' ::= N 0 ;;
         ''r''::= Plus (N 1) (V ''x'');;
         (WHILE (Less (Plus (N 1) (V ''l'')) (V ''r''))
              DO (''m'' ::= (Div (Plus (V ''l'') (V ''r'')) (N 2)) ;;
                 (IF Not (Less (Times (V ''m'') (V ''m'')) (V ''x''))
                    THEN ''l'' ::= V ''m''
                    ELSE ''r'' ::= V ''m'');;
                 ''m'' ::= N 0))"

text \<open>In this theory we will show that its running time is in the order of magnitude of the
      logarithm of the variable ''x''\<close>

text \<open>a little lemma we need later for bounding the running time:\<close>

lemma absch: "\<And>s k. 1 + s ''x'' = 2 ^ k \<Longrightarrow> 5 * k \<le> 96 + 100 * Discrete.log (nat (s ''x''))"
proof -
  fix s :: state and  k :: nat
  assume F: " 1 + s ''x'' = 2 ^ k "
  then have i: "nat (1 + s ''x'') =  2 ^ k" and nn: "s ''x''\<ge> 0"  apply (auto simp: nat_power_eq)
    by (smt one_le_power)
  have F: "1 + nat (s ''x'') = 2 ^k" unfolding i[symmetric] using nn by auto
  show "5 * k \<le> 96 + 100 * Discrete.log (nat (s ''x''))"
  proof (cases "s ''x'' \<ge> 1")
    case True
    have "5 * k = 5 * (Discrete.log (2^k))"     by auto
    also have "\<dots> = 5 * Discrete.log (1 + nat (s ''x''))" by(simp only: F[symmetric])
    also have "\<dots> \<le> 5 * Discrete.log (nat (s ''x'' + s ''x''))" using True
      apply auto apply(rule monoD[OF log_mono]) by auto
    also have "\<dots> = 5 *  Discrete.log (2 * nat (s ''x''))" by (auto simp: nat_mult_distrib)
    also have "\<dots> = 5 + 5 * (Discrete.log (nat (s ''x'')))" using True by auto
    also have "\<dots> \<le> 96 + 100 * Discrete.log (nat (s ''x''))" by simp
    finally show ?thesis .
  next
    case False
    with nn have gt1: "s ''x'' = 0" by auto
    from F[unfolded gt1] have "2 ^ k = (1::int)" using log_Suc_zero by auto
    then have "k=0"
      by (metis One_nat_def add.right_neutral gt1 i n_not_Suc_n nat_numeral nat_power_eq_Suc_0_iff numeral_2_eq_2 numeral_One)
    then show ?thesis by(simp add: gt1)
  qed
qed

text \<open>For simplicity we assume, that during the process all segments between ''l'' and ''r'' have
      as length a power of two. This simplifies the analysis.
      To obtain this we choose the precondition P accordingly.

      Now lets show the correctness of our time complexity: the binary search is in O(log ''x'') \<close>

lemma
  assumes P: "P  = (\<lambda>l s.  (\<exists>k. 1 + s ''x''  = 2 ^ k) )"
      and e : "e  = (\<lambda>s. Discrete.log (nat (s ''x'')) + 1)" and
      Q[simp]: "Q = (\<lambda>l s. True)"
  shows " \<turnstile>\<^sub>1 {P} c { e \<Down> Q}"
proof -

  \<comment> \<open>first we create an annotated command\<close>
  let ?lb = "''m'' ::=
              (Div (Plus (V ''l'') (V ''r'')) (N 2)) ;;
              (IF Not (Less (Times (V ''m'') (V ''m'')) (V ''x''))
                THEN ''l'' ::= V ''m''
                ELSE ''r'' ::= V ''m'');;
              (''m'' ::= N 0)::acom"
  \<comment> \<open>with an Invariant\<close>
  define I :: assn2 where "I \<equiv> (\<lambda>l s. (\<exists>k. s ''r'' - s ''l'' = 2 ^ k ) \<and> s ''l'' \<ge> 0 )"

  \<comment> \<open>and an time bound annotation for the loop\<close>
  define E :: tbd where "E \<equiv> %s. 1 + 5 * Discrete.log (nat(s ''r'' - s ''l''))"
  define S :: "state \<Rightarrow> state" where "S \<equiv> %s. s"
  define Es :: "vname \<Rightarrow> vname set" where "Es  = (%x. {x})"

  define R :: "(assn2*(vname set))*((state\<Rightarrow>state)*(tbd*((vname set*(vname \<Rightarrow> vname set)))))"
      where "R=((I,{''l'',''r''}),(S,(E,({''l'',''r''},Es))))"

  let ?C = "''l''::= N 0 ;; (''m'' ::= N 0) ;; ''r''::= Plus (N 1) (V ''x'');; ({R} WHILE (Less (Plus (N 1) (V ''l'')) (V ''r'')) DO ?lb)"

  \<comment> \<open>we show that the annotated command corresponds to the command we are interested in\<close>
  have s: "strip ?C = c" unfolding c_def by auto

  \<comment> \<open>now we show that the annotated command is correct; here we use the improved VCG and the
      Nielson\<close>
  have v: "\<turnstile>\<^sub>1 {P} strip ?C {e  \<Down> Q}"
  proof (rule vc_sound'', safe)

    \<comment> \<open>A) first lets show the verification conditions:\<close>
    show "vc ?C Q {} {}"  unfolding R_def apply (simp only: vc.simps) apply auto
      subgoal unfolding I_def by auto
      subgoal unfolding I_def by auto
      subgoal unfolding E_def by auto
    proof (goal_cases)
      fix s::state and l
      assume  I: "I l s" and 2: "1 + s ''l'' < s ''r''"
      from I obtain k :: nat where 3: "s ''r'' - s ''l'' = 2 ^ k" and 4: "s ''l'' \<ge> 0" unfolding I_def by blast
      from 3 2 have "k>0" using gr0I by force
      then obtain k' where k': "k=k'+1" by (metis Suc_eq_plus1 Suc_pred)

      from 3 k' have R1: " s ''r'' - (s ''l'' + s ''r'') div 2 = 2 ^ k'" and
          R2: "(s ''l'' + s ''r'') div 2 - s ''l'' = 2 ^ k'" by auto
      then have E1: "\<exists>k. s ''r'' - (s ''l'' + s ''r'') div 2 = 2 ^ k" and
          E2: "\<exists>k. (s ''l'' + s ''r'') div 2 - s ''l'' = 2 ^ k" by auto
      then show "I l (s(''l'' := (s ''l'' + s ''r'') div 2, ''m'' := 0))" and
          "I l (s(''r'' := (s ''l'' + s ''r'') div 2, ''m'' := 0))" using 2 4 unfolding I_def by auto

      show "Suc (Suc (Suc (Suc (Suc (E (s(''l'' := (s ''l'' + s ''r'') div 2, ''m'' := 0))))))) \<le> E s"
        unfolding E_def apply simp unfolding R1 3 k' by (auto  simp: nat_power_eq nat_mult_distrib)
      show "Suc (Suc (Suc (Suc (Suc (E (s(''r'' := (s ''l'' + s ''r'') div 2, ''m'' := 0))))))) \<le> E s"
        unfolding E_def apply simp unfolding R2 3 k' by (auto  simp: nat_power_eq nat_mult_distrib)
    next
      fix l s
      show "Suc 0 \<le> E s" unfolding E_def by auto
      show "Suc 0 \<le> E s" unfolding E_def by auto
    qed
  next
    \<comment> \<open>B) lets show that the precondition implies the weakest precondition, and that the
            time bound of C can be bounded by log ''x''\<close>
    fix s
    show "(\<exists>k>0. \<forall>l s. P l s \<longrightarrow> pre ?C Q l s \<and> time ?C s \<le> k * e s)"
      apply(rule exI[where x=100])
      unfolding P R_def I_def E_def e by (auto simp: nat_power_eq absch)
  qed
    \<comment> \<open>last side conditions are proven automatically\<close>
    (auto simp: Q support_inv R_def I_def)

  \<comment> \<open>now we conclude with the correctness of the Hoare triple involving the time bound\<close>
  from s v show ?thesis by simp
qed

end


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

section \<open>Polynomials, fractions and rings\<close>

theory Polynomial_Factorial
imports
  Complex_Main
  Polynomial
  Normalized_Fraction
begin

subsection \<open>Lifting elements into the field of fractions\<close>

definition to_fract :: "'a :: idom \<Rightarrow> 'a fract"
  where "to_fract x = Fract x 1"
  \<comment> \<open>FIXME: more idiomatic name, abbreviation\<close>

lemma to_fract_0 [simp]: "to_fract 0 = 0"
  by (simp add: to_fract_def eq_fract Zero_fract_def)

lemma to_fract_1 [simp]: "to_fract 1 = 1"
  by (simp add: to_fract_def eq_fract One_fract_def)

lemma to_fract_add [simp]: "to_fract (x + y) = to_fract x + to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_diff [simp]: "to_fract (x - y) = to_fract x - to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_uminus [simp]: "to_fract (-x) = -to_fract x"
  by (simp add: to_fract_def)

lemma to_fract_mult [simp]: "to_fract (x * y) = to_fract x * to_fract y"
  by (simp add: to_fract_def)

lemma to_fract_eq_iff [simp]: "to_fract x = to_fract y \<longleftrightarrow> x = y"
  by (simp add: to_fract_def eq_fract)

lemma to_fract_eq_0_iff [simp]: "to_fract x = 0 \<longleftrightarrow> x = 0"
  by (simp add: to_fract_def Zero_fract_def eq_fract)

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 to_fract_quot_of_fract:
  assumes "snd (quot_of_fract x) = 1"
  shows   "to_fract (fst (quot_of_fract x)) = x"
proof -
  have "x = Fract (fst (quot_of_fract x)) (snd (quot_of_fract x))" by simp
  also note assms
  finally show ?thesis by (simp add: to_fract_def)
qed

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 Fract_conv_to_fract: "Fract a b = to_fract a / to_fract b"
  by (simp add: to_fract_def)

lemma quot_of_fract_to_fract [simp]: "quot_of_fract (to_fract x) = (x, 1)"
  unfolding to_fract_def by transfer (simp add: normalize_quot_def)

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

lemma snd_quot_of_fract_to_fract [simp]: "snd (quot_of_fract (to_fract x)) = 1"
  unfolding to_fract_def by (rule snd_quot_of_fract_Fract_whole) simp_all

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 unit_factor_1_imp_normalized: "unit_factor x = 1 \<Longrightarrow> normalize x = x"
  by (subst (2) normalize_mult_unit_factor [symmetric, of x])
     (simp del: normalize_mult_unit_factor)

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)

subsection \<open>Lifting polynomial coefficients to the field of fractions\<close>

abbreviation (input) fract_poly
  where "fract_poly \<equiv> map_poly to_fract"

abbreviation (input) unfract_poly
  where "unfract_poly \<equiv> map_poly (fst \<circ> quot_of_fract)"

lemma fract_poly_smult [simp]: "fract_poly (smult c p) = smult (to_fract c) (fract_poly p)"
  by (simp add: smult_conv_map_poly map_poly_map_poly o_def)

lemma fract_poly_0 [simp]: "fract_poly 0 = 0"
  by (simp add: poly_eqI coeff_map_poly)

lemma fract_poly_1 [simp]: "fract_poly 1 = 1"
  by (simp add: map_poly_pCons)

lemma fract_poly_add [simp]:
  "fract_poly (p + q) = fract_poly p + fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma fract_poly_diff [simp]:
  "fract_poly (p - q) = fract_poly p - fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly)

lemma to_fract_sum [simp]: "to_fract (sum f A) = sum (\<lambda>x. to_fract (f x)) A"
  by (cases "finite A", induction A rule: finite_induct) simp_all

lemma fract_poly_mult [simp]:
  "fract_poly (p * q) = fract_poly p * fract_poly q"
  by (intro poly_eqI) (simp_all add: coeff_map_poly coeff_mult)

lemma fract_poly_eq_iff [simp]: "fract_poly p = fract_poly q \<longleftrightarrow> p = q"
  by (auto simp: poly_eq_iff coeff_map_poly)

lemma fract_poly_eq_0_iff [simp]: "fract_poly p = 0 \<longleftrightarrow> p = 0"
  using fract_poly_eq_iff[of p 0] by (simp del: fract_poly_eq_iff)

lemma fract_poly_dvd: "p dvd q \<Longrightarrow> fract_poly p dvd fract_poly q"
  by (auto elim!: dvdE)

lemma prod_mset_fract_poly:
  "(\<Prod>x\<in>#A. map_poly to_fract (f x)) = fract_poly (prod_mset (image_mset f A))"
  by (induct A) (simp_all add: ac_simps)

lemma is_unit_fract_poly_iff:
  "p dvd 1 \<longleftrightarrow> fract_poly p dvd 1 \<and> content p = 1"
proof safe
  assume A: "p dvd 1"
  with fract_poly_dvd [of p 1] show "is_unit (fract_poly p)"
    by simp
  from A show "content p = 1"
    by (auto simp: is_unit_poly_iff normalize_1_iff)
next
  assume A: "fract_poly p dvd 1" and B: "content p = 1"
  from A obtain c where c: "fract_poly p = [:c:]" by (auto simp: is_unit_poly_iff)
  {
    fix n :: nat assume "n > 0"
    have "to_fract (coeff p n) = coeff (fract_poly p) n" by (simp add: coeff_map_poly)
    also note c
    also from \<open>n > 0\<close> have "coeff [:c:] n = 0" by (simp add: coeff_pCons split: nat.splits)
    finally have "coeff p n = 0" by simp
  }
  hence "degree p \<le> 0" by (intro degree_le) simp_all
  with B show "p dvd 1" by (auto simp: is_unit_poly_iff normalize_1_iff elim!: degree_eq_zeroE)
qed

lemma fract_poly_is_unit: "p dvd 1 \<Longrightarrow> fract_poly p dvd 1"
  using fract_poly_dvd[of p 1] by simp

lemma fract_poly_smult_eqE:
  fixes c :: "'a :: {idom_divide,ring_gcd,semiring_gcd_mult_normalize} fract"
  assumes "fract_poly p = smult c (fract_poly q)"
  obtains a b
    where "c = to_fract b / to_fract a" "smult a p = smult b q" "coprime a b" "normalize a = a"
proof -
  define a b where "a = fst (quot_of_fract c)" and "b = snd (quot_of_fract c)"
  have "smult (to_fract a) (fract_poly q) = smult (to_fract b) (fract_poly p)"
    by (subst smult_eq_iff) (simp_all add: a_def b_def Fract_conv_to_fract [symmetric] assms)
  hence "fract_poly (smult a q) = fract_poly (smult b p)" by (simp del: fract_poly_eq_iff)
  hence "smult b p = smult a q" by (simp only: fract_poly_eq_iff)
  moreover have "c = to_fract a / to_fract b" "coprime b a" "normalize b = b"
    by (simp_all add: a_def b_def coprime_quot_of_fract [of c] ac_simps
          normalize_snd_quot_of_fract Fract_conv_to_fract [symmetric])
  ultimately show ?thesis by (intro that[of a b])
qed

subsection \<open>Fractional content\<close>

abbreviation (input) Lcm_coeff_denoms
    :: "'a :: {semiring_Gcd,idom_divide,ring_gcd,semiring_gcd_mult_normalize} fract poly \<Rightarrow> 'a"
  where "Lcm_coeff_denoms p \<equiv> Lcm (snd ` quot_of_fract ` set (coeffs p))"

definition fract_content ::
      "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} fract poly \<Rightarrow> 'a fract" where
  "fract_content p =
     (let d = Lcm_coeff_denoms p in Fract (content (unfract_poly (smult (to_fract d) p))) d)"

definition primitive_part_fract ::
      "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} fract poly \<Rightarrow> 'a poly" where
  "primitive_part_fract p =
     primitive_part (unfract_poly (smult (to_fract (Lcm_coeff_denoms p)) p))"

lemma primitive_part_fract_0 [simp]: "primitive_part_fract 0 = 0"
  by (simp add: primitive_part_fract_def)

lemma fract_content_eq_0_iff [simp]:
  "fract_content p = 0 \<longleftrightarrow> p = 0"
  unfolding fract_content_def Let_def Zero_fract_def
  by (subst eq_fract) (auto simp: Lcm_0_iff map_poly_eq_0_iff)

lemma content_primitive_part_fract [simp]:
  fixes p :: "'a :: {semiring_gcd_mult_normalize,
                     factorial_semiring, ring_gcd, semiring_Gcd,idom_divide} fract poly"
  shows "p \<noteq> 0 \<Longrightarrow> content (primitive_part_fract p) = 1"
  unfolding primitive_part_fract_def
  by (rule content_primitive_part)
     (auto simp: primitive_part_fract_def map_poly_eq_0_iff Lcm_0_iff)

lemma content_times_primitive_part_fract:
  "smult (fract_content p) (fract_poly (primitive_part_fract p)) = p"
proof -
  define p' where "p' = unfract_poly (smult (to_fract (Lcm_coeff_denoms p)) p)"
  have "fract_poly p' =
          map_poly (to_fract \<circ> fst \<circ> quot_of_fract) (smult (to_fract (Lcm_coeff_denoms p)) p)"
    unfolding primitive_part_fract_def p'_def
    by (subst map_poly_map_poly) (simp_all add: o_assoc)
  also have "\<dots> = smult (to_fract (Lcm_coeff_denoms p)) p"
  proof (intro map_poly_idI, unfold o_apply)
    fix c assume "c \<in> set (coeffs (smult (to_fract (Lcm_coeff_denoms p)) p))"
    then obtain c' where c: "c' \<in> set (coeffs p)" "c = to_fract (Lcm_coeff_denoms p) * c'"
      by (auto simp add: Lcm_0_iff coeffs_smult split: if_splits)
    note c(2)
    also have "c' = Fract (fst (quot_of_fract c')) (snd (quot_of_fract c'))"
      by simp
    also have "to_fract (Lcm_coeff_denoms p) * \<dots> =
                 Fract (Lcm_coeff_denoms p * fst (quot_of_fract c')) (snd (quot_of_fract c'))"
      unfolding to_fract_def by (subst mult_fract) simp_all
    also have "snd (quot_of_fract \<dots>) = 1"
      by (intro snd_quot_of_fract_Fract_whole dvd_mult2 dvd_Lcm) (insert c(1), auto)
    finally show "to_fract (fst (quot_of_fract c)) = c"
      by (rule to_fract_quot_of_fract)
  qed
  also have "p' = smult (content p') (primitive_part p')"
    by (rule content_times_primitive_part [symmetric])
  also have "primitive_part p' = primitive_part_fract p"
    by (simp add: primitive_part_fract_def p'_def)
  also have "fract_poly (smult (content p') (primitive_part_fract p)) =
               smult (to_fract (content p')) (fract_poly (primitive_part_fract p))" by simp
  finally have "smult (to_fract (content p')) (fract_poly (primitive_part_fract p)) =
                      smult (to_fract (Lcm_coeff_denoms p)) p" .
  thus ?thesis
    by (subst (asm) smult_eq_iff)
       (auto simp add: Let_def p'_def Fract_conv_to_fract field_simps Lcm_0_iff fract_content_def)
qed

lemma fract_content_fract_poly [simp]: "fract_content (fract_poly p) = to_fract (content p)"
proof -
  have "Lcm_coeff_denoms (fract_poly p) = 1"
    by (auto simp: set_coeffs_map_poly)
  hence "fract_content (fract_poly p) =
           to_fract (content (map_poly (fst \<circ> quot_of_fract \<circ> to_fract) p))"
    by (simp add: fract_content_def to_fract_def fract_collapse map_poly_map_poly del: Lcm_1_iff)
  also have "map_poly (fst \<circ> quot_of_fract \<circ> to_fract) p = p"
    by (intro map_poly_idI) simp_all
  finally show ?thesis .
qed

lemma content_decompose_fract:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,
                     semiring_gcd_mult_normalize} fract poly"
  obtains c p' where "p = smult c (map_poly to_fract p')" "content p' = 1"
proof (cases "p = 0")
  case True
  hence "p = smult 0 (map_poly to_fract 1)" "content 1 = 1" by simp_all
  thus ?thesis ..
next
  case False
  thus ?thesis
    by (rule that[OF content_times_primitive_part_fract [symmetric] content_primitive_part_fract])
qed

subsection \<open>More properties of content and primitive part\<close>

lemma lift_prime_elem_poly:
  assumes "prime_elem (c :: 'a :: semidom)"
  shows   "prime_elem [:c:]"
proof (rule prime_elemI)
  fix a b assume *: "[:c:] dvd a * b"
  from * have dvd: "c dvd coeff (a * b) n" for n
    by (subst (asm) const_poly_dvd_iff) blast
  {
    define m where "m = (GREATEST m. \<not>c dvd coeff b m)"
    assume "\<not>[:c:] dvd b"
    hence A: "\<exists>i. \<not>c dvd coeff b i" by (subst (asm) const_poly_dvd_iff) blast
    have B: "\<And>i. \<not>c dvd coeff b i \<Longrightarrow> i \<le> degree b"
      by (auto intro: le_degree)
    have coeff_m: "\<not>c dvd coeff b m" unfolding m_def by (rule GreatestI_ex_nat[OF A B])
    have "i \<le> m" if "\<not>c dvd coeff b i" for i
      unfolding m_def by (blast intro!: Greatest_le_nat that B)
    hence dvd_b: "c dvd coeff b i" if "i > m" for i using that by force

    have "c dvd coeff a i" for i
    proof (induction i rule: nat_descend_induct[of "degree a"])
      case (base i)
      thus ?case by (simp add: coeff_eq_0)
    next
      case (descend i)
      let ?A = "{..i+m} - {i}"
      have "c dvd coeff (a * b) (i + m)" by (rule dvd)
      also have "coeff (a * b) (i + m) = (\<Sum>k\<le>i + m. coeff a k * coeff b (i + m - k))"
        by (simp add: coeff_mult)
      also have "{..i+m} = insert i ?A" by auto
      also have "(\<Sum>k\<in>\<dots>. coeff a k * coeff b (i + m - k)) =
                   coeff a i * coeff b m + (\<Sum>k\<in>?A. coeff a k * coeff b (i + m - k))"
        (is "_ = _ + ?S")
        by (subst sum.insert) simp_all
      finally have eq: "c dvd coeff a i * coeff b m + ?S" .
      moreover have "c dvd ?S"
      proof (rule dvd_sum)
        fix k assume k: "k \<in> {..i+m} - {i}"
        show "c dvd coeff a k * coeff b (i + m - k)"
        proof (cases "k < i")
          case False
          with k have "c dvd coeff a k" by (intro descend.IH) simp
          thus ?thesis by simp
        next
          case True
          hence "c dvd coeff b (i + m - k)" by (intro dvd_b) simp
          thus ?thesis by simp
        qed
      qed
      ultimately have "c dvd coeff a i * coeff b m"
        by (simp add: dvd_add_left_iff)
      with assms coeff_m show "c dvd coeff a i"
        by (simp add: prime_elem_dvd_mult_iff)
    qed
    hence "[:c:] dvd a" by (subst const_poly_dvd_iff) blast
  }
  then show "[:c:] dvd a \<or> [:c:] dvd b" by blast
next
  from assms show "[:c:] \<noteq> 0" and "\<not> [:c:] dvd 1"
    by (simp_all add: prime_elem_def is_unit_const_poly_iff)
qed

lemma prime_elem_const_poly_iff:
  fixes c :: "'a :: semidom"
  shows   "prime_elem [:c:] \<longleftrightarrow> prime_elem c"
proof
  assume A: "prime_elem [:c:]"
  show "prime_elem c"
  proof (rule prime_elemI)
    fix a b assume "c dvd a * b"
    hence "[:c:] dvd [:a:] * [:b:]" by (simp add: mult_ac)
    from A and this have "[:c:] dvd [:a:] \<or> [:c:] dvd [:b:]" by (rule prime_elem_dvd_multD)
    thus "c dvd a \<or> c dvd b" by simp
  qed (insert A, auto simp: prime_elem_def is_unit_poly_iff)
qed (auto intro: lift_prime_elem_poly)

lemma fract_poly_dvdD:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,
                     semiring_gcd_mult_normalize} poly"
  assumes "fract_poly p dvd fract_poly q" "content p = 1"
  shows   "p dvd q"
proof -
  from assms(1) obtain r where r: "fract_poly q = fract_poly p * r" by (erule dvdE)
  from content_decompose_fract[of r] guess c r' . note r' = this
  from r r' have eq: "fract_poly q = smult c (fract_poly (p * r'))" by simp
  from fract_poly_smult_eqE[OF this] guess a b . note ab = this
  have "content (smult a q) = content (smult b (p * r'))" by (simp only: ab(2))
  hence eq': "normalize b = a * content q" by (simp add: assms content_mult r' ab(4))
  have "1 = gcd a (normalize b)" by (simp add: ab)
  also note eq'
  also have "gcd a (a * content q) = a" by (simp add: gcd_proj1_if_dvd ab(4))
  finally have [simp]: "a = 1" by simp
  from eq ab have "q = p * ([:b:] * r')" by simp
  thus ?thesis by (rule dvdI)
qed

subsection \<open>Polynomials over a field are a Euclidean ring\<close>

context
begin

interpretation field_poly:
  normalization_euclidean_semiring_multiplicative where zero = "0 :: 'a :: field poly"
    and one = 1 and plus = plus and minus = minus
    and times = times
    and normalize = "\<lambda>p. smult (inverse (lead_coeff p)) p"
    and unit_factor = "\<lambda>p. [:lead_coeff p:]"
    and euclidean_size = "\<lambda>p. if p = 0 then 0 else 2 ^ degree p"
    and divide = divide and modulo = modulo
  rewrites "dvd.dvd (times :: 'a poly \<Rightarrow> _) = Rings.dvd"
    and "comm_monoid_mult.prod_mset times 1 = prod_mset"
    and "comm_semiring_1.irreducible times 1 0 = irreducible"
    and "comm_semiring_1.prime_elem times 1 0 = prime_elem"
proof -
  show "dvd.dvd (times :: 'a poly \<Rightarrow> _) = Rings.dvd"
    by (simp add: dvd_dict)
  show "comm_monoid_mult.prod_mset times 1 = prod_mset"
    by (simp add: prod_mset_dict)
  show "comm_semiring_1.irreducible times 1 0 = irreducible"
    by (simp add: irreducible_dict)
  show "comm_semiring_1.prime_elem times 1 0 = prime_elem"
    by (simp add: prime_elem_dict)
  show "class.normalization_euclidean_semiring_multiplicative divide plus minus (0 :: 'a poly) times 1
    modulo (\<lambda>p. if p = 0 then 0 else 2 ^ degree p)
    (\<lambda>p. [:lead_coeff p:]) (\<lambda>p. smult (inverse (lead_coeff p)) p)"
  proof (standard, fold dvd_dict)
    fix p :: "'a poly"
    show "[:lead_coeff p:] * smult (inverse (lead_coeff p)) p = p"
      by (cases "p = 0") simp_all
  next
    fix p :: "'a poly" assume "is_unit p"
    then show "[:lead_coeff p:] = p"
      by (elim is_unit_polyE) (auto simp: monom_0 one_poly_def field_simps)
  next
    fix p :: "'a poly" assume "p \<noteq> 0"
    then show "is_unit [:lead_coeff p:]"
      by (simp add: is_unit_pCons_iff)
  next
    fix a b :: "'a poly" assume "is_unit a"
    thus "[:lead_coeff (a * b):] = a * [:lead_coeff b:]"
      by (auto elim!: is_unit_polyE)
  qed (auto simp: lead_coeff_mult Rings.div_mult_mod_eq intro!: degree_mod_less' degree_mult_right_le)
qed

lemma field_poly_irreducible_imp_prime:
  "prime_elem p" if "irreducible p" for p :: "'a :: field poly"
  using that by (fact field_poly.irreducible_imp_prime_elem)
find_theorems name:prod_mset_prime_factorization
lemma field_poly_prod_mset_prime_factorization:
  "prod_mset (field_poly.prime_factorization p) = smult (inverse (lead_coeff p)) p"
  if "p \<noteq> 0" for p :: "'a :: field poly"
  using that by (fact field_poly.prod_mset_prime_factorization)

lemma field_poly_in_prime_factorization_imp_prime:
  "prime_elem p" if "p \<in># field_poly.prime_factorization x"
  for p :: "'a :: field poly"
  by (rule field_poly.prime_imp_prime_elem, rule field_poly.in_prime_factors_imp_prime)
    (fact that)

subsection \<open>Primality and irreducibility in polynomial rings\<close>

lemma nonconst_poly_irreducible_iff:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "degree p \<noteq> 0"
  shows   "irreducible p \<longleftrightarrow> irreducible (fract_poly p) \<and> content p = 1"
proof safe
  assume p: "irreducible p"

  from content_decompose[of p] guess p' . note p' = this
  hence "p = [:content p:] * p'" by simp
  from p this have "[:content p:] dvd 1 \<or> p' dvd 1" by (rule irreducibleD)
  moreover have "\<not>p' dvd 1"
  proof
    assume "p' dvd 1"
    hence "degree p = 0" by (subst p') (auto simp: is_unit_poly_iff)
    with assms show False by contradiction
  qed
  ultimately show [simp]: "content p = 1" by (simp add: is_unit_const_poly_iff)

  show "irreducible (map_poly to_fract p)"
  proof (rule irreducibleI)
    have "fract_poly p = 0 \<longleftrightarrow> p = 0" by (intro map_poly_eq_0_iff) auto
    with assms show "map_poly to_fract p \<noteq> 0" by auto
  next
    show "\<not>is_unit (fract_poly p)"
    proof
      assume "is_unit (map_poly to_fract p)"
      hence "degree (map_poly to_fract p) = 0"
        by (auto simp: is_unit_poly_iff)
      hence "degree p = 0" by (simp add: degree_map_poly)
      with assms show False by contradiction
   qed
 next
   fix q r assume qr: "fract_poly p = q * r"
   from content_decompose_fract[of q] guess cg q' . note q = this
   from content_decompose_fract[of r] guess cr r' . note r = this
   from qr q r p have nz: "cg \<noteq> 0" "cr \<noteq> 0" by auto
   from qr have eq: "fract_poly p = smult (cr * cg) (fract_poly (q' * r'))"
     by (simp add: q r)
   from fract_poly_smult_eqE[OF this] guess a b . note ab = this
   hence "content (smult a p) = content (smult b (q' * r'))" by (simp only:)
   with ab(4) have a: "a = normalize b" by (simp add: content_mult q r)
   then have "normalize b = gcd a b"
     by simp
   with \<open>coprime a b\<close> have "normalize b = 1"
     by simp
   then have "a = 1" "is_unit b"
     by (simp_all add: a normalize_1_iff)

   note eq
   also from ab(1) \<open>a = 1\<close> have "cr * cg = to_fract b" by simp
   also have "smult \<dots> (fract_poly (q' * r')) = fract_poly (smult b (q' * r'))" by simp
   finally have "p = ([:b:] * q') * r'" by (simp del: fract_poly_smult)
   from p and this have "([:b:] * q') dvd 1 \<or> r' dvd 1" by (rule irreducibleD)
   hence "q' dvd 1 \<or> r' dvd 1" by (auto dest: dvd_mult_right simp del: mult_pCons_left)
   hence "fract_poly q' dvd 1 \<or> fract_poly r' dvd 1" by (auto simp: fract_poly_is_unit)
   with q r show "is_unit q \<or> is_unit r"
     by (auto simp add: is_unit_smult_iff dvd_field_iff nz)
 qed

next

  assume irred: "irreducible (fract_poly p)" and primitive: "content p = 1"
  show "irreducible p"
  proof (rule irreducibleI)
    from irred show "p \<noteq> 0" by auto
  next
    from irred show "\<not>p dvd 1"
      by (auto simp: irreducible_def dest: fract_poly_is_unit)
  next
    fix q r assume qr: "p = q * r"
    hence "fract_poly p = fract_poly q * fract_poly r" by simp
    from irred and this have "fract_poly q dvd 1 \<or> fract_poly r dvd 1"
      by (rule irreducibleD)
    with primitive qr show "q dvd 1 \<or> r dvd 1"
      by (auto simp:  content_prod_eq_1_iff is_unit_fract_poly_iff)
  qed
qed

private lemma irreducible_imp_prime_poly:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "irreducible p"
  shows   "prime_elem p"
proof (cases "degree p = 0")
  case True
  with assms show ?thesis
    by (auto simp: prime_elem_const_poly_iff irreducible_const_poly_iff
             intro!: irreducible_imp_prime_elem elim!: degree_eq_zeroE)
next
  case False
  from assms False have irred: "irreducible (fract_poly p)" and primitive: "content p = 1"
    by (simp_all add: nonconst_poly_irreducible_iff)
  from irred have prime: "prime_elem (fract_poly p)" by (rule field_poly_irreducible_imp_prime)
  show ?thesis
  proof (rule prime_elemI)
    fix q r assume "p dvd q * r"
    hence "fract_poly p dvd fract_poly (q * r)" by (rule fract_poly_dvd)
    hence "fract_poly p dvd fract_poly q * fract_poly r" by simp
    from prime and this have "fract_poly p dvd fract_poly q \<or> fract_poly p dvd fract_poly r"
      by (rule prime_elem_dvd_multD)
    with primitive show "p dvd q \<or> p dvd r" by (auto dest: fract_poly_dvdD)
  qed (insert assms, auto simp: irreducible_def)
qed

lemma degree_primitive_part_fract [simp]:
  "degree (primitive_part_fract p) = degree p"
proof -
  have "p = smult (fract_content p) (fract_poly (primitive_part_fract p))"
    by (simp add: content_times_primitive_part_fract)
  also have "degree \<dots> = degree (primitive_part_fract p)"
    by (auto simp: degree_map_poly)
  finally show ?thesis ..
qed

lemma irreducible_primitive_part_fract:
  fixes p :: "'a :: {idom_divide, ring_gcd, factorial_semiring, semiring_Gcd,semiring_gcd_mult_normalize} fract poly"
  assumes "irreducible p"
  shows   "irreducible (primitive_part_fract p)"
proof -
  from assms have deg: "degree (primitive_part_fract p) \<noteq> 0"
    by (intro notI)
       (auto elim!: degree_eq_zeroE simp: irreducible_def is_unit_poly_iff dvd_field_iff)
  hence [simp]: "p \<noteq> 0" by auto

  note \<open>irreducible p\<close>
  also have "p = [:fract_content p:] * fract_poly (primitive_part_fract p)"
    by (simp add: content_times_primitive_part_fract)
  also have "irreducible \<dots> \<longleftrightarrow> irreducible (fract_poly (primitive_part_fract p))"
    by (intro irreducible_mult_unit_left) (simp_all add: is_unit_poly_iff dvd_field_iff)
  finally show ?thesis using deg
    by (simp add: nonconst_poly_irreducible_iff)
qed

lemma prime_elem_primitive_part_fract:
  fixes p :: "'a :: {idom_divide, ring_gcd, factorial_semiring, semiring_Gcd,semiring_gcd_mult_normalize} fract poly"
  shows "irreducible p \<Longrightarrow> prime_elem (primitive_part_fract p)"
  by (intro irreducible_imp_prime_poly irreducible_primitive_part_fract)

lemma irreducible_linear_field_poly:
  fixes a b :: "'a::field"
  assumes "b \<noteq> 0"
  shows "irreducible [:a,b:]"
proof (rule irreducibleI)
  fix p q assume pq: "[:a,b:] = p * q"
  also from pq assms have "degree \<dots> = degree p + degree q"
    by (intro degree_mult_eq) auto
  finally have "degree p = 0 \<or> degree q = 0" using assms by auto
  with assms pq show "is_unit p \<or> is_unit q"
    by (auto simp: is_unit_const_poly_iff dvd_field_iff elim!: degree_eq_zeroE)
qed (insert assms, auto simp: is_unit_poly_iff)

lemma prime_elem_linear_field_poly:
  "(b :: 'a :: field) \<noteq> 0 \<Longrightarrow> prime_elem [:a,b:]"
  by (rule field_poly_irreducible_imp_prime, rule irreducible_linear_field_poly)

lemma irreducible_linear_poly:
  fixes a b :: "'a::{idom_divide,ring_gcd,factorial_semiring,semiring_Gcd,semiring_gcd_mult_normalize}"
  shows "b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> irreducible [:a,b:]"
  by (auto intro!: irreducible_linear_field_poly
           simp:   nonconst_poly_irreducible_iff content_def map_poly_pCons)

lemma prime_elem_linear_poly:
  fixes a b :: "'a::{idom_divide,ring_gcd,factorial_semiring,semiring_Gcd,semiring_gcd_mult_normalize}"
  shows "b \<noteq> 0 \<Longrightarrow> coprime a b \<Longrightarrow> prime_elem [:a,b:]"
  by (rule irreducible_imp_prime_poly, rule irreducible_linear_poly)

subsection \<open>Prime factorisation of polynomials\<close>

private lemma poly_prime_factorization_exists_content_1:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "p \<noteq> 0" "content p = 1"
  shows   "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> prod_mset A = normalize p"
proof -
  let ?P = "field_poly.prime_factorization (fract_poly p)"
  define c where "c = prod_mset (image_mset fract_content ?P)"
  define c' where "c' = c * to_fract (lead_coeff p)"
  define e where "e = prod_mset (image_mset primitive_part_fract ?P)"
  define A where "A = image_mset (normalize \<circ> primitive_part_fract) ?P"
  have "content e = (\<Prod>x\<in>#field_poly.prime_factorization (map_poly to_fract p).
                      content (primitive_part_fract x))"
    by (simp add: e_def content_prod_mset multiset.map_comp o_def)
  also have "image_mset (\<lambda>x. content (primitive_part_fract x)) ?P = image_mset (\<lambda>_. 1) ?P"
    by (intro image_mset_cong content_primitive_part_fract) auto
  finally have content_e: "content e = 1"
    by simp

  from \<open>p \<noteq> 0\<close> have "fract_poly p = [:lead_coeff (fract_poly p):] *
    smult (inverse (lead_coeff (fract_poly p))) (fract_poly p)"
    by simp
  also have "[:lead_coeff (fract_poly p):] = [:to_fract (lead_coeff p):]"
    by (simp add: monom_0 degree_map_poly coeff_map_poly)
  also from assms have "smult (inverse (lead_coeff (fract_poly p))) (fract_poly p) = prod_mset ?P"
    by (subst field_poly_prod_mset_prime_factorization) simp_all
  also have "\<dots> = prod_mset (image_mset id ?P)" by simp
  also have "image_mset id ?P =
               image_mset (\<lambda>x. [:fract_content x:] * fract_poly (primitive_part_fract x)) ?P"
    by (intro image_mset_cong) (auto simp: content_times_primitive_part_fract)
  also have "prod_mset \<dots> = smult c (fract_poly e)"
    by (subst prod_mset.distrib) (simp_all add: prod_mset_fract_poly prod_mset_const_poly c_def e_def)
  also have "[:to_fract (lead_coeff p):] * \<dots> = smult c' (fract_poly e)"
    by (simp add: c'_def)
  finally have eq: "fract_poly p = smult c' (fract_poly e)" .
  also obtain b where b: "c' = to_fract b" "is_unit b"
  proof -
    from fract_poly_smult_eqE[OF eq] guess a b . note ab = this
    from ab(2) have "content (smult a p) = content (smult b e)" by (simp only: )
    with assms content_e have "a = normalize b" by (simp add: ab(4))
    with ab have ab': "a = 1" "is_unit b"
      by (simp_all add: normalize_1_iff)
    with ab ab' have "c' = to_fract b" by auto
    from this and \<open>is_unit b\<close> show ?thesis by (rule that)
  qed
  hence "smult c' (fract_poly e) = fract_poly (smult b e)" by simp
  finally have "p = smult b e" by (simp only: fract_poly_eq_iff)
  hence "p = [:b:] * e" by simp
  with b have "normalize p = normalize e"
    by (simp only: normalize_mult) (simp add: is_unit_normalize is_unit_poly_iff)
  also have "normalize e = prod_mset A"
    by (simp add: multiset.map_comp e_def A_def normalize_prod_mset)
  finally have "prod_mset A = normalize p" ..

  have "prime_elem p" if "p \<in># A" for p
    using that by (auto simp: A_def prime_elem_primitive_part_fract prime_elem_imp_irreducible
                        dest!: field_poly_in_prime_factorization_imp_prime )
  from this and \<open>prod_mset A = normalize p\<close> show ?thesis
    by (intro exI[of _ A]) blast
qed

lemma poly_prime_factorization_exists:
  fixes p :: "'a :: {factorial_semiring,semiring_Gcd,ring_gcd,idom_divide,semiring_gcd_mult_normalize} poly"
  assumes "p \<noteq> 0"
  shows   "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> normalize (prod_mset A) = normalize p"
proof -
  define B where "B = image_mset (\<lambda>x. [:x:]) (prime_factorization (content p))"
  have "\<exists>A. (\<forall>p. p \<in># A \<longrightarrow> prime_elem p) \<and> prod_mset A = normalize (primitive_part p)"
    by (rule poly_prime_factorization_exists_content_1) (insert assms, simp_all)
  then guess A by (elim exE conjE) note A = this
  have "normalize (prod_mset (A + B)) = normalize (prod_mset A * normalize (prod_mset B))"
    by simp
  also from assms have "normalize (prod_mset B) = normalize [:content p:]"
    by (simp add: prod_mset_const_poly normalize_const_poly prod_mset_prime_factorization_weak B_def)
  also have "prod_mset A = normalize (primitive_part p)"
    using A by simp
  finally have "normalize (prod_mset (A + B)) = normalize (primitive_part p * [:content p:])"
    by simp
  moreover have "\<forall>p. p \<in># B \<longrightarrow> prime_elem p"
    by (auto simp: B_def intro!: lift_prime_elem_poly dest: in_prime_factors_imp_prime)
  ultimately show ?thesis using A by (intro exI[of _ "A + B"]) (auto)
qed

end

subsection \<open>Typeclass instances\<close>

instance poly :: ("{factorial_ring_gcd,semiring_gcd_mult_normalize}") factorial_semiring
  by standard (rule poly_prime_factorization_exists)

instantiation poly :: ("{factorial_ring_gcd, semiring_gcd_mult_normalize}") factorial_ring_gcd
begin

definition gcd_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  [code del]: "gcd_poly = gcd_factorial"

definition lcm_poly :: "'a poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  [code del]: "lcm_poly = lcm_factorial"

definition Gcd_poly :: "'a poly set \<Rightarrow> 'a poly" where
 [code del]: "Gcd_poly = Gcd_factorial"

definition Lcm_poly :: "'a poly set \<Rightarrow> 'a poly" where
 [code del]: "Lcm_poly = Lcm_factorial"

instance by standard (simp_all add: gcd_poly_def lcm_poly_def Gcd_poly_def Lcm_poly_def)

end

instance poly :: ("{factorial_ring_gcd, semiring_gcd_mult_normalize}") semiring_gcd_mult_normalize ..

instantiation poly :: ("{field,factorial_ring_gcd,semiring_gcd_mult_normalize}")
   "{unique_euclidean_ring, normalization_euclidean_semiring}"
begin

definition euclidean_size_poly :: "'a poly \<Rightarrow> nat"
  where "euclidean_size_poly p = (if p = 0 then 0 else 2 ^ degree p)"

definition division_segment_poly :: "'a poly \<Rightarrow> 'a poly"
  where [simp]: "division_segment_poly p = 1"

instance proof
  show "(q * p + r) div p = q" if "p \<noteq> 0"
    and "euclidean_size r < euclidean_size p" for q p r :: "'a poly"
  proof -
    from \<open>p \<noteq> 0\<close> eucl_rel_poly [of r p] have "eucl_rel_poly (r + q * p) p (q + r div p, r mod p)"
      by (simp add: eucl_rel_poly_iff distrib_right)
    then have "(r + q * p) div p = q + r div p"
      by (rule div_poly_eq)
    with that show ?thesis
      by (cases "r = 0") (simp_all add: euclidean_size_poly_def div_poly_less ac_simps)
  qed
qed (auto simp: euclidean_size_poly_def Rings.div_mult_mod_eq div_poly_less degree_mult_eq power_add
    intro!: degree_mod_less' split: if_splits)

end

instance poly :: ("{field, normalization_euclidean_semiring, factorial_ring_gcd,
                    semiring_gcd_mult_normalize}") euclidean_ring_gcd
  by (rule euclidean_ring_gcd_class.intro, rule factorial_euclidean_semiring_gcdI) standard

subsection \<open>Polynomial GCD\<close>

lemma gcd_poly_decompose:
  fixes p q :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  shows "gcd p q =
           smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q))"
proof (rule sym, rule gcdI)
  have "[:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q) dvd
          [:content p:] * primitive_part p" by (intro mult_dvd_mono) simp_all
  thus "smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q)) dvd p"
    by simp
next
  have "[:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q) dvd
          [:content q:] * primitive_part q" by (intro mult_dvd_mono) simp_all
  thus "smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q)) dvd q"
    by simp
next
  fix d assume "d dvd p" "d dvd q"
  hence "[:content d:] * primitive_part d dvd
           [:gcd (content p) (content q):] * gcd (primitive_part p) (primitive_part q)"
    by (intro mult_dvd_mono) auto
  thus "d dvd smult (gcd (content p) (content q)) (gcd (primitive_part p) (primitive_part q))"
    by simp
qed (auto simp: normalize_smult)

lemma gcd_poly_pseudo_mod:
  fixes p q :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  assumes nz: "q \<noteq> 0" and prim: "content p = 1" "content q = 1"
  shows   "gcd p q = gcd q (primitive_part (pseudo_mod p q))"
proof -
  define r s where "r = fst (pseudo_divmod p q)" and "s = snd (pseudo_divmod p q)"
  define a where "a = [:coeff q (degree q) ^ (Suc (degree p) - degree q):]"
  have [simp]: "primitive_part a = unit_factor a"
    by (simp add: a_def unit_factor_poly_def unit_factor_power monom_0)
  from nz have [simp]: "a \<noteq> 0" by (auto simp: a_def)

  have rs: "pseudo_divmod p q = (r, s)" by (simp add: r_def s_def)
  have "gcd (q * r + s) q = gcd q s"
    using gcd_add_mult[of q r s] by (simp add: gcd.commute add_ac mult_ac)
  with pseudo_divmod(1)[OF nz rs]
    have "gcd (p * a) q = gcd q s" by (simp add: a_def)
  also from prim have "gcd (p * a) q = gcd p q"
    by (subst gcd_poly_decompose)
       (auto simp: primitive_part_mult gcd_mult_unit1 primitive_part_prim
             simp del: mult_pCons_right )
  also from prim have "gcd q s = gcd q (primitive_part s)"
    by (subst gcd_poly_decompose) (simp_all add: primitive_part_prim)
  also have "s = pseudo_mod p q" by (simp add: s_def pseudo_mod_def)
  finally show ?thesis .
qed

lemma degree_pseudo_mod_less:
  assumes "q \<noteq> 0" "pseudo_mod p q \<noteq> 0"
  shows   "degree (pseudo_mod p q) < degree q"
  using pseudo_mod(2)[of q p] assms by auto

function gcd_poly_code_aux :: "'a :: factorial_ring_gcd poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  "gcd_poly_code_aux p q =
     (if q = 0 then normalize p else gcd_poly_code_aux q (primitive_part (pseudo_mod p q)))"
by auto
termination
  by (relation "measure ((\<lambda>p. if p = 0 then 0 else Suc (degree p)) \<circ> snd)")
     (auto simp: degree_pseudo_mod_less)

declare gcd_poly_code_aux.simps [simp del]

lemma gcd_poly_code_aux_correct:
  assumes "content p = 1" "q = 0 \<or> content q = 1"
  shows   "gcd_poly_code_aux p q = gcd p q"
  using assms
proof (induction p q rule: gcd_poly_code_aux.induct)
  case (1 p q)
  show ?case
  proof (cases "q = 0")
    case True
    thus ?thesis by (subst gcd_poly_code_aux.simps) auto
  next
    case False
    hence "gcd_poly_code_aux p q = gcd_poly_code_aux q (primitive_part (pseudo_mod p q))"
      by (subst gcd_poly_code_aux.simps) simp_all
    also from "1.prems" False
      have "primitive_part (pseudo_mod p q) = 0 \<or>
              content (primitive_part (pseudo_mod p q)) = 1"
      by (cases "pseudo_mod p q = 0") auto
    with "1.prems" False
      have "gcd_poly_code_aux q (primitive_part (pseudo_mod p q)) =
              gcd q (primitive_part (pseudo_mod p q))"
      by (intro 1) simp_all
    also from "1.prems" False
      have "\<dots> = gcd p q" by (intro gcd_poly_pseudo_mod [symmetric]) auto
    finally show ?thesis .
  qed
qed

definition gcd_poly_code
    :: "'a :: factorial_ring_gcd poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly"
  where "gcd_poly_code p q =
           (if p = 0 then normalize q else if q = 0 then normalize p else
              smult (gcd (content p) (content q))
                (gcd_poly_code_aux (primitive_part p) (primitive_part q)))"

lemma gcd_poly_code [code]: "gcd p q = gcd_poly_code p q"
  by (simp add: gcd_poly_code_def gcd_poly_code_aux_correct gcd_poly_decompose [symmetric])

lemma lcm_poly_code [code]:
  fixes p q :: "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"
  shows "lcm p q = normalize (p * q div gcd p q)"
  by (fact lcm_gcd)

lemmas Gcd_poly_set_eq_fold [code] =
  Gcd_set_eq_fold [where ?'a = "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"]
lemmas Lcm_poly_set_eq_fold [code] =
  Lcm_set_eq_fold [where ?'a = "'a :: {factorial_ring_gcd,semiring_gcd_mult_normalize} poly"]

text \<open>Example:
  @{lemma "Lcm {[:1, 2, 3:], [:2, 3, 4:]} = [:[:2:], [:7:], [:16:], [:17:], [:12 :: int:]:]" by eval}
\<close>

end


section \<open>Upper and Lower Solutions\<close>
theory Upper_Lower_Solution
imports Flow
begin

text \<open>Following  Walter~\cite{walter} in section 9\<close>

lemma IVT_min:
  fixes f :: "real \<Rightarrow> 'b :: {linorder_topology,real_normed_vector,ordered_real_vector}"
  \<comment> \<open>generalize?\<close>
  assumes y: "f a \<le> y" "y \<le> f b" "a \<le> b"
  assumes *: "continuous_on {a .. b} f"
  notes [continuous_intros] = *[THEN continuous_on_subset]
  obtains x where "a \<le> x" "x \<le> b" "f x = y" "\<And>x'. a \<le> x' \<Longrightarrow> x' < x \<Longrightarrow> f x' < y"
proof -
  let ?s = "((\<lambda>x. f x - y) -` {0..}) \<inter> {a..b}"
  have "?s \<noteq> {}"
    using assms
    by auto
  have "closed ?s"
    by (rule closed_vimage_Int) (auto intro!: continuous_intros)
  moreover have "bounded ?s"
    by (rule bounded_Int) (simp add: bounded_closed_interval)
  ultimately have "compact ?s"
    using compact_eq_bounded_closed by blast
  from compact_attains_inf[OF this \<open>?s \<noteq> {}\<close>]
  obtain x where x: "a \<le> x" "x \<le> b" "f x \<ge> y"
    and min: "\<And>z. a \<le> z \<Longrightarrow> z \<le> b \<Longrightarrow> f z \<ge> y \<Longrightarrow> x \<le> z"
    by auto
  have "f x \<le> y"
  proof (rule ccontr)
    assume n: "\<not> f x \<le> y"
    then have "\<exists>z\<ge>a. z \<le> x \<and> (\<lambda>x. f x - y) z = 0"
      using x by (intro IVT') (auto intro!: continuous_intros simp: assms)
    then obtain z where z: "a \<le> z" "z \<le> x" "f z = y" by auto
    then have "a \<le> z" "z \<le> b" "f z \<ge> y" using x by auto
    from min [OF this] z n
    show False by auto
  qed
  then have "a \<le> x" "x \<le> b" "f x = y"
    using x
    by (auto )
  moreover have "f x' < y" if "a \<le> x'" "x' < x" for x'
    apply (rule ccontr)
    using min[of x'] that x
    by (auto simp: not_less)
  ultimately show ?thesis ..
qed

lemma filtermap_at_left_shift: "filtermap (\<lambda>x. x - d) (at_left a) = at_left (a - d::real)"
  by (simp add: filter_eq_iff eventually_filtermap eventually_at_filter filtermap_nhds_shift[symmetric])

context
  fixes v v' w w'::"real \<Rightarrow> real" and t0 t1 e::real
  assumes v': "(v has_vderiv_on v') {t0 <.. t1}"
    and w': "(w has_vderiv_on w') {t0 <.. t1}"
  assumes pos_ivl: "t0 < t1"
  assumes e_pos: "e > 0" and e_in: "t0 + e \<le> t1"
  assumes less:  "\<And>t. t0 < t \<Longrightarrow> t < t0 + e \<Longrightarrow> v t < w t"
begin

lemma first_intersection_crossing_derivatives:
  assumes na: "t0 < tg" "tg \<le> t1" "v tg \<ge> w tg"
  notes [continuous_intros] =
    vderiv_on_continuous_on[OF v', THEN continuous_on_subset]
    vderiv_on_continuous_on[OF w', THEN continuous_on_subset]
  obtains x0 where
    "t0 < x0" "x0 \<le> tg"
    "v' x0 \<ge> w' x0"
    "v x0 = w x0"
    "\<And>t. t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t"
proof -
  have "(v - w) (min tg (t0 + e / 2)) \<le> 0" "0 \<le> (v - w) tg"
    "min tg (t0 + e / 2) \<le> tg"
    "continuous_on {min tg (t0 + e / 2)..tg} (v - w)"
  using less[of "t0 + e / 2"]
    less[of tg]na \<open>e > 0\<close>
    by (auto simp: min_def intro!: continuous_intros)
  from IVT_min[OF this]
  obtain x0 where x0: "min tg (t0 + e / 2) \<le> x0" "x0 \<le> tg" "v x0 = w x0"
    "\<And>x'. min tg (t0 + e / 2) \<le> x' \<Longrightarrow> x' < x0 \<Longrightarrow> v x' < w x'"
    by auto
  then have x0_in: "t0 < x0" "x0 \<le> t1"
    using \<open>e > 0\<close> na(1,2)
    by (auto)
  note \<open>t0 < x0\<close> \<open>x0 \<le> tg\<close>
  moreover
  {
    from v' x0_in
    have "(v has_derivative (\<lambda>x. x * v' x0)) (at x0 within {t0<..<x0})"
      by (force intro: has_derivative_within_subset simp: has_vector_derivative_def has_vderiv_on_def)
    then have v: "((\<lambda>y. (v y - (v x0 + (y - x0) * v' x0)) / norm (y - x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
      unfolding has_derivative_within
      by (simp add: ac_simps)
    from w' x0_in
    have "(w has_derivative (\<lambda>x. x * w' x0)) (at x0 within {t0<..<x0})"
      by (force intro: has_derivative_within_subset simp: has_vector_derivative_def has_vderiv_on_def)
    then have w: "((\<lambda>y. (w y - (w x0 + (y - x0) * w' x0)) / norm (y - x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
      unfolding has_derivative_within
      by (simp add: ac_simps)

    have evs: "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. min tg (t0 + e / 2) < x"
      "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. t0 < x \<and> x < x0"
      using less na(1) na(3) x0(3) x0_in(1)
      by (force simp: min_def eventually_at_filter intro!: order_tendstoD[OF tendsto_ident_at])+
    then have "\<forall>\<^sub>F x in at x0 within {t0<..<x0}.
       (v x - (v x0 + (x - x0) * v' x0)) / norm (x - x0) - (w x - (w x0 + (x - x0) * w' x0)) / norm (x - x0) =
       (v x - w x) / norm (x - x0) + (v' x0 - w' x0)"
       apply eventually_elim
       using x0_in x0 less na \<open>t0 < t1\<close> sum_sqs_eq
       by (auto simp: divide_simps algebra_simps min_def intro!: eventuallyI split: if_split_asm)
    from this tendsto_diff[OF v w]
    have 1: "((\<lambda>x. (v x - w x) / norm (x - x0) + (v' x0 - w' x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
      by (force intro: tendsto_eq_rhs Lim_transform_eventually)
    moreover
    from evs have 2: "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. (v x - w x) / norm (x - x0) + (v' x0 - w' x0) \<le> (v' x0 - w' x0)"
      by eventually_elim (auto simp: divide_simps intro!: less_imp_le x0(4))

    moreover
    have "at x0 within {t0<..<x0} \<noteq> bot"
      by (simp add: \<open>t0 < x0\<close> at_within_eq_bot_iff less_imp_le)

    ultimately
    have "0 \<le> v' x0 - w' x0"
      by (rule tendsto_upperbound)
    then have "v' x0 \<ge> w' x0" by simp
  }
  moreover note \<open>v x0 = w x0\<close>
  moreover
  have "t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t" for t
    by (cases "min tg (t0 + e / 2) \<le> t") (auto intro: x0 less)
  ultimately show ?thesis ..
qed

lemma defect_less:
  assumes b: "\<And>t. t0 < t \<Longrightarrow> t \<le> t1 \<Longrightarrow> v' t - f t (v t) < w' t - f t (w t)"
  notes [continuous_intros] =
    vderiv_on_continuous_on[OF v', THEN continuous_on_subset]
    vderiv_on_continuous_on[OF w', THEN continuous_on_subset]
  shows "\<forall>t \<in> {t0 <.. t1}. v t < w t"
proof (rule ccontr)
  assume " \<not> (\<forall>t\<in>{t0 <.. t1}. v t < w t)"
  then obtain tu where "t0 < tu" "tu \<le> t1" "v tu \<ge> w tu" by auto
  from first_intersection_crossing_derivatives[OF this]
  obtain x0 where "t0 < x0" "x0 \<le> tu" "w' x0 \<le> v' x0" "v x0 = w x0" "\<And>t. t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t"
    by metis
  with b[of x0] \<open>tu \<le> t1\<close>
  show False
    by simp
qed

end

lemma has_derivatives_less_lemma:
  fixes v v' ::"real \<Rightarrow> real"
  assumes v': "(v has_vderiv_on v') T"
  assumes y': "(y has_vderiv_on y') T"
  assumes lu: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> v' t - f t (v t) < y' t - f t (y t)"
  assumes lower: "v t0 \<le> y t0"
  assumes eq_imp: "v t0 = y t0 \<Longrightarrow> v' t0 < y' t0"
  assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
  shows "v t < y t"
proof -
  have subset: "{t0 .. t} \<subseteq> T"
    by (rule atMostAtLeast_subset_convex) (auto simp: assms is_interval_convex)
  obtain d where "0 < d" "t0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> s < t0 + d \<Longrightarrow> v s < y s" for s
  proof cases
    assume "v t0 = y t0"
    from this[THEN eq_imp]
    have *: "0 < y' t0 - v' t0"
      by (simp add: )
    have "((\<lambda>t. y t - v t) has_vderiv_on (\<lambda>t0. y' t0 - v' t0)) {t0 .. t}"
      by (auto intro!: derivative_intros y' v' has_vderiv_on_subset[OF _ subset])
    with \<open>t0 < t\<close>
    have d: "((\<lambda>t. y t - v t) has_real_derivative y' t0 - v' t0) (at t0 within {t0 .. t})"
      by (auto simp: has_vderiv_on_def has_field_derivative_iff_has_vector_derivative)
    from has_real_derivative_pos_inc_right[OF d *] \<open>v t0 = y t0\<close>
    obtain d where "d > 0" and vy: "h > 0 \<Longrightarrow> t0 + h \<le> t \<Longrightarrow> h < d \<Longrightarrow> v (t0 + h) < y (t0 + h)" for h
      by auto
    have vy: "t0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> s < t0 + d \<Longrightarrow> v s < y s" for s
      using vy[of "s - t0"] by simp
    with \<open>d > 0\<close> show ?thesis ..
  next
    assume "v t0 \<noteq> y t0"
    then have "v t0 < y t0" using lower by simp
    moreover
    have "continuous_on {t0 .. t} v" "continuous_on {t0 .. t} y"
      by (auto intro!: vderiv_on_continuous_on assms has_vderiv_on_subset[OF _ subset])
    then have "(v \<longlongrightarrow> v t0) (at t0 within {t0 .. t})" "(y \<longlongrightarrow> y t0) (at t0 within {t0 .. t})"
      by (auto simp: continuous_on)
    ultimately have "\<forall>\<^sub>F x in at t0 within {t0 .. t}. 0 < y x - v x"
      by (intro order_tendstoD) (auto intro!: tendsto_eq_intros)
    then obtain d where "d > 0" "\<And>x. t0 < x \<Longrightarrow> x \<le> t \<Longrightarrow> x < t0 + d \<Longrightarrow> v x < y x"
      by atomize_elim (auto simp: eventually_at algebra_simps dist_real_def)
    then show ?thesis ..
  qed
  with \<open>d > 0\<close> \<open>t0 < t\<close>
  obtain e where "e > 0" "t0 + e \<le> t" "t0 < s \<Longrightarrow> s < t0 + e \<Longrightarrow> v s < y s" for s
    by atomize_elim (auto simp: min_def divide_simps intro!: exI[where x="min (d/2) ((t - t0) / 2)"]
        split: if_split_asm)
  from defect_less[
      OF has_vderiv_on_subset[OF v']
        has_vderiv_on_subset[OF y']
        \<open>t0 < t\<close>
        this lu]
  show "v t < y t" using \<open>t0 < t\<close> subset
    by (auto simp: subset_iff assms)
qed

lemma strict_lower_solution:
  fixes v v' ::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) T X"
  assumes v': "(v has_vderiv_on v') T"
  assumes lower: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> v' t < f t (v t)"
  assumes iv: "v t0 \<le> y t0" "v t0 = y t0 \<Longrightarrow> v' t0 < f t0 (y t0)"
  assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
  shows "v t < y t"
proof -
  note v'
  moreover
  note solves_odeD(1)[OF sol]
  moreover
  have 3: "v' t - f t (v t) < f t (y t) - f t (y t)" if "t \<in> T" "t > t0" for t
    using lower(1)[OF that]
    by arith
  moreover note iv
  moreover note t
  ultimately
  show "v t < y t"
    by (rule has_derivatives_less_lemma)
qed

lemma strict_upper_solution:
  fixes w w'::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) T X"
  assumes w': "(w has_vderiv_on w') T"
    and upper: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> f t (w t) < w' t"
    and iv: "y t0 \<le> w t0" "y t0 = w t0 \<Longrightarrow> f t0 (y t0) < w' t0"
  assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
  shows "y t < w t"
proof -
  note solves_odeD(1)[OF sol]
  moreover
  note w'
  moreover
  have "f t (y t) - f t (y t) < w' t - f t (w t)" if "t \<in> T" "t > t0" for t
    using upper(1)[OF that]
    by arith
  moreover note iv
  moreover note t
  ultimately
  show "y t < w t"
    by (rule has_derivatives_less_lemma)
qed

lemma uniform_limit_at_within_subset:
  assumes "uniform_limit S x l (at t within T)"
  assumes "U \<subseteq> T"
  shows "uniform_limit S x l (at t within U)"
  by (metis assms(1) assms(2) eventually_within_Un filterlim_iff subset_Un_eq)

lemma uniform_limit_le:
  fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
  assumes I: "I \<noteq> bot"
  assumes u: "uniform_limit X f g I"
  assumes u': "uniform_limit X f' g' I"
  assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. f i x \<le> f' i x"
  assumes "x \<in> X"
  shows "g x \<le> g' x"
proof -
  have "\<forall>\<^sub>F i in I. f i x \<le> f' i x" using assms by (simp add: eventually_mono)
  with I tendsto_uniform_limitI[OF u' \<open>x \<in> X\<close>] tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>]
  show ?thesis by (rule tendsto_le)
qed

lemma uniform_limit_le_const:
  fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
  assumes I: "I \<noteq> bot"
  assumes u: "uniform_limit X f g I"
  assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. f i x \<le> h x"
  assumes "x \<in> X"
  shows "g x \<le> h x"
proof -
  have "\<forall>\<^sub>F i in I. f i x \<le> h x" using assms by (simp add: eventually_mono)
  then show ?thesis by (metis tendsto_upperbound I tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>])
qed

lemma uniform_limit_ge_const:
  fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
  assumes I: "I \<noteq> bot"
  assumes u: "uniform_limit X f g I"
  assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. h x \<le> f i x"
  assumes "x \<in> X"
  shows "h x \<le> g x"
proof -
  have "\<forall>\<^sub>F i in I. h x \<le> f i x" using assms by (simp add: eventually_mono)
  then show ?thesis by (metis tendsto_lowerbound I tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>])
qed

locale ll_on_open_real = ll_on_open T f X for T f and X::"real set"
begin

lemma lower_solution:
  fixes v v' ::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) S X"
  assumes v': "(v has_vderiv_on v') S"
  assumes lower: "\<And>t. t \<in> S \<Longrightarrow> t > t0 \<Longrightarrow> v' t < f t (v t)"
  assumes iv: "v t0 \<le> y t0"
  assumes t: "t0 \<le> t" "t0 \<in> S" "t \<in> S" "is_interval S" "S \<subseteq> T"
  shows "v t \<le> y t"
proof cases
  assume "v t0 = y t0"
  have "{t0 -- t} \<subseteq> S" using t by (simp add: closed_segment_subset is_interval_convex)
  with sol have "(y solves_ode f) {t0 -- t} X" using order_refl by (rule solves_ode_on_subset)
  moreover note refl
  moreover
  have "{t0 -- t} \<subseteq> T" using \<open>{t0 -- t} \<subseteq> S\<close> \<open>S \<subseteq> T\<close> by (rule order_trans)
  ultimately have t_ex: "t \<in> existence_ivl t0 (y t0)"
    by (rule existence_ivl_maximal_segment)

  have t0_ex: "t0 \<in> existence_ivl t0 (y t0)"
    using in_existence_between_zeroI t_ex by blast
  have "t0 \<in> T" using assms(9) t(2) by blast

  from uniform_limit_flow[OF t0_ex t_ex] \<open>t0 \<le> t\<close>
  have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at (y t0))" by simp
  then have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at_right (y t0))"
    by (rule uniform_limit_at_within_subset) simp
  moreover
  {
    have "\<forall>\<^sub>F i in at (y t0). t \<in> existence_ivl t0 i"
      by (rule eventually_mem_existence_ivl) fact
    then have "\<forall>\<^sub>F i in at_right (y t0). t \<in> existence_ivl t0 i"
      unfolding eventually_at_filter
      by eventually_elim simp
    moreover have "\<forall>\<^sub>F i in at_right (y t0). i \<in> X"
    proof -
      have f1: "\<And>r ra rb. r \<notin> existence_ivl ra rb \<or> rb \<in> X"
        by (metis existence_ivl_reverse flow_in_domain flows_reverse)
      obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> (real \<Rightarrow> bool) \<Rightarrow> real" where
        "\<And>p f pa fa. (\<not> eventually p f \<or> eventually pa f \<or> p (rr p pa)) \<and>
          (\<not> eventually p fa \<or> \<not> pa (rr p pa) \<or> eventually pa fa)"
        by (metis (no_types) eventually_mono)
      then show ?thesis
        using f1 calculation by meson
    qed
    moreover have "\<forall>\<^sub>F i in at_right (y t0). y t0 < i"
      by (simp add: eventually_at_filter)
    ultimately have "\<forall>\<^sub>F i in at_right (y t0). \<forall>x\<in>{t0..t}. v x \<le> flow t0 i x"
    proof eventually_elim
      case (elim y')
      show ?case
      proof safe
        fix s assume s: "s \<in> {t0..t}"
        show "v s \<le> flow t0 y' s"
        proof cases
          assume "s = t0" with elim iv show ?thesis
            by (simp add: \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
        next
          assume "s \<noteq> t0" with s have "t0 < s" by simp
          have "{t0 -- s} \<subseteq> S" using \<open>{t0--t} \<subseteq> S\<close> closed_segment_eq_real_ivl s by auto
          from s elim have "{t0..s} \<subseteq> existence_ivl t0 y'"
            using ivl_subset_existence_ivl by blast
          with flow_solves_ode have sol: "(flow t0 y' solves_ode f) {t0 .. s} X"
            by (rule solves_ode_on_subset) (auto intro!: \<open>y' \<in> X\<close> \<open>t0 \<in> T\<close>)
          have "{t0 .. s} \<subseteq> S" using \<open>{t0 -- s} \<subseteq> S\<close> by (simp add: closed_segment_eq_real_ivl split: if_splits)
          with v' have v': "(v has_vderiv_on v') {t0 .. s}"
            by (rule has_vderiv_on_subset)
          from \<open>y t0 < y'\<close> \<open>v t0 = y t0\<close> have less_init: "v t0 < flow t0 y' t0"
            by (simp add: flow_initial_time_if \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
          from strict_lower_solution[OF sol v' lower less_imp_le[OF less_init] _ \<open>t0 < s\<close>]
            \<open>{t0 .. s} \<subseteq> S\<close>
            less_init \<open>t0 < s\<close>
          have "v s < flow t0 y' s" by (simp add: subset_iff is_interval_cc)
          then show ?thesis by simp
        qed
      qed
    qed
  }
  moreover have "t \<in> {t0 .. t}" using \<open>t0 \<le> t\<close> by simp
  ultimately have "v t \<le> flow t0 (y t0) t"
    by (rule uniform_limit_ge_const[OF trivial_limit_at_right_real])
  also have "flow t0 (y t0) t = y t"
    using sol t
    by (intro maximal_existence_flow) auto
  finally show ?thesis .
next
  assume "v t0 \<noteq> y t0" then have less: "v t0 < y t0" using iv by simp
  show ?thesis
    apply (cases "t0 = t")
    subgoal using iv by blast
    subgoal using strict_lower_solution[OF sol v' lower iv] less t by force
    done
qed

lemma upper_solution:
  fixes v v' ::"real \<Rightarrow> real"
  assumes sol: "(y solves_ode f) S X"
  assumes v': "(v has_vderiv_on v') S"
  assumes upper: "\<And>t. t \<in> S \<Longrightarrow> t > t0 \<Longrightarrow> f t (v t) < v' t"
  assumes iv: "y t0 \<le> v t0"
  assumes t: "t0 \<le> t" "t0 \<in> S" "t \<in> S" "is_interval S" "S \<subseteq> T"
  shows "y t \<le> v t"
proof cases
  assume "v t0 = y t0"
  have "{t0 -- t} \<subseteq> S" using t by (simp add: closed_segment_subset is_interval_convex)
  with sol have "(y solves_ode f) {t0 -- t} X" using order_refl by (rule solves_ode_on_subset)
  moreover note refl
  moreover
  have "{t0 -- t} \<subseteq> T" using \<open>{t0 -- t} \<subseteq> S\<close> \<open>S \<subseteq> T\<close> by (rule order_trans)
  ultimately have t_ex: "t \<in> existence_ivl t0 (y t0)"
    by (rule existence_ivl_maximal_segment)

  have t0_ex: "t0 \<in> existence_ivl t0 (y t0)"
    using in_existence_between_zeroI t_ex by blast
  have "t0 \<in> T" using assms(9) t(2) by blast

  from uniform_limit_flow[OF t0_ex t_ex] \<open>t0 \<le> t\<close>
  have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at (y t0))" by simp
  then have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at_left (y t0))"
    by (rule uniform_limit_at_within_subset) simp
  moreover
  {
    have "\<forall>\<^sub>F i in at (y t0). t \<in> existence_ivl t0 i"
      by (rule eventually_mem_existence_ivl) fact
    then have "\<forall>\<^sub>F i in at_left (y t0). t \<in> existence_ivl t0 i"
      unfolding eventually_at_filter
      by eventually_elim simp
    moreover have "\<forall>\<^sub>F i in at_left (y t0). i \<in> X"
    proof -
      have f1: "\<And>r ra rb. r \<notin> existence_ivl ra rb \<or> rb \<in> X"
        by (metis existence_ivl_reverse flow_in_domain flows_reverse)
      obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> (real \<Rightarrow> bool) \<Rightarrow> real" where
        "\<And>p f pa fa. (\<not> eventually p f \<or> eventually pa f \<or> p (rr p pa)) \<and>
          (\<not> eventually p fa \<or> \<not> pa (rr p pa) \<or> eventually pa fa)"
        by (metis (no_types) eventually_mono)
      then show ?thesis
        using f1 calculation by meson
    qed
    moreover have "\<forall>\<^sub>F i in at_left (y t0). i < y t0"
      by (simp add: eventually_at_filter)
    ultimately have "\<forall>\<^sub>F i in at_left (y t0). \<forall>x\<in>{t0..t}. flow t0 i x \<le> v x"
    proof eventually_elim
      case (elim y')
      show ?case
      proof safe
        fix s assume s: "s \<in> {t0..t}"
        show "flow t0 y' s \<le> v s"
        proof cases
          assume "s = t0" with elim iv show ?thesis
            by (simp add: \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
        next
          assume "s \<noteq> t0" with s have "t0 < s" by simp
          have "{t0 -- s} \<subseteq> S" using \<open>{t0--t} \<subseteq> S\<close> closed_segment_eq_real_ivl s by auto
          from s elim have "{t0..s} \<subseteq> existence_ivl t0 y'"
            using ivl_subset_existence_ivl by blast
          with flow_solves_ode have sol: "(flow t0 y' solves_ode f) {t0 .. s} X"
            by (rule solves_ode_on_subset) (auto intro!: \<open>y' \<in> X\<close> \<open>t0 \<in> T\<close>)
          have "{t0 .. s} \<subseteq> S" using \<open>{t0 -- s} \<subseteq> S\<close> by (simp add: closed_segment_eq_real_ivl split: if_splits)
          with v' have v': "(v has_vderiv_on v') {t0 .. s}"
            by (rule has_vderiv_on_subset)
          from \<open>y' < y t0\<close> \<open>v t0 = y t0\<close> have less_init: "flow t0 y' t0 < v t0"
            by (simp add: flow_initial_time_if \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
          from strict_upper_solution[OF sol v' upper less_imp_le[OF less_init] _ \<open>t0 < s\<close>]
            \<open>{t0 .. s} \<subseteq> S\<close>
            less_init \<open>t0 < s\<close>
          have "flow t0 y' s < v s" by (simp add: subset_iff is_interval_cc)
          then show ?thesis by simp
        qed
      qed
    qed
  }
  moreover have "t \<in> {t0 .. t}" using \<open>t0 \<le> t\<close> by simp
  ultimately have "flow t0 (y t0) t \<le> v t"
    by (rule uniform_limit_le_const[OF trivial_limit_at_left_real])
  also have "flow t0 (y t0) t = y t"
    using sol t
    by (intro maximal_existence_flow) auto
  finally show ?thesis .
next
  assume "v t0 \<noteq> y t0" then have less: "y t0 < v t0" using iv by simp
  show ?thesis
    apply (cases "t0 = t")
    subgoal using iv by blast
    subgoal using strict_upper_solution[OF sol v' upper iv] less t by force
    done
qed

end

end