(*  Title:      HOL/Analysis/Continuous_Extension.thy
    Authors:    LC Paulson, based on material from HOL Light
*)

section \<open>Continuous Extensions of Functions\<close>

theory Continuous_Extension
imports Starlike
begin

subsection\<open>Partitions of unity subordinate to locally finite open coverings\<close>

text\<open>A difference from HOL Light: all summations over infinite sets equal zero,
   so the "support" must be made explicit in the summation below!\<close>

proposition subordinate_partition_of_unity:
  fixes S :: "'a::metric_space set"
  assumes "S \<subseteq> \<Union>\<C>" and opC: "\<And>T. T \<in> \<C> \<Longrightarrow> open T"
      and fin: "\<And>x. x \<in> S \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. U \<inter> V \<noteq> {}}"
  obtains F :: "['a set, 'a] \<Rightarrow> real"
    where "\<And>U. U \<in> \<C> \<Longrightarrow> continuous_on S (F U) \<and> (\<forall>x \<in> S. 0 \<le> F U x)"
      and "\<And>x U. \<lbrakk>U \<in> \<C>; x \<in> S; x \<notin> U\<rbrakk> \<Longrightarrow> F U x = 0"
      and "\<And>x. x \<in> S \<Longrightarrow> supp_sum (\<lambda>W. F W x) \<C> = 1"
      and "\<And>x. x \<in> S \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. \<exists>x\<in>V. F U x \<noteq> 0}"
proof (cases "\<exists>W. W \<in> \<C> \<and> S \<subseteq> W")
  case True
    then obtain W where "W \<in> \<C>" "S \<subseteq> W" by metis
    then show ?thesis
      by (rule_tac F = "\<lambda>V x. if V = W then 1 else 0" in that) (auto simp: supp_sum_def support_on_def)
next
  case False
    have nonneg: "0 \<le> supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>" for x
      by (simp add: supp_sum_def sum_nonneg)
    have sd_pos: "0 < setdist {x} (S - V)" if "V \<in> \<C>" "x \<in> S" "x \<in> V" for V x
    proof -
      have "closedin (top_of_set S) (S - V)"
        by (simp add: Diff_Diff_Int closedin_def opC openin_open_Int \<open>V \<in> \<C>\<close>)
      with that False  setdist_pos_le [of "{x}" "S - V"]
      show ?thesis
        using setdist_gt_0_closedin by fastforce
    qed
    have ss_pos: "0 < supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>" if "x \<in> S" for x
    proof -
      obtain U where "U \<in> \<C>" "x \<in> U" using \<open>x \<in> S\<close> \<open>S \<subseteq> \<Union>\<C>\<close>
        by blast
      obtain V where "open V" "x \<in> V" "finite {U \<in> \<C>. U \<inter> V \<noteq> {}}"
        using \<open>x \<in> S\<close> fin by blast
      then have *: "finite {A \<in> \<C>. \<not> S \<subseteq> A \<and> x \<notin> closure (S - A)}"
        using closure_def that by (blast intro: rev_finite_subset)
      have "x \<notin> closure (S - U)"
        using \<open>U \<in> \<C>\<close> \<open>x \<in> U\<close> opC open_Int_closure_eq_empty by fastforce
      then show ?thesis
        apply (simp add: setdist_eq_0_sing_1 supp_sum_def support_on_def)
        apply (rule ordered_comm_monoid_add_class.sum_pos2 [OF *, of U])
        using \<open>U \<in> \<C>\<close> \<open>x \<in> U\<close> False
        apply (auto simp: sd_pos that)
        done
    qed
    define F where
      "F \<equiv> \<lambda>W x. if x \<in> S then setdist {x} (S - W) / supp_sum (\<lambda>V. setdist {x} (S - V)) \<C> else 0"
    show ?thesis
    proof (rule_tac F = F in that)
      have "continuous_on S (F U)" if "U \<in> \<C>" for U
      proof -
        have *: "continuous_on S (\<lambda>x. supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>)"
        proof (clarsimp simp add: continuous_on_eq_continuous_within)
          fix x assume "x \<in> S"
          then obtain X where "open X" and x: "x \<in> S \<inter> X" and finX: "finite {U \<in> \<C>. U \<inter> X \<noteq> {}}"
            using assms by blast
          then have OSX: "openin (top_of_set S) (S \<inter> X)" by blast
          have sumeq: "\<And>x. x \<in> S \<inter> X \<Longrightarrow>
                     (\<Sum>V | V \<in> \<C> \<and> V \<inter> X \<noteq> {}. setdist {x} (S - V))
                     = supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>"
            apply (simp add: supp_sum_def)
            apply (rule sum.mono_neutral_right [OF finX])
            apply (auto simp: setdist_eq_0_sing_1 support_on_def subset_iff)
            apply (meson DiffI closure_subset disjoint_iff_not_equal subsetCE)
            done
          show "continuous (at x within S) (\<lambda>x. supp_sum (\<lambda>V. setdist {x} (S - V)) \<C>)"
            apply (rule continuous_transform_within_openin
                     [where f = "\<lambda>x. (sum (\<lambda>V. setdist {x} (S - V)) {V \<in> \<C>. V \<inter> X \<noteq> {}})"
                        and S ="S \<inter> X"])
            apply (rule continuous_intros continuous_at_setdist continuous_at_imp_continuous_at_within OSX x)+
            apply (simp add: sumeq)
            done
        qed
        show ?thesis
          apply (simp add: F_def)
          apply (rule continuous_intros *)+
          using ss_pos apply force
          done
      qed
      moreover have "\<lbrakk>U \<in> \<C>; x \<in> S\<rbrakk> \<Longrightarrow> 0 \<le> F U x" for U x
        using nonneg [of x] by (simp add: F_def field_split_simps)
      ultimately show "\<And>U. U \<in> \<C> \<Longrightarrow> continuous_on S (F U) \<and> (\<forall>x\<in>S. 0 \<le> F U x)"
        by metis
    next
      show "\<And>x U. \<lbrakk>U \<in> \<C>; x \<in> S; x \<notin> U\<rbrakk> \<Longrightarrow> F U x = 0"
        by (simp add: setdist_eq_0_sing_1 closure_def F_def)
    next
      show "supp_sum (\<lambda>W. F W x) \<C> = 1" if "x \<in> S" for x
        using that ss_pos [OF that]
        by (simp add: F_def field_split_simps supp_sum_divide_distrib [symmetric])
    next
      show "\<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. \<exists>x\<in>V. F U x \<noteq> 0}" if "x \<in> S" for x
        using fin [OF that] that
        by (fastforce simp: setdist_eq_0_sing_1 closure_def F_def elim!: rev_finite_subset)
    qed
qed

subsection\<open>Urysohn's Lemma for Euclidean Spaces\<close>

text \<open>For Euclidean spaces the proof is easy using distances.\<close>

lemma Urysohn_both_ne:
  assumes US: "closedin (top_of_set U) S"
      and UT: "closedin (top_of_set U) T"
      and "S \<inter> T = {}" "S \<noteq> {}" "T \<noteq> {}" "a \<noteq> b"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::real_normed_vector"
    where "continuous_on U f"
          "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a b"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = b \<longleftrightarrow> x \<in> T)"
proof -
  have S0: "\<And>x. x \<in> U \<Longrightarrow> setdist {x} S = 0 \<longleftrightarrow> x \<in> S"
    using \<open>S \<noteq> {}\<close>  US setdist_eq_0_closedin  by auto
  have T0: "\<And>x. x \<in> U \<Longrightarrow> setdist {x} T = 0 \<longleftrightarrow> x \<in> T"
    using \<open>T \<noteq> {}\<close>  UT setdist_eq_0_closedin  by auto
  have sdpos: "0 < setdist {x} S + setdist {x} T" if "x \<in> U" for x
  proof -
    have "\<not> (setdist {x} S = 0 \<and> setdist {x} T = 0)"
      using assms by (metis IntI empty_iff setdist_eq_0_closedin that)
    then show ?thesis
      by (metis add.left_neutral add.right_neutral add_pos_pos linorder_neqE_linordered_idom not_le setdist_pos_le)
  qed
  define f where "f \<equiv> \<lambda>x. a + (setdist {x} S / (setdist {x} S + setdist {x} T)) *\<^sub>R (b - a)"
  show ?thesis
  proof (rule_tac f = f in that)
    show "continuous_on U f"
      using sdpos unfolding f_def
      by (intro continuous_intros | force)+
    show "f x \<in> closed_segment a b" if "x \<in> U" for x
        unfolding f_def
      apply (simp add: closed_segment_def)
      apply (rule_tac x="(setdist {x} S / (setdist {x} S + setdist {x} T))" in exI)
      using sdpos that apply (simp add: algebra_simps)
      done
    show "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
      using S0 \<open>a \<noteq> b\<close> f_def sdpos by force
    show "(f x = b \<longleftrightarrow> x \<in> T)" if "x \<in> U" for x
    proof -
      have "f x = b \<longleftrightarrow> (setdist {x} S / (setdist {x} S + setdist {x} T)) = 1"
        unfolding f_def
        apply (rule iffI)
         apply (metis  \<open>a \<noteq> b\<close> add_diff_cancel_left' eq_iff_diff_eq_0 pth_1 real_vector.scale_right_imp_eq, force)
        done
      also have "...  \<longleftrightarrow> setdist {x} T = 0 \<and> setdist {x} S \<noteq> 0"
        using sdpos that
        by (simp add: field_split_simps) linarith
      also have "...  \<longleftrightarrow> x \<in> T"
        using \<open>S \<noteq> {}\<close> \<open>T \<noteq> {}\<close> \<open>S \<inter> T = {}\<close> that
        by (force simp: S0 T0)
      finally show ?thesis .
    qed
  qed
qed

proposition Urysohn_local_strong:
  assumes US: "closedin (top_of_set U) S"
      and UT: "closedin (top_of_set U) T"
      and "S \<inter> T = {}" "a \<noteq> b"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on U f"
          "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a b"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
          "\<And>x. x \<in> U \<Longrightarrow> (f x = b \<longleftrightarrow> x \<in> T)"
proof (cases "S = {}")
  case True show ?thesis
  proof (cases "T = {}")
    case True show ?thesis
    proof (rule_tac f = "\<lambda>x. midpoint a b" in that)
      show "continuous_on U (\<lambda>x. midpoint a b)"
        by (intro continuous_intros)
      show "midpoint a b \<in> closed_segment a b"
        using csegment_midpoint_subset by blast
      show "(midpoint a b = a) = (x \<in> S)" for x
        using \<open>S = {}\<close> \<open>a \<noteq> b\<close> by simp
      show "(midpoint a b = b) = (x \<in> T)" for x
        using \<open>T = {}\<close> \<open>a \<noteq> b\<close> by simp
    qed
  next
    case False
    show ?thesis
    proof (cases "T = U")
      case True with \<open>S = {}\<close> \<open>a \<noteq> b\<close> show ?thesis
        by (rule_tac f = "\<lambda>x. b" in that) (auto)
    next
      case False
      with UT closedin_subset obtain c where c: "c \<in> U" "c \<notin> T"
        by fastforce
      obtain f where f: "continuous_on U f"
                "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment (midpoint a b) b"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = midpoint a b \<longleftrightarrow> x = c)"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = b \<longleftrightarrow> x \<in> T)"
        apply (rule Urysohn_both_ne [of U "{c}" T "midpoint a b" "b"])
        using c \<open>T \<noteq> {}\<close> assms apply simp_all
        done
      show ?thesis
        apply (rule_tac f=f in that)
        using \<open>S = {}\<close> \<open>T \<noteq> {}\<close> f csegment_midpoint_subset notin_segment_midpoint [OF \<open>a \<noteq> b\<close>]
        apply force+
        done
    qed
  qed
