section \<open> UTP Theories \<close>

theory utp_theory
imports utp_rel_laws
begin

text \<open> Here, we mechanise a representation of UTP theories using locales~\<^cite>\<open>"Ballarin06"\<close>. We also
  link them to the HOL-Algebra library~\<^cite>\<open>"Ballarin17"\<close>, which allows us to import properties from
  complete lattices and Galois connections. \<close>

subsection \<open> Complete lattice of predicates \<close>

definition upred_lattice :: "('\<alpha> upred) gorder" ("\<P>") where
"upred_lattice = \<lparr> carrier = UNIV, eq = (=), le = (\<sqsubseteq>) \<rparr>"

text \<open> @{term "\<P>"} is the complete lattice of alphabetised predicates. All other theories will
  be defined relative to it. \<close>

interpretation upred_lattice: complete_lattice \<P>
proof (unfold_locales, simp_all add: upred_lattice_def)
  fix A :: "'\<alpha> upred set"
  show "\<exists>s. is_lub \<lparr>carrier = UNIV, eq = (=), le = (\<sqsubseteq>)\<rparr> s A"
    apply (rule_tac x="\<Squnion> A" in exI)
    apply (rule least_UpperI)
       apply (auto intro: Inf_greatest simp add: Inf_lower Upper_def)
    done
  show "\<exists>i. is_glb \<lparr>carrier = UNIV, eq = (=), le = (\<sqsubseteq>)\<rparr> i A"
    apply (rule_tac x="\<Sqinter> A" in exI)
    apply (rule greatest_LowerI)
       apply (auto intro: Sup_least simp add: Sup_upper Lower_def)
    done
qed

lemma upred_weak_complete_lattice [simp]: "weak_complete_lattice \<P>"
  by (simp add: upred_lattice.weak.weak_complete_lattice_axioms)

lemma upred_lattice_eq [simp]:
  "(.=\<^bsub>\<P>\<^esub>) = (=)"
  by (simp add: upred_lattice_def)

lemma upred_lattice_le [simp]:
  "le \<P> P Q = (P \<sqsubseteq> Q)"
  by (simp add: upred_lattice_def)

lemma upred_lattice_carrier [simp]:
  "carrier \<P> = UNIV"
  by (simp add: upred_lattice_def)

lemma upred_lattice_Monotonic [simp]: "Mono\<^bsub>\<P>\<^esub> H = Monotonic H"
  using upred_lattice.weak_partial_order_axioms by (auto simp add: isotone_def mono_def)

subsection \<open> UTP theories hierarchy \<close>

definition utp_order :: "('\<alpha> \<times> '\<alpha>) health \<Rightarrow> '\<alpha> hrel gorder" where
"utp_order H = \<lparr> carrier = {P. P is H}, eq = (=), le = (\<sqsubseteq>) \<rparr>"

text \<open> Constant @{term utp_order} obtains the order structure associated with a UTP theory.
  Its carrier is the set of healthy predicates, equality is HOL equality, and the order is
  refinement. \<close>

lemma utp_order_carrier [simp]:
  "carrier (utp_order H) = \<lbrakk>H\<rbrakk>\<^sub>H"
  by (simp add: utp_order_def)

lemma utp_order_eq [simp]:
  "eq (utp_order T) = (=)"
  by (simp add: utp_order_def)

lemma utp_order_le [simp]:
  "le (utp_order T) = (\<sqsubseteq>)"
  by (simp add: utp_order_def)

lemma utp_partial_order: "partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma utp_weak_partial_order: "weak_partial_order (utp_order T)"
  by (unfold_locales, simp_all add: utp_order_def)

lemma mono_Monotone_utp_order:
  "mono f \<Longrightarrow> Monotone (utp_order T) f"
  apply (auto simp add: isotone_def)
   apply (metis partial_order_def utp_partial_order)
  apply (metis monoD)
  done

lemma isotone_utp_orderI: "Monotonic H \<Longrightarrow> isotone (utp_order X) (utp_order Y) H"
  by (auto simp add: mono_def isotone_def utp_weak_partial_order)

lemma Mono_utp_orderI:
  "\<lbrakk> \<And> P Q. \<lbrakk> P \<sqsubseteq> Q; P is H; Q is H \<rbrakk> \<Longrightarrow> F(P) \<sqsubseteq> F(Q) \<rbrakk> \<Longrightarrow> Mono\<^bsub>utp_order H\<^esub> F"
  by (auto simp add: isotone_def utp_weak_partial_order)

text \<open> The UTP order can equivalently be characterised as the fixed point lattice, @{const fpl}. \<close>

lemma utp_order_fpl: "utp_order H = fpl \<P> H"
  by (auto simp add: utp_order_def upred_lattice_def fps_def Healthy_def)

subsection \<open> UTP theory hierarchy \<close>

text \<open> We next define a hierarchy of locales that characterise different classes of UTP theory.
  Minimally we require that a UTP theory's healthiness condition is idempotent. \<close>

locale utp_theory =
  fixes hcond :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel" ("\<H>")
  assumes HCond_Idem: "\<H>(\<H>(P)) = \<H>(P)"
begin

  abbreviation thy_order :: "'\<alpha> hrel gorder" where
  "thy_order \<equiv> utp_order \<H>"

  lemma HCond_Idempotent [closure,intro]: "Idempotent \<H>"
    by (simp add: Idempotent_def HCond_Idem)

  sublocale utp_po: partial_order "utp_order \<H>"
    by (unfold_locales, simp_all add: utp_order_def)

  text \<open> We need to remove some transitivity rules to stop them being applied in calculations \<close>

  declare utp_po.trans [trans del]

end

locale utp_theory_lattice = utp_theory +
  assumes uthy_lattice: "complete_lattice (utp_order \<H>)"
begin

sublocale complete_lattice "utp_order \<H>"
  by (simp add: uthy_lattice)

declare top_closed [simp del]
declare bottom_closed [simp del]

text \<open> The healthiness conditions of a UTP theory lattice form a complete lattice, and allows us to make
  use of complete lattice results from HOL-Algebra~\<^cite>\<open>"Ballarin17"\<close>, such as the Knaster-Tarski theorem. We can also
  retrieve lattice operators as below. \<close>

abbreviation utp_top ("\<^bold>\<top>")
where "utp_top \<equiv> top (utp_order \<H>)"

abbreviation utp_bottom ("\<^bold>\<bottom>")
where "utp_bottom \<equiv> bottom (utp_order \<H>)"

abbreviation utp_join (infixl "\<^bold>\<squnion>" 65) where
"utp_join \<equiv> join (utp_order \<H>)"

abbreviation utp_meet (infixl "\<^bold>\<sqinter>" 70) where
"utp_meet \<equiv> meet (utp_order \<H>)"

abbreviation utp_sup ("\<^bold>\<Squnion>_" [90] 90) where
"utp_sup \<equiv> Lattice.sup (utp_order \<H>)"

abbreviation utp_inf ("\<^bold>\<Sqinter>_" [90] 90) where
"utp_inf \<equiv> Lattice.inf (utp_order \<H>)"

abbreviation utp_gfp ("\<^bold>\<nu>") where
"utp_gfp \<equiv> GREATEST_FP (utp_order \<H>)"

abbreviation utp_lfp ("\<^bold>\<mu>") where
"utp_lfp \<equiv> LEAST_FP (utp_order \<H>)"

end

syntax
  "_tmu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<mu>\<index> _ \<bullet> _" [0, 10] 10)
  "_tnu" :: "logic \<Rightarrow> pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<nu>\<index> _ \<bullet> _" [0, 10] 10)

notation gfp ("\<mu>")
notation lfp ("\<nu>")

translations
  "\<^bold>\<mu>\<^bsub>H\<^esub> X \<bullet> P" == "CONST LEAST_FP (CONST utp_order H) (\<lambda> X. P)"
  "\<^bold>\<nu>\<^bsub>H\<^esub> X \<bullet> P" == "CONST GREATEST_FP (CONST utp_order H) (\<lambda> X. P)"

lemma upred_lattice_inf:
  "Lattice.inf \<P> A = \<Sqinter> A"
  by (metis Sup_least Sup_upper UNIV_I antisym_conv subsetI upred_lattice.weak.inf_greatest upred_lattice.weak.inf_lower upred_lattice_carrier upred_lattice_le)

text \<open> We can then derive a number of properties about these operators, as below. \<close>

context utp_theory_lattice
begin

  lemma LFP_healthy_comp: "\<^bold>\<mu> F = \<^bold>\<mu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} = {P. (P is \<H>) \<and> F (\<H> P) \<sqsubseteq> P}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: LEAST_FP_def)
  qed

  lemma GFP_healthy_comp: "\<^bold>\<nu> F = \<^bold>\<nu> (F \<circ> \<H>)"
  proof -
    have "{P. (P is \<H>) \<and> P \<sqsubseteq> F P} = {P. (P is \<H>) \<and> P \<sqsubseteq> F (\<H> P)}"
      by (auto simp add: Healthy_def)
    thus ?thesis
      by (simp add: GREATEST_FP_def)
  qed

  lemma top_healthy [closure]: "\<^bold>\<top> is \<H>"
    using weak.top_closed by auto

  lemma bottom_healthy [closure]: "\<^bold>\<bottom> is \<H>"
    using weak.bottom_closed by auto

  lemma utp_top: "P is \<H> \<Longrightarrow> P \<sqsubseteq> \<^bold>\<top>"
    using weak.top_higher by auto

  lemma utp_bottom: "P is \<H> \<Longrightarrow> \<^bold>\<bottom> \<sqsubseteq> P"
    using weak.bottom_lower by auto

end

lemma upred_top: "\<top>\<^bsub>\<P>\<^esub> = false"
  using ball_UNIV greatest_def by fastforce

lemma upred_bottom: "\<bottom>\<^bsub>\<P>\<^esub> = true"
  by fastforce

text \<open> One way of obtaining a complete lattice is showing that the healthiness conditions
  are monotone, which the below locale characterises. \<close>

locale utp_theory_mono = utp_theory +
  assumes HCond_Mono [closure,intro]: "Monotonic \<H>"

sublocale utp_theory_mono \<subseteq> utp_theory_lattice
proof -
  interpret weak_complete_lattice "fpl \<P> \<H>"
    by (rule Knaster_Tarski, auto)

  have "complete_lattice (fpl \<P> \<H>)"
    by (unfold_locales, simp add: fps_def sup_exists, (blast intro: sup_exists inf_exists)+)

  hence "complete_lattice (utp_order \<H>)"
    by (simp add: utp_order_def, simp add: upred_lattice_def)

  thus "utp_theory_lattice \<H>"
    by (simp add: utp_theory_axioms utp_theory_lattice.intro utp_theory_lattice_axioms.intro)
qed

text \<open> In a monotone theory, the top and bottom can always be obtained by applying the healthiness
  condition to the predicate top and bottom, respectively. \<close>

context utp_theory_mono
begin

lemma healthy_top: "\<^bold>\<top> = \<H>(false)"
proof -
  have "\<^bold>\<top> = \<top>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<top>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(1)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> false"
    by (simp add: upred_top)
  finally show ?thesis .
qed

lemma healthy_bottom: "\<^bold>\<bottom> = \<H>(true)"
proof -
  have "\<^bold>\<bottom> = \<bottom>\<^bsub>fpl \<P> \<H>\<^esub>"
    by (simp add: utp_order_fpl)
  also have "... = \<H> \<bottom>\<^bsub>\<P>\<^esub>"
    using Knaster_Tarski_idem_extremes(2)[of \<P> \<H>]
    by (simp add: HCond_Idempotent HCond_Mono)
  also have "... = \<H> true"
    by (simp add: upred_bottom)
   finally show ?thesis .
