(* Author: Maximilian Schäffeler, adapted from Markov_Models.Discrete_Time_Markov_Process *)

section \<open>Discrete-Time Markov Decision Processes with Arbitrary State Spaces\<close>

text \<open>
  In this file we construct discrete-time Markov decision processes,
  e.g. with arbitrary state spaces.
  Proofs and definitions are adapted from Markov\_Models.Discrete\_Time\_Markov\_Process.
\<close>

theory MDP_cont
  imports "HOL-Probability.Probability"
begin

lemma Ionescu_Tulcea_C_eq:
  assumes "\<And>i h. h \<in> space (PiM {0..<i} N) \<Longrightarrow> P i h = P' i h"
  assumes h: "Ionescu_Tulcea P N" "Ionescu_Tulcea P' N"
  shows "Ionescu_Tulcea.C P N 0 n (\<lambda>x. undefined) = Ionescu_Tulcea.C P' N 0 n (\<lambda>x. undefined)"
proof (induction n)
  case 0
  then show ?case using h by (auto simp: Ionescu_Tulcea.C_def)
next
  case (Suc n)
  have aux: "space (PiM {0..<0 + n} N) = space (rec_nat (\<lambda>n. return (Pi\<^sub>M {0..<n} N))
    (\<lambda>m ma n \<omega>. ma n \<omega> \<bind> Ionescu_Tulcea.eP P' N (n + m)) n 0 (\<lambda>x. undefined))"
    using h
    by (subst Ionescu_Tulcea.space_C[symmetric, where P = P', where x = "(\<lambda>x. undefined)"])
      (auto simp add: Ionescu_Tulcea.C_def)
  have "\<And>i h. h \<in> space (PiM {0..<i} N) \<Longrightarrow> Ionescu_Tulcea.eP P N i h = Ionescu_Tulcea.eP P' N i h"
    by (auto simp add: Ionescu_Tulcea.eP_def assms)
  then show ?case
    using Suc.IH h
    using aux[symmetric]
    by (auto intro!: bind_cong simp: Ionescu_Tulcea.C_def)
qed

lemma Ionescu_Tulcea_CI_eq:
  assumes "\<And>i h. h \<in> space (PiM {0..<i} N) \<Longrightarrow> P i h = P' i h"
  assumes h: "Ionescu_Tulcea P N" "Ionescu_Tulcea P' N"
  shows "Ionescu_Tulcea.CI P N = Ionescu_Tulcea.CI P' N"
proof -
  have "\<And>J. Ionescu_Tulcea.CI P N J = Ionescu_Tulcea.CI P' N J"
    unfolding Ionescu_Tulcea.CI_def[OF h(1)] Ionescu_Tulcea.CI_def[OF h(2)]
    using assms
    by (auto intro!: distr_cong Ionescu_Tulcea_C_eq)
  thus ?thesis by auto
qed

lemma measure_eqI_PiM_sequence:
  fixes M :: "nat \<Rightarrow> 'a measure"
  assumes *[simp]: "sets P = PiM UNIV M" "sets Q = PiM UNIV M"
  assumes eq: "\<And>A n. (\<And>i. A i \<in> sets (M i)) \<Longrightarrow>
    P (prod_emb UNIV M {..n} (Pi\<^sub>E {..n} A)) = Q (prod_emb UNIV M {..n} (Pi\<^sub>E {..n} A))"
  assumes A: "finite_measure P"
  shows "P = Q"
proof (rule measure_eqI_PiM_infinite[OF * _ A])
  fix J :: "nat set" and F'
  assume J: "finite J" "\<And>i. i \<in> J \<Longrightarrow> F' i \<in> sets (M i)"

  define n where "n = (if J = {} then 0 else Max J)"
  define F where "F i = (if i \<in> J then F' i else space (M i))" for i
  then have F[simp, measurable]: "F i \<in> sets (M i)" for i
    using J by auto
  have emb_eq: "prod_emb UNIV M J (Pi\<^sub>E J F') = prod_emb UNIV M {..n} (Pi\<^sub>E {..n} F)"
  proof cases
    assume "J = {}" then show ?thesis
      by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
  next
    assume "J \<noteq> {}" then show ?thesis
      by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le \<open>finite J\<close> split: if_split_asm)
  qed

  show "emeasure P (prod_emb UNIV M J (Pi\<^sub>E J F')) = emeasure Q (prod_emb UNIV M J (Pi\<^sub>E J F'))"
    unfolding emb_eq by (rule eq) fact
qed

lemma distr_cong_simp:
  "M = K \<Longrightarrow> sets N = sets L \<Longrightarrow> (\<And>x. x \<in> space M =simp=> f x = g x) \<Longrightarrow> distr M N f = distr K L g"
  unfolding simp_implies_def by (rule distr_cong)

subsection \<open>Definition and Basic Properties\<close>

locale discrete_MDP =
  fixes Ms :: "'s measure"
    and Ma :: "'a measure"
    and A :: "'s \<Rightarrow> 'a set"
    and K :: "'s \<times> 'a \<Rightarrow> 's measure"
    (* The valid actions are measurable subsets of all actions *)
  assumes A_s: "\<And>s. A s \<in> sets Ma"
    (* There always exists a valid action *)
  assumes A_ne: "\<And>s. A s \<noteq> {}"
    (* Assume the existence of at least 1 policy *)
  assumes ex_pol: "\<exists>\<delta> \<in> Ms \<rightarrow>\<^sub>M Ma. \<forall>s. \<delta> s \<in> A s"
    (* The kernel maps a state-action pair to a distribution over states *)
  assumes K[measurable]: "K \<in> Ms \<Otimes>\<^sub>M Ma \<rightarrow>\<^sub>M prob_algebra Ms"
begin

lemma space_prodI[intro]: "x \<in> space A' \<Longrightarrow> y \<in> space B \<Longrightarrow> (x,y) \<in> space (A' \<Otimes>\<^sub>M B)"
  by (auto simp add: space_pair_measure)

abbreviation "M \<equiv> Ms \<Otimes>\<^sub>M Ma"
abbreviation "Ma_A s \<equiv> restrict_space Ma (A s)"

lemma space_ma[intro]: "s \<in> space Ms \<Longrightarrow> a \<in> space Ma \<Longrightarrow> (s,a) \<in> space M"
  by (simp add: space_pair_measure)

lemma space_x0[simp]: "x0 \<in> space (prob_algebra Ms) \<Longrightarrow> space x0 = space Ms"
  by (metis (mono_tags, lifting) space_prob_algebra mem_Collect_eq sets_eq_imp_space_eq)

lemma A_subs_Ma: "A s \<subseteq> space Ma"
  by (simp add: A_s sets.sets_into_space)

lemma space_Ma_A_subset: "s \<in> space Ms \<Longrightarrow> space (Ma_A s) \<subseteq> A s"
  by (simp add: space_restrict_space)

lemma K_restrict [measurable]: "K \<in> (Ms \<Otimes>\<^sub>M Ma_A s) \<rightarrow>\<^sub>M prob_algebra Ms"
  by measurable (metis measurable_id measurable_pair_iff measurable_restrict_space2_iff)

lemma measurable_K_act[measurable, intro]: "s \<in> space Ms \<Longrightarrow> (\<lambda>a. K (s, a)) \<in> Ma \<rightarrow>\<^sub>M prob_algebra Ms"
  by measurable

lemma measurable_K_st[measurable, intro]: "a \<in> space Ma \<Longrightarrow> (\<lambda>s. K (s, a)) \<in> Ms \<rightarrow>\<^sub>M prob_algebra Ms"
  by measurable

lemma space_K[simp]: "sa \<in> space M \<Longrightarrow> space (K sa) = space Ms"
  using K unfolding prob_algebra_def measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma space_K2[simp]: "s \<in> space Ms \<Longrightarrow> a \<in> space Ma \<Longrightarrow> space (K (s, a)) = space Ms"
  by (simp add: space_pair_measure)

lemma space_K_E: "s' \<in> space (K (s,a)) \<Longrightarrow> s \<in> space Ms \<Longrightarrow> a \<in> space Ma \<Longrightarrow> s' \<in> space Ms"
  by auto

lemma sets_K: "sa \<in> space M \<Longrightarrow> sets (K sa) = sets Ms"
  using K unfolding prob_algebra_def unfolding measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma sets_K'[measurable_cong]: "s \<in> space Ms \<Longrightarrow> a \<in> space Ma \<Longrightarrow> sets (K (s,a)) = sets Ms"
  by (simp add: sets_K space_pair_measure)

lemma prob_space_K[intro]: "sa \<in> space M \<Longrightarrow> prob_space (K sa)"
  using measurable_space[OF K] by (simp add: space_prob_algebra)

lemma prob_space_K2[intro]: "s \<in> space Ms \<Longrightarrow> a \<in> space Ma \<Longrightarrow> prob_space (K (s,a))"
  using prob_space_K by (simp add: space_pair_measure)

lemma K_in_space [intro]: "m \<in> space M \<Longrightarrow> K m \<in> space (prob_algebra Ms)"
  by (meson K measurable_space)

subsection \<open>Policies\<close>
  (* This section represents our own developments. *)

type_synonym ('c, 'd) pol = "nat \<Rightarrow> ((nat \<Rightarrow> 'c \<times> 'd) \<times> 'c) \<Rightarrow> 'd measure"

(* History of i steps *)
abbreviation "H i \<equiv> Pi\<^sub>M {0..<i} (\<lambda>_. M)"
  (* + current state *)
abbreviation "Hs i \<equiv>  H i \<Otimes>\<^sub>M Ms"

lemma space_H1: "j < (i :: nat)  \<Longrightarrow> \<omega> \<in> space (H i) \<Longrightarrow> \<omega> j \<in> space M"
  using PiE_def
  by (auto simp: space_PiM)

lemma space_case_nat[intro]:
  assumes "\<omega> \<in> space (H i)" "s \<in> space Ms"
  shows "case_nat s (fst \<circ> \<omega>) i \<in> space Ms"
  using assms
  by (cases i) (auto intro!: space_H1 measurable_space[OF measurable_fst])

lemma undefined_in_H0: "(\<lambda>_. undefined) \<in> space (H (0 :: nat))"
  by auto

lemma sets_K_Suc[measurable_cong]: "h \<in> space (H (Suc n)) \<Longrightarrow> sets (K (h n)) = sets Ms"
  using sets_K space_H1 by blast

text\<open>A decision rule is a function from states to distributions over enabled actions.\<close>
definition "is_dec0 d \<equiv> d \<in> Ms \<rightarrow>\<^sub>M prob_algebra Ma "

definition "is_dec (t :: nat) d \<equiv> (d \<in> Hs t \<rightarrow>\<^sub>M prob_algebra Ma) "

lemma "is_dec0 d \<Longrightarrow> is_dec t (\<lambda>(_,s). d s)"
  unfolding is_dec0_def is_dec_def by auto

text\<open>A policy is a function from histories to valid decision rules.\<close>
definition is_policy :: "('s, 'a) pol \<Rightarrow> bool" where
  "is_policy p \<equiv> \<forall>i. is_dec i (p i)"

(* selects the next action without history *)
abbreviation p0 :: "('s, 'a) pol \<Rightarrow> 's \<Rightarrow> 'a measure" where
  "p0 p s \<equiv> p (0 ::nat) (\<lambda>_. undefined, s)"

context
  fixes p assumes p[simp]: "is_policy p"
begin

lemma is_policyD[measurable]: "p i \<in> Hs i \<rightarrow>\<^sub>M prob_algebra Ma"
  using p unfolding is_policy_def is_dec_def by auto

lemma space_policy[simp]: "hs \<in> space (Hs i) \<Longrightarrow> space (p i hs) = space Ma"
  using K is_policyD unfolding prob_algebra_def measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma space_policy'[simp]: "h \<in> space (H i) \<Longrightarrow> s \<in> space Ms \<Longrightarrow> space (p i (h,s)) = space Ma"
  using space_policy
  by (simp add: space_pair_measure)

lemma space_policyI[intro]:
  assumes "s \<in> space Ms" "h \<in> space (H i)" "a \<in> space Ma"
  shows "a \<in> space (p i (h,s))"
  using space_policy assms
  by (auto simp: space_pair_measure)

lemma sets_policy[simp]: "hs \<in> space (Hs i) \<Longrightarrow> sets (p i hs) = sets Ma"
  using p K is_policyD
  unfolding prob_algebra_def measurable_restrict_space2_iff
  by (auto dest: subprob_measurableD)

lemma sets_policy'[measurable_cong, simp]:
  "h \<in> space (H i) \<Longrightarrow> s \<in> space Ms \<Longrightarrow> sets (p i (h,s)) = sets Ma"
  using sets_policy
  by (auto simp: space_pair_measure)

lemma sets_policy''[measurable_cong, simp]:
  "h \<in> space ((Pi\<^sub>M {} (\<lambda>_. M))) \<Longrightarrow> s \<in> space Ms \<Longrightarrow> sets (p 0 (h,s)) = sets Ma"
  using sets_policy
  by (auto simp: space_pair_measure)

lemma policy_prob_space: "hs \<in> space (Hs i) \<Longrightarrow> prob_space (p i hs)"
proof -
  assume h: "hs \<in> space (Hs i)"
  hence "p i hs \<in> space (prob_algebra Ma)"
    using p by (auto intro: measurable_space)
  thus "prob_space (p i hs)"
    unfolding prob_algebra_def by (simp add: space_restrict_space)
qed

lemma policy_prob_space': "h \<in> space (H i) \<Longrightarrow> s \<in> space Ms \<Longrightarrow> prob_space (p i (h,s))"
  using policy_prob_space by (simp add: space_pair_measure)

lemma prob_space_p0: "x \<in> space Ms \<Longrightarrow> prob_space (p0 p x)"
  by (simp add: policy_prob_space')

lemma p0_sets[measurable_cong]: "x \<in> space Ms \<Longrightarrow> sets (p 0 (\<lambda>_. undefined,x)) = sets Ma"
  using subprob_measurableD(2) measurable_prob_algebraD by simp

lemma space_p0[simp]: "s \<in> space Ms \<Longrightarrow> space (p0 p s) = space Ma"
  by auto

lemma return_policy_prob_algebra [measurable]:
  "h \<in> space (H n) \<Longrightarrow> x \<in> space Ms \<Longrightarrow> (\<lambda>a. return M (x, a)) \<in> p n (h, x) \<rightarrow>\<^sub>M prob_algebra M"
  by measurable
end

subsection \<open>Successor Policy\<close>
text \<open>To shift the policy by one step, we provide a single state-action pair as history\<close>
definition "Suc_policy p sa = (\<lambda>i (h, s). p (Suc i) (\<lambda>i'. case_nat sa h i', s))"

lemma p_as_Suc_policy: "p (Suc i) (h, s) = Suc_policy p ((h 0)) i (\<lambda>i. h (Suc i), s)"
proof -
  have *: "case_nat (f 0) (\<lambda>i. f (Suc i)) = f" for f
    by (auto split: nat.splits)
  show ?thesis
    unfolding Suc_policy_def
    by (auto simp: *)
qed

lemma is_policy_Suc_policy[intro]:
  assumes s: "sa \<in> space M" and p: "is_policy p"
  shows "is_policy (Suc_policy p sa)"
proof -
  have *: "(\<lambda>x. case_nat sa (fst x)) \<in> Pi\<^sub>M {0..<i} (\<lambda>_. M) \<Otimes>\<^sub>M Ms \<rightarrow>\<^sub>M Pi\<^sub>M {0..<Suc i} (\<lambda>_. M)" for i
    using s space_H1
    by (intro  measurable_PiM_single) (fastforce simp: space_PiM space_pair_measure split: nat.splits)+
  have "\<And>i. p i \<in> Pi\<^sub>M {0..<i} (\<lambda>_. M) \<Otimes>\<^sub>M Ms \<rightarrow>\<^sub>M prob_algebra Ma"
    using is_policyD p by blast
  hence "\<And>i. Suc_policy p sa i \<in> Pi\<^sub>M {0..<i} (\<lambda>_. M) \<Otimes>\<^sub>M Ms \<rightarrow>\<^sub>M prob_algebra Ma"
    unfolding Suc_policy_def
    using *
    by measurable
  thus ?thesis unfolding is_policy_def is_dec_def
    by blast
qed

lemma Suc_policy_measurable_step[measurable]:
  assumes "is_policy p"
  shows "(\<lambda>x. Suc_policy p (fst (fst x)) n (snd (fst x), snd x)) \<in>
    (M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M)) \<Otimes>\<^sub>M Ms \<rightarrow>\<^sub>M prob_algebra Ma"
  unfolding Suc_policy_def
  using assms
  by measurable (auto
      intro: measurable_PiM_single'
      simp:  space_pair_measure PiE_iff space_PiM extensional_def
      split: nat.split)

subsection \<open>Single-Step Distribution\<close>

text\<open>@{term "K'"} takes
  a policy,
  a distribution over 's,
  the epoch,
  and a history,
  produces a distribution over the next state-action pair.\<close>
definition K' :: "('s, 'a) pol \<Rightarrow> 's measure \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> ('s \<times> 'a)) \<Rightarrow> ('s \<times> 'a) measure"
  where
    "K' p s0 n \<omega> = do {
    s \<leftarrow> case_nat s0 (K \<circ> \<omega>) n;
    a \<leftarrow> p n (\<omega>, s);
    return M (s, a)
}"

