(*
    Original Author of Riddle: Tjark Weber
    Updates and additions by Jacques Fleuriot
*)

theory Tut4Soln imports Main begin

(* Note that most of these can be proved in more than one way *)

lemma "(P \<longrightarrow>(Q\<longrightarrow>R))\<longrightarrow>((P\<longrightarrow>Q)\<longrightarrow>(P\<longrightarrow>R))"
proof (rule impI)+
  assume "P" "P \<longrightarrow> Q \<longrightarrow> R" then have qr: "Q \<longrightarrow> R"
    (* try sledgehammer here instead to see what it suggests *)
    by fast
  assume "P" "P \<longrightarrow> Q" then have "Q"
    by blast
  then show "R" using qr
    by blast
qed

lemma "(\<forall>x. P x \<longrightarrow> Q)\<longrightarrow>(\<exists>x. P x\<longrightarrow>Q)"
proof
  assume "\<forall>x. P x \<longrightarrow> Q" then have "P a \<longrightarrow> Q" ..
  then show "\<exists>x. P x\<longrightarrow>Q" ..
qed
lemma foo: assumes ex: "\<not>(\<exists>x. P x)" shows all: "\<forall>x. \<not>P x"
proof
  fix x
  show  "\<not> P x"
  proof
    assume "P x" then have "\<exists>x. P x" by (rule exI)
    then show False using ex by simp
  qed
qed

lemma foo2: assumes ex: "\<not>(\<exists>x. P x)" shows "\<forall>x. \<not>P x"
(* "safe" is a method that will not make any provable goal become unprovable.
    It does not do any exI or spec/allE steps. You can use other methods instead *)
proof(safe)
  fix x
  assume "P x" then have "\<exists>x. P x" by (rule exI)
  then show False using ex
    by simp
qed

(* A proof showing the use of a raw proof block. More elegant proofs are possible. *)

