(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

section \<open>Formalization of the Crowds-Protocol\<close>

theory Crowds_Protocol
  imports "../Discrete_Time_Markov_Chain"
begin

lemma cond_prob_nonneg[simp]: "0 \<le> cond_prob M A B"
  by (auto simp: cond_prob_def)

lemma (in MC_syntax) emeasure_suntil_geometric:
  assumes [measurable]: "Measurable.pred S P"
  assumes "s \<in> X" and *[simp]: "0 \<le> p" "0 \<le> r"
  assumes r: "\<And>s. s \<in> X \<Longrightarrow> emeasure (T s) {\<omega>\<in>space (T s). P \<omega>} = ennreal r"
  assumes p: "\<And>s. s \<in> X \<Longrightarrow> emeasure (K s) X = ennreal p" "p < 1"
  assumes "\<And>t. AE \<omega> in T t. \<not> (P \<sqinter> (HLD X \<sqinter> nxt (HLD X suntil P))) \<omega>"
  shows "emeasure (T s) {\<omega>\<in>space (T s). (HLD X suntil P) \<omega>} = r / (1 - p)"
proof (subst emeasure_suntil_disj)
  let ?F = "\<lambda>F s. emeasure (T s) {\<omega> \<in> space (T s). P \<omega>} + \<integral>\<^sup>+ t. F t * indicator X t \<partial>K s"
  let ?f = "\<lambda>x. ennreal r + ennreal p * x"

  have "mono ?F" "mono ?f"
    by (auto intro!: monoI max.mono add_mono nn_integral_mono mult_left_mono mult_right_mono simp: le_fun_def)

  have 1: "lfp ?f \<le> lfp ?F s"
    using \<open>s \<in> X\<close>
  proof (induction arbitrary: s rule: lfp_ordinal_induct[OF \<open>mono ?f\<close>])
    case step: (1 x)
    then have "?f x \<le> ?F (\<lambda>_. x) s"
      by (auto simp: p r[simplified] nn_integral_cmult mult.commute[of _ x]
               intro!: add_mono mult_right_mono)
    also have "?F (\<lambda>_. x) \<le> ?F (lfp ?F)"
      using step
      by (intro le_funI add_mono order_refl nn_integral_mono) (auto simp: split: split_indicator)
    finally show ?case
      by (subst lfp_unfold[OF \<open>mono ?F\<close>]) (auto simp: le_fun_def)
  qed (auto intro!: Sup_least)
  also have 2: "lfp ?F s \<le> r / (1 - p)"
    using \<open>s \<in> X\<close>
  proof (induction arbitrary: s rule: lfp_ordinal_induct[OF \<open>mono ?F\<close>])
    case (1 S)
    with r have "?F S s \<le> ennreal r + (\<integral>\<^sup>+x. ennreal (r / (1 - p)) * indicator X x \<partial>K s)"
      by (intro add_mono nn_integral_mono) (auto split: split_indicator)
    also have "\<dots> \<le> ennreal r + ennreal (r * p / (1 - p))"
      using \<open>s \<in> X\<close> by (simp add: nn_integral_cmult_indicator p ennreal_mult''[symmetric])
    also have "\<dots> = ennreal (r / (1 - p))"
      using \<open>p < 1\<close> by (simp add: field_simps ennreal_plus[symmetric] del: ennreal_plus)
    finally show ?case .
  qed (auto intro!: SUP_least)
  finally obtain x where x: "lfp ?f = ennreal x" and [simp]: "0 \<le> x"
    by (cases "lfp ?f") (auto simp: top_unique)
  from \<open>p < 1\<close> have "\<And>x. x = r + p * x \<Longrightarrow> x = r / (1 - p)"
    by (auto simp: field_simps)
  with lfp_unfold[OF \<open>mono ?f\<close>] \<open>p < 1\<close> have "lfp ?f = r / (1 - p)"
    unfolding x by (auto simp add: ennreal_plus[symmetric] ennreal_mult[symmetric] simp del: ennreal_plus)
  with 1 2 show "lfp ?F s = ennreal (r / (1 - p))"
    by auto
qed fact+

subsection \<open>Definition of the Crowds-Protocol\<close>

datatype 'a state = Start | Init 'a | Mix 'a | End

lemma inj_Mix[simp]: "inj_on Mix A"
  by (auto intro: inj_onI)

lemma inj_Init[simp]: "inj_on Init A"
  by (auto intro: inj_onI)

lemma distinct_state_image[simp]:
  "Start \<notin> Mix ` A" "Init j \<notin> Mix ` A" "End \<notin> Mix ` A" "Mix j \<in> Mix ` A \<longleftrightarrow> j \<in> A"
  "Start \<notin> Init ` A" "Mix j \<notin> Init ` A" "End \<notin> Init ` A" "Init j \<in> Init ` A \<longleftrightarrow> j \<in> A"
  by auto

lemma Init_cut_Mix[simp]:
  "Init ` H \<inter> Mix ` J = {}"
  by auto

abbreviation "Jondo B \<equiv> Init`B \<union> Mix`B"

locale Crowds_Protocol =
  fixes J :: "'a set" and C :: "'a set" and p_f :: real and p_i :: "'a \<Rightarrow> real"
  assumes J_not_empty: "J \<noteq> {}" and finite_J[simp]: "finite J"
  assumes C_smaller: "C \<subset> J" and C_non_empty: "C \<noteq> {}"
  assumes p_f: "0 < p_f" "p_f < 1"
  assumes p_i_nonneg[simp]: "\<And>j. j \<in> J \<Longrightarrow> 0 \<le> p_i j"
  assumes p_i_distr: "(\<Sum>j\<in>J. p_i j) = 1"
  assumes p_i_C: "\<And>j. j \<in> C \<Longrightarrow> p_i j = 0"
begin

abbreviation H :: "'a set" where
  "H \<equiv> J - C"

definition "p_j = 1 / card J"

lemma p_f_nonneg[simp]: "0 \<le> p_f" "p_f \<le> 1"
  using p_f by simp_all

lemma p_j_nonneg[simp]: "0 \<le> p_j"
  by (simp add: p_j_def)

definition "p_H = card H / card J"

lemma p_H_nonneg[simp]: "0 \<le> p_H" "p_H \<le> 1"
  by (auto simp: p_H_def divide_le_eq_1 card_gt_0_iff intro!: card_mono )

definition next_prob :: "'a state \<Rightarrow> 'a state \<Rightarrow> real" where
  "next_prob s t = (case (s, t) of (Start, Init j) \<Rightarrow> if j \<in> H then p_i j else 0
                                 | (Init j, Mix j') \<Rightarrow> if j' \<in> J then p_j else 0
                                 | (Mix j, Mix j') \<Rightarrow> if j' \<in> J then p_f * p_j else 0
                                 | (Mix j, End) \<Rightarrow> 1 - p_f
                                 | (End, End) \<Rightarrow> 1
                                 | _ \<Rightarrow> 0)"

definition "N s = embed_pmf (next_prob s)"

interpretation MC_syntax N .

abbreviation "\<PP> \<equiv> T Start"

abbreviation "E s \<equiv> set_pmf (N s)"

lemma finite_C[simp]: "finite C"
  using C_smaller finite_J by (blast intro: finite_subset)

lemma sum_p_i_C[simp]: "sum p_i C = 0"
  by (auto intro: sum.neutral p_i_C)

lemma sum_p_i_H[simp]: "sum p_i H = 1"
  using C_smaller by (simp add: sum_diff p_i_distr)

lemma possible_jondo:
  obtains j where "j \<in> J" "j \<notin> C" "p_i j \<noteq> 0"
proof (atomize_elim, rule ccontr)
  assume "\<not> (\<exists>j. j \<in> J \<and> j \<notin> C \<and> p_i j \<noteq> 0)"
  with p_i_C have "\<forall>j\<in>J. p_i j = 0"
    by auto
  with p_i_distr show False
    by simp
qed

lemma C_le_J[simp]: "card C < card J"
  using C_smaller
  by (intro psubset_card_mono) auto

lemma p_H: "0 < p_H" "p_H < 1"
  using J_not_empty C_smaller C_non_empty
  by (simp_all add: p_H_def card_Diff_subset card_mono field_simps zero_less_divide_iff card_gt_0_iff)

lemma p_H_p_f_pos: "0 < p_H * p_f"
  using p_f p_H by (simp add: zero_less_mult_iff)

lemma p_H_p_f_less_1: "p_H * p_f < 1"
proof -
  have "p_H * p_f < 1 * 1"
    using p_H p_f by (intro mult_strict_mono) auto
  then show "p_H * p_f < 1" by simp
qed

lemma p_j_pos: "0 < p_j"
  unfolding p_j_def using J_not_empty by auto

lemma H_compl: "1 - p_H = real (card C) / real (card J)"
  using C_non_empty J_not_empty C_smaller
  by (simp add: p_H_def card_Diff_subset card_mono of_nat_diff divide_eq_eq field_simps)

lemma H_compl2: "1 - p_H = card C * p_j"
  unfolding H_compl p_j_def by simp

lemma H_eq2: "card H * p_j = p_H"
  unfolding p_j_def p_H_def by simp

lemma pmf_next_pmf[simp]: "pmf (N s) t = next_prob s t"
  unfolding N_def
proof (rule pmf_embed_pmf)
  show "\<And>x. 0 \<le> next_prob s x"
    using p_j_pos p_f by (auto simp: next_prob_def intro: p_i_nonneg split: state.split)
  show "(\<integral>\<^sup>+ x. ennreal (next_prob s x) \<partial>count_space UNIV) = 1"
    using p_f J_not_empty
    by (subst nn_integral_count_space'[where A="Init`H \<union> Mix`J \<union> {End}"])
       (auto simp: next_prob_def sum.reindex sum.union_disjoint p_i_distr p_j_def
             split: state.split)
qed

lemma next_prob_Start[simp]: "next_prob Start (Init j) = (if j \<in> H then p_i j else 0)"
  by (auto simp: next_prob_def)

lemma next_prob_to_Init[simp]: "j \<in> H \<Longrightarrow> next_prob s (Init j) =
    (case s of Start \<Rightarrow> p_i j | _ \<Rightarrow> 0)"
  by (cases s) (auto simp: next_prob_def)

lemma next_prob_to_Mix[simp]: "j \<in> J \<Longrightarrow> next_prob s (Mix j) =
    (case s of Init j \<Rightarrow> p_j | Mix j \<Rightarrow> p_f * p_j | _ \<Rightarrow> 0)"
  by (cases s) (auto simp: next_prob_def)

lemma next_prob_to_End[simp]: "next_prob s End =
    (case s of Mix j \<Rightarrow> 1 - p_f | End \<Rightarrow> 1 | _ \<Rightarrow> 0)"
  by (cases s) (auto simp: next_prob_def)

lemma next_prob_Mix_MixI: "\<exists>j. s = Mix j \<Longrightarrow> \<exists>j\<in>J. s' = Mix j \<Longrightarrow> next_prob s s' = p_f * p_j"
  by (cases s) auto

lemma E_Start: "E Start = {Init j | j. j \<in> H \<and> p_i j \<noteq> 0 }"
  using p_i_C by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma E_Init: "E (Init j) = {Mix j | j. j \<in> J }"
  using p_j_pos C_smaller by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma E_Mix: "E (Mix j) = {Mix j | j. j \<in> J } \<union> {End}"
  using p_j_pos p_f by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma E_End: "E End = {End}"
  by (auto simp: set_pmf_iff next_prob_def split: state.splits if_split_asm)

lemma enabled_End:
  "enabled End \<omega> \<longleftrightarrow> \<omega> = sconst End"
proof safe
  assume "enabled End \<omega>" then show "\<omega> = sconst End"
  proof (coinduction arbitrary: \<omega>)
    case Eq_stream then show ?case
      by (auto simp: enabled.simps[of _ \<omega>] E_End)
  qed
next
  show "enabled End (sconst End)"
    by coinduction (simp add: E_End)
qed

lemma AE_End: "(AE \<omega> in T End. P \<omega>) \<longleftrightarrow> P (sconst End)"
proof -
  have "(AE \<omega> in T End. P \<omega>) \<longleftrightarrow> (AE \<omega> in T End. P \<omega> \<and> \<omega> = sconst End)"
    using AE_T_enabled[of End] by (simp add: enabled_End)
  also have "\<dots> = (AE \<omega> in T End. P (sconst End) \<and> \<omega> = sconst End)"
    by (simp add: enabled_End del: AE_conj_iff cong: rev_conj_cong)
  also have "\<dots> = (AE \<omega> in T End. P (sconst End))"
    using AE_T_enabled[of End] by (simp add: enabled_End)
  finally show ?thesis
    by simp
qed

lemma emeasure_Init_eq_Mix:
  assumes [measurable]: "Measurable.pred S P"
  assumes AE_End: "AE x in T End. \<not> P (End ## x)"
  shows "emeasure (T (Init j)) {x\<in>space (T (Init j)). P x} =
    emeasure (T (Mix j)) {x\<in>space (T (Mix j)). P x} / p_f"
proof -
  have *: "{Mix j | j. j \<in> J } = Mix ` J"
    by auto
  show ?thesis
    using emeasure_eq_0_AE[OF AE_End] p_f
    apply (subst (1 2) emeasure_Collect_T)
    apply simp
    apply (subst (1 2) nn_integral_measure_pmf_finite)
    apply (auto simp: E_Mix E_Init * sum.reindex sum_distrib_right[symmetric] divide_ennreal
      ennreal_times_divide[symmetric])
    done
qed

text \<open>

What is the probability that the server sees a specific jondo (including the initiator) as sender.

\<close>

definition visit :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a state stream \<Rightarrow> bool" where
  "visit I L = Init`(I \<inter> H) \<cdot> (HLD (Mix`J) suntil (Mix`(L \<inter> J) \<cdot> HLD {End}))"

lemma visit_unique1:
  "visit I1 L1 \<omega> \<Longrightarrow> visit I2 L2 \<omega> \<Longrightarrow> I1 \<inter> I2 \<noteq> {}"
  by (auto simp: visit_def HLD_iff)

lemma visit_unique2:
  assumes "visit I1 L1 \<omega>" "visit I2 L2 \<omega>"
  shows "L1 \<inter> L2 \<noteq> {}"
proof -
  let ?U = "\<lambda>L \<omega>. (HLD (Mix`J) suntil ((Mix`(L\<inter>J)) \<cdot> HLD {End})) \<omega>"
  have "?U L1 (stl \<omega>)" "?U L2 (stl \<omega>)"
    using assms by (auto simp: visit_def)
  then show "L1 \<inter> L2 \<noteq> {}"
  proof (induction "stl \<omega>" arbitrary: \<omega> rule: suntil_induct_strong)
    case base then show ?case
      by (auto simp add: suntil.simps[of _ _ "stl (stl \<omega>)"] suntil.simps[of _ _ "stl \<omega>"] HLD_iff)
  next
    case step
    show ?case
    proof cases
      assume "((Mix`(L2\<inter>J)) \<cdot> HLD {End}) (stl \<omega>)"
      with step.hyps show ?thesis
        by (auto simp: inj_Mix HLD_iff elim: suntil.cases)
    next
      assume "\<not> ((Mix`(L2\<inter>J)) \<cdot> HLD {End}) (stl \<omega>)"
      with step.prems have "?U L2 (stl (stl \<omega>))"
        by (auto elim: suntil.cases)
      then show ?thesis
        by (rule step.hyps(4)[OF refl])
    qed
  qed
qed

lemma visit_imp_in_H: "visit {i} J \<omega> \<Longrightarrow> i \<in> H"
  by (auto simp: visit_def HLD_iff)

lemma emeasure_visit:
  assumes I: "I \<subseteq> H" and L: "L \<subseteq> J"
  shows "emeasure \<PP> {\<omega>\<in>space \<PP>. visit I L \<omega>} = (\<Sum>i\<in>I. p_i i) * (card L * p_j)"
proof -
  let ?J = "HLD (Mix`J)" and ?E = "(Mix`L) \<cdot> HLD {End}"
  let ?\<phi> = "?J aand not ?E"
  let ?P = "\<lambda>x P. emeasure (T x) {\<omega>\<in>space (T x). P \<omega>}"

  have [intro]: "finite L"
    using finite_J \<open>L \<subseteq> J\<close> by (blast intro: finite_subset)
  have [simp, intro]: "finite I"
    using finite_J \<open>I \<subseteq> H\<close> by (blast intro: finite_subset)

  { fix j assume j: "j \<in> H"
    have "?P (Mix j) (?J suntil ?E) = (p_f * p_j * (1 - p_f) * card L) / (1 - p_f)"
    proof (rule emeasure_suntil_geometric)
      fix s assume s: "s \<in> Mix ` J"
      then have "?P s ?E = (\<integral>\<^sup>+x. ennreal (1 - p_f) * indicator (Mix`L) x \<partial>N s)"
        by (auto simp add: emeasure_HLD_nxt emeasure_HLD AE_measure_pmf_iff emeasure_pmf_single
                 split: state.split split_indicator simp del: space_T nxt.simps
                 intro!: nn_integral_cong_AE)
      also have "\<dots> = ennreal (1 - p_f) * emeasure (N s) (Mix`L)"
        using p_f by (intro nn_integral_cmult_indicator) auto
      also have "\<dots> = ennreal ((1 - p_f) * card L * p_j * p_f)"
        using s assms
        by (subst emeasure_measure_pmf_finite)
           (auto simp: sum.reindex subset_eq ennreal_mult mult_ac)
      finally show "?P s ?E = p_f * p_j * (1 - p_f) * card L"
        by simp
    next
      show "\<And>t. AE \<omega> in T  t. \<not> (?E \<sqinter> (?J \<sqinter> nxt (?J suntil ?E))) \<omega>"
        by (intro AE_I2) (auto simp: HLD_iff elim: suntil.cases)
    qed (insert p_f j, auto simp: emeasure_measure_pmf_finite sum.reindex p_j_def)
    then have "?P (Init j) (?J suntil ?E) = (p_f * p_j * (1 - p_f) * card L) / (1 - p_f) / p_f"
      by (subst emeasure_Init_eq_Mix) (simp_all add:  suntil.simps[of _ _ "x ## s" for x s] divide_ennreal p_f)
    then have "?P (Init j) (?J suntil ?E) = p_j * card L"
      using p_f by simp }
  note J_suntil_E = this

  have "?P Start (visit I L) = (\<integral>\<^sup>+x. ?P x (?J suntil ?E) * indicator (Init`I) x \<partial>N Start)"
    unfolding visit_def using I L by (subst emeasure_HLD_nxt) (auto simp: Int_absorb2)
  also have "\<dots> = (\<integral>\<^sup>+x. ennreal (p_j * card L) * indicator (Init`I) x \<partial>N Start)"
    using I J_suntil_E
    by (intro nn_integral_cong ennreal_mult_right_cong)
       (auto split: split_indicator_asm)
  also have "\<dots> = ennreal ((\<Sum>i\<in>I. p_i i) * card L * p_j)"
    using p_j_pos assms
    by (subst nn_integral_cmult_indicator)
       (auto simp: emeasure_measure_pmf_finite sum.reindex subset_eq ennreal_mult[symmetric] sum_nonneg)
  finally show ?thesis by (simp add: ac_simps)
qed

lemma measurable_visit[measurable]: "Measurable.pred S (visit I L)"
  by (simp add: visit_def)

lemma AE_visit: "AE \<omega> in \<PP>. visit H J \<omega>"
proof (rule T.AE_I_eq_1)
  show "emeasure \<PP> {\<omega>\<in>space \<PP>. visit H J \<omega>} = 1"
    using J_not_empty by (subst emeasure_visit ) (simp_all add: p_j_def)
qed simp

subsection \<open>Server gets no information\<close>

lemma server_view1: "j \<in> J \<Longrightarrow> \<P>(\<omega> in \<PP>. visit H {j} \<omega>) = p_j"
  unfolding measure_def by (subst emeasure_visit) simp_all

lemma server_view_indep:
  "L \<subseteq> J \<Longrightarrow> I \<subseteq> H \<Longrightarrow> \<P>(\<omega> in \<PP>. visit I L \<omega>) = \<P>(\<omega> in \<PP>. visit H L \<omega>) * \<P>(\<omega> in \<PP>. visit I J \<omega>)"
  unfolding measure_def
  by (subst (1 2 3) emeasure_visit) (auto simp: p_j_def sum_nonneg subset_eq)

lemma server_view: "\<P>(\<omega> in \<PP>. \<exists>j\<in>H. visit {j} {j} \<omega>) = p_j"
  using finite_J
proof (subst T.prob_sum[where I="H" and P="\<lambda>j. visit {j} {j}"])
  show "(\<Sum>j\<in>H. \<P>(\<omega> in \<PP>. visit {j} {j} \<omega>)) = p_j"
    by (auto simp: measure_def emeasure_visit sum_distrib_right[symmetric] simp del: space_T sets_T)
  show "AE x in \<PP>. (\<forall>n\<in>H. visit {n} {n} x \<longrightarrow> (\<exists>j\<in>H. visit {j} {j} x)) \<and>
                ((\<exists>j\<in>H. visit {j} {j} x) \<longrightarrow> (\<exists>!n. n \<in> H \<and> visit {n} {n} x))"
    by (auto dest: visit_unique1)
qed simp_all

subsection \<open>Probability that collaborators gain information\<close>

definition "hit_C = Init`H \<cdot> ev (HLD (Mix`C))"
definition "before_C B = (HLD (Jondo H)) suntil ((Jondo (B \<inter> H)) \<cdot> HLD (Mix ` C))"

lemma measurable_hit_C[measurable]: "Measurable.pred S hit_C"
  by (simp add: hit_C_def)

lemma measurable_before_C[measurable]: "Measurable.pred S (before_C B)"
  by (simp add: before_C_def)

lemma before_C:
  assumes \<omega>: "enabled Start \<omega>"
  shows "before_C B \<omega> \<longleftrightarrow>
    ((Init`H \<cdot> (HLD (Mix`H) suntil (Mix`(B \<inter> H) \<cdot> HLD (Mix`C)))) or (Init`(B \<inter> H) \<cdot> HLD (Mix`C))) \<omega>"