next
  case False
  show ?thesis
  proof (cases "T = {}")
    case True show ?thesis
    proof (cases "S = U")
      case True with \<open>T = {}\<close> \<open>a \<noteq> b\<close> show ?thesis
        by (rule_tac f = "\<lambda>x. a" in that) (auto)
    next
      case False
      with US closedin_subset obtain c where c: "c \<in> U" "c \<notin> S"
        by fastforce
      obtain f where f: "continuous_on U f"
                "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a (midpoint a b)"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = midpoint a b \<longleftrightarrow> x = c)"
                "\<And>x. x \<in> U \<Longrightarrow> (f x = a \<longleftrightarrow> x \<in> S)"
        apply (rule Urysohn_both_ne [of U S "{c}" a "midpoint a b"])
        using c \<open>S \<noteq> {}\<close> assms apply simp_all
        apply (metis midpoint_eq_endpoint)
        done
      show ?thesis
        apply (rule_tac f=f in that)
        using \<open>S \<noteq> {}\<close> \<open>T = {}\<close> f  \<open>a \<noteq> b\<close>
        apply simp_all
        apply (metis (no_types) closed_segment_commute csegment_midpoint_subset midpoint_sym subset_iff)
        apply (metis closed_segment_commute midpoint_sym notin_segment_midpoint)
        done
    qed
  next
    case False
    show ?thesis
      using Urysohn_both_ne [OF US UT \<open>S \<inter> T = {}\<close> \<open>S \<noteq> {}\<close> \<open>T \<noteq> {}\<close> \<open>a \<noteq> b\<close>] that
      by blast
  qed
qed

lemma Urysohn_local:
  assumes US: "closedin (top_of_set U) S"
      and UT: "closedin (top_of_set U) T"
      and "S \<inter> T = {}"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on U f"
          "\<And>x. x \<in> U \<Longrightarrow> f x \<in> closed_segment a b"
          "\<And>x. x \<in> S \<Longrightarrow> f x = a"
          "\<And>x. x \<in> T \<Longrightarrow> f x = b"
proof (cases "a = b")
  case True then show ?thesis
    by (rule_tac f = "\<lambda>x. b" in that) (auto)
next
  case False
  then show ?thesis
    apply (rule Urysohn_local_strong [OF assms])
    apply (erule that, assumption)
    apply (meson US closedin_singleton closedin_trans)
    apply (meson UT closedin_singleton closedin_trans)
    done
qed

lemma Urysohn_strong:
  assumes US: "closed S"
      and UT: "closed T"
      and "S \<inter> T = {}" "a \<noteq> b"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on UNIV f"
          "\<And>x. f x \<in> closed_segment a b"
          "\<And>x. f x = a \<longleftrightarrow> x \<in> S"
          "\<And>x. f x = b \<longleftrightarrow> x \<in> T"
using assms by (auto intro: Urysohn_local_strong [of UNIV S T])

proposition Urysohn:
  assumes US: "closed S"
      and UT: "closed T"
      and "S \<inter> T = {}"
  obtains f :: "'a::euclidean_space \<Rightarrow> 'b::euclidean_space"
    where "continuous_on UNIV f"
          "\<And>x. f x \<in> closed_segment a b"
          "\<And>x. x \<in> S \<Longrightarrow> f x = a"
          "\<And>x. x \<in> T \<Longrightarrow> f x = b"
  using assms by (auto intro: Urysohn_local [of UNIV S T a b])

subsection\<open>Dugundji's Extension Theorem and Tietze Variants\<close>

text \<open>See \<^cite>\<open>"dugundji"\<close>.\<close>

lemma convex_supp_sum:
  assumes "convex S" and 1: "supp_sum u I = 1"
      and "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> u i \<and> (u i = 0 \<or> f i \<in> S)"
    shows "supp_sum (\<lambda>i. u i *\<^sub>R f i) I \<in> S"
proof -
  have fin: "finite {i \<in> I. u i \<noteq> 0}"
    using 1 sum.infinite by (force simp: supp_sum_def support_on_def)
  then have "supp_sum (\<lambda>i. u i *\<^sub>R f i) I = sum (\<lambda>i. u i *\<^sub>R f i) {i \<in> I. u i \<noteq> 0}"
    by (force intro: sum.mono_neutral_left simp: supp_sum_def support_on_def)
  also have "... \<in> S"
    using 1 assms by (force simp: supp_sum_def support_on_def intro: convex_sum [OF fin \<open>convex S\<close>])
  finally show ?thesis .
qed

theorem Dugundji:
  fixes f :: "'a::{metric_space,second_countable_topology} \<Rightarrow> 'b::real_inner"
  assumes "convex C" "C \<noteq> {}"
      and cloin: "closedin (top_of_set U) S"
      and contf: "continuous_on S f" and "f ` S \<subseteq> C"
  obtains g where "continuous_on U g" "g ` U \<subseteq> C"
                  "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
proof (cases "S = {}")
  case True then show thesis
    apply (rule_tac g="\<lambda>x. SOME y. y \<in> C" in that)
      apply (rule continuous_intros)
     apply (meson all_not_in_conv \<open>C \<noteq> {}\<close> image_subsetI someI_ex, simp)
    done