qed

lemma healthy_inf:
  assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
  shows "\<^bold>\<Sqinter> A = \<H> (\<Sqinter> A)"
  using Knaster_Tarski_idem_inf_eq[OF upred_weak_complete_lattice, of "\<H>"]
  by (simp, metis HCond_Idempotent HCond_Mono assms partial_object.simps(3) upred_lattice_def upred_lattice_inf utp_order_def)

end

locale utp_theory_continuous = utp_theory +
  assumes HCond_Cont [closure,intro]: "Continuous \<H>"

sublocale utp_theory_continuous \<subseteq> utp_theory_mono
proof
  show "Monotonic \<H>"
    by (simp add: Continuous_Monotonic HCond_Cont)
qed

context utp_theory_continuous
begin

  lemma healthy_inf_cont:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "\<^bold>\<Sqinter> A = \<Sqinter> A"
  proof -
    have "\<^bold>\<Sqinter> A = \<Sqinter> (\<H>`A)"
      using Continuous_def HCond_Cont assms(1) assms(2) healthy_inf by auto
    also have "... = \<Sqinter> A"
      by (unfold Healthy_carrier_image[OF assms(1)], simp)
    finally show ?thesis .
  qed

  lemma healthy_inf_def:
    assumes "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<Sqinter> A = (if (A = {}) then \<^bold>\<top> else (\<Sqinter> A))"
    using assms healthy_inf_cont weak.weak_inf_empty by auto

  lemma healthy_meet_cont:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<^bold>\<sqinter> Q = P \<sqinter> Q"
    using healthy_inf_cont[of "{P, Q}"] assms
    by (simp add: Healthy_if meet_def)

  lemma meet_is_healthy [closure]:
    assumes "P is \<H>" "Q is \<H>"
    shows "P \<sqinter> Q is \<H>"
    by (metis Continuous_Disjunctous Disjunctuous_def HCond_Cont Healthy_def' assms(1) assms(2))

  lemma meet_bottom [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<bottom> = \<^bold>\<bottom>"
      by (simp add: assms semilattice_sup_class.sup_absorb2 utp_bottom)

  lemma meet_top [simp]:
    assumes "P is \<H>"
    shows "P \<sqinter> \<^bold>\<top> = P"
      by (simp add: assms semilattice_sup_class.sup_absorb1 utp_top)

  text \<open> The UTP theory lfp operator can be rewritten to the alphabetised predicate lfp when
    in a continuous context. \<close>

  theorem utp_lfp_def:
    assumes "Monotonic F" "F \<in> \<lbrakk>\<H>\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
    shows "\<^bold>\<mu> F = (\<mu> X \<bullet> F(\<H>(X)))"
  proof (rule antisym)
    have ne: "{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<noteq> {}"
    proof -
      have "F \<^bold>\<top> \<sqsubseteq> \<^bold>\<top>"
        using assms(2) utp_top weak.top_closed by force
      thus ?thesis
        by (auto, rule_tac x="\<^bold>\<top>" in exI, auto simp add: top_healthy)
    qed
    show "\<^bold>\<mu> F \<sqsubseteq> (\<mu> X \<bullet> F (\<H> X))"
    proof -
      have "\<Sqinter>{P. (P is \<H>) \<and> F(P) \<sqsubseteq> P} \<sqsubseteq> \<Sqinter>{P. F(\<H>(P)) \<sqsubseteq> P}"
      proof -
        have 1: "\<And> P. F(\<H>(P)) = \<H>(F(\<H>(P)))"
          by (metis HCond_Idem Healthy_def assms(2) funcset_mem mem_Collect_eq)
        show ?thesis
        proof (rule Sup_least, auto)
          fix P
          assume a: "F (\<H> P) \<sqsubseteq> P"
          hence F: "(F (\<H> P)) \<sqsubseteq> (\<H> P)"
            by (metis 1 HCond_Mono mono_def)
          show "\<Sqinter>{P. (P is \<H>) \<and> F P \<sqsubseteq> P} \<sqsubseteq> P"
          proof (rule Sup_upper2[of "F (\<H> P)"])
            show "F (\<H> P) \<in> {P. (P is \<H>) \<and> F P \<sqsubseteq> P}"
            proof (auto)
              show "F (\<H> P) is \<H>"
                by (metis 1 Healthy_def)
              show "F (F (\<H> P)) \<sqsubseteq> F (\<H> P)"
                using F mono_def assms(1) by blast
            qed
            show "F (\<H> P) \<sqsubseteq> P"
              by (simp add: a)
          qed
        qed
      qed

      with ne show ?thesis
        by (simp add: LEAST_FP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
    qed
    from ne show "(\<mu> X \<bullet> F (\<H> X)) \<sqsubseteq> \<^bold>\<mu> F"
      apply (simp add: LEAST_FP_def gfp_def, subst healthy_inf_cont, auto simp add: lfp_def)
      apply (rule Sup_least)
      apply (auto simp add: Healthy_def Sup_upper)
      done
  qed

  lemma UINF_ind_Healthy [closure]:
    assumes "\<And> i. P(i) is \<H>"
    shows "(\<Sqinter> i \<bullet> P(i)) is \<H>"
    by (simp add: closure assms)

end

text \<open> In another direction, we can also characterise UTP theories that are relational. Minimally
  this requires that the healthiness condition is closed under sequential composition. \<close>

locale utp_theory_rel =
  utp_theory +
  assumes Healthy_Sequence [closure]: "\<lbrakk> P is \<H>; Q is \<H> \<rbrakk> \<Longrightarrow> (P ;; Q) is \<H>"
begin

lemma upower_Suc_Healthy [closure]:
  assumes "P is \<H>"
  shows "P \<^bold>^ Suc n is \<H>"
  by (induct n, simp_all add: closure assms upred_semiring.power_Suc)

end

locale utp_theory_cont_rel = utp_theory_rel + utp_theory_continuous
begin

  lemma seq_cont_Sup_distl:
    assumes "P is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "P ;; (\<^bold>\<Sqinter> A) = \<^bold>\<Sqinter> {P ;; Q | Q. Q \<in> A }"
  proof -
    have "{P ;; Q | Q. Q \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distl setcompr_eq_image assms)
  qed

  lemma seq_cont_Sup_distr:
    assumes "Q is \<H>" "A \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H" "A \<noteq> {}"
    shows "(\<^bold>\<Sqinter> A) ;; Q = \<^bold>\<Sqinter> {P ;; Q | P. P \<in> A }"
  proof -
    have "{P ;; Q | P. P \<in> A } \<subseteq> \<lbrakk>\<H>\<rbrakk>\<^sub>H"
      using Healthy_Sequence assms(1) assms(2) by (auto)
    thus ?thesis
      by (simp add: healthy_inf_cont seq_Sup_distr setcompr_eq_image assms)
  qed

  lemma uplus_healthy [closure]:
    assumes "P is \<H>"
    shows "P\<^sup>+ is \<H>"
    by (simp add: uplus_power_def closure assms)

end

text \<open> There also exist UTP theories with units. Not all theories have both a left and a right unit
  (e.g. H1-H2 designs) and so we split up the locale into two cases. \<close>

locale utp_theory_units =
  utp_theory_rel +
  fixes utp_unit ("\<I>\<I>")
  assumes Healthy_Unit [closure]: "\<I>\<I> is \<H>"
begin

text \<open> We can characterise the theory Kleene star by lifting the relational one. \<close>

definition utp_star ("_\<^bold>\<star>" [999] 999) where
[upred_defs]: "utp_star P = (P\<^sup>\<star> ;; \<I>\<I>)"

text \<open> We can then characterise tests as refinements of units. \<close>

definition utp_test :: "'a hrel \<Rightarrow> bool" where
[upred_defs]: "utp_test b = (\<I>\<I> \<sqsubseteq> b)"

end

locale utp_theory_left_unital =
  utp_theory_units +
  assumes Unit_Left: "P is \<H> \<Longrightarrow> (\<I>\<I> ;; P) = P"

locale utp_theory_right_unital =
  utp_theory_units +
  assumes Unit_Right: "P is \<H> \<Longrightarrow> (P ;; \<I>\<I>) = P"

locale utp_theory_unital =
  utp_theory_left_unital + utp_theory_right_unital
begin

lemma Unit_self [simp]:
  "\<I>\<I> ;; \<I>\<I> = \<I>\<I>"
  by (simp add: Healthy_Unit Unit_Right)

lemma utest_intro:
  "\<I>\<I> \<sqsubseteq> P \<Longrightarrow> utp_test P"
  by (simp add: utp_test_def)

lemma utest_Unit [closure]:
  "utp_test \<I>\<I>"
  by (simp add: utp_test_def)

end

locale utp_theory_mono_unital = utp_theory_unital + utp_theory_mono
begin

lemma utest_Top [closure]: "utp_test \<^bold>\<top>"
  by (simp add: Healthy_Unit utp_test_def utp_top)

end

locale utp_theory_cont_unital = utp_theory_cont_rel + utp_theory_unital

sublocale utp_theory_cont_unital \<subseteq> utp_theory_mono_unital
  by (simp add: utp_theory_mono_axioms utp_theory_mono_unital_def utp_theory_unital_axioms)

locale utp_theory_unital_zerol =
  utp_theory_unital +
  utp_theory_lattice +
  assumes Top_Left_Zero: "P is \<H> \<Longrightarrow> \<^bold>\<top> ;; P = \<^bold>\<top>"

locale utp_theory_cont_unital_zerol =
  utp_theory_cont_unital + utp_theory_unital_zerol
begin

lemma Top_test_Right_Zero:
  assumes "b is \<H>" "utp_test b"
  shows "b ;; \<^bold>\<top> = \<^bold>\<top>"
proof -
  have "b \<sqinter> \<I>\<I> = \<I>\<I>"
    by (meson assms(2) semilattice_sup_class.le_iff_sup utp_test_def)
  then show ?thesis
    by (metis (no_types) Top_Left_Zero Unit_Left assms(1) meet_top top_healthy upred_semiring.distrib_right)
qed

end

subsection \<open> Theory of relations \<close>

interpretation rel_theory: utp_theory_mono_unital id skip_r
  rewrites "rel_theory.utp_top = false"
  and "rel_theory.utp_bottom = true"
  and "carrier (utp_order id) = UNIV"
  and "(P is id) = True"
proof -
  show "utp_theory_mono_unital id II"
    by (unfold_locales, simp_all add: Healthy_def)
  then interpret utp_theory_mono_unital id skip_r
    by simp
  show "utp_top = false" "utp_bottom = true"
    by (simp_all add: healthy_top healthy_bottom)
  show "carrier (utp_order id) = UNIV" "(P is id) = True"
    by (auto simp add: utp_order_def Healthy_def)
qed

thm rel_theory.GFP_unfold

subsection \<open> Theory links \<close>

text \<open> We can also describe links between theories, such a Galois connections and retractions,
  using the following notation. \<close>

definition mk_conn ("_ \<Leftarrow>\<langle>_,_\<rangle>\<Rightarrow> _" [90,0,0,91] 91) where
"H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2 \<equiv> \<lparr> orderA = utp_order H1, orderB = utp_order H2, lower = \<H>\<^sub>2, upper = \<H>\<^sub>1 \<rparr>"

lemma mk_conn_orderA [simp]: "\<X>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H1"
  by (simp add:mk_conn_def)

lemma mk_conn_orderB [simp]: "\<Y>\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = utp_order H2"
  by (simp add:mk_conn_def)

lemma mk_conn_lower [simp]:  "\<pi>\<^sub>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>1"
  by (simp add: mk_conn_def)

lemma mk_conn_upper [simp]:  "\<pi>\<^sup>*\<^bsub>H1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H2\<^esub> = \<H>\<^sub>2"
  by (simp add: mk_conn_def)

lemma galois_comp: "(H\<^sub>2 \<Leftarrow>\<langle>\<H>\<^sub>3,\<H>\<^sub>4\<rangle>\<Rightarrow> H\<^sub>3) \<circ>\<^sub>g (H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1,\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>2) = H\<^sub>1 \<Leftarrow>\<langle>\<H>\<^sub>1\<circ>\<H>\<^sub>3,\<H>\<^sub>4\<circ>\<H>\<^sub>2\<rangle>\<Rightarrow> H\<^sub>3"
  by (simp add: comp_galcon_def mk_conn_def)

text \<open> Example Galois connection / retract: Existential quantification \<close>

lemma Idempotent_ex: "mwb_lens x \<Longrightarrow> Idempotent (ex x)"
  by (simp add: Idempotent_def exists_twice)

lemma Monotonic_ex: "mwb_lens x \<Longrightarrow> Monotonic (ex x)"
  by (simp add: mono_def ex_mono)

lemma ex_closed_unrest:
  "vwb_lens x \<Longrightarrow> \<lbrakk>ex x\<rbrakk>\<^sub>H = {P. x \<sharp> P}"
  by (simp add: Healthy_def unrest_as_exists)

text \<open> Any theory can be composed with an existential quantification to produce a Galois connection \<close>

theorem ex_retract:
  assumes "vwb_lens x" "Idempotent H" "ex x \<circ> H = H \<circ> ex x"
  shows "retract ((ex x \<circ> H) \<Leftarrow>\<langle>ex x, H\<rangle>\<Rightarrow> H)"
proof (unfold_locales, simp_all)
  show "H \<in> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>H\<rbrakk>\<^sub>H"
    using Healthy_Idempotent assms by blast
  from assms(1) assms(3)[THEN sym] show "ex x \<in> \<lbrakk>H\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>ex x \<circ> H\<rbrakk>\<^sub>H"
    by (simp add: Pi_iff Healthy_def fun_eq_iff exists_twice)
  fix P Q
  assume "P is (ex x \<circ> H)" "Q is H"
  thus "(H P \<sqsubseteq> Q) = (P \<sqsubseteq> (\<exists> x \<bullet> Q))"
    by (metis (no_types, lifting) Healthy_Idempotent Healthy_if assms comp_apply dual_order.trans ex_weakens utp_pred_laws.ex_mono vwb_lens_wb)
next
  fix P
  assume "P is (ex x \<circ> H)"
  thus "(\<exists> x \<bullet> H P) \<sqsubseteq> P"
    by (simp add: Healthy_def)
qed

corollary ex_retract_id:
  assumes "vwb_lens x"
  shows "retract (ex x \<Leftarrow>\<langle>ex x, id\<rangle>\<Rightarrow> id)"
  using assms ex_retract[where H="id"] by (auto)
end


(*  Title:      HOL/Number_Theory/Totient.thy
    Author:     Jeremy Avigad
    Author:     Florian Haftmann
    Author:     Manuel Eberl
*)

section \<open>Fundamental facts about Euler's totient function\<close>

theory Totient
imports
  Complex_Main
  "HOL-Computational_Algebra.Primes"
  Cong
begin

definition totatives :: "nat \<Rightarrow> nat set" where
  "totatives n = {k \<in> {0<..n}. coprime k n}"

lemma in_totatives_iff: "k \<in> totatives n \<longleftrightarrow> k > 0 \<and> k \<le> n \<and> coprime k n"
  by (simp add: totatives_def)

lemma totatives_code [code]: "totatives n = Set.filter (\<lambda>k. coprime k n) {0<..n}"
  by (simp add: totatives_def Set.filter_def)

lemma finite_totatives [simp]: "finite (totatives n)"
  by (simp add: totatives_def)

lemma totatives_subset: "totatives n \<subseteq> {0<..n}"
  by (auto simp: totatives_def)

lemma zero_not_in_totatives [simp]: "0 \<notin> totatives n"
  by (auto simp: totatives_def)

lemma totatives_le: "x \<in> totatives n \<Longrightarrow> x \<le> n"
  by (auto simp: totatives_def)

lemma totatives_less:
  assumes "x \<in> totatives n" "n > 1"
  shows   "x < n"
proof -
  from assms have "x \<noteq> n" by (auto simp: totatives_def)
  with totatives_le[OF assms(1)] show ?thesis by simp
qed

lemma totatives_0 [simp]: "totatives 0 = {}"
  by (auto simp: totatives_def)

lemma totatives_1 [simp]: "totatives 1 = {Suc 0}"
  by (auto simp: totatives_def)

lemma totatives_Suc_0 [simp]: "totatives (Suc 0) = {Suc 0}"
  by (auto simp: totatives_def)

lemma one_in_totatives [simp]: "n > 0 \<Longrightarrow> Suc 0 \<in> totatives n"
  by (auto simp: totatives_def)

lemma totatives_eq_empty_iff [simp]: "totatives n = {} \<longleftrightarrow> n = 0"
  using one_in_totatives[of n] by (auto simp del: one_in_totatives)

lemma minus_one_in_totatives:
  assumes "n \<ge> 2"
  shows "n - 1 \<in> totatives n"
  using assms coprime_diff_one_left_nat [of n] by (simp add: in_totatives_iff)

lemma power_in_totatives:
  assumes "m > 1" "coprime m g"
  shows   "g ^ i mod m \<in> totatives m"
proof -
  have "\<not>m dvd g ^ i"
  proof
    assume "m dvd g ^ i"
    hence "\<not>coprime m (g ^ i)"
      using \<open>m > 1\<close> by (subst coprime_absorb_left) auto
    with \<open>coprime m g\<close> show False by simp
  qed
  with assms show ?thesis
    by (auto simp: totatives_def coprime_commute intro!: Nat.gr0I)
qed

lemma totatives_prime_power_Suc:
  assumes "prime p"
  shows   "totatives (p ^ Suc n) = {0<..p^Suc n} - (\<lambda>m. p * m) ` {0<..p^n}"
proof safe
  fix m assume m: "p * m \<in> totatives (p ^ Suc n)" and m: "m \<in> {0<..p^n}"
  thus False using assms by (auto simp: totatives_def gcd_mult_left)
next
  fix k assume k: "k \<in> {0<..p^Suc n}" "k \<notin> (\<lambda>m. p * m) ` {0<..p^n}"
  from k have "\<not>(p dvd k)" by (auto elim!: dvdE)
  hence "coprime k (p ^ Suc n)"
    using prime_imp_coprime [OF assms, of k]
    by (cases "n > 0") (auto simp add: ac_simps)
  with k show "k \<in> totatives (p ^ Suc n)" by (simp add: totatives_def)
qed (auto simp: totatives_def)

lemma totatives_prime: "prime p \<Longrightarrow> totatives p = {0<..<p}"
  using totatives_prime_power_Suc [of p 0] by auto

lemma bij_betw_totatives:
  assumes "m1 > 1" "m2 > 1" "coprime m1 m2"
  shows   "bij_betw (\<lambda>x. (x mod m1, x mod m2)) (totatives (m1 * m2))
             (totatives m1 \<times> totatives m2)"
  unfolding bij_betw_def
proof
  show "inj_on (\<lambda>x. (x mod m1, x mod m2)) (totatives (m1 * m2))"
  proof (intro inj_onI, clarify)
    fix x y assume xy: "x \<in> totatives (m1 * m2)" "y \<in> totatives (m1 * m2)"
                       "x mod m1 = y mod m1" "x mod m2 = y mod m2"
    have ex: "\<exists>!z. z < m1 * m2 \<and> [z = x] (mod m1) \<and> [z = x] (mod m2)"
      by (rule binary_chinese_remainder_unique_nat) (insert assms, simp_all)
    have "x < m1 * m2 \<and> [x = x] (mod m1) \<and> [x = x] (mod m2)"
         "y < m1 * m2 \<and> [y = x] (mod m1) \<and> [y = x] (mod m2)"
      using xy assms by (simp_all add: totatives_less one_less_mult cong_def)
    from this[THEN the1_equality[OF ex]] show "x = y" by simp
  qed
next
  show "(\<lambda>x. (x mod m1, x mod m2)) ` totatives (m1 * m2) = totatives m1 \<times> totatives m2"
  proof safe
    fix x assume "x \<in> totatives (m1 * m2)"
    with assms show "x mod m1 \<in> totatives m1" "x mod m2 \<in> totatives m2"
      using coprime_common_divisor [of x m1 m1] coprime_common_divisor [of x m2 m2]
      by (auto simp add: in_totatives_iff mod_greater_zero_iff_not_dvd)
  next
    fix a b assume ab: "a \<in> totatives m1" "b \<in> totatives m2"
    with assms have ab': "a < m1" "b < m2" by (auto simp: totatives_less)
    with binary_chinese_remainder_unique_nat[OF assms(3), of a b] obtain x
      where x: "x < m1 * m2" "x mod m1 = a" "x mod m2 = b" by (auto simp: cong_def)
    from x ab assms(3) have "x \<in> totatives (m1 * m2)"
      by (auto intro: ccontr simp add: in_totatives_iff)
    with x show "(a, b) \<in> (\<lambda>x. (x mod m1, x mod m2)) ` totatives (m1*m2)" by blast
  qed
qed

lemma bij_betw_totatives_gcd_eq:
  fixes n d :: nat
  assumes "d dvd n" "n > 0"
  shows   "bij_betw (\<lambda>k. k * d) (totatives (n div d)) {k\<in>{0<..n}. gcd k n = d}"
  unfolding bij_betw_def
proof
  show "inj_on (\<lambda>k. k * d) (totatives (n div d))"
    by (auto simp: inj_on_def)
next
  show "(\<lambda>k. k * d) ` totatives (n div d) = {k\<in>{0<..n}. gcd k n = d}"
  proof (intro equalityI subsetI, goal_cases)
    case (1 k)
    then show ?case using assms
      by (auto elim: dvdE simp add: in_totatives_iff ac_simps gcd_mult_right)
  next
    case (2 k)
    hence "d dvd k" by auto
    then obtain l where k: "k = l * d" by (elim dvdE) auto
    from 2 assms show ?case
      using gcd_mult_right [of _ d l]
      by (auto intro: gcd_eq_1_imp_coprime elim!: dvdE simp add: k image_iff in_totatives_iff ac_simps)
  qed
qed

definition totient :: "nat \<Rightarrow> nat" where
  "totient n = card (totatives n)"

primrec totient_naive :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "totient_naive 0 acc n = acc"
| "totient_naive (Suc k) acc n =
     (if coprime (Suc k) n then totient_naive k (acc + 1) n else totient_naive k acc n)"

lemma totient_naive:
  "totient_naive k acc n = card {x \<in> {0<..k}. coprime x n} + acc"
proof (induction k arbitrary: acc)
  case (Suc k acc)
  have "totient_naive (Suc k) acc n =
          (if coprime (Suc k) n then 1 else 0) + card {x \<in> {0<..k}. coprime x n} + acc"
    using Suc by simp
  also have "(if coprime (Suc k) n then 1 else 0) =
               card (if coprime (Suc k) n then {Suc k} else {})" by auto
  also have "\<dots> + card {x \<in> {0<..k}. coprime x n} =
               card ((if coprime (Suc k) n then {Suc k} else {}) \<union> {x \<in> {0<..k}. coprime x n})"
    by (intro card_Un_disjoint [symmetric]) auto
  also have "((if coprime (Suc k) n then {Suc k} else {}) \<union> {x \<in> {0<..k}. coprime x n}) =
               {x \<in> {0<..Suc k}. coprime x n}" by (auto elim: le_SucE)
  finally show ?case .
qed simp_all

lemma totient_code_naive [code]: "totient n = totient_naive n 0 n"
  by (subst totient_naive) (simp add: totient_def totatives_def)

lemma totient_le: "totient n \<le> n"
proof -
  have "card (totatives n) \<le> card {0<..n}"
    by (intro card_mono) (auto simp: totatives_def)
  thus ?thesis by (simp add: totient_def)
qed

lemma totient_less:
  assumes "n > 1"
  shows "totient n < n"
proof -
  from assms have "card (totatives n) \<le> card {0<..<n}"
    using totatives_less[of _ n] totatives_subset[of n] by (intro card_mono) auto
  with assms show ?thesis by (simp add: totient_def)
qed

lemma totient_0 [simp]: "totient 0 = 0"
  by (simp add: totient_def)

lemma totient_Suc_0 [simp]: "totient (Suc 0) = Suc 0"
  by (simp add: totient_def)

lemma totient_1 [simp]: "totient 1 = Suc 0"
  by simp

lemma totient_0_iff [simp]: "totient n = 0 \<longleftrightarrow> n = 0"
  by (auto simp: totient_def)

lemma totient_gt_0_iff [simp]: "totient n > 0 \<longleftrightarrow> n > 0"
  by (auto intro: Nat.gr0I)

lemma totient_gt_1:
  assumes "n > 2"
  shows   "totient n > 1"
proof -
  have "{1, n - 1} \<subseteq> totatives n"
    using assms coprime_diff_one_left_nat[of n] by (auto simp: totatives_def)
  hence "card {1, n - 1} \<le> card (totatives n)"
    by (intro card_mono) auto
  thus ?thesis using assms
    by (simp add: totient_def)
qed

lemma card_gcd_eq_totient:
  "n > 0 \<Longrightarrow> d dvd n \<Longrightarrow> card {k\<in>{0<..n}. gcd k n = d} = totient (n div d)"
  unfolding totient_def by (rule sym, rule bij_betw_same_card[OF bij_betw_totatives_gcd_eq])

lemma totient_divisor_sum: "(\<Sum>d | d dvd n. totient d) = n"
proof (cases "n = 0")
  case False
  hence "n > 0" by simp
  define A where "A = (\<lambda>d. {k\<in>{0<..n}. gcd k n = d})"
  have *: "card (A d) = totient (n div d)" if d: "d dvd n" for d
    using \<open>n > 0\<close> and d unfolding A_def by (rule card_gcd_eq_totient)
  have "n = card {1..n}" by simp
  also have "{1..n} = (\<Union>d\<in>{d. d dvd n}. A d)" by safe (auto simp: A_def)
  also have "card \<dots> = (\<Sum>d | d dvd n. card (A d))"
    using \<open>n > 0\<close> by (intro card_UN_disjoint) (auto simp: A_def)
  also have "\<dots> = (\<Sum>d | d dvd n. totient (n div d))" by (intro sum.cong refl *) auto
  also have "\<dots> = (\<Sum>d | d dvd n. totient d)" using \<open>n > 0\<close>
    by (intro sum.reindex_bij_witness[of _ "(div) n" "(div) n"]) (auto elim: dvdE)
  finally show ?thesis ..
qed auto

lemma totient_mult_coprime:
  assumes "coprime m n"
  shows   "totient (m * n) = totient m * totient n"
proof (cases "m > 1 \<and> n > 1")
  case True
  hence mn: "m > 1" "n > 1" by simp_all
  have "totient (m * n) = card (totatives (m * n))" by (simp add: totient_def)
  also have "\<dots> = card (totatives m \<times> totatives n)"
    using bij_betw_totatives [OF mn \<open>coprime m n\<close>] by (rule bij_betw_same_card)
  also have "\<dots> = totient m * totient n" by (simp add: totient_def)
  finally show ?thesis .
next
  case False
  with assms show ?thesis by (cases m; cases n) auto
qed

lemma totient_prime_power_Suc:
  assumes "prime p"
  shows   "totient (p ^ Suc n) = p ^ n * (p - 1)"
proof -
  from assms have "totient (p ^ Suc n) = card ({0<..p ^ Suc n} - (*) p ` {0<..p ^ n})"
    unfolding totient_def by (subst totatives_prime_power_Suc) simp_all
  also from assms have "\<dots> = p ^ Suc n - card ((*) p ` {0<..p^n})"
    by (subst card_Diff_subset) (auto intro: prime_gt_0_nat)
  also from assms have "card ((*) p ` {0<..p^n}) = p ^ n"
    by (subst card_image) (auto simp: inj_on_def)
  also have "p ^ Suc n - p ^ n = p ^ n * (p - 1)" by (simp add: algebra_simps)
  finally show ?thesis .
qed

lemma totient_prime_power:
  assumes "prime p" "n > 0"
  shows   "totient (p ^ n) = p ^ (n - 1) * (p - 1)"
  using totient_prime_power_Suc[of p "n - 1"] assms by simp

lemma totient_imp_prime:
  assumes "totient p = p - 1" "p > 0"
  shows   "prime p"
proof (cases "p = 1")
  case True
  with assms show ?thesis by auto
next
  case False
  with assms have p: "p > 1" by simp
  have "x \<in> {0<..<p}" if "x \<in> totatives p" for x
    using that and p by (cases "x = p") (auto simp: totatives_def)
  with assms have *: "totatives p = {0<..<p}"
    by (intro card_subset_eq) (auto simp: totient_def)
  have **: False if "x \<noteq> 1" "x \<noteq> p" "x dvd p" for x
  proof -
    from that have nz: "x \<noteq> 0" by (auto intro!: Nat.gr0I)
    from that and p have le: "x \<le> p" by (intro dvd_imp_le) auto
    from that and nz have "\<not>coprime x p"
      by (auto elim: dvdE)
    hence "x \<notin> totatives p" by (simp add: totatives_def)
    also note *
    finally show False using that and le by auto
  qed
  hence "(\<forall>m. m dvd p \<longrightarrow> m = 1 \<or> m = p)" by blast
  with p show ?thesis by (subst prime_nat_iff) (auto dest: **)
qed

lemma totient_prime:
  assumes "prime p"
  shows   "totient p = p - 1"
  using totient_prime_power_Suc[of p 0] assms by simp

lemma totient_2 [simp]: "totient 2 = 1"
  and totient_3 [simp]: "totient 3 = 2"
  and totient_5 [simp]: "totient 5 = 4"
  and totient_7 [simp]: "totient 7 = 6"
  by (subst totient_prime; simp)+

lemma totient_4 [simp]: "totient 4 = 2"
  and totient_8 [simp]: "totient 8 = 4"
  and totient_9 [simp]: "totient 9 = 6"
  using totient_prime_power[of 2 2] totient_prime_power[of 2 3] totient_prime_power[of 3 2]
  by simp_all

lemma totient_6 [simp]: "totient 6 = 2"
  using totient_mult_coprime [of 2 3] coprime_add_one_right [of 2]
  by simp

lemma totient_even:
  assumes "n > 2"
  shows   "even (totient n)"
proof (cases "\<exists>p. prime p \<and> p \<noteq> 2 \<and> p dvd n")
  case True
  then obtain p where p: "prime p" "p \<noteq> 2" "p dvd n" by auto
  from \<open>p \<noteq> 2\<close> have "p = 0 \<or> p = 1 \<or> p > 2" by auto
  with p(1) have "odd p" using prime_odd_nat[of p] by auto
  define k where "k = multiplicity p n"
  from p assms have k_pos: "k > 0" unfolding k_def by (subst multiplicity_gt_zero_iff) auto
  have "p ^ k dvd n" unfolding k_def by (simp add: multiplicity_dvd)
  then obtain m where m: "n = p ^ k * m" by (elim dvdE)
  with assms have m_pos: "m > 0" by (auto intro!: Nat.gr0I)
  from k_def m_pos p have "\<not> p dvd m"
    by (subst (asm) m) (auto intro!: Nat.gr0I simp: prime_elem_multiplicity_mult_distrib
                          prime_elem_multiplicity_eq_zero_iff)
  with \<open>prime p\<close> have "coprime p m"
    by (rule prime_imp_coprime)
  with \<open>k > 0\<close> have "coprime (p ^ k) m"
    by simp
  then show ?thesis using p k_pos \<open>odd p\<close>
    by (auto simp add: m totient_mult_coprime totient_prime_power)
next
  case False
  from assms have "n = (\<Prod>p\<in>prime_factors n. p ^ multiplicity p n)"
    by (intro Primes.prime_factorization_nat) auto
  also from False have "\<dots> = (\<Prod>p\<in>prime_factors n. if p = 2 then 2 ^ multiplicity 2 n else 1)"
    by (intro prod.cong refl) auto
  also have "\<dots> = 2 ^ multiplicity 2 n"
    by (subst prod.delta[OF finite_set_mset]) (auto simp: prime_factors_multiplicity)
  finally have n: "n = 2 ^ multiplicity 2 n" .
  have "multiplicity 2 n = 0 \<or> multiplicity 2 n = 1 \<or> multiplicity 2 n > 1" by force
  with n assms have "multiplicity 2 n > 1" by auto
  thus ?thesis by (subst n) (simp add: totient_prime_power)
qed

lemma totient_prod_coprime:
  assumes "pairwise coprime (f ` A)" "inj_on f A"
  shows   "totient (prod f A) = (\<Prod>a\<in>A. totient (f a))"
  using assms
proof (induction A rule: infinite_finite_induct)
  case (insert x A)
  have *: "coprime (prod f A) (f x)"
  proof (rule prod_coprime_left)
    fix y
    assume "y \<in> A"
    with \<open>x \<notin> A\<close> have "y \<noteq> x"
      by auto
    with \<open>x \<notin> A\<close> \<open>y \<in> A\<close> \<open>inj_on f (insert x A)\<close> have "f y \<noteq> f x"
      using inj_onD [of f "insert x A" y x]
      by auto
    with \<open>y \<in> A\<close> show "coprime (f y) (f x)"
      using pairwiseD [OF \<open>pairwise coprime (f ` insert x A)\<close>]
      by auto
  qed
  from insert.hyps have "prod f (insert x A) = prod f A * f x" by simp
  also have "totient \<dots> = totient (prod f A) * totient (f x)"
    using insert.hyps insert.prems by (intro totient_mult_coprime *)
  also have "totient (prod f A) = (\<Prod>a\<in>A. totient (f a))"
    using insert.prems by (intro insert.IH) (auto dest: pairwise_subset)
  also from insert.hyps have "\<dots> * totient (f x) = (\<Prod>a\<in>insert x A. totient (f a))" by simp
  finally show ?case .
qed simp_all

(* TODO Move *)
lemma prime_power_eq_imp_eq:
  fixes p q :: "'a :: factorial_semiring"
  assumes "prime p" "prime q" "m > 0"
  assumes "p ^ m = q ^ n"
  shows   "p = q"
proof (rule ccontr)
  assume pq: "p \<noteq> q"
  from assms have "m = multiplicity p (p ^ m)"
    by (subst multiplicity_prime_power) auto
  also note \<open>p ^ m = q ^ n\<close>
  also from assms pq have "multiplicity p (q ^ n) = 0"
    by (subst multiplicity_distinct_prime_power) auto
  finally show False using \<open>m > 0\<close> by simp
qed

lemma totient_formula1:
  assumes "n > 0"
  shows   "totient n = (\<Prod>p\<in>prime_factors n. p ^ (multiplicity p n - 1) * (p - 1))"
proof -
  from assms have "n = (\<Prod>p\<in>prime_factors n. p ^ multiplicity p n)"
    by (rule prime_factorization_nat)
  also have "totient \<dots> = (\<Prod>x\<in>prime_factors n. totient (x ^ multiplicity x n))"
  proof (rule totient_prod_coprime)
    show "pairwise coprime ((\<lambda>p. p ^ multiplicity p n) ` prime_factors n)"
    proof (rule pairwiseI, clarify)
      fix p q assume *: "p \<in># prime_factorization n" "q \<in># prime_factorization n"
                     "p ^ multiplicity p n \<noteq> q ^ multiplicity q n"
      then have "multiplicity p n > 0" "multiplicity q n > 0"
        by (simp_all add: prime_factors_multiplicity)
      with * primes_coprime [of p q] show "coprime (p ^ multiplicity p n) (q ^ multiplicity q n)"
        by auto
    qed
  next
    show "inj_on (\<lambda>p. p ^ multiplicity p n) (prime_factors n)"
    proof
      fix p q assume pq: "p \<in># prime_factorization n" "q \<in># prime_factorization n"
                         "p ^ multiplicity p n = q ^ multiplicity q n"
      from assms and pq have "prime p" "prime q" "multiplicity p n > 0"
        by (simp_all add: prime_factors_multiplicity)
      from prime_power_eq_imp_eq[OF this pq(3)] show "p = q" .
    qed
  qed
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. p ^ (multiplicity p n - 1) * (p - 1))"
    by (intro prod.cong refl totient_prime_power) (auto simp: prime_factors_multiplicity)
  finally show ?thesis .
qed

lemma totient_dvd:
  assumes "m dvd n"
  shows   "totient m dvd totient n"
proof (cases "m = 0 \<or> n = 0")
  case False
  let ?M = "\<lambda>p m :: nat. multiplicity p m - 1"
  have "(\<Prod>p\<in>prime_factors m. p ^ ?M p m * (p - 1)) dvd
          (\<Prod>p\<in>prime_factors n. p ^ ?M p n * (p - 1))" using assms False
    by (intro prod_dvd_prod_subset2 mult_dvd_mono dvd_refl le_imp_power_dvd diff_le_mono
              dvd_prime_factors dvd_imp_multiplicity_le) auto
  with False show ?thesis by (simp add: totient_formula1)
qed (insert assms, auto)

lemma totient_dvd_mono:
  assumes "m dvd n" "n > 0"
  shows   "totient m \<le> totient n"
  by (cases "m = 0") (insert assms, auto intro: dvd_imp_le totient_dvd)

(* TODO Move *)
lemma prime_factors_power: "n > 0 \<Longrightarrow> prime_factors (x ^ n) = prime_factors x"
  by (cases "x = 0"; cases "n = 0")
     (auto simp: prime_factors_multiplicity prime_elem_multiplicity_power_distrib zero_power)

lemma totient_formula2:
  "real (totient n) = real n * (\<Prod>p\<in>prime_factors n. 1 - 1 / real p)"
proof (cases "n = 0")
  case False
  have "real (totient n) = (\<Prod>p\<in>prime_factors n. real
          (p ^ (multiplicity p n - 1) * (p - 1)))"
    using False by (subst totient_formula1) simp_all
  also have "\<dots> = (\<Prod>p\<in>prime_factors n. real (p ^ multiplicity p n) * (1 - 1 / real p))"
    by (intro prod.cong refl) (auto simp add: field_simps prime_factors_multiplicity
          prime_ge_Suc_0_nat of_nat_diff power_Suc [symmetric] simp del: power_Suc)
  also have "\<dots> = real (\<Prod>p\<in>prime_factors n. p ^ multiplicity p n) *
                    (\<Prod>p\<in>prime_factors n. 1 - 1 / real p)" by (subst prod.distrib) auto
  also have "(\<Prod>p\<in>prime_factors n. p ^ multiplicity p n) = n"
    using False by (intro Primes.prime_factorization_nat [symmetric]) auto
  finally show ?thesis .
qed auto

lemma totient_gcd: "totient (a * b) * totient (gcd a b) = totient a * totient b * gcd a b"
proof (cases "a = 0 \<or> b = 0")
  case False
  let ?P = "prime_factors :: nat \<Rightarrow> nat set"
  have "real (totient a * totient b * gcd a b) = real (a * b * gcd a b) *
          ((\<Prod>p\<in>?P a. 1 - 1 / real p) * (\<Prod>p\<in>?P b. 1 - 1 / real p))"
    by (simp add: totient_formula2)
  also have "?P a = (?P a - ?P b) \<union> (?P a \<inter> ?P b)" by auto
  also have "(\<Prod>p\<in>\<dots>. 1 - 1 / real p) =
                 (\<Prod>p\<in>?P a - ?P b. 1 - 1 / real p) * (\<Prod>p\<in>?P a \<inter> ?P b. 1 - 1 / real p)"
    by (rule prod.union_disjoint) blast+
  also have "\<dots> * (\<Prod>p\<in>?P b. 1 - 1 / real p) = (\<Prod>p\<in>?P a - ?P b. 1 - 1 / real p) *
               (\<Prod>p\<in>?P b. 1 - 1 / real p) * (\<Prod>p\<in>?P a \<inter> ?P b. 1 - 1 / real p)" (is "_ = ?A * _")
    by (simp only: mult_ac)
  also have "?A = (\<Prod>p\<in>?P a - ?P b \<union> ?P b. 1 - 1 / real p)"
    by (rule prod.union_disjoint [symmetric]) blast+
  also have "?P a - ?P b \<union> ?P b = ?P a \<union> ?P b" by blast
  also have "real (a * b * gcd a b) * ((\<Prod>p\<in>\<dots>. 1 - 1 / real p) *
                 (\<Prod>p\<in>?P a \<inter> ?P b. 1 - 1 / real p)) = real (totient (a * b) * totient (gcd a b))"
    using False by (simp add: totient_formula2 prime_factors_product prime_factorization_gcd)
  finally show ?thesis by (simp only: of_nat_eq_iff)
qed auto

lemma totient_mult: "totient (a * b) = totient a * totient b * gcd a b div totient (gcd a b)"
  by (subst totient_gcd [symmetric]) simp

lemma of_nat_eq_1_iff: "of_nat x = (1 :: 'a :: {semiring_1, semiring_char_0}) \<longleftrightarrow> x = 1"
  by (fact of_nat_eq_1_iff)

(* TODO Move *)
lemma odd_imp_coprime_nat:
  assumes "odd (n::nat)"
  shows   "coprime n 2"
proof -
  from assms obtain k where n: "n = Suc (2 * k)" by (auto elim!: oddE)
  have "coprime (Suc (2 * k)) (2 * k)"
    by (fact coprime_Suc_left_nat)
  then show ?thesis using n
    by simp
qed

lemma totient_double: "totient (2 * n) = (if even n then 2 * totient n else totient n)"
  by (simp add: totient_mult ac_simps odd_imp_coprime_nat)

lemma totient_power_Suc: "totient (n ^ Suc m) = n ^ m * totient n"
proof (induction m arbitrary: n)
  case (Suc m n)
  have "totient (n ^ Suc (Suc m)) = totient (n * n ^ Suc m)" by simp
  also have "\<dots> = n ^ Suc m * totient n"
    using Suc.IH by (subst totient_mult) simp
  finally show ?case .
qed simp_all

lemma totient_power: "m > 0 \<Longrightarrow> totient (n ^ m) = n ^ (m - 1) * totient n"
  using totient_power_Suc[of n "m - 1"] by (cases m) simp_all

lemma totient_gcd_lcm: "totient (gcd a b) * totient (lcm a b) = totient a * totient b"
proof (cases "a = 0 \<or> b = 0")
  case False
  let ?P = "prime_factors :: nat \<Rightarrow> nat set" and ?f = "\<lambda>p::nat. 1 - 1 / real p"
  have "real (totient (gcd a b) * totient (lcm a b)) = real (gcd a b * lcm a b) *
          (prod ?f (?P a \<inter> ?P b) * prod ?f (?P a \<union> ?P b))"
    using False unfolding of_nat_mult
    by (simp add: totient_formula2 prime_factorization_gcd prime_factorization_lcm)
  also have "gcd a b * lcm a b = a * b" by simp
  also have "?P a \<union> ?P b = (?P a - ?P a \<inter> ?P b) \<union> ?P b" by blast
  also have "prod ?f \<dots> = prod ?f (?P a - ?P a \<inter> ?P b) * prod ?f (?P b)"
    by (rule prod.union_disjoint) blast+
  also have "prod ?f (?P a \<inter> ?P b) * \<dots> =
               prod ?f (?P a \<inter> ?P b \<union> (?P a - ?P a \<inter> ?P b)) * prod ?f (?P b)"
    by (subst prod.union_disjoint) auto
  also have "?P a \<inter> ?P b \<union> (?P a - ?P a \<inter> ?P b) = ?P a" by blast
  also have "real (a * b) * (prod ?f (?P a) * prod ?f (?P b)) = real (totient a * totient b)"
    using False by (simp add: totient_formula2)
  finally show ?thesis by (simp only: of_nat_eq_iff)
qed auto

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Half Galois Property\<close>
theory Half_Galois_Property
  imports
    Galois_Base
    Order_Equivalences
begin

text \<open>As the definition of the Galois property also works on heterogeneous relations,
we define the concepts in a locale that generalises @{locale galois}.\<close>

locale galois_prop = orders L R
  for L :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
  and R :: "'c \<Rightarrow> 'd \<Rightarrow> bool"
  and l :: "'a \<Rightarrow> 'c"
  and r :: "'d \<Rightarrow> 'b"
begin

text \<open>Unlike common literature, we split the definition of the Galois property
into two halves. This has its merits in modularity of proofs and preciser
statement of required assumptions.\<close>

definition "half_galois_prop_left \<equiv>
  \<forall>x y. in_codom (\<le>\<^bsub>R\<^esub>) y \<longrightarrow> x \<le>\<^bsub>L\<^esub> r y \<longrightarrow> l x \<le>\<^bsub>R\<^esub> y"

notation galois_prop.half_galois_prop_left (infix "\<^sub>h\<unlhd>" 50)

lemma half_galois_prop_leftI [intro]:
  assumes "\<And>x y. in_codom (\<le>\<^bsub>R\<^esub>) y \<Longrightarrow> x \<le>\<^bsub>L\<^esub> r y \<Longrightarrow> l x \<le>\<^bsub>R\<^esub> y"
  shows "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding half_galois_prop_left_def using assms by blast

lemma half_galois_prop_leftD [dest]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "in_codom (\<le>\<^bsub>R\<^esub>) y"
  and "x \<le>\<^bsub>L\<^esub> r y"
  shows "l x \<le>\<^bsub>R\<^esub> y"
  using assms unfolding half_galois_prop_left_def by blast

text\<open>Observe that the second half can be obtained by creating an appropriately
flipped and inverted interpretation of @{locale galois_prop}. Indeed, many
concepts in our formalisation are "closed" under inversion,
i.e. taking their inversion yields a statement for a related concept.
Many theorems can thus be derived for free by inverting (and flipping) the
concepts at hand. In such cases, we only state those theorems that require some
non-trivial setup. All other theorems can simply be obtained by creating a
suitable locale interpretation.\<close>

interpretation flip_inv : galois_prop "(\<ge>\<^bsub>R\<^esub>)" "(\<ge>\<^bsub>L\<^esub>)" r l .

definition "half_galois_prop_right \<equiv> flip_inv.half_galois_prop_left"

notation galois_prop.half_galois_prop_right (infix "\<unlhd>\<^sub>h" 50)

lemma half_galois_prop_rightI [intro]:
  assumes "\<And>x y. in_dom (\<le>\<^bsub>L\<^esub>) x \<Longrightarrow> l x \<le>\<^bsub>R\<^esub> y \<Longrightarrow> x \<le>\<^bsub>L\<^esub> r y"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  unfolding half_galois_prop_right_def using assms by blast

lemma half_galois_prop_rightD [dest]:
  assumes "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  and "in_dom (\<le>\<^bsub>L\<^esub>) x"
  and "l x \<le>\<^bsub>R\<^esub> y"
  shows "x \<le>\<^bsub>L\<^esub> r y"
  using assms unfolding half_galois_prop_right_def by blast

interpretation g : galois_prop S T f g for S T f g .

lemma rel_inv_half_galois_prop_right_eq_half_galois_prop_left_rel_inv [simp]:
  "((\<le>\<^bsub>R\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L\<^esub>))\<inverse> = ((\<ge>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<ge>\<^bsub>R\<^esub>))"
  by (intro ext) blast

corollary half_galois_prop_left_rel_inv_iff_half_galois_prop_right [iff]:
  "((\<ge>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<ge>\<^bsub>R\<^esub>)) f g \<longleftrightarrow> ((\<le>\<^bsub>R\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L\<^esub>)) g f"
  by (simp flip: rel_inv_half_galois_prop_right_eq_half_galois_prop_left_rel_inv)

lemma rel_inv_half_galois_prop_left_eq_half_galois_prop_right_rel_inv [simp]:
  "((\<le>\<^bsub>R\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L\<^esub>))\<inverse> = ((\<ge>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<ge>\<^bsub>R\<^esub>))"
  by (intro ext) blast

corollary half_galois_prop_right_rel_inv_iff_half_galois_prop_left [iff]:
  "((\<ge>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<ge>\<^bsub>R\<^esub>)) f g \<longleftrightarrow> ((\<le>\<^bsub>R\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L\<^esub>)) g f"
  by (simp flip: rel_inv_half_galois_prop_left_eq_half_galois_prop_right_rel_inv)

end

context galois
begin

sublocale galois_prop L R l r .

lemma rel_unit_if_left_rel_if_mono_wrt_relI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "in_dom (\<le>\<^bsub>L\<^esub>) x \<Longrightarrow> l x \<le>\<^bsub>R\<^esub> l x' \<Longrightarrow> x \<le>\<^bsub>L\<^esub> \<eta> x'"
  and "x \<le>\<^bsub>L\<^esub> x'"
  shows "x \<le>\<^bsub>L\<^esub> \<eta> x'"
  using assms by auto

corollary rel_unit_if_left_rel_if_half_galois_prop_right_if_mono_wrt_rel:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  and "x \<le>\<^bsub>L\<^esub> x'"
  shows "x \<le>\<^bsub>L\<^esub> \<eta> x'"
  using assms
  by (auto intro: rel_unit_if_left_rel_if_mono_wrt_relI half_galois_prop_rightD)

corollary rel_unit_if_reflexive_on_if_half_galois_prop_right_if_mono_wrt_rel:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  and "P x"
  shows "x \<le>\<^bsub>L\<^esub> \<eta> x"
  using assms by (blast
    intro: rel_unit_if_left_rel_if_half_galois_prop_right_if_mono_wrt_rel)

corollary inflationary_on_unit_if_reflexive_on_if_half_galois_prop_rightI:
  fixes P :: "'a \<Rightarrow> bool"
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>L\<^esub>)"
  shows "inflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  using assms by (intro inflationary_onI) (fastforce intro:
    rel_unit_if_reflexive_on_if_half_galois_prop_right_if_mono_wrt_rel)