proof -
  { fix \<omega> s assume "((HLD (Jondo H)) suntil (Jondo (B \<inter> H) \<cdot> HLD (Mix ` C))) \<omega>"
      "enabled s \<omega>" "s \<in> Jondo H"
    then have "(HLD (Mix ` H) suntil (Mix ` (B \<inter> H) \<cdot> (HLD (Mix ` C)))) \<omega>"
    proof (induction arbitrary: s)
      case (base \<omega>) then show ?case
        by (auto simp: HLD_iff enabled.simps[of _ \<omega>] E_Init E_Mix intro!: suntil.intros(1))
    next
      case (step \<omega>) from step.prems step.hyps step.IH[of "shd \<omega>"] show ?case
        by (auto simp: HLD_iff enabled.simps[of _ \<omega>] E_Init E_Mix
                       suntil.simps[of _ _ \<omega>] enabled_End suntil_sconst)
    qed }
  note this[of "stl \<omega>" "shd \<omega>"]
  moreover
  { fix \<omega> s assume "(HLD (Mix ` H) suntil (Mix ` (B \<inter> H) \<cdot> (HLD (Mix ` C)))) \<omega>"
      "enabled s \<omega>" "s \<in> Jondo H"
    then have "((HLD (Jondo H)) suntil ((Jondo (B \<inter> H)) \<cdot> HLD (Mix ` C))) \<omega>"
    proof (induction arbitrary: s)
      case (step \<omega>) from step.prems step.hyps step.IH[of "shd \<omega>"] show ?case
        by (auto simp: HLD_iff enabled.simps[of _ \<omega>] E_Init E_Mix
                       suntil.simps[of _ _ \<omega>] enabled_End suntil_sconst)
    qed (auto intro: suntil.intros simp: HLD_iff) }
  note this[of "stl \<omega>" "shd \<omega>"]
  ultimately show ?thesis
    using assms
    using \<open>enabled Start \<omega>\<close>
    unfolding before_C_def suntil.simps[of _ _ \<omega>] enabled.simps[of _ \<omega>]
    by (auto simp: E_Start HLD_iff)
qed

lemma before_C_unique:
  assumes \<omega>: "before_C I1 \<omega>" "before_C I2 \<omega>" shows "I1 \<inter> I2 \<noteq> {}"
  using \<omega> unfolding before_C_def
proof induction
  case (base \<omega>) then show ?case
    by (auto simp add: suntil.simps[of _ _ \<omega>] suntil.simps[of _ _ "stl \<omega>"] HLD_iff)
next
  case (step \<omega>) then show ?case
    by (auto simp add: suntil.simps[of _ _ \<omega>] suntil.simps[of _ _ "stl \<omega>"] HLD_iff)
qed

lemma hit_C_imp_before_C:
  assumes "enabled Start \<omega>" "hit_C \<omega>" shows "before_C H \<omega>"
proof -
  let ?X = "Init`H \<union> Mix`H"
  { fix \<omega> s assume "ev (HLD (Mix`C)) \<omega>" "s\<in>?X" "enabled s \<omega>"
    then have "((HLD (Jondo H)) suntil (?X \<cdot> HLD (Mix ` C))) (s ## \<omega>)"
    proof (induction arbitrary: s rule: ev_induct_strong)
      case (step \<omega> s) from step.IH[of "shd \<omega>"] step.prems step.hyps show ?case
        by (auto simp: enabled.simps[of _ \<omega>] suntil_Stream E_Init E_Mix HLD_iff
          enabled_End ev_sconst)
    qed (auto simp: suntil_Stream) }
  from this[of "stl \<omega>" "shd \<omega>"] assms show ?thesis
    by (auto simp: before_C_def hit_C_def enabled.simps[of _ \<omega>] E_Start)
qed

lemma before_C_single:
  assumes "before_C I \<omega>" shows "\<exists>i\<in>I \<inter> H. before_C {i} \<omega>"
  using assms unfolding before_C_def by induction (auto simp: HLD_iff intro: suntil.intros)

lemma before_C_imp_in_H: "before_C {i} \<omega> \<Longrightarrow> i \<in> H"
  by (auto dest: before_C_single)

subsection \<open>The probability that the sender hits a collaborator\<close>