next
  case False
  then have sd_pos: "\<And>x. \<lbrakk>x \<in> U; x \<notin> S\<rbrakk> \<Longrightarrow> 0 < setdist {x} S"
    using setdist_eq_0_closedin [OF cloin] le_less setdist_pos_le by fastforce
  define \<B> where "\<B> = {ball x (setdist {x} S / 2) |x. x \<in> U - S}"
  have [simp]: "\<And>T. T \<in> \<B> \<Longrightarrow> open T"
    by (auto simp: \<B>_def)
  have USS: "U - S \<subseteq> \<Union>\<B>"
    by (auto simp: sd_pos \<B>_def)
  obtain \<C> where USsub: "U - S \<subseteq> \<Union>\<C>"
       and nbrhd: "\<And>U. U \<in> \<C> \<Longrightarrow> open U \<and> (\<exists>T. T \<in> \<B> \<and> U \<subseteq> T)"
       and fin: "\<And>x. x \<in> U - S \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U. U \<in> \<C> \<and> U \<inter> V \<noteq> {}}"
    by (rule paracompact [OF USS]) auto
  have "\<exists>v a. v \<in> U \<and> v \<notin> S \<and> a \<in> S \<and>
              T \<subseteq> ball v (setdist {v} S / 2) \<and>
              dist v a \<le> 2 * setdist {v} S" if "T \<in> \<C>" for T
  proof -
    obtain v where v: "T \<subseteq> ball v (setdist {v} S / 2)" "v \<in> U" "v \<notin> S"
      using \<open>T \<in> \<C>\<close> nbrhd by (force simp: \<B>_def)
    then obtain a where "a \<in> S" "dist v a < 2 * setdist {v} S"
      using setdist_ltE [of "{v}" S "2 * setdist {v} S"]
      using False sd_pos by force
    with v show ?thesis
      apply (rule_tac x=v in exI)
      apply (rule_tac x=a in exI, auto)
      done
  qed
  then obtain \<V> \<A> where
    VA: "\<And>T. T \<in> \<C> \<Longrightarrow> \<V> T \<in> U \<and> \<V> T \<notin> S \<and> \<A> T \<in> S \<and>
              T \<subseteq> ball (\<V> T) (setdist {\<V> T} S / 2) \<and>
              dist (\<V> T) (\<A> T) \<le> 2 * setdist {\<V> T} S"
    by metis
  have sdle: "setdist {\<V> T} S \<le> 2 * setdist {v} S" if "T \<in> \<C>" "v \<in> T" for T v
    using setdist_Lipschitz [of "\<V> T" S v] VA [OF \<open>T \<in> \<C>\<close>] \<open>v \<in> T\<close> by auto
  have d6: "dist a (\<A> T) \<le> 6 * dist a v" if "T \<in> \<C>" "v \<in> T" "a \<in> S" for T v a
  proof -
    have "dist (\<V> T) v < setdist {\<V> T} S / 2"
      using that VA mem_ball by blast
    also have "\<dots> \<le> setdist {v} S"
      using sdle [OF \<open>T \<in> \<C>\<close> \<open>v \<in> T\<close>] by simp
    also have vS: "setdist {v} S \<le> dist a v"
      by (simp add: setdist_le_dist setdist_sym \<open>a \<in> S\<close>)
    finally have VTV: "dist (\<V> T) v < dist a v" .
    have VTS: "setdist {\<V> T} S \<le> 2 * dist a v"
      using sdle that vS by force
    have "dist a (\<A> T) \<le> dist a v + dist v (\<V> T) + dist (\<V> T) (\<A> T)"
      by (metis add.commute add_le_cancel_left dist_commute dist_triangle2 dist_triangle_le)
    also have "\<dots> \<le> dist a v + dist a v + dist (\<V> T) (\<A> T)"
      using VTV by (simp add: dist_commute)
    also have "\<dots> \<le> 2 * dist a v + 2 * setdist {\<V> T} S"
      using VA [OF \<open>T \<in> \<C>\<close>] by auto
    finally show ?thesis
      using VTS by linarith
  qed
  obtain H :: "['a set, 'a] \<Rightarrow> real"
    where Hcont: "\<And>Z. Z \<in> \<C> \<Longrightarrow> continuous_on (U-S) (H Z)"
      and Hge0: "\<And>Z x. \<lbrakk>Z \<in> \<C>; x \<in> U-S\<rbrakk> \<Longrightarrow> 0 \<le> H Z x"
      and Heq0: "\<And>x Z. \<lbrakk>Z \<in> \<C>; x \<in> U-S; x \<notin> Z\<rbrakk> \<Longrightarrow> H Z x = 0"
      and H1: "\<And>x. x \<in> U-S \<Longrightarrow> supp_sum (\<lambda>W. H W x) \<C> = 1"
      and Hfin: "\<And>x. x \<in> U-S \<Longrightarrow> \<exists>V. open V \<and> x \<in> V \<and> finite {U \<in> \<C>. \<exists>x\<in>V. H U x \<noteq> 0}"
    apply (rule subordinate_partition_of_unity [OF USsub _ fin])
    using nbrhd by auto
  define g where "g \<equiv> \<lambda>x. if x \<in> S then f x else supp_sum (\<lambda>T. H T x *\<^sub>R f(\<A> T)) \<C>"
  show ?thesis
  proof (rule that)
    show "continuous_on U g"
    proof (clarsimp simp: continuous_on_eq_continuous_within)
      fix a assume "a \<in> U"
      show "continuous (at a within U) g"
      proof (cases "a \<in> S")
        case True show ?thesis
        proof (clarsimp simp add: continuous_within_topological)
          fix W
          assume "open W" "g a \<in> W"
          then obtain e where "0 < e" and e: "ball (f a) e \<subseteq> W"
            using openE True g_def by auto
          have "continuous (at a within S) f"
            using True contf continuous_on_eq_continuous_within by blast
          then obtain d where "0 < d"
                        and d: "\<And>x. \<lbrakk>x \<in> S; dist x a < d\<rbrakk> \<Longrightarrow> dist (f x) (f a) < e"
            using continuous_within_eps_delta \<open>0 < e\<close> by force
          have "g y \<in> ball (f a) e" if "y \<in> U" and y: "y \<in> ball a (d / 6)" for y
          proof (cases "y \<in> S")
            case True
            then have "dist (f a) (f y) < e"
              by (metis ball_divide_subset_numeral dist_commute in_mono mem_ball y d)
            then show ?thesis
              by (simp add: True g_def)
          next
            case False
            have *: "dist (f (\<A> T)) (f a) < e" if "T \<in> \<C>" "H T y \<noteq> 0" for T
            proof -
              have "y \<in> T"
                using Heq0 that False \<open>y \<in> U\<close> by blast
              have "dist (\<A> T) a < d"
                using d6 [OF \<open>T \<in> \<C>\<close> \<open>y \<in> T\<close> \<open>a \<in> S\<close>] y
                by (simp add: dist_commute mult.commute)
              then show ?thesis
                using VA [OF \<open>T \<in> \<C>\<close>] by (auto simp: d)
            qed
            have "supp_sum (\<lambda>T. H T y *\<^sub>R f (\<A> T)) \<C> \<in> ball (f a) e"
              apply (rule convex_supp_sum [OF convex_ball])
              apply (simp_all add: False H1 Hge0 \<open>y \<in> U\<close>)
              by (metis dist_commute *)
            then show ?thesis
              by (simp add: False g_def)
          qed
          then show "\<exists>A. open A \<and> a \<in> A \<and> (\<forall>y\<in>U. y \<in> A \<longrightarrow> g y \<in> W)"
            apply (rule_tac x = "ball a (d / 6)" in exI)
            using e \<open>0 < d\<close> by fastforce
        qed
      next
        case False
        obtain N where N: "open N" "a \<in> N"
                   and finN: "finite {U \<in> \<C>. \<exists>a\<in>N. H U a \<noteq> 0}"
          using Hfin False \<open>a \<in> U\<close> by auto
        have oUS: "openin (top_of_set U) (U - S)"
          using cloin by (simp add: openin_diff)
        have HcontU: "continuous (at a within U) (H T)" if "T \<in> \<C>" for T
          using Hcont [OF \<open>T \<in> \<C>\<close>] False  \<open>a \<in> U\<close> \<open>T \<in> \<C>\<close>
          apply (simp add: continuous_on_eq_continuous_within continuous_within)
          apply (rule Lim_transform_within_set)
          using oUS
            apply (force simp: eventually_at openin_contains_ball dist_commute dest!: bspec)+
          done
        show ?thesis
        proof (rule continuous_transform_within_openin [OF _ oUS])
          show "continuous (at a within U) (\<lambda>x. supp_sum (\<lambda>T. H T x *\<^sub>R f (\<A> T)) \<C>)"
          proof (rule continuous_transform_within_openin)
            show "continuous (at a within U)
                    (\<lambda>x. \<Sum>T\<in>{U \<in> \<C>. \<exists>x\<in>N. H U x \<noteq> 0}. H T x *\<^sub>R f (\<A> T))"
              by (force intro: continuous_intros HcontU)+
          next
            show "openin (top_of_set U) ((U - S) \<inter> N)"
              using N oUS openin_trans by blast
          next
            show "a \<in> (U - S) \<inter> N" using False \<open>a \<in> U\<close> N by blast
          next
            show "\<And>x. x \<in> (U - S) \<inter> N \<Longrightarrow>
                         (\<Sum>T \<in> {U \<in> \<C>. \<exists>x\<in>N. H U x \<noteq> 0}. H T x *\<^sub>R f (\<A> T))
                         = supp_sum (\<lambda>T. H T x *\<^sub>R f (\<A> T)) \<C>"
              by (auto simp: supp_sum_def support_on_def
                       intro: sum.mono_neutral_right [OF finN])
          qed
        next
          show "a \<in> U - S" using False \<open>a \<in> U\<close> by blast
        next
          show "\<And>x. x \<in> U - S \<Longrightarrow> supp_sum (\<lambda>T. H T x *\<^sub>R f (\<A> T)) \<C> = g x"
            by (simp add: g_def)
        qed
      qed
    qed
    show "g ` U \<subseteq> C"
      using \<open>f ` S \<subseteq> C\<close> VA
      by (fastforce simp: g_def Hge0 intro!: convex_supp_sum [OF \<open>convex C\<close>] H1)
    show "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
      by (simp add: g_def)
  qed
qed

corollary Tietze:
  fixes f :: "'a::{metric_space,second_countable_topology} \<Rightarrow> 'b::real_inner"
  assumes "continuous_on S f"
    and "closedin (top_of_set U) S"
    and "0 \<le> B"
    and "\<And>x. x \<in> S \<Longrightarrow> norm(f x) \<le> B"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
    "\<And>x. x \<in> U \<Longrightarrow> norm(g x) \<le> B"
  using assms by (auto simp: image_subset_iff intro: Dugundji [of "cball 0 B" U S f])

corollary\<^marker>\<open>tag unimportant\<close> Tietze_closed_interval:
  fixes f :: "'a::{metric_space,second_countable_topology} \<Rightarrow> 'b::euclidean_space"
  assumes "continuous_on S f"
    and "closedin (top_of_set U) S"
    and "cbox a b \<noteq> {}"
    and "\<And>x. x \<in> S \<Longrightarrow> f x \<in> cbox a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
    "\<And>x. x \<in> U \<Longrightarrow> g x \<in> cbox a b"
  apply (rule Dugundji [of "cbox a b" U S f])
  using assms by auto

corollary\<^marker>\<open>tag unimportant\<close> Tietze_closed_interval_1:
  fixes f :: "'a::{metric_space,second_countable_topology} \<Rightarrow> real"
  assumes "continuous_on S f"
    and "closedin (top_of_set U) S"
    and "a \<le> b"
    and "\<And>x. x \<in> S \<Longrightarrow> f x \<in> cbox a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
    "\<And>x. x \<in> U \<Longrightarrow> g x \<in> cbox a b"
  apply (rule Dugundji [of "cbox a b" U S f])
  using assms by (auto simp: image_subset_iff)

corollary\<^marker>\<open>tag unimportant\<close> Tietze_open_interval:
  fixes f :: "'a::{metric_space,second_countable_topology} \<Rightarrow> 'b::euclidean_space"
  assumes "continuous_on S f"
    and "closedin (top_of_set U) S"
    and "box a b \<noteq> {}"
    and "\<And>x. x \<in> S \<Longrightarrow> f x \<in> box a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
    "\<And>x. x \<in> U \<Longrightarrow> g x \<in> box a b"
  apply (rule Dugundji [of "box a b" U S f])
  using assms by auto

corollary\<^marker>\<open>tag unimportant\<close> Tietze_open_interval_1:
  fixes f :: "'a::{metric_space,second_countable_topology} \<Rightarrow> real"
  assumes "continuous_on S f"
    and "closedin (top_of_set U) S"
    and "a < b"
    and no: "\<And>x. x \<in> S \<Longrightarrow> f x \<in> box a b"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
    "\<And>x. x \<in> U \<Longrightarrow> g x \<in> box a b"
  apply (rule Dugundji [of "box a b" U S f])
  using assms by (auto simp: image_subset_iff)

corollary\<^marker>\<open>tag unimportant\<close> Tietze_unbounded:
  fixes f :: "'a::{metric_space,second_countable_topology} \<Rightarrow> 'b::real_inner"
  assumes "continuous_on S f"
    and "closedin (top_of_set U) S"
  obtains g where "continuous_on U g" "\<And>x. x \<in> S \<Longrightarrow> g x = f x"
  apply (rule Dugundji [of UNIV U S f])
  using assms by auto

end


section \<open>Quantum instantiation of registers\<close>

(* AXIOM INSTANTIATION (use instantiate_laws.py to generate Laws_Quantum.thy)

    # Type classes
    domain \<rightarrow> finite

    # Types
    some_domain \<rightarrow> unit

    # Constants
    comp_update \<rightarrow> cblinfun_compose
    id_update \<rightarrow> id_cblinfun
    preregister \<rightarrow> clinear
    tensor_update \<rightarrow> tensor_op

    # Lemmas
    id_update_left \<rightarrow> cblinfun_compose_id_left
    id_update_right \<rightarrow> cblinfun_compose_id_right
    comp_update_assoc \<rightarrow> cblinfun_compose_assoc
    id_preregister \<rightarrow> complex_vector.linear_id
    comp_preregister \<rightarrow> clinear_compose
    tensor_update_mult \<rightarrow> comp_tensor_op
    # preregister_tensor_left \<rightarrow> clinear_tensor_right
    # preregister_tensor_right \<rightarrow> clinear_tensor_left

    # Chapter name
    Generic laws about registers \<rightarrow> Generic laws about registers, instantiated quantumly
    Generic laws about complements \<rightarrow> Generic laws about complements, instantiated quantumly
*)

theory Axioms_Quantum
  imports Jordan_Normal_Form.Matrix_Impl "HOL-Library.Rewrite"
          Complex_Bounded_Operators.Complex_L2
          Finite_Tensor_Product
begin

unbundle cblinfun_notation
no_notation m_inv ("inv\<index> _" [81] 80)

type_synonym 'a update = \<open>('a ell2, 'a ell2) cblinfun\<close>

lemma preregister_mult_right: \<open>clinear (\<lambda>a. a o\<^sub>C\<^sub>L z)\<close>
  by (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
lemma preregister_mult_left: \<open>clinear (\<lambda>a. z o\<^sub>C\<^sub>L a)\<close>
  by (meson cbilinear_cblinfun_compose cbilinear_def)

definition register :: \<open>('a::finite update \<Rightarrow> 'b::finite update) \<Rightarrow> bool\<close> where
  "register F \<longleftrightarrow>
     clinear F
   \<and> F id_cblinfun = id_cblinfun
   \<and> (\<forall>a b. F(a o\<^sub>C\<^sub>L b) = F a o\<^sub>C\<^sub>L F b)
   \<and> (\<forall>a. F (a*) = (F a)*)"

lemma register_of_id: \<open>register F \<Longrightarrow> F id_cblinfun = id_cblinfun\<close>
  by (simp add: register_def)

lemma register_id: \<open>register id\<close>
  by (simp add: register_def complex_vector.module_hom_id)

lemma register_preregister: "register F \<Longrightarrow> clinear F"
  unfolding register_def by simp

lemma register_comp: "register F \<Longrightarrow> register G \<Longrightarrow> register (G \<circ> F)"
  unfolding register_def
  apply auto
  using clinear_compose by blast

lemma register_mult: "register F \<Longrightarrow> cblinfun_compose (F a) (F b) = F (cblinfun_compose a b)"
  unfolding register_def
  by auto

lemma register_tensor_left: \<open>register (\<lambda>a. tensor_op a id_cblinfun)\<close>
  by (simp add: comp_tensor_op register_def tensor_op_cbilinear tensor_op_adjoint)

lemma register_tensor_right: \<open>register (\<lambda>a. tensor_op id_cblinfun a)\<close>
  by (simp add: comp_tensor_op register_def tensor_op_cbilinear tensor_op_adjoint)

definition register_pair ::
  \<open>('a::finite update \<Rightarrow> 'c::finite update) \<Rightarrow> ('b::finite update \<Rightarrow> 'c update)
         \<Rightarrow> (('a\<times>'b) update \<Rightarrow> 'c update)\<close> where
  \<open>register_pair F G = (if register F \<and> register G \<and> (\<forall>a b. F a o\<^sub>C\<^sub>L G b = G b o\<^sub>C\<^sub>L F a) then
                        tensor_lift (\<lambda>a b. F a o\<^sub>C\<^sub>L G b) else (\<lambda>_. 0))\<close>

lemma cbilinear_F_comp_G[simp]: \<open>clinear F \<Longrightarrow> clinear G \<Longrightarrow> cbilinear (\<lambda>a b. F a o\<^sub>C\<^sub>L G b)\<close>
  unfolding cbilinear_def
  by (auto simp add: clinear_iff bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right)

lemma register_pair_apply:
  assumes [simp]: \<open>register F\<close> \<open>register G\<close>
  assumes \<open>\<And>a b. F a o\<^sub>C\<^sub>L G b = G b o\<^sub>C\<^sub>L F a\<close>
  shows \<open>(register_pair F G) (tensor_op a b) = F a o\<^sub>C\<^sub>L G b\<close>
  unfolding register_pair_def
  apply (simp flip: assms(3))
  by (metis assms(1) assms(2) cbilinear_F_comp_G register_preregister tensor_lift_correct)

lemma register_pair_is_register:
  fixes F :: \<open>'a::finite update \<Rightarrow> 'c::finite update\<close> and G
  assumes [simp]: \<open>register F\<close> and [simp]: \<open>register G\<close>
  assumes \<open>\<And>a b. F a o\<^sub>C\<^sub>L G b = G b o\<^sub>C\<^sub>L F a\<close>
  shows \<open>register (register_pair F G)\<close>
proof (unfold register_def, intro conjI allI)
  have [simp]: \<open>clinear F\<close> \<open>clinear G\<close>
    using assms register_def by blast+
  have [simp]: \<open>F id_cblinfun = id_cblinfun\<close> \<open>G id_cblinfun = id_cblinfun\<close>
    using assms(1,2) register_def by blast+
  show [simp]: \<open>clinear (register_pair F G)\<close>
    unfolding register_pair_def
    using assms apply auto
    apply (rule tensor_lift_clinear)
    by (simp flip: assms(3))
  show \<open>register_pair F G id_cblinfun = id_cblinfun\<close>
    apply (simp flip: tensor_id)
    apply (subst register_pair_apply)
    using assms by simp_all
  have [simp]: \<open>clinear (\<lambda>y. register_pair F G (x o\<^sub>C\<^sub>L y))\<close> for x :: \<open>('a\<times>'b) update\<close>
    apply (rule clinear_compose[unfolded o_def, where g=\<open>register_pair F G\<close>])
    by (simp_all add: preregister_mult_left bounded_cbilinear.add_right clinearI)
  have [simp]: \<open>clinear (\<lambda>y. x o\<^sub>C\<^sub>L register_pair F G y)\<close> for x :: \<open>'c update\<close>
    apply (rule clinear_compose[unfolded o_def, where f=\<open>register_pair F G\<close>])
    by (simp_all add: preregister_mult_left bounded_cbilinear.add_right clinearI)
  have [simp]: \<open>clinear (\<lambda>x. register_pair F G (x o\<^sub>C\<^sub>L y))\<close> for y :: \<open>('a\<times>'b) update\<close>
    apply (rule clinear_compose[unfolded o_def, where g=\<open>register_pair F G\<close>])
    by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
  have [simp]: \<open>clinear (\<lambda>x. register_pair F G x o\<^sub>C\<^sub>L y)\<close> for y :: \<open>'c update\<close>
    apply (rule clinear_compose[unfolded o_def, where f=\<open>register_pair F G\<close>])
    by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose clinearI)
  have [simp]: \<open>F (x o\<^sub>C\<^sub>L y) = F x o\<^sub>C\<^sub>L F y\<close> for x y
    by (simp add: register_mult)
  have [simp]: \<open>G (x o\<^sub>C\<^sub>L y) = G x o\<^sub>C\<^sub>L G y\<close> for x y
    by (simp add: register_mult)
  have [simp]: \<open>clinear (\<lambda>a. (register_pair F G (a*))*)\<close>
    apply (rule antilinear_o_antilinear[unfolded o_def, where f=\<open>adj\<close>])
     apply simp
    apply (rule antilinear_o_clinear[unfolded o_def, where g=\<open>adj\<close>])
    by (simp_all)
  have [simp]: \<open>F (a*) = (F a)*\<close> for a
    using assms(1) register_def by blast
  have [simp]: \<open>G (b*) = (G b)*\<close> for b
    using assms(2) register_def by blast

  fix a b
  show \<open>register_pair F G (a o\<^sub>C\<^sub>L b) = register_pair F G a o\<^sub>C\<^sub>L register_pair F G b\<close>
    apply (rule tensor_extensionality[THEN fun_cong, where x=b], simp_all)
    apply (rule tensor_extensionality[THEN fun_cong, where x=a], simp_all)
    apply (simp_all add: comp_tensor_op register_pair_apply assms(3))
    using assms(3)
    by (metis cblinfun_compose_assoc)
  have \<open>(register_pair F G (a*))* = register_pair F G a\<close>
    apply (rule tensor_extensionality[THEN fun_cong, where x=a])
    by (simp_all add: tensor_op_adjoint register_pair_apply assms(3))
  then show \<open>register_pair F G (a*) = register_pair F G a*\<close>
    by (metis double_adj)
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_weird_nat_mul2_comm
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul2 :: "Nat => Nat => Nat" where
"mul2 (Z) y = Z"
| "mul2 (S z) (Z) = Z"
| "mul2 (S z) (S x2) = plus (S Z) (add3acc z x2 (mul2 z x2))"

theorem property0 :
  "((mul2 x y) = (mul2 y x))"
  oops

end


theory prop_25
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype Nat = Z | S "Nat"
  fun max2 :: "Nat => Nat => Nat" where
  "max2 (Z) y = y"
  | "max2 (S z) (Z) = S z"
  | "max2 (S z) (S x2) = S (max2 z x2)"
  fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
  | "le (S z) (Z) = False"
  | "le (S z) (S x2) = le z x2"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  (*hipster max2 le equal2 *)
lemma lemma_a [thy_expl]: "equal2 x4 y4 = equal2 y4 x4"
by (hipster_induct_schemes prop_25.equal2.simps)

lemma lemma_aa [thy_expl]: "equal2 x2 x2 = True"
by (hipster_induct_schemes prop_25.equal2.simps)

lemma lemma_ab [thy_expl]: "equal2 x2 (S x2) = False"
by (hipster_induct_schemes prop_25.equal2.simps)

  theorem x0 :
    "(equal2 (max2 a b) b) = (le a b)"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*
  File:    Selberg_Asymptotic_Formula.thy
  Author:  Manuel Eberl, TU München

  Selberg's asymptotic formula, which is an important ingredient in the elementary
  proof of the Prime Number Theorem by Selberg and Erdős.
*)
section \<open>Selberg's asymptotic formula\<close>
theory Selberg_Asymptotic_Formula
imports
  More_Dirichlet_Misc
  Prime_Number_Theorem.Prime_Counting_Functions
  Shapiro_Tauberian
  Euler_MacLaurin.Euler_MacLaurin_Landau
  Partial_Zeta_Bounds
begin

text \<open>
  Following Apostol, we first show an inversion formula: Consider a function $f(x)$ for
  $x\in\mathbb{R}_{{}>\,0}$. Define $g(x) := \ln x \cdot \sum_{n\leq x} f(x / n)$. Then:
  \[f(x) \ln x + \sum_{n\leq x} \Lambda(n) f(x/n) = \sum_{n\leq x} \mu(n) g(x/n)\]
\<close>
(* 4.17 *)
locale selberg_inversion =
  fixes F G :: "real \<Rightarrow> 'a :: {real_algebra_1, comm_ring_1}"
  defines "G \<equiv> (\<lambda>x. of_real (ln x) * sum_upto (\<lambda>n. F (x / n)) x)"
begin

lemma eq:
  assumes "x \<ge> 1"
  shows "F x * of_real (ln x) + dirichlet_prod' mangoldt F x = dirichlet_prod' moebius_mu G x"
proof -
  have "F x * of_real (ln x) =
          dirichlet_prod' (\<lambda>n. if n = 1 then 1 else 0) (\<lambda>x. F x * of_real (ln x)) x"
    by (subst dirichlet_prod'_one_left) (use \<open>x \<ge> 1\<close> in auto)
  also have "\<dots> = dirichlet_prod' (\<lambda>n. \<Sum>d | d dvd n. moebius_mu d) (\<lambda>x. F x * of_real (ln x)) x"
    by (intro dirichlet_prod'_cong refl, subst sum_moebius_mu_divisors') auto
  finally have eq1: "F x * of_real (ln x) = \<dots>" .

  have eq2: "dirichlet_prod' mangoldt F x =
               dirichlet_prod' (dirichlet_prod moebius_mu (\<lambda>n. of_real (ln (real n)))) F x"
  proof (intro dirichlet_prod'_cong refl)
    fix n :: nat assume n: "n > 0"
    thus "mangoldt n = dirichlet_prod moebius_mu (\<lambda>n. of_real (ln (real n)) :: 'a) n"
      by (intro moebius_inversion mangoldt_sum [symmetric]) auto
  qed

  have "F x * of_real (ln x) + dirichlet_prod' mangoldt F x =
          sum_upto (\<lambda>n. F (x / n) * (\<Sum>d | d dvd n.
            moebius_mu d * of_real (ln (x / n) + ln (n div d)))) x"
    unfolding eq1 eq2 unfolding dirichlet_prod'_def sum_upto_def
    by (simp add: algebra_simps sum.distrib dirichlet_prod_def sum_distrib_left sum_distrib_right)
  also have "\<dots> = sum_upto (\<lambda>n. F (x / n) * (\<Sum>d | d dvd n. moebius_mu d * of_real (ln (x / d)))) x"
    using \<open>x \<ge> 1\<close> by (intro sum_upto_cong refl arg_cong2[where f = "\<lambda>x y. x * y"] sum.cong)
                     (auto elim!: dvdE simp: ln_div ln_mult)
  also have "\<dots> = sum_upto (\<lambda>n. \<Sum>d | d dvd n. moebius_mu d * of_real (ln (x / d)) * F (x / n)) x"
    by (simp add: sum_distrib_left sum_distrib_right mult_ac)
  also have "\<dots> = (\<Sum>(n,d)\<in>(SIGMA n:{n. n > 0 \<and> real n \<le> x}. {d. d dvd n}).
                    moebius_mu d * of_real (ln (x / d)) * F (x / n))"
    unfolding sum_upto_def by (subst sum.Sigma) (auto simp: case_prod_unfold)
  also have "\<dots> = (\<Sum>(d,q)\<in>(SIGMA d:{d. d > 0 \<and> real d \<le> x}. {q. q > 0 \<and> real q \<le> x / d}).
                    moebius_mu d * of_real (ln (x / d)) * F (x / (q * d)))"
    by (rule sum.reindex_bij_witness[of _ "\<lambda>(d,q). (d * q, d)" "\<lambda>(n,d). (d, n div d)"])
       (auto simp: Real.real_of_nat_div field_simps dest: dvd_imp_le)
  also have "\<dots> = sum_upto (\<lambda>d. moebius_mu d * of_real (ln (x / d)) *
                                  sum_upto (\<lambda>q. F (x / (q * d))) (x / d)) x"
    by (subst sum.Sigma [symmetric]) (auto simp: sum_upto_def sum_distrib_left)
  also have "\<dots> = dirichlet_prod' moebius_mu G x"
    by (simp add: dirichlet_prod'_def G_def mult_ac)
  finally show ?thesis .
qed

end

text \<open>
  We can now show Selberg's formula
  \[\psi(x)\ln x + \sum_{n\leq x} \Lambda(n)\psi(x/n) = 2x\ln x + O(x)\ .\]
\<close>
(* 4.18 *)
theorem selberg_asymptotic_formula:
  includes prime_counting_notation
  shows    "(\<lambda>x. \<psi> x * ln x + dirichlet_prod' mangoldt \<psi> x) =o
               (\<lambda>x. 2 * x * ln x) +o O(\<lambda>x. x)"
proof -
  define C :: real where [simp]: "C = euler_mascheroni"
  define F2 :: "real \<Rightarrow> real" where [simp]: "F2 = (\<lambda>x. x - C - 1)"
  define G1 where "G1 = (\<lambda>x. ln x * sum_upto (\<lambda>n. \<psi> (x / n)) x)"
  define G2 where "G2 = (\<lambda>x. ln x * sum_upto (\<lambda>n. F2 (x / n)) x)"

  interpret F1: selberg_inversion \<psi> G1
    by unfold_locales (simp_all add: G1_def)
  interpret F2: selberg_inversion F2 G2
    by unfold_locales (simp_all add: G2_def)

  have G1_bigo: "(\<lambda>x. G1 x - (x * ln x ^ 2 - x * ln x)) \<in> O(\<lambda>x. ln x ^ 2)"
  proof -
    have "(\<lambda>x. ln x * (sum_upto (\<lambda>n. \<psi> (x / n)) x - x * ln x + x)) \<in> O(\<lambda>x. ln x * ln x)"
      by (intro landau_o.big.mult_left sum_upto_\<psi>_x_over_n_asymptotics)
    thus ?thesis by (simp add: power2_eq_square G1_def algebra_simps)
  qed

  have G2_bigo: "(\<lambda>x. G2 x - (x * ln x ^ 2 - x * ln x)) \<in> O(ln)"
  proof -
  define R1 :: "real \<Rightarrow> real" where "R1 = (\<lambda>x. x * ln x * (harm (nat \<lfloor>x\<rfloor>) - (ln x + C)))"
  define R2 :: "real \<Rightarrow> real" where "R2 = (\<lambda>x. (C + 1) * ln x * frac x)"
    have "(\<lambda>x. G2 x - (x * ln x ^ 2 - x * ln x)) \<in> \<Theta>(\<lambda>x. R1 x + R2 x)"
    proof (intro bigthetaI_cong eventually_mono[OF eventually_ge_at_top[of 1]])
      fix x :: real assume x: "x \<ge> 1"
      have "G2 x = x * ln x * sum_upto (\<lambda>n. 1 / n) x - (C + 1) * \<lfloor>x\<rfloor> * ln x"
        using x by (simp add: G2_def sum_upto_altdef sum_subtractf
                              sum_distrib_left sum_distrib_right algebra_simps)
      also have "sum_upto (\<lambda>n. 1 / n) x = harm (nat \<lfloor>x\<rfloor>)"
        using x unfolding sum_upto_def harm_def
        by (intro sum.cong) (auto simp: field_simps le_nat_iff le_floor_iff)
      also have "x * ln x * harm (nat \<lfloor>x\<rfloor>) - (C + 1) * \<lfloor>x\<rfloor> * ln x =
                   x * ln x ^ 2 - x * ln x + R1 x + R2 x"
        by (simp add: R1_def R2_def algebra_simps frac_def power2_eq_square)
      finally show "G2 x - (x * ln x ^ 2 - x * ln x) = R1 x + R2 x" by simp
    qed
    also have "(\<lambda>x. R1 x + R2 x) \<in> O(ln)"
    proof (intro sum_in_bigo)
      have "(\<lambda>x::real. ln x - ln (nat \<lfloor>x\<rfloor>)) \<in> O(\<lambda>x. ln x - ln (x - 1))"
      proof (intro bigoI[of _ 1] eventually_mono[OF eventually_ge_at_top[of 2]])
        fix x :: real assume x: "x \<ge> 2"
        thus "norm (ln x - ln (nat \<lfloor>x\<rfloor>)) \<le> 1 * norm (ln x - ln (x - 1))" by auto
      qed
      also have "(\<lambda>x::real. ln x - ln (x - 1)) \<in> O(\<lambda>x. 1 / x)" by real_asymp
      finally have bigo_ln_floor: "(\<lambda>x::real. ln x - ln (nat \<lfloor>x\<rfloor>)) \<in> O(\<lambda>x. 1 / x)" .

      have "(\<lambda>x. harm (nat \<lfloor>x\<rfloor>) - (ln (nat \<lfloor>x\<rfloor>) + C)) \<in> O(\<lambda>x. 1 / nat \<lfloor>x\<rfloor>)"
        unfolding C_def using harm_expansion_bigo_simple2
        by (rule landau_o.big.compose) (* TODO: real_asymp should be able to do this *)
           (auto intro!: filterlim_compose[OF filterlim_nat_sequentially filterlim_floor_sequentially])
      also have "(\<lambda>x. 1 / nat \<lfloor>x\<rfloor>) \<in> O(\<lambda>x. 1 / x)" by real_asymp
      finally have "(\<lambda>x. harm (nat \<lfloor>x\<rfloor>) - (ln (nat \<lfloor>x\<rfloor>) + C) - (ln x - ln (nat \<lfloor>x\<rfloor>)))
                       \<in> O(\<lambda>x. 1 / x)" by (rule sum_in_bigo[OF _bigo_ln_floor])
      hence "(\<lambda>x. harm (nat \<lfloor>x\<rfloor>) - (ln x + C)) \<in> O(\<lambda>x. 1 / x)" by (simp add: algebra_simps)
      hence "(\<lambda>x. x * ln x * (harm (nat \<lfloor>x\<rfloor>) - (ln x + C))) \<in> O(\<lambda>x. x * ln x * (1 / x))"
        by (intro landau_o.big.mult_left)
      thus "R1 \<in> O(ln)" by (simp add: landau_divide_simps R1_def)
    next
      have "R2 \<in> O(\<lambda>x. 1 * ln x * 1)" (* TODO: real_asymp? *)
        unfolding R2_def by (intro landau_o.big.mult landau_o.big_refl) real_asymp+
      thus "R2 \<in> O(ln)" by (simp add: R2_def)
    qed
    finally show "(\<lambda>x. G2 x - (x * (ln x)\<^sup>2 - x * ln x)) \<in> O(ln)" .
  qed
  hence G2_bigo': "(\<lambda>x. G2 x - (x * (ln x)\<^sup>2 - x * ln x)) \<in> O(\<lambda>x. ln x ^ 2)"
    by (rule landau_o.big.trans) real_asymp+

  \<comment> \<open>Now things become a bit hairy. In order to show that the `Big-O' bound is actually
      valid for all \<open>x \<ge> 1\<close>, we need to show that \<open>G1 x - G2 x\<close> is bounded on any compact
      interval starting at 1.\<close>
  have "\<exists>c>0. \<forall>x\<ge>1. \<bar>G1 x - G2 x\<bar> \<le> c * \<bar>sqrt x\<bar>"
  proof (rule bigoE_bounded_real_fun)
    have "(\<lambda>x. G1 x - G2 x) \<in> O(\<lambda>x. ln x ^ 2)"
      using sum_in_bigo(2)[OF G1_bigo G2_bigo'] by simp
    also have "(\<lambda>x::real. ln x ^ 2) \<in> O(sqrt)" by real_asymp
    finally show "(\<lambda>x. G1 x - G2 x) \<in> O(sqrt)" .
  next
    fix x :: real assume "x \<ge> 1"
    thus "\<bar>sqrt x\<bar> \<ge> 1" by simp
  next
    fix b :: real assume b: "b \<ge> 1"
    show "bounded ((\<lambda>x. G1 x - G2 x) ` {1..b})"
    proof (rule boundedI, safe)
      fix x assume x: "x \<in> {1..b}"
      have "\<bar>G1 x - G2 x\<bar> = \<bar>ln x * sum_upto (\<lambda>n. \<psi> (x / n) - F2 (x / n)) x\<bar>"
        by (simp add: G1_def G2_def sum_upto_def sum_distrib_left ring_distribs sum_subtractf)
      also have "\<dots> = ln x * \<bar>sum_upto (\<lambda>n. \<psi> (x / n) - F2 (x / n)) x\<bar>"
        using x b by (simp add: abs_mult)
      also have "\<bar>sum_upto (\<lambda>n. \<psi> (x / n) - F2 (x / n)) x\<bar> \<le>
                   sum_upto (\<lambda>n. \<bar>\<psi> (x / n) - F2 (x / n)\<bar>) x"
        unfolding sum_upto_def by (rule sum_abs)
      also have "\<dots> \<le> sum_upto (\<lambda>n. \<psi> x + (x + C + 1)) x"
        unfolding sum_upto_def
      proof (intro sum_mono)
        fix n assume n: "n \<in> {n. n > 0 \<and> real n \<le> x}"
        hence le: "x / n \<le> x / 1" by (intro divide_left_mono) auto
        thus "\<bar>\<psi> (x / n) - F2 (x / n)\<bar> \<le> \<psi> x + (x + C + 1)"
          unfolding F2_def using euler_mascheroni_pos x le \<psi>_nonneg \<psi>_mono[of "x / n" x]
          by (intro order.trans[OF abs_triangle_ineq]
                    order.trans[OF abs_triangle_ineq4] add_mono) auto
      qed
      also have "\<dots> = (\<psi> x + (x + C + 1)) * \<lfloor>x\<rfloor>"
        using x by (simp add: sum_upto_altdef)
      also have "ln x * ((\<psi> x + (x + C + 1)) * real_of_int \<lfloor>x\<rfloor>) \<le>
                   ln b * ((\<psi> b + (b + C + 1)) * real_of_int \<lfloor>b\<rfloor>)"
        using euler_mascheroni_pos x
        by (intro mult_mono add_mono order.refl \<psi>_mono add_nonneg_nonneg mult_nonneg_nonneg
                     \<psi>_nonneg) (auto intro: floor_mono)
      finally show "norm (G1 x - G2 x) \<le> ln b * ((\<psi> b + (b + C + 1)) * real_of_int \<lfloor>b\<rfloor>)"
        using x by (simp add: mult_left_mono)
    qed
  qed auto
  then obtain A where A: "A > 0" "\<And>x. x \<ge> 1 \<Longrightarrow> \<bar>G1 x - G2 x\<bar> \<le> A * sqrt x" by auto

  \<comment> \<open>The rest of the proof now consists merely of combining some asymptotic estimates.\<close>
  have "(\<lambda>x. (\<psi> x - F2 x) * ln x + sum_upto (\<lambda>n. mangoldt n * (\<psi> (x / n) - F2 (x / n))) x)
          \<in> \<Theta>(\<lambda>x. sum_upto (\<lambda>n. moebius_mu n * (G1 (x / n) - G2 (x / n))) x)"
  proof (intro bigthetaI_cong eventually_mono[OF eventually_ge_at_top[of 1]])
    fix x :: real assume x: "x \<ge> 1"
    have "(\<psi> x - F2 x) * ln x + sum_upto (\<lambda>n. mangoldt n * (\<psi> (x / n) - F2 (x / n))) x =
            (\<psi> x * of_real (ln x) + dirichlet_prod' mangoldt \<psi> x) -
            (F2 x * of_real (ln x) + dirichlet_prod' mangoldt F2 x)"
      by (simp add: algebra_simps dirichlet_prod'_def sum_upto_def sum_subtractf sum.distrib)
    also have "\<dots> = sum_upto (\<lambda>n. moebius_mu n * (G1 (x / n) - G2 (x / n))) x"
      unfolding F1.eq[OF x] F2.eq[OF x]
      by (simp add: dirichlet_prod'_def sum_upto_def sum_subtractf sum.distrib algebra_simps)
    finally show "(\<psi> x - F2 x) * ln x + sum_upto (\<lambda>n. mangoldt n * (\<psi> (x/n) - F2 (x/n))) x = \<dots>" .
  qed
  also have "(\<lambda>x. sum_upto (\<lambda>n. moebius_mu n * (G1 (x / n) - G2 (x / n))) x) \<in>
               O(\<lambda>x. A * sqrt x * sum_upto (\<lambda>x. x powr (-1/2)) x)"
  proof (intro bigoI eventually_mono[OF eventually_ge_at_top[of 1]])
    fix x :: real assume x: "x \<ge> 1"
    have "\<bar>sum_upto (\<lambda>n. moebius_mu n * (G1 (x / n) - G2 (x / n))) x\<bar> \<le>
            sum_upto (\<lambda>n. \<bar>moebius_mu n * (G1 (x / n) - G2 (x / n))\<bar>) x"
      unfolding sum_upto_def by (rule sum_abs)
    also have "\<dots> \<le> sum_upto (\<lambda>n. 1 * (A * sqrt (x / n))) x"
      unfolding sum_upto_def abs_mult by (intro A sum_mono mult_mono) (auto simp: moebius_mu_def)
    also have "\<dots> = A * sqrt x * sum_upto (\<lambda>x. x powr (-1/2)) x"
      using x by (simp add: sum_upto_def powr_minus powr_half_sqrt sum_distrib_left
                            sum_distrib_right real_sqrt_divide field_simps)
    also have "\<dots> \<le> \<bar>A * sqrt x * sum_upto (\<lambda>x. x powr (-1/2)) x\<bar>" by simp
    finally show "norm (sum_upto (\<lambda>n. moebius_mu n * (G1 (x / n) - G2 (x / n))) x) \<le>
                    1 * norm (A * sqrt x * sum_upto (\<lambda>x. x powr (-1/2)) x)" by simp
  qed
  also have "(\<lambda>x. A * sqrt x * sum_upto (\<lambda>x. x powr (-1/2)) x) \<in> O(\<lambda>x. 1 * sqrt x * x powr (1/2))"
    using zeta_partial_sum_le_pos_bigo[of "1 / 2"]
    by (intro landau_o.big.mult ) (auto simp: max_def)
  also have "(\<lambda>x::real. 1 * sqrt x * x powr (1/2)) \<in> O(\<lambda>x. x)"
    by real_asymp
  finally have bigo: "(\<lambda>x. (\<psi> x - F2 x) * ln x + sum_upto (\<lambda>n. mangoldt n * (\<psi> (x/n) - F2 (x/n))) x)
                        \<in> O(\<lambda>x. x)" (is "?h \<in> _") .

  let ?R = "\<lambda>x. sum_upto (\<lambda>n. mangoldt n / n) x"
  let ?lhs = "\<lambda>x. \<psi> x * ln x + dirichlet_prod' mangoldt \<psi> x"

  note bigo
  also have "?h = (\<lambda>x. ?lhs x - (x * ln x - (C + 1) * (ln x + \<psi> x)) - x * ?R x)"
    by (rule ext) (simp add: algebra_simps dirichlet_prod'_def  sum_distrib_right \<psi>_def
                             sum_upto_def sum_subtractf sum.distrib sum_distrib_left)
  finally have "(\<lambda>x. ?lhs x - (x * ln x - (C + 1) * (ln x + \<psi> x)) - x * ?R x + x * (?R x - ln x))
                    \<in> O(\<lambda>x. x)" (is "?h' \<in> _")
  proof (rule sum_in_bigo)
    have "(\<lambda>x. x * (sum_upto (\<lambda>n. mangoldt n / real n) x - ln x)) \<in> O(\<lambda>x. x * 1)"
      by (intro landau_o.big.mult_left \<psi>.asymptotics)
    thus "(\<lambda>x. x * (sum_upto (\<lambda>n. mangoldt n / real n) x - ln x)) \<in> O(\<lambda>x. x)" by simp
  qed
  also have "?h' = (\<lambda>x. ?lhs x - (2 * x * ln x - (C + 1) * (ln x + \<psi> x)))"
    by (simp add: fun_eq_iff algebra_simps)
  finally have "(\<lambda>x. ?lhs x - (2*x*ln x - (C+1) * (ln x + \<psi> x)) - (C+1) * (ln x + \<psi> x)) \<in> O(\<lambda>x. x)"
  proof (rule sum_in_bigo)
    have "(\<lambda>x. ln x + \<psi> x) \<in> O(\<lambda>x. x)"
      by (intro sum_in_bigo bigthetaD1[OF \<psi>.bigtheta]) real_asymp+
    thus "(\<lambda>x. (C + 1) * (ln x + \<psi> x)) \<in> O(\<lambda>x. x)" by simp
  qed
  also have "(\<lambda>x. ?lhs x - (2*x*ln x - (C+1) * (ln x + \<psi> x)) - (C+1) * (ln x + \<psi> x)) =
               (\<lambda>x. ?lhs x - 2 * x * ln x)" by (simp add: algebra_simps)
  finally show ?thesis
    by (subst set_minus_plus [symmetric]) (simp_all add: fun_diff_def algebra_simps)
qed

end


(*  Title:      HOL/UNITY/Comp.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Author:     Sidi Ehmety

Composition.

From Chandy and Sanders, "Reasoning About Program Composition",
Technical Report 2000-003, University of Florida, 2000.
*)

section\<open>Composition: Basic Primitives\<close>

theory Comp
imports Union
begin

instantiation program :: (type) ord
begin

definition component_def: "F \<le> H \<longleftrightarrow> (\<exists>G. F\<squnion>G = H)"

definition strict_component_def: "F < (H::'a program) \<longleftrightarrow> (F \<le> H & F \<noteq> H)"

instance ..

end

definition component_of :: "'a program =>'a program=> bool" (infixl "component'_of" 50)
  where "F component_of H == \<exists>G. F ok G & F\<squnion>G = H"

definition strict_component_of :: "'a program\<Rightarrow>'a program=> bool" (infixl "strict'_component'_of" 50)
  where "F strict_component_of H == F component_of H & F\<noteq>H"

definition preserves :: "('a=>'b) => 'a program set"
  where "preserves v == \<Inter>z. stable {s. v s = z}"

definition localize :: "('a=>'b) => 'a program => 'a program" where
  "localize v F == mk_program(Init F, Acts F,
                              AllowedActs F \<inter> (\<Union>G \<in> preserves v. Acts G))"

definition funPair :: "['a => 'b, 'a => 'c, 'a] => 'b * 'c"
  where "funPair f g == %x. (f x, g x)"

subsection\<open>The component relation\<close>
lemma componentI: "H \<le> F | H \<le> G ==> H \<le> (F\<squnion>G)"
apply (unfold component_def, auto)
apply (rule_tac x = "G\<squnion>Ga" in exI)
apply (rule_tac [2] x = "G\<squnion>F" in exI)
apply (auto simp add: Join_ac)
done

lemma component_eq_subset:
     "(F \<le> G) =
      (Init G \<subseteq> Init F & Acts F \<subseteq> Acts G & AllowedActs G \<subseteq> AllowedActs F)"
apply (unfold component_def)
apply (force intro!: exI program_equalityI)
done

lemma component_SKIP [iff]: "SKIP \<le> F"
apply (unfold component_def)
apply (force intro: Join_SKIP_left)
done

lemma component_refl [iff]: "F \<le> (F :: 'a program)"
apply (unfold component_def)
apply (blast intro: Join_SKIP_right)
done

lemma SKIP_minimal: "F \<le> SKIP ==> F = SKIP"
by (auto intro!: program_equalityI simp add: component_eq_subset)

lemma component_Join1: "F \<le> (F\<squnion>G)"
by (unfold component_def, blast)

lemma component_Join2: "G \<le> (F\<squnion>G)"
apply (unfold component_def)
apply (simp add: Join_commute, blast)
done

lemma Join_absorb1: "F \<le> G ==> F\<squnion>G = G"
by (auto simp add: component_def Join_left_absorb)

lemma Join_absorb2: "G \<le> F ==> F\<squnion>G = F"
by (auto simp add: Join_ac component_def)

lemma JN_component_iff: "((JOIN I F) \<le> H) = (\<forall>i \<in> I. F i \<le> H)"
by (simp add: component_eq_subset, blast)

lemma component_JN: "i \<in> I ==> (F i) \<le> (\<Squnion>i \<in> I. (F i))"
apply (unfold component_def)
apply (blast intro: JN_absorb)
done

lemma component_trans: "[| F \<le> G; G \<le> H |] ==> F \<le> (H :: 'a program)"
apply (unfold component_def)
apply (blast intro: Join_assoc [symmetric])
done

lemma component_antisym: "[| F \<le> G; G \<le> F |] ==> F = (G :: 'a program)"
apply (simp (no_asm_use) add: component_eq_subset)
apply (blast intro!: program_equalityI)
done

lemma Join_component_iff: "((F\<squnion>G) \<le> H) = (F \<le> H & G \<le> H)"
by (simp add: component_eq_subset, blast)

lemma component_constrains: "[| F \<le> G; G \<in> A co B |] ==> F \<in> A co B"
by (auto simp add: constrains_def component_eq_subset)

lemma component_stable: "[| F \<le> G; G \<in> stable A |] ==> F \<in> stable A"
by (auto simp add: stable_def component_constrains)

(*Used in Guar.thy to show that programs are partially ordered*)
lemmas program_less_le = strict_component_def

subsection\<open>The preserves property\<close>

lemma preservesI: "(!!z. F \<in> stable {s. v s = z}) ==> F \<in> preserves v"
by (unfold preserves_def, blast)

lemma preserves_imp_eq:
     "[| F \<in> preserves v;  act \<in> Acts F;  (s,s') \<in> act |] ==> v s = v s'"
by (unfold preserves_def stable_def constrains_def, force)

lemma Join_preserves [iff]:
     "(F\<squnion>G \<in> preserves v) = (F \<in> preserves v & G \<in> preserves v)"
by (unfold preserves_def, auto)

lemma JN_preserves [iff]:
     "(JOIN I F \<in> preserves v) = (\<forall>i \<in> I. F i \<in> preserves v)"
by (simp add: JN_stable preserves_def, blast)

lemma SKIP_preserves [iff]: "SKIP \<in> preserves v"
by (auto simp add: preserves_def)

lemma funPair_apply [simp]: "(funPair f g) x = (f x, g x)"
by (simp add:  funPair_def)

lemma preserves_funPair: "preserves (funPair v w) = preserves v \<inter> preserves w"
by (auto simp add: preserves_def stable_def constrains_def, blast)

(* (F \<in> preserves (funPair v w)) = (F \<in> preserves v \<inter> preserves w) *)
declare preserves_funPair [THEN eqset_imp_iff, iff]

lemma funPair_o_distrib: "(funPair f g) o h = funPair (f o h) (g o h)"
by (simp add: funPair_def o_def)

lemma fst_o_funPair [simp]: "fst o (funPair f g) = f"
by (simp add: funPair_def o_def)

lemma snd_o_funPair [simp]: "snd o (funPair f g) = g"
by (simp add: funPair_def o_def)

lemma subset_preserves_o: "preserves v \<subseteq> preserves (w o v)"
by (force simp add: preserves_def stable_def constrains_def)

lemma preserves_subset_stable: "preserves v \<subseteq> stable {s. P (v s)}"
apply (auto simp add: preserves_def stable_def constrains_def)
apply (rename_tac s' s)
apply (subgoal_tac "v s = v s'")
apply (force+)
done

lemma preserves_subset_increasing: "preserves v \<subseteq> increasing v"
by (auto simp add: preserves_subset_stable [THEN subsetD] increasing_def)

lemma preserves_id_subset_stable: "preserves id \<subseteq> stable A"
by (force simp add: preserves_def stable_def constrains_def)

(** For use with def_UNION_ok_iff **)

lemma safety_prop_preserves [iff]: "safety_prop (preserves v)"
by (auto intro: safety_prop_INTER1 simp add: preserves_def)

(** Some lemmas used only in Client.thy **)

lemma stable_localTo_stable2:
     "[| F \<in> stable {s. P (v s) (w s)};
         G \<in> preserves v;  G \<in> preserves w |]
      ==> F\<squnion>G \<in> stable {s. P (v s) (w s)}"
apply simp
apply (subgoal_tac "G \<in> preserves (funPair v w) ")
 prefer 2 apply simp
apply (drule_tac P1 = "case_prod Q" for Q in preserves_subset_stable [THEN subsetD],
       auto)
done

lemma Increasing_preserves_Stable:
     "[| F \<in> stable {s. v s \<le> w s};  G \<in> preserves v; F\<squnion>G \<in> Increasing w |]
      ==> F\<squnion>G \<in> Stable {s. v s \<le> w s}"
apply (auto simp add: stable_def Stable_def Increasing_def Constrains_def all_conj_distrib)
apply (blast intro: constrains_weaken)
(*The G case remains*)
apply (auto simp add: preserves_def stable_def constrains_def)
(*We have a G-action, so delete assumptions about F-actions*)
apply (erule_tac V = "\<forall>act \<in> Acts F. P act" for P in thin_rl)
apply (erule_tac V = "\<forall>z. \<forall>act \<in> Acts F. P z act" for P in thin_rl)
apply (subgoal_tac "v x = v xa")
 apply auto
apply (erule order_trans, blast)
done

(** component_of **)

(*  component_of is stronger than \<le> *)
lemma component_of_imp_component: "F component_of H ==> F \<le> H"
by (unfold component_def component_of_def, blast)

(* component_of satisfies many of the same properties as \<le> *)
lemma component_of_refl [simp]: "F component_of F"
apply (unfold component_of_def)
apply (rule_tac x = SKIP in exI, auto)
done

lemma component_of_SKIP [simp]: "SKIP component_of F"
by (unfold component_of_def, auto)

lemma component_of_trans:
     "[| F component_of G; G component_of H |] ==> F component_of H"
apply (unfold component_of_def)
apply (blast intro: Join_assoc [symmetric])
done

lemmas strict_component_of_eq = strict_component_of_def

(** localize **)
lemma localize_Init_eq [simp]: "Init (localize v F) = Init F"
by (simp add: localize_def)

lemma localize_Acts_eq [simp]: "Acts (localize v F) = Acts F"
by (simp add: localize_def)

lemma localize_AllowedActs_eq [simp]:
   "AllowedActs (localize v F) = AllowedActs F \<inter> (\<Union>G \<in> preserves v. Acts G)"
by (unfold localize_def, auto)

end


theory topo_closure_algebra
  imports topo_operators_basic
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

section \<open>Closure algebra\<close>
text\<open>\noindent{We define a topological Boolean algebra with a primitive closure operator and verify a few properties.}\<close>

text\<open>\noindent{Declares a primitive (unconstrained) closure operation and defines others from it.}\<close>
consts \<C>::"\<sigma>\<Rightarrow>\<sigma>"
abbreviation "\<I> \<equiv> \<C>\<^sup>d" \<comment>\<open> interior \<close>
abbreviation "\<B> \<equiv> \<B>\<^sub>C \<C>" \<comment>\<open> border \<close>
abbreviation "\<F> \<equiv> \<F>\<^sub>C \<C>" \<comment>\<open> frontier \<close>

subsection \<open>Basic properties\<close>

text\<open>\noindent{Verifies minimal conditions under which operators resulting from conversion functions coincide.}\<close>
lemma ICdual': "\<C> \<^bold>\<equiv> \<I>\<^sup>d" using dual_symm equal_op_def by auto
lemma IB_rel: "Cl_2 \<C> \<Longrightarrow> \<I> \<^bold>\<equiv> \<I>\<^sub>B \<B>" using Br_cl_def EXP_dual1 Int_br_def compl_def dEXP_def diff_def dual_def equal_op_def meet_def by fastforce
lemma IF_rel: "Cl_2 \<C> \<Longrightarrow> \<I> \<^bold>\<equiv> \<I>\<^sub>F \<F>" by (smt EXP_def Fr_cl_def Int_fr_def compl_def diff_def dual_def equal_op_def meet_def)

text\<open>\noindent{Fixed-point and other operators are interestingly related.}\<close>
lemma fp1: "Cl_2 \<C> \<Longrightarrow> \<I>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>c" by (smt BI_rel Br_int_def IB_rel Int_br_def compl_def diff_def dimp_def equal_op_def)
lemma fp2: "Cl_2 \<C> \<Longrightarrow> \<B>\<^sup>f\<^sup>p \<^bold>\<equiv> \<I>\<^sup>c" using fp1 by (smt compl_def dimp_def equal_op_def)
lemma fp3: "Cl_2 \<C> \<Longrightarrow> \<C>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B>\<^sup>d" by (smt BI_rel Br_int_def CB_rel Cl_br_def compl_def diff_def dimp_def dual_def equal_op_def join_def)
lemma fp4: "Cl_2 \<C> \<Longrightarrow> (\<B>\<^sup>d)\<^sup>f\<^sup>p \<^bold>\<equiv> \<C>" by (smt dimp_def equal_op_def fp3)
lemma fp5: "Cl_2 \<C> \<Longrightarrow> \<F>\<^sup>f\<^sup>p \<^bold>\<equiv> \<B> \<^bold>\<squnion> (\<C>\<^sup>c)" by (smt Br_cl_def CF_rel Cl_fr_def FC2 Fr_2_def compl_def dimp_def eq_ext' equal_op_def join_def meet_def)

text\<open>\noindent{Define some fixed-point predicates and prove some properties.}\<close>
abbreviation openset ("Op") where "Op A \<equiv> fp \<I> A"
abbreviation closedset ("Cl") where "Cl A \<equiv> fp \<C> A"
abbreviation borderset ("Br") where "Br A \<equiv> fp \<B> A"
abbreviation frontierset ("Fr") where "Fr A \<equiv> fp \<F> A"

lemma Int_Open: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Op(\<I> A)" using IC4 IDEM_def by blast
lemma Cl_Closed: "Cl_4 \<C> \<Longrightarrow> \<forall>A. Cl(\<C> A)" by (simp add: IDEM_def)
lemma Br_Border: "Cl_1b \<C> \<Longrightarrow> \<forall>A. Br(\<B> A)" by (metis BI_rel Br_cl_def Br_int_def CI1b MULT_a_def diff_def eq_ext' meet_def)
text\<open>\noindent{In contrast, there is no analogous fixed-point result for frontier:}\<close>
lemma "\<CC> \<C> \<Longrightarrow> \<forall>A. Fr(\<F> A)" nitpick oops (*counterexample even if assuming all closure conditions*)

lemma OpCldual: "\<forall>A. Cl A \<longleftrightarrow> Op(\<^bold>\<midarrow>A)" by (simp add: compl_def dual_def)
lemma ClOpdual: "\<forall>A. Op A \<longleftrightarrow> Cl(\<^bold>\<midarrow>A)" by (simp add: fp_d)
lemma Fr_ClBr: "Cl_2 \<C> \<Longrightarrow> \<forall>A. Fr(A) = (Cl(A) \<and> Br(A))" using BF_rel by (metis Br_fr_def CF_rel Cl_fr_def eq_ext' join_def meet_def)
lemma Cl_F: "Cl_1b \<C> \<Longrightarrow> Cl_2 \<C> \<Longrightarrow> Cl_4 \<C> \<Longrightarrow> \<forall>A. Cl(\<F> A)" using Cl_8_def Fr_cl_def PC8 by auto

end