interpretation flip : galois_prop R L r l .

lemma right_rel_if_right_left_rel_right_if_deflationary_onI:
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "((\<le>\<^bsub>R\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>L\<^esub>)) r l"
  and "deflationary_on P (\<le>\<^bsub>R\<^esub>) \<epsilon>"
  and "transitive (\<le>\<^bsub>R\<^esub>)"
  and "r y \<le>\<^bsub>L\<^esub> r y'"
  and "in_dom (\<le>\<^bsub>R\<^esub>) y"
  and "P y'"
  shows "y \<le>\<^bsub>R\<^esub> y'"
  using assms by fastforce

lemma half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "deflationary_on (in_codom (\<le>\<^bsub>R\<^esub>)) (\<le>\<^bsub>R\<^esub>) \<epsilon>"
  and "transitive (\<le>\<^bsub>R\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  using assms by (intro half_galois_prop_leftI) fastforce

interpretation flip_inv : galois "(\<ge>\<^bsub>R\<^esub>)" "(\<ge>\<^bsub>L\<^esub>)" r l
  rewrites "flip_inv.unit \<equiv> \<epsilon>" and "flip_inv.counit \<equiv> \<eta>"
  and "\<And>R S. (R\<inverse> \<Rrightarrow>\<^sub>m S\<inverse>) \<equiv> (R \<Rrightarrow>\<^sub>m S)"
  and "\<And>R S f g. (R\<inverse> \<unlhd>\<^sub>h S\<inverse>) f g \<equiv> (S \<^sub>h\<unlhd> R) g f"
  and "((\<ge>\<^bsub>R\<^esub>) \<^sub>h\<unlhd> (\<ge>\<^bsub>L\<^esub>)) r l \<equiv> ((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  and "\<And>P R. inflationary_on P R\<inverse> \<equiv> deflationary_on P R"
  and "\<And>P R. deflationary_on P R\<inverse>  \<equiv> inflationary_on P R"
  and "\<And>(P :: 'b \<Rightarrow> bool). reflexive_on P (\<ge>\<^bsub>R\<^esub>) \<equiv> reflexive_on P (\<le>\<^bsub>R\<^esub>)"
  and "\<And>R. transitive R\<inverse> \<equiv> transitive R"
  and "\<And>R. in_dom R\<inverse> \<equiv> in_codom R"
  and "\<And>R. in_codom R\<inverse> \<equiv> in_dom R"
  by (simp_all add: flip_unit_eq_counit flip_counit_eq_unit
    galois_prop.half_galois_prop_left_rel_inv_iff_half_galois_prop_right
    galois_prop.half_galois_prop_right_rel_inv_iff_half_galois_prop_left)