lemma Pr_hit_C: "\<P>(\<omega> in \<PP>. hit_C \<omega>) = (1 - p_H) / (1 - p_H * p_f)"
proof -
  let ?P = "\<lambda>x P. emeasure (T x) {\<omega>\<in>space (T x). P \<omega>}"
  let ?M = "HLD (Mix ` C)" and ?I = "Init`H" and ?J = "Mix`H"
  let ?\<phi> = "(HLD ?J) aand not ?M"

  { fix s assume s: "s \<in> Jondo J"
    have "AE \<omega> in T s. ev ?M \<omega> \<longleftrightarrow> (HLD ?J suntil ?M) \<omega>"
      using AE_T_enabled
    proof eventually_elim
      fix \<omega> assume \<omega>: "enabled s \<omega>"
      show "ev ?M \<omega> \<longleftrightarrow> (HLD ?J suntil ?M) \<omega>"
      proof
        assume "ev ?M \<omega>"
        from this \<omega> s show "(HLD ?J suntil ?M) \<omega>"
        proof (induct arbitrary: s rule: ev_induct_strong)
          case (step \<omega>) then show ?case
            by (auto simp: HLD_iff enabled.simps[of _ \<omega>] suntil.simps[of _ _ \<omega>] E_End E_Init E_Mix
                           enabled_End ev_sconst)
        qed (auto simp: HLD_iff E_Init intro: suntil.intros)
      qed (rule ev_suntil)
    qed }
  note ev_eq_suntil = this

  have "?P Start hit_C = (\<integral>\<^sup>+x. ?P x (ev ?M) * indicator ?I x \<partial>N Start)"
    unfolding hit_C_def by (rule emeasure_HLD_nxt) measurable
  also have "\<dots> = (\<integral>\<^sup>+x. ennreal ((1 - p_H) / (1 - p_f * p_H)) * indicator ?I x \<partial>N Start)"
  proof (intro nn_integral_cong ennreal_mult_right_cong refl)
    fix x assume "indicator (Init ` H) x \<noteq> 0"
    then have "x \<in> ?I"
      by (auto split: split_indicator_asm)
    { fix j assume j: "j \<in> H"
      with ev_eq_suntil[of "Mix j"] have "?P (Mix j) (ev ?M) = ?P (Mix j) ((HLD ?J) suntil ?M)"
        by (intro emeasure_eq_AE) auto
      also have "\<dots> = (((1 - p_H) * p_f)) / (1 - p_H * p_f)"
      proof (rule emeasure_suntil_geometric)
        fix s assume s: "s \<in> Mix ` H"
        from s C_smaller show "?P s ?M = ennreal ((1 - p_H) * p_f)"
          by (subst emeasure_HLD)
             (auto simp add: emeasure_measure_pmf_finite sum.reindex subset_eq p_j_def H_compl)
        from s show "emeasure (N s) (Mix`H) = p_H * p_f"
          by (auto simp: emeasure_measure_pmf_finite sum.reindex p_H_def p_j_def)
      qed (insert j, auto simp: HLD_iff p_H_p_f_less_1)
      finally have "?P (Init j) (ev ?M) = (1 - p_H) / (1 - p_H * p_f)"
        using p_f
        by (subst emeasure_Init_eq_Mix)
           (auto simp: ev_Stream AE_End ev_sconst HLD_iff mult_le_one divide_ennreal) }
    then show "?P x (ev ?M) = (1 - p_H) / (1 - p_f * p_H)"
      using \<open>x \<in> ?I\<close> by (auto simp: mult_ac)
  qed
  also have "\<dots> = ennreal ((1 - p_H) / (1 - p_H * p_f))"
    using p_j_pos p_H p_H_p_f_less_1
    by (subst nn_integral_cmult_indicator)
       (auto simp: emeasure_measure_pmf_finite sum.reindex subset_eq mult_ac
             intro!: divide_nonneg_nonneg)
  finally show ?thesis
    by (simp add: measure_def mult_le_one)
qed

lemma before_C_imp_hit_C:
  assumes "enabled Start \<omega>" "before_C B \<omega>"
  shows "hit_C \<omega>"
proof -
  { fix \<omega> j assume "((HLD (Jondo H)) suntil (Jondo (B \<inter> H) \<cdot> HLD (Mix ` C))) \<omega>"
      "j \<in> H" "enabled (Mix j) \<omega>"
    then have "ev (HLD (Mix`C)) \<omega>"
    proof (induction arbitrary: j rule: suntil_induct_strong)
      case (step \<omega>) then show ?case
        by (auto simp: enabled.simps[of _ \<omega>] E_Mix enabled_End ev_sconst suntil_sconst HLD_iff)
    qed auto }
  from this[of "stl (stl \<omega>)"] assms show "hit_C \<omega>"
    by (force simp: before_C_def hit_C_def E_Start HLD_iff E_Init
      enabled.simps[of _ \<omega>] ev.simps[of _ \<omega>] suntil.simps[of _ _ \<omega>]
      enabled.simps[of _ "stl \<omega>"] ev.simps[of _ "stl \<omega>"] suntil.simps[of _ _ "stl \<omega>"])
qed

lemma negE: "\<not> P \<Longrightarrow> P \<Longrightarrow> False"
  by blast

lemma Pr_visit_before_C:
  assumes L: "L \<subseteq> H" and I: "I \<subseteq> H"
  shows "\<P>(\<omega> in \<PP>. visit I J \<omega> \<and> before_C L \<omega> \<bar> hit_C \<omega> ) =
    (\<Sum>i\<in>I. p_i i) * card L * p_j * p_f + (\<Sum>i\<in>I \<inter> L. p_i i) * (1 - p_H * p_f)"
proof -
  let ?M = "Mix`H"
  let ?P = "\<lambda>x P. emeasure (T x) {\<omega>\<in>space (T x). P \<omega>}"
  let ?V = "(visit I J aand before_C L) aand hit_C"
  let ?U = "HLD ?M suntil (Mix`L \<cdot> HLD (Mix`C))"
  let ?L = "HLD (Mix`C)"

  have IJ: "x \<in> I \<Longrightarrow> x \<in> J" for x
    using I by auto

  have [simp, intro]: "finite I" "finite L"
    using L I by (auto dest: finite_subset)

  have "?P Start ?V = ?P Start ((Init`I \<cdot> ?U) or (Init`(I \<inter> L) \<cdot> ?L))"
  proof (rule emeasure_Collect_eq_AE)
    show "AE \<omega> in \<PP>. ?V \<omega> \<longleftrightarrow> ((Init`I \<cdot> ?U) or (Init`(I \<inter> L) \<cdot> ?L)) \<omega>"
      using AE_T_enabled AE_visit
    proof eventually_elim
      case (elim \<omega>)
      then show ?case
        using before_C_imp_hit_C[of \<omega> "L"]  before_C[of \<omega> "L"] I L
        by (auto simp: visit_def HLD_iff Int_absorb2)
    qed
    show "Measurable.pred \<PP> ((Init`I \<cdot> ?U) or (Init`(I \<inter> L) \<cdot> ?L))"
      by measurable
  qed measurable
  also have "\<dots> = ?P Start (Init`I \<cdot> ?U) + ?P Start (Init`(I \<inter> L) \<cdot> ?L)"
    using L I
    apply (subst plus_emeasure)
    apply (auto intro!: arg_cong2[where f=emeasure])
    apply (subst (asm) suntil.simps)
    apply (auto simp add: HLD_iff[abs_def] elim: suntil.cases)
    done
  also have "?P Start (Init`(I \<inter> L) \<cdot> ?L) = (\<Sum>i\<in>I\<inter>L. p_i i * (1 - p_H))"
    using L I C_smaller p_j_pos
    apply (subst emeasure_HLD_nxt emeasure_HLD, simp)+
    apply (subst nn_integral_indicator_finite)
    apply (auto simp: emeasure_measure_pmf_finite sum.reindex next_prob_def sum.If_cases
                      Int_absorb2 H_compl2 ennreal_mult[symmetric] sum_nonneg
                      sum_distrib_left[symmetric] sum_distrib_right[symmetric]
                intro!: sum.cong sum_nonneg)
    apply (subst (asm) ennreal_inj)
    apply (auto intro!: mult_nonneg_nonneg sum_nonneg sum.mono_neutral_left elim!: negE)
    done
  also have "?P Start (Init`I \<cdot> ?U) = (\<Sum>i\<in>I. ?P (Init i) ?U * p_i i)"
    using I
    by (subst emeasure_HLD_nxt, simp)
       (auto simp: nn_integral_indicator_finite sum.reindex emeasure_measure_pmf_finite
             intro!: sum.cong[OF refl])
  also have "\<dots> = (\<Sum>i\<in>I. ennreal (p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f)) * p_i i)"
  proof (intro sum.cong refl arg_cong2[where f="(*)"])
    fix i assume "i \<in> I"
    with I have i: "i \<in> H"
      by auto
    have "?P (Mix i) ?U = (p_f * p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f))"
      unfolding before_C_def
    proof (rule emeasure_suntil_geometric[where X="?M"])
      show "Mix i \<in> ?M"
        using i by auto
    next
      fix s assume "s \<in> ?M"
      with p_f p_j_pos L C_smaller[THEN less_imp_le]
      show "?P s (Mix`L \<cdot> (HLD (Mix ` C))) = ennreal (p_f * p_f * (1 - p_H) * p_j * card L)"
        apply (simp add: emeasure_HLD emeasure_HLD_nxt del: nxt.simps space_T)
        apply (subst nn_integral_measure_pmf_support[of "Mix`L"])
        apply (auto simp add: subset_eq emeasure_measure_pmf_finite sum.reindex H_compl p_j_def
          ennreal_mult[symmetric] ennreal_of_nat_eq_real_of_nat)
        done
    next
      fix s assume "s \<in> ?M" then show "emeasure (N s) ?M = ennreal (p_H * p_f)"
        by (auto simp add: emeasure_measure_pmf_finite sum.reindex H_eq2)
    next
      show "AE \<omega> in T t. \<not> ((Mix ` L \<cdot> ?L) \<sqinter> (HLD (Mix ` H) \<sqinter> nxt ?U)) \<omega>" for t
        using L
        apply (simp add: AE_T_iff[of _ t])
        apply (subst AE_T_iff; simp)
        apply (auto simp: HLD_iff suntil_Stream)
        done
    qed (insert L, auto simp: p_H_p_f_less_1 E_Mix)
    then show "?P (Init i) ?U = p_f * (1 - p_H) * p_j * card L / (1 - p_H * p_f)"
      by (subst emeasure_Init_eq_Mix)
         (auto simp: AE_End suntil_Stream divide_ennreal mult_le_one p_f)
  qed
  finally have *: "\<P>(\<omega> in T Start. ?V \<omega>) =
      (p_f * (1 - p_H) * p_j * (card L) / (1 - p_H * p_f)) * (\<Sum>i\<in>I. p_i i) +
      (\<Sum>i\<in>I \<inter> L. p_i i) * (1 - p_H)"
    using sum_nonneg [of "I \<inter> L" p_i]  sum_nonneg [of "I" p_i]
    by (simp add: mult_ac measure_def sum_distrib_right[symmetric] sum_distrib_left[symmetric]
                  sum_divide_distrib[symmetric] IJ ennreal_mult[symmetric]
                  mult_le_one ennreal_plus[symmetric]
             del: ennreal_plus)
  show ?thesis
    unfolding cond_prob_def Pr_hit_C *
    using *
    using p_f p_H p_j_pos p_H_p_f_less_1 by (simp add: divide_simps) (simp add: field_simps)
qed

lemma Pr_visit_eq_before_C:
  "\<P>(\<omega> in \<PP>. \<exists>j\<in>H. visit {j} J \<omega> \<and> before_C {j} \<omega> \<bar> hit_C \<omega> ) = 1 - (p_H - p_j) * p_f"
proof -
  let ?V = "\<lambda>j. visit {j} J aand before_C {j}" and ?H = "hit_C"
  let ?J = "H"
  have "\<P>(\<omega> in \<PP>. (\<exists>j\<in>?J. ?V j \<omega>) \<and> ?H \<omega>) = (\<Sum>j\<in>?J. \<P>(\<omega> in \<PP>. (?V j aand ?H) \<omega>))"
  proof (rule T.prob_sum)
    show "AE \<omega> in \<PP>. (\<forall>j\<in>?J. (?V j aand ?H) \<omega> \<longrightarrow> ((\<exists>j\<in>?J. ?V j \<omega>) \<and> ?H \<omega>)) \<and>
      (((\<exists>j\<in>?J. ?V j \<omega>) \<and> ?H \<omega>) \<longrightarrow> (\<exists>!j. j\<in>?J \<and> (?V j aand ?H) \<omega>))"
      by (auto intro!: AE_I2 dest: visit_unique1)
  qed auto
  then have "\<P>(\<omega> in \<PP>. (\<exists>j\<in>?J. ?V j \<omega>) \<bar> ?H \<omega>) = (\<Sum>j\<in>?J. \<P>(\<omega> in \<PP>. ?V j \<omega> \<bar> ?H \<omega>))"
    by (simp add: cond_prob_def sum_divide_distrib)
  also have "\<dots> = p_j * p_f + (1 - p_H * p_f)"
    by (simp add: Pr_visit_before_C sum_distrib_right[symmetric] sum.distrib)
  finally show ?thesis
    by (simp add: field_simps)
qed

lemma probably_innocent:
  assumes approx: "1 / (2 * (p_H - p_j)) \<le> p_f" and "p_H \<noteq> p_j"
  shows "\<P>(\<omega> in \<PP>. \<exists>j\<in>H. visit {j} J \<omega> \<and> before_C {j} \<omega> \<bar> hit_C \<omega> ) \<le> 1 / 2"
  unfolding Pr_visit_eq_before_C
