theory Transport_Typedef
  imports
    Main
    Transport_Typedef_Base
    Transport_PER
    Transport_Syntax
begin

context
  includes galois_rel_syntax transport_syntax
begin

typedef pint = "{i :: int. 0 \<le> i}" by auto

interpretation typedef_pint :
  type_definition Rep_pint Abs_pint "{i :: int. 0 \<le> i}"
  by (fact type_definition_pint)

typedef 'a fset = "{s :: 'a set. finite s}" by auto

interpretation typedef_fset :
  type_definition Rep_fset Abs_fset "{s :: 'a set. finite s}"
  by (fact type_definition_fset)

lemma eq_restrict_set_eq_eq_unif_hint [unif_hint]:
  "P \<equiv> \<lambda>x. x \<in> A \<Longrightarrow> ((=\<^bsub>A :: 'a set\<^esub>) :: 'a \<Rightarrow> _) \<equiv> (=\<^bsub>P\<^esub>)"
  by simp

(*could also automatically tagged for every instance in type_definition*)
declare
  typedef_pint.partial_equivalence_rel_equivalence[per_intro]
  typedef_fset.partial_equivalence_rel_equivalence[per_intro]

lemma one_parametric [transport_parametric]: "typedef_pint.L 1 1"
  by auto

transport_term pint_one :: "pint" where x = "1 :: int"
  by transport_term_prover

lemma add_parametric [transport_parametric]:
  "(typedef_pint.L \<Rrightarrow> typedef_pint.L \<Rrightarrow> typedef_pint.L) (+) (+)"
  by (intro Dep_Fun_Rel_relI) (auto intro!: eq_restrictI elim!: eq_restrictE)

transport_term pint_add :: "pint \<Rightarrow> pint \<Rightarrow> pint"
  where x = "(+) :: int \<Rightarrow> _"
  by transport_term_prover

lemma empty_parametric [transport_parametric]: "typedef_fset.L {} {}"
  by auto

transport_term fempty :: "'a fset" where x = "{} :: 'a set"
  by transport_term_prover

lemma insert_parametric [transport_parametric]:
  "((=) \<Rrightarrow> typedef_fset.L \<Rrightarrow> typedef_fset.L) insert insert"
  by auto

transport_term finsert :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
  where x = insert
  and L = "((=) \<Rrightarrow> typedef_fset.L \<Rrightarrow> typedef_fset.L)"
  and R = "((=) \<Rrightarrow> typedef_fset.R \<Rrightarrow> typedef_fset.R)"
  by transport_term_prover

context
  notes refl[transport_related_intro]
begin

transport_term insert_add_int_fset_whitebox :: "int fset"
  where x = "insert (1 + (1 :: int)) {}" !
  by transport_related_prover

lemma empty_parametric' [transport_related_intro]: "(rel_set R) {} {}"
  by (intro Dep_Fun_Rel_relI rel_setI) (auto dest: rel_setD1 rel_setD2)

lemma insert_parametric' [transport_related_intro]:
  "(R \<Rrightarrow> rel_set R \<Rrightarrow> rel_set R) insert insert"
  by (intro Dep_Fun_Rel_relI rel_setI) (auto dest: rel_setD1 rel_setD2)

(*proven for all natural functors*)
lemma Galois_set_hint [unif_hint]:
  "L \<equiv> rel_set (L1 :: 'a \<Rightarrow> 'a \<Rightarrow> bool)
  \<Longrightarrow> R \<equiv> rel_set (R1 :: 'b \<Rightarrow> 'b \<Rightarrow> bool) \<Longrightarrow> r \<equiv> image r1 \<Longrightarrow> S \<equiv> (\<^bsub>L1\<^esub>\<lessapprox>\<^bsub>R1 r1\<^esub>)
  \<Longrightarrow> (\<^bsub>L\<^esub>\<lessapprox>\<^bsub>R r\<^esub>) \<equiv> rel_set S"
  sorry

transport_term insert_add_pint_set_whitebox :: "pint set"
  where x = "insert (1 + (1 :: int)) {}" !
  by transport_related_prover

print_statement insert_add_int_fset_whitebox_def insert_add_pint_set_whitebox_def

lemma rel_fun_eq_Fun_Rel_rel: "rel_fun = Fun_Rel_rel"
  by (intro ext iffI Dep_Fun_Rel_relI) (auto elim: rel_funE)

transport_term insert_add_pint_fset_whitebox :: "pint fset"
  where x = "insert (1 + (1 :: int)) {}" !
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm Fun_Rel_relD}] 1\<close>)+
  defer
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm Fun_Rel_relD}] 1\<close>)+
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm pint_add_related'}] 1\<close>)
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm pint_one_related'}] 1\<close>)
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm pint_one_related'}] 1\<close>)
  oops

end

lemma image_parametric [transport_parametric]:
  "(((=) \<Rrightarrow> (=)) \<Rrightarrow> typedef_fset.L \<Rrightarrow> typedef_fset.L) image image"
  by (intro Dep_Fun_Rel_relI) auto

transport_term fimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset"
  where x = image
  by transport_term_prover

lemma image_parametric' [transport_related_intro]:
  "((R \<Rrightarrow> S) \<Rrightarrow> rel_set R \<Rrightarrow> rel_set S) image image"
  using transfer_raw[simplified rel_fun_eq_Fun_Rel_rel Transfer.Rel_def]
  by simp

(* lemma insert_union: "(insert a B) \<union> C = insert a (B \<union> C)"
  by auto *)

(* lemma eq_rel: "((\<^bsub>L\<^esub>\<lessapprox>) \<Rrightarrow> (\<^bsub>L\<^esub>\<lessapprox>) \<Rrightarrow> (\<longleftrightarrow>)) (=) (=)"
  using Rep_fset_inject
  by (intro Dep_Fun_Rel_relI) (auto elim!: galois_rel.GaloisE eq_restrictE) *)

(* lemma finsert_funion: "funion (finsert a B) C = finsert a (funion B C)"
proof -
  "(\<longleftrightarrow>) ?target ?goal"
  have "a = a" by auto
  have "Rep_fset B \<^bsub>L\<^esub>\<lessapprox> B"
    by (fact typedef_fset.Galois_Rep_self)
  have "insert a (Rep_fset B) \<^bsub>L\<^esub>\<lessapprox> finsert a B"
   by (fact Dep_Fun_Rel_relD[OF
        Dep_Fun_Rel_relD[OF finsert_related' \<open>a = a\<close>]
        \<open>Rep_fset B \<^bsub>L\<^esub>\<lessapprox> B\<close>
    ])
  have "Rep_fset C \<^bsub>L\<^esub>\<lessapprox> C"
    by (fact typedef_fset.Galois_Rep_self)
  have "union (Rep_fset B) (Rep_fset C) \<^bsub>L\<^esub>\<lessapprox> funion B C"
    by (fact Dep_Fun_Rel_relD[OF
        Dep_Fun_Rel_relD[OF funion_related' \<open>Rep_fset B \<^bsub>L\<^esub>\<lessapprox> B\<close>]
        \<open>Rep_fset C \<^bsub>L\<^esub>\<lessapprox> C\<close>
    ])
  have "funion (finsert a B) C = finsert a (funion B C)
    \<longleftrightarrow>
    union (insert a (Rep_fset B)) (Rep_fset C)
      = insert a (union (Rep_fset B) (Rep_fset C))"
    sorry
  have "union (insert a (Rep_fset B)) (Rep_fset C)
    = insert a (union (Rep_fset B) (Rep_fset C))"
    using insert_union by simp
  show ?thesis sorry
qed *)

(*experiment with compositions*)

context
  fixes L1 R1 l1 r1 L R l r
  assumes "(L1 \<equiv>\<^bsub>PER\<^esub> R1) l1 r1"
  defines "L \<equiv> rel_set L1" and "R \<equiv> rel_set R1"
  and "l \<equiv> image l1" and "r \<equiv> image r1"
begin

interpretation transport L R l r .

(*proven for all natural functors*)
lemma transport_per_set: "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^bsub>PER\<^esub> (\<le>\<^bsub>R\<^esub>)) l r" sorry

end

context
  fixes L1 R1 l1 r1 L R l r
  assumes per1: "(L1 \<equiv>\<^bsub>PER\<^esub> R1) l1 r1"
  and compat:
    "transport_comp.middle_compatible_codom (rel_set R1) typedef_fset.L"
begin

transport_term fempty_param :: "'b fset"
  where x = "{} :: 'a set"
  and L = "transport_comp.L ?L1 ?R1 (?l1 :: 'a set \<Rightarrow> 'b set) ?r1 typedef_fset.L"
  and R = "transport_comp.L typedef_fset.R typedef_fset.L ?r2 ?l2 ?R1"
  apply (rule transport_comp.partial_equivalence_rel_equivalenceI)
    apply (rule transport_per_set[OF per1])
    apply per_prover
    apply (fact compat)
  apply (rule transport_comp.left_relI[where ?y="{}" and ?y'="{}"])
    apply (auto intro!: galois_rel.GaloisI in_codomI empty_transfer)
  done

end

definition "set_succ \<equiv> image ((+) (1 :: int))"

lemma set_succ_parametric [transport_parametric]:
  "(typedef_fset.L \<Rrightarrow> typedef_fset.L) set_succ set_succ"
  unfolding set_succ_def by auto

transport_term fset_succ :: "int fset \<Rightarrow> int fset"
  where x = set_succ
  and L = "typedef_fset.L \<Rrightarrow> typedef_fset.L"
  and R = "typedef_fset.R \<Rrightarrow> typedef_fset.R"
  by transport_term_prover

(* lemma Galois_id_hint [unif_hint]:
  "(L :: 'a \<Rightarrow> 'a \<Rightarrow> bool) \<equiv> R \<Longrightarrow> r \<equiv> id \<Longrightarrow> E \<equiv> L \<Longrightarrow> (\<^bsub>L\<^esub>\<lessapprox>\<^bsub>R r\<^esub>) \<equiv> E"
  by (simp only: eq_reflection[OF transport_id.Galois_eq_left]) *)

lemma Fun_Rel_relD_delay:
  assumes "\<And>x y. R x y \<Longrightarrow> S (f x) (g y)"
  and "T = (R \<Rrightarrow> S)"
  shows "T f g"
  using assms by blast

transport_term fset_succ' :: "int fset \<Rightarrow> int fset"
  where x = set_succ
  and L = "typedef_fset.L \<Rrightarrow> typedef_fset.L"
  and R = "typedef_fset.R \<Rrightarrow> typedef_fset.R"
  unfold set_succ_def !
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm Fun_Rel_relD_delay}] 1\<close>)
  (* apply transport_related_prover *)
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm Fun_Rel_relD}] 1\<close>)
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm Fun_Rel_relD}] 1\<close>)
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm fimage_related'}] 1\<close>)
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm Fun_Rel_relD}] 1\<close>)
  defer
  apply (tactic \<open>any_unify_hints_resolve_tac @{context} [@{thm refl}] 1\<close>)
  oops

lemma pint_middle_compat:
  "transport_comp.middle_compatible_codom (rel_set ((=) :: pint \<Rightarrow> _))
  (=\<^bsub>Collect (finite :: pint set \<Rightarrow> _)\<^esub>)"
  by (intro transport_comp.middle_compatible_codom_if_right1_le_eqI)
  (auto simp: rel_set_eq intro!: transitiveI)

transport_term pint_fset_succ :: "pint fset \<Rightarrow> pint fset"
  where x = "set_succ :: int set \<Rightarrow> int set"
  apply (rule transport_Fun_Rel.partial_equivalence_rel_equivalenceI)
    apply (rule transport_comp.partial_equivalence_rel_equivalenceI)
      apply (rule transport_per_set)
      apply (rule typedef_pint.partial_equivalence_rel_equivalence)
      apply per_prover
      apply (fact pint_middle_compat)
    apply (rule transport_comp.partial_equivalence_rel_equivalenceI)
      apply (rule transport_per_set)
      apply (rule typedef_pint.partial_equivalence_rel_equivalence)
      apply per_prover
      apply (fact pint_middle_compat)
  apply (simp add: transport_def)
  apply (intro Dep_Fun_Rel_relI)
  oops

end

end


(*  Title:     HOL/Probability/Sinc_Integral.thy
    Authors:   Jeremy Avigad (CMU), Luke Serafin (CMU)
    Authors:   Johannes Hölzl, TU München
*)

section \<open>Integral of sinc\<close>

theory Sinc_Integral
  imports Distributions
begin

subsection \<open>Various preparatory integrals\<close>