corollary counit_rel_if_right_rel_if_mono_wrt_relI:
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "in_codom (\<le>\<^bsub>R\<^esub>) y' \<Longrightarrow> r y \<le>\<^bsub>L\<^esub> r y' \<Longrightarrow> \<epsilon> y \<le>\<^bsub>R\<^esub> y'"
  and "y \<le>\<^bsub>R\<^esub> y'"
  shows "\<epsilon> y \<le>\<^bsub>R\<^esub> y'"
  using assms
  by (fact flip_inv.rel_unit_if_left_rel_if_mono_wrt_relI
    [simplified rel_inv_iff_rel])

corollary counit_rel_if_right_rel_if_half_galois_prop_left_if_mono_wrt_rel:
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "y \<le>\<^bsub>R\<^esub> y'"
  shows "\<epsilon> y \<le>\<^bsub>R\<^esub> y'"
  using assms
  by (fact flip_inv.rel_unit_if_left_rel_if_half_galois_prop_right_if_mono_wrt_rel
    [simplified rel_inv_iff_rel])

corollary counit_rel_if_reflexive_on_if_half_galois_prop_left_if_mono_wrt_rel:
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>R\<^esub>)"
  and "P y"
  shows "\<epsilon> y \<le>\<^bsub>R\<^esub> y"
  using assms
  by (fact flip_inv.rel_unit_if_reflexive_on_if_half_galois_prop_right_if_mono_wrt_rel
    [simplified rel_inv_iff_rel])