proof -
  have [simp]: "\<And>n :: nat. 1 \<le> real n \<longleftrightarrow> 1 \<le> n" by auto
  have "0 \<le> p_j" unfolding p_j_def by auto
  then have "1 * p_j \<le> p_H"
    unfolding H_eq2[symmetric] using C_smaller
    by (intro mult_mono) (auto simp: Suc_le_eq card_Diff_subset not_le)
  with \<open>p_H \<noteq> p_j\<close> have "p_j < p_H" by auto
  with approx show "1 - (p_H - p_j) * p_f \<le> 1 / 2"
    by (auto simp add: field_simps divide_le_eq split: if_split_asm)
qed

lemma Pr_before_C:
  assumes L: "L \<subseteq> H"
  shows "\<P>(\<omega> in \<PP>. before_C L \<omega> \<bar> hit_C \<omega> ) =
    card L * p_j * p_f + (\<Sum>l\<in>L. p_i l) * (1 - p_H * p_f)"
proof -
  have "\<P>(\<omega> in \<PP>. before_C L \<omega> \<bar> hit_C \<omega> ) =
    \<P>(\<omega> in \<PP>. visit H J \<omega> \<and> before_C L \<omega> \<bar> hit_C \<omega> )"
    using AE_visit by (auto intro!: T.cond_prob_eq_AE)
  also have "\<dots> = card L * p_j * p_f + (\<Sum>i\<in>L. p_i i) * (1 - p_H * p_f)"
    using L by (subst Pr_visit_before_C[OF L order_refl]) (auto simp: Int_absorb1)
  finally show ?thesis .
qed

lemma P_visit:
  assumes I: "I \<subseteq> H"
  shows "\<P>(\<omega> in \<PP>. visit I J \<omega> \<bar> hit_C \<omega> ) = (\<Sum>i\<in>I. p_i i)"
proof -
  have "\<P>(\<omega> in \<PP>. visit I J \<omega> \<bar> hit_C \<omega> ) =
    \<P>(\<omega> in \<PP>. visit I J \<omega> \<and> before_C H \<omega> \<bar> hit_C \<omega> )"
  proof (rule T.cond_prob_eq_AE)
    show "AE x in \<PP>. hit_C x \<longrightarrow>
                visit I J x = (visit I J x \<and> before_C H x)"
      using AE_T_enabled by eventually_elim (auto intro: hit_C_imp_before_C)
  qed auto
  also have "\<dots> = sum p_i I"
    using I by (subst Pr_visit_before_C[OF order_refl]) (auto simp: Int_absorb2 field_simps p_H_def p_j_def)
  finally show ?thesis .
qed

subsection \<open>Probability space of hitting a collaborator\<close>

definition "hC = uniform_measure \<PP> {\<omega>\<in>space \<PP>. hit_C \<omega>}"

lemma emeasure_hit_C_not_0: "emeasure \<PP> {\<omega> \<in> space \<PP>. hit_C \<omega>} \<noteq> 0"
  using p_H p_H_p_f_less_1 unfolding Pr_hit_C T.emeasure_eq_measure by auto

lemma measurable_hC[measurable (raw)]:
  "A \<in> sets S \<Longrightarrow> A \<in> sets hC"
  "f \<in> measurable M S \<Longrightarrow> f \<in> measurable M hC"
  "g \<in> measurable S M \<Longrightarrow> g \<in> measurable hC M"
  "A \<inter> space S \<in> sets S \<Longrightarrow> A \<inter> space hC \<in> sets S"
  unfolding hC_def uniform_measure_def
  by simp_all

lemma vimage_Int_space_C[simp]:
  "f -` {x} \<inter> space hC = {\<omega>\<in>space S. f \<omega> = x}"
  by (auto simp: hC_def)

sublocale hC: information_space hC 2
proof -
  interpret hC: prob_space hC
    unfolding hC_def
    using emeasure_hit_C_not_0
    by (intro prob_space_uniform_measure) auto
  show "information_space hC 2"
    by standard simp
qed

abbreviation
  mutual_information_Pow_CP ("\<I>'(_ ; _')") where
  "\<I>(X ; Y) \<equiv> hC.mutual_information 2 (count_space (X`space hC)) (count_space (Y`space hC)) X Y"

lemma simple_functionI:
  assumes "finite (range f)"
  assumes [measurable]: "\<And>x. {\<omega>\<in>space S. f \<omega> = x} \<in> sets S"
  shows "simple_function hC f"
  using assms unfolding simple_function_def hC_def
  by (simp add: vimage_def space_stream_space)

subsection \<open>Estimate the information to the collaborators\<close>

lemma measure_hC[simp]:
  assumes A[measurable]: "A \<in> sets S"
  shows "measure hC A = \<P>(\<omega> in \<PP>. \<omega> \<in> A \<bar> hit_C \<omega> )"
  unfolding hC_def cond_prob_def
  using emeasure_hit_C_not_0 A
  by (subst measure_uniform_measure) (simp_all add: T.emeasure_eq_measure Int_def conj_ac)

subsubsection \<open>Setup random variables for mutual information\<close>

definition "first_J \<omega> = (THE i. visit {i} J \<omega>)"

lemma first_J_eq:
  "visit {i} J \<omega> \<Longrightarrow> first_J \<omega> = i"
  unfolding first_J_def by (intro the_equality) (auto dest: visit_unique1)

lemma AE_first_J:
  "AE \<omega> in \<PP>. visit {i} J \<omega> \<longleftrightarrow> first_J \<omega> = i"
  using AE_visit
proof eventually_elim
  fix \<omega> assume "visit H J \<omega>"
  then obtain j where "visit {j} J \<omega>" "j \<in> H"
    by (auto simp: visit_def HLD_iff)
  then show "visit {i} J \<omega> \<longleftrightarrow> first_J \<omega> = i"
    by (auto dest: visit_unique1 first_J_eq)
qed

lemma measurbale_first_J[measurable]: "first_J \<in> measurable S (count_space UNIV)"
  unfolding first_J_def[abs_def]
  by (intro measurable_THE[where I=H])
     (auto dest: visit_imp_in_H visit_unique1 intro: countable_finite)

definition "last_H \<omega> = (THE i. before_C {i} \<omega>)"

lemma measurbale_last_H[measurable]: "last_H \<in> measurable S (count_space UNIV)"
  unfolding last_H_def[abs_def]
  by (intro measurable_THE[where I=H])
     (auto dest: before_C_single before_C_unique intro: countable_finite)

lemma last_H_eq:
  "before_C {i} \<omega> \<Longrightarrow> last_H \<omega> = i"
  unfolding last_H_def by (intro the_equality) (auto dest: before_C_unique)

lemma last_H:
  assumes "enabled Start \<omega>" "hit_C \<omega>"
  shows "before_C {last_H \<omega>} \<omega>" "last_H \<omega> \<in> H"
  by (metis before_C_single hit_C_imp_before_C last_H_eq Int_iff assms)+

lemma AE_last_H:
  "AE \<omega> in \<PP>. hit_C \<omega> \<longrightarrow> before_C {i} \<omega> \<longleftrightarrow> last_H \<omega> = i"
  using AE_T_enabled
proof eventually_elim
  fix \<omega> assume "enabled Start \<omega>" then show "hit_C \<omega> \<longrightarrow> before_C {i} \<omega> = (last_H \<omega> = i)"
    by (auto dest: last_H last_H_eq)
qed

lemma information_flow:
  defines "h \<equiv> real (card H)"
  assumes init_uniform: "\<And>i. i \<in> H \<Longrightarrow> p_i i = 1 / h"
  shows "\<I>(first_J ; last_H) \<le> (1 - (h - 1) * p_j * p_f) * log 2 h"
proof -
  let ?il = "\<lambda>i l. \<P>(\<omega> in \<PP>. visit {i} J \<omega> \<and> before_C {l} \<omega> \<bar> hit_C \<omega> )"
  let ?i = "\<lambda>i. \<P>(\<omega> in \<PP>. visit {i} J \<omega> \<bar> hit_C \<omega> )"
  let ?l = "\<lambda>l. \<P>(\<omega> in \<PP>. before_C {l} \<omega> \<bar> hit_C \<omega> )"

  from init_uniform have init_H: "\<And>i. i \<in> H \<Longrightarrow> p_i i = p_j / p_H"
    by (simp add: p_j_def p_H_def h_def)

  from h_def have "1/h = p_j/p_H" "h = p_H / p_j" "p_H = h * p_j"
    by (auto simp: p_H_def p_j_def field_simps)
  from C_smaller have h_pos: "0 < h"
    by (auto simp add: card_gt_0_iff h_def)

  let ?s = "(h - 1) * p_j"
  let ?f = "?s * p_f"

  from psubset_card_mono[OF _ C_smaller]
  have "1 \<le> card J - card C"
    by (simp del: C_le_J)
  then have "1 \<le> h"
    using C_smaller
    by (simp add: h_def card_Diff_subset card_mono field_simps del: C_le_J)

  have log_le_0: "?f * log 2 (p_H * p_f) \<le> ?f * log 2 1"
    using p_H_p_f_less_1 p_H_p_f_pos p_j_pos p_f \<open>1 \<le> h\<close>
    by (intro mult_left_mono log_le mult_nonneg_nonneg) auto

  have "(h - 1) * p_j < 1"
    using \<open>1 \<le> h\<close> C_smaller
    by (auto simp: h_def p_j_def divide_less_eq card_Diff_subset card_mono)
  then have 1: "(h - 1) * p_j * p_f < 1 * 1"
    using p_f by (intro mult_strict_mono) auto

  { fix \<omega> have "first_J \<omega> \<in> H \<or> first_J \<omega> = (THE x. False)"
      apply (cases "\<forall>i. \<not> visit {i} J \<omega>")
      apply (simp add: first_J_def)
      apply (auto dest: visit_imp_in_H first_J_eq)
      done }
  then have range_fj: "range first_J \<subseteq> H \<union> {THE x. False}"
    by auto

  have sf_fj: "simple_function hC first_J"
    by (rule simple_functionI) (auto intro: finite_subset[OF range_fj])

  have sd_fj: "simple_distributed hC first_J ?i"
    apply (rule hC.simple_distributedI[OF sf_fj])
    apply (auto intro!: T.cond_prob_eq_AE)
    apply (auto simp: space_stream_space)
    using AE_first_J
    apply eventually_elim
    apply auto
    done

  { fix \<omega> have "last_H \<omega> \<in> H \<or> last_H \<omega> = (THE x. False)"
      apply (cases "\<forall>i. \<not> before_C {i} \<omega>")
      apply (simp add: last_H_def)
      apply (auto dest: before_C_imp_in_H last_H_eq)
      done }
  then have range_lnc: "range last_H \<subseteq> H \<union> {THE x. False}"
    by auto

  have sf_lnc: "simple_function hC last_H"
    by (rule simple_functionI) (auto intro: finite_subset[OF range_lnc])

  have sd_lnc: "simple_distributed hC last_H ?l"
    apply (rule hC.simple_distributedI[OF sf_lnc])
    apply (auto intro!: T.cond_prob_eq_AE)
    apply (auto simp: space_stream_space)
    using AE_last_H
    apply eventually_elim
    apply auto
    done

  have sd_fj_lnc: "simple_distributed hC (\<lambda>\<omega>. (first_J \<omega>, last_H \<omega>)) (\<lambda>(i, l). ?il i l)"
    apply (rule hC.simple_distributedI)
    apply (rule simple_function_Pair[OF sf_fj sf_lnc])
    apply (auto intro!: T.cond_prob_eq_AE)
    apply (auto simp: space_stream_space)
    using AE_last_H AE_first_J
    apply eventually_elim
    apply auto
    done

  define c where "c = (SOME j. j \<in> C)"
  have c: "c \<in> C"
    using C_non_empty unfolding ex_in_conv[symmetric] c_def by (rule someI_ex)

  let ?inner = "\<lambda>i. \<Sum>l\<in>H. ?il i l * log 2 (?il i l / (?i i * ?l l))"
  { fix i assume i: "i \<in> H"
    with h_pos have card_idx: "real_of_nat (card (H - {i})) = p_H / p_j - 1"
      by (auto simp add: p_j_def p_H_def h_def)

    have neq0: "p_j \<noteq> 0" "p_H \<noteq> 0"
      unfolding p_j_def p_H_def
      using C_smaller i by auto

    from i have "?inner i =
      (\<Sum>l\<in>H - {i}. ?il i l * log 2 (?il i l / (?i i * ?l l))) +
      ?il i i * log 2 (?il i i / (?i i * ?l i))"
      by (simp add: sum_diff)
    also have "\<dots> =
      (\<Sum>l\<in>H - {i}. p_j/p_H * p_j * p_f * log 2 (p_j * p_f / (p_j * p_f + p_j/p_H * (1 - p_H * p_f)))) +
      p_j/p_H * (p_j * p_f + (1 - p_H * p_f)) * log 2 ((p_j * p_f + (1 - p_H * p_f)) / (p_j * p_f + p_j/p_H * (1 - p_H * p_f)))"
      using i p_f p_j_pos p_H
      apply (simp add: Pr_visit_before_C P_visit init_H Pr_before_C
                  del: sum_constant)
      apply (simp add: divide_simps distrib_left)
      apply (intro arg_cong2[where f="(*)"] refl arg_cong2[where f=log])
      apply (auto simp: field_simps)
      done
    also have "\<dots> = (?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)) / h"
      using neq0 p_f by (simp add: card_idx field_simps \<open>p_H = h * p_j\<close>)
    finally have "?inner i = (?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)) / h" . }
  then have "(\<Sum>i\<in>H. ?inner i) = ?f * log 2 (h * p_j * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)"
    using h_pos by (simp add: h_def[symmetric])
  also have "\<dots> = ?f * log 2 (p_H * p_f) + (1 - ?f) * log 2 ((1 - ?f) * h)"
    by (simp add: \<open>h = p_H / p_j\<close>)
  also have "\<dots> \<le> (1 - ?f) * log 2 ((1 - ?f) * h)"
    using log_le_0 by simp
  also have "\<dots> \<le> (1 - ?f) * log 2 h"
    using h_pos \<open>1 \<le> h\<close> 1 p_j_pos p_f
    by (intro mult_left_mono log_le mult_pos_pos mult_nonneg_nonneg) auto
  finally have "(\<Sum>i\<in>H. ?inner i) \<le> (1 - ?f) * log 2 h" .
  also have "(\<Sum>i\<in>H. ?inner i) =
      (\<Sum>(i, l)\<in>(first_J`space S) \<times> (last_H`space S). ?il i l * log 2 (?il i l / (?i i * ?l l)))"
    unfolding sum.cartesian_product
  proof (safe intro!: sum.mono_neutral_cong_left del: DiffE DiffI)
    show "finite ((first_J ` space S) \<times> (last_H ` space S))"
      using sf_fj sf_lnc by (auto simp add: hC_def dest!: simple_functionD(1))
  next
    fix i assume "i \<in> H"
    then have "visit {i} J (Init i ## Mix i ## sconst End)"
      "before_C {i} (Init i ## Mix c ## sconst End)"
      by (auto simp: before_C_def visit_def suntil_Stream HLD_iff c)
    then show "i \<in> first_J ` space S" "i \<in> last_H ` space S"
      by (auto simp: space_stream_space image_iff eq_commute dest!: first_J_eq last_H_eq)
  next
    fix i l assume "(i, l) \<in> first_J ` space S \<times> last_H ` space S - H \<times> H"
    then have H: "i \<notin> H \<or> l \<notin> H"
      by auto
    have "\<P>(\<omega> in \<PP>. (visit {i} J \<omega> \<and> before_C {l} \<omega>) \<and> hit_C \<omega>) = 0"
      using H by (intro T.prob_eq_0_AE) (auto dest: visit_imp_in_H before_C_imp_in_H)
    then show "?il i l * log 2 (?il i l / (?i i * ?l l)) = 0"
      by (simp add: cond_prob_def)
  qed
  also have "\<dots> = \<I>(first_J ; last_H)"
    unfolding sum.cartesian_product
    apply (subst hC.mutual_information_simple_distributed[OF sd_fj sd_lnc sd_fj_lnc])
    apply (simp add: hC_def)
  proof (safe intro!: sum.mono_neutral_right imageI)
    show "finite ((first_J ` space S) \<times> (last_H ` space S))"
      using sf_fj sf_lnc by (auto simp add: hC_def dest!: simple_functionD(1))
  next
    fix i l assume "(first_J i, last_H l) \<notin> (\<lambda>x. (first_J x, last_H x)) ` space S"
    moreover
    { fix i l assume "i \<in> H" "l \<in> H"
      then have "visit {i} J (Init i ## Mix l ## Mix c ## sconst End)"
        "before_C {l} (Init i ## Mix l ## Mix c ## sconst End)"
        using c C_smaller by (auto simp: before_C_def visit_def HLD_iff suntil_Stream)
      then have "first_J (Init i ## Mix l ## Mix c ## sconst End) = i"
        "last_H (Init i ## Mix l ## Mix c ## sconst End) = l"
        by (auto intro!: first_J_eq last_H_eq) }
    note this[of "first_J i" "last_H l"]
    ultimately have "(first_J i, last_H l) \<notin> H\<times>H"
      by (auto simp: space_stream_space image_iff eq_commute) metis
    then have "\<P>(\<omega> in \<PP>. (visit {first_J i} J \<omega> \<and> before_C {last_H l} \<omega>) \<and> hit_C \<omega>) = 0"
      by (intro T.prob_eq_0_AE) (auto dest: visit_imp_in_H before_C_imp_in_H)
    then show "?il (first_J i) (last_H l) *
      log 2 (?il (first_J i) (last_H l) / (?i (first_J i) * ?l (last_H l))) = 0"
      by (simp add: cond_prob_def)
  qed
  finally show ?thesis by simp