lemma assumes n_all: "\<not>(\<forall>x. P x)" shows "\<exists>x. \<not>P x"
proof (rule ccontr)
  assume n_ex: "\<nexists>x. \<not> P x"
  have "\<forall>x. P x"
    proof - (* dash means don't apply any default ND steps *)
      {fix z   (* arbitrary z *)
        have "P z"
        proof (rule ccontr)
          assume "\<not> P z" then have "\<exists>x. \<not> P x" ..
          then show False using n_ex  by simp
        qed
      }
      then show ?thesis .. (* method ".." is one that can do straightforward ND steps but you could e.g. use simp instead*)
    qed
    then show False using n_all by simp
qed

(* Shorter proof of same theorem as above *)

lemma assumes n_all: "\<not>(\<forall>x. P x)" shows "\<exists>x. \<not>P x"
proof (rule ccontr)
  assume n_ex: "\<nexists>x. \<not> P x"
  {fix x
    have "P x"
    proof (rule ccontr)
      assume "\<not> P x" then have "\<exists>x. \<not> P x" ..
      then show False using n_ex  by simp
    qed
  }
  then have "\<forall>x. P x" ..
  then show False using n_all by simp
qed

(* Another Proof using previous result *)
lemma assumes n_all: "\<not>(\<forall>x. P x)" shows "\<exists>x. \<not>P x"
proof (rule ccontr)
  assume "\<nexists>x. \<not> P x"
  then have "\<forall>x. \<not>\<not>P x" by (rule foo)
  then have "\<forall>x. P x" by simp
  from n_all this show False by (rule notE)
qed

(* A possible proof, without named assumptions and goals. Other proofs are possible *)

lemma "(R\<longrightarrow>P)\<longrightarrow>(((\<not>R \<or> P)\<longrightarrow>(Q\<longrightarrow>S))\<longrightarrow>(Q\<longrightarrow>S))"
proof (rule impI)+
  assume "R \<longrightarrow> P" "Q" "\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S"
  show "S"
  proof (cases)
    assume  "R"
    then have "P" using `R \<longrightarrow> P` by blast
    then have "\<not>R \<or> P" ..
    then have "Q \<longrightarrow> S" using `\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S` by blast
    then show "S" using  `Q` by simp
  next
    assume notr: "\<not>R"
    then have "\<not>R \<or> P" ..
    then have "Q \<longrightarrow> S" using `\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S` by blast
    then show "S" using  `Q` by simp
  qed
qed

(* Another proof of the above, without explicit use of cases *)
lemma "(R \<longrightarrow> P) \<longrightarrow> (((\<not>R \<or> P) \<longrightarrow> (Q \<longrightarrow> S)) \<longrightarrow> (Q \<longrightarrow> S))"
proof (rule impI, rule impI)
  assume a: "R \<longrightarrow> P" "\<not> R \<or> P \<longrightarrow> Q \<longrightarrow> S"
  { assume R
    hence P using a(1) by (rule_tac mp)
    hence "\<not> R \<or> P" by (rule disjI2)
  }
  moreover
  { assume "\<not>R"
    hence "\<not> R \<or> P" by (rule disjI1)
  }
  ultimately have "\<not> R \<or> P" by (rule_tac disjE, rule_tac excluded_middle)
  from this a(2) show "Q \<longrightarrow> S" by (rule_tac mp)
qed

text {* A Riddle: Rich Grandfather *}

text {*
  First prove the following formula, which is valid in classical predicate
  logic, informally with pen and paper.  Use case distinctions and/or proof by
  contradiction.

  "If every poor man has a rich father,
   then there is a rich man who has a rich grandfather"
*}

text {*
Proof
(1) We first show: "\<exists>x. rich x".
Proof by contradiction.
    Assume "\<not> (\<exists>x. rich x)"
      Then "\<forall>x. \<not> rich x"
      We consider an arbitrary "y" with "\<not> rich y"
      Then "rich (father y)"

(2) Now we show the theorem.
Proof by cases.
    Case 1:  "rich (father (father x))"
             We are done.
    Case 2: "\<not> rich (father (father x))"
            Then "rich (father (father (father x)))
            Also "rich (father x)"
            because otherwise "rich (father (father x))"
qed
*}

text {*
  Now prove the formula in Isabelle using a sequence of rule applications (i.e.\
  only using the methods rule, erule and assumption).
*}

theorem
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich (father (father x)) \<and> rich x"
apply (rule classical)
apply (rule exI)
apply (rule conjI)

  apply (rule classical)
  apply (rule allE) apply assumption
  apply (erule impE) apply assumption
  apply (erule notE)
  apply (rule exI)
  apply (rule conjI) apply assumption
  apply (rule classical)
  apply (erule allE)
  apply (erule notE)
  apply (erule impE) apply assumption
  apply assumption

apply (rule classical)
apply (rule allE) apply assumption
apply (erule impE) apply assumption
apply (erule notE)
apply (rule exI)
apply (rule conjI) apply assumption
apply (rule classical)
apply (erule allE)
apply (erule notE)
apply (erule impE) apply assumption
apply assumption
done

text{* An alternative proof of the above that does not rely on meta variables and uses additional
       tactics/methods such as drule and cut_tac .Note the use of rule exCI too.

       Note also that the order in which the subgoals are tackled are dictated by Isabelle but
       there are ways of doing the proof in a way closer to the informal one e.g. using "prefer"
       to change the order of the goals (although this makes the proof potentially more "brittle"
       to changes in future versions of Isabelle *}

theorem
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x) \<Longrightarrow>
  \<exists>x. rich (father (father x)) \<and> rich x"
apply (subgoal_tac "\<exists>x. rich x")
apply (erule exE)
(* Tackling (2) first *)
apply (cut_tac P="rich (father(father x))" in excluded_middle)
apply (erule disjE)
(* Case 2 *)
apply (subgoal_tac "rich(father x)")
apply (drule_tac x="father(father x)" in spec)
apply (drule mp, assumption)
apply (rule_tac x="father x" in exI)
apply (rule conjI)
apply assumption
apply assumption
apply (rule ccontr)
apply (drule_tac x="father x" in spec)
apply (drule mp, assumption)
apply (erule notE, assumption)
(* Case 1*)
apply (rule_tac x=x in exI)
apply (rule conjI)
apply assumption
apply assumption
(* Tackling (1) now *)
apply (rule_tac a="father x" in exCI)
apply (drule_tac x=x in spec)
apply (drule_tac x=x in spec)
apply (drule mp, assumption)
apply assumption
done

text {*
  Here is a proof in Isar that resembles the informal reasoning above:
*}

theorem rich_grandfather:
  "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)
   \<Longrightarrow> \<exists>x. rich x \<and> rich (father (father x))"
proof -
  assume a: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  have "\<exists>x. rich x"
  proof (rule classical)
    fix y
    assume "\<not> (\<exists>x. rich x)"
    then have "\<forall>x. \<not> rich x" by simp
    then have "\<not> rich y" by simp
    with a have "rich (father y)" by simp
    then show ?thesis by rule
  qed
  then obtain x where x: "rich x" by auto
  show ?thesis
  proof cases
    assume "rich (father (father x))"
    with x show ?thesis by auto
  next
    assume b: "\<not> rich (father (father x))"
    with a have "rich (father (father (father x)))" by blast
    moreover have "rich (father x)"
    proof (rule classical)
      assume "\<not> rich (father x)"
      with a have "rich (father (father x))" by simp
      with b show ?thesis by contradiction
    qed
    ultimately show ?thesis by auto
  qed
qed

text {*
  An slightly modified proof of the above, with a named assumption right from the beginning:
*}

theorem rich_grandfather2:
  assumes a: "\<forall>x. \<not> rich x \<longrightarrow> rich (father x)"
  shows "\<exists>x. rich x \<and> rich (father (father x))"
proof -
  have "\<exists>x. rich x"
  proof (rule classical)
    fix y
    assume "\<not> (\<exists>x. rich x)"
    then have "\<forall>x. \<not> rich x" by simp
    then have "\<not> rich y" by simp
    with a have "rich (father y)" by simp
    then show ?thesis by rule
  qed
  then obtain x where x: "rich x" by auto
  show ?thesis
  proof cases
    assume "rich (father (father x))"
    with x show ?thesis by auto
  next
    assume b: "\<not> rich (father (father x))"
    with a have "rich (father (father (father x)))" by simp
    moreover have "rich (father x)"
    proof (rule classical)
      assume "\<not> rich (father x)"
      with a have "rich (father (father x))" by simp
      with b show ?thesis by contradiction
    qed
    ultimately show ?thesis by auto
  qed
qed

 end


(*  Author: John Harrison, Marco Maggesi, Graziano Gentili, Gianni Ciolli, Valentina Bruno
    Ported from "hol_light/Multivariate/canal.ml" by L C Paulson (2014)
*)

section \<open>Complex Analysis Basics\<close>
text \<open>Definitions of analytic and holomorphic functions, limit theorems, complex differentiation\<close>

theory Complex_Analysis_Basics
  imports Derivative "HOL-Library.Nonpos_Ints" Uncountable_Sets
begin

subsection\<^marker>\<open>tag unimportant\<close>\<open>General lemmas\<close>

lemma nonneg_Reals_cmod_eq_Re: "z \<in> \<real>\<^sub>\<ge>\<^sub>0 \<Longrightarrow> norm z = Re z"
  by (simp add: complex_nonneg_Reals_iff cmod_eq_Re)

lemma fact_cancel:
  fixes c :: "'a::real_field"
  shows "of_nat (Suc n) * c / (fact (Suc n)) = c / (fact n)"
  using of_nat_neq_0 by force

lemma vector_derivative_cnj_within:
  assumes "at x within A \<noteq> bot" and "f differentiable at x within A"
  shows   "vector_derivative (\<lambda>z. cnj (f z)) (at x within A) =
             cnj (vector_derivative f (at x within A))" (is "_ = cnj ?D")
proof -
  let ?D = "vector_derivative f (at x within A)"
  from assms have "(f has_vector_derivative ?D) (at x within A)"
    by (subst (asm) vector_derivative_works)
  hence "((\<lambda>x. cnj (f x)) has_vector_derivative cnj ?D) (at x within A)"
    by (rule has_vector_derivative_cnj)
  thus ?thesis using assms by (auto dest: vector_derivative_within)
qed

lemma vector_derivative_cnj:
  assumes "f differentiable at x"
  shows   "vector_derivative (\<lambda>z. cnj (f z)) (at x) = cnj (vector_derivative f (at x))"
  using assms by (intro vector_derivative_cnj_within) auto

lemma
  shows open_halfspace_Re_lt: "open {z. Re(z) < b}"
    and open_halfspace_Re_gt: "open {z. Re(z) > b}"
    and closed_halfspace_Re_ge: "closed {z. Re(z) \<ge> b}"
    and closed_halfspace_Re_le: "closed {z. Re(z) \<le> b}"
    and closed_halfspace_Re_eq: "closed {z. Re(z) = b}"
    and open_halfspace_Im_lt: "open {z. Im(z) < b}"
    and open_halfspace_Im_gt: "open {z. Im(z) > b}"
    and closed_halfspace_Im_ge: "closed {z. Im(z) \<ge> b}"
    and closed_halfspace_Im_le: "closed {z. Im(z) \<le> b}"
    and closed_halfspace_Im_eq: "closed {z. Im(z) = b}"
  by (intro open_Collect_less closed_Collect_le closed_Collect_eq continuous_on_Re
            continuous_on_Im continuous_on_id continuous_on_const)+

lemma uncountable_halfspace_Im_gt: "uncountable {z. Im z > c}"
proof -
  obtain r where r: "r > 0" "ball ((c + 1) *\<^sub>R \<i>) r \<subseteq> {z. Im z > c}"
    using open_halfspace_Im_gt[of c] unfolding open_contains_ball by force
  then show ?thesis
    using countable_subset uncountable_ball by blast
qed

lemma uncountable_halfspace_Im_lt: "uncountable {z. Im z < c}"
proof -
  obtain r where r: "r > 0" "ball ((c - 1) *\<^sub>R \<i>) r \<subseteq> {z. Im z < c}"
    using open_halfspace_Im_lt[of c] unfolding open_contains_ball by force
  then show ?thesis
    using countable_subset uncountable_ball by blast
qed

lemma uncountable_halfspace_Re_gt: "uncountable {z. Re z > c}"
proof -
  obtain r where r: "r > 0" "ball (of_real(c + 1)) r \<subseteq> {z. Re z > c}"
    using open_halfspace_Re_gt[of c] unfolding open_contains_ball by force
  then show ?thesis
    using countable_subset uncountable_ball by blast
qed

lemma uncountable_halfspace_Re_lt: "uncountable {z. Re z < c}"
proof -
  obtain r where r: "r > 0" "ball (of_real(c - 1)) r \<subseteq> {z. Re z < c}"
    using open_halfspace_Re_lt[of c] unfolding open_contains_ball by force
  then show ?thesis
    using countable_subset uncountable_ball by blast
qed

lemma connected_halfspace_Im_gt [intro]: "connected {z. c < Im z}"
  by (intro convex_connected convex_halfspace_Im_gt)

lemma connected_halfspace_Im_lt [intro]: "connected {z. c > Im z}"
  by (intro convex_connected convex_halfspace_Im_lt)

lemma connected_halfspace_Re_gt [intro]: "connected {z. c < Re z}"
  by (intro convex_connected convex_halfspace_Re_gt)

lemma connected_halfspace_Re_lt [intro]: "connected {z. c > Re z}"
  by (intro convex_connected convex_halfspace_Re_lt)

lemma closed_complex_Reals: "closed (\<real> :: complex set)"
proof -
  have "(\<real> :: complex set) = {z. Im z = 0}"
    by (auto simp: complex_is_Real_iff)
  then show ?thesis
    by (metis closed_halfspace_Im_eq)
qed

lemma closed_Real_halfspace_Re_le: "closed (\<real> \<inter> {w. Re w \<le> x})"
  by (simp add: closed_Int closed_complex_Reals closed_halfspace_Re_le)

lemma closed_nonpos_Reals_complex [simp]: "closed (\<real>\<^sub>\<le>\<^sub>0 :: complex set)"
proof -
  have "\<real>\<^sub>\<le>\<^sub>0 = \<real> \<inter> {z. Re(z) \<le> 0}"
    using complex_nonpos_Reals_iff complex_is_Real_iff by auto
  then show ?thesis
    by (metis closed_Real_halfspace_Re_le)
qed

lemma closed_Real_halfspace_Re_ge: "closed (\<real> \<inter> {w. x \<le> Re(w)})"
  using closed_halfspace_Re_ge
  by (simp add: closed_Int closed_complex_Reals)

lemma closed_nonneg_Reals_complex [simp]: "closed (\<real>\<^sub>\<ge>\<^sub>0 :: complex set)"
proof -
  have "\<real>\<^sub>\<ge>\<^sub>0 = \<real> \<inter> {z. Re(z) \<ge> 0}"
    using complex_nonneg_Reals_iff complex_is_Real_iff by auto
  then show ?thesis
    by (metis closed_Real_halfspace_Re_ge)
qed

lemma closed_real_abs_le: "closed {w \<in> \<real>. \<bar>Re w\<bar> \<le> r}"
proof -
  have "{w \<in> \<real>. \<bar>Re w\<bar> \<le> r} = (\<real> \<inter> {w. Re w \<le> r}) \<inter> (\<real> \<inter> {w. Re w \<ge> -r})"
    by auto
  then show "closed {w \<in> \<real>. \<bar>Re w\<bar> \<le> r}"
    by (simp add: closed_Int closed_Real_halfspace_Re_ge closed_Real_halfspace_Re_le)
qed

lemma real_lim:
  fixes l::complex
  assumes "(f \<longlongrightarrow> l) F" and "\<not> trivial_limit F" and "eventually P F" and "\<And>a. P a \<Longrightarrow> f a \<in> \<real>"
  shows  "l \<in> \<real>"
proof (rule Lim_in_closed_set[OF closed_complex_Reals _ assms(2,1)])
  show "eventually (\<lambda>x. f x \<in> \<real>) F"
    using assms(3, 4) by (auto intro: eventually_mono)
qed

lemma real_lim_sequentially:
  fixes l::complex
  shows "(f \<longlongrightarrow> l) sequentially \<Longrightarrow> (\<exists>N. \<forall>n\<ge>N. f n \<in> \<real>) \<Longrightarrow> l \<in> \<real>"
by (rule real_lim [where F=sequentially]) (auto simp: eventually_sequentially)

lemma real_series:
  fixes l::complex
  shows "f sums l \<Longrightarrow> (\<And>n. f n \<in> \<real>) \<Longrightarrow> l \<in> \<real>"
unfolding sums_def
by (metis real_lim_sequentially sum_in_Reals)

lemma Lim_null_comparison_Re:
  assumes "eventually (\<lambda>x. norm(f x) \<le> Re(g x)) F" "(g \<longlongrightarrow> 0) F" shows "(f \<longlongrightarrow> 0) F"
  by (rule Lim_null_comparison[OF assms(1)] tendsto_eq_intros assms(2))+ simp

subsection\<open>Holomorphic functions\<close>

definition\<^marker>\<open>tag important\<close> holomorphic_on :: "[complex \<Rightarrow> complex, complex set] \<Rightarrow> bool"
           (infixl "(holomorphic'_on)" 50)
  where "f holomorphic_on s \<equiv> \<forall>x\<in>s. f field_differentiable (at x within s)"

named_theorems\<^marker>\<open>tag important\<close> holomorphic_intros "structural introduction rules for holomorphic_on"

lemma holomorphic_onI [intro?]: "(\<And>x. x \<in> s \<Longrightarrow> f field_differentiable (at x within s)) \<Longrightarrow> f holomorphic_on s"
  by (simp add: holomorphic_on_def)

lemma holomorphic_onD [dest?]: "\<lbrakk>f holomorphic_on s; x \<in> s\<rbrakk> \<Longrightarrow> f field_differentiable (at x within s)"
  by (simp add: holomorphic_on_def)

lemma holomorphic_on_imp_differentiable_on:
    "f holomorphic_on s \<Longrightarrow> f differentiable_on s"
  unfolding holomorphic_on_def differentiable_on_def
  by (simp add: field_differentiable_imp_differentiable)

lemma holomorphic_on_imp_differentiable_at:
   "\<lbrakk>f holomorphic_on s; open s; x \<in> s\<rbrakk> \<Longrightarrow> f field_differentiable (at x)"
using at_within_open holomorphic_on_def by fastforce

lemma holomorphic_on_empty [holomorphic_intros]: "f holomorphic_on {}"
  by (simp add: holomorphic_on_def)

lemma holomorphic_on_open:
    "open s \<Longrightarrow> f holomorphic_on s \<longleftrightarrow> (\<forall>x \<in> s. \<exists>f'. DERIV f x :> f')"
  by (auto simp: holomorphic_on_def field_differentiable_def has_field_derivative_def at_within_open [of _ s])

lemma holomorphic_on_UN_open:
  assumes "\<And>n. n \<in> I \<Longrightarrow> f holomorphic_on A n" "\<And>n. n \<in> I \<Longrightarrow> open (A n)"
  shows   "f holomorphic_on (\<Union>n\<in>I. A n)"
proof -
  have "f field_differentiable at z within (\<Union>n\<in>I. A n)" if "z \<in> (\<Union>n\<in>I. A n)" for z
  proof -
    from that obtain n where "n \<in> I" "z \<in> A n"
      by blast
    hence "f holomorphic_on A n" "open (A n)"
      by (simp add: assms)+
    with \<open>z \<in> A n\<close> have "f field_differentiable at z"
      by (auto simp: holomorphic_on_open field_differentiable_def)
    thus ?thesis
      by (meson field_differentiable_at_within)
  qed
  thus ?thesis
    by (auto simp: holomorphic_on_def)
qed

lemma holomorphic_on_imp_continuous_on:
    "f holomorphic_on s \<Longrightarrow> continuous_on s f"
  by (metis field_differentiable_imp_continuous_at continuous_on_eq_continuous_within holomorphic_on_def)

lemma holomorphic_closedin_preimage_constant:
  assumes "f holomorphic_on D"
  shows "closedin (top_of_set D) {z\<in>D. f z = a}"
  by (simp add: assms continuous_closedin_preimage_constant holomorphic_on_imp_continuous_on)

lemma holomorphic_closed_preimage_constant:
  assumes "f holomorphic_on UNIV"
  shows "closed {z. f z = a}"
  using holomorphic_closedin_preimage_constant [OF assms] by simp

lemma holomorphic_on_subset [elim]:
    "f holomorphic_on s \<Longrightarrow> t \<subseteq> s \<Longrightarrow> f holomorphic_on t"
  unfolding holomorphic_on_def
  by (metis field_differentiable_within_subset subsetD)

lemma holomorphic_transform: "\<lbrakk>f holomorphic_on s; \<And>x. x \<in> s \<Longrightarrow> f x = g x\<rbrakk> \<Longrightarrow> g holomorphic_on s"
  by (metis field_differentiable_transform_within linordered_field_no_ub holomorphic_on_def)

lemma holomorphic_cong: "s = t ==> (\<And>x. x \<in> s \<Longrightarrow> f x = g x) \<Longrightarrow> f holomorphic_on s \<longleftrightarrow> g holomorphic_on t"
  by (metis holomorphic_transform)

lemma holomorphic_on_linear [simp, holomorphic_intros]: "((*) c) holomorphic_on s"
  unfolding holomorphic_on_def by (metis field_differentiable_linear)

lemma holomorphic_on_const [simp, holomorphic_intros]: "(\<lambda>z. c) holomorphic_on s"
  unfolding holomorphic_on_def by (metis field_differentiable_const)

lemma holomorphic_on_ident [simp, holomorphic_intros]: "(\<lambda>x. x) holomorphic_on s"
  unfolding holomorphic_on_def by (metis field_differentiable_ident)

lemma holomorphic_on_id [simp, holomorphic_intros]: "id holomorphic_on s"
  unfolding id_def by (rule holomorphic_on_ident)

lemma constant_on_imp_holomorphic_on:
  assumes "f constant_on A"
  shows   "f holomorphic_on A"
proof -
  from assms obtain c where c: "\<forall>x\<in>A. f x = c"
    unfolding constant_on_def by blast
  have "f holomorphic_on A \<longleftrightarrow> (\<lambda>_. c) holomorphic_on A"
    by (intro holomorphic_cong) (use c in auto)
  thus ?thesis
    by simp
qed

lemma holomorphic_on_compose:
  "f holomorphic_on s \<Longrightarrow> g holomorphic_on (f ` s) \<Longrightarrow> (g o f) holomorphic_on s"
  using field_differentiable_compose_within[of f _ s g]
  by (auto simp: holomorphic_on_def)

lemma holomorphic_on_compose_gen:
  "f holomorphic_on s \<Longrightarrow> g holomorphic_on t \<Longrightarrow> f ` s \<subseteq> t \<Longrightarrow> (g o f) holomorphic_on s"
  by (metis holomorphic_on_compose holomorphic_on_subset)

lemma holomorphic_on_balls_imp_entire:
  assumes "\<not>bdd_above A" "\<And>r. r \<in> A \<Longrightarrow> f holomorphic_on ball c r"
  shows   "f holomorphic_on B"
proof (rule holomorphic_on_subset)
  show "f holomorphic_on UNIV" unfolding holomorphic_on_def
  proof
    fix z :: complex
    from \<open>\<not>bdd_above A\<close> obtain r where r: "r \<in> A" "r > norm (z - c)"
      by (meson bdd_aboveI not_le)
    with assms(2) have "f holomorphic_on ball c r" by blast
    moreover from r have "z \<in> ball c r" by (auto simp: dist_norm norm_minus_commute)
    ultimately show "f field_differentiable at z"
      by (auto simp: holomorphic_on_def at_within_open[of _ "ball c r"])
  qed
qed auto

lemma holomorphic_on_balls_imp_entire':
  assumes "\<And>r. r > 0 \<Longrightarrow> f holomorphic_on ball c r"
  shows   "f holomorphic_on B"
proof (rule holomorphic_on_balls_imp_entire)
  {
    fix M :: real
    have "\<exists>x. x > max M 0" by (intro gt_ex)
    hence "\<exists>x>0. x > M" by auto
  }
  thus "\<not>bdd_above {(0::real)<..}" unfolding bdd_above_def
    by (auto simp: not_le)
qed (insert assms, auto)

lemma holomorphic_on_minus [holomorphic_intros]: "f holomorphic_on A \<Longrightarrow> (\<lambda>z. -(f z)) holomorphic_on A"
  by (metis field_differentiable_minus holomorphic_on_def)

lemma holomorphic_on_add [holomorphic_intros]:
  "\<lbrakk>f holomorphic_on A; g holomorphic_on A\<rbrakk> \<Longrightarrow> (\<lambda>z. f z + g z) holomorphic_on A"
  unfolding holomorphic_on_def by (metis field_differentiable_add)

lemma holomorphic_on_diff [holomorphic_intros]:
  "\<lbrakk>f holomorphic_on A; g holomorphic_on A\<rbrakk> \<Longrightarrow> (\<lambda>z. f z - g z) holomorphic_on A"
  unfolding holomorphic_on_def by (metis field_differentiable_diff)

lemma holomorphic_on_mult [holomorphic_intros]:
  "\<lbrakk>f holomorphic_on A; g holomorphic_on A\<rbrakk> \<Longrightarrow> (\<lambda>z. f z * g z) holomorphic_on A"
  unfolding holomorphic_on_def by (metis field_differentiable_mult)

lemma holomorphic_on_inverse [holomorphic_intros]:
  "\<lbrakk>f holomorphic_on A; \<And>z. z \<in> A \<Longrightarrow> f z \<noteq> 0\<rbrakk> \<Longrightarrow> (\<lambda>z. inverse (f z)) holomorphic_on A"
  unfolding holomorphic_on_def by (metis field_differentiable_inverse)

lemma holomorphic_on_divide [holomorphic_intros]:
  "\<lbrakk>f holomorphic_on A; g holomorphic_on A; \<And>z. z \<in> A \<Longrightarrow> g z \<noteq> 0\<rbrakk> \<Longrightarrow> (\<lambda>z. f z / g z) holomorphic_on A"
  unfolding holomorphic_on_def by (metis field_differentiable_divide)

lemma holomorphic_on_power [holomorphic_intros]:
  "f holomorphic_on A \<Longrightarrow> (\<lambda>z. (f z)^n) holomorphic_on A"
  unfolding holomorphic_on_def by (metis field_differentiable_power)

lemma holomorphic_on_power_int [holomorphic_intros]:
  assumes nz: "n \<ge> 0 \<or> (\<forall>x\<in>A. f x \<noteq> 0)" and f: "f holomorphic_on A"
  shows   "(\<lambda>x. f x powi n) holomorphic_on A"
proof (cases "n \<ge> 0")
  case True
  have "(\<lambda>x. f x ^ nat n) holomorphic_on A"
    by (simp add: f holomorphic_on_power)
  with True show ?thesis
    by (simp add: power_int_def)
next
  case False
  hence "(\<lambda>x. inverse (f x ^ nat (-n))) holomorphic_on A"
    using nz by (auto intro!: holomorphic_intros f)
  with False show ?thesis
    by (simp add: power_int_def power_inverse)
qed

lemma holomorphic_on_sum [holomorphic_intros]:
  "(\<And>i. i \<in> I \<Longrightarrow> (f i) holomorphic_on A) \<Longrightarrow> (\<lambda>x. sum (\<lambda>i. f i x) I) holomorphic_on A"
  unfolding holomorphic_on_def by (metis field_differentiable_sum)

lemma holomorphic_on_prod [holomorphic_intros]:
  "(\<And>i. i \<in> I \<Longrightarrow> (f i) holomorphic_on A) \<Longrightarrow> (\<lambda>x. prod (\<lambda>i. f i x) I) holomorphic_on A"
  by (induction I rule: infinite_finite_induct) (auto intro: holomorphic_intros)

lemma holomorphic_pochhammer [holomorphic_intros]:
  "f holomorphic_on A \<Longrightarrow> (\<lambda>s. pochhammer (f s) n) holomorphic_on A"
  by (induction n) (auto intro!: holomorphic_intros simp: pochhammer_Suc)

lemma holomorphic_on_scaleR [holomorphic_intros]:
  "f holomorphic_on A \<Longrightarrow> (\<lambda>x. c *\<^sub>R f x) holomorphic_on A"
  by (auto simp: scaleR_conv_of_real intro!: holomorphic_intros)

lemma holomorphic_on_Un [holomorphic_intros]:
  assumes "f holomorphic_on A" "f holomorphic_on B" "open A" "open B"
  shows   "f holomorphic_on (A \<union> B)"
  using assms by (auto simp: holomorphic_on_def  at_within_open[of _ A]
                             at_within_open[of _ B]  at_within_open[of _ "A \<union> B"] open_Un)

lemma holomorphic_on_If_Un [holomorphic_intros]:
  assumes "f holomorphic_on A" "g holomorphic_on B" "open A" "open B"
  assumes "\<And>z. z \<in> A \<Longrightarrow> z \<in> B \<Longrightarrow> f z = g z"
  shows   "(\<lambda>z. if z \<in> A then f z else g z) holomorphic_on (A \<union> B)" (is "?h holomorphic_on _")
proof (intro holomorphic_on_Un)
  note \<open>f holomorphic_on A\<close>
  also have "f holomorphic_on A \<longleftrightarrow> ?h holomorphic_on A"
    by (intro holomorphic_cong) auto
  finally show \<dots> .
next
  note \<open>g holomorphic_on B\<close>
  also have "g holomorphic_on B \<longleftrightarrow> ?h holomorphic_on B"
    using assms by (intro holomorphic_cong) auto
  finally show \<dots> .
qed (insert assms, auto)

lemma holomorphic_derivI:
     "\<lbrakk>f holomorphic_on S; open S; x \<in> S\<rbrakk>
      \<Longrightarrow> (f has_field_derivative deriv f x) (at x within T)"
by (metis DERIV_deriv_iff_field_differentiable at_within_open  holomorphic_on_def has_field_derivative_at_within)

lemma complex_derivative_transform_within_open:
  "\<lbrakk>f holomorphic_on s; g holomorphic_on s; open s; z \<in> s; \<And>w. w \<in> s \<Longrightarrow> f w = g w\<rbrakk>
   \<Longrightarrow> deriv f z = deriv g z"
  unfolding holomorphic_on_def
  by (rule DERIV_imp_deriv)
     (metis DERIV_deriv_iff_field_differentiable has_field_derivative_transform_within_open at_within_open)

lemma holomorphic_on_compose_cnj_cnj:
  assumes "f holomorphic_on cnj ` A" "open A"
  shows   "cnj \<circ> f \<circ> cnj holomorphic_on A"
proof -
  have [simp]: "open (cnj ` A)"
    unfolding image_cnj_conv_vimage_cnj using assms by (intro open_vimage) auto
  show ?thesis
    using assms unfolding holomorphic_on_def
    by (auto intro!: field_differentiable_cnj_cnj simp: at_within_open_NO_MATCH)
qed

lemma holomorphic_nonconstant:
  assumes holf: "f holomorphic_on S" and "open S" "\<xi> \<in> S" "deriv f \<xi> \<noteq> 0"
    shows "\<not> f constant_on S"
  by (rule nonzero_deriv_nonconstant [of f "deriv f \<xi>" \<xi> S])
    (use assms in \<open>auto simp: holomorphic_derivI\<close>)

subsection\<open>Analyticity on a set\<close>

definition\<^marker>\<open>tag important\<close> analytic_on (infixl "(analytic'_on)" 50)
  where "f analytic_on S \<equiv> \<forall>x \<in> S. \<exists>e. 0 < e \<and> f holomorphic_on (ball x e)"

named_theorems\<^marker>\<open>tag important\<close> analytic_intros "introduction rules for proving analyticity"

lemma analytic_imp_holomorphic: "f analytic_on S \<Longrightarrow> f holomorphic_on S"
  by (simp add: at_within_open [OF _ open_ball] analytic_on_def holomorphic_on_def)
     (metis centre_in_ball field_differentiable_at_within)

lemma analytic_on_open: "open S \<Longrightarrow> f analytic_on S \<longleftrightarrow> f holomorphic_on S"
  by (meson analytic_imp_holomorphic analytic_on_def holomorphic_on_subset openE)

lemma analytic_on_imp_differentiable_at:
  "f analytic_on S \<Longrightarrow> x \<in> S \<Longrightarrow> f field_differentiable (at x)"
  using analytic_on_def holomorphic_on_imp_differentiable_at by auto

lemma analytic_at_imp_isCont:
  assumes "f analytic_on {z}"
  shows   "isCont f z"
  using assms by (meson analytic_on_imp_differentiable_at field_differentiable_imp_continuous_at insertI1)

lemma analytic_at_neq_imp_eventually_neq:
  assumes "f analytic_on {x}" "f x \<noteq> c"
  shows   "eventually (\<lambda>y. f y \<noteq> c) (at x)"
proof (intro tendsto_imp_eventually_ne)
  show "f \<midarrow>x\<rightarrow> f x"
    using assms by (simp add: analytic_at_imp_isCont isContD)
qed (use assms in auto)

lemma analytic_on_subset: "f analytic_on S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> f analytic_on T"
  by (auto simp: analytic_on_def)

lemma analytic_on_Un: "f analytic_on (S \<union> T) \<longleftrightarrow> f analytic_on S \<and> f analytic_on T"
  by (auto simp: analytic_on_def)

lemma analytic_on_Union: "f analytic_on (\<Union>\<T>) \<longleftrightarrow> (\<forall>T \<in> \<T>. f analytic_on T)"
  by (auto simp: analytic_on_def)

lemma analytic_on_UN: "f analytic_on (\<Union>i\<in>I. S i) \<longleftrightarrow> (\<forall>i\<in>I. f analytic_on (S i))"
  by (auto simp: analytic_on_def)

lemma analytic_on_holomorphic:
  "f analytic_on S \<longleftrightarrow> (\<exists>T. open T \<and> S \<subseteq> T \<and> f holomorphic_on T)"
  (is "?lhs = ?rhs")
proof -
  have "?lhs \<longleftrightarrow> (\<exists>T. open T \<and> S \<subseteq> T \<and> f analytic_on T)"
  proof safe
    assume "f analytic_on S"
    then show "\<exists>T. open T \<and> S \<subseteq> T \<and> f analytic_on T"
      apply (simp add: analytic_on_def)
      apply (rule exI [where x="\<Union>{U. open U \<and> f analytic_on U}"], auto)
      apply (metis open_ball analytic_on_open centre_in_ball)
      by (metis analytic_on_def)
  next
    fix T
    assume "open T" "S \<subseteq> T" "f analytic_on T"
    then show "f analytic_on S"
        by (metis analytic_on_subset)
  qed
  also have "... \<longleftrightarrow> ?rhs"
    by (auto simp: analytic_on_open)
  finally show ?thesis .
qed

lemma analytic_on_linear [analytic_intros,simp]: "((*) c) analytic_on S"
  by (auto simp add: analytic_on_holomorphic)

lemma analytic_on_const [analytic_intros,simp]: "(\<lambda>z. c) analytic_on S"
  by (metis analytic_on_def holomorphic_on_const zero_less_one)

lemma analytic_on_ident [analytic_intros,simp]: "(\<lambda>x. x) analytic_on S"
  by (simp add: analytic_on_def gt_ex)

lemma analytic_on_id [analytic_intros]: "id analytic_on S"
  unfolding id_def by (rule analytic_on_ident)

lemma analytic_on_compose:
  assumes f: "f analytic_on S"
      and g: "g analytic_on (f ` S)"
    shows "(g o f) analytic_on S"
unfolding analytic_on_def
proof (intro ballI)
  fix x
  assume x: "x \<in> S"
  then obtain e where e: "0 < e" and fh: "f holomorphic_on ball x e" using f
    by (metis analytic_on_def)
  obtain e' where e': "0 < e'" and gh: "g holomorphic_on ball (f x) e'" using g
    by (metis analytic_on_def g image_eqI x)
  have "isCont f x"
    by (metis analytic_on_imp_differentiable_at field_differentiable_imp_continuous_at f x)
  with e' obtain d where d: "0 < d" and fd: "f ` ball x d \<subseteq> ball (f x) e'"
     by (auto simp: continuous_at_ball)
  have "g \<circ> f holomorphic_on ball x (min d e)"
    apply (rule holomorphic_on_compose)
    apply (metis fh holomorphic_on_subset min.bounded_iff order_refl subset_ball)
    by (metis fd gh holomorphic_on_subset image_mono min.cobounded1 subset_ball)
  then show "\<exists>e>0. g \<circ> f holomorphic_on ball x e"
    by (metis d e min_less_iff_conj)
qed

lemma analytic_on_compose_gen:
  "f analytic_on S \<Longrightarrow> g analytic_on T \<Longrightarrow> (\<And>z. z \<in> S \<Longrightarrow> f z \<in> T)
             \<Longrightarrow> g o f analytic_on S"
by (metis analytic_on_compose analytic_on_subset image_subset_iff)

lemma analytic_on_neg [analytic_intros]:
  "f analytic_on S \<Longrightarrow> (\<lambda>z. -(f z)) analytic_on S"
by (metis analytic_on_holomorphic holomorphic_on_minus)

lemma analytic_on_add [analytic_intros]:
  assumes f: "f analytic_on S"
      and g: "g analytic_on S"
    shows "(\<lambda>z. f z + g z) analytic_on S"
unfolding analytic_on_def
proof (intro ballI)
  fix z
  assume z: "z \<in> S"
  then obtain e where e: "0 < e" and fh: "f holomorphic_on ball z e" using f
    by (metis analytic_on_def)
  obtain e' where e': "0 < e'" and gh: "g holomorphic_on ball z e'" using g
    by (metis analytic_on_def g z)
  have "(\<lambda>z. f z + g z) holomorphic_on ball z (min e e')"
    apply (rule holomorphic_on_add)
    apply (metis fh holomorphic_on_subset min.bounded_iff order_refl subset_ball)
    by (metis gh holomorphic_on_subset min.bounded_iff order_refl subset_ball)
  then show "\<exists>e>0. (\<lambda>z. f z + g z) holomorphic_on ball z e"
    by (metis e e' min_less_iff_conj)
qed

lemma analytic_on_diff [analytic_intros]:
  assumes f: "f analytic_on S"
      and g: "g analytic_on S"
    shows "(\<lambda>z. f z - g z) analytic_on S"
unfolding analytic_on_def
proof (intro ballI)
  fix z
  assume z: "z \<in> S"
  then obtain e where e: "0 < e" and fh: "f holomorphic_on ball z e" using f
    by (metis analytic_on_def)
  obtain e' where e': "0 < e'" and gh: "g holomorphic_on ball z e'" using g
    by (metis analytic_on_def g z)
  have "(\<lambda>z. f z - g z) holomorphic_on ball z (min e e')"
    apply (rule holomorphic_on_diff)
    apply (metis fh holomorphic_on_subset min.bounded_iff order_refl subset_ball)
    by (metis gh holomorphic_on_subset min.bounded_iff order_refl subset_ball)
  then show "\<exists>e>0. (\<lambda>z. f z - g z) holomorphic_on ball z e"
    by (metis e e' min_less_iff_conj)
qed

lemma analytic_on_mult [analytic_intros]:
  assumes f: "f analytic_on S"
      and g: "g analytic_on S"
    shows "(\<lambda>z. f z * g z) analytic_on S"
unfolding analytic_on_def
proof (intro ballI)
  fix z
  assume z: "z \<in> S"
  then obtain e where e: "0 < e" and fh: "f holomorphic_on ball z e" using f
    by (metis analytic_on_def)
  obtain e' where e': "0 < e'" and gh: "g holomorphic_on ball z e'" using g
    by (metis analytic_on_def g z)
  have "(\<lambda>z. f z * g z) holomorphic_on ball z (min e e')"
    apply (rule holomorphic_on_mult)
    apply (metis fh holomorphic_on_subset min.bounded_iff order_refl subset_ball)
    by (metis gh holomorphic_on_subset min.bounded_iff order_refl subset_ball)
  then show "\<exists>e>0. (\<lambda>z. f z * g z) holomorphic_on ball z e"
    by (metis e e' min_less_iff_conj)
qed

lemma analytic_on_inverse [analytic_intros]:
  assumes f: "f analytic_on S"
      and nz: "(\<And>z. z \<in> S \<Longrightarrow> f z \<noteq> 0)"
    shows "(\<lambda>z. inverse (f z)) analytic_on S"
unfolding analytic_on_def
proof (intro ballI)
  fix z
  assume z: "z \<in> S"
  then obtain e where e: "0 < e" and fh: "f holomorphic_on ball z e" using f
    by (metis analytic_on_def)
  have "continuous_on (ball z e) f"
    by (metis fh holomorphic_on_imp_continuous_on)
  then obtain e' where e': "0 < e'" and nz': "\<And>y. dist z y < e' \<Longrightarrow> f y \<noteq> 0"
    by (metis open_ball centre_in_ball continuous_on_open_avoid e z nz)
  have "(\<lambda>z. inverse (f z)) holomorphic_on ball z (min e e')"
    apply (rule holomorphic_on_inverse)
    apply (metis fh holomorphic_on_subset min.cobounded2 min.commute subset_ball)
    by (metis nz' mem_ball min_less_iff_conj)
  then show "\<exists>e>0. (\<lambda>z. inverse (f z)) holomorphic_on ball z e"
    by (metis e e' min_less_iff_conj)
qed

lemma analytic_on_divide [analytic_intros]:
  assumes f: "f analytic_on S"
      and g: "g analytic_on S"
      and nz: "(\<And>z. z \<in> S \<Longrightarrow> g z \<noteq> 0)"
    shows "(\<lambda>z. f z / g z) analytic_on S"
unfolding divide_inverse
by (metis analytic_on_inverse analytic_on_mult f g nz)

lemma analytic_on_power [analytic_intros]:
  "f analytic_on S \<Longrightarrow> (\<lambda>z. (f z) ^ n) analytic_on S"
by (induct n) (auto simp: analytic_on_mult)

lemma analytic_on_power_int [analytic_intros]:
  assumes nz: "n \<ge> 0 \<or> (\<forall>x\<in>A. f x \<noteq> 0)" and f: "f analytic_on A"
  shows   "(\<lambda>x. f x powi n) analytic_on A"
proof (cases "n \<ge> 0")
  case True
  have "(\<lambda>x. f x ^ nat n) analytic_on A"
    using analytic_on_power f by blast
  with True show ?thesis
    by (simp add: power_int_def)
next
  case False
  hence "(\<lambda>x. inverse (f x ^ nat (-n))) analytic_on A"
    using nz by (auto intro!: analytic_intros f)
  with False show ?thesis
    by (simp add: power_int_def power_inverse)
qed

lemma analytic_on_sum [analytic_intros]:
  "(\<And>i. i \<in> I \<Longrightarrow> (f i) analytic_on S) \<Longrightarrow> (\<lambda>x. sum (\<lambda>i. f i x) I) analytic_on S"
  by (induct I rule: infinite_finite_induct) (auto simp: analytic_on_add)

lemma analytic_on_prod [analytic_intros]:
  "(\<And>i. i \<in> I \<Longrightarrow> (f i) analytic_on S) \<Longrightarrow> (\<lambda>x. prod (\<lambda>i. f i x) I) analytic_on S"
  by (induct I rule: infinite_finite_induct) (auto simp: analytic_on_mult)

lemma deriv_left_inverse:
  assumes "f holomorphic_on S" and "g holomorphic_on T"
      and "open S" and "open T"
      and "f ` S \<subseteq> T"
      and [simp]: "\<And>z. z \<in> S \<Longrightarrow> g (f z) = z"
      and "w \<in> S"
    shows "deriv f w * deriv g (f w) = 1"
proof -
  have "deriv f w * deriv g (f w) = deriv g (f w) * deriv f w"
    by (simp add: algebra_simps)
  also have "... = deriv (g o f) w"
    using assms
    by (metis analytic_on_imp_differentiable_at analytic_on_open deriv_chain image_subset_iff)
  also have "... = deriv id w"
  proof (rule complex_derivative_transform_within_open [where s=S])
    show "g \<circ> f holomorphic_on S"
      by (rule assms holomorphic_on_compose_gen holomorphic_intros)+
  qed (use assms in auto)
  also have "... = 1"
    by simp
  finally show ?thesis .
qed

subsection\<^marker>\<open>tag unimportant\<close>\<open>Analyticity at a point\<close>

lemma analytic_at_ball:
  "f analytic_on {z} \<longleftrightarrow> (\<exists>e. 0<e \<and> f holomorphic_on ball z e)"
  by (metis analytic_on_def singleton_iff)

lemma analytic_at:
  "f analytic_on {z} \<longleftrightarrow> (\<exists>s. open s \<and> z \<in> s \<and> f holomorphic_on s)"
  by (metis analytic_on_holomorphic empty_subsetI insert_subset)

lemma holomorphic_on_imp_analytic_at:
  assumes "f holomorphic_on A" "open A" "z \<in> A"
  shows   "f analytic_on {z}"
  using assms by (meson analytic_at)

lemma analytic_on_analytic_at:
  "f analytic_on s \<longleftrightarrow> (\<forall>z \<in> s. f analytic_on {z})"
  by (metis analytic_at_ball analytic_on_def)

lemma analytic_at_two:
  "f analytic_on {z} \<and> g analytic_on {z} \<longleftrightarrow>
   (\<exists>s. open s \<and> z \<in> s \<and> f holomorphic_on s \<and> g holomorphic_on s)"
  (is "?lhs = ?rhs")
proof
  assume ?lhs
  then obtain s t
    where st: "open s" "z \<in> s" "f holomorphic_on s"
              "open t" "z \<in> t" "g holomorphic_on t"
    by (auto simp: analytic_at)
  show ?rhs
    apply (rule_tac x="s \<inter> t" in exI)
    using st
    apply (auto simp: holomorphic_on_subset)
    done
next
  assume ?rhs
  then show ?lhs
    by (force simp add: analytic_at)
qed

subsection\<^marker>\<open>tag unimportant\<close>\<open>Combining theorems for derivative with ``analytic at'' hypotheses\<close>

lemma
  assumes "f analytic_on {z}" "g analytic_on {z}"
  shows complex_derivative_add_at: "deriv (\<lambda>w. f w + g w) z = deriv f z + deriv g z"
    and complex_derivative_diff_at: "deriv (\<lambda>w. f w - g w) z = deriv f z - deriv g z"
    and complex_derivative_mult_at: "deriv (\<lambda>w. f w * g w) z =
           f z * deriv g z + deriv f z * g z"
proof -
  obtain s where s: "open s" "z \<in> s" "f holomorphic_on s" "g holomorphic_on s"
    using assms by (metis analytic_at_two)
  show "deriv (\<lambda>w. f w + g w) z = deriv f z + deriv g z"
    apply (rule DERIV_imp_deriv [OF DERIV_add])
    using s
    apply (auto simp: holomorphic_on_open field_differentiable_def DERIV_deriv_iff_field_differentiable)
    done
  show "deriv (\<lambda>w. f w - g w) z = deriv f z - deriv g z"
    apply (rule DERIV_imp_deriv [OF DERIV_diff])
    using s
    apply (auto simp: holomorphic_on_open field_differentiable_def DERIV_deriv_iff_field_differentiable)
    done
  show "deriv (\<lambda>w. f w * g w) z = f z * deriv g z + deriv f z * g z"
    apply (rule DERIV_imp_deriv [OF DERIV_mult'])
    using s
    apply (auto simp: holomorphic_on_open field_differentiable_def DERIV_deriv_iff_field_differentiable)
    done
qed

lemma deriv_cmult_at:
  "f analytic_on {z} \<Longrightarrow>  deriv (\<lambda>w. c * f w) z = c * deriv f z"
by (auto simp: complex_derivative_mult_at)

lemma deriv_cmult_right_at:
  "f analytic_on {z} \<Longrightarrow>  deriv (\<lambda>w. f w * c) z = deriv f z * c"
by (auto simp: complex_derivative_mult_at)

subsection\<^marker>\<open>tag unimportant\<close>\<open>Complex differentiation of sequences and series\<close>

(* TODO: Could probably be simplified using Uniform_Limit *)
lemma has_complex_derivative_sequence:
  fixes S :: "complex set"
  assumes cvs: "convex S"
      and df:  "\<And>n x. x \<in> S \<Longrightarrow> (f n has_field_derivative f' n x) (at x within S)"
      and conv: "\<And>e. 0 < e \<Longrightarrow> \<exists>N. \<forall>n x. n \<ge> N \<longrightarrow> x \<in> S \<longrightarrow> norm (f' n x - g' x) \<le> e"
      and "\<exists>x l. x \<in> S \<and> ((\<lambda>n. f n x) \<longlongrightarrow> l) sequentially"
    shows "\<exists>g. \<forall>x \<in> S. ((\<lambda>n. f n x) \<longlongrightarrow> g x) sequentially \<and>
                       (g has_field_derivative (g' x)) (at x within S)"
proof -
  from assms obtain x l where x: "x \<in> S" and tf: "((\<lambda>n. f n x) \<longlongrightarrow> l) sequentially"
    by blast
  { fix e::real assume e: "e > 0"
    then obtain N where N: "\<forall>n\<ge>N. \<forall>x. x \<in> S \<longrightarrow> cmod (f' n x - g' x) \<le> e"
      by (metis conv)
    have "\<exists>N. \<forall>n\<ge>N. \<forall>x\<in>S. \<forall>h. cmod (f' n x * h - g' x * h) \<le> e * cmod h"
    proof (rule exI [of _ N], clarify)
      fix n y h
      assume "N \<le> n" "y \<in> S"
      then have "cmod (f' n y - g' y) \<le> e"
        by (metis N)
      then have "cmod h * cmod (f' n y - g' y) \<le> cmod h * e"
        by (auto simp: antisym_conv2 mult_le_cancel_left norm_triangle_ineq2)
      then show "cmod (f' n y * h - g' y * h) \<le> e * cmod h"
        by (simp add: norm_mult [symmetric] field_simps)
    qed
  } note ** = this
  show ?thesis
    unfolding has_field_derivative_def
  proof (rule has_derivative_sequence [OF cvs _ _ x])
    show "(\<lambda>n. f n x) \<longlonglongrightarrow> l"
      by (rule tf)
  next show "\<And>e. e > 0 \<Longrightarrow> \<forall>\<^sub>F n in sequentially. \<forall>x\<in>S. \<forall>h. cmod (f' n x * h - g' x * h) \<le> e * cmod h"
      unfolding eventually_sequentially by (blast intro: **)
  qed (metis has_field_derivative_def df)
qed

lemma has_complex_derivative_series:
  fixes S :: "complex set"
  assumes cvs: "convex S"
      and df:  "\<And>n x. x \<in> S \<Longrightarrow> (f n has_field_derivative f' n x) (at x within S)"
      and conv: "\<And>e. 0 < e \<Longrightarrow> \<exists>N. \<forall>n x. n \<ge> N \<longrightarrow> x \<in> S
                \<longrightarrow> cmod ((\<Sum>i<n. f' i x) - g' x) \<le> e"
      and "\<exists>x l. x \<in> S \<and> ((\<lambda>n. f n x) sums l)"
    shows "\<exists>g. \<forall>x \<in> S. ((\<lambda>n. f n x) sums g x) \<and> ((g has_field_derivative g' x) (at x within S))"
proof -
  from assms obtain x l where x: "x \<in> S" and sf: "((\<lambda>n. f n x) sums l)"
    by blast
  { fix e::real assume e: "e > 0"
    then obtain N where N: "\<forall>n x. n \<ge> N \<longrightarrow> x \<in> S
            \<longrightarrow> cmod ((\<Sum>i<n. f' i x) - g' x) \<le> e"
      by (metis conv)
    have "\<exists>N. \<forall>n\<ge>N. \<forall>x\<in>S. \<forall>h. cmod ((\<Sum>i<n. h * f' i x) - g' x * h) \<le> e * cmod h"
    proof (rule exI [of _ N], clarify)
      fix n y h
      assume "N \<le> n" "y \<in> S"
      then have "cmod ((\<Sum>i<n. f' i y) - g' y) \<le> e"
        by (metis N)
      then have "cmod h * cmod ((\<Sum>i<n. f' i y) - g' y) \<le> cmod h * e"
        by (auto simp: antisym_conv2 mult_le_cancel_left norm_triangle_ineq2)
      then show "cmod ((\<Sum>i<n. h * f' i y) - g' y * h) \<le> e * cmod h"
        by (simp add: norm_mult [symmetric] field_simps sum_distrib_left)
    qed
  } note ** = this
  show ?thesis
  unfolding has_field_derivative_def
  proof (rule has_derivative_series [OF cvs _ _ x])
    fix n x
    assume "x \<in> S"
    then show "((f n) has_derivative (\<lambda>z. z * f' n x)) (at x within S)"
      by (metis df has_field_derivative_def mult_commute_abs)
  next show " ((\<lambda>n. f n x) sums l)"
    by (rule sf)
  next show "\<And>e. e>0 \<Longrightarrow> \<forall>\<^sub>F n in sequentially. \<forall>x\<in>S. \<forall>h. cmod ((\<Sum>i<n. h * f' i x) - g' x * h) \<le> e * cmod h"
      unfolding eventually_sequentially by (blast intro: **)
  qed
qed

subsection\<^marker>\<open>tag unimportant\<close> \<open>Taylor on Complex Numbers\<close>

lemma sum_Suc_reindex:
  fixes f :: "nat \<Rightarrow> 'a::ab_group_add"
    shows  "sum f {0..n} = f 0 - f (Suc n) + sum (\<lambda>i. f (Suc i)) {0..n}"
by (induct n) auto

lemma field_Taylor:
  assumes S: "convex S"
      and f: "\<And>i x. x \<in> S \<Longrightarrow> i \<le> n \<Longrightarrow> (f i has_field_derivative f (Suc i) x) (at x within S)"
      and B: "\<And>x. x \<in> S \<Longrightarrow> norm (f (Suc n) x) \<le> B"
      and w: "w \<in> S"
      and z: "z \<in> S"
    shows "norm(f 0 z - (\<Sum>i\<le>n. f i w * (z-w) ^ i / (fact i)))
          \<le> B * norm(z - w)^(Suc n) / fact n"
proof -
  have wzs: "closed_segment w z \<subseteq> S" using assms
    by (metis convex_contains_segment)
  { fix u
    assume "u \<in> closed_segment w z"
    then have "u \<in> S"
      by (metis wzs subsetD)
    have "(\<Sum>i\<le>n. f i u * (- of_nat i * (z-u)^(i - 1)) / (fact i) +
                      f (Suc i) u * (z-u)^i / (fact i)) =
              f (Suc n) u * (z-u) ^ n / (fact n)"
    proof (induction n)
      case 0 show ?case by simp
    next
      case (Suc n)
      have "(\<Sum>i\<le>Suc n. f i u * (- of_nat i * (z-u) ^ (i - 1)) / (fact i) +
                             f (Suc i) u * (z-u) ^ i / (fact i)) =
           f (Suc n) u * (z-u) ^ n / (fact n) +
           f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n) / (fact (Suc n)) -
           f (Suc n) u * ((1 + of_nat n) * (z-u) ^ n) / (fact (Suc n))"
        using Suc by simp
      also have "... = f (Suc (Suc n)) u * (z-u) ^ Suc n / (fact (Suc n))"
      proof -
        have "(fact(Suc n)) *
             (f(Suc n) u *(z-u) ^ n / (fact n) +
               f(Suc(Suc n)) u *((z-u) *(z-u) ^ n) / (fact(Suc n)) -
               f(Suc n) u *((1 + of_nat n) *(z-u) ^ n) / (fact(Suc n))) =
            ((fact(Suc n)) *(f(Suc n) u *(z-u) ^ n)) / (fact n) +
            ((fact(Suc n)) *(f(Suc(Suc n)) u *((z-u) *(z-u) ^ n)) / (fact(Suc n))) -
            ((fact(Suc n)) *(f(Suc n) u *(of_nat(Suc n) *(z-u) ^ n))) / (fact(Suc n))"
          by (simp add: algebra_simps del: fact_Suc)
        also have "... = ((fact (Suc n)) * (f (Suc n) u * (z-u) ^ n)) / (fact n) +
                         (f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n)) -
                         (f (Suc n) u * ((1 + of_nat n) * (z-u) ^ n))"
          by (simp del: fact_Suc)
        also have "... = (of_nat (Suc n) * (f (Suc n) u * (z-u) ^ n)) +
                         (f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n)) -
                         (f (Suc n) u * ((1 + of_nat n) * (z-u) ^ n))"
          by (simp only: fact_Suc of_nat_mult ac_simps) simp
        also have "... = f (Suc (Suc n)) u * ((z-u) * (z-u) ^ n)"
          by (simp add: algebra_simps)
        finally show ?thesis
        by (simp add: mult_left_cancel [where c = "(fact (Suc n))", THEN iffD1] del: fact_Suc)
      qed
      finally show ?case .
    qed
    then have "((\<lambda>v. (\<Sum>i\<le>n. f i v * (z - v)^i / (fact i)))
                has_field_derivative f (Suc n) u * (z-u) ^ n / (fact n))
               (at u within S)"
      apply (intro derivative_eq_intros)
      apply (blast intro: assms \<open>u \<in> S\<close>)
      apply (rule refl)+
      apply (auto simp: field_simps)
      done
  } note sum_deriv = this
  { fix u
    assume u: "u \<in> closed_segment w z"
    then have us: "u \<in> S"
      by (metis wzs subsetD)
    have "norm (f (Suc n) u) * norm (z - u) ^ n \<le> norm (f (Suc n) u) * norm (u - z) ^ n"
      by (metis norm_minus_commute order_refl)
    also have "... \<le> norm (f (Suc n) u) * norm (z - w) ^ n"
      by (metis mult_left_mono norm_ge_zero power_mono segment_bound [OF u])
    also have "... \<le> B * norm (z - w) ^ n"
      by (metis norm_ge_zero zero_le_power mult_right_mono  B [OF us])
    finally have "norm (f (Suc n) u) * norm (z - u) ^ n \<le> B * norm (z - w) ^ n" .
  } note cmod_bound = this
  have "(\<Sum>i\<le>n. f i z * (z - z) ^ i / (fact i)) = (\<Sum>i\<le>n. (f i z / (fact i)) * 0 ^ i)"
    by simp
  also have "\<dots> = f 0 z / (fact 0)"
    by (subst sum_zero_power) simp
  finally have "norm (f 0 z - (\<Sum>i\<le>n. f i w * (z - w) ^ i / (fact i)))
                \<le> norm ((\<Sum>i\<le>n. f i w * (z - w) ^ i / (fact i)) -
                        (\<Sum>i\<le>n. f i z * (z - z) ^ i / (fact i)))"
    by (simp add: norm_minus_commute)
  also have "... \<le> B * norm (z - w) ^ n / (fact n) * norm (w - z)"
    apply (rule field_differentiable_bound
      [where f' = "\<lambda>w. f (Suc n) w * (z - w)^n / (fact n)"
         and S = "closed_segment w z", OF convex_closed_segment])
    apply (auto simp: DERIV_subset [OF sum_deriv wzs]
                  norm_divide norm_mult norm_power divide_le_cancel cmod_bound)
    done
  also have "...  \<le> B * norm (z - w) ^ Suc n / (fact n)"
    by (simp add: algebra_simps norm_minus_commute)
  finally show ?thesis .
qed

lemma complex_Taylor:
  assumes S: "convex S"
      and f: "\<And>i x. x \<in> S \<Longrightarrow> i \<le> n \<Longrightarrow> (f i has_field_derivative f (Suc i) x) (at x within S)"
      and B: "\<And>x. x \<in> S \<Longrightarrow> cmod (f (Suc n) x) \<le> B"
      and w: "w \<in> S"
      and z: "z \<in> S"
    shows "cmod(f 0 z - (\<Sum>i\<le>n. f i w * (z-w) ^ i / (fact i)))
          \<le> B * cmod(z - w)^(Suc n) / fact n"
  using assms by (rule field_Taylor)

text\<open>Something more like the traditional MVT for real components\<close>

lemma complex_mvt_line:
  assumes "\<And>u. u \<in> closed_segment w z \<Longrightarrow> (f has_field_derivative f'(u)) (at u)"
    shows "\<exists>u. u \<in> closed_segment w z \<and> Re(f z) - Re(f w) = Re(f'(u) * (z - w))"
proof -
  have twz: "\<And>t. (1 - t) *\<^sub>R w + t *\<^sub>R z = w + t *\<^sub>R (z - w)"
    by (simp add: real_vector.scale_left_diff_distrib real_vector.scale_right_diff_distrib)
  note assms[unfolded has_field_derivative_def, derivative_intros]
  show ?thesis
    apply (cut_tac mvt_simple
                     [of 0 1 "Re o f o (\<lambda>t. (1 - t) *\<^sub>R w +  t *\<^sub>R z)"
                      "\<lambda>u. Re o (\<lambda>h. f'((1 - u) *\<^sub>R w + u *\<^sub>R z) * h) o (\<lambda>t. t *\<^sub>R (z - w))"])
    apply auto
    apply (rule_tac x="(1 - x) *\<^sub>R w + x *\<^sub>R z" in exI)
    apply (auto simp: closed_segment_def twz) []
    apply (intro derivative_eq_intros has_derivative_at_withinI, simp_all)
    apply (simp add: fun_eq_iff real_vector.scale_right_diff_distrib)
    apply (force simp: twz closed_segment_def)
    done
qed

lemma complex_Taylor_mvt:
  assumes "\<And>i x. \<lbrakk>x \<in> closed_segment w z; i \<le> n\<rbrakk> \<Longrightarrow> ((f i) has_field_derivative f (Suc i) x) (at x)"
    shows "\<exists>u. u \<in> closed_segment w z \<and>
            Re (f 0 z) =
            Re ((\<Sum>i = 0..n. f i w * (z - w) ^ i / (fact i)) +
                (f (Suc n) u * (z-u)^n / (fact n)) * (z - w))"
proof -
  { fix u
    assume u: "u \<in> closed_segment w z"
    have "(\<Sum>i = 0..n.
               (f (Suc i) u * (z-u) ^ i - of_nat i * (f i u * (z-u) ^ (i - Suc 0))) /
               (fact i)) =
          f (Suc 0) u -
             (f (Suc (Suc n)) u * ((z-u) ^ Suc n) - (of_nat (Suc n)) * (z-u) ^ n * f (Suc n) u) /
             (fact (Suc n)) +
             (\<Sum>i = 0..n.
                 (f (Suc (Suc i)) u * ((z-u) ^ Suc i) - of_nat (Suc i) * (f (Suc i) u * (z-u) ^ i)) /
                 (fact (Suc i)))"
       by (subst sum_Suc_reindex) simp
    also have "... = f (Suc 0) u -
             (f (Suc (Suc n)) u * ((z-u) ^ Suc n) - (of_nat (Suc n)) * (z-u) ^ n * f (Suc n) u) /
             (fact (Suc n)) +
             (\<Sum>i = 0..n.
                 f (Suc (Suc i)) u * ((z-u) ^ Suc i) / (fact (Suc i))  -
                 f (Suc i) u * (z-u) ^ i / (fact i))"
      by (simp only: diff_divide_distrib fact_cancel ac_simps)
    also have "... = f (Suc 0) u -
             (f (Suc (Suc n)) u * (z-u) ^ Suc n - of_nat (Suc n) * (z-u) ^ n * f (Suc n) u) /
             (fact (Suc n)) +
             f (Suc (Suc n)) u * (z-u) ^ Suc n / (fact (Suc n)) - f (Suc 0) u"
      by (subst sum_Suc_diff) auto
    also have "... = f (Suc n) u * (z-u) ^ n / (fact n)"
      by (simp only: algebra_simps diff_divide_distrib fact_cancel)
    finally have "(\<Sum>i = 0..n. (f (Suc i) u * (z - u) ^ i
                             - of_nat i * (f i u * (z-u) ^ (i - Suc 0))) / (fact i)) =
                  f (Suc n) u * (z - u) ^ n / (fact n)" .
    then have "((\<lambda>u. \<Sum>i = 0..n. f i u * (z - u) ^ i / (fact i)) has_field_derivative
                f (Suc n) u * (z - u) ^ n / (fact n))  (at u)"
      apply (intro derivative_eq_intros)+
      apply (force intro: u assms)
      apply (rule refl)+
      apply (auto simp: ac_simps)
      done
  }
  then show ?thesis
    apply (cut_tac complex_mvt_line [of w z "\<lambda>u. \<Sum>i = 0..n. f i u * (z-u) ^ i / (fact i)"
               "\<lambda>u. (f (Suc n) u * (z-u)^n / (fact n))"])
    apply (auto simp add: intro: open_closed_segment)
    done
qed

end


(*
  File:    Sophomores_Dream.thy
  Author:  Manuel Eberl, University of Innsbruck
*)
section \<open>The Sophomore's Dream\<close>
theory Sophomores_Dream
  imports "HOL-Analysis.Analysis" "HOL-Real_Asymp.Real_Asymp"
begin

text \<open>
  This formalisation mostly follows the very clear proof sketch from Wikipedia~\<^cite>\<open>"wikipedia"\<close>.
  That article also provides an interesting historical perspective. A more detailed
  exploration of Bernoulli's historical proof can be found in the book by Dunham~\<^cite>\<open>"dunham"\<close>.

  The name `Sophomore's Dream' apparently comes from a book by Borwein et al., in analogy to
  the `Freshman's Dream' equation $(x+y)^n = x^n + y^n$ (which is generally \<^emph>\<open>not\<close> true except
  in rings of characteristic $n$).
\<close>

subsection \<open>Continuity and bounds for $x \log x$\<close>

lemma x_log_x_continuous: "continuous_on {0..1} (\<lambda>x::real. x * ln x)"
proof -
  have "continuous (at x within {0..1}) (\<lambda>x::real. x * ln x)" if "x \<in> {0..1}" for x
  proof (cases "x = 0")
    case True
    have "((\<lambda>x::real. x * ln x) \<longlongrightarrow> 0) (at_right 0)"
      by real_asymp
    thus ?thesis using True
      by (simp add: continuous_def Lim_ident_at at_within_Icc_at_right)
  qed (auto intro!: continuous_intros)
  thus ?thesis
    using continuous_on_eq_continuous_within by blast
qed

lemma x_log_x_within_01_le:
  assumes "x \<in> {0..(1::real)}"
  shows   "x * ln x \<in> {-exp (-1)..0}"
proof -
  have "x * ln x \<le> 0"
    using assms by (cases "x = 0") (auto simp: mult_nonneg_nonpos)
  let ?f = "\<lambda>x::real. x * ln x"
  have diff: "(?f has_field_derivative (ln x + 1)) (at x)" if "x > 0" for x
    using that by (auto intro!: derivative_eq_intros)
  have diff': "?f differentiable at x" if "x > 0" for x
    using diff[OF that] real_differentiable_def by blast

  consider "x = 0" | "x = 1" | "x = exp (-1)" | "0 < x" "x < exp (-1)" | "exp (-1) < x" "x < 1"
    using assms unfolding atLeastAtMost_iff by linarith
  hence "x * ln x \<ge> -exp (-1)"
  proof cases
    assume x: "0 < x" "x < exp (-1)"
    have "\<exists>l z. x < z \<and> z < exp (-1) \<and> (?f has_real_derivative l) (at z) \<and>
             ?f (exp (-1)) - ?f x = (exp (-1) - x) * l"
      using x by (intro MVT continuous_on_subset [OF x_log_x_continuous] diff') auto
    then obtain l z where lz:
      "x < z" "z < exp (-1)" "(?f has_real_derivative l) (at z)"
      "?f x = -exp (-1) - (exp (-1) - x) * l"
      by (auto simp: algebra_simps)
    have [simp]: "l = ln z + 1"
      using DERIV_unique[OF diff[of z] lz(3)] lz(1) x by auto
    have "ln z \<le> ln (exp (-1))"
      using lz x by (subst ln_le_cancel_iff) auto
    hence "(exp (- 1) - x) * l \<le> 0"
      using x lz by (intro mult_nonneg_nonpos) auto
    with lz show ?thesis
      by linarith
  next
    assume x: "exp (-1) < x" "x < 1"
    have "\<exists>l z. exp (-1) < z \<and> z < x \<and> (?f has_real_derivative l) (at z) \<and>
             ?f x - ?f (exp (-1)) = (x - exp (-1)) * l"
    proof (intro MVT continuous_on_subset [OF x_log_x_continuous] diff')
      fix t :: real assume t: "exp (-1) < t"
      show "t > 0"
        by (rule less_trans [OF _ t]) auto
    qed (use x in auto)
    then obtain l z where lz:
      "exp (-1) < z" "z < x" "(?f has_real_derivative l) (at z)"
      "?f x = -exp (-1) - (exp (-1) - x) * l"
      by (auto simp: algebra_simps)
    have "z > 0"
      by (rule less_trans [OF _ lz(1)]) auto
    have [simp]: "l = ln z + 1"
      using DERIV_unique[OF diff[of z] lz(3)] \<open>z > 0\<close> by auto
    have "ln z \<ge> ln (exp (-1))"
      using lz \<open>z > 0\<close> by (subst ln_le_cancel_iff) auto
    hence "(exp (- 1) - x) * l \<le> 0"
      using x lz by (intro mult_nonpos_nonneg) auto
    with lz show ?thesis
      by linarith
  qed auto

  with \<open>x * ln x \<le> 0\<close> show ?thesis
    by auto
qed

subsection \<open>Convergence, Summability, Integrability\<close>

text \<open>
  As a first result we can show that the two sums that occur in the two different versions
  of the Sophomore's Dream are absolutely summable. This is achieved by a simple comparison
  test with the series $\sum_{k=1}^\infty k^{-2}$, as $k^{-k} \in O(k^{-2})$.
\<close>
theorem abs_summable_sophomores_dream: "summable (\<lambda>k. 1 / real (k ^ k))"
proof (rule summable_comparison_test_bigo)
  show "(\<lambda>k. 1 / real (k ^ k)) \<in> O(\<lambda>k. 1 / real k ^ 2)"
    by real_asymp
  show "summable (\<lambda>n. norm (1 / real n ^ 2))"
    using inverse_power_summable[of 2, where ?'a = real] by (simp add: field_simps)
qed

text \<open>
  The existence of the integral is also fairly easy to show since the integrand is continuous
  and the integration domain is compact. There is, however, one hiccup: The integrand is not
  actually continuous.

  We have $\lim_{x\to 0} x^x = 1$, but in Isabelle $0^0$ is defined as \<open>0\<close> (for real numbers).
  Thus, there is a discontinuity at \<open>x = 0\<close>

  However, this is a removable discontinuity since for any $x>0$ we have $x^x = e^{x\log x}$, and
  as we have just shown, $e^{x \log x}$ \<^emph>\<open>is\<close> continuous on $[0, 1]$. Since the two integrands
  differ only for \<open>x = 0\<close> (which is negligible), the integral still exists.
\<close>
theorem integrable_sophomores_dream: "(\<lambda>x::real. x powr x) integrable_on {0..1}"
proof -
  have "(\<lambda>x::real. exp (x * ln x)) integrable_on {0..1}"
    by (intro integrable_continuous_real continuous_on_exp x_log_x_continuous)
  also have "?this \<longleftrightarrow> (\<lambda>x::real. exp (x * ln x)) integrable_on {0<..<1}"
    by (simp add: integrable_on_Icc_iff_Ioo)
  also have "\<dots> \<longleftrightarrow> (\<lambda>x::real. x powr x) integrable_on {0<..<1}"
    by (intro integrable_cong) (auto simp: powr_def)
  also have "\<dots> \<longleftrightarrow> ?thesis"
    by (simp add: integrable_on_Icc_iff_Ioo)
  finally show ?thesis .
qed

text \<open>
  Next, we have to show the absolute convergence of the two auxiliary sums that will occur in
  our proofs so that we can exchange the order of integration and summation. This is done
  with a straightforward application of the Weierstra\ss\ \<open>M\<close> test.
\<close>
lemma uniform_limit_sophomores_dream1:
  "uniform_limit {0..(1::real)}
      (\<lambda>n x. \<Sum>k<n. (x * ln x) ^ k / fact k)
      (\<lambda>x. \<Sum>k. (x * ln x) ^ k / fact k)
      sequentially"
proof (rule Weierstrass_m_test)
  show "summable (\<lambda>k. exp (-1) ^ k / fact k :: real)"
    using summable_exp[of "exp (-1)"] by (simp add: field_simps)
next
  fix k :: nat and x :: real
  assume x: "x \<in> {0..1}"
  have "norm ((x * ln x) ^ k / fact k) = norm (x * ln x) ^ k / fact k"
    by (simp add: power_abs)
  also have "\<dots> \<le> exp (-1) ^ k / fact k"
    by (intro divide_right_mono power_mono) (use x_log_x_within_01_le [of x] x in auto)
  finally show "norm ((x * ln x) ^ k / fact k) \<le> exp (- 1) ^ k / fact k" .
qed

lemma uniform_limit_sophomores_dream2:
  "uniform_limit {0..(1::real)}
      (\<lambda>n x. \<Sum>k<n. (-(x * ln x)) ^ k / fact k)
      (\<lambda>x. \<Sum>k. (-(x * ln x)) ^ k / fact k)
      sequentially"
proof (rule Weierstrass_m_test)
  show "summable (\<lambda>k. exp (-1) ^ k / fact k :: real)"
    using summable_exp[of "exp (-1)"] by (simp add: field_simps)
next
  fix k :: nat and x :: real
  assume x: "x \<in> {0..1}"
  have "norm ((-x * ln x) ^ k / fact k) = norm (x * ln x) ^ k / fact k"
    by (simp add: power_abs)
  also have "\<dots> \<le> exp (-1) ^ k / fact k"
    by (intro divide_right_mono power_mono) (use x_log_x_within_01_le [of x] x in auto)
  finally show "norm ((-(x * ln x)) ^ k / fact k) \<le> exp (- 1) ^ k / fact k" by simp
qed

subsection \<open>An auxiliary integral\<close>

text \<open>
  Next we compute the integral
    \[\int_0^1 (x\log x)^n\,\text{d}x = \frac{(-1)^n\, n!}{(n+1)^{n+1}}\ ,\]
  which is a key ingredient in our proof.
\<close>
lemma sophomores_dream_aux_integral:
  "((\<lambda>x. (x * ln x) ^ n) has_integral (- 1) ^ n * fact n / real ((n + 1) ^ (n + 1))) {0<..<1}"
proof -
  have "((\<lambda>t. t powr real n / exp t) has_integral fact n) {0..}"
    using Gamma_integral_real[of "n + 1"] by (auto simp: Gamma_fact powr_realpow)
  also have "?this \<longleftrightarrow> ((\<lambda>t. t powr real n / exp t) has_integral fact n) {0<..}"
  proof (rule has_integral_spike_set_eq)
    have eq: "{x \<in> {0<..} - {0..}. x powr real n / exp x \<noteq> 0} = {}"
      by auto
    thus "negligible {x \<in> {0<..} - {0..}. x powr real n / exp x \<noteq> 0}"
      by (subst eq) auto
    have "{x \<in> {0..} - {0<..}. x powr real n / exp x \<noteq> 0} \<subseteq> {0}"
      by auto
    moreover have "negligible {0::real}"
      by simp
    ultimately show "negligible {x \<in> {0..} - {0<..}. x powr real n / exp x \<noteq> 0}"
      by (meson negligible_subset)
  qed
  also have "\<dots> \<longleftrightarrow> ((\<lambda>t::real. t ^ n / exp t) has_integral fact n) {0<..}"
    by (intro has_integral_spike_eq) (auto simp: powr_realpow)
  finally have 1: "((\<lambda>t::real. t ^ n / exp t) has_integral fact n) {0<..}" .

  have "(\<lambda>x::real. \<bar>x\<bar> ^ n / exp x) integrable_on {0<..} \<longleftrightarrow>
        (\<lambda>x::real. x ^ n / exp x) integrable_on {0<..}"
    by (intro integrable_cong) auto
  hence 2: "(\<lambda>t::real. t ^ n / exp t) absolutely_integrable_on {0<..}"
    using 1 by (simp add: absolutely_integrable_on_def power_abs has_integral_iff)

  define g :: "real \<Rightarrow> real" where "g = (\<lambda>x. -ln x * (n + 1))"
  define g' :: "real \<Rightarrow> real" where "g' = (\<lambda>x. -(n + 1) / x)"
  define h :: "real \<Rightarrow> real" where "h = (\<lambda>u. exp (-u / (n + 1)))"
  have bij: "bij_betw g {0<..<1} {0<..}"
    by (rule bij_betwI[of _ _ _ h]) (auto simp: g_def h_def mult_neg_pos)
  have deriv: "(g has_real_derivative g' x) (at x within {0<..<1})"
    if "x \<in> {0<..<1}" for x
    unfolding g_def g'_def using that by (auto intro!: derivative_eq_intros simp: field_simps)

  have "(\<lambda>t::real. t ^ n / exp t) absolutely_integrable_on g ` {0<..<1} \<and>
        integral (g ` {0<..<1}) (\<lambda>t::real. t ^ n / exp t) = fact n"
    using 1 2 bij by (simp add: bij_betw_def has_integral_iff)
  also have "?this \<longleftrightarrow> ((\<lambda>x. \<bar>g' x\<bar> *\<^sub>R (g x ^ n / exp (g x))) absolutely_integrable_on {0<..<1} \<and>
                       integral {0<..<1} (\<lambda>x. \<bar>g' x\<bar> *\<^sub>R (g x ^ n / exp (g x))) = fact n)"
    by (intro has_absolute_integral_change_of_variables_1' [symmetric] deriv)
       (auto simp: inj_on_def g_def)
  finally have "((\<lambda>x. \<bar>g' x\<bar> *\<^sub>R (g x ^ n / exp (g x))) has_integral fact n) {0<..<1}"
    using eq_integralD set_lebesgue_integral_eq_integral(1) by blast
  also have "?this \<longleftrightarrow>
     ((\<lambda>x::real. ((-1)^n*(n+1)^(n+1)) *\<^sub>R (ln x ^ n * x ^ n)) has_integral fact n) {0<..<1}"
  proof (rule has_integral_cong)
    fix x :: real assume x: "x \<in> {0<..<1}"
    have "\<bar>g' x\<bar> *\<^sub>R (g x ^ n / exp (g x)) =
            (-1) ^ n * (real n + 1) ^ (n + 1) * ln x ^ n * (exp (ln x * (n + 1)) / x)"
      using x by (simp add: g_def g'_def exp_minus power_minus' divide_simps add_ac)
    also have "exp (ln x * (n + 1)) = x powr real (n + 1)"
      using x by (simp add: powr_def)
    also have "\<dots> / x = x ^ n"
      using x by (subst powr_realpow) auto
    finally show "\<bar>g' x\<bar> *\<^sub>R (g x ^ n / exp (g x)) =
                    ((-1)^n*(n+1)^(n+1)) *\<^sub>R (ln x ^ n * x ^ n)"
      by (simp add: algebra_simps)
  qed
  also have "\<dots> \<longleftrightarrow> ((\<lambda>x::real. ln x ^ n * x ^ n) has_integral
                      fact n /\<^sub>R real_of_int ((- 1) ^ n * int ((n + 1) ^ (n + 1)))) {0<..<1}"
    by (intro has_integral_cmul_iff') (auto simp del: power_Suc)
  also have "fact n /\<^sub>R real_of_int ((- 1) ^ n * int ((n + 1) ^ (n + 1))) =
             (-1) ^ n * fact n / (n+1) ^ (n+1)"
    by (auto simp: divide_simps)
  finally show ?thesis
    by (simp add: power_mult_distrib mult_ac)
qed

subsection \<open>Main proofs\<close>

text \<open>
  We can now show the first formula: $\int_0^1 x^{-x}\,\text{d}x = \sum_{n=1}^\infty n^{-n}$
\<close>
lemma sophomores_dream_aux1:
  "summable (\<lambda>k. 1 / real ((k+1)^(k+1)))"
  "integral {0..1} (\<lambda>x. x powr (-x)) = (\<Sum>n. 1 / (n+1)^(n+1))"
proof -
  define S where "S = (\<lambda>x::real. \<Sum>k. (-(x * ln x)) ^ k / fact k)"
  have S_eq: "S x = x powr (-x)" if "x > 0" for x
  proof -
    have "S x = exp (-x * ln x)"
      by (simp add: S_def exp_def field_simps)
    also have "\<dots> = x powr (-x)"
      using \<open>x > 0\<close> by (simp add: powr_def)
    finally show ?thesis .
  qed

  have cont: "continuous_on {0..1} (\<lambda>x::real. \<Sum>k<n. (-(x * ln x)) ^ k / fact k)" for n
    by (intro continuous_on_sum continuous_on_divide x_log_x_continuous continuous_on_power
              continuous_on_const continuous_on_minus) auto

  obtain I J where IJ: "\<And>n. ((\<lambda>x. \<Sum>k<n. (-(x * ln x)) ^ k / fact k) has_integral I n) {0..1}"
                       "(S has_integral J) {0..1}" "I \<longlonglongrightarrow> J"
    using uniform_limit_integral [OF uniform_limit_sophomores_dream2 cont] by (auto simp: S_def)

  note \<open>(S has_integral J) {0..1}\<close>
  also have "(S has_integral J) {0..1} \<longleftrightarrow> (S has_integral J) {0<..<1}"
    by (simp add: has_integral_Icc_iff_Ioo)
  also have "\<dots> \<longleftrightarrow> ((\<lambda>x. x powr (-x)) has_integral J) {0<..<1}"
    by (intro has_integral_cong) (use S_eq in auto)
  also have "\<dots> \<longleftrightarrow> ((\<lambda>x. x powr (-x)) has_integral J) {0..1}"
    by (simp add: has_integral_Icc_iff_Ioo)
  finally have integral: "((\<lambda>x. x powr (-x)) has_integral J) {0..1}" .

  have I_eq: "I = (\<lambda>n. \<Sum>k<n. 1 / real ((k+1)^(k+1)))"
  proof
    fix n :: nat
    have "((\<lambda>x::real. \<Sum>k<n. (-1)^k * ((x * ln x) ^ k / fact k)) has_integral
            (\<Sum>k<n. (-1)^k * ((-1)^k * fact k / real ((k + 1) ^ (k + 1)) / fact k))) {0<..<1}"
      by (intro has_integral_sum[OF _ has_integral_mult_right] has_integral_divide
                sophomores_dream_aux_integral) auto
    also have "(\<lambda>x::real. \<Sum>k<n. (-1)^k * ((x * ln x) ^ k / fact k)) =
               (\<lambda>x::real. \<Sum>k<n. (-(x * ln x)) ^ k / fact k)"
      by (simp add: power_minus')
    also have "(\<Sum>k<n. (-1)^k * ((-1) ^ k * fact k / real ((k + 1) ^ (k + 1)) / fact k)) =
               (\<Sum>k<n. 1 / real ((k + 1) ^ (k + 1)))"
      by simp
    also note has_integral_Icc_iff_Ioo [symmetric]
    finally show "I n = (\<Sum>k<n. 1 / real ((k+1)^(k+1)))"
      by (rule has_integral_unique [OF IJ(1)[of n]])
  qed
  hence sums: "(\<lambda>k. 1 / real ((k + 1) ^ (k + 1))) sums J"
    using IJ(3) I_eq by (simp add: sums_def)

  from sums show "summable (\<lambda>k. 1 / real ((k+1)^(k+1)))"
    by (simp add: sums_iff)
  from integral sums show "integral {0..1} (\<lambda>x. x powr (-x)) = (\<Sum>n. 1 / (n+1)^(n+1))"
    by (simp add: sums_iff has_integral_iff)
qed

theorem sophomores_dream1:
  "(\<lambda>k::nat. norm (k powi (-k))) summable_on {1..}"
  "integral {0..1} (\<lambda>x. x powr (-x)) = (\<Sum>\<^sub>\<infinity> k\<in>{(1::nat)..}. k powi (-k))"
proof -
  let ?I = "integral {0..1} (\<lambda>x. x powr (-x))"
  have "(\<lambda>k::nat. norm (k powi (-k))) summable_on UNIV"
    using abs_summable_sophomores_dream
    by (intro norm_summable_imp_summable_on) (auto simp: power_int_minus field_simps)
  thus "(\<lambda>k::nat. norm (k powi (-k))) summable_on {1..}"
    by (rule summable_on_subset_banach) auto

  have "(\<lambda>n. 1 / (n+1)^(n+1)) sums ?I"
    using sophomores_dream_aux1 by (simp add: sums_iff)
  moreover have "summable (\<lambda>n. norm (1 / real (Suc n ^ Suc n)))"
    by (subst summable_Suc_iff) (use abs_summable_sophomores_dream in \<open>auto simp: field_simps\<close>)
  ultimately have "((\<lambda>n::nat. 1 / (n+1)^(n+1)) has_sum ?I) UNIV"
    by (intro norm_summable_imp_has_sum) auto
  also have "?this \<longleftrightarrow> (((\<lambda>n::nat. 1 / n^n) \<circ> Suc) has_sum ?I) UNIV"
    by (simp add: o_def field_simps)
  also have "\<dots> \<longleftrightarrow> ((\<lambda>n::nat. 1 / n^n) has_sum ?I) (Suc ` UNIV)"
    by (intro has_sum_reindex [symmetric]) auto
  also have "Suc ` UNIV = {1..}"
    using greaterThan_0 by auto
  also have "((\<lambda>n::nat. (1 / real (n ^ n))) has_sum ?I) {1..} \<longleftrightarrow>
             ((\<lambda>n::nat. n powi (-n)) has_sum ?I) {1..}"
    by (intro has_sum_cong) (auto simp: power_int_minus field_simps power_minus')
  finally show "integral {0..1} (\<lambda>x. x powr (-x)) = (\<Sum>\<^sub>\<infinity>k\<in>{(1::nat)..}. k powi (-k))"
    by (auto dest!: infsumI simp: algebra_simps)
qed

text \<open>
  Next, we show the second formula: $\int_0^1 x^x\,\text{d}x = -\sum_{n=1}^\infty (-n)^{-n}$
\<close>
lemma sophomores_dream_aux2:
  "summable (\<lambda>k. (-1) ^ k / real ((k+1)^(k+1)))"
  "integral {0..1} (\<lambda>x. x powr x) = (\<Sum>n. (-1)^n / (n+1)^(n+1))"
proof -
  define S where "S = (\<lambda>x::real. \<Sum>k. (x * ln x) ^ k / fact k)"
  have S_eq: "S x = x powr x" if "x > 0" for x
  proof -
    have "S x = exp (x * ln x)"
      by (simp add: S_def exp_def field_simps)
    also have "\<dots> = x powr x"
      using \<open>x > 0\<close> by (simp add: powr_def)
    finally show ?thesis .
  qed

  have cont: "continuous_on {0..1} (\<lambda>x::real. \<Sum>k<n. (x * ln x) ^ k / fact k)" for n
    by (intro continuous_on_sum continuous_on_divide x_log_x_continuous continuous_on_power
              continuous_on_const) auto

  obtain I J where IJ: "\<And>n. ((\<lambda>x. \<Sum>k<n. (x * ln x) ^ k / fact k) has_integral I n) {0..1}"
                       "(S has_integral J) {0..1}" "I \<longlonglongrightarrow> J"
    using uniform_limit_integral [OF uniform_limit_sophomores_dream1 cont] by (auto simp: S_def)

  note \<open>(S has_integral J) {0..1}\<close>
  also have "(S has_integral J) {0..1} \<longleftrightarrow> (S has_integral J) {0<..<1}"
    by (simp add: has_integral_Icc_iff_Ioo)
  also have "\<dots> \<longleftrightarrow> ((\<lambda>x. x powr x) has_integral J) {0<..<1}"
    by (intro has_integral_cong) (use S_eq in auto)
  also have "\<dots> \<longleftrightarrow> ((\<lambda>x. x powr x) has_integral J) {0..1}"
    by (simp add: has_integral_Icc_iff_Ioo)
  finally have integral: "((\<lambda>x. x powr x) has_integral J) {0..1}" .

  have I_eq: "I = (\<lambda>n. \<Sum>k<n. (-1) ^ k / real ((k+1)^(k+1)))"
  proof
    fix n :: nat
    have "((\<lambda>x::real. \<Sum>k<n. (x * ln x) ^ k / fact k) has_integral
            (\<Sum>k<n. (-1) ^ k * fact k / real ((k + 1) ^ (k + 1)) / fact k)) {0<..<1}"
      by (intro has_integral_sum has_integral_divide sophomores_dream_aux_integral) auto
    also have "(\<Sum>k<n. (- 1) ^ k * fact k / real ((k + 1) ^ (k + 1)) / fact k) =
               (\<Sum>k<n. (- 1) ^ k / real ((k + 1) ^ (k + 1)))"
      by simp
    also note has_integral_Icc_iff_Ioo [symmetric]
    finally show "I n = (\<Sum>k<n. (-1) ^ k / real ((k+1)^(k+1)))"
      by (rule has_integral_unique [OF IJ(1)[of n]])
  qed
  hence sums: "(\<lambda>k. (-1) ^ k / real ((k + 1) ^ (k + 1))) sums J"
    using IJ(3) I_eq by (simp add: sums_def)

  from sums show "summable (\<lambda>k. (-1) ^ k / real ((k+1)^(k+1)))"
    by (simp add: sums_iff)
  from integral sums show "integral {0..1} (\<lambda>x. x powr x) = (\<Sum>n. (-1)^n / (n+1)^(n+1))"
    by (simp add: sums_iff has_integral_iff)
qed

theorem sophomores_dream2:
  "(\<lambda>k::nat. norm ((-k) powi (-k))) summable_on {1..}"
  "integral {0..1} (\<lambda>x. x powr x) = -(\<Sum>\<^sub>\<infinity> k\<in>{(1::nat)..}. (-k) powi (-k))"
proof -
  let ?I = "integral {0..1} (\<lambda>x. x powr x)"
  have "(\<lambda>k::nat. norm ((-k) powi (-k))) summable_on UNIV"
    using abs_summable_sophomores_dream
    by (intro norm_summable_imp_summable_on) (auto simp: power_int_minus field_simps)
  thus "(\<lambda>k::nat. norm ((-k) powi (-k))) summable_on {1..}"
    by (rule summable_on_subset_banach) auto

  have "(\<lambda>n. (-1)^n / (n+1)^(n+1)) sums ?I"
    using sophomores_dream_aux2 by (simp add: sums_iff)
  moreover have "summable (\<lambda>n. 1 / real (Suc n ^ Suc n))"
    by (subst summable_Suc_iff) (use abs_summable_sophomores_dream in \<open>auto simp: field_simps\<close>)
  hence "summable (\<lambda>n. norm ((- 1) ^ n / real (Suc n ^ Suc n)))"
    by simp
  ultimately have "((\<lambda>n::nat. (-1)^n / (n+1)^(n+1)) has_sum ?I) UNIV"
    by (intro norm_summable_imp_has_sum) auto
  also have "?this \<longleftrightarrow> (((\<lambda>n::nat. -((-1)^n / n^n)) \<circ> Suc) has_sum ?I) UNIV"
    by (simp add: o_def field_simps)
  also have "\<dots> \<longleftrightarrow> ((\<lambda>n::nat. -((-1)^n / n ^ n)) has_sum ?I) (Suc ` UNIV)"
    by (intro has_sum_reindex [symmetric]) auto
  also have "Suc ` UNIV = {1..}"
    using greaterThan_0 by auto
  also have "((\<lambda>n::nat. -((- 1) ^ n / real (n ^ n))) has_sum ?I) {1..} \<longleftrightarrow>
             ((\<lambda>n::nat. -((-n) powi (-n))) has_sum ?I) {1..}"
    by (intro has_sum_cong) (auto simp: power_int_minus field_simps power_minus')
  also have "\<dots> \<longleftrightarrow> ((\<lambda>n::nat. (-n) powi (-n)) has_sum (-?I)) {1..}"
    by (simp add: has_sum_uminus)
  finally show "integral {0..1} (\<lambda>x. x powr x) = -(\<Sum>\<^sub>\<infinity>k\<in>{(1::nat)..}. (-k) powi (-k))"
    by (auto dest!: infsumI simp: algebra_simps)
qed

end


(*  Title:      HOL/Complete_Partial_Order.thy
    Author:     Brian Huffman, Portland State University
    Author:     Alexander Krauss, TU Muenchen
*)

section \<open>Chain-complete partial orders and their fixpoints\<close>

theory Complete_Partial_Order
  imports Product_Type
begin

subsection \<open>Monotone functions\<close>

text \<open>Dictionary-passing version of \<^const>\<open>Orderings.mono\<close>.\<close>

definition monotone :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
  where "monotone orda ordb f \<longleftrightarrow> (\<forall>x y. orda x y \<longrightarrow> ordb (f x) (f y))"

lemma monotoneI[intro?]: "(\<And>x y. orda x y \<Longrightarrow> ordb (f x) (f y)) \<Longrightarrow> monotone orda ordb f"
  unfolding monotone_def by iprover

lemma monotoneD[dest?]: "monotone orda ordb f \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)"
  unfolding monotone_def by iprover

subsection \<open>Chains\<close>

text \<open>
  A chain is a totally-ordered set. Chains are parameterized over
  the order for maximal flexibility, since type classes are not enough.
\<close>

definition chain :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
  where "chain ord S \<longleftrightarrow> (\<forall>x\<in>S. \<forall>y\<in>S. ord x y \<or> ord y x)"

lemma chainI:
  assumes "\<And>x y. x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> ord x y \<or> ord y x"
  shows "chain ord S"
  using assms unfolding chain_def by fast

lemma chainD:
  assumes "chain ord S" and "x \<in> S" and "y \<in> S"
  shows "ord x y \<or> ord y x"
  using assms unfolding chain_def by fast

lemma chainE:
  assumes "chain ord S" and "x \<in> S" and "y \<in> S"
  obtains "ord x y" | "ord y x"
  using assms unfolding chain_def by fast

lemma chain_empty: "chain ord {}"
  by (simp add: chain_def)

lemma chain_equality: "chain (=) A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x = y)"
  by (auto simp add: chain_def)

lemma chain_subset: "chain ord A \<Longrightarrow> B \<subseteq> A \<Longrightarrow> chain ord B"
  by (rule chainI) (blast dest: chainD)

lemma chain_imageI:
  assumes chain: "chain le_a Y"
    and mono: "\<And>x y. x \<in> Y \<Longrightarrow> y \<in> Y \<Longrightarrow> le_a x y \<Longrightarrow> le_b (f x) (f y)"
  shows "chain le_b (f ` Y)"
  by (blast intro: chainI dest: chainD[OF chain] mono)

subsection \<open>Chain-complete partial orders\<close>

text \<open>
  A \<open>ccpo\<close> has a least upper bound for any chain.  In particular, the
  empty set is a chain, so every \<open>ccpo\<close> must have a bottom element.
\<close>

class ccpo = order + Sup +
  assumes ccpo_Sup_upper: "chain (\<le>) A \<Longrightarrow> x \<in> A \<Longrightarrow> x \<le> Sup A"
  assumes ccpo_Sup_least: "chain (\<le>) A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup A \<le> z"
begin

lemma chain_singleton: "Complete_Partial_Order.chain (\<le>) {x}"
  by (rule chainI) simp

lemma ccpo_Sup_singleton [simp]: "\<Squnion>{x} = x"
  by (rule antisym) (auto intro: ccpo_Sup_least ccpo_Sup_upper simp add: chain_singleton)

subsection \<open>Transfinite iteration of a function\<close>

context notes [[inductive_internals]]
begin

inductive_set iterates :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a set"
  for f :: "'a \<Rightarrow> 'a"
  where
    step: "x \<in> iterates f \<Longrightarrow> f x \<in> iterates f"
  | Sup: "chain (\<le>) M \<Longrightarrow> \<forall>x\<in>M. x \<in> iterates f \<Longrightarrow> Sup M \<in> iterates f"

end

lemma iterates_le_f: "x \<in> iterates f \<Longrightarrow> monotone (\<le>) (\<le>) f \<Longrightarrow> x \<le> f x"
  by (induct x rule: iterates.induct)
    (force dest: monotoneD intro!: ccpo_Sup_upper ccpo_Sup_least)+

lemma chain_iterates:
  assumes f: "monotone (\<le>) (\<le>) f"
  shows "chain (\<le>) (iterates f)" (is "chain _ ?C")
proof (rule chainI)
  fix x y
  assume "x \<in> ?C" "y \<in> ?C"
  then show "x \<le> y \<or> y \<le> x"
  proof (induct x arbitrary: y rule: iterates.induct)
    fix x y
    assume y: "y \<in> ?C"
      and IH: "\<And>z. z \<in> ?C \<Longrightarrow> x \<le> z \<or> z \<le> x"
    from y show "f x \<le> y \<or> y \<le> f x"
    proof (induct y rule: iterates.induct)
      case (step y)
      with IH f show ?case by (auto dest: monotoneD)
    next
      case (Sup M)
      then have chM: "chain (\<le>) M"
        and IH': "\<And>z. z \<in> M \<Longrightarrow> f x \<le> z \<or> z \<le> f x" by auto
      show "f x \<le> Sup M \<or> Sup M \<le> f x"
      proof (cases "\<exists>z\<in>M. f x \<le> z")
        case True
        then have "f x \<le> Sup M"
          apply rule
          apply (erule order_trans)
          apply (rule ccpo_Sup_upper[OF chM])
          apply assumption
          done
        then show ?thesis ..
      next
        case False
        with IH' show ?thesis
          by (auto intro: ccpo_Sup_least[OF chM])
      qed
    qed
  next
    case (Sup M y)
    show ?case
    proof (cases "\<exists>x\<in>M. y \<le> x")
      case True
      then have "y \<le> Sup M"
        apply rule
        apply (erule order_trans)
        apply (rule ccpo_Sup_upper[OF Sup(1)])
        apply assumption
        done
      then show ?thesis ..
    next
      case False with Sup
      show ?thesis by (auto intro: ccpo_Sup_least)
    qed
  qed
qed

lemma bot_in_iterates: "Sup {} \<in> iterates f"
  by (auto intro: iterates.Sup simp add: chain_empty)

subsection \<open>Fixpoint combinator\<close>

definition fixp :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a"
  where "fixp f = Sup (iterates f)"

lemma iterates_fixp:
  assumes f: "monotone (\<le>) (\<le>) f"
  shows "fixp f \<in> iterates f"
  unfolding fixp_def
  by (simp add: iterates.Sup chain_iterates f)

lemma fixp_unfold:
  assumes f: "monotone (\<le>) (\<le>) f"
  shows "fixp f = f (fixp f)"
proof (rule antisym)
  show "fixp f \<le> f (fixp f)"
    by (intro iterates_le_f iterates_fixp f)
  have "f (fixp f) \<le> Sup (iterates f)"
    by (intro ccpo_Sup_upper chain_iterates f iterates.step iterates_fixp)
  then show "f (fixp f) \<le> fixp f"
    by (simp only: fixp_def)
qed

lemma fixp_lowerbound:
  assumes f: "monotone (\<le>) (\<le>) f"
    and z: "f z \<le> z"
  shows "fixp f \<le> z"
  unfolding fixp_def
proof (rule ccpo_Sup_least[OF chain_iterates[OF f]])
  fix x
  assume "x \<in> iterates f"
  then show "x \<le> z"
  proof (induct x rule: iterates.induct)
    case (step x)
    from f \<open>x \<le> z\<close> have "f x \<le> f z" by (rule monotoneD)
    also note z
    finally show "f x \<le> z" .
  next
    case (Sup M)
    then show ?case
      by (auto intro: ccpo_Sup_least)
  qed
qed

end

subsection \<open>Fixpoint induction\<close>

setup \<open>Sign.map_naming (Name_Space.mandatory_path "ccpo")\<close>

definition admissible :: "('a set \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
  where "admissible lub ord P \<longleftrightarrow> (\<forall>A. chain ord A \<longrightarrow> A \<noteq> {} \<longrightarrow> (\<forall>x\<in>A. P x) \<longrightarrow> P (lub A))"

lemma admissibleI:
  assumes "\<And>A. chain ord A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> \<forall>x\<in>A. P x \<Longrightarrow> P (lub A)"
  shows "ccpo.admissible lub ord P"
  using assms unfolding ccpo.admissible_def by fast

lemma admissibleD:
  assumes "ccpo.admissible lub ord P"
  assumes "chain ord A"
  assumes "A \<noteq> {}"
  assumes "\<And>x. x \<in> A \<Longrightarrow> P x"
  shows "P (lub A)"
  using assms by (auto simp: ccpo.admissible_def)

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

lemma (in ccpo) fixp_induct:
  assumes adm: "ccpo.admissible Sup (\<le>) P"
  assumes mono: "monotone (\<le>) (\<le>) f"
  assumes bot: "P (Sup {})"
  assumes step: "\<And>x. P x \<Longrightarrow> P (f x)"
  shows "P (fixp f)"
  unfolding fixp_def
  using adm chain_iterates[OF mono]
proof (rule ccpo.admissibleD)
  show "iterates f \<noteq> {}"
    using bot_in_iterates by auto
next
  fix x
  assume "x \<in> iterates f"
  then show "P x"
  proof (induct rule: iterates.induct)
    case prems: (step x)
    from this(2) show ?case by (rule step)
  next
    case (Sup M)
    then show ?case by (cases "M = {}") (auto intro: step bot ccpo.admissibleD adm)
  qed
qed

lemma admissible_True: "ccpo.admissible lub ord (\<lambda>x. True)"
  unfolding ccpo.admissible_def by simp

(*lemma admissible_False: "\<not> ccpo.admissible lub ord (\<lambda>x. False)"
unfolding ccpo.admissible_def chain_def by simp
*)
lemma admissible_const: "ccpo.admissible lub ord (\<lambda>x. t)"
  by (auto intro: ccpo.admissibleI)

lemma admissible_conj:
  assumes "ccpo.admissible lub ord (\<lambda>x. P x)"
  assumes "ccpo.admissible lub ord (\<lambda>x. Q x)"
  shows "ccpo.admissible lub ord (\<lambda>x. P x \<and> Q x)"
  using assms unfolding ccpo.admissible_def by simp

lemma admissible_all:
  assumes "\<And>y. ccpo.admissible lub ord (\<lambda>x. P x y)"
  shows "ccpo.admissible lub ord (\<lambda>x. \<forall>y. P x y)"
  using assms unfolding ccpo.admissible_def by fast

lemma admissible_ball:
  assumes "\<And>y. y \<in> A \<Longrightarrow> ccpo.admissible lub ord (\<lambda>x. P x y)"
  shows "ccpo.admissible lub ord (\<lambda>x. \<forall>y\<in>A. P x y)"
  using assms unfolding ccpo.admissible_def by fast

lemma chain_compr: "chain ord A \<Longrightarrow> chain ord {x \<in> A. P x}"
  unfolding chain_def by fast

context ccpo
begin

lemma admissible_disj:
  fixes P Q :: "'a \<Rightarrow> bool"
  assumes P: "ccpo.admissible Sup (\<le>) (\<lambda>x. P x)"
  assumes Q: "ccpo.admissible Sup (\<le>) (\<lambda>x. Q x)"
  shows "ccpo.admissible Sup (\<le>) (\<lambda>x. P x \<or> Q x)"
proof (rule ccpo.admissibleI)
  fix A :: "'a set"
  assume chain: "chain (\<le>) A"
  assume A: "A \<noteq> {}" and P_Q: "\<forall>x\<in>A. P x \<or> Q x"
  have "(\<exists>x\<in>A. P x) \<and> (\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> P y) \<or> (\<exists>x\<in>A. Q x) \<and> (\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> Q y)"
    (is "?P \<or> ?Q" is "?P1 \<and> ?P2 \<or> _")
  proof (rule disjCI)
    assume "\<not> ?Q"
    then consider "\<forall>x\<in>A. \<not> Q x" | a where "a \<in> A" "\<forall>y\<in>A. a \<le> y \<longrightarrow> \<not> Q y"
      by blast
    then show ?P
    proof cases
      case 1
      with P_Q have "\<forall>x\<in>A. P x" by blast
      with A show ?P by blast
    next
      case 2
      note a = \<open>a \<in> A\<close>
      show ?P
      proof
        from P_Q 2 have *: "\<forall>y\<in>A. a \<le> y \<longrightarrow> P y" by blast
        with a have "P a" by blast
        with a show ?P1 by blast
        show ?P2
        proof
          fix x
          assume x: "x \<in> A"
          with chain a show "\<exists>y\<in>A. x \<le> y \<and> P y"
          proof (rule chainE)
            assume le: "a \<le> x"
            with * a x have "P x" by blast
            with x le show ?thesis by blast
          next
            assume "a \<ge> x"
            with a \<open>P a\<close> show ?thesis by blast
          qed
        qed
      qed
    qed
  qed
  moreover
  have "Sup A = Sup {x \<in> A. P x}" if "\<forall>x\<in>A. \<exists>y\<in>A. x \<le> y \<and> P y" for P
  proof (rule antisym)
    have chain_P: "chain (\<le>) {x \<in> A. P x}"
      by (rule chain_compr [OF chain])
    show "Sup A \<le> Sup {x \<in> A. P x}"
      apply (rule ccpo_Sup_least [OF chain])
      apply (drule that [rule_format])
      apply clarify
      apply (erule order_trans)
      apply (simp add: ccpo_Sup_upper [OF chain_P])
      done
    show "Sup {x \<in> A. P x} \<le> Sup A"
      apply (rule ccpo_Sup_least [OF chain_P])
      apply clarify
      apply (simp add: ccpo_Sup_upper [OF chain])
      done
  qed
  ultimately
  consider "\<exists>x. x \<in> A \<and> P x" "Sup A = Sup {x \<in> A. P x}"
    | "\<exists>x. x \<in> A \<and> Q x" "Sup A = Sup {x \<in> A. Q x}"
    by blast
  then show "P (Sup A) \<or> Q (Sup A)"
    apply cases
     apply simp_all
     apply (rule disjI1)
     apply (rule ccpo.admissibleD [OF P chain_compr [OF chain]]; simp)
    apply (rule disjI2)
    apply (rule ccpo.admissibleD [OF Q chain_compr [OF chain]]; simp)
    done
qed

end

instance complete_lattice \<subseteq> ccpo
  by standard (fast intro: Sup_upper Sup_least)+

lemma lfp_eq_fixp:
  assumes mono: "mono f"
  shows "lfp f = fixp f"
proof (rule antisym)
  from mono have f': "monotone (\<le>) (\<le>) f"
    unfolding mono_def monotone_def .
  show "lfp f \<le> fixp f"
    by (rule lfp_lowerbound, subst fixp_unfold [OF f'], rule order_refl)
  show "fixp f \<le> lfp f"
    by (rule fixp_lowerbound [OF f']) (simp add: lfp_fixpoint [OF mono])
qed

hide_const (open) iterates fixp

end