corollary deflationary_on_counit_if_reflexive_on_if_half_galois_prop_leftI:
  fixes P :: "'b \<Rightarrow> bool"
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  and "reflexive_on P (\<le>\<^bsub>R\<^esub>)"
  shows "deflationary_on P (\<le>\<^bsub>R\<^esub>) \<epsilon>"
  using assms
  by (fact flip_inv.inflationary_on_unit_if_reflexive_on_if_half_galois_prop_rightI)

corollary left_rel_if_left_right_rel_left_if_inflationary_onI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>L\<^esub>)) r l"
  and "inflationary_on P (\<le>\<^bsub>L\<^esub>) \<eta>"
  and "transitive (\<le>\<^bsub>L\<^esub>)"
  and "l x \<le>\<^bsub>R\<^esub> l x'"
  and "in_codom (\<le>\<^bsub>L\<^esub>) x'"
  and "P x"
  shows "x \<le>\<^bsub>L\<^esub> x'"
  using assms by (intro flip_inv.right_rel_if_right_left_rel_right_if_deflationary_onI
    [simplified rel_inv_iff_rel])

corollary half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel:
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "inflationary_on (in_dom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  and "transitive (\<le>\<^bsub>L\<^esub>)"
  shows "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  using assms
  by (fact flip_inv.half_galois_prop_left_left_right_if_transitive_if_deflationary_on_if_mono_wrt_rel)