qed

end

end


section {* Every Kleene algebra with domain is a Kleene algebra with tests *}

theory KAD_is_KAT

imports "$AFP/KAD/Antidomain_Semiring"
        "$AFP/KAT_and_DRA/SingleSorted/KAT"
        "AVC_KAD/VC_KAD"
        "AVC_KAT/VC_KAT"
begin

context antidomain_kleene_algebra
begin

sublocale kat "op +" "op \<cdot>" "1" "0" "op \<le>" "op <" star antidomain_op
  apply standard
  apply simp
  using local.a_d_mult_closure local.am_d_def apply auto[1]
  using local.dpdz.dom_weakly_local apply auto[1]
  using local.a_d_add_closure local.a_de_morgan by presburger

lemma H_kat_to_kad: "H p x q \<longleftrightarrow> d p \<le> |x] (d q)"
  using local.H_def local.addual.ars_r_def local.fbox_demodalisation3 by auto

end

lemma H_eq: "P \<le> Id \<Longrightarrow> Q \<le> Id \<Longrightarrow> rel_kat.H P X Q = rel_antidomain_kleene_algebra.H P X Q"
  apply (simp add: rel_kat.H_def rel_antidomain_kleene_algebra.H_def)
  apply (subgoal_tac "rel_antidomain_kleene_algebra.t P = Id \<inter> P")
  apply (subgoal_tac "rel_antidomain_kleene_algebra.t Q = Id \<inter> Q")
  apply simp
  apply (auto simp: rel_ad_def)
done

(* hiding notation for VC_KAD *)
no_notation VC_KAD.spec_sugar ("PRE _ _ POST _" [64,64,64] 63)
and VC_KAD.cond_sugar ("IF _ THEN _ ELSE _ FI" [64,64,64] 63)
and VC_KAD.gets ("_ ::= _" [70, 65] 61)

lemma maximum:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
  by (simp only: sH_cond_iff H_assign_iff, auto)

lemma H_from_kat: "PRE p x POST q = (\<lceil>p\<rceil> \<le> (rel_antidomain_kleene_algebra.fbox x) \<lceil>q\<rceil>)"
  apply (subst H_eq)
  apply (clarsimp simp add: p2r_def)
  apply (clarsimp simp add: p2r_def)
  apply (subst rel_antidomain_kleene_algebra.H_kat_to_kad)
  apply (subgoal_tac "rel_antidomain_kleene_algebra.ads_d \<lceil>p\<rceil> = \<lceil>p\<rceil>")
  apply (subgoal_tac "rel_antidomain_kleene_algebra.ads_d \<lceil>q\<rceil> = \<lceil>q\<rceil>")
  apply simp
  apply (auto simp: rel_antidomain_kleene_algebra.ads_d_def rel_ad_def p2r_def)
done

lemma cond_iff: "rel_kat.ifthenelse \<lceil>P\<rceil> X Y = rel_antidomain_kleene_algebra.cond \<lceil>P\<rceil> X Y"
  by (auto simp: rel_kat.ifthenelse_def rel_antidomain_kleene_algebra.cond_def)

lemma gets_iff: "v ::= e = VC_KAD.gets v e"
  by (auto simp: VC_KAT.gets_def VC_KAD.gets_def)

lemma maximum2:
  "PRE (\<lambda>s:: nat store. True)
   (IF (\<lambda>s. s ''x'' \<ge> s ''y'')
    THEN (''z'' ::= (\<lambda>s. s ''x''))
    ELSE (''z'' ::= (\<lambda>s. s ''y''))
    FI)
   POST (\<lambda>s. s ''z'' = max (s ''x'') (s ''y''))"
   apply (subst H_from_kat)
   apply (subst cond_iff)
   apply (subst gets_iff)
   apply (subst gets_iff)
   apply auto
done

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_rotate_self
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rotate :: "Nat => 'a list => 'a list" where
"rotate (Z) z = z"
| "rotate (S z2) (nil2) = nil2"
| "rotate (S z2) (cons2 z22 xs1) =
     rotate z2 (x xs1 (cons2 z22 (nil2)))"

theorem property0 :
  "((rotate n (x xs xs)) = (x (rotate n xs) (rotate n xs)))"
  oops

end


section \<open>Domain 0 - Zermelo Fraenkel set theory in HOL\<close>

theory ZF_HOL
  imports "$ISABELLE_HOME/src/HOL/ZFC_in_HOL/ZFC_Typeclasses"
          Model_locale begin

(*membership relation, defined as HOL set membership and the 'elements' coercion from V to V set *)
abbreviation mem where "mem a x \<equiv> a \<in> elts x"

(*empty set is a coerced version of the HOL empty set*)
thm zero_V_def

(*argument of union needs lifting, then result needs flattening *)
abbreviation union where "union x \<equiv> ZFC_in_HOL.set (Union (elts ` (elts x)))"

(*subset relation gained by showing that V is a distributive lattice*)
abbreviation subset where "subset x y \<equiv> x \<le> y"

(*V \<Rightarrow> V power set already defined in ZFC_in_HOL*)
thm VPow_def

thm succ_def

abbreviation repl where "repl P x \<equiv> ZFC_in_HOL.set ((\<lambda>a. (THE b. P a b)) ` {a . a \<in> elts x \<and> (\<exists>b. P a b)})"

interpretation GZF_HOL : GZF mem 0 "(\<lambda>x. True)" union subset VPow succ \<omega> repl
proof (unfold_locales, auto, rule exI)
  fix P :: "V \<Rightarrow> V \<Rightarrow> bool" and x a b assume "\<forall>a. mem a x \<longrightarrow> Uniq (P a)" "mem a x" "P a b"
  moreover hence "The (P a) = b" unfolding Uniq_def by auto
  ultimately show "mem a x \<and> P a (The (P a))" "b \<in> (\<lambda>a. The (P a)) ` {a. mem a x \<and> Ex (P a)}" by auto
qed

thm GZF_HOL.un_iff
find_consts "V"

abbreviation ord where "ord x \<equiv> ZFC_in_HOL.Ord x"
abbreviation lt where "lt x y \<equiv> x < y \<and> ord x \<and> ord y"

lemma succD : "ord (succ i) \<Longrightarrow> ord i"
  by (erule Ord_in_Ord, auto)

lemma lt_ord : "lt i j \<Longrightarrow> ord i \<and> ord j" by auto
lemma lt_mem : "lt i j \<Longrightarrow> mem i j" using lt_ord Ord_mem_iff_lt by auto
lemma mem_lt : assumes "ord j" shows "mem i j \<Longrightarrow> lt i j" using OrdmemD assms Ord_in_Ord by auto