text \<open> Naming convention
The theorem name consists of the following parts:
  \<^item> Kind of integral: \<open>has_bochner_integral\<close> / \<open>integrable\<close> / \<open>LBINT\<close>
  \<^item> Interval: Interval (0 / infinity / open / closed) (infinity / open / closed)
  \<^item> Name of the occurring constants: power, exp, m (for minus), scale, sin, $\ldots$
\<close>

lemma has_bochner_integral_I0i_power_exp_m':
  "has_bochner_integral lborel (\<lambda>x. x^k * exp (-x) * indicator {0 ..} x::real) (fact k)"
  using nn_intergal_power_times_exp_Ici[of k]
  by (intro has_bochner_integral_nn_integral)
     (auto simp: nn_integral_set_ennreal split: split_indicator)

lemma has_bochner_integral_I0i_power_exp_m:
  "has_bochner_integral lborel (\<lambda>x. x^k * exp (-x) * indicator {0 <..} x::real) (fact k)"
  using AE_lborel_singleton[of 0]
  by (intro has_bochner_integral_cong_AE[THEN iffD1, OF _ _ _ has_bochner_integral_I0i_power_exp_m'])
     (auto split: split_indicator)

lemma integrable_I0i_exp_mscale: "0 < (u::real) \<Longrightarrow> set_integrable lborel {0 <..} (\<lambda>x. exp (-(x * u)))"
  using lborel_integrable_real_affine_iff[of u "\<lambda>x. indicator {0 <..} x *\<^sub>R exp (- x)" 0]
        has_bochner_integral_I0i_power_exp_m[of 0]
  by (simp add: indicator_def zero_less_mult_iff mult_ac integrable.intros)

lemma LBINT_I0i_exp_mscale: "0 < (u::real) \<Longrightarrow> LBINT x=0..\<infinity>. exp (-(x * u)) = 1 / u"
  using lborel_integral_real_affine[of u "\<lambda>x. indicator {0<..} x *\<^sub>R exp (- x)" 0]
        has_bochner_integral_I0i_power_exp_m[of 0]
  by (auto simp: indicator_def zero_less_mult_iff interval_lebesgue_integral_0_infty field_simps
           dest!: has_bochner_integral_integral_eq)

lemma LBINT_I0c_exp_mscale_sin:
  "LBINT x=0..t. exp (-(u * x)) * sin x =
    (1 / (1 + u^2)) * (1 - exp (-(u * t)) * (u * sin t + cos t))" (is "_ = ?F t")
  unfolding zero_ereal_def
proof (subst interval_integral_FTC_finite)
  show "(?F has_vector_derivative exp (- (u * x)) * sin x) (at x within {min 0 t..max 0 t})" for x
    by (auto intro!: derivative_eq_intros
             simp: has_field_derivative_iff_has_vector_derivative[symmetric] power2_eq_square)
       (simp_all add: field_simps add_nonneg_eq_0_iff)
qed (auto intro: continuous_at_imp_continuous_on)

lemma LBINT_I0i_exp_mscale_sin:
  assumes "0 < x"
  shows "LBINT u=0..\<infinity>. \<bar>exp (-u * x) * sin x\<bar> = \<bar>sin x\<bar> / x"
proof (subst interval_integral_FTC_nonneg)
  let ?F = "\<lambda>u. 1 / x * (1 - exp (- u * x)) * \<bar>sin x\<bar>"
  show "\<And>t. (?F has_real_derivative \<bar>exp (- t * x) * sin x\<bar>) (at t)"
    using \<open>0 < x\<close> by (auto intro!: derivative_eq_intros simp: abs_mult)
  show "((?F \<circ> real_of_ereal) \<longlongrightarrow> 0) (at_right 0)"
    using \<open>0 < x\<close> by (auto simp: zero_ereal_def ereal_tendsto_simps intro!: tendsto_eq_intros)
  have *: "((\<lambda>t. exp (- t * x)) \<longlongrightarrow> 0) at_top"
    using \<open>0 < x\<close>
    by (auto intro!: exp_at_bot[THEN filterlim_compose] filterlim_tendsto_pos_mult_at_top filterlim_ident
             simp: filterlim_uminus_at_bot mult.commute[of _ x])
  show "((?F \<circ> real_of_ereal) \<longlongrightarrow> \<bar>sin x\<bar> / x) (at_left \<infinity>)"
    using \<open>0 < x\<close> unfolding ereal_tendsto_simps
    by (intro filterlim_compose[OF _ *]) (auto intro!: tendsto_eq_intros filterlim_ident)
qed auto

lemma
  shows integrable_inverse_1_plus_square:
      "set_integrable lborel (einterval (-\<infinity>) \<infinity>) (\<lambda>x. inverse (1 + x^2))"
  and LBINT_inverse_1_plus_square:
      "LBINT x=-\<infinity>..\<infinity>. inverse (1 + x^2) = pi"
proof -
  have 1: "- (pi / 2) < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> (tan has_real_derivative 1 + (tan x)\<^sup>2) (at x)" for x
    using cos_gt_zero_pi[of x] by (subst tan_sec) (auto intro!: DERIV_tan simp: power_inverse)
  have 2: "- (pi / 2) < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> isCont (\<lambda>x. 1 + (tan x)\<^sup>2) x" for x
    using cos_gt_zero_pi[of x] by auto
  show "LBINT x=-\<infinity>..\<infinity>. inverse (1 + x^2) = pi"
    by (subst interval_integral_substitution_nonneg[of "-pi/2" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 filterlim_tan_at_right
             simp add: ereal_tendsto_simps filterlim_tan_at_left add_nonneg_eq_0_iff)
  show "set_integrable lborel (einterval (-\<infinity>) \<infinity>) (\<lambda>x. inverse (1 + x^2))"
    by (subst interval_integral_substitution_nonneg[of "-pi/2" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 filterlim_tan_at_right
             simp add: ereal_tendsto_simps filterlim_tan_at_left add_nonneg_eq_0_iff)
qed

lemma
  shows integrable_I0i_1_div_plus_square:
    "interval_lebesgue_integrable lborel 0 \<infinity> (\<lambda>x. 1 / (1 + x^2))"
  and LBINT_I0i_1_div_plus_square:
    "LBINT x=0..\<infinity>. 1 / (1 + x^2) = pi / 2"
proof -
  have 1: "0 < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> (tan has_real_derivative 1 + (tan x)\<^sup>2) (at x)" for x
    using cos_gt_zero_pi[of x] by (subst tan_sec) (auto intro!: DERIV_tan simp: power_inverse)
  have 2: "0 < x \<Longrightarrow> x * 2 < pi \<Longrightarrow> isCont (\<lambda>x. 1 + (tan x)\<^sup>2) x" for x
    using cos_gt_zero_pi[of x] by auto
  show "LBINT x=0..\<infinity>. 1 / (1 + x^2) = pi / 2"
    by (subst interval_integral_substitution_nonneg[of "0" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 tendsto_eq_intros
             simp add: ereal_tendsto_simps filterlim_tan_at_left zero_ereal_def add_nonneg_eq_0_iff)
  show "interval_lebesgue_integrable lborel 0 \<infinity> (\<lambda>x. 1 / (1 + x^2))"
    unfolding interval_lebesgue_integrable_def
    by (subst interval_integral_substitution_nonneg[of "0" "pi/2" tan "\<lambda>x. 1 + (tan x)^2"])
       (auto intro: derivative_eq_intros 1 2 tendsto_eq_intros
             simp add: ereal_tendsto_simps filterlim_tan_at_left zero_ereal_def add_nonneg_eq_0_iff)
qed

section \<open>The sinc function, and the sine integral (Si)\<close>

abbreviation sinc :: "real \<Rightarrow> real" where
  "sinc \<equiv> (\<lambda>x. if x = 0 then 1 else sin x / x)"

lemma sinc_at_0: "((\<lambda>x. sin x / x::real) \<longlongrightarrow> 1) (at 0)"
  using DERIV_sin [of 0] by (auto simp add: has_field_derivative_def field_has_derivative_at)

lemma isCont_sinc: "isCont sinc x"
proof cases
  assume "x = 0" then show ?thesis
    using LIM_equal [where g = "\<lambda>x. sin x / x" and a=0 and f=sinc and l=1]
    by (auto simp: isCont_def sinc_at_0)
next
  assume "x \<noteq> 0" show ?thesis
    by (rule continuous_transform_within [where d = "abs x" and f = "\<lambda>x. sin x / x"])
       (auto simp add: dist_real_def \<open>x \<noteq> 0\<close>)
qed

lemma continuous_on_sinc[continuous_intros]:
  "continuous_on S f \<Longrightarrow> continuous_on S (\<lambda>x. sinc (f x))"
  using continuous_on_compose[of S f sinc, OF _ continuous_at_imp_continuous_on]
  by (auto simp: isCont_sinc)

lemma borel_measurable_sinc[measurable]: "sinc \<in> borel_measurable borel"
  by (intro borel_measurable_continuous_on1 continuous_at_imp_continuous_on ballI isCont_sinc)

lemma sinc_AE: "AE x in lborel. sin x / x = sinc x"
  by (rule AE_I [where N = "{0}"], auto)

definition Si :: "real \<Rightarrow> real" where "Si t \<equiv> LBINT x=0..t. sin x / x"

lemma sinc_neg [simp]: "sinc (- x) = sinc x"
  by auto

(* TODO: Determine whether this can reasonably be eliminated by redefining Si. *)
lemma Si_alt_def : "Si t = LBINT x=0..t. sinc x"
proof cases
  assume "0 \<le> t" then show ?thesis
    using AE_lborel_singleton[of 0]
    by (auto simp: Si_def intro!: interval_lebesgue_integral_cong_AE)
next
  assume "\<not> 0 \<le> t" then show ?thesis
    unfolding Si_def using AE_lborel_singleton[of 0]
    by (subst (1 2) interval_integral_endpoints_reverse)
       (auto simp: Si_def intro!: interval_lebesgue_integral_cong_AE)
qed

lemma Si_neg:
  assumes "T \<ge> 0" shows "Si (- T) = - Si T"
proof -
  have "LBINT x=ereal 0..T. -1 *\<^sub>R sinc (- x) = LBINT y= ereal (- 0)..ereal (- T). sinc y"
    by (rule interval_integral_substitution_finite [OF assms])
       (auto intro: derivative_intros continuous_at_imp_continuous_on isCont_sinc)
  also have "(LBINT x=ereal 0..T. -1 *\<^sub>R sinc (- x)) = -(LBINT x=ereal 0..T. sinc x)"
    by (subst sinc_neg) (simp_all add: interval_lebesgue_integral_uminus)
  finally have *: "-(LBINT x=ereal 0..T. sinc x) = LBINT y= ereal 0..ereal (- T). sinc y"
    by simp
  show ?thesis
    using assms unfolding Si_alt_def
    by (subst zero_ereal_def)+ (auto simp add: * [symmetric])
qed

lemma integrable_sinc':
  "interval_lebesgue_integrable lborel (ereal 0) (ereal T) (\<lambda>t. sin (t * \<theta>) / t)"
proof -
  have *: "interval_lebesgue_integrable lborel (ereal 0) (ereal T) (\<lambda>t. \<theta> * sinc (t * \<theta>))"
    by (intro interval_lebesgue_integrable_mult_right interval_integrable_isCont continuous_within_compose3 [OF isCont_sinc])
       auto
  show ?thesis
    by (rule interval_lebesgue_integrable_cong_AE[THEN iffD1, OF _ _ _ *])
       (insert AE_lborel_singleton[of 0], auto)
qed

(* TODO: need a better version of FTC2 *)
lemma DERIV_Si: "(Si has_real_derivative sinc x) (at x)"
proof -
  have "(at x within {min 0 (x - 1)..max 0 (x + 1)}) = at x"
    by (intro at_within_interior) auto
  moreover have "min 0 (x - 1) \<le> x" "x \<le> max 0 (x + 1)"
    by auto
  ultimately show ?thesis
    using interval_integral_FTC2[of "min 0 (x - 1)" 0 "max 0 (x + 1)" sinc x]
    by (auto simp: continuous_at_imp_continuous_on isCont_sinc Si_alt_def[abs_def] zero_ereal_def
                   has_field_derivative_iff_has_vector_derivative
             split del: if_split)
qed

lemma isCont_Si: "isCont Si x"
  using DERIV_Si by (rule DERIV_isCont)

lemma borel_measurable_Si[measurable]: "Si \<in> borel_measurable borel"
  by (auto intro: isCont_Si continuous_at_imp_continuous_on borel_measurable_continuous_on1)

lemma Si_at_top_LBINT:
  "((\<lambda>t. (LBINT x=0..\<infinity>. exp (-(x * t)) * (x * sin t + cos t) / (1 + x^2))) \<longlongrightarrow> 0) at_top"
proof -
  let ?F = "\<lambda>x t. exp (- (x * t)) * (x * sin t + cos t) / (1 + x\<^sup>2) :: real"
  have int: "set_integrable lborel {0<..} (\<lambda>x. exp (- x) * (x + 1) :: real)"
    unfolding distrib_left
    using has_bochner_integral_I0i_power_exp_m[of 0] has_bochner_integral_I0i_power_exp_m[of 1]
    by (intro set_integral_add) (auto dest!: integrable.intros simp: ac_simps)

  have "((\<lambda>t::real. LBINT x:{0<..}. ?F x t) \<longlongrightarrow> LBINT x::real:{0<..}. 0) at_top"
  proof (rule integral_dominated_convergence_at_top[OF _ _ int], simp_all del: abs_divide split: split_indicator)
    have *: "0 < x \<Longrightarrow> \<bar>x * sin t + cos t\<bar> / (1 + x\<^sup>2) \<le> (x * 1 + 1) / 1" for x t :: real
      by (intro frac_le abs_triangle_ineq[THEN order_trans] add_mono)
         (auto simp add: abs_mult simp del: mult_1_right intro!: mult_mono)
    then have **: "1 \<le> t \<Longrightarrow> 0 < x \<Longrightarrow> \<bar>?F x t\<bar> \<le> exp (- x) * (x + 1)" for x t :: real
        by (auto simp add: abs_mult times_divide_eq_right[symmetric] simp del: times_divide_eq_right
                 intro!:  mult_mono)

    show "\<forall>\<^sub>F i in at_top. AE x in lborel. 0 < x \<longrightarrow> \<bar>?F x i\<bar> \<le> exp (- x) * (x + 1)"
      using eventually_ge_at_top[of "1::real"] ** by (auto elim: eventually_mono)
    show "AE x in lborel. 0 < x \<longrightarrow> (?F x \<longlongrightarrow> 0) at_top"
    proof (intro always_eventually impI allI)
      fix x :: real assume "0 < x"
      show "((\<lambda>t. exp (- (x * t)) * (x * sin t + cos t) / (1 + x\<^sup>2)) \<longlongrightarrow> 0) at_top"
      proof (rule Lim_null_comparison)
        show "\<forall>\<^sub>F t in at_top. norm (?F x t) \<le> exp (- (x * t)) * (x + 1)"
          using eventually_ge_at_top[of "1::real"] * \<open>0 < x\<close>
          by (auto simp add: abs_mult times_divide_eq_right[symmetric] simp del: times_divide_eq_right
                   intro!: mult_mono elim: eventually_mono)
        show "((\<lambda>t. exp (- (x * t)) * (x + 1)) \<longlongrightarrow> 0) at_top"
          by (auto simp: filterlim_uminus_at_top [symmetric]
                   intro!: filterlim_tendsto_pos_mult_at_top[OF tendsto_const] \<open>0<x\<close> filterlim_ident
                           tendsto_mult_left_zero filterlim_compose[OF exp_at_bot])
      qed
    qed
  qed
  then show "((\<lambda>t. (LBINT x=0..\<infinity>. exp (-(x * t)) * (x * sin t + cos t) / (1 + x^2))) \<longlongrightarrow> 0) at_top"
    by (simp add: interval_lebesgue_integral_0_infty)
qed

lemma Si_at_top_integrable:
  assumes "t \<ge> 0"
  shows "interval_lebesgue_integrable lborel 0 \<infinity> (\<lambda>x. exp (- (x * t)) * (x * sin t + cos t) / (1 + x\<^sup>2))"
  using \<open>0 \<le> t\<close> unfolding le_less
proof
  assume "0 = t" then show ?thesis
    using integrable_I0i_1_div_plus_square by simp
next
  assume [arith]: "0 < t"
  have *: "0 \<le> a \<Longrightarrow> 0 < x \<Longrightarrow> a / (1 + x\<^sup>2) \<le> a" for a x :: real
    using zero_le_power2[of x, arith] using divide_left_mono[of 1 "1+x\<^sup>2" a] by auto
  have "set_integrable lborel {0<..} (\<lambda>x. (exp (- x) * x) * (sin t/t) + exp (- x) * cos t)"
    using has_bochner_integral_I0i_power_exp_m[of 0] has_bochner_integral_I0i_power_exp_m[of 1]
    by (intro set_integral_add set_integrable_mult_left)
       (auto dest!: integrable.intros simp: ac_simps)
  from lborel_integrable_real_affine[OF this, of t 0]
  show ?thesis
    unfolding interval_lebesgue_integral_0_infty
    by (rule Bochner_Integration.integrable_bound) (auto simp: field_simps * split: split_indicator)
qed

lemma Si_at_top: "(Si \<longlongrightarrow> pi / 2) at_top"
proof -
  have "\<forall>\<^sub>F t in at_top. pi / 2 - (LBINT u=0..\<infinity>. exp (-(u * t)) * (u * sin t + cos t) / (1 + u^2)) = Si t"
    using eventually_ge_at_top[of 0]
  proof eventually_elim
    fix t :: real assume "t \<ge> 0"
    have "Si t = LBINT x=0..t. sin x * (LBINT u=0..\<infinity>. exp (-(u * x)))"
      unfolding Si_def using \<open>0 \<le> t\<close>
      by (intro interval_integral_discrete_difference[where X="{0}"]) (auto simp: LBINT_I0i_exp_mscale)
    also have "\<dots> = LBINT x. (LBINT u=ereal 0..\<infinity>. indicator {0 <..< t} x *\<^sub>R sin x * exp (-(u * x)))"
      using \<open>0\<le>t\<close> by (simp add: zero_ereal_def interval_lebesgue_integral_le_eq mult_ac)
    also have "\<dots> = LBINT x. (LBINT u. indicator ({0<..} \<times> {0 <..< t}) (u, x) *\<^sub>R (sin x * exp (-(u * x))))"
      by (subst interval_integral_Ioi) (simp_all add: indicator_times ac_simps)
    also have "\<dots> = LBINT u. (LBINT x. indicator ({0<..} \<times> {0 <..< t}) (u, x) *\<^sub>R (sin x * exp (-(u * x))))"
    proof (intro lborel_pair.Fubini_integral[symmetric] lborel_pair.Fubini_integrable)
      show "(\<lambda>(x, y). indicator ({0<..} \<times> {0<..<t}) (y, x) *\<^sub>R (sin x * exp (- (y * x))))
          \<in> borel_measurable (lborel \<Otimes>\<^sub>M lborel)" (is "?f \<in> borel_measurable _")
        by measurable

      have "AE x in lborel. indicator {0..t} x *\<^sub>R abs (sinc x) = LBINT y. norm (?f (x, y))"
        using AE_lborel_singleton[of 0] AE_lborel_singleton[of t]
      proof eventually_elim
        fix x :: real assume x: "x \<noteq> 0" "x \<noteq> t"
        have "LBINT y. \<bar>indicator ({0<..} \<times> {0<..<t}) (y, x) *\<^sub>R (sin x * exp (- (y * x)))\<bar> =
            LBINT y. \<bar>sin x\<bar> * exp (- (y * x)) * indicator {0<..} y * indicator {0<..<t} x"
          by (intro Bochner_Integration.integral_cong) (auto split: split_indicator simp: abs_mult)
        also have "\<dots> = \<bar>sin x\<bar> * indicator {0<..<t} x * (LBINT y=0..\<infinity>.  exp (- (y * x)))"
          by (cases "x > 0")
             (auto simp: field_simps interval_lebesgue_integral_0_infty split: split_indicator)
        also have "\<dots> = \<bar>sin x\<bar> * indicator {0<..<t} x * (1 / x)"
          by (cases "x > 0") (auto simp add: LBINT_I0i_exp_mscale)
        also have "\<dots> = indicator {0..t} x *\<^sub>R \<bar>sinc x\<bar>"
          using x by (simp add: field_simps split: split_indicator)
        finally show "indicator {0..t} x *\<^sub>R abs (sinc x) = LBINT y. norm (?f (x, y))"
          by simp
      qed
      moreover have "set_integrable lborel {0 .. t} (\<lambda>x. abs (sinc x))"
        by (auto intro!: borel_integrable_compact continuous_intros simp del: real_scaleR_def)
      ultimately show "integrable lborel (\<lambda>x. LBINT y. norm (?f (x, y)))"
        by (rule integrable_cong_AE_imp[rotated 2]) simp

      have "0 < x \<Longrightarrow> set_integrable lborel {0<..} (\<lambda>y. sin x * exp (- (y * x)))" for x :: real
          by (intro set_integrable_mult_right integrable_I0i_exp_mscale)
      then show "AE x in lborel. integrable lborel (\<lambda>y. ?f (x, y))"
        by (intro AE_I2) (auto simp: indicator_times split: split_indicator)
    qed
    also have "... = LBINT u=0..\<infinity>. (LBINT x=0..t. exp (-(u * x)) * sin x)"
      using \<open>0\<le>t\<close>
      by (auto simp: interval_lebesgue_integral_def zero_ereal_def ac_simps
               split: split_indicator intro!: Bochner_Integration.integral_cong)
    also have "\<dots> = LBINT u=0..\<infinity>. 1 / (1 + u\<^sup>2) - 1 / (1 + u\<^sup>2) * (exp (- (u * t)) * (u * sin t + cos t))"
      by (auto simp: divide_simps LBINT_I0c_exp_mscale_sin intro!: interval_integral_cong)
    also have "... = pi / 2 - (LBINT u=0..\<infinity>. exp (- (u * t)) * (u * sin t + cos t) / (1 + u^2))"
      using Si_at_top_integrable[OF \<open>0\<le>t\<close>] by (simp add: integrable_I0i_1_div_plus_square LBINT_I0i_1_div_plus_square)
    finally show "pi / 2 - (LBINT u=0..\<infinity>. exp (-(u * t)) * (u * sin t + cos t) / (1 + u^2)) = Si t" ..
  qed
  then show ?thesis
    by (rule Lim_transform_eventually)
       (auto intro!: tendsto_eq_intros Si_at_top_LBINT)
qed

subsection \<open>The final theorems: boundedness and scalability\<close>

lemma bounded_Si: "\<exists>B. \<forall>T. \<bar>Si T\<bar> \<le> B"
proof -
  have *: "0 \<le> y \<Longrightarrow> dist x y < z \<Longrightarrow> abs x \<le> y + z" for x y z :: real
    by (simp add: dist_real_def)

  have "eventually (\<lambda>T. dist (Si T) (pi / 2) < 1) at_top"
    using Si_at_top by (elim tendstoD) simp
  then have "eventually (\<lambda>T. 0 \<le> T \<and> \<bar>Si T\<bar> \<le> pi / 2 + 1) at_top"
    using eventually_ge_at_top[of 0] by eventually_elim (insert *[of "pi/2" "Si _" 1], auto)
  then have "\<exists>T. 0 \<le> T \<and> (\<forall>t \<ge> T. \<bar>Si t\<bar> \<le> pi / 2 + 1)"
    by (auto simp add: eventually_at_top_linorder)
  then obtain T where T: "0 \<le> T" "\<And>t. t \<ge> T \<Longrightarrow> \<bar>Si t\<bar> \<le> pi / 2 + 1"
    by auto
  moreover have "t \<le> - T \<Longrightarrow> \<bar>Si t\<bar> \<le> pi / 2 + 1" for t
    using T(1) T(2)[of "-t"] Si_neg[of "- t"] by simp
  moreover have "\<exists>M. \<forall>t. -T \<le> t \<and> t \<le> T \<longrightarrow> \<bar>Si t\<bar> \<le> M"
    by (rule isCont_bounded) (auto intro!: isCont_Si continuous_intros \<open>0 \<le> T\<close>)
  then obtain M where M: "\<And>t. -T \<le> t \<and> t \<le> T \<Longrightarrow> \<bar>Si t\<bar> \<le> M"
    by auto
  ultimately show ?thesis
    by (intro exI[of _ "max M (pi/2 + 1)"]) (meson le_max_iff_disj linorder_not_le order_le_less)
qed

lemma LBINT_I0c_sin_scale_divide:
  assumes "T \<ge> 0"
  shows "LBINT t=0..T. sin (t * \<theta>) / t = sgn \<theta> * Si (T * \<bar>\<theta>\<bar>)"
proof -
  { assume "0 < \<theta>"
    have "(LBINT t=ereal 0..T. sin (t * \<theta>) / t) = (LBINT t=ereal 0..T. \<theta> *\<^sub>R sinc (t * \<theta>))"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    also have "\<dots> = (LBINT t=ereal (0 * \<theta>)..T * \<theta>. sinc t)"
      apply (rule interval_integral_substitution_finite [OF assms])
      apply (subst mult.commute, rule DERIV_subset)
      by (auto intro!: derivative_intros continuous_at_imp_continuous_on isCont_sinc)
    also have "\<dots> = (LBINT t=ereal (0 * \<theta>)..T * \<theta>. sin t / t)"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    finally have "(LBINT t=ereal 0..T. sin (t * \<theta>) / t) = (LBINT t=ereal 0..T * \<theta>. sin t / t)"
      by simp
    hence "LBINT x. indicator {0<..<T} x * sin (x * \<theta>) / x =
        LBINT x. indicator {0<..<T * \<theta>} x * sin x / x"
      using assms \<open>0 < \<theta>\<close> unfolding interval_lebesgue_integral_def einterval_eq zero_ereal_def
        by (auto simp: ac_simps)
  } note aux1 = this
  { assume "0 > \<theta>"
    have [simp]: "integrable lborel (\<lambda>x. sin (x * \<theta>) * indicator {0<..<T} x / x)"
      using integrable_sinc' [of T \<theta>] assms
      by (simp add: interval_lebesgue_integrable_def ac_simps)
    have "(LBINT t=ereal 0..T. sin (t * -\<theta>) / t) = (LBINT t=ereal 0..T. -\<theta> *\<^sub>R sinc (t * -\<theta>))"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    also have "\<dots> = (LBINT t=ereal (0 * -\<theta>)..T * -\<theta>. sinc t)"
      apply (rule interval_integral_substitution_finite [OF assms])
      apply (subst mult.commute, rule DERIV_subset)
      by (auto intro!: derivative_intros continuous_at_imp_continuous_on isCont_sinc)
    also have "\<dots> = (LBINT t=ereal (0 * -\<theta>)..T * -\<theta>. sin t / t)"
      by (rule interval_integral_discrete_difference[of "{0}"]) auto
    finally have "(LBINT t=ereal 0..T. sin (t * -\<theta>) / t) = (LBINT t=ereal 0..T * -\<theta>. sin t / t)"
      by simp
    hence "LBINT x. indicator {0<..<T} x * sin (x * \<theta>) / x =
       - (LBINT x. indicator {0<..<- (T * \<theta>)} x * sin x / x)"
      using assms \<open>0 > \<theta>\<close> unfolding interval_lebesgue_integral_def einterval_eq zero_ereal_def
        by (auto simp add: field_simps mult_le_0_iff split: if_split_asm)
  } note aux2 = this
  show ?thesis
    using assms unfolding Si_def interval_lebesgue_integral_def sgn_real_def einterval_eq zero_ereal_def
    apply auto
    apply (erule aux1)
    apply (rule aux2)
    apply auto
    done
qed

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Connecting Polynomials with Homomorphism Locales\<close>

theory Ring_Hom_Poly
imports
  "HOL-Computational_Algebra.Euclidean_Algorithm"
  Ring_Hom
  Missing_Polynomial
begin

text\<open>@{term poly} as a homomorphism. Note that types differ.\<close>

interpretation poly_hom: comm_semiring_hom "\<lambda>p. poly p a" by (unfold_locales, auto)

interpretation poly_hom: comm_ring_hom "\<lambda>p. poly p a"..

interpretation poly_hom: idom_hom "\<lambda>p. poly p a"..

text \<open>@{term "(\<circ>\<^sub>p)"} as a homomorphism.\<close>

interpretation pcompose_hom: comm_semiring_hom "\<lambda>q. q \<circ>\<^sub>p p"
  using pcompose_add pcompose_mult pcompose_1 by (unfold_locales, auto)

interpretation pcompose_hom: comm_ring_hom "\<lambda>q. q \<circ>\<^sub>p p" ..

interpretation pcompose_hom: idom_hom "\<lambda>q. q \<circ>\<^sub>p p" ..

definition eval_poly :: "('a \<Rightarrow> 'b :: comm_semiring_1) \<Rightarrow> 'a :: zero poly \<Rightarrow> 'b \<Rightarrow> 'b" where
  [code del]: "eval_poly h p = poly (map_poly h p)"

lemma eval_poly_code[code]: "eval_poly h p x = fold_coeffs (\<lambda> a b. h a + x * b) p 0"
  by (induct p, auto simp: eval_poly_def)

lemma eval_poly_as_sum:
  fixes h :: "'a :: zero \<Rightarrow> 'b :: comm_semiring_1"
  assumes "h 0 = 0"
  shows "eval_poly h p x = (\<Sum>i\<le>degree p. x^i * h (coeff p i))"
  unfolding eval_poly_def
proof (induct p)
  case 0 show ?case using assms by simp
  next case (pCons a p) thus ?case
    proof (cases "p = 0")
      case True show ?thesis by (simp add: True map_poly_simps assms)
      next case False show ?thesis
        unfolding degree_pCons_eq[OF False]
        unfolding sum.atMost_Suc_shift
        unfolding map_poly_pCons[OF pCons(1)]
        by (simp add: pCons(2) sum_distrib_left mult.assoc)
  qed
qed

lemma coeff_const: "coeff [: a :] i = (if i = 0 then a else 0)"
  by (metis coeff_monom monom_0)

lemma x_as_monom: "[:0,1:] = monom 1 1"
  by (simp add: monom_0 monom_Suc)

lemma x_pow_n: "monom 1 1 ^ n = monom 1 n"
  by (induct n) (simp_all add: monom_0 monom_Suc)

lemma map_poly_eval_poly: assumes h0: "h 0 = 0"
  shows "map_poly h p = eval_poly (\<lambda> a. [: h a :]) p [:0,1:]" (is "?mp = ?ep")
proof (rule poly_eqI)
  fix i :: nat
  have 2: "(\<Sum>x\<le>i. \<Sum>xa\<le>degree p. (if xa = x then 1 else 0) * coeff [:h (coeff p xa):] (i - x))
    = h (coeff p i)" (is "sum ?f ?s = ?r")
  proof -
    have "sum ?f ?s = ?f i + sum ?f ({..i} - {i})"
      by (rule sum.remove[of _ i], auto)
    also have "sum ?f ({..i} - {i}) = 0"
      by (rule sum.neutral, intro ballI, rule sum.neutral, auto simp: coeff_const)
    also have "?f i = (\<Sum>xa\<le>degree p. (if xa = i then 1 else 0) * h (coeff p xa))" (is "_ = ?m")
      unfolding coeff_const by simp
    also have "\<dots> = ?r"
    proof (cases "i \<le> degree p")
      case True
      show ?thesis
        by (subst sum.remove[of _ i], insert True, auto)
    next
      case False
      hence [simp]: "coeff p i = 0" using le_degree by blast
      show ?thesis
        by (subst sum.neutral, auto simp: h0)
    qed
    finally show ?thesis by simp
  qed
  have h'0: "[: h 0 :] = 0" using h0 by auto
  show "coeff ?mp i = coeff ?ep i"
    unfolding coeff_map_poly[of h, OF h0]
    unfolding eval_poly_as_sum[of "\<lambda>a. [: h a :]", OF h'0]
    unfolding coeff_sum
    unfolding x_as_monom x_pow_n coeff_mult
    unfolding sum.swap[of _ _ "{..degree p}"]
    unfolding coeff_monom using 2 by auto
qed

lemma smult_as_map_poly: "smult a = map_poly ((*) a)"
  by (rule ext, rule poly_eqI, subst coeff_map_poly, auto)

subsection \<open>@{const map_poly} of Homomorphisms\<close>

context zero_hom begin
  text \<open>We will consider @{term hom} is always simpler than @{term "map_poly hom"}.\<close>
  lemma map_poly_hom_monom[simp]: "map_poly hom (monom a i) = monom (hom a) i"
    by(rule map_poly_monom, auto)
  lemma coeff_map_poly_hom[simp]: "coeff (map_poly hom p) i = hom (coeff p i)"
    by (rule coeff_map_poly, rule hom_zero)
end

locale map_poly_zero_hom = base: zero_hom
begin
  sublocale zero_hom "map_poly hom" by (unfold_locales, auto)
end

text \<open>@{const map_poly} preserves homomorphisms over addition.\<close>

context comm_monoid_add_hom
begin
  lemma map_poly_hom_add[hom_distribs]:
    "map_poly hom (p + q) = map_poly hom p + map_poly hom q"
    by (rule map_poly_add; simp add: hom_distribs)
end

locale map_poly_comm_monoid_add_hom = base: comm_monoid_add_hom
begin
  sublocale comm_monoid_add_hom "map_poly hom" by (unfold_locales, auto simp:hom_distribs)
end

text \<open>To preserve homomorphisms over multiplication, it demands commutative ring homomorphisms.\<close>
context comm_semiring_hom begin
  lemma map_poly_pCons_hom[hom_distribs]: "map_poly hom (pCons a p) = pCons (hom a) (map_poly hom p)"
    unfolding map_poly_simps by auto
  lemma map_poly_hom_smult[hom_distribs]:
    "map_poly hom (smult c p) = smult (hom c) (map_poly hom p)"
    by (induct p, auto simp: hom_distribs)
  lemma poly_map_poly[simp]: "poly (map_poly hom p) (hom x) = hom (poly p x)"
    by (induct p; simp add: hom_distribs)
end

locale map_poly_comm_semiring_hom = base: comm_semiring_hom
begin
  sublocale map_poly_comm_monoid_add_hom..
  sublocale comm_semiring_hom "map_poly hom"
  proof
    show "map_poly hom 1 = 1" by simp
    fix p q show "map_poly hom (p * q) = map_poly hom p * map_poly hom q"
      by (induct p, auto simp: hom_distribs)
  qed
end

locale map_poly_comm_ring_hom = base: comm_ring_hom
begin
  sublocale map_poly_comm_semiring_hom..
  sublocale comm_ring_hom "map_poly hom"..
end

locale map_poly_idom_hom = base: idom_hom
begin
  sublocale map_poly_comm_ring_hom..
  sublocale idom_hom "map_poly hom"..
end

subsubsection \<open>Injectivity\<close>

locale map_poly_inj_zero_hom = base: inj_zero_hom
begin
  sublocale inj_zero_hom "map_poly hom"
  proof (unfold_locales)
    fix p q :: "'a poly" assume "map_poly hom p = map_poly hom q"
    from cong[of "\<lambda>p. coeff p _", OF refl this] show "p = q" by (auto intro: poly_eqI)
  qed simp
end

locale map_poly_inj_comm_monoid_add_hom = base: inj_comm_monoid_add_hom
begin
  sublocale map_poly_comm_monoid_add_hom..
  sublocale map_poly_inj_zero_hom..
  sublocale inj_comm_monoid_add_hom "map_poly hom"..
end

locale map_poly_inj_comm_semiring_hom = base: inj_comm_semiring_hom
begin
  sublocale map_poly_comm_semiring_hom..
  sublocale map_poly_inj_zero_hom..
  sublocale inj_comm_semiring_hom "map_poly hom"..
end

locale map_poly_inj_comm_ring_hom = base: inj_comm_ring_hom
begin
  sublocale map_poly_inj_comm_semiring_hom..
  sublocale inj_comm_ring_hom "map_poly hom"..
end

locale map_poly_inj_idom_hom = base: inj_idom_hom
begin
  sublocale map_poly_inj_comm_ring_hom..
  sublocale inj_idom_hom "map_poly hom"..
end

lemma degree_map_poly_le: "degree (map_poly f p) \<le> degree p"
  by(induct p;auto)

lemma coeffs_map_poly: (* An exact variant *)
  assumes "f (lead_coeff p) = 0 \<longleftrightarrow> p = 0"
  shows "coeffs (map_poly f p) = map f (coeffs p)"
  unfolding coeffs_map_poly using assms by (simp add:coeffs_def)

lemma degree_map_poly: (* An exact variant *)
  assumes "f (lead_coeff p) = 0 \<longleftrightarrow> p = 0"
  shows   "degree (map_poly f p) = degree p"
  unfolding degree_eq_length_coeffs unfolding coeffs_map_poly[of f, OF assms] by simp

context zero_hom_0 begin
  lemma degree_map_poly_hom[simp]: "degree (map_poly hom p) = degree p"
    by (rule degree_map_poly, auto)
  lemma coeffs_map_poly_hom[simp]: "coeffs (map_poly hom p) = map hom (coeffs p)"
    by (rule coeffs_map_poly, auto)
  lemma hom_lead_coeff[simp]: "lead_coeff (map_poly hom p) = hom (lead_coeff p)"
    by simp
end

context comm_semiring_hom begin

  interpretation map_poly_hom: map_poly_comm_semiring_hom..

  lemma poly_map_poly_0[simp]:
    "poly (map_poly hom p) 0 = hom (poly p 0)" (is "?l = ?r")
  proof-
    have "?l = poly (map_poly hom p) (hom 0)" by auto
    then show ?thesis unfolding poly_map_poly.
  qed

  lemma poly_map_poly_1[simp]:
    "poly (map_poly hom p) 1 = hom (poly p 1)" (is "?l = ?r")
  proof-
    have "?l = poly (map_poly hom p) (hom 1)" by auto
    then show ?thesis unfolding poly_map_poly.
  qed

  lemma map_poly_hom_as_monom_sum:
    "(\<Sum>j\<le>degree p. monom (hom (coeff p j)) j) = map_poly hom p"
  proof -
    show ?thesis
      by (subst(6) poly_as_sum_of_monoms'[OF le_refl, symmetric], simp add: hom_distribs)
  qed

  lemma map_poly_pcompose[hom_distribs]:
    "map_poly hom (f \<circ>\<^sub>p g) = map_poly hom f \<circ>\<^sub>p map_poly hom g"
    by (induct f arbitrary: g; auto simp: hom_distribs)

end

context comm_semiring_hom begin

lemma eval_poly_0[simp]: "eval_poly hom 0 x = 0" unfolding eval_poly_def by simp
lemma eval_poly_monom: "eval_poly hom (monom a n) x = hom a * x ^ n"
  unfolding eval_poly_def
  unfolding map_poly_monom[of hom, OF hom_zero] using poly_monom.

lemma poly_map_poly_eval_poly: "poly (map_poly hom p) = eval_poly hom p"
  unfolding eval_poly_def..

lemma map_poly_eval_poly:
  "map_poly hom p = eval_poly (\<lambda> a. [: hom a :]) p [:0,1:]"
  by (rule map_poly_eval_poly, simp)

lemma degree_extension: assumes "degree p \<le> n"
  shows "(\<Sum>i\<le>degree p. x ^ i * hom (coeff p i))
      = (\<Sum>i\<le>n. x ^ i * hom (coeff p i))" (is "?l = ?r")
proof -
  let ?f = "\<lambda> i. x ^ i * hom (coeff p i)"
  define m where "m = n - degree p"
  have n: "n = degree p + m" unfolding m_def using assms by auto
  have "?r = (\<Sum> i \<le> degree p + m. ?f i)" unfolding n ..
  also have "\<dots> = ?l + sum ?f {Suc (degree p) .. degree p + m}"
    by (subst sum.union_disjoint[symmetric], auto intro: sum.cong)
  also have "sum ?f {Suc (degree p) .. degree p + m} = 0"
    by (rule sum.neutral, auto simp: coeff_eq_0)
  finally show ?thesis by simp
qed

lemma eval_poly_add[simp]: "eval_poly hom (p + q) x = eval_poly hom p x + eval_poly hom q x"
  unfolding eval_poly_def hom_distribs..

lemma eval_poly_sum: "eval_poly hom (\<Sum>k\<in>A. p k) x = (\<Sum>k\<in>A. eval_poly hom (p k) x)"
proof (induct A rule: infinite_finite_induct)
  case (insert a A)
  show ?case
    unfolding sum.insert[OF insert(1-2)] insert(3)[symmetric] by simp
qed (auto simp: eval_poly_def)

lemma eval_poly_poly: "eval_poly hom p (hom x) = hom (poly p x)"
  unfolding eval_poly_def by auto

end

context comm_ring_hom begin
  interpretation map_poly_hom: map_poly_comm_ring_hom..

  lemma pseudo_divmod_main_hom:
    "pseudo_divmod_main (hom lc) (map_poly hom q) (map_poly hom r) (map_poly hom d) dr i =
     map_prod (map_poly hom) (map_poly hom) (pseudo_divmod_main lc q r d dr i)"
  proof-
    show ?thesis by (induct lc q r d dr i rule:pseudo_divmod_main.induct, auto simp: Let_def hom_distribs)
  qed
end

lemma(in inj_comm_ring_hom) pseudo_divmod_hom:
  "pseudo_divmod (map_poly hom p) (map_poly hom q) =
   map_prod (map_poly hom) (map_poly hom) (pseudo_divmod p q)"
  unfolding pseudo_divmod_def using pseudo_divmod_main_hom[of _ 0] by (cases "q = 0",auto)

lemma(in inj_idom_hom) pseudo_mod_hom:
  "pseudo_mod (map_poly hom p) (map_poly hom q) = map_poly hom (pseudo_mod p q)"
  using pseudo_divmod_hom unfolding pseudo_mod_def by auto

lemma(in idom_hom) map_poly_pderiv[hom_distribs]:
  "map_poly hom (pderiv p) = pderiv (map_poly hom p)"
proof (induct p rule: pderiv.induct)
  case (1 a p)
  then show ?case unfolding pderiv.simps map_poly_pCons_hom by (cases "p = 0", auto simp: hom_distribs)
qed

context field_hom
begin

lemma map_poly_pdivmod[hom_distribs]:
  "map_prod (map_poly hom) (map_poly hom) (p div q, p mod q) =
    (map_poly hom p div map_poly hom q, map_poly hom p mod map_poly hom q)"
  (is "?l = ?r")
proof -
  let ?mp = "map_poly hom"
  interpret map_poly_hom: map_poly_idom_hom..
  obtain r s where dm: "(p div q, p mod q) = (r, s)"
    by force
  hence r: "r = p div q" and s: "s = p mod q"
    by simp_all
  from dm [folded pdivmod_pdivmodrel] have "eucl_rel_poly p q (r, s)"
    by auto
  from this[unfolded eucl_rel_poly_iff]
  have eq: "p = r * q + s" and cond: "(if q = 0 then r = 0 else s = 0 \<or> degree s < degree q)" by auto
  from arg_cong[OF eq, of ?mp, unfolded map_poly_add]
  have eq: "?mp p = ?mp q * ?mp r + ?mp s" by (auto simp: hom_distribs)
  from cond have cond: "(if ?mp q = 0 then ?mp r = 0 else ?mp s = 0 \<or> degree (?mp s) < degree (?mp q))"
    by simp
  from eq cond have "eucl_rel_poly (?mp p) (?mp q) (?mp r, ?mp s)"
    unfolding eucl_rel_poly_iff by auto
  from this[unfolded pdivmod_pdivmodrel]
  show ?thesis unfolding dm prod.simps by simp
qed

lemma map_poly_div[hom_distribs]: "map_poly hom (p div q) = map_poly hom p div map_poly hom q"
  using map_poly_pdivmod[of p q] by simp

lemma map_poly_mod[hom_distribs]: "map_poly hom (p mod q) = map_poly hom p mod map_poly hom q"
  using map_poly_pdivmod[of p q] by simp

end

locale field_hom' = field_hom hom
  for hom :: "'a :: {field_gcd} \<Rightarrow> 'b :: {field_gcd}"
begin

lemma map_poly_normalize[hom_distribs]: "map_poly hom (normalize p) = normalize (map_poly hom p)"
  by (simp add: normalize_poly_def hom_distribs)

lemma map_poly_gcd[hom_distribs]: "map_poly hom (gcd p q) = gcd (map_poly hom p) (map_poly hom q)"
  by (induct p q rule: eucl_induct)
    (simp_all add: map_poly_normalize ac_simps hom_distribs)

end

definition div_poly :: "'a :: euclidean_semiring \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
  "div_poly a p = map_poly (\<lambda> c. c div a) p"

lemma smult_div_poly: assumes "\<And> c. c \<in> set (coeffs p) \<Longrightarrow> a dvd c"
  shows "smult a (div_poly a p) = p"
  unfolding smult_as_map_poly div_poly_def
  by (subst map_poly_map_poly, force, subst map_poly_idI, insert assms, auto)

lemma coeff_div_poly: "coeff (div_poly a f) n = coeff f n div a"
  unfolding div_poly_def
  by (rule coeff_map_poly, auto)

locale map_poly_inj_idom_divide_hom = base: inj_idom_divide_hom
begin
sublocale map_poly_idom_hom ..
sublocale map_poly_inj_zero_hom ..
sublocale inj_idom_hom "map_poly hom" ..
lemma divide_poly_main_hom: defines "hh \<equiv> map_poly hom"
  shows "hh (divide_poly_main lc f g h i j) = divide_poly_main (hom lc) (hh f) (hh g) (hh h) i j"
  unfolding hh_def
proof (induct j arbitrary: lc f g h i)
  case (Suc j lc f g h i)
  let ?h = "map_poly hom"
  show ?case unfolding divide_poly_main.simps Let_def
    unfolding base.coeff_map_poly_hom base.hom_div[symmetric] base.hom_mult[symmetric] base.eq_iff
      if_distrib[of ?h] hom_zero
    by (rule if_cong[OF refl _ refl], subst Suc, simp add: hom_minus hom_add hom_mult)
qed simp

sublocale inj_idom_divide_hom "map_poly hom"
proof
  fix f g :: "'a poly"
  let ?h = "map_poly hom"
  show "?h (f div g) = (?h f) div (?h g)" unfolding divide_poly_def if_distrib[of ?h]
    divide_poly_main_hom by simp
qed

lemma order_hom: "order (hom x) (map_poly hom f) = order x f"
  unfolding Polynomial.order_def unfolding hom_dvd_iff[symmetric]
  unfolding hom_power by (simp add: base.hom_uminus)
end

subsection \<open>Example Interpretations\<close>

abbreviation "of_int_poly \<equiv> map_poly of_int"

interpretation of_int_poly_hom: map_poly_comm_semiring_hom of_int..
interpretation of_int_poly_hom: map_poly_comm_ring_hom of_int..
interpretation of_int_poly_hom: map_poly_idom_hom of_int..
interpretation of_int_poly_hom:
  map_poly_inj_comm_ring_hom "of_int :: int  \<Rightarrow> 'a :: {comm_ring_1,ring_char_0}" ..
interpretation of_int_poly_hom:
  map_poly_inj_idom_hom "of_int :: int  \<Rightarrow> 'a :: {idom,ring_char_0}" ..

text \<open>The following operations are homomorphic w.r.t. only @{class monoid_add}.\<close>

interpretation pCons_0_hom: injective "pCons 0" by (unfold_locales, auto)
interpretation pCons_0_hom: zero_hom_0 "pCons 0" by (unfold_locales, auto)
interpretation pCons_0_hom: inj_comm_monoid_add_hom "pCons 0" by (unfold_locales, auto)
interpretation pCons_0_hom: inj_ab_group_add_hom "pCons 0" by (unfold_locales, auto)

interpretation monom_hom: injective "\<lambda>x. monom x d" by (unfold_locales, auto)
interpretation monom_hom: inj_monoid_add_hom "\<lambda>x. monom x d" by (unfold_locales, auto simp: add_monom)
interpretation monom_hom: inj_comm_monoid_add_hom "\<lambda>x. monom x d"..

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                  April 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CPO
imports Infra
begin

(*****************************************************************

         1. Complete partial order (cpo)
         2. Continuity
         3. Tarski Theorem

 *****************************************************************)

definition
  directed ::  "'a::order set => bool"
  where
  directed_def : "directed X == ((X ~= {}) &
                                 (ALL x y. x : X & y : X -->
                                    (EX z. z : X & x <= z & y <= z)))"
(* 2009-1
axclass bot0 < order
consts Bot :: "'a::bot0"  (* Bottom *)

axclass
  bot < bot0
  bottom_bot : "Bot <= (x::'a::bot0)"
*)

class bot0 =
fixes Bot :: "'a::order"  ("Bot") (* Bottom *)

class bot = bot0 +
assumes bottom_bot : "Bot <= x"

(*
class Bot =
fixes Bot :: "'a::order"  (* Bottom *)

class bot = Bot +
assumes bottom_bot : "Bot <= x"
*)

(* 2009-1
axclass
  cpo < order
  complete_cpo : "(directed (X::'a::order set)) ==> X hasLUB"
*)

class cpo = order +
assumes complete_cpo : "(directed (X::'a::order set)) ==> X hasLUB"

(*** pointed cpo ***)

(*
axclass cpo_bot < cpo, bot
*)

class cpo_bot = cpo + bot

definition
  continuous  :: "('a::cpo => 'b::cpo) => bool"
  where
  continuous_def : "continuous f == ALL X.
                      directed X --> ((f ` X) hasLUB & LUB (f ` X) = f (LUB X))"
definition
  admissible  :: "('a::cpo => bool) => bool"
  where
  admissible_def : "admissible P == ALL X.
                      directed X --> (ALL x:X. P x) --> P (LUB X)"

(**********************************************************
                    small lemmas
 **********************************************************)

lemma complete_cpo_lm:
  "ALL (X::'a::cpo set). directed X --> X hasLUB"
by (simp add: complete_cpo)

(*** another definition of continuous ***)

lemma continuous_only_if: "continuous f ==>
          directed X --> (EX x. ((f x) isLUB (f ` X) & x isLUB X))"
apply (intro allI impI)
apply (insert complete_cpo_lm)
apply (drule_tac x="X" in spec)
apply (simp)
apply (insert LUB_is[of X], simp)

apply (simp add: hasLUB_def)
apply (erule exE)
apply (rule_tac x="x" in exI)

apply (simp add: continuous_def)
apply (drule_tac x="X" in spec)
apply (simp)

apply (erule conjE)
apply (simp add: LUB_iff)

apply (insert LUB_unique[of "LUB X" X])
by (simp)

lemma continuous_if:
    "ALL X. directed X --> (EX x. ((f x) isLUB (f ` X) & x isLUB X))
     ==> continuous f"
apply (simp add: continuous_def)
apply (intro allI impI)
apply (drule_tac x="X" in spec)
apply (simp)
apply (elim conjE exE)

apply (subgoal_tac "(f ` X) hasLUB", simp)
apply (simp add: LUB_iff)
apply (subgoal_tac "x = LUB X", simp)
apply (rule LUB_unique)
apply (simp)
apply (rule LUB_is)

apply (simp add: hasLUB_def)
apply (rule_tac x="x" in exI, simp)

apply (simp add: hasLUB_def)
apply (rule_tac x="f x" in exI, simp)
done

(*** iff ***)

lemma continuous_iff: "continuous f =
   (ALL X. directed X --> (EX x. ((f x) isLUB (f ` X) & x isLUB X)))"
apply (rule iffI)
apply (simp add: continuous_only_if)
apply (simp add: continuous_if)
done

(**********************************************************
             lemmas and theorems for Tarski
 **********************************************************)

(* LUB is not affected by Bot *)

lemma LUB_with_Bot:
  "((x::('a::cpo_bot)) isLUB {x. f x | x = Bot}) = (x isLUB {x. f x})"
apply (rule iffI)

apply (simp add: isLUB_def isUB_def)
apply (erule conjE)
apply (intro allI impI)
apply (rotate_tac 1)
apply (drule_tac x="y" in spec)
apply (rotate_tac -1)
apply (drule mp)
apply (intro allI)
apply (drule_tac x="ya" in spec)
apply (simp add: bottom_bot)
apply (assumption)

apply (simp add: isLUB_def isUB_def bottom_bot)
done

(************************************************************)

(* if x<=y then {x,y} is a directed set. *)
(* this is used in a proof for continuous_mono *)

lemma directed_x_y: "x <= y ==> directed {x, y}"
apply (simp add: directed_def)
apply (intro allI impI)
apply (rule_tac x="y" in exI)
by (auto)

(* the least upper bound of a set {x,y} *)
(* this is used in a proof for continuous_mono *)

lemma LUB_x_y: "[| x <= y ; z isLUB {x, y} |] ==> z = y"
apply (simp only: isUB_def isLUB_def)
apply (elim conjE)
apply (drule_tac x="y" in spec, simp)
apply (drule_tac x="y" in spec, simp)
done

(************************ continuity *****************************)

(* f is continuous --> f is monotonic *)

lemma continuous_mono: "continuous f ==> mono f"
apply (simp add: continuous_iff mono_def)
apply (intro allI impI)
apply (rename_tac A B)
apply (drule_tac x="{A,B}" in spec)
apply (simp add: directed_x_y)
apply (erule exE)
apply (erule conjE)

apply (subgoal_tac "x = B")
apply (simp add: isUB_def isLUB_def)
apply (simp add: LUB_x_y)
done

(* directed and functions *)

lemma directed_continuous:
  "[| continuous f ; directed X |] ==> directed (f ` X)"
apply (insert continuous_mono[of f])
apply (simp add: continuous_iff directed_def)
apply (drule_tac x="X" in spec)
apply (simp)
apply (intro allI impI)
apply (simp add: in_image_set)
apply (elim conjE exE)

apply (drule_tac x="ya" in spec)
apply (drule_tac x="yb" in spec)
apply (simp)
apply (elim conjE exE)

apply (rule_tac x="f z" in exI)
apply (rule conjI)
apply (rule_tac x="z" in exI, simp)

by (simp add: mono_def)

(* composition of continuous functions *)

lemma compo_continuous:
  "[| continuous f ; continuous g |] ==> continuous (g o f)"
apply (insert directed_continuous[of f])

apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec)
apply (drule_tac x="f ` X" in spec)
apply (simp)
apply (elim conjE exE)
apply (rule_tac x="x" in exI)
(* Isabelle 2013  apply (simp add: image_compose) *)
apply (simp add: image_comp)

apply (subgoal_tac "xa = f x", simp)
apply (simp add: LUB_unique)
done

(*********************** Tarski continuous ****************************)

lemma Tarski_directed_lm1:
  "mono (f::('a::cpo_bot => 'a::cpo_bot)) ==> (f ^^ n) Bot <= (f ^^ (n+1)) Bot"
apply (induct_tac n)
apply (simp add: bottom_bot)
apply (simp add: mono_def)
done

lemma Tarski_directed_lm2:
  "mono (f::('a::cpo_bot => 'a::cpo_bot)) ==> (f ^^ n) Bot <= (f ^^ (n+m)) Bot"
apply (induct_tac m)
apply (simp)
apply (insert Tarski_directed_lm1[of f])
apply (rule order_trans)
apply (simp)
apply (simp)
done

lemma Tarski_directed:
  "mono (f::('a::cpo_bot => 'a::cpo_bot)) ==> directed {x. EX n. x = (f^^n) Bot}"
apply (simp add: directed_def)

apply (rule conjI)
apply (rule_tac x="Bot" in exI)
apply (rule_tac x="0" in exI)
apply (simp)

apply (intro allI impI)
apply (elim conjE exE)

apply (rename_tac x y n m)
apply (case_tac "m <= n")

apply (rule_tac x="x" in exI)
apply (rule conjI)
apply (rule_tac x="n" in exI)
apply (assumption)

apply (simp)
apply (subgoal_tac "(f ^^ m) Bot <= (f ^^ (m + (n-m))) Bot", simp)
apply (rule Tarski_directed_lm2, simp)

apply (rule_tac x="y" in exI)
apply (rule conjI)
apply (rule_tac x="m" in exI)
apply (assumption)

      (* ~ m <= n *)
apply (simp)
apply (subgoal_tac "(f ^^ n) Bot <= (f ^^ (n + (m-n))) Bot", simp)
apply (rule Tarski_directed_lm2, simp)
done

lemma Tarski_image_expand_lm:
  "f ` {x. EX n. x = (f ^^ n) Bot} = {x. EX n. x = f ((f ^^ n) Bot)}"
apply (auto simp add: image_Collect)
done

lemma Tarski_by_continuity:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==>
    (EX x. f x isLUB {x. EX n. x = f((f^^n) Bot)} &
             x isLUB {x. EX n. x =   (f^^n) Bot })"
apply (insert continuous_mono[of f])
apply (simp)

apply (simp add: continuous_iff)
apply (drule_tac x="{x. EX n. x = (f ^^ n) Bot}" in spec)
apply (simp add: Tarski_directed)
apply (erule exE)
apply (rule_tac x="x" in exI)
apply (simp add: Tarski_image_expand_lm)
done

(******)

lemma Tarski_LUB_lm:
  "(EX n. (x = ((f::('a::cpo_bot => 'a::cpo_bot)) ^^ n) Bot) )
   = ((EX n. x = (f ^^ (Suc n)) Bot) | x = Bot)"
apply (rule iffI)

(* ==> *)
apply (erule exE)
apply (insert nat_zero_or_Suc)
apply (drule_tac x="n" in spec)
apply (erule disjE)
apply (simp)

apply (erule exE)
apply (rule disjI1)
apply (rule_tac x="m" in exI)
apply (simp)

(* <== *)
apply (erule disjE)
apply (erule exE)
apply (rule_tac x="Suc n" in exI)
apply (simp)
apply (rule_tac x="0" in exI)
apply (simp)
done

(******)

lemma Tarski_LUB:
  "ALL (f::('a::cpo_bot => 'a::cpo_bot)) x.
    (x::'a::cpo_bot) isLUB {x. EX n. x = f((f^^n) Bot)} =
                   x isLUB {x. EX n. x =   (f^^n) Bot }"
apply (simp add: Tarski_LUB_lm LUB_with_Bot)
done

(******)

lemma Tarski_least_lm:
  "[| mono (f::('a::cpo_bot => 'a::cpo_bot)) ; y = f y |]
   ==> (f^^n) Bot <= y"
apply (induct_tac n)
apply (simp add: bottom_bot)
apply (simp add: mono_def)
apply (drule_tac x="(f ^^ n) Bot" in spec)
apply (drule_tac x="y" in spec)
by (simp)

lemma Tarski_least:
  "[| mono (f::('a::cpo_bot => 'a::cpo_bot)) ;
      x isLUB {x. EX n. x = (f^^n) Bot } ; y = f y |]
   ==> x <= y"
apply (simp add: isLUB_def)
apply (erule conjE)
apply (drule_tac x="y" in spec)
apply (drule mp)
apply (simp add: isUB_def)
apply (intro allI impI)
apply (erule exE)
apply (simp add: Tarski_least_lm)
by (assumption)

(*-------------------*
 |       Tarski      |
 *-------------------*)

theorem Tarski_thm:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==>
    f hasLFP & LFP f isLUB {x. EX n. x = (f^^n) Bot}"
apply (insert Tarski_by_continuity[of f])
apply (simp add: Tarski_LUB)
apply (erule exE)

apply (subgoal_tac "x isLFP f")        (* ...1 *)
apply (simp add: isLFP_LFP hasLFP_def)
apply (rule_tac x="x" in exI, simp)

      (* 1 *)
apply (simp add: isLFP_def)
apply (erule conjE)
apply (simp add: LUB_unique)
apply (intro allI impI)
apply (rule Tarski_least[of f])
apply (simp_all add: continuous_mono)
done

(*-------------------*
 |    Tarski LUB     |
 *-------------------*)

theorem Tarski_thm_LFP_LUB:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==>
    LFP f = LUB {x. EX n. x = (f^^n) Bot}"
apply (insert Tarski_thm[of f])
apply (auto simp add: isLUB_LUB)
done

(*--------------------*
 | Tarski (existency) |
 *--------------------*)

theorem Tarski_thm_EX:
  "continuous (f::('a::cpo_bot => 'a::cpo_bot)) ==> f hasLFP"
by (simp add: Tarski_thm)

(*========================================================*
 |           Fixed Point Induction (pointed CPO)          |
 *========================================================*)

theorem cpo_fixpoint_induction:
  "[| (R::'a::cpo_bot => bool) Bot ; continuous f ; admissible R ;
     inductivefun R f |]
   ==> f hasLFP & R (LFP f)"
apply (insert Tarski_thm[of f], simp)
apply (simp add: admissible_def)
apply (drule_tac x="{x. EX n. x = (f^^n) Bot }" in spec)
apply (simp add: Tarski_directed continuous_mono)
apply (auto simp add: inductivefun_all_n)
apply (simp add: isLUB_LUB)
done

theorem cpo_fixpoint_induction_R:
  "[| (R::'a::cpo_bot => bool) Bot ; continuous f ; admissible R ;
     inductivefun R f |]
   ==> R (LFP f)"
by (simp add: cpo_fixpoint_induction)

(*----------------------------------------------------------*
 |                                                          |
 |       Fixed point induction for refinement (CPO)         |
 |                                                          |
 *----------------------------------------------------------*)

(************************************************************
         admissibility lemma for refinement for cpo
 ************************************************************)

lemma admissible_Rev_fun: "admissible (Rev_fun X)"
apply (simp add: Rev_fun_def)
apply (simp add: admissible_def)
by (auto simp add: LUB_least complete_cpo)

(*** Bot ***)

lemma Rev_fun_Bot: "Rev_fun (X::'a::bot) Bot"
by (simp add: Rev_fun_def bottom_bot)

(************************************************************
         Fixed Point Induction (CPO) for refinement
 ************************************************************)

theorem cpo_fixpoint_induction_rev:
  "[| continuous f ; f X <= X |]
   ==> LFP f <= (X::'a::cpo_bot)"
apply (insert cpo_fixpoint_induction[of "(Rev_fun X)" f])
apply (simp add: admissible_Rev_fun Rev_fun_Bot)
apply (subgoal_tac "inductivefun (Rev_fun X) f")
apply (simp add: Rev_fun_def)

      (* inductiveness *)
apply (simp add: inductivefun_def Rev_fun_def)
apply (intro allI impI)
apply (insert continuous_mono[of f])
apply (simp add: mono_def)
apply (drule_tac x="x" in spec)
apply (drule_tac x="X" in spec)
by (simp)

(*** EX version ***)

theorem cpo_fixpoint_induction_rev_EX:
  "[| continuous f ; f X <= X ; Y isLFP f |]
   ==> Y <= (X::'a::cpo_bot)"
apply (insert cpo_fixpoint_induction_rev[of f X])
by (auto simp add: isLFP_LFP)

(*****************************************************************)

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2005, 2006  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Fields - introduction\<close>

theory Field_ZF imports Ring_ZF

begin

text\<open>This theory covers basic facts about fields.\<close>

subsection\<open>Definition and basic properties\<close>

text\<open>In this section we define what is a field and list the basic properties
  of fields.\<close>

text\<open>Field is a notrivial commutative ring such that all
  non-zero elements have an inverse. We define the notion of being a field as
  a statement about three sets. The first set, denoted \<open>K\<close> is the
  carrier of the field. The second set, denoted \<open>A\<close> represents the
  additive operation on \<open>K\<close> (recall that in ZF set theory functions
  are sets). The third set \<open>M\<close> represents the multiplicative operation
  on \<open>K\<close>.\<close>

definition
  "IsAfield(K,A,M) \<equiv>
  (IsAring(K,A,M) \<and> (M {is commutative on} K) \<and>
  TheNeutralElement(K,A) \<noteq> TheNeutralElement(K,M) \<and>
  (\<forall>a\<in>K. a\<noteq>TheNeutralElement(K,A)\<longrightarrow>
  (\<exists>b\<in>K. M`\<langle>a,b\<rangle> = TheNeutralElement(K,M))))"

text\<open>The \<open>field0\<close> context extends the \<open>ring0\<close>
  context adding field-related assumptions and notation related to the
  multiplicative inverse.\<close>

locale field0 = ring0 K A M for K A M +
  assumes mult_commute: "M {is commutative on} K"

  assumes not_triv: "\<zero> \<noteq> \<one>"

  assumes inv_exists: "\<forall>a\<in>K. a\<noteq>\<zero> \<longrightarrow> (\<exists>b\<in>K. a\<cdot>b = \<one>)"

  fixes non_zero ("K\<^sub>0")
  defines non_zero_def[simp]: "K\<^sub>0 \<equiv> K-{\<zero>}"

  fixes inv ("_\<inverse> " [96] 97)
  defines inv_def[simp]: "a\<inverse> \<equiv> GroupInv(K\<^sub>0,restrict(M,K\<^sub>0\<times>K\<^sub>0))`(a)"

text\<open>The next lemma assures us that we are talking fields
  in the \<open>field0\<close> context.\<close>

lemma (in field0) Field_ZF_1_L1: shows "IsAfield(K,A,M)"
  using ringAssum mult_commute not_triv inv_exists IsAfield_def
  by simp

text\<open>We can use theorems proven in the \<open>field0\<close> context whenever we
  talk about a field.\<close>

lemma field_field0: assumes "IsAfield(K,A,M)"
  shows "field0(K,A,M)"
  using assms IsAfield_def field0_axioms.intro ring0_def field0_def
  by simp

text\<open>Let's have an explicit statement that the multiplication
  in fields is commutative.\<close>

lemma (in field0) field_mult_comm: assumes "a\<in>K"  "b\<in>K"
  shows "a\<cdot>b = b\<cdot>a"
  using mult_commute assms IsCommutative_def by simp

text\<open>Fields do not have zero divisors.\<close>

lemma (in field0) field_has_no_zero_divs: shows "HasNoZeroDivs(K,A,M)"
proof -
  { fix a b assume A1: "a\<in>K"  "b\<in>K" and A2: "a\<cdot>b = \<zero>"  and A3: "b\<noteq>\<zero>"
    from inv_exists A1 A3 obtain c where I: "c\<in>K" and II: "b\<cdot>c = \<one>"
      by auto
    from A2 have "a\<cdot>b\<cdot>c = \<zero>\<cdot>c" by simp
    with A1 I have "a\<cdot>(b\<cdot>c) = \<zero>"
      using Ring_ZF_1_L11 Ring_ZF_1_L6 by simp
    with A1 II have "a=\<zero> "using Ring_ZF_1_L3 by simp }
  then have "\<forall>a\<in>K.\<forall>b\<in>K. a\<cdot>b = \<zero> \<longrightarrow> a=\<zero> \<or> b=\<zero>" by auto
    then show ?thesis using HasNoZeroDivs_def by auto
qed

text\<open>$K_0$ (the set of nonzero field elements is closed with respect
  to multiplication.\<close>

lemma (in field0) Field_ZF_1_L2:
  shows "K\<^sub>0 {is closed under} M"
  using Ring_ZF_1_L4 field_has_no_zero_divs Ring_ZF_1_L12
    IsOpClosed_def by auto

text\<open>Any nonzero element has a right inverse that is nonzero.\<close>

lemma (in field0) Field_ZF_1_L3: assumes A1: "a\<in>K\<^sub>0"
  shows "\<exists>b\<in>K\<^sub>0. a\<cdot>b = \<one>"
proof -
  from inv_exists A1 obtain b where "b\<in>K" and "a\<cdot>b = \<one>"
    by auto
  with not_triv A1 show "\<exists>b\<in>K\<^sub>0. a\<cdot>b = \<one>"
    using Ring_ZF_1_L6 by auto
qed

text\<open>If we remove zero, the field with multiplication
  becomes a group and we can use all theorems proven in
  \<open>group0\<close> context.\<close>

theorem (in field0) Field_ZF_1_L4: shows
  "IsAgroup(K\<^sub>0,restrict(M,K\<^sub>0\<times>K\<^sub>0))"
  "group0(K\<^sub>0,restrict(M,K\<^sub>0\<times>K\<^sub>0))"
  "\<one> = TheNeutralElement(K\<^sub>0,restrict(M,K\<^sub>0\<times>K\<^sub>0))"
proof-
  let ?f = "restrict(M,K\<^sub>0\<times>K\<^sub>0)"
  have
    "M {is associative on} K"
    "K\<^sub>0 \<subseteq> K"  "K\<^sub>0 {is closed under} M"
    using Field_ZF_1_L1 IsAfield_def IsAring_def IsAgroup_def
      IsAmonoid_def Field_ZF_1_L2 by auto
  then have "?f {is associative on} K\<^sub>0"
    using func_ZF_4_L3 by simp
  moreover
  from not_triv have
    I: "\<one>\<in>K\<^sub>0 \<and> (\<forall>a\<in>K\<^sub>0. ?f`\<langle>\<one>,a\<rangle> = a \<and>  ?f`\<langle>a,\<one>\<rangle> = a)"
    using Ring_ZF_1_L2 Ring_ZF_1_L3 by auto
  then have "\<exists>n\<in>K\<^sub>0. \<forall>a\<in>K\<^sub>0. ?f`\<langle>n,a\<rangle> = a \<and>  ?f`\<langle>a,n\<rangle> = a"
    by blast
  ultimately have II: "IsAmonoid(K\<^sub>0,?f)" using IsAmonoid_def
    by simp
  then have "monoid0(K\<^sub>0,?f)" using monoid0_def by simp
  moreover note I
  ultimately show "\<one> = TheNeutralElement(K\<^sub>0,?f)"
    by (rule monoid0.group0_1_L4)
  then have "\<forall>a\<in>K\<^sub>0.\<exists>b\<in>K\<^sub>0. ?f`\<langle>a,b\<rangle> =  TheNeutralElement(K\<^sub>0,?f)"
    using Field_ZF_1_L3 by auto
  with II show "IsAgroup(K\<^sub>0,?f)" by (rule definition_of_group)
  then show "group0(K\<^sub>0,?f)" using group0_def by simp
qed

text\<open>The inverse of a nonzero field element is nonzero.\<close>

lemma (in field0) Field_ZF_1_L5: assumes A1: "a\<in>K"  "a\<noteq>\<zero>"
  shows "a\<inverse> \<in> K\<^sub>0"  "(a\<inverse>)\<^sup>2 \<in> K\<^sub>0"   "a\<inverse> \<in> K"  "a\<inverse> \<noteq> \<zero>"
proof -
  from A1 have "a \<in> K\<^sub>0" by simp
  then show "a\<inverse> \<in> K\<^sub>0" using Field_ZF_1_L4 group0.inverse_in_group
    by auto
  then show  "(a\<inverse>)\<^sup>2 \<in> K\<^sub>0"  "a\<inverse> \<in> K"  "a\<inverse> \<noteq> \<zero>"
    using Field_ZF_1_L2 IsOpClosed_def by auto
qed

text\<open>The inverse is really the inverse.\<close>

lemma (in field0) Field_ZF_1_L6: assumes A1: "a\<in>K"  "a\<noteq>\<zero>"
  shows "a\<cdot>a\<inverse> = \<one>"  "a\<inverse>\<cdot>a = \<one>"
proof -
  let ?f = "restrict(M,K\<^sub>0\<times>K\<^sub>0)"
  from A1 have
    "group0(K\<^sub>0,?f)"
    "a \<in> K\<^sub>0"
    using Field_ZF_1_L4 by auto
  then have
    "?f`\<langle>a,GroupInv(K\<^sub>0, ?f)`(a)\<rangle> = TheNeutralElement(K\<^sub>0,?f) \<and>
    ?f`\<langle>GroupInv(K\<^sub>0,?f)`(a),a\<rangle> = TheNeutralElement(K\<^sub>0, ?f)"
    by (rule group0.group0_2_L6)
  with A1 show "a\<cdot>a\<inverse> = \<one>"  "a\<inverse>\<cdot>a = \<one>"
    using Field_ZF_1_L5 Field_ZF_1_L4 by auto
qed

text\<open>A lemma with two field elements and cancelling.\<close>

lemma (in field0) Field_ZF_1_L7: assumes "a\<in>K" "b\<in>K" "b\<noteq>\<zero>"
  shows
  "a\<cdot>b\<cdot>b\<inverse> = a"
  "a\<cdot>b\<inverse>\<cdot>b = a"
  using assms Field_ZF_1_L5 Ring_ZF_1_L11 Field_ZF_1_L6 Ring_ZF_1_L3
  by auto

subsection\<open>Equations and identities\<close>

text\<open>This section deals with more specialized identities that are true in
  fields.\<close>

text\<open>$a/(a^2) = 1/a $ .\<close>

lemma (in field0) Field_ZF_2_L1: assumes A1: "a\<in>K"  "a\<noteq>\<zero>"
  shows "a\<cdot>(a\<inverse>)\<^sup>2 = a\<inverse>"
proof -
  have "a\<cdot>(a\<inverse>)\<^sup>2 = a\<cdot>(a\<inverse>\<cdot>a\<inverse>)" by simp
  also from A1 have "\<dots> =  (a\<cdot>a\<inverse>)\<cdot>a\<inverse>"
    using Field_ZF_1_L5 Ring_ZF_1_L11
    by simp
  also from A1 have "\<dots> = a\<inverse>"
    using Field_ZF_1_L6 Field_ZF_1_L5 Ring_ZF_1_L3
    by simp
  finally show "a\<cdot>(a\<inverse>)\<^sup>2 = a\<inverse>" by simp
qed

text\<open>If we multiply two different numbers by a nonzero number, the results
  will be different.\<close>

lemma (in field0) Field_ZF_2_L2:
  assumes "a\<in>K"  "b\<in>K"  "c\<in>K"  "a\<noteq>b"  "c\<noteq>\<zero>"
  shows "a\<cdot>c\<inverse> \<noteq> b\<cdot>c\<inverse>"
  using assms field_has_no_zero_divs Field_ZF_1_L5 Ring_ZF_1_L12B
  by simp

text\<open>We can put a nonzero factor on the other side of non-identity
  (is this the best way to call it?) changing it to the inverse.\<close>

lemma (in field0) Field_ZF_2_L3:
  assumes A1: "a\<in>K"  "b\<in>K"  "b\<noteq>\<zero>"  "c\<in>K"   and A2: "a\<cdot>b \<noteq> c"
  shows "a \<noteq> c\<cdot>b\<inverse>"
proof -
  from A1 A2 have "a\<cdot>b\<cdot>b\<inverse> \<noteq> c\<cdot>b\<inverse>"
    using  Ring_ZF_1_L4 Field_ZF_2_L2 by simp
  with A1 show "a \<noteq> c\<cdot>b\<inverse>" using Field_ZF_1_L7
    by simp
qed

text\<open>If if the inverse of $b$ is different than $a$, then the
  inverse of $a$ is different than $b$.\<close>

lemma (in field0) Field_ZF_2_L4:
  assumes "a\<in>K"  "a\<noteq>\<zero>" and "b\<inverse> \<noteq> a"
  shows "a\<inverse> \<noteq> b"
  using assms Field_ZF_1_L4 group0.group0_2_L11B
  by simp

text\<open>An identity with two field elements, one and an inverse.\<close>

lemma (in field0) Field_ZF_2_L5:
  assumes "a\<in>K"  "b\<in>K" "b\<noteq>\<zero>"
  shows "(\<one> \<ra> a\<cdot>b)\<cdot>b\<inverse> = a \<ra> b\<inverse>"
  using assms Ring_ZF_1_L4 Field_ZF_1_L5 Ring_ZF_1_L2 ring_oper_distr
    Field_ZF_1_L7 Ring_ZF_1_L3 by simp

text\<open>An identity with three field elements, inverse and cancelling.\<close>

lemma (in field0) Field_ZF_2_L6: assumes A1: "a\<in>K"  "b\<in>K"  "b\<noteq>\<zero>"  "c\<in>K"
  shows "a\<cdot>b\<cdot>(c\<cdot>b\<inverse>) = a\<cdot>c"
proof -
  from A1 have T: "a\<cdot>b \<in> K"  "b\<inverse> \<in> K"
    using Ring_ZF_1_L4 Field_ZF_1_L5 by auto
  with mult_commute A1 have "a\<cdot>b\<cdot>(c\<cdot>b\<inverse>) = a\<cdot>b\<cdot>(b\<inverse>\<cdot>c)"
    using IsCommutative_def by simp
  moreover
  from A1 T have "a\<cdot>b \<in> K"  "b\<inverse> \<in> K"  "c\<in>K"
    by auto
  then have "a\<cdot>b\<cdot>b\<inverse>\<cdot>c = a\<cdot>b\<cdot>(b\<inverse>\<cdot>c)"
    by (rule Ring_ZF_1_L11)
  ultimately have "a\<cdot>b\<cdot>(c\<cdot>b\<inverse>) = a\<cdot>b\<cdot>b\<inverse>\<cdot>c" by simp
  with A1 show "a\<cdot>b\<cdot>(c\<cdot>b\<inverse>) = a\<cdot>c"
    using Field_ZF_1_L7 by simp
qed

subsection\<open>1/0=0\<close>

text\<open>In ZF if $f: X\rightarrow Y$ and $x\notin X$ we have $f(x)=\emptyset$.
  Since $\emptyset$ (the empty set) in ZF is the same as zero of natural numbers we
  can claim that $1/0=0$ in certain sense. In this section we prove a theorem that
  makes makes it explicit.\<close>

text\<open>The next locale extends the \<open>field0\<close> locale to introduce notation
  for division operation.\<close>

locale fieldd = field0 +
  fixes division
  defines division_def[simp]: "division \<equiv> {\<langle>p,fst(p)\<cdot>snd(p)\<inverse>\<rangle>. p\<in>K\<times>K\<^sub>0}"

  fixes fdiv (infixl "\<fd>" 95)
  defines fdiv_def[simp]: "x\<fd>y \<equiv> division`\<langle>x,y\<rangle>"

text\<open>Division is a function on $K\times K_0$ with values in $K$.\<close>

lemma (in fieldd) div_fun: shows "division: K\<times>K\<^sub>0 \<rightarrow> K"
proof -
  have "\<forall>p \<in> K\<times>K\<^sub>0. fst(p)\<cdot>snd(p)\<inverse> \<in> K"
  proof
    fix p assume "p \<in> K\<times>K\<^sub>0"
    hence "fst(p) \<in> K" and "snd(p) \<in> K\<^sub>0" by auto
    then show  "fst(p)\<cdot>snd(p)\<inverse> \<in> K" using Ring_ZF_1_L4 Field_ZF_1_L5 by auto
  qed
  then have "{\<langle>p,fst(p)\<cdot>snd(p)\<inverse>\<rangle>. p\<in>K\<times>K\<^sub>0}: K\<times>K\<^sub>0 \<rightarrow> K"
    by (rule ZF_fun_from_total)
  thus ?thesis by simp
qed

text\<open>So, really $1/0=0$. The essential lemma is \<open>apply_0\<close> from standard
  Isabelle's \<open>func.thy\<close>.\<close>

theorem (in fieldd) one_over_zero: shows "\<one>\<fd>\<zero> = 0"
proof-
  have "domain(division) = K\<times>K\<^sub>0" using div_fun func1_1_L1
    by simp
  hence "\<langle>\<one>,\<zero>\<rangle> \<notin> domain(division)" by auto
  then show ?thesis using apply_0 by simp
qed

end


theory Extended_Real_Lemma_Bucket
imports Complex_Main "~~/src/HOL/Library/Extended_Real" "~~/src/HOL/Multivariate_Analysis/Extended_Real_Limits"
begin

lemma ereal_inverse_real: "\<bar>z\<bar> \<noteq> \<infinity> \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> ereal (inverse (real_of_ereal z)) = inverse z"
  by (cases z) simp_all

lemma ereal_inverse_mult:
  "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse (a * (b::ereal)) = inverse a * inverse b"
  by (cases a; cases b) auto

lemma tendsto_PInfty': "(f ---> \<infinity>) F = (\<forall>r>c. eventually (\<lambda>x. ereal r < f x) F)"
proof (subst tendsto_PInfty, intro iffI allI impI)
  assume A: "\<forall>r>c. eventually (\<lambda>x. ereal r < f x) F"
  fix r :: real
  from A have A: "eventually (\<lambda>x. ereal r < f x) F" if "r > c" for r using that by blast
  show "eventually (\<lambda>x. ereal r < f x) F"
  proof (cases "r > c")
    case False
    hence B: "ereal r \<le> ereal (c + 1)" by simp
    have "c < c + 1" by simp
    from A[OF this] show "eventually (\<lambda>x. ereal r < f x) F"
      by eventually_elim (rule le_less_trans[OF B])
  qed (simp add: A)
qed simp

lemma tendsto_zero_erealI:
  assumes "\<And>e. e > 0 \<Longrightarrow> eventually (\<lambda>x. \<bar>f x\<bar> < ereal e) F"
  shows   "(f ---> 0) F"
proof (subst filterlim_cong[OF refl refl])
  from assms[OF zero_less_one] show "eventually (\<lambda>x. f x = ereal (real_of_ereal (f x))) F"
    by eventually_elim (auto simp: ereal_real)
  hence "eventually (\<lambda>x. abs (real_of_ereal (f x)) < e) F" if "e > 0" for e using assms[OF that]
    by eventually_elim (simp add: real_less_ereal_iff that)
  hence "((\<lambda>x. real_of_ereal (f x)) ---> 0) F" unfolding tendsto_iff
    by (auto simp: tendsto_iff dist_real_def)
  thus "((\<lambda>x. ereal (real_of_ereal (f x))) ---> 0) F" by (simp add: zero_ereal_def)
qed

lemma tendsto_inverse_ereal:
  assumes lim:     "(f ---> (c :: ereal)) F"
  assumes nonneg:  "eventually (\<lambda>x. f x \<ge> 0) F"
  shows   "((\<lambda>x. inverse (f x)) ---> inverse c) F"
proof (cases "F = bot")
  assume F: "F \<noteq> bot"
  from F assms have c: "c \<ge> 0" by (rule tendsto_le_const)
  then consider "c = 0" | "c = \<infinity>" | c' where "c = ereal c'" "c' > 0"
    by (cases c) (auto simp: le_less)
  thus ?thesis
  proof cases
    fix c' assume c': "c = ereal c'" "c' > 0"
    with c' have f: "eventually (\<lambda>x. f x > 0) F" "eventually (\<lambda>x. f x < \<infinity>) F"
      by (intro order_tendstoD[OF lim]; simp)+
    hence "((ereal \<circ> (real_of_ereal \<circ> f)) ---> c) F"
      by (intro Lim_transform_eventually[OF _ lim], eventually_elim) (simp add: ereal_real)
    hence "((\<lambda>x. real_of_ereal (f x)) ---> c') F" by (simp add: c' o_def)
    with c' have "((inverse \<circ> real_of_ereal \<circ> f) ---> inverse c') F" unfolding o_def
      by (intro tendsto_inverse) simp_all
    with c' have "((ereal \<circ> inverse \<circ> real_of_ereal \<circ> f) ---> inverse c) F"
      by (simp add: o_def)
    moreover from f have "eventually (\<lambda>x. (ereal \<circ> inverse \<circ> real_of_ereal \<circ> f) x = inverse (f x)) F"
      by eventually_elim (simp add: ereal_inverse_real)

    ultimately show "((\<lambda>x. inverse (f x)) ---> inverse c) F"
      by (rule Lim_transform_eventually[rotated])
  next
    assume "c = 0"
    hence "c < \<infinity>" and c: "c = ereal 0" by simp_all
    note f = order_tendstoD(2)[OF lim this(1)]
    from lim c have lim': "((\<lambda>x. real_of_ereal (f x)) ---> 0) F"
      using lim_real_of_ereal[of f 0 F] by simp
    have "eventually (\<lambda>x. ereal r < inverse (f x)) F" if "r > 0" for r
    proof -
      from that have "inverse r > 0" by simp
      from nonneg f order_tendstoD(2)[OF lim' this] show ?thesis
      proof eventually_elim
        fix x assume "f x \<ge> 0" "f x < \<infinity>" "real_of_ereal (f x) < inverse r"
        with that show "inverse (f x) > ereal r" by (cases "f x") (simp_all add: field_simps)
      qed
    qed
    thus ?thesis by (simp add: c tendsto_PInfty'[of _ _ 0])
  next
    assume c: "c = \<infinity>"
    hence f: "eventually (\<lambda>x. f x > 0) F" by (intro order_tendstoD[OF lim]) simp_all
    {
      fix r :: real assume r: "r > 0"
      from tendsto_PInfty lim have "eventually (\<lambda>x. f x > ereal (inverse r)) F"
        by (simp add: tendsto_PInfty c)
      with f have "eventually (\<lambda>x. abs (inverse (f x)) < ereal r) F"
      proof eventually_elim
        fix x assume "f x > 0" "ereal (inverse r) < f x"
        with r show "abs (inverse (f x)) < ereal r" by (cases "f x") (simp_all add: field_simps)
      qed
    }
    with c show "((\<lambda>x. inverse (f x)) ---> inverse c) F" by (force intro: tendsto_zero_erealI)
  qed
qed simp

lemma continuous_inverse_ereal_nonneg [continuous_intros]: "continuous_on ({0..} :: ereal set) inverse"
unfolding continuous_on_def
proof clarify
  fix x :: ereal assume "x \<ge> 0"
  thus "(inverse ---> inverse x) (at x within {0..})"
    by (intro tendsto_inverse_ereal) (auto simp: eventually_at_topological)
qed

lemma continuous_uminus_ereal [continuous_intros]: "continuous_on (A :: ereal set) uminus"
  unfolding continuous_on_def
  by (intro ballI tendsto_uminus_ereal[of "\<lambda>x. x::ereal"]) simp

lemma ereal_uminus_atMost [simp]: "uminus ` {..(a::ereal)} = {-a..}"
proof (intro equalityI subsetI)
  fix x :: ereal assume "x \<in> {-a..}"
  hence "-(-x) \<in> uminus ` {..a}" by (intro imageI) (simp add: ereal_uminus_le_reorder)
  thus "x \<in> uminus ` {..a}" by simp
qed auto

lemma continuous_inverse_ereal_nonpos: "continuous_on ({..<0} :: ereal set) inverse"
proof (subst continuous_on_cong[OF refl])
  have "continuous_on {(0::ereal)<..} inverse"
    by (rule continuous_on_subset[OF continuous_inverse_ereal_nonneg]) auto
  thus "continuous_on {..<(0::ereal)} (uminus \<circ> inverse \<circ> uminus)"
    by (intro continuous_intros) simp_all
qed simp

end