end

context order_functors
begin

interpretation g : galois L R l r .
interpretation flip_g : galois R L r l
  rewrites "flip_g.unit \<equiv> \<epsilon>" and "flip_g.counit \<equiv> \<eta>"
  by (simp_all only: flip_unit_eq_counit flip_counit_eq_unit)

lemma left_rel_if_left_right_rel_left_if_order_equivalenceI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  and "transitive (\<le>\<^bsub>L\<^esub>)"
  and "l x \<le>\<^bsub>R\<^esub> l x'"
  and "in_dom (\<le>\<^bsub>L\<^esub>) x"
  and "in_codom (\<le>\<^bsub>L\<^esub>) x'"
  shows "x \<le>\<^bsub>L\<^esub> x'"
  using assms by (auto intro!:
      flip_g.right_rel_if_right_left_rel_right_if_deflationary_onI
      g.half_galois_prop_right_left_right_if_transitive_if_inflationary_on_if_mono_wrt_rel
    elim!: rel_equivalence_onE
    intro: inflationary_on_if_le_pred_if_inflationary_on
      in_field_if_in_dom in_field_if_in_codom)

end

end


(*  Title:      HOL/Analysis/Embed_Measure.thy
    Author:     Manuel Eberl, TU München

    Defines measure embeddings with injective functions, i.e. lifting a measure on some values
    to a measure on "tagged" values (e.g. embed_measure M Inl lifts a measure on values 'a to a
    measure on the left part of the sum type 'a + 'b)
*)

section \<open>Embedding Measure Spaces with a Function\<close>

theory Embed_Measure
imports Binary_Product_Measure
begin

text \<open>
  Given a measure space on some carrier set \<open>\<Omega>\<close> and a function \<open>f\<close>, we can define a push-forward
  measure on the carrier set \<open>f(\<Omega>)\<close> whose \<open>\<sigma>\<close>-algebra is the one generated by mapping \<open>f\<close> over
  the original sigma algebra.

  This is useful e.\,g.\ when \<open>f\<close> is injective, i.\,e.\ it is some kind of ``tagging'' function.
  For instance, suppose we have some algebraaic datatype of values with various constructors,
  including a constructor \<open>RealVal\<close> for real numbers. Then \<open>embed_measure\<close> allows us to lift a
  measure on real numbers to the appropriate subset of that algebraic datatype.