lemma prob_space_K':
  assumes p: "is_policy p" and x: "x0 \<in> space (prob_algebra Ms)" and h: "h \<in> space (H n)"
  shows "prob_space (K' p x0 n h)"
  unfolding K'_def
proof (intro prob_space.prob_space_bind[where S = M])
  show "prob_space (case n of 0 \<Rightarrow> x0 | Suc x \<Rightarrow> (K \<circ> h) x)"
    using x h space_H1 by (auto split: nat.splits simp: space_prob_algebra)
next
  show "AE x in case n of 0 \<Rightarrow> x0 | Suc x \<Rightarrow> (K \<circ> h) x.
    prob_space (p n (h, x) \<bind> (\<lambda>a. return M (x, a)))"
  proof (cases n)
    case 0
    then have h': "h \<in> space (Pi\<^sub>M {0..<0} (\<lambda>_. M))"
      using h by auto
    show ?thesis
      using 0 p h x sets_policy'
      by (fastforce intro: prob_space.prob_space_bind[where S=M]
          policy_prob_space prob_space_return
          cong: measurable_cong_sets)
  next
    case (Suc nat)
    then show ?thesis
    proof (intro AE_I2 prob_space.prob_space_bind[of _ _ M], goal_cases)
      case (1 x)
      then show ?case
        using p space_H1 h x
        by (fastforce intro!: policy_prob_space)
    next
      case (2 x a)
      then show ?case
        using h p space_H1
        by (fastforce intro!: prob_space_return)
    next
      case (3 x)
      then show ?case
        using p h x space_K space_H1
        by (fastforce intro!: measurable_prob_algebraD return_policy_prob_algebra)
    qed
  qed
next
  show "(\<lambda>s. p n (h, s) \<bind> (\<lambda>a. return M (s, a))) \<in>
    (case n of 0 \<Rightarrow> x0 | Suc x \<Rightarrow> (K \<circ> h) x) \<rightarrow>\<^sub>M subprob_algebra M"
  proof (intro measurable_bind[where N = Ma])
    show " (\<lambda>x. p n (h, x)) \<in> (case n of 0 \<Rightarrow> x0 | Suc x \<Rightarrow> (K \<circ> h) x) \<rightarrow>\<^sub>M subprob_algebra Ma"
      using p h x
      by (auto split: nat.splits intro!: measurable_prob_algebraD simp: space_prob_algebra)
  next
    show "(\<lambda>s. return M (fst s, snd s)) \<in>
      (case n of 0 \<Rightarrow> x0 | Suc x \<Rightarrow> (K \<circ> h) x) \<Otimes>\<^sub>M Ma \<rightarrow>\<^sub>M subprob_algebra M"
      using h x sets_K_Suc
      by (auto split: nat.splits simp: sets_K space_prob_algebra cong: measurable_cong_sets)
  qed
qed

lemma measurable_K'[measurable]:
  assumes p: "is_policy p" and x: "x \<in> space (prob_algebra Ms)"
  shows "K' p x i \<in> H i \<rightarrow>\<^sub>M prob_algebra M"
proof -
  fix i
  show "K' p x i \<in> Pi\<^sub>M {0..<i} (\<lambda>_. M) \<rightarrow>\<^sub>M prob_algebra M"
    unfolding K'_def
  proof (intro measurable_bind_prob_space2[where N = Ms])
    show "(\<lambda>a. case i of 0 \<Rightarrow> x | Suc x \<Rightarrow> (K \<circ> a) x) \<in> Pi\<^sub>M {0..<i} (\<lambda>_. M) \<rightarrow>\<^sub>M prob_algebra Ms"
      using x by measurable auto
  next
    show "(\<lambda>(\<omega>, y). p i (\<omega>, y) \<bind> (\<lambda>a. return M (y, a))) \<in>
      Pi\<^sub>M {0..<i} (\<lambda>_. M) \<Otimes>\<^sub>M Ms \<rightarrow>\<^sub>M prob_algebra M"
      using x p by auto
  qed
qed

subsection \<open>Initial State-Action Distribution\<close>

text \<open>@{term "K0"} produces the initial state-action distribution from a state distribution
 and a policy.\<close>

definition "K0 p s0 = K' p s0 0 (\<lambda>_. undefined)"

lemma K0_def':
  "K0 p s0 = do {
    s \<leftarrow> s0;
    a \<leftarrow> p0 p s;
    return M (s, a)}"
  unfolding K0_def K'_def by auto

lemma K0_prob[measurable]: "is_policy p \<Longrightarrow> K0 p \<in> prob_algebra Ms \<rightarrow>\<^sub>M prob_algebra M"
  unfolding K0_def'
  by measurable