(*Can't be proved automatically - might have to copy some of the development from Isabelle/ZF?*)
lemma succ_mem_iff : "i \<in> elts (succ j) \<longleftrightarrow> i \<in> elts j | i = j"
  unfolding elts_succ by auto

lemma succ_iff : "lt i (succ j) \<longleftrightarrow> lt i j | i = j \<and> ord j"
proof
  assume "lt i (succ j)" hence mem:"mem i (succ j)" by (rule lt_mem)
  have "ord i" "ord (succ j)" using lt_ord[OF \<open>lt i (succ j)\<close>] by auto
  hence "ord j" using succD by auto

  from mem have "mem i j | i = j" using succ_mem_iff by auto
  thus "lt i j | i = j \<and> ord j" using Ord_mem_iff_lt \<open>ord i\<close> \<open>ord j\<close> by auto
next
  assume "lt i j | i = j \<and> ord j"
  thus "lt i (succ j)"
  proof
    assume "lt i j" hence "ord i" "ord j" by auto
    from \<open>lt i j\<close> have "mem i j" using Ord_mem_iff_lt by auto
    hence "mem i (succ j)" using succ_mem_iff by auto
    hence "i < succ j" using Ord_mem_iff_lt[OF \<open>ord i\<close> Ord_succ[OF \<open>ord j\<close>]] by auto
    thus "lt i (succ j)" using \<open>ord i\<close> \<open>ord j\<close>  by auto
  next
    assume h:"i = j \<and> ord j"
    hence "ord i" "ord (succ j)" using Ord_succ by auto

    from h have "mem i (succ j)" using succ_mem_iff by auto
    thus "lt i (succ j)" using Ord_mem_iff_lt[OF \<open>ord i\<close> \<open>ord (succ j)\<close>] \<open>ord i\<close> \<open>ord (succ j)\<close> by auto
  qed
qed

lemma limit_iff : "\<forall>\<mu>. Limit \<mu> \<longleftrightarrow> (ord \<mu> \<and> lt 0 \<mu> \<and> (\<forall>\<beta>. lt \<beta> \<mu> \<longrightarrow> lt (succ \<beta>) \<mu>))"
  proof (rule, rule)
    fix \<mu> assume "Limit \<mu>" hence def:"ord \<mu> \<and> mem 0 \<mu> \<and> (\<forall>y. mem y \<mu> \<longrightarrow> mem (ZFC_in_HOL.succ y) \<mu>)"
      unfolding Limit_def by simp
    hence 1: "ord \<mu>" and 2: "lt 0 \<mu>" using Ord_mem_iff_lt by auto
    have 3: "(\<forall>\<beta>. lt \<beta> \<mu> \<longrightarrow> lt (succ \<beta>) \<mu>)"
    proof (rule, rule)
      fix \<beta> assume "lt \<beta> \<mu>" hence "ord \<beta>" "mem \<beta> \<mu>" using Ord_mem_iff_lt by auto
      hence "mem (succ \<beta>) \<mu>" using def by auto
      thus "lt (succ \<beta>) \<mu>" using Ord_mem_iff_lt Ord_succ[OF \<open>ord \<beta>\<close>] \<open>ord \<mu>\<close> by auto
    qed
    from 1 2 3 show "ord \<mu> \<and> lt 0 \<mu> \<and> (\<forall>\<beta>. lt \<beta> \<mu> \<longrightarrow> lt (succ \<beta>) \<mu>)" by auto
  next
    fix \<mu> assume h:"ord \<mu> \<and> lt 0 \<mu> \<and> (\<forall>\<beta>. lt \<beta> \<mu> \<longrightarrow> lt (ZFC_in_HOL.succ \<beta>) \<mu>)"
    thus "Limit \<mu>" unfolding Limit_def using lt_mem proof (auto)
      fix y assume "mem y \<mu>" moreover hence "ord y" "ord \<mu>"using Ord_in_Ord h by auto
      ultimately have "lt y \<mu>" using Ord_mem_iff_lt by auto
      hence "lt (succ y) \<mu>" using h by auto
      thus "mem (succ y) \<mu>" using lt_mem by auto
    qed
  qed

lemma lt_trans : "lt i j \<Longrightarrow> lt j k \<Longrightarrow> lt i k" by auto
lemma lt_notsym : "lt i j \<Longrightarrow> \<not> lt j i" by auto
lemma lt_linear : "ord i \<and> ord j \<Longrightarrow> lt i j | i = j | lt j i" using Ord_linear_lt by auto
lemma lt_induct : "ord a \<Longrightarrow> (\<And>x. ord x \<Longrightarrow> (\<And>y. lt y x \<Longrightarrow> P y) \<Longrightarrow> P x) \<Longrightarrow> P a"
proof -
  assume "ord a" "(\<And>x. ord x \<Longrightarrow> (\<And>y. lt y x \<Longrightarrow> P y) \<Longrightarrow> P x)"
  hence "(\<And>x. ord x \<Longrightarrow> (\<And>y. mem y x \<Longrightarrow> P y) \<Longrightarrow> P x)" using lt_mem by auto
  thus ?thesis by (rule Ord_induct[OF \<open>ord a\<close>])
qed
thm lt_mem
lemma predset_def : "ord j \<Longrightarrow> mem i j \<longleftrightarrow> lt i j"
  by (rule, rule mem_lt, use lt_mem in auto)

(*Try using GZF_HOL.Lambda rather than VLambda*)
abbreviation tr3 where "tr3 G F A \<beta> \<equiv> transrec3 A (\<lambda>i. F (succ i)) (\<lambda>\<alpha> f. G \<alpha> (VLambda \<alpha> f)) \<beta>"
lemma rec0 : "tr3 G F A 0 = A"
 by (rule transrec3_0)

lemma recsucc: "tr3 G F A (succ \<beta>) = F (succ \<beta>) (tr3 G F A \<beta>)"
  by (rule transrec3_succ)
thm GZF_HOL.upair_iff
thm GZF_HOL.sng_iff

lemma "vpair a b = GZF_HOL.kpair a b" proof
  fix x show "mem x \<langle>a, b\<rangle> = mem x (GZF_HOL.kpair a b) "
  unfolding GZF_HOL.kpair_def using GZF_HOL.upair_iff vpair_def by auto
qed

lemma "VLambda x F = GZF_HOL.Lambda x F"
lemma reclim : "Limit \<mu> \<Longrightarrow> tr3 G F A \<mu> = G \<mu> (GZF_HOL.Lambda \<mu> (\<lambda>b. tr3 G F A b))"
  sorry

interpretation Ord_HOL : Ord mem 0 "(\<lambda>x. True)" union subset VPow succ \<omega> repl
                             ord lt 0 succ Limit "(\<lambda>x. x)" tr3 \<omega>
proof (unfold_locales)
  show "ord 0" by auto
  show "ord \<omega>" by auto
  show "\<forall>i j. lt i j \<longrightarrow> ord i \<and> ord j" using lt_ord by auto
  show "\<forall>i. ord (succ i) \<longleftrightarrow> ord i" using Ord_in_Ord by auto
  show "\<forall>i. \<not> lt i 0" by auto
  show "(\<forall>\<alpha> \<beta>. lt \<alpha> (succ \<beta>) \<longleftrightarrow> (lt \<alpha> \<beta> | \<alpha> = \<beta>  \<and> ord \<beta>))" using succ_iff by simp
  show "\<forall>\<mu>. Limit \<mu> \<longleftrightarrow> (ord \<mu> \<and> lt 0 \<mu> \<and> (\<forall>\<beta>. lt \<beta> \<mu> \<longrightarrow> lt (succ \<beta>) \<mu>))" by (rule limit_iff)


(*
Author: Alexander Katovsky
*)

section "Functor"

theory Functors
imports Category
begin

record ('o1, 'o2, 'm1, 'm2, 'a, 'b) Functor =
  CatDom :: "('o1,'m1,'a)Category_scheme"
  CatCod :: "('o2,'m2,'b)Category_scheme"
  MapM :: "'m1 \<Rightarrow> 'm2"

abbreviation
  FunctorMorApp :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme \<Rightarrow> 'm1 \<Rightarrow> 'm2" (infixr "##" 70) where
  "FunctorMorApp F m \<equiv> (MapM F) m"

definition
  MapO :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme \<Rightarrow> 'o1 \<Rightarrow> 'o2"  where
  "MapO F X \<equiv> THE Y . Y \<in> Obj(CatCod F) \<and>  F ## (Id (CatDom F) X) = Id (CatCod F) Y"

abbreviation
  FunctorObjApp :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme \<Rightarrow> 'o1 \<Rightarrow> 'o2" (infixr "@@" 70) where
  "FunctorObjApp F X \<equiv> (MapO F X)"

locale PreFunctor =
  fixes F :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme"  (structure)
  assumes FunctorComp: "f \<approx>>\<^bsub>CatDom F\<^esub> g \<Longrightarrow> F ## (f ;;\<^bsub>CatDom F\<^esub> g) = (F ## f) ;;\<^bsub>CatCod F\<^esub> (F ## g)"
  and     FunctorId:   "X \<in> obj\<^bsub>CatDom F\<^esub> \<Longrightarrow> \<exists> Y \<in> obj\<^bsub>CatCod F\<^esub> . F ## (id\<^bsub>CatDom F\<^esub> X) = id\<^bsub>CatCod F\<^esub> Y"
  and     CatDom[simp]:      "Category(CatDom F)"
  and     CatCod[simp]:      "Category(CatCod F)"

locale FunctorM = PreFunctor +
  assumes     FunctorCompM: "f maps\<^bsub>CatDom F\<^esub> X to Y \<Longrightarrow> (F ## f) maps\<^bsub>CatCod F\<^esub> (F @@ X) to (F @@ Y)"

locale FunctorExt =
  fixes F :: "('o1, 'o2, 'm1, 'm2, 'a1, 'a2, 'a) Functor_scheme"  (structure)
  assumes FunctorMapExt: "(MapM F) \<in> extensional (Mor (CatDom F))"

locale Functor = FunctorM (* + FunctorExt *)

definition
  MakeFtor :: "('o1, 'o2, 'm1, 'm2, 'a, 'b,'r) Functor_scheme \<Rightarrow> ('o1, 'o2, 'm1, 'm2, 'a, 'b,'r) Functor_scheme" where
  "MakeFtor F \<equiv> \<lparr>
      CatDom = CatDom F ,
      CatCod = CatCod F ,
      MapM = restrict (MapM F) (Mor (CatDom F)) ,
      \<dots> = Functor.more F
  \<rparr>"

lemma PreFunctorFunctor[simp]: "Functor F \<Longrightarrow> PreFunctor F"
by (simp add: Functor_def FunctorM_def)

lemmas functor_simps = PreFunctor.FunctorComp PreFunctor.FunctorId

definition
  functor_abbrev ("Ftor _ : _ \<longrightarrow> _" [81]) where
  "Ftor F : A \<longrightarrow> B \<equiv> (Functor F) \<and> (CatDom F = A) \<and> (CatCod F = B)"

lemma functor_abbrevE[elim]: "\<lbrakk>Ftor F : A \<longrightarrow> B ; \<lbrakk>(Functor F) ; (CatDom F = A) ; (CatCod F = B)\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (auto simp add: functor_abbrev_def)

definition
  functor_comp_def ("_ \<approx>>;;; _" [81]) where
  "functor_comp_def F G \<equiv> (Functor F) \<and> (Functor G) \<and> (CatDom G = CatCod F)"

lemma functor_comp_def[elim]: "\<lbrakk>F \<approx>>;;; G ; \<lbrakk>Functor F ; Functor G ; CatDom G = CatCod F\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
by (auto simp add: functor_comp_def_def)

lemma (in Functor) FunctorMapsTo:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows   "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))"
proof-
  have "f maps\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> f) to (cod\<^bsub>CatDom F\<^esub> f)" using assms by auto
  thus ?thesis by (simp add: FunctorCompM[of f "dom\<^bsub>CatDom F\<^esub> f" "cod\<^bsub>CatDom F\<^esub> f"])
qed

lemma (in Functor) FunctorCodDom:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows "dom\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> f)" and "cod\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (cod\<^bsub>CatDom F\<^esub> f)"
proof-
  have "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))" using assms by (simp add: FunctorMapsTo)
  thus "dom\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> f)" and "cod\<^bsub>CatCod F\<^esub>(F ## f) = F @@ (cod\<^bsub>CatDom F\<^esub> f)"
    by auto
qed

lemma (in Functor) FunctorCompPreserved: "f \<in> mor\<^bsub>CatDom F\<^esub> \<Longrightarrow> F ## f \<in> mor\<^bsub>CatCod F\<^esub>"
by (auto dest:FunctorMapsTo)

lemma (in Functor) FunctorCompDef:
  assumes "f \<approx>>\<^bsub>CatDom F\<^esub> g" shows "(F ## f) \<approx>>\<^bsub>CatCod F\<^esub> (F ## g)"
proof(auto simp add: CompDefined_def)
  show "F ## f \<in> mor\<^bsub>CatCod F\<^esub>" and "F ## g \<in> mor\<^bsub>CatCod F\<^esub>" using assms by (auto simp add: FunctorCompPreserved)
  have "f \<in> mor\<^bsub>CatDom F\<^esub>" and "g \<in> mor\<^bsub>CatDom F\<^esub>" using assms by auto
  hence a: "cod\<^bsub>CatCod F\<^esub> (F ## f) = F @@ (cod\<^bsub>CatDom F\<^esub> f)" and b: "dom\<^bsub>CatCod F\<^esub>(F ## g) = F @@ (dom\<^bsub>CatDom F\<^esub> g)"
    by (simp add: FunctorCodDom)+
  have "cod\<^bsub>CatCod F\<^esub> (F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> g)" using assms a by auto
  also have "... = dom\<^bsub>CatCod F\<^esub> (F ## g)" using b by simp
  finally show "cod\<^bsub>CatCod F\<^esub> (F ## f) = dom\<^bsub>CatCod F\<^esub> (F ## g)" .
qed

lemma FunctorComp: "\<lbrakk>Ftor F : A \<longrightarrow> B ; f \<approx>>\<^bsub>A\<^esub> g\<rbrakk> \<Longrightarrow> F ## (f ;;\<^bsub>A\<^esub> g) = (F ## f) ;;\<^bsub>B\<^esub> (F ## g)"
by (auto simp add: PreFunctor.FunctorComp)

lemma FunctorCompDef: "\<lbrakk>Ftor F : A \<longrightarrow> B ; f \<approx>>\<^bsub>A\<^esub> g\<rbrakk> \<Longrightarrow> (F ## f) \<approx>>\<^bsub>B\<^esub> (F ## g)"
by (auto simp add: Functor.FunctorCompDef)

lemma FunctorMapsTo:
  assumes "Ftor F : A \<longrightarrow> B" and "f maps\<^bsub>A\<^esub> X to Y"
  shows "(F ## f) maps\<^bsub>B\<^esub> (F @@ X) to (F @@ Y)"
proof-
  have b: "CatCod F = B" and a: "CatDom F = A" and ff: "Functor F" using assms by auto
  have df: "(dom\<^bsub>CatDom F\<^esub> f) = X" and cf: "(cod\<^bsub>CatDom F\<^esub> f) = Y" using a assms by auto
  have "f \<in> mor\<^bsub>CatDom F\<^esub>" using assms by auto
  hence "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))" using ff
    by (simp add: Functor.FunctorMapsTo)
  thus ?thesis using df cf b by simp
qed

lemma (in PreFunctor) FunctorId2:
  assumes "X \<in> obj\<^bsub>CatDom F\<^esub>"
  shows   "F @@ X \<in> obj\<^bsub>CatCod F\<^esub> \<and> F ## (id\<^bsub>CatDom F\<^esub> X) = id\<^bsub>CatCod F\<^esub> (F @@ X)"
proof-
  let ?Q = "\<lambda> E Y . Y \<in> obj\<^bsub>CatCod F\<^esub> \<and> E = id\<^bsub>CatCod F\<^esub> Y"
  let ?P = "?Q (F ## (id\<^bsub>CatDom F\<^esub> X))"
  from assms FunctorId obtain Y where "?P Y" by auto
  moreover  {
    fix y e z have "\<lbrakk>?Q e y ; ?Q e z\<rbrakk> \<Longrightarrow> y = z"
      by (auto intro: Category.IdInj[of "CatCod F" y z])
  }
  ultimately have "\<exists>! Z . ?P Z" by auto
  hence "?P (THE Y . ?P Y)" by (rule theI')
  thus ?thesis by (auto simp add: MapO_def)
qed

lemma FunctorId:
  assumes "Ftor F : C \<longrightarrow> D" and "X \<in> Obj C"
  shows "F ## (Id C X) = Id D (F @@ X)"
proof-
  have "CatDom F = C" and "CatCod F = D" and "PreFunctor F" using assms by auto
  thus ?thesis using assms PreFunctor.FunctorId2[of F X] by simp
qed

lemma (in Functor) DomFunctor: "f \<in> mor\<^bsub>CatDom F\<^esub> \<Longrightarrow> dom\<^bsub>CatCod F\<^esub> (F ## f) = F @@ (dom\<^bsub>CatDom F\<^esub> f)"
by (simp add: FunctorCodDom)

lemma (in Functor) FunctorId3Dom:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows   "F ## (id\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## f))"
proof-
  have "(dom\<^bsub>CatDom F\<^esub> f) \<in> obj\<^bsub>CatDom F\<^esub>" using assms by (simp add: Category.Cdom)
  hence "F ## (id\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f))" by (simp add: FunctorId2)
  also have "... = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## f))" using assms by (simp add: DomFunctor)
  finally show ?thesis by simp
qed

lemma (in Functor) FunctorId3Cod:
  assumes "f \<in> mor\<^bsub>CatDom F\<^esub>"
  shows   "F ## (id\<^bsub>CatDom F\<^esub> (cod\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## f))"
proof-
  have "(cod\<^bsub>CatDom F\<^esub> f) \<in> obj\<^bsub>CatDom F\<^esub>" using assms by (simp add: Category.Ccod)
  hence "F ## (id\<^bsub>CatDom F\<^esub> (cod\<^bsub>CatDom F\<^esub> f)) = id\<^bsub>CatCod F\<^esub> (F @@ (cod\<^bsub>CatDom F\<^esub> f))" by (simp add: FunctorId2)
  also have "... = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## f))" using assms by (simp add: CodFunctor)
  finally show ?thesis by simp
qed

lemma (in PreFunctor) FmToFo: "\<lbrakk>X \<in> obj\<^bsub>CatDom F\<^esub> ; Y \<in> obj\<^bsub>CatCod F\<^esub> ; F ## (id\<^bsub>CatDom F\<^esub> X) = id\<^bsub>CatCod F\<^esub> Y\<rbrakk> \<Longrightarrow> F @@ X = Y"
  by (auto simp add: FunctorId2 intro: Category.IdInj[of "CatCod F" "F @@ X" Y])

lemma MakeFtorPreFtor:
  assumes "PreFunctor F" shows "PreFunctor (MakeFtor F)"
proof-
  {
    fix X assume a: "X \<in> obj\<^bsub>CatDom F\<^esub>" have "id\<^bsub>CatDom F \<^esub>X \<in> mor\<^bsub>CatDom F\<^esub>"
    proof-
      have "Category (CatDom F)" using assms by (simp add: PreFunctor_def)
      hence "id\<^bsub>CatDom F \<^esub>X maps\<^bsub>CatDom F\<^esub> X to X" using a by (simp add: Category.Cidm)
      thus ?thesis using a by (auto)
    qed
  }
  thus "PreFunctor (MakeFtor F)" using assms
    by(auto simp add: PreFunctor_def MakeFtor_def Category.MapsToMorDomCod)
qed

lemma MakeFtorMor: "f \<in> mor\<^bsub>CatDom F\<^esub> \<Longrightarrow> MakeFtor F ## f = F ## f"
by(simp add: MakeFtor_def)

lemma MakeFtorObj:
  assumes "PreFunctor F" and "X \<in> obj\<^bsub>CatDom F\<^esub>"
  shows "MakeFtor F @@ X = F @@ X"
proof-
  have "X \<in> obj\<^bsub>CatDom (MakeFtor F)\<^esub>" using assms(2) by (simp add: MakeFtor_def)
  moreover have "(F @@ X) \<in> obj\<^bsub>CatCod (MakeFtor F)\<^esub>" using assms by (simp add: PreFunctor.FunctorId2 MakeFtor_def)
  moreover have "MakeFtor F ## id\<^bsub>CatDom (MakeFtor F) \<^esub>X = id\<^bsub>CatCod (MakeFtor F) \<^esub>(F @@ X)"
  proof-
    have "Category (CatDom F)" using assms(1) by (simp add: PreFunctor_def)
    hence "id\<^bsub>CatDom F \<^esub>X  maps\<^bsub>CatDom F\<^esub> X to X" using assms(2) by (auto simp add: Category.Cidm)
    hence "id\<^bsub>CatDom F \<^esub>X \<in> mor\<^bsub>CatDom F\<^esub>" by auto
    hence "MakeFtor F ## id\<^bsub>CatDom (MakeFtor F) \<^esub>X = F ## id\<^bsub>CatDom F \<^esub>X" by (simp add: MakeFtor_def)
    also have "... = id\<^bsub>CatCod F \<^esub>(F @@ X)" using assms by (simp add: PreFunctor.FunctorId2)
    finally show ?thesis by (simp add: MakeFtor_def)
  qed
  moreover have "PreFunctor (MakeFtor F)" using assms(1) by (simp add: MakeFtorPreFtor)
  ultimately show ?thesis by (simp add: PreFunctor.FmToFo)
qed

lemma MakeFtor: assumes "FunctorM F" shows "Functor (MakeFtor F)"
proof(intro_locales)
  show "PreFunctor (MakeFtor F)" using assms by (simp add: MakeFtorPreFtor FunctorM_def)
  show "FunctorM_axioms (MakeFtor F)"
  proof(auto simp add: FunctorM_axioms_def)
    {
      fix f X Y assume aa: "f maps\<^bsub>CatDom (MakeFtor F)\<^esub> X to Y"
      show "((MakeFtor F) ## f) maps\<^bsub>CatCod (MakeFtor F)\<^esub> ((MakeFtor F) @@ X) to ((MakeFtor F) @@ Y)"
      proof-
        have "((MakeFtor F) ## f) = F ## f" using aa by (auto simp add: MakeFtor_def)
        moreover have "((MakeFtor F) @@ X) = F @@ X" and "((MakeFtor F) @@ Y) = F @@ Y"
        proof-
          have "Category (CatDom F)" using assms by (simp add: FunctorM_def PreFunctor_def)
          hence "X \<in> obj\<^bsub>CatDom F\<^esub>" and "Y \<in> obj\<^bsub>CatDom F\<^esub>"
            using aa by (auto simp add: Category.MapsToObj MakeFtor_def)
          moreover have "PreFunctor F" using assms(1) by (simp add: FunctorM_def)
          ultimately show "((MakeFtor F) @@ X) = F @@ X" and "((MakeFtor F) @@ Y) = F @@ Y"
            by (simp add: MakeFtorObj)+
        qed
        moreover have "F ## f maps\<^bsub>CatCod F\<^esub> (F @@ X) to (F @@ Y)" using assms(1) aa
          by (simp add: FunctorM.FunctorCompM MakeFtor_def)
        ultimately show ?thesis by (simp add: MakeFtor_def)
      qed
    }
  qed
qed

definition
  IdentityFunctor' :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,'o,'m,'m,'a,'a) Functor" ("FId' _" [70]) where
  "IdentityFunctor' C \<equiv> \<lparr>CatDom = C , CatCod = C , MapM = (\<lambda> f . f) \<rparr>"

definition
  IdentityFunctor ("FId _" [70]) where
  "IdentityFunctor C \<equiv> MakeFtor(IdentityFunctor' C)"

lemma IdFtor'PreFunctor: "Category C \<Longrightarrow> PreFunctor (FId' C)"
by(auto simp add: PreFunctor_def IdentityFunctor'_def)

lemma IdFtor'Obj:
  assumes "Category C" and "X \<in> obj\<^bsub>CatDom (FId' C)\<^esub>"
  shows "(FId' C) @@ X = X"
proof-
  have "(FId' C) ## id\<^bsub>CatDom (FId' C)\<^esub> X = id\<^bsub>CatCod (FId' C)\<^esub> X" by(simp add: IdentityFunctor'_def)
  moreover have "X \<in> obj\<^bsub>CatCod (FId' C)\<^esub>" using assms by (simp add: IdentityFunctor'_def)
  ultimately show ?thesis using assms by (simp add: PreFunctor.FmToFo IdFtor'PreFunctor)
qed

lemma IdFtor'FtorM:
  assumes "Category C" shows "FunctorM (FId' C)"
proof(auto simp add: FunctorM_def IdFtor'PreFunctor assms FunctorM_axioms_def)
  {
    fix f X Y assume a: "f maps\<^bsub>CatDom (FId' C)\<^esub> X to Y"
    show "((FId' C) ## f) maps\<^bsub>CatCod (FId' C)\<^esub> ((FId' C) @@ X) to ((FId' C) @@ Y)"
    proof-
      have "X \<in> obj\<^bsub>CatDom (FId' C)\<^esub>" and "Y \<in> obj\<^bsub>CatDom (FId' C)\<^esub>"
        using a assms by (simp add: Category.MapsToObj IdentityFunctor'_def)+
      moreover have "(FId' C) ## f = f" and "CatDom (FId' C) = CatCod (FId' C)" by (simp add: IdentityFunctor'_def)+
      ultimately show ?thesis using assms a by(simp add: IdFtor'Obj)
    qed
  }
qed

lemma IdFtorFtor:  "Category C \<Longrightarrow> Functor (FId C)"
by (auto simp add: IdentityFunctor_def IdFtor'FtorM intro: MakeFtor)

definition
  ConstFunctor' :: "('o1,'m1,'a) Category_scheme \<Rightarrow>
                  ('o2,'m2,'b) Category_scheme \<Rightarrow> 'o2 \<Rightarrow> ('o1,'o2,'m1,'m2,'a,'b) Functor"  where
  "ConstFunctor' A B b \<equiv> \<lparr>
         CatDom = A ,
         CatCod = B ,
         MapM = (\<lambda> f . (Id B) b)
  \<rparr>"

definition "ConstFunctor A B b \<equiv> MakeFtor(ConstFunctor' A B b)"

lemma ConstFtor' :
  assumes "Category A" "Category B" "b \<in> (Obj B)"
  shows   "PreFunctor (ConstFunctor' A B b)"
  and     "FunctorM (ConstFunctor' A B b)"
proof-
  show "PreFunctor (ConstFunctor' A B b)" using assms
    apply (subst PreFunctor_def)
    apply (rule conjI)+
    by (auto simp add: ConstFunctor'_def Category.Simps Category.CatIdCompId)
  moreover
  {
    fix X  assume "X \<in> obj\<^bsub>A\<^esub>" "b \<in> obj\<^bsub>B\<^esub>" "PreFunctor (ConstFunctor' A B b)"
    hence "(ConstFunctor' A B b) @@ X = b"
      by (auto simp add: ConstFunctor'_def PreFunctor.FmToFo Category.Simps)
  }
  ultimately show "FunctorM (ConstFunctor' A B b)" using assms
    by (intro_locales, auto simp add: ConstFunctor'_def Category.Simps FunctorM_axioms_def)
qed

lemma ConstFtor:
  assumes "Category A" "Category B" "b \<in> (Obj B)"
  shows "Functor (ConstFunctor A B b)"
by (auto simp add: assms ConstFtor' ConstFunctor_def MakeFtor)

definition
  UnitFunctor :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,unit,'m,unit,'a,unit) Functor"  where
  "UnitFunctor C \<equiv> ConstFunctor C UnitCategory ()"

lemma UnitFtor:
  assumes "Category C"
  shows "Functor(UnitFunctor C)"
proof-
  have "() \<in> obj\<^bsub>UnitCategory\<^esub>" by (simp add: UnitCategory_def MakeCatObj)
  hence "Functor(ConstFunctor C UnitCategory ())" using assms
    by (simp add: ConstFtor)
  thus ?thesis by (simp add: UnitFunctor_def)
qed

definition
  FunctorComp' :: "('o1,'o2,'m1,'m2,'a1,'a2) Functor \<Rightarrow> ('o2,'o3,'m2,'m3,'b1,'b2) Functor
                    \<Rightarrow> ('o1,'o3,'m1,'m3,'a1,'b2) Functor" (infixl ";;:" 71) where
  "FunctorComp' F G \<equiv> \<lparr>
        CatDom = CatDom F ,
        CatCod = CatCod G ,
        MapM   = \<lambda> f . (MapM G)((MapM F) f)
  \<rparr>"

definition FunctorComp (infixl ";;;" 71) where "FunctorComp F G \<equiv> MakeFtor (FunctorComp' F G)"

lemma FtorCompComp':
  assumes "f \<approx>>\<^bsub>CatDom F\<^esub> g"
  and "F \<approx>>;;; G"
  shows "G ## (F ## (f ;;\<^bsub>CatDom F\<^esub> g)) = (G ## (F ## f)) ;;\<^bsub>CatCod G\<^esub> (G ## (F ## g))"
proof-
  have [simp]: "PreFunctor G \<and> PreFunctor F" using assms by auto
  have [simp]: "(F ## f) \<approx>>\<^bsub>CatDom G\<^esub> (F ## g)" using assms by (auto simp add: Functor.FunctorCompDef[of F f g])
  have "F ## (f ;;\<^bsub>CatDom F\<^esub> g) = (F ## f) ;;\<^bsub>CatCod F\<^esub> (F ## g)" using assms
    by (auto simp add: PreFunctor.FunctorComp)
  hence "G ## (F ## (f ;;\<^bsub>CatDom F\<^esub> g)) = G ## ((F ## f) ;;\<^bsub>CatCod F\<^esub> (F ## g))" by simp
  also have "... = G ## ((F ## f) ;;\<^bsub>CatDom G\<^esub> (F ## g))" using assms by auto
  also have "... = (G ## (F ## f)) ;;\<^bsub>CatCod G\<^esub> (G ## (F ## g))"
    by (simp add: PreFunctor.FunctorComp[of G "(F ## f)" "(F ## g)"])
  finally show ?thesis by simp
qed

lemma FtorCompId:
  assumes a: "X \<in> (Obj (CatDom F))"
  and "F \<approx>>;;; G"
  shows "G ## (F ## (id\<^bsub>CatDom F \<^esub>X)) = id\<^bsub>CatCod G\<^esub>(G @@ (F @@ X)) \<and> G @@ (F @@ X) \<in> (Obj (CatCod G))"
proof-
  have [simp]: "PreFunctor G \<and> PreFunctor F" using assms by auto
  have b: "(F @@ X) \<in> obj\<^bsub>CatDom G\<^esub>" using assms
    by (auto simp add: PreFunctor.FunctorId2)
  have "G ## F ## (id\<^bsub>CatDom F \<^esub>X) = G ## (id\<^bsub>CatCod F\<^esub>(F @@ X))" using b a
    by (simp add: PreFunctor.FunctorId2[of F "X"])
  also have "... = G ## (id\<^bsub>CatDom G\<^esub>(F @@ X))" using assms by auto
  also have "... = id\<^bsub>CatCod G\<^esub>(G @@ (F @@ X)) \<and> G @@ (F @@ X) \<in> (Obj (CatCod G))" using b
    by (simp add: PreFunctor.FunctorId2[of G "(F @@ X)"])
  finally show ?thesis by simp
qed

lemma FtorCompIdDef:
  assumes a: "X \<in> (Obj (CatDom F))" and b: "PreFunctor (F ;;: G)"
  and "F \<approx>>;;; G"
  shows "(F ;;: G) @@ X = (G @@ (F @@ X))"
proof-
  have "(F ;;: G) ## (id\<^bsub>CatDom (F ;;: G)\<^esub>(X)) = G ## (F ## (id\<^bsub>CatDom F\<^esub>(X)))" using assms
    by (simp add: FunctorComp'_def)
  also have "... = id\<^bsub>CatCod G\<^esub>(G @@ (F @@ (X)))" using assms a
    by(auto simp add: FtorCompId[of _ F G])
  finally have "(F ;;: G) ## (id\<^bsub>CatDom (F ;;: G)\<^esub>(X)) = id\<^bsub>CatCod (F ;;: G)\<^esub>(G @@ (F @@ X))" using assms
    by (simp add: FunctorComp'_def)
  moreover have "G @@ (F @@ (X)) \<in> (Obj (CatCod (F ;;: G)))" using assms a
    by(auto simp add: FtorCompId[of _ F G] FunctorComp'_def)
  moreover have "X \<in> obj\<^bsub>CatDom (F ;;: G)\<^esub>" using a by (simp add: FunctorComp'_def)
  ultimately show ?thesis using b
    by (simp add: PreFunctor.FmToFo[of "F ;;: G" X "G @@ (F @@ X)"])
qed

lemma FunctorCompMapsTo:
  assumes "f \<in> mor\<^bsub>CatDom (F ;;: G)\<^esub>" and "F \<approx>>;;; G"
  shows "(G ## (F ## f)) maps\<^bsub>CatCod G\<^esub> (G @@ (F @@ (dom\<^bsub>CatDom F\<^esub> f))) to (G @@ (F @@ (cod\<^bsub>CatDom F\<^esub> f)))"
proof-
  have "f \<in> mor\<^bsub>CatDom F \<^esub>\<and> Functor F" using assms by (auto simp add: FunctorComp'_def)
  hence "(F ## f) maps\<^bsub>CatDom G\<^esub> (F @@ (dom\<^bsub>CatDom F\<^esub> f)) to (F @@ (cod\<^bsub>CatDom F\<^esub> f))" using assms
    by (auto simp add: Functor.FunctorMapsTo[of F f])
  moreover have "FunctorM G" using assms by (auto simp add: FunctorComp_def Functor_def)
  ultimately show ?thesis by(simp add: FunctorM.FunctorCompM[of G "F ## f" "F @@ (dom\<^bsub>CatDom F\<^esub> f)" "F @@ (cod\<^bsub>CatDom F\<^esub> f)"])
qed

lemma FunctorCompMapsTo2:
  assumes "f \<in> mor\<^bsub>CatDom (F ;;: G)\<^esub>"
  and "F \<approx>>;;; G"
  and "PreFunctor (F ;;: G)"
  shows "((F ;;: G) ## f) maps\<^bsub>CatCod (F ;;: G)\<^esub> ((F ;;: G) @@ (dom\<^bsub>CatDom (F ;;: G)\<^esub> f)) to
                                               ((F ;;: G) @@ (cod\<^bsub>CatDom (F ;;: G)\<^esub> f))"
proof-
  have "Category (CatDom (F ;;: G))" using assms by (simp add: PreFunctor_def)
  hence 1: "(dom\<^bsub>CatDom (F ;;: G)\<^esub> f) \<in> obj\<^bsub>CatDom F \<^esub>\<and> (cod\<^bsub>CatDom (F ;;: G)\<^esub> f) \<in> obj\<^bsub>CatDom F\<^esub>" using assms
    by (auto simp add: Category.Simps FunctorComp'_def)
  have "(G ## (F ## f)) maps\<^bsub>CatCod G\<^esub> (G @@ (F @@ (dom\<^bsub>CatDom F\<^esub> f))) to (G @@ (F @@ (cod\<^bsub>CatDom F\<^esub> f)))"
    using assms by (auto simp add: FunctorCompMapsTo[of f F G])
  moreover have "CatDom F = CatDom(F ;;: G) \<and> CatCod G = CatCod(F ;;: G) \<and> (G ## (F ## f)) = ((F ;;: G) ## f)" using assms
    by (simp add: FunctorComp'_def)
  moreover have "(F ;;: G) @@ (dom\<^bsub>CatDom (F ;;: G)\<^esub> f) = (G @@ (F @@ (dom\<^bsub>CatDom(F ;;: G)\<^esub> f))) \<and>
        (F ;;: G) @@ (cod\<^bsub>CatDom (F ;;: G)\<^esub> f) = (G @@ (F @@ (cod\<^bsub>CatDom(F ;;: G)\<^esub> f)))"
    by (auto simp add: FtorCompIdDef[of _ F G] 1 assms)
  ultimately show ?thesis by auto
qed

lemma FunctorCompMapsTo3:
  assumes "f maps\<^bsub>CatDom (F ;;: G)\<^esub> X to Y"
  and "F \<approx>>;;; G"
  and "PreFunctor (F ;;: G)"
  shows "F ;;: G ## f maps\<^bsub>CatCod (F ;;: G)\<^esub> F ;;: G @@ X to F ;;: G @@ Y"
proof-
  have  "f \<in> mor\<^bsub>CatDom (F ;;: G)\<^esub>"
    and "dom\<^bsub>CatDom (F ;;: G)\<^esub> f = X"
    and "cod\<^bsub>CatDom (F ;;: G)\<^esub> f = Y" using assms by auto
  thus ?thesis using assms by (auto intro: FunctorCompMapsTo2)
qed

lemma FtorCompPreFtor:
  assumes "F \<approx>>;;; G"
  shows   "PreFunctor (F ;;: G)"
proof-
  have 1: "PreFunctor G \<and> PreFunctor F" using assms by auto
  show "PreFunctor (F ;;: G)" using assms
  proof(auto simp add: PreFunctor_def FunctorComp'_def Category.Simps
       FtorCompId[of _ F G] intro:FtorCompComp')
    show "Category (CatDom F)" and "Category (CatCod G)" using assms 1 by (auto simp add: PreFunctor_def)
  qed
qed

lemma FtorCompM :
  assumes "F \<approx>>;;; G"
  shows   "FunctorM (F ;;: G)"
proof(auto simp only: FunctorM_def)
  show 1: "PreFunctor (F ;;: G)" using assms by (rule FtorCompPreFtor)
  {
    fix X Y f assume a: "f maps\<^bsub>CatDom (F ;;: G)\<^esub> X to Y"
    have "F ;;: G ## f maps\<^bsub>CatCod (F ;;: G)\<^esub> F ;;: G @@ X to F ;;: G @@ Y"
      using a assms 1 by (rule FunctorCompMapsTo3)
  }
  thus "FunctorM_axioms (F ;;: G)"
    by(auto simp add: 1 FunctorM_axioms_def)
qed

lemma FtorComp:
  assumes "F \<approx>>;;; G"
  shows   "Functor (F ;;; G)"
proof-
  have "FunctorM (F ;;: G)" using assms by (rule FtorCompM)
  thus ?thesis by (simp add: FunctorComp_def MakeFtor)
qed

lemma (in Functor) FunctorPreservesIso:
  assumes     "ciso\<^bsub>CatDom F\<^esub> k"
  shows       "ciso\<^bsub>CatCod F\<^esub> (F ## k)"
proof-
  have [simp]: "k \<in> mor\<^bsub>CatDom F\<^esub>" using assms by (simp add: Category.IsoIsMor)
  have "cinv\<^bsub>CatCod F\<^esub> (F ## k) (F ## (Cinv\<^bsub>CatDom F\<^esub> k))"
    proof(rule Category.Inverse_relI)
      show "Category (CatCod F)" by simp
      show "(F ## k) \<approx>>\<^bsub>CatCod F\<^esub> (F ## (Cinv\<^bsub>CatDom F\<^esub> k))"
        by (rule FunctorCompDef, simp add: Category.IsoCompInv assms)
      show "(F ## k) ;;\<^bsub>CatCod F\<^esub> (F ## (Cinv\<^bsub>CatDom F\<^esub> k)) = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## k))"
      proof-
        have      "(F ## k) ;;\<^bsub>CatCod F\<^esub> (F ## (Cinv\<^bsub>CatDom F\<^esub> k)) = F ## (k ;;\<^bsub>CatDom F\<^esub> (Cinv\<^bsub>CatDom F\<^esub> k))" using assms
          by(auto simp add: FunctorComp Category.IsoCompInv)
        also have "... = F ## (id\<^bsub>CatDom F\<^esub> (dom\<^bsub>CatDom F\<^esub> k))" using assms by (simp add: Category.IsoInvId2)
        also have "... = id\<^bsub>CatCod F\<^esub> (dom\<^bsub>CatCod F\<^esub> (F ## k))" by (simp add: FunctorId3Dom)
        finally show ?thesis by simp
      qed
      show "(F ## (Cinv\<^bsub>CatDom F\<^esub> k)) ;;\<^bsub>CatCod F\<^esub> (F ## k) = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## k))"
      proof-
        have      "(F ## (Cinv\<^bsub>CatDom F\<^esub> k)) ;;\<^bsub>CatCod F\<^esub> (F ## k) = F ## ((Cinv\<^bsub>CatDom F\<^esub> k) ;;\<^bsub>CatDom F\<^esub>  k)" using assms
          by(auto simp add: FunctorComp Category.InvCompIso)
        also have "... = F ## (id\<^bsub>CatDom F\<^esub> (cod\<^bsub>CatDom F\<^esub> k))" using assms by (simp add: Category.IsoInvId1)
        also have "... = id\<^bsub>CatCod F\<^esub> (cod\<^bsub>CatCod F\<^esub> (F ## k))" using assms by (simp add: FunctorId3Cod)
        finally show ?thesis by simp
      qed
    qed
  thus ?thesis by(auto simp add: isomorphism_def)
qed

declare PreFunctor.CatDom[simp] PreFunctor.CatCod [simp]

lemma FunctorMFunctor[simp]: "Functor F \<Longrightarrow> FunctorM F"
by (simp add: Functor_def)

locale Equivalence = Functor +
  assumes Full: "\<lbrakk>A \<in> Obj (CatDom F) ; B \<in> Obj (CatDom F) ;
                  h maps\<^bsub>CatCod F\<^esub> (F @@ A) to (F @@ B)\<rbrakk> \<Longrightarrow>
                 \<exists> f . (f maps\<^bsub>CatDom F\<^esub> A to B) \<and> (F ## f = h)"
  and Faithful: "\<lbrakk>f maps\<^bsub>CatDom F\<^esub> A to B ; g maps\<^bsub>CatDom F\<^esub> A to B ; F ## f = F ## g\<rbrakk> \<Longrightarrow> f = g"
  and IsoDense: "C \<in> Obj (CatCod F) \<Longrightarrow> \<exists> A \<in> Obj (CatDom F) . ObjIso (CatCod F) (F @@ A) C"

end