\<close>
definition\<^marker>\<open>tag important\<close> embed_measure :: "'a measure \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b measure" where
  "embed_measure M f = measure_of (f ` space M) {f ` A |A. A \<in> sets M}
                           (\<lambda>A. emeasure M (f -` A \<inter> space M))"

lemma space_embed_measure: "space (embed_measure M f) = f ` space M"
  unfolding embed_measure_def
  by (subst space_measure_of) (auto dest: sets.sets_into_space)

lemma sets_embed_measure':
  assumes inj: "inj_on f (space M)"
  shows "sets (embed_measure M f) = {f ` A |A. A \<in> sets M}"
  unfolding embed_measure_def
proof (intro sigma_algebra.sets_measure_of_eq sigma_algebra_iff2[THEN iffD2] conjI allI ballI impI)
  fix s assume "s \<in> {f ` A |A. A \<in> sets M}"
  then obtain s' where s'_props: "s = f ` s'" "s' \<in> sets M" by auto
  hence "f ` space M - s = f ` (space M - s')" using inj
    by (auto dest: inj_onD sets.sets_into_space)
  also have "... \<in> {f ` A |A. A \<in> sets M}" using s'_props by auto
  finally show "f ` space M - s \<in> {f ` A |A. A \<in> sets M}" .
next
  fix A :: "nat \<Rightarrow> _" assume "range A \<subseteq> {f ` A |A. A \<in> sets M}"
  then obtain A' where A': "\<And>i. A i = f ` A' i" "\<And>i. A' i \<in> sets M"
    by (auto simp: subset_eq choice_iff)
  then have "(\<Union>x. f ` A' x) = f ` (\<Union>x. A' x)" by blast
  with A' show "(\<Union>i. A i) \<in> {f ` A |A. A \<in> sets M}"
    by simp blast
qed (auto dest: sets.sets_into_space)

lemma the_inv_into_vimage:
  "inj_on f X \<Longrightarrow> A \<subseteq> X \<Longrightarrow> the_inv_into X f -` A \<inter> (f`X) = f ` A"
  by (auto simp: the_inv_into_f_f)

lemma sets_embed_eq_vimage_algebra:
  assumes "inj_on f (space M)"
  shows "sets (embed_measure M f) = sets (vimage_algebra (f`space M) (the_inv_into (space M) f) M)"
  by (auto simp: sets_embed_measure'[OF assms] Pi_iff the_inv_into_f_f assms sets_vimage_algebra2 Setcompr_eq_image
           dest: sets.sets_into_space
           intro!: image_cong the_inv_into_vimage[symmetric])

lemma sets_embed_measure:
  assumes inj: "inj f"
  shows "sets (embed_measure M f) = {f ` A |A. A \<in> sets M}"
  using assms by (subst sets_embed_measure') (auto intro!: inj_onI dest: injD)

lemma in_sets_embed_measure: "A \<in> sets M \<Longrightarrow> f ` A \<in> sets (embed_measure M f)"
  unfolding embed_measure_def
  by (intro in_measure_of) (auto dest: sets.sets_into_space)

lemma measurable_embed_measure1:
  assumes g: "(\<lambda>x. g (f x)) \<in> measurable M N"
  shows "g \<in> measurable (embed_measure M f) N"
  unfolding measurable_def
proof safe
  fix A assume "A \<in> sets N"
  with g have "(\<lambda>x. g (f x)) -` A \<inter> space M \<in> sets M"
    by (rule measurable_sets)
  then have "f ` ((\<lambda>x. g (f x)) -` A \<inter> space M) \<in> sets (embed_measure M f)"
    by (rule in_sets_embed_measure)
  also have "f ` ((\<lambda>x. g (f x)) -` A \<inter> space M) = g -` A \<inter> space (embed_measure M f)"
    by (auto simp: space_embed_measure)
  finally show "g -` A \<inter> space (embed_measure M f) \<in> sets (embed_measure M f)" .
qed (insert measurable_space[OF assms], auto simp: space_embed_measure)

lemma measurable_embed_measure2':
  assumes "inj_on f (space M)"
  shows "f \<in> measurable M (embed_measure M f)"
proof-
  {
    fix A assume A: "A \<in> sets M"
    also from A have "A = A \<inter> space M" by auto
    also have "... = f -` f ` A \<inter> space M" using A assms
      by (auto dest: inj_onD sets.sets_into_space)
    finally have "f -` f ` A \<inter> space M \<in> sets M" .
  }
  thus ?thesis using assms unfolding embed_measure_def
    by (intro measurable_measure_of) (auto dest: sets.sets_into_space)
qed

lemma measurable_embed_measure2:
  assumes [simp]: "inj f" shows "f \<in> measurable M (embed_measure M f)"
  by (auto simp: inj_vimage_image_eq embed_measure_def
           intro!: measurable_measure_of dest: sets.sets_into_space)

lemma embed_measure_eq_distr':
  assumes "inj_on f (space M)"
  shows "embed_measure M f = distr M (embed_measure M f) f"
proof-
  have "distr M (embed_measure M f) f =
            measure_of (f ` space M) {f ` A |A. A \<in> sets M}
                       (\<lambda>A. emeasure M (f -` A \<inter> space M))" unfolding distr_def
      by (simp add: space_embed_measure sets_embed_measure'[OF assms])
  also have "... = embed_measure M f" unfolding embed_measure_def ..
  finally show ?thesis ..
qed

lemma embed_measure_eq_distr:
    "inj f \<Longrightarrow> embed_measure M f = distr M (embed_measure M f) f"
  by (rule embed_measure_eq_distr') (auto intro!: inj_onI dest: injD)

lemma nn_integral_embed_measure':
  "inj_on f (space M) \<Longrightarrow> g \<in> borel_measurable (embed_measure M f) \<Longrightarrow>
  nn_integral (embed_measure M f) g = nn_integral M (\<lambda>x. g (f x))"
  apply (subst embed_measure_eq_distr', simp)
  apply (subst nn_integral_distr)
  apply (simp_all add: measurable_embed_measure2')
  done

lemma nn_integral_embed_measure:
  "inj f \<Longrightarrow> g \<in> borel_measurable (embed_measure M f) \<Longrightarrow>
  nn_integral (embed_measure M f) g = nn_integral M (\<lambda>x. g (f x))"
  by(erule nn_integral_embed_measure'[OF subset_inj_on]) simp

lemma emeasure_embed_measure':
    assumes "inj_on f (space M)" "A \<in> sets (embed_measure M f)"
    shows "emeasure (embed_measure M f) A = emeasure M (f -` A \<inter> space M)"
  by (subst embed_measure_eq_distr'[OF assms(1)])
     (simp add: emeasure_distr[OF measurable_embed_measure2'[OF assms(1)] assms(2)])

lemma emeasure_embed_measure:
    assumes "inj f" "A \<in> sets (embed_measure M f)"
    shows "emeasure (embed_measure M f) A = emeasure M (f -` A \<inter> space M)"
 using assms by (intro emeasure_embed_measure') (auto intro!: inj_onI dest: injD)

lemma embed_measure_comp:
  assumes [simp]: "inj f" "inj g"
  shows "embed_measure (embed_measure M f) g = embed_measure M (g \<circ> f)"
proof-
  have [simp]: "inj (\<lambda>x. g (f x))" by (subst o_def[symmetric]) (auto intro: inj_compose)
  note measurable_embed_measure2[measurable]
  have "embed_measure (embed_measure M f) g =
            distr M (embed_measure (embed_measure M f) g) (g \<circ> f)"
      by (subst (1 2) embed_measure_eq_distr)
         (simp_all add: distr_distr sets_embed_measure cong: distr_cong)
  also have "... = embed_measure M (g \<circ> f)"
      by (subst (3) embed_measure_eq_distr, simp add: o_def, rule distr_cong)
         (auto simp: sets_embed_measure o_def image_image[symmetric]
               intro: inj_compose cong: distr_cong)
  finally show ?thesis .
qed

lemma sigma_finite_embed_measure:
  assumes "sigma_finite_measure M" and inj: "inj f"
  shows "sigma_finite_measure (embed_measure M f)"
proof -
  from assms(1) interpret sigma_finite_measure M .
  from sigma_finite_countable obtain A where
      A_props: "countable A" "A \<subseteq> sets M" "\<Union>A = space M" "\<And>X. X\<in>A \<Longrightarrow> emeasure M X \<noteq> \<infinity>" by blast
  from A_props have "countable ((`) f`A)" by auto
  moreover
  from inj and A_props have "(`) f`A \<subseteq> sets (embed_measure M f)"
    by (auto simp: sets_embed_measure)
  moreover
  from A_props and inj have "\<Union>((`) f`A) = space (embed_measure M f)"
    by (auto simp: space_embed_measure intro!: imageI)
  moreover
  from A_props and inj have "\<forall>a\<in>(`) f ` A. emeasure (embed_measure M f) a \<noteq> \<infinity>"
    by (intro ballI, subst emeasure_embed_measure)
       (auto simp: inj_vimage_image_eq intro: in_sets_embed_measure)
  ultimately show ?thesis by - (standard, blast)
qed

lemma embed_measure_count_space':
    "inj_on f A \<Longrightarrow> embed_measure (count_space A) f = count_space (f`A)"
  apply (subst distr_bij_count_space[of f A "f`A", symmetric])
  apply (simp add: inj_on_def bij_betw_def)
  apply (subst embed_measure_eq_distr')
  apply simp
  apply(auto 4 3 intro!: measure_eqI imageI simp add: sets_embed_measure' subset_image_iff)
  apply (subst (1 2) emeasure_distr)
  apply (auto simp: space_embed_measure sets_embed_measure')
  done

lemma embed_measure_count_space:
    "inj f \<Longrightarrow> embed_measure (count_space A) f = count_space (f`A)"
  by(rule embed_measure_count_space')(erule subset_inj_on, simp)

lemma sets_embed_measure_alt:
    "inj f \<Longrightarrow> sets (embed_measure M f) = ((`) f) ` sets M"
  by (auto simp: sets_embed_measure)

lemma emeasure_embed_measure_image':
  assumes "inj_on f (space M)" "X \<in> sets M"
  shows "emeasure (embed_measure M f) (f`X) = emeasure M X"
proof-
  from assms have "emeasure (embed_measure M f) (f`X) = emeasure M (f -` f ` X \<inter> space M)"
    by (subst emeasure_embed_measure') (auto simp: sets_embed_measure')
  also from assms have "f -` f ` X \<inter> space M = X" by (auto dest: inj_onD sets.sets_into_space)
  finally show ?thesis .
qed

lemma emeasure_embed_measure_image:
    "inj f \<Longrightarrow> X \<in> sets M \<Longrightarrow> emeasure (embed_measure M f) (f`X) = emeasure M X"
  by (simp_all add: emeasure_embed_measure in_sets_embed_measure inj_vimage_image_eq)

lemma embed_measure_eq_iff:
  assumes "inj f"
  shows "embed_measure A f = embed_measure B f \<longleftrightarrow> A = B" (is "?M = ?N \<longleftrightarrow> _")
proof
  from assms have I: "inj ((`) f)" by (auto intro: injI dest: injD)
  assume asm: "?M = ?N"
  hence "sets (embed_measure A f) = sets (embed_measure B f)" by simp
  with assms have "sets A = sets B" by (simp only: I inj_image_eq_iff sets_embed_measure_alt)
  moreover {
    fix X assume "X \<in> sets A"
    from asm have "emeasure ?M (f`X) = emeasure ?N (f`X)" by simp
    with \<open>X \<in> sets A\<close> and \<open>sets A = sets B\<close> and assms
        have "emeasure A X = emeasure B X" by (simp add: emeasure_embed_measure_image)
  }
  ultimately show "A = B" by (rule measure_eqI)
qed simp

lemma the_inv_into_in_Pi: "inj_on f A \<Longrightarrow> the_inv_into A f \<in> f ` A \<rightarrow> A"
  by (auto simp: the_inv_into_f_f)

lemma map_prod_image: "map_prod f g ` (A \<times> B) = (f`A) \<times> (g`B)"
  using map_prod_surj_on[OF refl refl] .

lemma map_prod_vimage: "map_prod f g -` (A \<times> B) = (f-`A) \<times> (g-`B)"
  by auto

lemma embed_measure_prod:
  assumes f: "inj f" and g: "inj g" and [simp]: "sigma_finite_measure M" "sigma_finite_measure N"
  shows "embed_measure M f \<Otimes>\<^sub>M embed_measure N g = embed_measure (M \<Otimes>\<^sub>M N) (\<lambda>(x, y). (f x, g y))"
    (is "?L = _")
  unfolding map_prod_def[symmetric]
proof (rule pair_measure_eqI)
  have fg[simp]: "\<And>A. inj_on (map_prod f g) A" "\<And>A. inj_on f A" "\<And>A. inj_on g A"
    using f g by (auto simp: inj_on_def)

  note complete_lattice_class.Sup_insert[simp del] ccSup_insert[simp del]
     ccSUP_insert[simp del]
  show sets: "sets ?L = sets (embed_measure (M \<Otimes>\<^sub>M N) (map_prod f g))"
    unfolding map_prod_def[symmetric]
    apply (simp add: sets_pair_eq_sets_fst_snd sets_embed_eq_vimage_algebra
      cong: vimage_algebra_cong)
    apply (subst sets_vimage_Sup_eq[where Y="space (M \<Otimes>\<^sub>M N)"])
    apply (simp_all add: space_pair_measure[symmetric])
    apply (auto simp add: the_inv_into_f_f
                simp del: map_prod_simp
                del: prod_fun_imageE) []
    apply auto []
    apply (subst (1 2 3 4 ) vimage_algebra_vimage_algebra_eq)
    apply (simp_all add: the_inv_into_in_Pi Pi_iff[of snd] Pi_iff[of fst] space_pair_measure)
    apply (simp_all add: Pi_iff[of snd] Pi_iff[of fst] the_inv_into_in_Pi vimage_algebra_vimage_algebra_eq
       space_pair_measure[symmetric] map_prod_image[symmetric])
    apply (intro arg_cong[where f=sets] arg_cong[where f=Sup] arg_cong2[where f=insert] vimage_algebra_cong)
    apply (auto simp: map_prod_image the_inv_into_f_f
                simp del: map_prod_simp del: prod_fun_imageE)
    apply (simp_all add: the_inv_into_f_f space_pair_measure)
    done

  note measurable_embed_measure2[measurable]
  fix A B assume AB: "A \<in> sets (embed_measure M f)" "B \<in> sets (embed_measure N g)"
  moreover have "f -` A \<times> g -` B \<inter> space (M \<Otimes>\<^sub>M N) = (f -` A \<inter> space M) \<times> (g -` B \<inter> space N)"
    by (auto simp: space_pair_measure)
  ultimately show "emeasure (embed_measure M f) A * emeasure (embed_measure N g) B =
                     emeasure (embed_measure (M \<Otimes>\<^sub>M N) (map_prod f g)) (A \<times> B)"
    by (simp add: map_prod_vimage sets[symmetric] emeasure_embed_measure
                  sigma_finite_measure.emeasure_pair_measure_Times)
qed (insert assms, simp_all add: sigma_finite_embed_measure)

lemma mono_embed_measure:
  "space M = space M' \<Longrightarrow> sets M \<subseteq> sets M' \<Longrightarrow> sets (embed_measure M f) \<subseteq> sets (embed_measure M' f)"
  unfolding embed_measure_def
  apply (subst (1 2) sets_measure_of)
  apply (blast dest: sets.sets_into_space)
  apply (blast dest: sets.sets_into_space)
  apply simp
  apply (intro sigma_sets_mono')
  apply safe
  apply (simp add: subset_eq)
  apply metis
  done

lemma density_embed_measure:
  assumes inj: "inj f" and Mg[measurable]: "g \<in> borel_measurable (embed_measure M f)"
  shows "density (embed_measure M f) g = embed_measure (density M (g \<circ> f)) f" (is "?M1 = ?M2")
proof (rule measure_eqI)
  fix X assume X: "X \<in> sets ?M1"
  from inj have Mf[measurable]: "f \<in> measurable M (embed_measure M f)"
    by (rule measurable_embed_measure2)
  from Mg and X have "emeasure ?M1 X = \<integral>\<^sup>+ x. g x * indicator X x \<partial>embed_measure M f"
    by (subst emeasure_density) simp_all
  also from X have "... = \<integral>\<^sup>+ x. g (f x) * indicator X (f x) \<partial>M"
    by (subst embed_measure_eq_distr[OF inj], subst nn_integral_distr) auto
  also have "... = \<integral>\<^sup>+ x. g (f x) * indicator (f -` X \<inter> space M) x \<partial>M"
    by (intro nn_integral_cong) (auto split: split_indicator)
  also from X have "... = emeasure (density M (g \<circ> f)) (f -` X \<inter> space M)"
    by (subst emeasure_density) (simp_all add: measurable_comp[OF Mf Mg] measurable_sets[OF Mf])
  also from X and inj have "... = emeasure ?M2 X"
    by (subst emeasure_embed_measure) (simp_all add: sets_embed_measure)
  finally show "emeasure ?M1 X = emeasure ?M2 X" .
qed (simp_all add: sets_embed_measure inj)

lemma density_embed_measure':
  assumes inj: "inj f" and inv: "\<And>x. f' (f x) = x" and Mg[measurable]: "g \<in> borel_measurable M"
  shows "density (embed_measure M f) (g \<circ> f') = embed_measure (density M g) f"
proof-
  have "density (embed_measure M f) (g \<circ> f') = embed_measure (density M (g \<circ> f' \<circ> f)) f"
    by (rule density_embed_measure[OF inj])
       (rule measurable_comp, rule measurable_embed_measure1, subst measurable_cong,
        rule inv, rule measurable_ident_sets, simp, rule Mg)
  also have "density M (g \<circ> f' \<circ> f) = density M g"
    by (intro density_cong) (subst measurable_cong, simp add: o_def inv, simp_all add: Mg inv)
  finally show ?thesis .
qed

lemma inj_on_image_subset_iff:
  assumes "inj_on f C" "A \<subseteq> C"  "B \<subseteq> C"
  shows "f ` A \<subseteq> f ` B \<longleftrightarrow> A \<subseteq> B"
proof (intro iffI subsetI)
  fix x assume A: "f ` A \<subseteq> f ` B" and B: "x \<in> A"
  from B have "f x \<in> f ` A" by blast
  with A have "f x \<in> f ` B" by blast
  then obtain y where "f x = f y" and "y \<in> B" by blast
  with assms and B have "x = y" by (auto dest: inj_onD)
  with \<open>y \<in> B\<close> show "x \<in> B" by simp
qed auto

lemma AE_embed_measure':
  assumes inj: "inj_on f (space M)"
  shows "(AE x in embed_measure M f. P x) \<longleftrightarrow> (AE x in M. P (f x))"
proof
  let ?M = "embed_measure M f"
  assume "AE x in ?M. P x"
  then obtain A where A_props: "A \<in> sets ?M" "emeasure ?M A = 0" "{x\<in>space ?M. \<not>P x} \<subseteq> A"
    by (force elim: AE_E)
  then obtain A' where A'_props: "A = f ` A'" "A' \<in> sets M" by (auto simp: sets_embed_measure' inj)
  moreover have B: "{x\<in>space ?M. \<not>P x} = f ` {x\<in>space M. \<not>P (f x)}"
    by (auto simp: inj space_embed_measure)
  from A_props(3) have "{x\<in>space M. \<not>P (f x)} \<subseteq> A'"
    by (subst (asm) B, subst (asm) A'_props, subst (asm) inj_on_image_subset_iff[OF inj])
       (insert A'_props, auto dest: sets.sets_into_space)
  moreover from A_props A'_props have "emeasure M A' = 0"
    by (simp add: emeasure_embed_measure_image' inj)
  ultimately show "AE x in M. P (f x)" by (intro AE_I)
next
  let ?M = "embed_measure M f"
  assume "AE x in M. P (f x)"
  then obtain A where A_props: "A \<in> sets M" "emeasure M A = 0" "{x\<in>space M. \<not>P (f x)} \<subseteq> A"
    by (force elim: AE_E)
  hence "f`A \<in> sets ?M" "emeasure ?M (f`A) = 0" "{x\<in>space ?M. \<not>P x} \<subseteq> f`A"
    by (auto simp: space_embed_measure emeasure_embed_measure_image' sets_embed_measure' inj)
  thus "AE x in ?M. P x" by (intro AE_I)
qed

lemma AE_embed_measure:
  assumes inj: "inj f"
  shows "(AE x in embed_measure M f. P x) \<longleftrightarrow> (AE x in M. P (f x))"
  using assms by (intro AE_embed_measure') (auto intro!: inj_onI dest: injD)

lemma nn_integral_monotone_convergence_SUP_countable:
  fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> ennreal"
  assumes nonempty: "Y \<noteq> {}"
  and chain: "Complete_Partial_Order.chain (\<le>) (f ` Y)"
  and countable: "countable B"
  shows "(\<integral>\<^sup>+ x. (SUP i\<in>Y. f i x) \<partial>count_space B) = (SUP i\<in>Y. (\<integral>\<^sup>+ x. f i x \<partial>count_space B))"
  (is "?lhs = ?rhs")
proof -
  let ?f = "(\<lambda>i x. f i (from_nat_into B x) * indicator (to_nat_on B ` B) x)"
  have "?lhs = \<integral>\<^sup>+ x. (SUP i\<in>Y. f i (from_nat_into B (to_nat_on B x))) \<partial>count_space B"
    by(rule nn_integral_cong)(simp add: countable)
  also have "\<dots> = \<integral>\<^sup>+ x. (SUP i\<in>Y. f i (from_nat_into B x)) \<partial>count_space (to_nat_on B ` B)"
    by(simp add: embed_measure_count_space'[symmetric] inj_on_to_nat_on countable nn_integral_embed_measure' measurable_embed_measure1)
  also have "\<dots> = \<integral>\<^sup>+ x. (SUP i\<in>Y. ?f i x) \<partial>count_space UNIV"
    by(simp add: nn_integral_count_space_indicator ennreal_indicator[symmetric] SUP_mult_right_ennreal nonempty)
  also have "\<dots> = (SUP i\<in>Y. \<integral>\<^sup>+ x. ?f i x \<partial>count_space UNIV)"
  proof(rule nn_integral_monotone_convergence_SUP_nat)
    show "Complete_Partial_Order.chain (\<le>) (?f ` Y)"
      by(rule chain_imageI[OF chain, unfolded image_image])(auto intro!: le_funI split: split_indicator dest: le_funD)
  qed fact
  also have "\<dots> = (SUP i\<in>Y. \<integral>\<^sup>+ x. f i (from_nat_into B x) \<partial>count_space (to_nat_on B ` B))"
    by(simp add: nn_integral_count_space_indicator)
  also have "\<dots> = (SUP i\<in>Y. \<integral>\<^sup>+ x. f i (from_nat_into B (to_nat_on B x)) \<partial>count_space B)"
    by(simp add: embed_measure_count_space'[symmetric] inj_on_to_nat_on countable nn_integral_embed_measure' measurable_embed_measure1)
  also have "\<dots> = ?rhs"
    by(intro arg_cong2[where f = "\<lambda>A f. Sup (f ` A)"] ext nn_integral_cong_AE)(simp_all add: AE_count_space countable)
  finally show ?thesis .
qed

end