lemma prob_space_K0: "is_policy p \<Longrightarrow> x0 \<in> space (prob_algebra Ms) \<Longrightarrow> prob_space (K0 p x0)"
  by (simp add: K0_def prob_space_K')

lemma space_K0[simp]: "is_policy p \<Longrightarrow> s \<in> space (prob_algebra Ms) \<Longrightarrow> space (K0 p s) = space M"
  by (meson K0_prob measurable_prob_algebraD sets_eq_imp_space_eq sets_kernel)

lemma sets_K0[measurable_cong]:
  assumes "is_policy p" "s \<in> space (prob_algebra Ms)"
  shows "sets (K0 p s) = sets M"
  using assms by (meson K0_prob measurable_prob_algebraD subprob_measurableD(2))

lemma K0_return_eq_p0:
  assumes "is_policy p" "s \<in> space Ms"
  shows "K0 p (return Ms s) = p0 p s \<bind> (\<lambda>a. return M (s,a))"
  unfolding K0_def'
  using assms
  by (subst bind_return[where N = M]) (auto intro!: measurable_prob_algebraD)

lemma M_ne_policy[intro]: "is_policy p \<Longrightarrow> s \<in> space (prob_algebra Ms) \<Longrightarrow> space M \<noteq> {}"
  using space_K0 prob_space.not_empty prob_space_K0
  by force

subsection \<open>Sequence Space of the MDP\<close>
text\<open>We can instantiate @{const Ionescu_Tulcea} with @{const K'}.\<close>
lemma IT_K': "is_policy p \<Longrightarrow> x \<in> space (prob_algebra Ms) \<Longrightarrow> Ionescu_Tulcea (K' p x) (\<lambda>_. M)"
  unfolding Ionescu_Tulcea_def using measurable_K' prob_space_K'
  by (fast dest: measurable_prob_algebraD)

definition lim_sequence :: "('s, 'a) pol \<Rightarrow> 's measure \<Rightarrow> (nat \<Rightarrow> ('s \<times> 'a)) measure"
  where
    "lim_sequence p x = projective_family.lim UNIV (Ionescu_Tulcea.CI (K' p x) (\<lambda>_. M)) (\<lambda>_. M)"

lemma
  assumes x: "x \<in> space (prob_algebra Ms)" and p: "is_policy p"
  shows space_lim_sequence: "space (lim_sequence p x) = space (\<Pi>\<^sub>M i\<in>UNIV. M)"
    and sets_lim_sequence[measurable_cong]: "sets (lim_sequence p x) = sets (\<Pi>\<^sub>M i\<in>UNIV. M)"
    and emeasure_lim_sequence_emb: "\<And>J X. finite J \<Longrightarrow> X \<in> sets (\<Pi>\<^sub>M j\<in>J. M) \<Longrightarrow>
      emeasure (lim_sequence p x) (prod_emb UNIV (\<lambda>_. M) J X) =
      emeasure (Ionescu_Tulcea.CI (K' p x) (\<lambda>_. M) J) X"
    and emeasure_lim_sequence_emb_I0o: "\<And>n X. X \<in> sets (\<Pi>\<^sub>M i \<in> {0..<n}. M) \<Longrightarrow>
      emeasure (lim_sequence p x) (prod_emb UNIV (\<lambda>_. M) {0..<n} X) =
      emeasure (Ionescu_Tulcea.C (K' p x) (\<lambda>_. M) 0 n (\<lambda>x. undefined)) X"
proof -
  interpret Ionescu_Tulcea "K' p x" "\<lambda>_. M"
    using IT_K'[OF p x] .
  show "space (lim_sequence p x) = space (\<Pi>\<^sub>M i\<in>UNIV. M)"
    unfolding lim_sequence_def by simp
  show "sets (lim_sequence p x) = sets (\<Pi>\<^sub>M i\<in>UNIV. M)"
    unfolding lim_sequence_def by simp

  { fix J :: "nat set" and X assume "finite J" "X \<in> sets (\<Pi>\<^sub>M j\<in>J. M)"
    then show "emeasure (lim_sequence p x) (PF.emb UNIV J X) = emeasure (CI J) X"
      unfolding lim_sequence_def by (rule lim) }
  note emb = this

  have up_to_I0o[simp]: "up_to {0..<n} = n" for n
    unfolding up_to_def by (rule Least_equality) auto

  { fix n :: nat and X assume "X \<in> sets (\<Pi>\<^sub>M j\<in>{0..<n}. M)"
    thus "emeasure (lim_sequence p x) (PF.emb UNIV {0..<n} X) = emeasure (C 0 n (\<lambda>x. undefined)) X"
      by (simp add: space_C emb CI_def space_PiM distr_id2 sets_C cong: distr_cong_simp) }
qed

lemma lim_sequence_prob_space:
  assumes "is_policy p" "s \<in> space (prob_algebra Ms)"
  shows "prob_space (lim_sequence p s)"
  using assms proof -
  assume p: "is_policy p"
  fix s assume [simp]: "s \<in> space (prob_algebra Ms)"
  interpret Ionescu_Tulcea "K' p s" "\<lambda>_. M"
    using IT_K' p by simp
  have sp:
    "space (lim_sequence p s) = prod_emb UNIV (\<lambda>_. M) {} (\<Pi>\<^sub>E j\<in>{}. space M)"
    "space (CI {}) = {} \<rightarrow>\<^sub>E space M"
    by (auto simp: p space_lim_sequence space_PiM prod_emb_def PF.space_P)
  show "prob_space (lim_sequence p s)"
    using PF.prob_space_P[THEN prob_space.emeasure_space_1, of "{}"]
    by (auto intro!: prob_spaceI simp add: p sp emeasure_lim_sequence_emb simp del: PiE_empty_domain)
qed

subsection \<open>Measurablility of the Sequence Space\<close>
lemma lim_sequence[measurable]:
  assumes p: "is_policy p"
  shows "lim_sequence p \<in> prob_algebra Ms \<rightarrow>\<^sub>M prob_algebra (\<Pi>\<^sub>M i\<in>UNIV. M)"
proof (intro measurable_prob_algebra_generated[OF sets_PiM Int_stable_prod_algebra
      prod_algebra_sets_into_space])
  show "\<And>a. a \<in> space (prob_algebra Ms) \<Longrightarrow> prob_space (lim_sequence p a)"
    using lim_sequence_prob_space p by blast
next
  fix a assume [simp]: "a \<in> space (prob_algebra Ms)"
  show "sets (lim_sequence p a) = sets (Pi\<^sub>M UNIV (\<lambda>i. M))"
    by (simp add: p sets_lim_sequence)
next
  fix X :: "(nat \<Rightarrow> 's \<times> 'a) set" assume "X \<in> prod_algebra UNIV (\<lambda>i. M)"
  then obtain J :: "nat set" and F where J: "J \<noteq> {}" "finite J" "F \<in> J \<rightarrow> sets M"
    and X: "X = prod_emb UNIV (\<lambda>_. M) J (Pi\<^sub>E J F)"
    unfolding prod_algebra_def by auto
  then have Pi_F: "finite J" "Pi\<^sub>E J F \<in> sets (Pi\<^sub>M J (\<lambda>_. M))"
    by (auto intro: sets_PiM_I_finite)

  define n where "n = (LEAST n. \<forall>i\<ge>n. i \<notin> J)"
  have J_le_n: "J \<subseteq> {0..<n}"
  proof -
    have "\<And>x. x \<in> J \<Longrightarrow> \<forall>i\<ge>Suc (Max J). i \<notin> J"
      using not_le Max_less_iff[OF \<open>finite J\<close>]
      by (auto simp: Suc_le_eq)
    moreover have "x \<in> J \<Longrightarrow> \<forall>i\<ge>a. i \<notin> J \<Longrightarrow> x < a" for x a
      using not_le by auto
    ultimately show ?thesis
      unfolding n_def
      by (fastforce intro!: LeastI2[of  "\<lambda>n. \<forall>i\<ge>n. i \<notin> J" "Suc (Max J)" "\<lambda>x. _ < x"])
  qed

  have C: "(\<lambda>x. Ionescu_Tulcea.C (K' p x) (\<lambda>_. M) 0 n (\<lambda>x. undefined)) \<in> prob_algebra Ms \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<n} (\<lambda>_. M))"
  proof (induction n)
    case 0
    thus ?case
      by (auto simp: measurable_cong[OF Ionescu_Tulcea.C.simps(1)[OF IT_K', OF p]])
  next
    case (Suc n)
    have "(\<lambda>w. Ionescu_Tulcea.eP (K' p (fst w)) (\<lambda>_. M) n (snd w))
    \<in> prob_algebra Ms \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<Suc n} (\<lambda>_. M))"
    proof (subst measurable_cong)
      fix w assume "w \<in> space (prob_algebra Ms \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M))"
      then show "Ionescu_Tulcea.eP (K' p (fst w)) (\<lambda>_. M) n (snd w) =
      distr (K' p (fst w) n (snd w)) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) (fun_upd (snd w) n)"
        by (auto simp: p space_pair_measure Ionescu_Tulcea.eP_def[OF IT_K'] split: prod.split)
    next
      show "(\<lambda>w. distr (K' p (fst w) n (snd w)) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) (fun_upd (snd w) n))
        \<in> prob_algebra Ms \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<Suc n} (\<lambda>_. M))"
      proof (rule measurable_distr2[where M = M])
        show "(\<lambda>(x, y). (snd x)(n := y)) \<in> (prob_algebra Ms \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M)) \<Otimes>\<^sub>M M \<rightarrow>\<^sub>M Pi\<^sub>M {0..<Suc n} (\<lambda>i. M)"
        proof (rule measurable_PiM_single')
          fix i assume "i \<in> {0..<Suc n}"
          then show "(\<lambda>\<omega>. (case \<omega> of (x, y) \<Rightarrow> (snd x)(n := y)) i) \<in> (prob_algebra Ms \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M)) \<Otimes>\<^sub>M M \<rightarrow>\<^sub>M M"
            unfolding split_beta' by (cases "i = n") auto
        next
          show "(\<lambda>\<omega>. case \<omega> of (x, y) \<Rightarrow> (snd x)(n := y)) \<in> space ((prob_algebra Ms \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M)) \<Otimes>\<^sub>M M) \<rightarrow> {0..<Suc n} \<rightarrow>\<^sub>E space M"
            by (auto simp: space_pair_measure space_PiM less_Suc_eq PiE_iff)
        qed
      next
        show "(\<lambda>x. K' p (fst x) n (snd x)) \<in> prob_algebra Ms \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra M"
          unfolding K'_def comp_def
          using p
          by (auto intro!: measurable_prob_algebraD)
      qed
    qed
    then show ?case
      using Suc.IH
      by (subst measurable_cong[OF Ionescu_Tulcea.C.simps(2)[OF IT_K', where p1 = p, OF p]])
        (auto intro!: measurable_bind)
  qed
  have *: "(\<lambda>x. Ionescu_Tulcea.CI (K' p x) (\<lambda>_. M) J) \<in> prob_algebra Ms \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M J (\<lambda>_. M))"
    using measurable_distr[OF measurable_restrict_subset[OF J_le_n], of "(\<lambda>_. M)"] C p
    by (subst measurable_cong)
      (auto simp: Ionescu_Tulcea.up_to_def[OF IT_K'] n_def Ionescu_Tulcea.CI_def[OF IT_K'])
  have "(\<lambda>a. emeasure (lim_sequence p a) X) \<in> borel_measurable (prob_algebra Ms) \<longleftrightarrow>
    (\<lambda>a. emeasure (Ionescu_Tulcea.CI (K' p a) (\<lambda>_. M) J) (Pi\<^sub>E J F)) \<in>
      borel_measurable (prob_algebra Ms)"
    unfolding X using J Pi_F by (intro p measurable_cong emeasure_lim_sequence_emb) auto
  also have "\<dots>"
    using * measurable_emeasure_subprob_algebra Pi_F(2) by auto
  finally show "(\<lambda>a. emeasure (lim_sequence p a) X) \<in> borel_measurable (prob_algebra Ms)" .
qed

lemma lim_sequence_aux[measurable]:
  assumes p: "is_policy p"
  assumes f : "\<And>x. x \<in> space M \<Longrightarrow> is_policy (f x)"
  assumes f': "\<And>n. (\<lambda>x. f (fst (fst x)) n (snd (fst x), snd x)) \<in>
    (M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M)) \<Otimes>\<^sub>M Ms \<rightarrow>\<^sub>M prob_algebra Ma"
  assumes gm: "g \<in> M \<rightarrow>\<^sub>M prob_algebra Ms"
  shows "(\<lambda>x. lim_sequence (f x) (g x)) \<in> M \<rightarrow>\<^sub>M prob_algebra (Pi\<^sub>M UNIV (\<lambda>_. M))"
proof (intro measurable_prob_algebra_generated[OF sets_PiM Int_stable_prod_algebra prod_algebra_sets_into_space])
  fix a assume a[simp]: "a \<in> space M"
  have g: "\<And>x. x \<in> space M \<Longrightarrow> g x \<in> space (prob_algebra Ms)"
    by (meson gm measurable_space)
  interpret Ionescu_Tulcea "K' (f a) (g a)" "\<lambda>_. M"
    using IT_K' p
    using f[OF \<open>a \<in> space M\<close>] g by measurable
  have p': "is_policy (f a)"
    using \<open>a \<in> space M\<close> p f by auto
  have sp:
    "space (lim_sequence (f a) (g a)) = prod_emb UNIV (\<lambda>_. M) {} (\<Pi>\<^sub>E j\<in>{}. space M)"
    "space (CI {}) = {} \<rightarrow>\<^sub>E space M"
    using g a p' by (auto simp: space_lim_sequence p' space_PiM prod_emb_def PF.space_P)
  have "emeasure (lim_sequence (f a) (g a)) (space (lim_sequence (f a) (g a))) = 1"
    unfolding sp
    using g a p' sets.top[of "(Pi\<^sub>M {} (\<lambda>_. M))", unfolded space_PiM_empty]
      PF.prob_space_P[THEN prob_space.emeasure_space_1, of "{}"]
    by (subst emeasure_lim_sequence_emb) (auto simp: emeasure_lim_sequence_emb sp)
  thus "prob_space (lim_sequence (f a) (g a))"
    by (auto intro: prob_spaceI)
  show "sets (lim_sequence (f a) (g a)) = sets (Pi\<^sub>M UNIV (\<lambda>i. M))"
    by (simp add: lim_sequence_def)
next
  fix X :: "(nat \<Rightarrow> 's \<times> 'a) set" assume "X \<in> prod_algebra UNIV (\<lambda>i. M)"
  then obtain J :: "nat set" and F where J: "J \<noteq> {}" "finite J" "F \<in> J \<rightarrow> sets M"
    and X: "X = prod_emb UNIV (\<lambda>_. M) J (Pi\<^sub>E J F)"
    unfolding prod_algebra_def by auto
  then have Pi_F: "finite J" "Pi\<^sub>E J F \<in> sets (Pi\<^sub>M J (\<lambda>_. M))"
    by (auto intro: sets_PiM_I_finite)

  define n where "n = (LEAST n. \<forall>i\<ge>n. i \<notin> J)"
  have J_le_n: "J \<subseteq> {0..<n}"
    unfolding n_def
    by (rule LeastI2[of _ "Suc (Max J)"]) (auto simp: \<open>finite J\<close> Suc_le_eq not_le[symmetric])

  have g: "\<And>x. x \<in> space M \<Longrightarrow> g x \<in> space (prob_algebra Ms)"
    by (meson gm measurable_space)

  have C: "(\<lambda>x. Ionescu_Tulcea.C (K' (f x) (g x)) (\<lambda>_. M) 0 n (\<lambda>x. undefined)) \<in>
    M \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<n} (\<lambda>_. M))"
  proof (induction n)
    case 0
    then show ?case
      using g f
      by (auto simp: measurable_cong[OF  Ionescu_Tulcea.C.simps(1)[OF IT_K']])
  next
    case (Suc n)
    then show ?case
    proof (subst measurable_cong[OF Ionescu_Tulcea.C.simps(2)[OF IT_K']])
      show "(\<lambda>w. Ionescu_Tulcea.C (K' (f w) (g w)) (\<lambda>_. M) 0 n (\<lambda>x. undefined) \<bind> Ionescu_Tulcea.eP (K' (f w) (g w)) (\<lambda>_. M) (0 + n))
    \<in> M \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<Suc n} (\<lambda>_. M))"
        if h: "(\<lambda>x. Ionescu_Tulcea.C (K' (f x) (g x)) (\<lambda>_. M) 0 n (\<lambda>x. undefined)) \<in> M \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<n} (\<lambda>_. M))"
      proof (rule measurable_bind'[OF h])
        show "(\<lambda>(x, y). Ionescu_Tulcea.eP (K' (f x) (g x)) (\<lambda>_. M) (0 + n) y) \<in> M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<Suc n} (\<lambda>_. M))"
        proof (subst measurable_cong)
          fix n :: nat and w assume "w \<in> space (M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M))"
          then show "(case w of (x, a) \<Rightarrow> Ionescu_Tulcea.eP (K' (f x) (g x)) (\<lambda>_. M) (0 + n) a) =
          (case w of (x, a) \<Rightarrow> distr (K' (f x) (g x) n a) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) (fun_upd a n))"
            by (auto simp: IT_K' Ionescu_Tulcea.eP_def f g space_ma p space_pair_measure
                Ionescu_Tulcea.eP_def[OF IT_K'])
        next
          fix n
          have "(\<lambda>w. distr (K' (f (fst w)) (g (fst w)) n (snd w)) (Pi\<^sub>M {0..<Suc n} (\<lambda>i. M)) (fun_upd (snd w) n))
              \<in> M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<Suc n} (\<lambda>_. M))"
          proof (intro measurable_distr2[where M=M] measurable_PiM_single', goal_cases)
            case (1 i)
            then show ?case
              by (cases "i = n") (auto simp: split_beta')
          next
            case 2
            then show ?case
              by (auto simp: split_beta' PiE_iff extensional_def Pi_iff space_pair_measure space_PiM)
          next
            case 3
            then show ?case
              unfolding K'_def
            proof (intro measurable_bind[where N = Ms], goal_cases)
              case 1
              then show ?case
                unfolding measurable_pair_swap_iff[of _ M]
                by measurable (auto simp: gm  measurable_snd'' intro: measurable_prob_algebraD)
            next
              case 2
              then show ?case
                unfolding Suc_policy_def
                using f'
                by (auto intro!: measurable_bind[where N = Ma] measurable_prob_algebraD)
            qed
          qed
          thus "(\<lambda>w. case w of (x, a) \<Rightarrow> distr ((K' (f x) (g x)) n a) (Pi\<^sub>M {0..<Suc n} (\<lambda>i. M)) (fun_upd a n)) \<in> M \<Otimes>\<^sub>M Pi\<^sub>M {0..<n} (\<lambda>_. M) \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M {0..<Suc n} (\<lambda>_. M))"
            by measurable
        qed
      qed
    qed (auto simp: f g)
  qed

  have p': "\<And>a. a \<in> space M \<Longrightarrow> is_policy (f a)"
    using f by auto
  have "(\<lambda>a. emeasure (lim_sequence (f a) (g a)) X) \<in> borel_measurable M \<longleftrightarrow>
    (\<lambda>a. emeasure (Ionescu_Tulcea.CI (K' (f a) (g a)) (\<lambda>_. M) J) (Pi\<^sub>E J F)) \<in> borel_measurable M"
    unfolding X using J Pi_F
    by (fastforce simp add: g f K space_pair_measure intro!: p p' measurable_cong emeasure_lim_sequence_emb)
  also have "..."
  proof (intro measurable_compose[OF _ measurable_emeasure_subprob_algebra[OF Pi_F(2)]],
      subst measurable_cong[where g = "(\<lambda>w. distr (Ionescu_Tulcea.C (K' (f w) (g w))
      (\<lambda>_. M) 0 n (\<lambda>x. undefined)) (Pi\<^sub>M J (\<lambda>_. M)) (\<lambda>f. restrict f J))"], goal_cases)
    case (1 w)
    then show ?case
      unfolding Ionescu_Tulcea.CI_def[OF IT_K'[OF f[OF 1] g[OF 1]]]
      using p
      by (subst Ionescu_Tulcea.up_to_def[OF IT_K'[of "Suc_policy p w" "K w"]])
        (auto simp add: n_def \<open>w \<in> space M\<close> prob_space_K sets_K space_prob_algebra)
  next
    case 2
    then show ?case
      using measurable_compose measurable_distr[OF measurable_restrict_subset[OF J_le_n]] C
      by blast
  qed
  thus "(\<lambda>a. emeasure (lim_sequence (f a) (g a)) X) \<in> borel_measurable M"
    using calculation by blast
qed

lemma lim_sequence_Suc_return[measurable]:
  assumes p: "is_policy p"
  assumes s: "s \<in> space Ms"
  shows "(\<lambda>x. lim_sequence (Suc_policy p (s, snd x)) (return Ms (fst x))) \<in>
    M \<rightarrow>\<^sub>M prob_algebra (Pi\<^sub>M UNIV (\<lambda>_. M))"
proof (intro lim_sequence_aux[OF p], goal_cases)
  case (1 x)
  then show ?case
    by (meson is_policy_Suc_policy measurable_snd measurable_space p s space_ma)
next
  case (2 n)
  then show ?case
    using p
    unfolding Suc_policy_def
    by measurable (auto intro: measurable_PiM_single'
        simp: s space_pair_measure space_PiM PiE_iff extensional_def split: nat.split)
qed measurable

lemma lim_sequence_Suc_K[measurable]:
  assumes "is_policy p"
  shows "(\<lambda>x. lim_sequence (Suc_policy p x) (K x)) \<in> M \<rightarrow>\<^sub>M prob_algebra (Pi\<^sub>M UNIV (\<lambda>_. M))"
  using assms
  by (fastforce intro!: lim_sequence_aux)

subsection \<open>Iteration Rule\<close>

  have [simp]: "space (K0 p x) \<noteq> {}"
    using space_K0[OF p x] x by auto

  have [simp]: "((\<lambda>_. undefined)(0 := x::('s \<times> 'a))) = case_nat x (\<lambda>_. undefined)" for x
    by (auto simp: fun_eq_iff split: nat.split)

  have "C 0 1 (\<lambda>_. undefined) \<bind> C 1 n = eP 0 (\<lambda>_. undefined) \<bind> C 1 n"
    using measurable_eP[of 0] measurable_C[of 1 n, measurable del]
    by (simp add: bind_return[where N="Pi\<^sub>M {0} (\<lambda>_. M)"])
  also have "\<dots> = K0 p x \<bind> (\<lambda>a. C 1 n (case_nat a (\<lambda>_. undefined)))"
    unfolding eP_def
  proof (subst bind_distr[where K = "Pi\<^sub>M {0..<Suc n} (\<lambda>_. M)"], goal_cases)
    case 1
    then show ?case
      using measurable_C[of 1 n, measurable del] x[THEN sets_K0[OF p]] measurable_ident_sets[OF sets_P]
      unfolding K0_def
      by auto
  next
    case 2
    then show ?case
      using measurable_C[of 1 n]
      by auto
  next
    case 3
    then show ?case
      by (simp add: space_P)
  next
    case 4
    then show ?case
      unfolding K0_def
      by (auto intro!: bind_cong)
  qed
  finally show
    "C 0 1 (\<lambda>_. undefined) \<bind> C 1 n = K0 p x \<bind> (\<lambda>a. C 1 n (case_nat a (\<lambda>_. undefined)))" .
qed

lemma lim_sequence_eq:
  assumes x: "x \<in> space (prob_algebra Ms)" assumes p: "is_policy p"
  shows "lim_sequence p x =
    K0 p x \<bind> (\<lambda>y. distr (lim_sequence (Suc_policy p y) (K y)) (\<Pi>\<^sub>M _\<in>UNIV. M) (case_nat y))"
    (is "_ = ?B p x")
proof (rule measure_eqI_PiM_infinite)
  show "sets (lim_sequence p x) = sets (\<Pi>\<^sub>M j\<in>UNIV. M)"
    using x p by (rule sets_lim_sequence)
  have [simp]: "space (K' p x 0 (\<lambda>n. undefined)) \<noteq> {}"
    using p
    using IT_K' Ionescu_Tulcea.non_empty Ionescu_Tulcea.space_P x by fastforce
  show "sets (?B p x) = sets (Pi\<^sub>M UNIV (\<lambda>j. M))"
    using p x M_ne_policy space_K0 by auto

  interpret lim_sequence: prob_space "lim_sequence p x"
    using lim_sequence x p by (auto simp: measurable_restrict_space2_iff prob_algebra_def)
  show "finite_measure (lim_sequence p x)"
    by (rule lim_sequence.finite_measure)

  interpret Ionescu_Tulcea "K' p x" "\<lambda>_. M"
    using  IT_K'[OF p x] .

  let ?U = "\<lambda>_::nat. undefined :: ('s \<times> 'a)"

  fix J :: "nat set" and F'
  assume J: "finite J" "\<And>i. i \<in> J \<Longrightarrow> F' i \<in> sets M"

  define n where "n = (if J = {} then 0 else Max J)"
  define F where "F i = (if i \<in> J then F' i else space M)" for i
  then have F[simp, measurable]: "F i \<in> sets M" for i
    using J by auto
  have emb_eq: "PF.emb UNIV J (Pi\<^sub>E J F') = PF.emb UNIV {0..<Suc n} (Pi\<^sub>E {0..<Suc n} F)"
  proof cases
    assume "J = {}" then show ?thesis
      by (auto simp add: n_def F_def[abs_def] prod_emb_def PiE_def)
  next
    assume "J \<noteq> {}" then show ?thesis
      by (auto simp: prod_emb_def PiE_iff F_def n_def less_Suc_eq_le \<open>finite J\<close> split: if_split_asm)
  qed

  have "emeasure (lim_sequence p x) (PF.emb UNIV J (Pi\<^sub>E J F')) =
    emeasure (C 0 (Suc n) ?U) (Pi\<^sub>E {0..<Suc n} F)"
    using x p unfolding emb_eq
    by (rule emeasure_lim_sequence_emb_I0o) (auto intro!: sets_PiM_I_finite)
  also have "C 0 (Suc n) ?U = K0 p x \<bind> (\<lambda>y. C 1 n (case_nat y ?U))"
    using split_C[of ?U 0 "Suc 0" n] step_C[OF x p] by simp
  also have "emeasure (K0 p x \<bind> (\<lambda>y. C 1 n (case_nat y ?U))) (Pi\<^sub>E {0..<Suc n} F) =
    (\<integral>\<^sup>+y. C 1 n (case_nat y ?U) (Pi\<^sub>E {0..<Suc n} F) \<partial>K0 p x)"
    using measurable_C[of 1 n, measurable del] sets_K0[OF p x] F x p non_empty space_K0
    by (intro emeasure_bind[OF  _ measurable_compose[OF _ measurable_C]])
      (auto cong: measurable_cong_sets intro!: measurable_PiM_single' split: nat.split_asm)
  also have "\<dots> = (\<integral>\<^sup>+y. distr (lim_sequence (Suc_policy p y) (K y))
    (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y) (PF.emb UNIV J (Pi\<^sub>E J F')) \<partial>K0 p x)"
  proof (intro nn_integral_cong)
    fix y assume "y \<in> space (K0 p x)"
    then have y: "y \<in> space M"
      using x p space_K0 by blast
    then interpret y: Ionescu_Tulcea "K' (Suc_policy p y) (K y)" "\<lambda>_. M"
      using p by (auto intro!: IT_K')
    have "fst y \<in> space Ms"
      by (meson measurable_fst measurable_space y)
    let ?y = "case_nat y"
    have [simp]: "?y ?U \<in> space (Pi\<^sub>M {0} (\<lambda>i. M))"
      using y by (auto simp: space_PiM PiE_iff extensional_def split: nat.split)
    have yM[measurable]: "?y \<in> Pi\<^sub>M {0..<m} (\<lambda>_. M) \<rightarrow>\<^sub>M Pi\<^sub>M {0..<Suc m} (\<lambda>i. M)" for m
      using y
      by (auto intro: measurable_PiM_single' simp: space_PiM PiE_iff extensional_def split: nat.split)
    have y': "?y ?U \<in> space (Pi\<^sub>M {0..<1} (\<lambda>i. M))"
      by (simp add: space_PiM PiE_def y extensional_def split: nat.split)

    have eq1: "?y -` Pi\<^sub>E {0..<Suc n} F \<inter> space (Pi\<^sub>M {0..<n} (\<lambda>_. M)) =
        (if y \<in> F 0 then Pi\<^sub>E {0..<n} (F\<circ>Suc) else {})"
      unfolding set_eq_iff using y sets.sets_into_space[OF F]
      by (auto simp: space_PiM PiE_iff extensional_def Ball_def split: nat.split nat.split_asm)

    have eq2: "?y -` PF.emb UNIV {0..<Suc n} (Pi\<^sub>E {0..<Suc n} F) \<inter> space (Pi\<^sub>M UNIV (\<lambda>_. M)) =
        (if y \<in> F 0 then PF.emb UNIV {0..<n} (Pi\<^sub>E {0..<n} (F\<circ>Suc)) else {})"
      unfolding set_eq_iff using y sets.sets_into_space[OF F]
      by (auto simp: space_PiM PiE_iff prod_emb_def extensional_def Ball_def split: nat.splits)

    let ?I = "indicator (F 0) y"
    have "fst y \<in> space Ms"
      using y by (meson measurable_fst measurable_space)
    have "C 1 n (?y ?U) = distr (y.C 0 n ?U) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) ?y"
    proof (induction n)
      case (Suc m)

      have "C 1 (Suc m) (?y ?U) = distr (y.C 0 m ?U) (Pi\<^sub>M {0..<Suc m} (\<lambda>i. M)) ?y \<bind> eP (Suc m)"
        using Suc by simp
      also have "\<dots> = y.C 0 m ?U \<bind> (\<lambda>x. eP (Suc m) (?y x))"
        by (auto intro!: bind_distr[where K="Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>_. M)"] simp: y y.space_C y.sets_C cong: measurable_cong_sets)
      also have "\<dots> = y.C 0 m ?U \<bind> (\<lambda>x. distr (y.eP m x) (Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>i. M)) ?y)"
      proof (intro bind_cong refl)
        fix \<omega>' assume \<omega>': "\<omega>' \<in> space (y.C 0 m ?U)"
        moreover have "K' p x (Suc m) (?y \<omega>') = K' (Suc_policy p y) (K y) m \<omega>'"
          unfolding K'_def Suc_policy_def
          by (auto split: nat.splits)
        ultimately show "eP (Suc m) (?y \<omega>') = distr (y.eP m \<omega>') (Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>i. M)) ?y"
          unfolding eP_def y.eP_def
          by (subst distr_distr) (auto simp: y.space_C y.sets_P split: nat.split cong: measurable_cong_sets
              intro!: distr_cong measurable_fun_upd[where J="{0..<m}"])
      qed
      also have "\<dots> = distr (y.C 0 m ?U \<bind> y.eP m) (Pi\<^sub>M {0..<Suc (Suc m)} (\<lambda>i. M)) ?y"
        by (auto intro!: distr_bind[symmetric, OF _ _ yM] simp: y.space_C y.sets_C cong: measurable_cong_sets)
      finally show ?case
        by simp
    qed (use y in \<open>simp add: PiM_empty distr_return\<close>)
    then have "C 1 n (case_nat y ?U) (Pi\<^sub>E {0..<Suc n} F) =
      (distr (y.C 0 n ?U) (\<Pi>\<^sub>M i\<in>{0..<Suc n}. M) ?y) (Pi\<^sub>E {0..<Suc n} F)" by simp
    also have "\<dots> = ?I * y.C 0 n ?U (Pi\<^sub>E {0..<n} (F \<circ> Suc))"
      by (subst emeasure_distr) (auto simp: y.sets_C y.space_C eq1 cong: measurable_cong_sets)
    also have
      "\<dots> = ?I * lim_sequence (Suc_policy p y) (K y) (PF.emb UNIV {0..<n} (Pi\<^sub>E {0..<n} (F \<circ> Suc)))"
      using y sets_PiM_I_finite
      by (subst emeasure_lim_sequence_emb_I0o) (auto simp add:  p sets_PiM_I_finite)
    also have "\<dots> = distr (lim_sequence (Suc_policy p y) (K y)) (Pi\<^sub>M UNIV (\<lambda>j. M)) ?y
      (PF.emb UNIV {0..<Suc n} (Pi\<^sub>E {0..<Suc n} F))"
    proof (subst emeasure_distr, goal_cases)
      case 1
      thus ?case
        using y
        by measurable (simp add: lim_sequence_def measurable_ident_sets)
      case 2
      thus ?case
        by auto
      case 3
      thus ?case
        using y
        by (subst space_lim_sequence[OF _ is_policy_Suc_policy[OF _ p]]) (auto simp: eq2)
    qed
    finally show "emeasure (C 1 n (case_nat y (\<lambda>_. undefined))) (Pi\<^sub>E {0..<Suc n} F) =
      emeasure (distr (lim_sequence (Suc_policy p y) (K y)) (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y))
        (y.PF.emb UNIV J (Pi\<^sub>E J F'))"
      unfolding emb_eq .
  qed
  also have "\<dots> = emeasure (K0 p x \<bind> (\<lambda>y. distr (lim_sequence (Suc_policy p y) (K y))
    (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y))) (PF.emb UNIV J (Pi\<^sub>E J F'))"
    using J sets_K0[OF \<open>is_policy p\<close> \<open>x \<in> space (prob_algebra Ms)\<close>] p
    by (subst emeasure_bind[where N="PiM UNIV (\<lambda>_. M)"]) (auto simp: sets_K x cong: measurable_cong_sets
        intro!: measurable_distr2[OF _ measurable_prob_algebraD[OF lim_sequence]]
        measurable_prob_algebraD
        measurable_distr2[where M = "PiM UNIV (\<lambda>_. M)"])
  finally show "emeasure (lim_sequence p x) (PF.emb UNIV J (Pi\<^sub>E J F')) =
    emeasure (K0 p x \<bind> (\<lambda>y. distr (lim_sequence (Suc_policy p y) (K y)) (Pi\<^sub>M UNIV (\<lambda>j. M))
      (case_nat y))) (PF.emb UNIV J (Pi\<^sub>E J F'))".
qed

subsection \<open>Stream Space of the MDP\<close>
definition lim_stream :: "('s, 'a) pol \<Rightarrow> 's measure \<Rightarrow> ('s \<times> 'a) stream measure"
  where
    "lim_stream p x = distr (lim_sequence p x) (stream_space M) to_stream"

lemma space_lim_stream: "space (lim_stream p x) = streams (space M)"
  unfolding lim_stream_def by (simp add: space_stream_space)

lemma sets_lim_stream[measurable_cong]: "sets (lim_stream p x) = sets (stream_space M)"
  unfolding lim_stream_def by simp

lemma lim_stream[measurable]:
  assumes "is_policy p"
  shows "lim_stream p \<in> prob_algebra Ms \<rightarrow>\<^sub>M prob_algebra (stream_space M)"
  unfolding lim_stream_def[abs_def]
  using assms
  by (auto intro: measurable_distr_prob_space2[OF lim_sequence])

lemma lim_stream_Suc[measurable]:
  assumes p: "is_policy p"
  shows "(\<lambda>a. lim_stream (Suc_policy p a) (K a)) \<in> M \<rightarrow>\<^sub>M prob_algebra (stream_space M)"
  unfolding lim_stream_def[abs_def]
  using p
  by (auto intro: measurable_distr_prob_space2[OF lim_sequence_Suc_K])

lemma space_stream_space_M_ne: "x \<in> space M \<Longrightarrow> space (stream_space M) \<noteq> {}"
  using sconst_streams[of x "space M"] by (auto simp: space_stream_space)

lemma prob_space_lim_stream[intro]:
  assumes "is_policy p" "x \<in> space (prob_algebra Ms)"
  shows "prob_space (lim_stream p x)"
  by (metis (no_types, lifting) space_prob_algebra measurable_space assms lim_stream mem_Collect_eq)

lemma prob_space_step:
  assumes "is_policy p" "x \<in> space M"
  shows "prob_space (lim_stream (Suc_policy p x) (K x))"
  by (auto simp: assms K_in_space is_policy_Suc_policy)

lemma lim_stream_eq:
  assumes p: "is_policy p"
  assumes x: "x \<in> space (prob_algebra Ms)"
  shows "lim_stream p x = do {
    y \<leftarrow> K0 p x;
    \<omega> \<leftarrow> lim_stream (Suc_policy p y) (K y);
    return (stream_space M) (y ## \<omega>)
  }"
  unfolding lim_stream_def lim_sequence_eq[OF x p]
proof (subst distr_bind[OF _ _ measurable_to_stream])
  show "(\<lambda>y. distr (lim_sequence (Suc_policy p y) (K y)) (Pi\<^sub>M UNIV (\<lambda>j. M)) (case_nat y)) \<in>
    K0 p x \<rightarrow>\<^sub>M subprob_algebra (Pi\<^sub>M UNIV (\<lambda>i. M))"
  proof (intro measurable_prob_algebraD measurable_distr_prob_space2[where M="Pi\<^sub>M UNIV (\<lambda>j. M)"])
    show "(\<lambda>x. lim_sequence (Suc_policy p x) (K x)) \<in> K0 p x \<rightarrow>\<^sub>M prob_algebra (Pi\<^sub>M UNIV (\<lambda>j. M))"
      using lim_sequence_Suc_K[OF p] sets_K0[OF p x] measurable_cong_sets
      by blast
  next show "(\<lambda>(ya, y). case_nat ya y) \<in> K0 p x \<Otimes>\<^sub>M Pi\<^sub>M UNIV (\<lambda>j. M) \<rightarrow>\<^sub>M Pi\<^sub>M UNIV (\<lambda>j. M)"
      using sets_K0[OF p x]
      by (subst measurable_cong_sets[of  _ "M \<Otimes>\<^sub>M Pi\<^sub>M UNIV (\<lambda>j. M)"]) auto
  qed
next
  show "space (K0 p x) \<noteq> {}"
    using x p prob_space.not_empty prob_space_K0
    by blast
next
  show "K0 p x \<bind> (\<lambda>x. distr (distr (lim_sequence (Suc_policy p x) (K x)) (Pi\<^sub>M UNIV (\<lambda>j. M))
    (case_nat x)) (stream_space M) to_stream) = K0 p x \<bind> (\<lambda>y. distr (lim_sequence (Suc_policy p y)
      (K y)) (stream_space M) to_stream \<bind> (\<lambda>\<omega>. return (stream_space M) (y ## \<omega>)))"
  proof (intro bind_cong refl, subst distr_distr)
    show "to_stream \<in> Pi\<^sub>M UNIV (\<lambda>j. M) \<rightarrow>\<^sub>M stream_space M"
      by measurable
  next
    show "\<And>a. a \<in> space (K0 p x) \<Longrightarrow>
      case_nat a \<in> lim_sequence (Suc_policy p a) (K a) \<rightarrow>\<^sub>M Pi\<^sub>M UNIV (\<lambda>j. M)"
      by measurable (auto simp: p x intro!: measurable_ident_sets sets_lim_sequence intro: measurable_space)
  next
    show "\<And>a. a \<in> space (K0 p x) \<Longrightarrow>
      distr (lim_sequence (Suc_policy p a) (K a)) (stream_space M) (to_stream \<circ> case_nat a) =
      distr (lim_sequence (Suc_policy p a) (K a)) (stream_space M) to_stream \<bind>
        (\<lambda>\<omega>. return (stream_space M) (a ## \<omega>))"
    proof (subst bind_return_distr', goal_cases)
      case (1 a)
      then show ?case by (simp add: p space_stream_space_M_ne x)
    next
      case (2 a)
      then show ?case using p x by (auto simp: sets_lim_sequence cong: measurable_cong_sets intro!: distr_cong)[1]
    next
      case (3 a)
      then show ?case
        using p x
        by (subst distr_distr) (auto simp: to_stream_nat_case intro!: measurable_compose[OF _ measurable_to_stream]
            sets_lim_sequence distr_cong measurable_ident_sets)
    qed
  qed
qed

end
end


theory prop_43
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun union :: "Nat list => Nat list => Nat list" where
  "union (Nil2) y = y"
  | "union (Cons2 z xs) y =
       (if elem z y then union xs y else Cons2 z (union xs y))"
  (*hipster equal2 elem union *)
  theorem x0 :
    "(elem x y) ==> (elem x (union z y))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


(*
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
  show "FunctorExt (MakeFtor F)" by(simp add: FunctorExt_def MakeFtor_def)
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


(*  Title:      HOL/HOLCF/Cfun.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section {* The type of continuous functions *}

theory Cfun
imports Cpodef Fun_Cpo Product_Cpo
begin

default_sort cpo

subsection {* Definition of continuous function type *}

definition "cfun = {f::'a => 'b. cont f}"

cpodef ('a, 'b) cfun (infixr "->" 0) = "cfun :: ('a => 'b) set"
  unfolding cfun_def by (auto intro: cont_const adm_cont)

type_notation (xsymbols)
  cfun  ("(_ \<rightarrow>/ _)" [1, 0] 0)

notation
  Rep_cfun  ("(_$/_)" [999,1000] 999)

notation (xsymbols)
  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)

notation (HTML output)
  Rep_cfun  ("(_\<cdot>/_)" [999,1000] 999)

subsection {* Syntax for continuous lambda abstraction *}

syntax "_cabs" :: "[logic, logic] \<Rightarrow> logic"

parse_translation {*
(* rewrite (_cabs x t) => (Abs_cfun (%x. t)) *)
  [Syntax_Trans.mk_binder_tr (@{syntax_const "_cabs"}, @{const_syntax Abs_cfun})];
*}

print_translation {*
  [(@{const_syntax Abs_cfun}, fn _ => fn [Abs abs] =>
      let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
      in Syntax.const @{syntax_const "_cabs"} $ x $ t end)]
*}  -- {* To avoid eta-contraction of body *}

text {* Syntax for nested abstractions *}

syntax
  "_Lambda" :: "[cargs, logic] \<Rightarrow> logic"  ("(3LAM _./ _)" [1000, 10] 10)

syntax (xsymbols)
  "_Lambda" :: "[cargs, logic] \<Rightarrow> logic" ("(3\<Lambda> _./ _)" [1000, 10] 10)

parse_ast_translation {*
(* rewrite (LAM x y z. t) => (_cabs x (_cabs y (_cabs z t))) *)
(* cf. Syntax.lambda_ast_tr from src/Pure/Syntax/syn_trans.ML *)
  let
    fun Lambda_ast_tr [pats, body] =
          Ast.fold_ast_p @{syntax_const "_cabs"}
            (Ast.unfold_ast @{syntax_const "_cargs"} (Ast.strip_positions pats), body)
      | Lambda_ast_tr asts = raise Ast.AST ("Lambda_ast_tr", asts);
  in [(@{syntax_const "_Lambda"}, K Lambda_ast_tr)] end;
*}

print_ast_translation {*
(* rewrite (_cabs x (_cabs y (_cabs z t))) => (LAM x y z. t) *)
(* cf. Syntax.abs_ast_tr' from src/Pure/Syntax/syn_trans.ML *)
  let
    fun cabs_ast_tr' asts =
      (case Ast.unfold_ast_p @{syntax_const "_cabs"}
          (Ast.Appl (Ast.Constant @{syntax_const "_cabs"} :: asts)) of
        ([], _) => raise Ast.AST ("cabs_ast_tr'", asts)
      | (xs, body) => Ast.Appl
          [Ast.Constant @{syntax_const "_Lambda"},
           Ast.fold_ast @{syntax_const "_cargs"} xs, body]);
  in [(@{syntax_const "_cabs"}, K cabs_ast_tr')] end
*}

text {* Dummy patterns for continuous abstraction *}
translations
  "\<Lambda> _. t" => "CONST Abs_cfun (\<lambda> _. t)"

subsection {* Continuous function space is pointed *}

lemma bottom_cfun: "\<bottom> \<in> cfun"
by (simp add: cfun_def inst_fun_pcpo)

instance cfun :: (cpo, discrete_cpo) discrete_cpo
by intro_classes (simp add: below_cfun_def Rep_cfun_inject)

instance cfun :: (cpo, pcpo) pcpo
by (rule typedef_pcpo [OF type_definition_cfun below_cfun_def bottom_cfun])

lemmas Rep_cfun_strict =
  typedef_Rep_strict [OF type_definition_cfun below_cfun_def bottom_cfun]

lemmas Abs_cfun_strict =
  typedef_Abs_strict [OF type_definition_cfun below_cfun_def bottom_cfun]

text {* function application is strict in its first argument *}

lemma Rep_cfun_strict1 [simp]: "\<bottom>\<cdot>x = \<bottom>"
by (simp add: Rep_cfun_strict)

lemma LAM_strict [simp]: "(\<Lambda> x. \<bottom>) = \<bottom>"
by (simp add: inst_fun_pcpo [symmetric] Abs_cfun_strict)

text {* for compatibility with old HOLCF-Version *}
lemma inst_cfun_pcpo: "\<bottom> = (\<Lambda> x. \<bottom>)"
by simp

subsection {* Basic properties of continuous functions *}

text {* Beta-equality for continuous functions *}

lemma Abs_cfun_inverse2: "cont f \<Longrightarrow> Rep_cfun (Abs_cfun f) = f"
by (simp add: Abs_cfun_inverse cfun_def)

lemma beta_cfun: "cont f \<Longrightarrow> (\<Lambda> x. f x)\<cdot>u = f u"
by (simp add: Abs_cfun_inverse2)

text {* Beta-reduction simproc *}

text {*
  Given the term @{term "(\<Lambda> x. f x)\<cdot>y"}, the procedure tries to
  construct the theorem @{term "(\<Lambda> x. f x)\<cdot>y == f y"}.  If this
  theorem cannot be completely solved by the cont2cont rules, then
  the procedure returns the ordinary conditional @{text beta_cfun}
  rule.

  The simproc does not solve any more goals that would be solved by
  using @{text beta_cfun} as a simp rule.  The advantage of the
  simproc is that it can avoid deeply-nested calls to the simplifier
  that would otherwise be caused by large continuity side conditions.

  Update: The simproc now uses rule @{text Abs_cfun_inverse2} instead
  of @{text beta_cfun}, to avoid problems with eta-contraction.
*}

simproc_setup beta_cfun_proc ("Rep_cfun (Abs_cfun f)") = {*
  fn phi => fn ctxt => fn ct =>
    let
      val dest = Thm.dest_comb;
      val f = (snd o dest o snd o dest) ct;
      val [T, U] = Thm.dest_ctyp (ctyp_of_term f);
      val tr = instantiate' [SOME T, SOME U] [SOME f]
          (mk_meta_eq @{thm Abs_cfun_inverse2});
      val rules = Named_Theorems.get ctxt @{named_theorems cont2cont};
      val tac = SOLVED' (REPEAT_ALL_NEW (match_tac ctxt (rev rules)));
    in SOME (perhaps (SINGLE (tac 1)) tr) end
*}

text {* Eta-equality for continuous functions *}

lemma eta_cfun: "(\<Lambda> x. f\<cdot>x) = f"
by (rule Rep_cfun_inverse)

text {* Extensionality for continuous functions *}

lemma cfun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f\<cdot>x = g\<cdot>x)"
by (simp add: Rep_cfun_inject [symmetric] fun_eq_iff)

lemma cfun_eqI: "(\<And>x. f\<cdot>x = g\<cdot>x) \<Longrightarrow> f = g"
by (simp add: cfun_eq_iff)

text {* Extensionality wrt. ordering for continuous functions *}

lemma cfun_below_iff: "f \<sqsubseteq> g \<longleftrightarrow> (\<forall>x. f\<cdot>x \<sqsubseteq> g\<cdot>x)"
by (simp add: below_cfun_def fun_below_iff)

lemma cfun_belowI: "(\<And>x. f\<cdot>x \<sqsubseteq> g\<cdot>x) \<Longrightarrow> f \<sqsubseteq> g"
by (simp add: cfun_below_iff)

text {* Congruence for continuous function application *}

lemma cfun_cong: "\<lbrakk>f = g; x = y\<rbrakk> \<Longrightarrow> f\<cdot>x = g\<cdot>y"
by simp

lemma cfun_fun_cong: "f = g \<Longrightarrow> f\<cdot>x = g\<cdot>x"
by simp

lemma cfun_arg_cong: "x = y \<Longrightarrow> f\<cdot>x = f\<cdot>y"
by simp

subsection {* Continuity of application *}

lemma cont_Rep_cfun1: "cont (\<lambda>f. f\<cdot>x)"
by (rule cont_Rep_cfun [OF cont_id, THEN cont2cont_fun])

lemma cont_Rep_cfun2: "cont (\<lambda>x. f\<cdot>x)"
apply (cut_tac x=f in Rep_cfun)
apply (simp add: cfun_def)
done

lemmas monofun_Rep_cfun = cont_Rep_cfun [THEN cont2mono]

lemmas monofun_Rep_cfun1 = cont_Rep_cfun1 [THEN cont2mono]
lemmas monofun_Rep_cfun2 = cont_Rep_cfun2 [THEN cont2mono]

text {* contlub, cont properties of @{term Rep_cfun} in each argument *}

lemma contlub_cfun_arg: "chain Y \<Longrightarrow> f\<cdot>(\<Squnion>i. Y i) = (\<Squnion>i. f\<cdot>(Y i))"
by (rule cont_Rep_cfun2 [THEN cont2contlubE])

lemma contlub_cfun_fun: "chain F \<Longrightarrow> (\<Squnion>i. F i)\<cdot>x = (\<Squnion>i. F i\<cdot>x)"
by (rule cont_Rep_cfun1 [THEN cont2contlubE])

text {* monotonicity of application *}

lemma monofun_cfun_fun: "f \<sqsubseteq> g \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>x"
by (simp add: cfun_below_iff)

lemma monofun_cfun_arg: "x \<sqsubseteq> y \<Longrightarrow> f\<cdot>x \<sqsubseteq> f\<cdot>y"
by (rule monofun_Rep_cfun2 [THEN monofunE])

lemma monofun_cfun: "\<lbrakk>f \<sqsubseteq> g; x \<sqsubseteq> y\<rbrakk> \<Longrightarrow> f\<cdot>x \<sqsubseteq> g\<cdot>y"
by (rule below_trans [OF monofun_cfun_fun monofun_cfun_arg])

text {* ch2ch - rules for the type @{typ "'a -> 'b"} *}

lemma chain_monofun: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
by (erule monofun_Rep_cfun2 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfunR: "chain Y \<Longrightarrow> chain (\<lambda>i. f\<cdot>(Y i))"
by (rule monofun_Rep_cfun2 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfunL: "chain F \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>x)"
by (rule monofun_Rep_cfun1 [THEN ch2ch_monofun])

lemma ch2ch_Rep_cfun [simp]:
  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> chain (\<lambda>i. (F i)\<cdot>(Y i))"
by (simp add: chain_def monofun_cfun)

lemma ch2ch_LAM [simp]:
  "\<lbrakk>\<And>x. chain (\<lambda>i. S i x); \<And>i. cont (\<lambda>x. S i x)\<rbrakk> \<Longrightarrow> chain (\<lambda>i. \<Lambda> x. S i x)"
by (simp add: chain_def cfun_below_iff)

text {* contlub, cont properties of @{term Rep_cfun} in both arguments *}

lemma lub_APP:
  "\<lbrakk>chain F; chain Y\<rbrakk> \<Longrightarrow> (\<Squnion>i. F i\<cdot>(Y i)) = (\<Squnion>i. F i)\<cdot>(\<Squnion>i. Y i)"
by (simp add: contlub_cfun_fun contlub_cfun_arg diag_lub)

lemma lub_LAM:
  "\<lbrakk>\<And>x. chain (\<lambda>i. F i x); \<And>i. cont (\<lambda>x. F i x)\<rbrakk>
    \<Longrightarrow> (\<Squnion>i. \<Lambda> x. F i x) = (\<Lambda> x. \<Squnion>i. F i x)"
by (simp add: lub_cfun lub_fun ch2ch_lambda)

lemmas lub_distribs = lub_APP lub_LAM

text {* strictness *}

lemma strictI: "f\<cdot>x = \<bottom> \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
apply (rule bottomI)
apply (erule subst)
apply (rule minimal [THEN monofun_cfun_arg])
done

text {* type @{typ "'a -> 'b"} is chain complete *}

lemma lub_cfun: "chain F \<Longrightarrow> (\<Squnion>i. F i) = (\<Lambda> x. \<Squnion>i. F i\<cdot>x)"
by (simp add: lub_cfun lub_fun ch2ch_lambda)

subsection {* Continuity simplification procedure *}

text {* cont2cont lemma for @{term Rep_cfun} *}

lemma cont2cont_APP [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes t: "cont (\<lambda>x. t x)"
  shows "cont (\<lambda>x. (f x)\<cdot>(t x))"
proof -
  have 1: "\<And>y. cont (\<lambda>x. (f x)\<cdot>y)"
    using cont_Rep_cfun1 f by (rule cont_compose)
  show "cont (\<lambda>x. (f x)\<cdot>(t x))"
    using t cont_Rep_cfun2 1 by (rule cont_apply)
qed

text {*
  Two specific lemmas for the combination of LCF and HOL terms.
  These lemmas are needed in theories that use types like @{typ "'a \<rightarrow> 'b \<Rightarrow> 'c"}.
*}

lemma cont_APP_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s)"
by (rule cont2cont_APP [THEN cont2cont_fun])

lemma cont_APP_app_app [simp]: "\<lbrakk>cont f; cont g\<rbrakk> \<Longrightarrow> cont (\<lambda>x. ((f x)\<cdot>(g x)) s t)"
by (rule cont_APP_app [THEN cont2cont_fun])

text {* cont2mono Lemma for @{term "%x. LAM y. c1(x)(y)"} *}

lemma cont2mono_LAM:
  "\<lbrakk>\<And>x. cont (\<lambda>y. f x y); \<And>y. monofun (\<lambda>x. f x y)\<rbrakk>
    \<Longrightarrow> monofun (\<lambda>x. \<Lambda> y. f x y)"
  unfolding monofun_def cfun_below_iff by simp

text {* cont2cont Lemma for @{term "%x. LAM y. f x y"} *}

text {*
  Not suitable as a cont2cont rule, because on nested lambdas
  it causes exponential blow-up in the number of subgoals.
*}

lemma cont2cont_LAM:
  assumes f1: "\<And>x. cont (\<lambda>y. f x y)"
  assumes f2: "\<And>y. cont (\<lambda>x. f x y)"
  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
proof (rule cont_Abs_cfun)
  fix x
  from f1 show "f x \<in> cfun" by (simp add: cfun_def)
  from f2 show "cont f" by (rule cont2cont_lambda)
qed

text {*
  This version does work as a cont2cont rule, since it
  has only a single subgoal.
*}

lemma cont2cont_LAM' [simp, cont2cont]:
  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo \<Rightarrow> 'c::cpo"
  assumes f: "cont (\<lambda>p. f (fst p) (snd p))"
  shows "cont (\<lambda>x. \<Lambda> y. f x y)"
using assms by (simp add: cont2cont_LAM prod_cont_iff)

lemma cont2cont_LAM_discrete [simp, cont2cont]:
  "(\<And>y::'a::discrete_cpo. cont (\<lambda>x. f x y)) \<Longrightarrow> cont (\<lambda>x. \<Lambda> y. f x y)"
by (simp add: cont2cont_LAM)

subsection {* Miscellaneous *}

text {* Monotonicity of @{term Abs_cfun} *}

lemma monofun_LAM:
  "\<lbrakk>cont f; cont g; \<And>x. f x \<sqsubseteq> g x\<rbrakk> \<Longrightarrow> (\<Lambda> x. f x) \<sqsubseteq> (\<Lambda> x. g x)"
by (simp add: cfun_below_iff)

text {* some lemmata for functions with flat/chfin domain/range types *}

lemma chfin_Rep_cfunR: "chain (Y::nat => 'a::cpo->'b::chfin)
      ==> !s. ? n. (LUB i. Y i)$s = Y n$s"
apply (rule allI)
apply (subst contlub_cfun_fun)
apply assumption
apply (fast intro!: lub_eqI chfin lub_finch2 chfin2finch ch2ch_Rep_cfunL)
done

lemma adm_chfindom: "adm (\<lambda>(u::'a::cpo \<rightarrow> 'b::chfin). P(u\<cdot>s))"
by (rule adm_subst, simp, rule adm_chfin)

subsection {* Continuous injection-retraction pairs *}

text {* Continuous retractions are strict. *}

lemma retraction_strict:
  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> f\<cdot>\<bottom> = \<bottom>"
apply (rule bottomI)
apply (drule_tac x="\<bottom>" in spec)
apply (erule subst)
apply (rule monofun_cfun_arg)
apply (rule minimal)
done

lemma injection_eq:
  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x = g\<cdot>y) = (x = y)"
apply (rule iffI)
apply (drule_tac f=f in cfun_arg_cong)
apply simp
apply simp
done

lemma injection_below:
  "\<forall>x. f\<cdot>(g\<cdot>x) = x \<Longrightarrow> (g\<cdot>x \<sqsubseteq> g\<cdot>y) = (x \<sqsubseteq> y)"
apply (rule iffI)
apply (drule_tac f=f in monofun_cfun_arg)
apply simp
apply (erule monofun_cfun_arg)
done

lemma injection_defined_rev:
  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; g\<cdot>z = \<bottom>\<rbrakk> \<Longrightarrow> z = \<bottom>"
apply (drule_tac f=f in cfun_arg_cong)
apply (simp add: retraction_strict)
done

lemma injection_defined:
  "\<lbrakk>\<forall>x. f\<cdot>(g\<cdot>x) = x; z \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> g\<cdot>z \<noteq> \<bottom>"
by (erule contrapos_nn, rule injection_defined_rev)

text {* a result about functions with flat codomain *}

lemma flat_eqI: "\<lbrakk>(x::'a::flat) \<sqsubseteq> y; x \<noteq> \<bottom>\<rbrakk> \<Longrightarrow> x = y"
by (drule ax_flat, simp)

lemma flat_codom:
  "f\<cdot>x = (c::'b::flat) \<Longrightarrow> f\<cdot>\<bottom> = \<bottom> \<or> (\<forall>z. f\<cdot>z = c)"
apply (case_tac "f\<cdot>x = \<bottom>")
apply (rule disjI1)
apply (rule bottomI)
apply (erule_tac t="\<bottom>" in subst)
apply (rule minimal [THEN monofun_cfun_arg])
apply clarify
apply (rule_tac a = "f\<cdot>\<bottom>" in refl [THEN box_equals])
apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
apply (erule minimal [THEN monofun_cfun_arg, THEN flat_eqI])
done

subsection {* Identity and composition *}

definition
  ID :: "'a \<rightarrow> 'a" where
  "ID = (\<Lambda> x. x)"

definition
  cfcomp  :: "('b \<rightarrow> 'c) \<rightarrow> ('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'c" where
  oo_def: "cfcomp = (\<Lambda> f g x. f\<cdot>(g\<cdot>x))"

abbreviation
  cfcomp_syn :: "['b \<rightarrow> 'c, 'a \<rightarrow> 'b] \<Rightarrow> 'a \<rightarrow> 'c"  (infixr "oo" 100)  where
  "f oo g == cfcomp\<cdot>f\<cdot>g"

lemma ID1 [simp]: "ID\<cdot>x = x"
by (simp add: ID_def)

lemma cfcomp1: "(f oo g) = (\<Lambda> x. f\<cdot>(g\<cdot>x))"
by (simp add: oo_def)

lemma cfcomp2 [simp]: "(f oo g)\<cdot>x = f\<cdot>(g\<cdot>x)"
by (simp add: cfcomp1)

lemma cfcomp_LAM: "cont g \<Longrightarrow> f oo (\<Lambda> x. g x) = (\<Lambda> x. f\<cdot>(g x))"
by (simp add: cfcomp1)

lemma cfcomp_strict [simp]: "\<bottom> oo f = \<bottom>"
by (simp add: cfun_eq_iff)

text {*
  Show that interpretation of (pcpo,@{text "_->_"}) is a category.
  The class of objects is interpretation of syntactical class pcpo.
  The class of arrows  between objects @{typ 'a} and @{typ 'b} is interpret. of @{typ "'a -> 'b"}.
  The identity arrow is interpretation of @{term ID}.
  The composition of f and g is interpretation of @{text "oo"}.
*}

lemma ID2 [simp]: "f oo ID = f"
by (rule cfun_eqI, simp)

lemma ID3 [simp]: "ID oo f = f"
by (rule cfun_eqI, simp)

lemma assoc_oo: "f oo (g oo h) = (f oo g) oo h"
by (rule cfun_eqI, simp)

subsection {* Strictified functions *}

default_sort pcpo

definition
  seq :: "'a \<rightarrow> 'b \<rightarrow> 'b" where
  "seq = (\<Lambda> x. if x = \<bottom> then \<bottom> else ID)"

lemma cont2cont_if_bottom [cont2cont, simp]:
  assumes f: "cont (\<lambda>x. f x)" and g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. if f x = \<bottom> then \<bottom> else g x)"
proof (rule cont_apply [OF f])
  show "\<And>x. cont (\<lambda>y. if y = \<bottom> then \<bottom> else g x)"
    unfolding cont_def is_lub_def is_ub_def ball_simps
    by (simp add: lub_eq_bottom_iff)
  show "\<And>y. cont (\<lambda>x. if y = \<bottom> then \<bottom> else g x)"
    by (simp add: g)
qed

lemma seq_conv_if: "seq\<cdot>x = (if x = \<bottom> then \<bottom> else ID)"
unfolding seq_def by simp

lemma seq_simps [simp]:
  "seq\<cdot>\<bottom> = \<bottom>"
  "seq\<cdot>x\<cdot>\<bottom> = \<bottom>"
  "x \<noteq> \<bottom> \<Longrightarrow> seq\<cdot>x = ID"
by (simp_all add: seq_conv_if)

definition
  strictify  :: "('a \<rightarrow> 'b) \<rightarrow> 'a \<rightarrow> 'b" where
  "strictify = (\<Lambda> f x. seq\<cdot>x\<cdot>(f\<cdot>x))"

lemma strictify_conv_if: "strictify\<cdot>f\<cdot>x = (if x = \<bottom> then \<bottom> else f\<cdot>x)"
unfolding strictify_def by simp

lemma strictify1 [simp]: "strictify\<cdot>f\<cdot>\<bottom> = \<bottom>"
by (simp add: strictify_conv_if)

lemma strictify2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> strictify\<cdot>f\<cdot>x = f\<cdot>x"
by (simp add: strictify_conv_if)

subsection {* Continuity of let-bindings *}

lemma cont2cont_Let:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g1: "\<And>y. cont (\<lambda>x. g x y)"
  assumes g2: "\<And>x. cont (\<lambda>y. g x y)"
  shows "cont (\<lambda>x. let y = f x in g x y)"
unfolding Let_def using f g2 g1 by (rule cont_apply)

lemma cont2cont_Let' [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>p. g (fst p) (snd p))"
  shows "cont (\<lambda>x. let y = f x in g x y)"
using f
proof (rule cont2cont_Let)
  fix x show "cont (\<lambda>y. g x y)"
    using g by (simp add: prod_cont_iff)
next
  fix y show "cont (\<lambda>x. g x y)"
    using g by (simp add: prod_cont_iff)
qed

text {* The simple version (suggested by Joachim Breitner) is needed if
  the type of the defined term is not a cpo. *}

lemma cont2cont_Let_simple [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. g x y)"
  shows "cont (\<lambda>x. let y = t in g x y)"
unfolding Let_def using assms .

end


section \<open>State and Lens integration\<close>

theory Lens_State
imports
  "HOL-Library.State_Monad"
  Lens_Algebra
begin
text \<open>Inspired by Haskell's lens package\<close>

definition zoom :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('a, 'c) state \<Rightarrow> ('b, 'c) state" where
"zoom l m = State (\<lambda>b. case run_state m (lens_get l b) of (c, a) \<Rightarrow> (c, lens_put l b a))"

definition use :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('b, 'a) state" where
"use l = zoom l State_Monad.get"

definition modify :: "('a \<Longrightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('b, unit) state" where
"modify l f = zoom l (State_Monad.update f)"

definition assign :: "('a \<Longrightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> ('b, unit) state" where
"assign l b = zoom l (State_Monad.set b)"

context begin

qualified abbreviation "add l n \<equiv> modify l (\<lambda>x. x + n)"
qualified abbreviation "sub l n \<equiv> modify l (\<lambda>x. x - n)"
qualified abbreviation "mul l n \<equiv> modify l (\<lambda>x. x * n)"
qualified abbreviation "inc l \<equiv> add l 1"
qualified abbreviation "dec l \<equiv> sub l 1"

end

bundle lens_state_notation begin
  notation zoom (infixr "\<rhd>" 80)
  notation modify (infix "%=" 80)
  notation assign (infix ".=" 80)
  notation Lens_State.add (infix "+=" 80)
  notation Lens_State.sub (infix "-=" 80)
  notation Lens_State.mul (infix "*=" 80)
  notation Lens_State.inc ("_ ++")
  notation Lens_State.dec ("_ --")
end

context includes lens_state_notation begin

lemma zoom_comp1: "l1 \<rhd> l2 \<rhd> s = (l2 ;\<^sub>L l1) \<rhd> s"
unfolding zoom_def lens_comp_def
by (auto split: prod.splits)

lemma zoom_zero[simp]: "zero_lens \<rhd> s = s"
unfolding zoom_def zero_lens_def
by simp

lemma zoom_id[simp]: "id_lens \<rhd> s = s"
unfolding zoom_def id_lens_def
by simp

end

lemma (in mwb_lens) zoom_comp2[simp]: "zoom x m \<bind> (\<lambda>a. zoom x (n a)) = zoom x (m \<bind> n)"
unfolding zoom_def State_Monad.bind_def
by (auto split: prod.splits simp: put_get put_put)

lemma (in wb_lens) use_alt_def: "use x = map_state (lens_get x) State_Monad.get"
unfolding State_Monad.get_def use_def zoom_def
by (simp add: comp_def get_put)

lemma (in wb_lens) modify_alt_def: "modify x f = State_Monad.update (update f)"
unfolding modify_def zoom_def update_def State_Monad.update_def State_Monad.get_def State_Monad.set_def State_Monad.bind_def
by auto

lemma (in wb_lens) modify_id[simp]: "modify x (\<lambda>x. x) = State_Monad.return ()"
unfolding update_def modify_alt_def
by (simp add: get_put)

lemma (in mwb_lens) modify_comp[simp]: "bind (modify x f) (\<lambda>_. modify x g) = modify x (g \<circ> f)"
unfolding modify_def
by simp

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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_add3_assoc1
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

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

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

theorem property0 :
  "((add3 (add3 x1 x2 x3) x4 x5) = (add3 x1 x2 (add3 x3 x4 x5)))"
  oops

end