section \<open>Value Iteration for Reachability Probabilities of MDPs\<close>

theory MDP_RP
  imports "../Markov_Models"
begin

subsection \<open>Auxiliary Theorems\<close>

lemma INF_Union_eq: "(INF x\<in>\<Union>A. f x) = (INF a\<in>A. INF x\<in>a. f x)" for f :: "_ \<Rightarrow> 'a::complete_lattice"
  by (auto intro!: antisym INF_greatest intro: INF_lower2)

lemma lift_option_eq_None: "lift_option f A B = None \<longleftrightarrow> (A \<noteq> None \<longrightarrow> B = None)"
  by (cases A; cases B; auto)

lemma lift_option_eq_Some: "lift_option f A B = Some y \<longleftrightarrow> (\<exists>a b. A = Some a \<and> B = Some b \<and> y = f a b)"
  by (cases A; cases B; auto)

lemma ord_option_Some1_iff: "ord_option R (Some a) y \<longleftrightarrow> (\<exists>b. y = Some b \<and> R a b)"
  by (cases y; auto)

lemma ord_option_Some2_iff: "ord_option R x (Some b) \<longleftrightarrow> (\<forall>a. x = Some a \<longrightarrow> R a b)"
  by (cases x; auto)

lemma sym_Restr: "sym A \<Longrightarrow> sym (Restr A S)"
  by (auto simp: sym_def)

lemma trans_Restr: "trans A \<Longrightarrow> trans (Restr A S)"
  by (auto simp: trans_def)

lemma quotient_eq_singleton: "equiv A r \<Longrightarrow> A // r = {B} \<Longrightarrow> B = A"
  using Union_quotient[of A r] by auto

lemma UN_singleton_image: "(\<Union>x\<in>A. {f x}) = f ` A"
  by auto

lemma image_eq_singeltonD: "f ` A = {x} \<Longrightarrow> \<forall>a\<in>A. f a = x"
  by auto

lemma fun_ord_refl: "reflp ord  \<Longrightarrow> reflp (fun_ord ord)"
  by (auto simp: fun_ord_def reflp_def)

lemma fun_ord_antisym: "antisymp ord  \<Longrightarrow> antisymp (fun_ord ord)"
  by (fastforce simp: fun_ord_def antisymp_def)

lemma fun_ord_combine:
  "fun_ord ord a b \<Longrightarrow> fun_ord ord c d \<Longrightarrow> (\<And>s. ord (a s) (b s) \<Longrightarrow> ord (c s) (d s) \<Longrightarrow> ord (e s) (f s)) \<Longrightarrow> fun_ord ord e f"
  by (auto simp: fun_ord_def)

lemma not_all_eq: "~ (\<forall>y. x \<noteq> y)"
  by auto

lemma ball_vimage_iff: "(\<forall>x\<in>f -` X. P x) \<longleftrightarrow> (\<forall>x. f x \<in> X \<longrightarrow> P x)"
  by auto

lemma UN_If_cases: "(\<Union>x\<in>X. if P x then A x else B x) = (\<Union>x\<in>{x\<in>X. P x}. A x) \<union> (\<Union>x\<in>{x\<in>X. \<not> P x}. B x)"
  by (auto split: if_splits)

lemma (in Reachability_Problem) n_eq_0_closed:
  assumes s: "s \<in> S'" and S': "S' \<subseteq> S" "S' \<inter> S2 = {}" and closed: "\<And>s. s \<in> S' \<Longrightarrow> \<exists>D\<in>K s. D \<subseteq> S'"
  shows "n s = 0"
proof -
  from closed obtain ct where ct: "\<And>s. s \<in> S' \<Longrightarrow> ct s \<in> K s" "\<And>s. s \<in> S' \<Longrightarrow> ct s \<subseteq> S'"
    by metis

  define cfg where "cfg = memoryless_on (\<lambda>s. if s \<in> S' then ct s else arb_act s)"

  have cfg_on: "cfg s \<in> cfg_on s" for s
    unfolding cfg_def using ct by (intro memoryless_on_cfg_onI) auto

  have state_cfg[simp]: "state (cfg s) = s" for s
    unfolding cfg_def by (intro state_memoryless_on)
  have action_cfg[simp]: "action (cfg s) = (if s \<in> S' then ct s else arb_act s)" for s
    unfolding cfg_def by (intro action_memoryless_on)
  have cont_cfg[simp]: "s \<in> S' \<Longrightarrow> t \<in> ct s \<Longrightarrow> cont (cfg s) t = cfg t" for s t
    unfolding cfg_def by (intro cont_memoryless_on) auto

  from s have "v (cfg s) = 0"
  proof (coinduction arbitrary: s rule: v_eq_0_coinduct)
    case (valid cfg') with cfg_on s S' show ?case
      by (auto simp: valid_cfg_def)
  next
    case (nS2 cfg') with S' show ?case
      by auto
  next
    case (cont cfg') with S' ct show ?case
      by (force simp: set_K_cfg)
  qed
  show "n s = 0"
  proof (rule n_eq_0)
    show "s \<in> S" using s S' by auto
  qed fact+
qed

lemma (in Reachability_Problem) n_lb_ennreal:
  fixes x
  assumes "s \<in> S"
  assumes solution: "\<And>s D. s \<in> S1 \<Longrightarrow> D \<in> K s \<Longrightarrow> x s \<le> (\<Sum>t\<in>S. ennreal (pmf D t) * x t)"
  assumes solution_n0: "\<And>s. s \<in> S \<Longrightarrow> n s = 0 \<Longrightarrow> x s = 0"
  assumes solution_S2: "\<And>s. s \<in> S2 \<Longrightarrow> x s = 1"
    and le_1:  "\<And>s. s \<in> S \<Longrightarrow> x s \<le> 1"
  shows "x s \<le> n s" (is "_ \<le> ?y s")
proof -
  have x_less_top[simp]: "s \<in> S \<Longrightarrow> x s < top" for s
    using le_1[of s] by (auto simp: less_top[symmetric] top_unique)

  have "enn2real (x s) \<le> enn2real (n s)"
    apply (rule n_lb[OF \<open>s\<in>S\<close>])
    subgoal for s D
      by (rule ennreal_le_iff[THEN iffD1])
          (use S1 in \<open>auto intro!: sum_nonneg simp add: subset_eq solution sum_ennreal[symmetric] ennreal_mult simp del: sum_ennreal\<close>)
    apply (auto simp: solution_n0 solution_S2)
    done
  with \<open>s\<in>S\<close> show ?thesis
    by (subst (asm) ennreal_le_iff[symmetric]) (simp_all add: real_n)
qed

lifting_forget pmf_as_function.pmf.lifting

text \<open>
  Type to describe MDP components. The support (i.e. elements which are not mapped to an empty
set) is the set of states of the component.

Most of this is from:
  Formal verification of probabilistic systems
  Luca de Alfaro (PhD thesis, 1997)
and
  Reachability in MDPs: Refining Convergence of Value Iteration
  Serge Haddad and Benjamin Monmege (2014)
\<close>

typedef 's mdpc = "UNIV :: ('s \<rightharpoonup> 's pmf set) set"
  by auto

setup_lifting type_definition_mdpc

lift_definition states :: "'s mdpc \<Rightarrow> 's set"
  is dom .

declare [[coercion states]]

lift_definition actions :: "'s mdpc \<Rightarrow> 's \<Rightarrow> 's pmf set"
  is "\<lambda>f s. case f s of None \<Rightarrow> {} | Some a \<Rightarrow> a" .

lemma in_states: "actions \<phi> s \<noteq> {} \<Longrightarrow> s \<in> states \<phi>"
  by transfer auto

lemma mdpc_eqI: "states \<phi> = states \<psi> \<Longrightarrow> (\<And>s. s \<in> states \<phi> \<Longrightarrow> actions \<phi> s = actions \<psi> s) \<Longrightarrow> \<phi> = \<psi>"
  apply transfer
  apply (rule ext)
  subgoal premises prems for \<phi> \<psi> x
    using prems(1) prems(2)[of x]
    by (cases "x \<in> dom \<phi>") (auto simp: fun_eq_iff split: option.splits)
  done

lift_definition map_mdpc :: "('s \<Rightarrow> 't) \<Rightarrow> 's mdpc \<Rightarrow> 't mdpc"
  is "\<lambda>m f s. if f ` (m -` {s}) \<subseteq> {None} then None else Some {map_pmf m d | d A t. m t = s \<and> f t = Some A \<and> d \<in> A}" .

lemma states_map_mdpc: "states (map_mdpc f M) = f ` (states M)"
  by (transfer fixing: f) (auto simp: subset_eq image_iff dom_def split: if_splits)

lemma actions_map_mdpc_eq_Collect: "actions (map_mdpc f M) s = {map_pmf f d | d t. f t = s \<and> d \<in> actions M t}"
  by transfer (force simp: subset_eq split: option.splits)

lemma actions_map_mdpc: "actions (map_mdpc f M) s = map_pmf f ` (\<Union>t\<in>f -` {s}. actions M t)"
  by (auto simp: actions_map_mdpc_eq_Collect)

lemma map_mdpc_compose: "map_mdpc f (map_mdpc g M) = map_mdpc (f \<circ> g) M"
  by (intro mdpc_eqI)
     (auto simp add: states_map_mdpc image_comp actions_map_mdpc image_UN map_pmf_compose[symmetric]
                     vimage_comp[symmetric])

lemma map_mdpc_id: "map_mdpc id = id"
  by (auto simp: fun_eq_iff states_map_mdpc actions_map_mdpc intro!: mdpc_eqI)

lemma finite_states_map: "finite (states M) \<Longrightarrow> finite (map_mdpc f M)"
  by (simp add: states_map_mdpc)

lemma finite_actions_map:
  assumes "finite (states M)" "\<And>s. finite (actions M s)" shows "finite (actions (map_mdpc f M) s)"
proof -
  have "(\<Union>x\<in>f -` {s}. actions M x) = (\<Union>x\<in>f -` {s} \<inter> states M. actions M x)"
    using in_states[of M] by auto
  with assms show ?thesis
    by (auto simp add: actions_map_mdpc)
qed

lift_definition fix_loop :: "'s \<Rightarrow> 's mdpc \<Rightarrow> 's mdpc"
  is "\<lambda>s M t. if s = t then Some {return_pmf s} else M t" .

lemma states_fix_loop[simp]: "states (fix_loop s M) = insert s (states M)"
  by transfer (auto simp: subset_eq image_iff dom_def split: if_splits)

lemma actions_fix_loop[simp]: "actions (fix_loop s M) t = (if s = t then {return_pmf s} else actions M t)"
  by transfer auto

lemma fix_loop_idem: "fix_loop s (fix_loop s M) = fix_loop s M"
  by (auto intro!: mdpc_eqI)

lemma fix_loop_commute: "fix_loop s (fix_loop t M) = fix_loop t (fix_loop s M)"
  by (auto intro!: mdpc_eqI)

lemma map_fix_loop:
  assumes f_s: "\<And>t. f s = f t \<Longrightarrow> t = s"
  shows "map_mdpc f (fix_loop s M) = fix_loop (f s) (map_mdpc f M)"
  by (auto simp: states_map_mdpc actions_map_mdpc_eq_Collect split: if_splits intro!: mdpc_eqI dest!: f_s f_s[OF sym]) force+

lift_definition map_actions :: "('s \<Rightarrow> 's pmf set \<Rightarrow> 's pmf set) \<Rightarrow> 's mdpc \<Rightarrow> 's mdpc"
  is "\<lambda>m f s. map_option (m s) (f s)" .

lemma state_map_actions[simp]: "states (map_actions f \<phi>) = states \<phi>"
  by transfer auto

lemma actions_map_actions[simp]: "(s \<notin> states \<phi> \<Longrightarrow> f s {} = {}) \<Longrightarrow> actions (map_actions f \<phi>) s = f s (actions \<phi> s)"
  by transfer (auto split: option.splits)

lift_definition restrict_states :: "'s set \<Rightarrow> 's mdpc \<Rightarrow> 's mdpc"
  is "\<lambda>S f s. if s \<in> S then f s else None" .

lemma state_restrict_states[simp]: "states (restrict_states S \<phi>) = states \<phi> \<inter> S"
  by transfer (auto split: if_splits)

lemma actions_restrict_states[simp]: "actions (restrict_states S \<phi>) s = (if s \<in> S then actions \<phi> s else {})"
  by transfer (auto split: if_splits)

lemma restrict_states_idem: "states \<phi> \<subseteq> A \<Longrightarrow> restrict_states A \<phi> = \<phi>"
  by transfer (force simp: fun_eq_iff subset_eq dom_def)

instantiation mdpc :: (type) lattice
begin

lift_definition less_eq_mdpc :: "'s mdpc \<Rightarrow> 's mdpc \<Rightarrow> bool"
  is "fun_ord (ord_option (\<subseteq>))" .

definition less_mdpc :: "'s mdpc \<Rightarrow> 's mdpc \<Rightarrow> bool"
  where "less_mdpc f g \<longleftrightarrow> (f \<le> g \<and> \<not> g \<le> f)"

lift_definition inf_mdpc :: "'s mdpc \<Rightarrow> 's mdpc \<Rightarrow> 's mdpc"
  is "\<lambda>f g s. lift_option (\<inter>) (f s) (g s)" .

lift_definition sup_mdpc :: "'s mdpc \<Rightarrow> 's mdpc \<Rightarrow> 's mdpc"
  is "\<lambda>f g s. combine_options (\<union>) (f s) (g s)" .

instance
proof
  fix x y z :: "'s mdpc"
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (rule less_mdpc_def)
  note ord =
    fun_ord_refl[where 'b="'s", OF reflp_ord_option[where 'a="'s pmf set"], of "(\<subseteq>)"]
    fun_ord_trans[where 'b="'s", OF transp_ord_option[where 'a="'s pmf set"], of "(\<subseteq>)"]
    fun_ord_antisym[where 'b="'s", OF antisymp_ord_option[where 'a="'s pmf set"], of "(\<subseteq>)"]
  show  "x \<le> x" "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z" "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (transfer; insert ord; auto simp: transp_def antisymp_def reflp_def)+
  show "x \<sqinter> y \<le> x" "x \<sqinter> y \<le> y"
    by (transfer; auto simp: fun_ord_def ord_option.simps lift_option_def split: Option.bind_split)+
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    apply transfer
    subgoal premises prems for a b c
      using prems by (rule fun_ord_combine) (auto simp: ord_option.simps)
    done
  show "x \<le> x \<squnion> y" "y \<le> x \<squnion> y"
    by (transfer; auto simp: fun_ord_def ord_option.simps combine_options_def not_all_eq split: option.splits)+
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    apply transfer
    subgoal premises prems for a b c
      using prems by (rule fun_ord_combine) (auto simp: ord_option.simps)
    done
qed
end

instantiation mdpc :: (type) complete_lattice
begin

lift_definition bot_mdpc :: "'a mdpc" is "\<lambda>_. None" .

lift_definition top_mdpc :: "'a mdpc" is "\<lambda>_. Some UNIV" .

lift_definition Sup_mdpc :: "'a mdpc set \<Rightarrow> 'a mdpc"
  is "\<lambda>M s. if \<exists>m\<in>M. m s \<noteq> None then Some (\<Union>{ d | m d. m \<in> M \<and> m s = Some d}) else None" .

lift_definition Inf_mdpc :: "'a mdpc set \<Rightarrow> 'a mdpc"
  is "\<lambda>M s. if \<exists>m\<in>M. m s = None then None else Some (\<Inter>{ d | m d. m \<in> M \<and> m s = Some d})" .

instance
proof
  fix x :: "'a mdpc" and X :: "'a mdpc set"
  show "x \<in> X \<Longrightarrow> \<Sqinter>X \<le> x" "x \<in> X \<Longrightarrow> x \<le> \<Squnion>X"
    by (transfer; force simp: fun_ord_def ord_option_Some1_iff ord_option_Some2_iff)+
  show "(\<And>y. y \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> x \<le> \<Sqinter>X"
    apply transfer
    apply (clarsimp simp: fun_ord_def ord_option.simps)
    subgoal premises P for X m x
      using P[rule_format, of _ x]
      by (cases "m x") fastforce+
    done
  show "(\<And>y. y \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> \<Squnion>X \<le> x"
    apply transfer
    apply (clarsimp simp: fun_ord_def ord_option.simps)
    subgoal premises P for X m x y z
      using P(1)[rule_format, of _ x] P(1)[rule_format, of y x] P(2,3)
      by auto force
    done
qed (transfer; auto)+
end

lemma states_sup[simp]: "states (\<phi> \<squnion> \<psi>) = states \<phi> \<union> states \<psi>"
  by transfer (auto simp: combine_options_def split: option.splits)

lemma states_SUP[simp]: "states (\<Squnion>A) = (\<Union>a\<in>A. states a)"
  by transfer (auto simp: dom_def split: option.splits if_splits)

lemma states_inf[simp]: "states (\<phi> \<sqinter> \<psi>) = states \<phi> \<inter> states \<psi>"
  by transfer (auto simp: lift_option_eq_Some split: option.splits)

lemma states_mono: "\<phi> \<le> \<psi> \<Longrightarrow> states \<phi> \<subseteq> states \<psi>"
  using states_sup[of \<phi> \<psi>] by (auto simp del: states_sup simp add: sup_absorb2)

lemma actions_sup[simp]: "actions (\<phi> \<squnion> \<psi>) = actions \<phi> \<squnion> actions \<psi>"
  by transfer (auto simp: combine_options_def split: option.splits)

lemma actions_SUP[simp]: "actions (\<Squnion>A) s = (\<Union>a\<in>A. actions a s)"
  by transfer (auto simp: dom_def split: option.splits if_splits, blast)

lemma actions_inf[simp]: "actions (\<phi> \<sqinter> \<psi>) = actions \<phi> \<sqinter> actions \<psi>"
  by transfer (auto simp: fun_eq_iff split: option.splits)

lemma actions_mono: assumes *: "\<phi> \<le> \<psi>" shows "actions \<phi> \<le> actions \<psi>"
proof -
  have "actions \<phi> \<le> actions \<phi> \<squnion> actions \<psi>"
    by auto
  also have "\<dots> = actions \<psi>"
    using * actions_sup[of \<phi> \<psi>] by (auto simp add: sup_absorb2)
  finally show ?thesis .
qed

lemma le_mdpcI: "states M \<subseteq> states N \<Longrightarrow> (\<And>s. s \<in> states M \<Longrightarrow> actions M s \<subseteq> actions N s) \<Longrightarrow> M \<le> N"
  by transfer
     (force simp: fun_ord_def ord_option.simps subset_eq split: option.splits)

lemma le_mdpc_iff: "M \<le> N \<longleftrightarrow> states M \<subseteq> states N \<and> (\<forall>s. actions M s \<subseteq> actions N s)"
  using states_mono[of M N] actions_mono[of M N] by (auto simp: le_fun_def intro!: le_mdpcI)

lemma map_actions_le: "(\<And>s A. s \<in> states \<phi> \<Longrightarrow> f s A \<subseteq> A) \<Longrightarrow> map_actions f \<phi> \<le> \<phi>"
  apply (intro le_mdpcI)
  subgoal by auto
  subgoal premises p for s using p(1)[of s] p(1)[of s "{}"] p(2) actions_map_actions by auto
  done

lemma restrict_states_mono: "A \<subseteq> B \<Longrightarrow> \<phi> \<le> \<psi> \<Longrightarrow> restrict_states A \<phi> \<le> restrict_states B \<psi>"
  using states_mono[of \<phi> \<psi>] actions_mono[of \<phi> \<psi>] by (intro le_mdpcI) (auto simp: le_fun_def)

lemma restrict_states_le: "restrict_states A M \<le> M"
  by (intro le_mdpcI) auto

lemma eq_bot_iff_states: "\<phi> = bot \<longleftrightarrow> states \<phi> = {}"
  by transfer auto

lemma fix_loop_neq_bot: "fix_loop s N \<noteq> bot"
  unfolding eq_bot_iff_states by simp

lemma
  shows states_bot[simp]: "states bot = {}"
    and actions_bot[simp]: "actions bot = (\<lambda>s. {})"
  unfolding fun_eq_iff by (transfer; auto)+

lemma inf_eq_bot_eq_disjnt_states: "A \<sqinter> B = bot \<longleftrightarrow> disjnt (states A) (states B)"
  unfolding disjnt_def by transfer  (auto simp: fun_eq_iff lift_option_eq_None)

text \<open>Enabled States\<close>
definition en :: "'s mdpc \<Rightarrow> 's rel"
  where "en \<phi> = {(s, t) | d s t. d \<in> actions \<phi> s \<and> t \<in> set_pmf d}"

lemma en_sup[simp]: "en (\<phi> \<squnion> \<psi>) = en \<phi> \<union> en \<psi>"
  by (auto simp: en_def)

lemma en_SUP[simp]: "en (Sup A) = (\<Union>a\<in>A. en a)"
  by (auto simp: en_def)

lemma en_mono: "\<phi> \<le> \<psi> \<Longrightarrow> en \<phi> \<subseteq> en \<psi>"
  unfolding en_def
  apply transfer
  apply (auto simp: fun_ord_def split: option.splits)
  subgoal for \<phi> \<psi> a b x y
    by (auto elim!: allE[of _ x] simp: ord_option.simps intro!: exI[of _ b] exI[of _ x])
  done

lemma en_states: "(s, t) \<in> en M \<Longrightarrow> s \<in> states M"
  using in_states[of M s] by (auto simp: en_def)

lemma en_bot[simp]: "en bot = {}"
  by (simp add: en_def)

lemma en_fix_loop[simp]: "en (fix_loop s M) = insert (s, s) (en M - {s} \<times> UNIV)"
  by (force simp add: en_def )

lift_definition trivial :: "'s \<Rightarrow> 's mdpc" is "\<lambda>s. (\<lambda>_. None)(s := Some {})" .

lemma states_trivial[simp]: "states (trivial s) = {s}"
  by transfer auto

lemma actions_trivial[simp]: "actions (trivial s) = (\<lambda>_. {})"
  by transfer (auto simp: fun_eq_iff)

lemma en_trivial[simp]: "en (trivial s) = {}"
  by (simp add: en_def)

lemma trivial_le_iff: "trivial x \<le> \<phi> \<longleftrightarrow> x \<in> states \<phi>"
  by transfer (auto simp: ord_option.simps fun_ord_def)

lemma trivial_le: "x \<in> states \<phi> \<Longrightarrow> trivial x \<le> \<phi>"
  unfolding trivial_le_iff .

lemma trivial_neq_bot: "trivial x \<noteq> bot"
  by transfer auto

lift_definition loop :: "'s \<Rightarrow> 's mdpc"
  is "\<lambda>s. (\<lambda>_. None)(s := Some {return_pmf s})" .

lemma states_loop[simp]: "states (loop s) = {s}"
  by transfer auto

lemma actions_loop: "actions (loop s) = ((\<lambda>_. {})(s := {return_pmf s}))"
  by transfer (auto simp: fun_eq_iff)

lemma
  shows actions_loop_self[simp]: "actions (loop s) s = {return_pmf s}"
    and actions_loop_neq[simp]: "s \<noteq> t \<Longrightarrow> actions (loop s) t = {}"
  by (simp_all add: actions_loop)

lemma en_loop[simp]: "en (loop s) = {(s, s)}"
  by (auto simp: en_def actions_loop)

lemma loop_neq_bot: "loop s \<noteq> bot"
  unfolding eq_bot_iff_states by simp

lemma loop_le: "loop x \<le> M \<longleftrightarrow> (x \<in> states M \<and> return_pmf x \<in> actions M x)"
  by (auto simp: le_mdpc_iff actions_loop)

lemma le_loop: "M \<le> loop x \<longleftrightarrow> (states M \<subseteq> {x} \<and> actions M x \<subseteq> {return_pmf x})"
  using in_states[of M] by (auto simp: le_mdpc_iff actions_loop)

text \<open>Strongly Connected (SC)\<close>
definition sc :: "'s mdpc \<Rightarrow> bool"
  where "sc \<phi> \<longleftrightarrow> states \<phi> \<times> states \<phi> \<subseteq> (en \<phi>)\<^sup>*"

lemma scD: "sc \<phi> \<Longrightarrow> x \<in> states \<phi> \<Longrightarrow> y \<in> states \<phi> \<Longrightarrow> (x, y) \<in> (en \<phi>)\<^sup>*"
  by (auto simp: sc_def)

lemma scI: "(\<And>x y. x \<in> states \<phi> \<Longrightarrow> y \<in> states \<phi> \<Longrightarrow> (x, y) \<in> (en \<phi>)\<^sup>*) \<Longrightarrow> sc \<phi>"
  by (auto simp: sc_def)

lemma sc_trivial[simp]: "sc (trivial s)"
  by (simp add: sc_def)

lemma sc_loop[simp]: "sc (loop s)"
  by (auto simp: sc_def)

lemma sc_bot[simp]: "sc bot"
  by (simp add: sc_def)

lemma sc_SupI_directed:
  assumes A: "\<And>a. a \<in> A \<Longrightarrow> sc a"
    and directed: "\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> \<exists>c\<in>A. a \<le> c \<and> b \<le> c"
  shows "sc (Sup A)"
  unfolding sc_def
proof clarsimp
  fix x y a b assume "a \<in> A" "b \<in> A" and xy: "x \<in> states a" "y \<in> states b"
  with directed obtain c where "c \<in> A" "a \<le> c" "b \<le> c"
    by auto
  with xy have "x \<in> states c" "y \<in> states c"
    using states_mono[of a c] states_mono[of b c] by auto
  with A[OF \<open>c \<in> A\<close>] \<open>c \<in> A\<close>
  have "(x, y) \<in> (en c)\<^sup>*"
    by (auto simp: sc_def subset_eq)
  then show "(x, y) \<in> (\<Union>x\<in>A. en x)\<^sup>*"
    using rtrancl_mono[of "en c" "\<Union>a\<in>A. en a"] \<open>c\<in>A\<close> by auto
qed

lemma sc_supI:
  assumes \<phi>: "sc \<phi>" and \<psi>: "sc \<psi>" and not_disjoint: "\<phi> \<sqinter> \<psi> \<noteq> bot"
  shows "sc (\<phi> \<squnion> \<psi>)"
  unfolding sc_def
proof safe
  fix x y assume "x \<in> states (\<phi> \<squnion> \<psi>)" "y \<in> states (\<phi> \<squnion> \<psi>)"
  moreover obtain z where "z \<in> states \<phi>" "z \<in> states \<psi>"
    using not_disjoint by (auto simp: inf_eq_bot_eq_disjnt_states disjnt_def)
  moreover have "(en \<phi>)\<^sup>* \<union> (en \<psi>)\<^sup>* \<subseteq> (en (\<phi> \<squnion> \<psi>))\<^sup>*"
    by (metis rtrancl_Un_subset en_sup)
  ultimately have "(x, z) \<in> (en (\<phi> \<squnion> \<psi>))\<^sup>*" "(z, y) \<in> (en (\<phi> \<squnion> \<psi>))\<^sup>*"
    using \<phi> \<psi> by (auto dest: scD)
  then show "(x, y) \<in> (en (\<phi> \<squnion> \<psi>))\<^sup>*"
    by auto
qed

lemma sc_eq_loop:
  assumes M: "sc M" and s: "s \<in> M" "actions M s = {return_pmf s}" shows "M = loop s"
proof -
  { fix t assume "t \<in> M"
    then have "(s, t) \<in> (en M)\<^sup>*"
      using M[THEN scD, OF \<open>s \<in> M\<close> \<open>t \<in> M\<close>] by simp
    from this have "t = s"
      by (induction rule: rtrancl_induct) (auto simp: en_def \<open>actions M s = {return_pmf s}\<close>) }
  then have "states M = {s}"
    using \<open>s \<in> M\<close> by blast
  then show ?thesis
    by (intro mdpc_eqI) (auto simp: \<open>actions M s = {return_pmf s}\<close>)
qed

lemma sc_eq_trivial:
  assumes M: "sc M" and s: "s \<in> M" "actions M s = {}" shows "M = trivial s"
proof -
  { fix t assume "t \<in> M" "t \<noteq> s"
    then have "(s, t) \<in> (en M)\<^sup>+"
      using M[THEN scD, OF \<open>s \<in> M\<close> \<open>t \<in> M\<close>] by (simp add: rtrancl_eq_or_trancl)
    from tranclD[OF this] \<open>actions M s = {}\<close> have False
      by (auto simp: en_def) }
  then have "states M = {s}"
    using \<open>s \<in> M\<close> by auto
  then show ?thesis
    by (intro mdpc_eqI) (auto simp: \<open>actions M s = {}\<close>)
qed

definition closed_mdpc :: "'s mdpc \<Rightarrow> bool"
  where "closed_mdpc \<phi> \<longleftrightarrow> en \<phi> \<subseteq> states \<phi> \<times> states \<phi>"

lemma closed_mdpcD: "closed_mdpc \<phi> \<Longrightarrow> D \<in> actions \<phi> x \<Longrightarrow> y \<in> D \<Longrightarrow> y \<in> states \<phi>"
  by (auto simp: closed_mdpc_def en_def)

lemma closed_mdpc_supI: "closed_mdpc \<phi> \<Longrightarrow> closed_mdpc \<psi> \<Longrightarrow> closed_mdpc (\<phi> \<squnion> \<psi>)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_SupI: "(\<And>a. a \<in> A \<Longrightarrow> closed_mdpc a) \<Longrightarrow> closed_mdpc (\<Squnion>A)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_infI: "closed_mdpc \<phi> \<Longrightarrow> closed_mdpc \<psi> \<Longrightarrow> closed_mdpc (\<phi> \<sqinter> \<psi>)"
  using en_mono[of "\<phi> \<sqinter> \<psi>" \<phi>] en_mono[of "\<phi> \<sqinter> \<psi>" \<psi>]
  by (auto simp: closed_mdpc_def lift_option_eq_Some)

lemma closed_mdpc_trivial[simp]: "closed_mdpc (trivial s)"
  by (simp add: closed_mdpc_def)

lemma closed_mdpc_loop[simp]: "closed_mdpc (loop s)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_fix_loop: "closed_mdpc M \<Longrightarrow> closed_mdpc (fix_loop s M)"
  by (auto simp: closed_mdpc_def)

lemma closed_mdpc_map: assumes M: "closed_mdpc M" shows "closed_mdpc (map_mdpc f M)"
  using closed_mdpcD[OF M]
  by (auto simp: closed_mdpc_def en_def actions_map_mdpc states_map_mdpc intro!: imageI intro: in_states)

definition close :: "'s mdpc \<Rightarrow> 's mdpc"
  where "close \<phi> = map_actions (\<lambda>s A. {a\<in>A. set_pmf a \<subseteq> states \<phi>}) \<phi>"

lemma
  shows states_close[simp]: "states (close \<phi>) = states \<phi>"
    and actions_close[simp]: "actions (close \<phi>) s = {a\<in>actions \<phi> s. a \<subseteq> states \<phi>}"
  by (auto simp: close_def)

lemma closed_close: "closed_mdpc (close \<phi>)"
  by (auto simp add: closed_mdpc_def en_def intro: in_states)

lemma close_closed: "closed_mdpc \<phi> \<Longrightarrow> close \<phi> = \<phi>"
  unfolding closed_mdpc_def by (intro mdpc_eqI) (auto simp: en_def)

lemma close_close: "close (close \<phi>) = close \<phi>"
  by (simp add: closed_close close_closed)

lemma close_le: "close M \<le> M"
  unfolding close_def by (intro map_actions_le) auto

lemma close_mono: "\<phi> \<le> \<psi> \<Longrightarrow> close \<phi> \<le> close \<psi>"
  using states_mono[of \<phi> \<psi>] actions_mono[of \<phi> \<psi>]
  unfolding close_def by (intro le_mdpcI) (auto simp: le_fun_def)

text \<open>End Component (EC)\<close>
definition ec :: "'s mdpc \<Rightarrow> bool"
  where "ec \<phi> \<longleftrightarrow> sc \<phi> \<and> closed_mdpc \<phi>"

lemma ec_trivial[simp]: "ec (trivial s)"
  by (auto simp: ec_def)

lemma ec_bot[simp]: "ec bot"
  by (auto simp: ec_def)

lemma ec_loop[simp]: "ec (loop s)"
  by (auto simp: ec_def)

lemma ec_sup: "ec \<phi> \<Longrightarrow> ec \<psi> \<Longrightarrow> \<phi> \<sqinter> \<psi> \<noteq> bot \<Longrightarrow> ec (\<phi> \<squnion> \<psi>)"
  by (simp add: ec_def sc_supI closed_mdpc_supI)

lemma ec_Sup_directed:
  "(\<And>a. a \<in> A \<Longrightarrow> ec a) \<Longrightarrow> (\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> \<exists>c\<in>A. a \<le> c \<and> b \<le> c) \<Longrightarrow> ec (\<Squnion>A)"
  by (auto simp: ec_def closed_mdpc_SupI sc_SupI_directed)

text \<open>Maximal End Component (MEC) relative to @{term M}\<close>
definition mec :: "'s mdpc \<Rightarrow> 's mdpc \<Rightarrow> bool"
  where "mec M \<phi> \<longleftrightarrow> ec \<phi> \<and> \<phi> \<le> M \<and> (\<forall>\<psi>\<le>M. ec \<psi> \<longrightarrow> \<phi> \<le> \<psi> \<longrightarrow> \<phi> = \<psi>)"

lemma mec_refl: "ec M \<Longrightarrow> mec M M"
  by (auto simp: mec_def)

lemma mec_le: "mec M \<phi> \<Longrightarrow> \<phi> \<le> M"
  by (auto simp: mec_def)

lemma mec_ec: "mec M \<phi> \<Longrightarrow> ec \<phi>"
  by (auto simp: mec_def)

lemma mec_least: "mec M \<phi> \<Longrightarrow> \<psi> \<le> M \<Longrightarrow> \<phi> \<le> \<psi> \<Longrightarrow> ec \<psi> \<Longrightarrow> \<phi> \<ge> \<psi>"
  by (auto simp: mec_def)

lemma mec_bot_imp_bot: assumes "mec \<phi> bot" shows "\<phi> = bot"
proof (rule ccontr)
  assume "\<phi> \<noteq> bot"
  then obtain x where "x \<in> states \<phi>"
    unfolding eq_bot_iff_states by auto
  then have "ec (trivial x)" "trivial x \<le> \<phi>"
    by (auto intro: trivial_le)
  then have "trivial x = bot"
    using \<open>mec \<phi> bot\<close> by (auto simp: mec_def)
  then show False
    by (simp add: trivial_neq_bot)
qed

lemma mec_imp_bot_eq_bot: "mec \<phi> \<psi> \<Longrightarrow> \<phi> = bot \<longleftrightarrow> \<psi> = bot"
  using mec_bot_imp_bot[of \<phi>] by (auto simp: mec_def)

lemma mec_unique: assumes \<phi>: "mec M \<phi>" and \<psi>: "mec M \<psi>" and "\<phi> \<sqinter> \<psi> \<noteq> bot" shows "\<phi> = \<psi>"
proof -
  have "mec M (\<phi> \<squnion> \<psi>)"
    using assms
    by (auto intro!: mec_def[THEN iffD2] ec_sup antisym dest: mec_ec mec_le)
       (blast intro: le_supI1 mec_least[of M])
  with mec_least[OF \<phi>, of "\<phi> \<squnion> \<psi>"] mec_least[OF \<psi>,  of "\<phi> \<squnion> \<psi>"] mec_le[OF this] mec_ec[OF this]
  show "\<phi> = \<psi>"
    by auto
qed

lemma mec_exists: assumes \<phi>: "\<phi> \<noteq> bot" "ec \<phi>" and M: "\<phi> \<le> M" shows "\<exists>\<psi>\<ge>\<phi>. mec M \<psi>"
proof (intro exI conjI)
  show "\<phi> \<le> \<Squnion>{\<psi>. \<phi> \<le> \<psi> \<and> \<psi> \<le> M \<and> ec \<psi>}"
    using \<phi> M by (intro Sup_upper) auto
  show "mec M (\<Squnion>{\<psi>. \<phi> \<le> \<psi> \<and> \<psi> \<le> M \<and> ec \<psi>})"
    unfolding mec_def
  proof safe
    show "ec (\<Squnion>{\<psi>. \<phi> \<le> \<psi> \<and> \<psi> \<le> M \<and> ec \<psi>})"
    proof (safe intro!: ec_Sup_directed)
      fix a b assume *: "\<phi> \<le> a" "\<phi> \<le> b" and "a \<le> M" "b \<le> M" "ec a" "ec b"
      moreover have "a \<sqinter> b \<noteq> bot"
        using * \<phi> bot_unique[of "\<phi>"] le_inf_iff[of \<phi> a b] by (auto simp del: inf.bounded_iff)
      ultimately show "\<exists>c\<in>{\<psi>. \<phi> \<le> \<psi> \<and> \<psi> \<le> M \<and> ec \<psi>}. a \<le> c \<and> b \<le> c"
        by (intro bexI[of _ "sup a b"]) (auto intro: le_supI1 intro!: ec_sup)
    qed
    fix \<psi> assume \<psi>: "\<psi> \<le> M" "ec \<psi>" "\<Squnion>{\<psi>. \<phi> \<le> \<psi> \<and> \<psi> \<le> M \<and> ec \<psi>} \<le> \<psi>"
    have "\<phi> \<le> \<Squnion>{\<psi>. \<phi> \<le> \<psi> \<and> \<psi> \<le> M \<and> ec \<psi>}"
      using assms by (auto intro!: Sup_upper)
    also have "\<dots> \<le> \<psi>" by fact
    finally show "\<Squnion>{\<psi>. \<phi> \<le> \<psi> \<and> \<psi> \<le> M \<and> ec \<psi>} = \<psi>"
      using \<psi> by (intro antisym Sup_upper) auto
  qed (auto intro!: Sup_least)
qed

lemma mec_exists': "x \<in> states M \<Longrightarrow> \<exists>\<psi>. x \<in> states \<psi> \<and> mec M \<psi>"
  using mec_exists[of "trivial x"] by (auto simp: trivial_neq_bot trivial_le_iff)

lemma mec_loop: "x \<in> states M \<Longrightarrow> actions M x = {return_pmf x} \<Longrightarrow> mec M (loop x)"
  apply (auto simp: mec_def loop_le ec_def)
  subgoal for \<phi>
    using sc_eq_loop[of \<phi> x] actions_mono[of \<phi> M, THEN le_funD, of x] by auto
  done

lemma mec_fix_loop: "mec (fix_loop s M) (loop s)"
  by (intro mec_loop) auto

definition trivials :: "'s mdpc \<Rightarrow> 's set"
  where "trivials M = {x. mec M (trivial x)}"

lemma trivials_subset_states: "trivials M \<subseteq> states M"
  by (auto simp: trivials_def mec_def trivial_le_iff)

text \<open>Bottom MEC (BEMC) in @{term M}\<close>
definition bmec :: "'s mdpc \<Rightarrow> 's mdpc \<Rightarrow> bool"
  where "bmec M \<phi> \<longleftrightarrow> mec \<phi> M \<and> (\<forall>s\<in>states \<phi>. actions \<phi> s = actions M s)"

definition actions' :: "'s mdpc \<Rightarrow> 's \<Rightarrow> 's pmf set"
  where "actions' M s = (if s \<in> states M then actions M s else {return_pmf s})"

lemma closed_mdpcD':
  "closed_mdpc M \<Longrightarrow> s \<in> states M \<Longrightarrow> (\<Union>D\<in>actions' M s. set_pmf D) \<subseteq> states M"
  by (auto simp: actions'_def dest: closed_mdpcD)

locale Finite_MDP =
  fixes M :: "'s mdpc"
  assumes closed_M: "closed_mdpc M" and M_neq_bot: "M \<noteq> bot"
    and actions_neq_empty_M: "\<And>s. s \<in> states M \<Longrightarrow> actions M s \<noteq> {}"
    and finite_states_M: "finite M"
    and finite_actions_M: "\<And>s. finite (actions M s)"
begin

sublocale Finite_Markov_Decision_Process "actions' M" "states M"
proof
  show "actions' M s \<noteq> {}" for s
    using actions_neq_empty_M by (auto simp: actions'_def )
  show "states M \<noteq> {}" "finite M" "\<And>s. finite (actions' M s)"
    using M_neq_bot finite_states_M finite_actions_M by (auto simp: eq_bot_iff_states actions'_def)
  show "s \<in> states M \<Longrightarrow> (\<Union>D\<in>actions' M s. set_pmf D) \<subseteq> states M" for s
    using closed_M by (rule closed_mdpcD')
qed

lemma Finite_MDP_map_loop: "Finite_MDP (map_mdpc f M \<squnion> loop s)"
proof
  show "closed_mdpc (map_mdpc f M \<squnion> loop s)"
    by (intro closed_mdpc_supI closed_mdpc_map closed_M closed_mdpc_loop)
  show "finite (actions (map_mdpc f M \<squnion> loop s) t)" for t
    by (auto simp: actions_loop intro!: finite_actions_map finite_states_M finite_actions_M)
  show "finite (map_mdpc f M \<squnion> loop s)"
    by (auto intro!: finite_states_M finite_states_map)
qed (auto simp: loop_neq_bot states_map_mdpc actions_loop actions_map_mdpc dest: actions_neq_empty_M)

lemma Finite_MDP_map_fix_loop: "Finite_MDP (fix_loop s (map_mdpc f M))"
proof
  show "closed_mdpc (fix_loop s (map_mdpc f M))"
    by (intro closed_mdpc_supI closed_mdpc_map closed_M closed_mdpc_fix_loop)
  show "finite (actions (fix_loop s (map_mdpc f M)) t)" for t
    by (auto simp: actions_loop intro!: finite_actions_map finite_states_M finite_actions_M)
  show "finite (fix_loop s (map_mdpc f M))"
    by (auto intro!: finite_states_M finite_states_map)
qed (auto simp: fix_loop_neq_bot states_map_mdpc actions_map_mdpc dest: actions_neq_empty_M)

end

context
  fixes M :: "'s mdpc"
    and F :: "'s set"
  assumes M_neq_bot: "M \<noteq> bot"
    and closed_M: "closed_mdpc M"
    and actions_neq_empty_M: "\<And>s. s \<in> states M \<Longrightarrow> actions M s \<noteq> {}"
    and finite_states_M: "finite M"
    and finite_actions_M: "\<And>s. finite (actions M s)"
    and F_subset: "F \<subseteq> states M"
begin

lemma finite_F[simp]: "finite F"
  using F_subset finite_states_M by (auto dest: finite_subset)

interpretation M: Finite_MDP M
  proof qed fact+

interpretation M: Reachability_Problem "actions' M" "states M" "states M - F" F
  proof qed (insert F_subset, auto)

definition r :: "'s \<Rightarrow> 's option"
  where "r s = (if s \<in> F then None else Some s)"

lemma r_eq_None[simp]: "r s = None \<longleftrightarrow> s \<in> F"
  by (simp add: r_def)

lemma r_eq_Some[simp]: "r s = Some t \<longleftrightarrow> (s \<notin> F \<and> s = t)"
  by (simp add: r_def)

lemma r_in_Some_image: "r s \<in> Some ` X \<longleftrightarrow> (s \<notin> F \<and> s \<in> X)"
  by (auto simp: r_def)

lemma shows r_F: "s \<in> F \<Longrightarrow> r s = None" and r_nF: "s \<notin> F \<Longrightarrow> r s = Some s"
  by auto

definition R :: "'s option mdpc"
  where "R = fix_loop None (map_mdpc r M)"

lemma closed_R: "closed_mdpc R"
  unfolding R_def by (intro closed_mdpc_map closed_M closed_mdpc_fix_loop)

lemma states_R[simp]: "states R = Some ` (states M - F) \<union> {None}"
  by (auto simp add: R_def r_def[abs_def] states_map_mdpc)

lemma actions_R_None[simp]:
  "actions R None = {return_pmf None}"
  by (auto simp add: R_def)

lemma actions_R_Some[simp]:
  "actions R (Some s) = (if s \<in> F then {} else map_pmf r ` actions M s)"
  by (auto simp add: R_def actions_map_mdpc split: if_splits intro!: imageI)

lemma mec_R_loop: "mec R (loop None)"
  unfolding R_def by (intro mec_fix_loop)

interpretation R: Finite_MDP R
  unfolding R_def by (rule M.Finite_MDP_map_fix_loop)

interpretation R: Reachability_Problem "actions' R" "states R" "{None}" "{}"
  proof qed auto

lemma F_not_trivial: "s \<in> F \<Longrightarrow> Some s \<notin> trivials R"
  by (auto simp: trivials_def mec_def trivial_le_iff)

primrec min_state :: "'s option \<Rightarrow> 's + bool"
  where
    "min_state None = Inr True"
  | "min_state (Some s) = (if Some s \<in> trivials R then Inl s else Inr False)"

lemma min_state_eq_Inl: "min_state s = Inl t \<longleftrightarrow> (Some t \<in> trivials R \<and> s = Some t)"
  by (cases s) auto

lemma min_state_eq_Inr: "min_state s = Inr b \<longleftrightarrow> (if b then s = None else s \<noteq> None \<and> s \<notin> trivials R)"
  by (cases s) auto

lemma map_min_state_R: "map_mdpc min_state R = fix_loop (Inr True) (map_mdpc (min_state \<circ> r) M)"
  unfolding R_def
  by (subst map_fix_loop)
     (auto simp: map_mdpc_compose min_state_eq_Inr eq_commute[of "Inr True"])

definition min_mdpc :: "('s + bool) mdpc"
  where "min_mdpc = fix_loop (Inr False) (map_mdpc min_state R)"

lemma states_min_mdpc: "states min_mdpc = {Inl t | t. Some t \<in> trivials R} \<union> {Inr True, Inr False}"
  using trivials_subset_states[of R] by (auto simp add: min_mdpc_def states_map_mdpc image_comp split: if_splits)

lemma actions_min_mdpc_Inl:
  "actions min_mdpc (Inl t) = (if Some t \<in> trivials R then map_pmf (min_state \<circ> r) ` actions M t else {})"
proof -
  have eq: "min_state -` {Inl t} = (if Some t \<in> trivials R then {Some t} else {})"
    by (auto simp: min_state_eq_Inl)
  show ?thesis using F_not_trivial[of t]
    by (simp add: min_mdpc_def actions_map_mdpc eq image_comp map_pmf_compose[symmetric])
qed

lemma actions_min_mdpc_Inr: "actions min_mdpc (Inr b) = {return_pmf (Inr b)}"
  by (simp add: min_mdpc_def map_min_state_R)

interpretation min: Finite_MDP min_mdpc
  unfolding min_mdpc_def by (rule R.Finite_MDP_map_fix_loop)

interpretation min: Reachability_Problem "actions' min_mdpc" "states min_mdpc" "states min_mdpc - {Inr True}" "{Inr True}"
  proof qed (auto simp: states_min_mdpc)

lemma M_n_eq_0_not_trivials:
  assumes "s \<in> states M" "s \<notin> F" "Some s \<notin> trivials R"
  shows "M.n s = 0"
proof -
  have "Some s \<in> states R"
    using assms by auto

  obtain \<phi> where "mec R \<phi>" "s \<in> Some -` \<phi>"
    using mec_exists'[OF \<open>Some s \<in> states R\<close>] by auto
  then have action_\<phi>: "Some t \<in> \<phi> \<Longrightarrow> actions \<phi> (Some t) \<noteq> {}" for t
    using mec_ec[OF \<open>mec R \<phi>\<close>] \<open>Some s \<notin> trivials R\<close> sc_eq_trivial[of \<phi> "Some t"]
    by (auto simp: ec_def trivials_def)

  have None_notin_states: "None \<notin> states \<phi>"
    using mec_R_loop \<open>mec R \<phi>\<close> \<open>s \<in> Some -` \<phi>\<close> mec_unique[of R "loop None" \<phi>]
    by (auto simp: inf_eq_bot_eq_disjnt_states disjnt_def)

  from \<open>s \<in> Some -` \<phi>\<close> show "M.n s = 0"
  proof (rule M.n_eq_0_closed)
    show "Some -` states \<phi> \<subseteq> states M" "Some -` states \<phi> \<inter> F = {}"
      using mec_le[OF \<open>mec R \<phi>\<close>] by (auto simp: r_def le_mdpc_iff)
    fix s assume "s \<in> Some -` \<phi>"
    then have s: "s \<in> states M" "s \<notin> F" "actions \<phi> (Some s) \<noteq> {}"
      using mec_le[OF \<open>mec R \<phi>\<close>] by (auto simp: le_mdpc_iff action_\<phi>)
    then obtain D where D: "D \<in> actions \<phi> (Some s)"
      by auto
    then have "D \<in> actions R (Some s)"
      using mec_le[OF \<open>mec R \<phi>\<close>, THEN actions_mono] s by (auto simp add: le_fun_def simp del: actions_R_Some)
    with s obtain D' where D_eq: "D = map_pmf r D'" and D': "D' \<in> actions M s"
      by auto
    have "set_pmf D \<subseteq> states \<phi>"
      using closed_mdpcD[OF _ D] mec_ec[OF \<open>mec R \<phi>\<close>] by (auto simp: ec_def)
    then have "set_pmf D = Some ` set_pmf D'"
      using closed_mdpcD[of \<phi>, OF _ \<open>D \<in> actions \<phi> (Some s)\<close>] None_notin_states
        mec_ec[OF \<open>mec R \<phi>\<close>]
      unfolding D_eq by (auto intro!: image_cong simp: r_def ec_def)
    then show "\<exists>x\<in>actions' M s. set_pmf x \<subseteq> Some -` states \<phi>"
      using \<open>s \<in> states M\<close> \<open>set_pmf D \<subseteq> states \<phi>\<close> D'
      by (intro bexI[of _ D']) (auto simp: actions'_def)
  qed
qed

lemma min_state_r_in_min_mdpc[simp]: "s \<in> M \<Longrightarrow> min_state (r s) \<in> min_mdpc"
  by (auto simp add: states_min_mdpc min_state_eq_Inr min_state_eq_Inl r_def)

end

end


(*
 * Copyright 2016, Data61, CSIRO
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(DATA61_BSD)
 *)
section \<open>Case-study\<close>

theory SumArr
imports
  "../OG_Syntax"
  Word_Lib.Word_32
begin

unbundle bit_operations_syntax

type_synonym routine = nat
type_synonym word32 = "32 word"
type_synonym funcs = "string \<times> nat"
datatype faults = Overflow | InvalidMem
type_synonym 'a array = "'a list"

text \<open>Sumarr computes the combined sum of all the elements of
multiple arrays. It does this by running a number of threads in
parallel, each computing the sum of elements of one of the arrays,
and then adding the result to a global variable gsum shared by all threads.
\<close>
record sumarr_state =
 \<comment> \<open>local variables of threads\<close>
  tarr :: "routine \<Rightarrow> word32 array"
  tid :: "routine \<Rightarrow> word32"
  ti :: "routine \<Rightarrow> word32"
  tsum :: "routine \<Rightarrow> word32"
 \<comment> \<open>global variables\<close>
  glock :: nat
  gsum :: word32
  gdone :: word32
  garr :: "(word32 array) array"
 \<comment> \<open>ghost variables\<close>
  ghost_lock :: "routine \<Rightarrow> bool"

definition
 NSUM :: word32
where
 "NSUM = 10"

definition
 MAXSUM :: word32
where
 "MAXSUM = 1500"

definition
 array_length :: "'a array \<Rightarrow> word32"
where
 "array_length arr \<equiv> of_nat (length arr)"

definition
 array_nth :: "'a array \<Rightarrow> word32 \<Rightarrow>'a"
where
 "array_nth arr n \<equiv> arr ! unat n"

definition
 array_in_bound :: "'a array \<Rightarrow> word32 \<Rightarrow> bool"
where
 "array_in_bound arr idx \<equiv> unat idx < (length arr)"

definition
  array_nat_sum :: "('a :: len) word array \<Rightarrow> nat"
where
  "array_nat_sum arr \<equiv> sum_list (map unat arr)"

definition
  "local_sum arr \<equiv> of_nat (min (unat MAXSUM) (array_nat_sum arr))"

definition
  "global_sum arr \<equiv> sum_list (map local_sum arr)"

definition
  "tarr_inv s i \<equiv>
    length (tarr s i) = unat NSUM \<and> tarr s i = garr s ! i"

abbreviation
  "sumarr_inv_till_lock s i \<equiv> \<not> bit (gdone s) i \<and> ((\<not> (ghost_lock s) (1 - i)) \<longrightarrow> ((gdone s = 0 \<and> gsum s = 0) \<or>
    (bit (gdone s) (1 - i) \<and> gsum s = local_sum (garr s !(1 - i)))))"

abbreviation
  "lock_inv s \<equiv>
    (glock s = fromEnum (ghost_lock s 0) + fromEnum (ghost_lock s 1)) \<and>
    (\<not>(ghost_lock s) 0 \<or> \<not>(ghost_lock s) 1)"

abbreviation
  "garr_inv s i \<equiv> (\<exists>a b. garr s = [a, b]) \<and>
    length (garr s ! (1-i)) = unat NSUM"

abbreviation
  "sumarr_inv s i \<equiv> lock_inv s \<and> tarr_inv s i \<and> garr_inv s i \<and>
    tid s i = (of_nat i + 1)"

definition
  lock :: "routine \<Rightarrow> (sumarr_state, funcs, faults) ann_com"
where
  "lock i \<equiv>
    \<lbrace> \<acute>sumarr_inv i \<and> \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
    AWAIT \<acute>glock = 0
    THEN \<acute>glock:=1,, \<acute>ghost_lock:=\<acute>ghost_lock (i:= True)
    END"

definition
 "sumarr_in_lock1 s i \<equiv> \<not>bit (gdone s) i \<and> ((gdone s = 0 \<and> gsum s = local_sum (tarr s i)) \<or>
   (bit (gdone s) (1 - i) \<and> \<not> bit (gdone s) i \<and> gsum s = global_sum (garr s)))"

definition
 "sumarr_in_lock2 s i \<equiv> (bit (gdone s) i \<and> \<not> bit (gdone s) (1 - i) \<and> gsum s = local_sum (tarr s i)) \<or>
   (bit (gdone s) i \<and> bit (gdone s) (1 - i) \<and> gsum s = global_sum (garr s))"

definition
  unlock :: "routine \<Rightarrow> (sumarr_state, funcs, faults) ann_com"
where
  "unlock i \<equiv>
    \<lbrace>  \<acute>sumarr_inv i \<and> \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>glock = 1 \<and>
    \<acute>ghost_lock i \<and> bit \<acute>gdone (unat (\<acute>tid i - 1)) \<and> \<acute>sumarr_in_lock2 i \<rbrace>
    \<langle>\<acute>glock := 0,, \<acute>ghost_lock:=\<acute>ghost_lock (i:= False)\<rangle>"

definition
 "local_postcond s i \<equiv> (\<not> (ghost_lock s) (1 - i) \<longrightarrow> gsum s = (if bit (gdone s) 0 \<and> bit (gdone s) 1
              then global_sum (garr s)
              else local_sum (garr s ! i))) \<and> bit (gdone s) i \<and> \<not>ghost_lock s i"

definition
  sumarr :: "routine \<Rightarrow> (sumarr_state, funcs, faults) ann_com"
where
  "sumarr i \<equiv>
  \<lbrace>\<acute>sumarr_inv i \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
  \<acute>tsum:=\<acute>tsum(i:=0) ;;
  \<lbrace> \<acute>tsum i = 0 \<and> \<acute>sumarr_inv i \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
  \<acute>ti:=\<acute>ti(i:=0) ;;
  TRY
    \<lbrace> \<acute>tsum i = 0 \<and> \<acute>sumarr_inv i \<and> \<acute>ti i = 0 \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
    WHILE \<acute>ti i < NSUM
    INV \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i \<le> NSUM \<and> \<acute>tsum i \<le> MAXSUM \<and>
          \<acute>tsum i = local_sum (take (unat (\<acute>ti i)) (\<acute>tarr i)) \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
    DO
     \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and> \<acute>tsum i \<le> MAXSUM \<and>
       \<acute>tsum i = local_sum (take (unat (\<acute>ti i)) (\<acute>tarr i)) \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
     (InvalidMem, \<lbrace> array_in_bound (\<acute>tarr i)  (\<acute>ti i) \<rbrace>) \<longmapsto>
       \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and> \<acute>tsum i \<le> MAXSUM \<and>
         \<acute>tsum i = local_sum (take (unat (\<acute>ti i)) (\<acute>tarr i)) \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
       \<acute>tsum:=\<acute>tsum(i:=\<acute>tsum i + array_nth (\<acute>tarr i) (\<acute>ti i));;
     \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and>
         local_sum (take (unat (\<acute>ti i)) (\<acute>tarr i)) \<le> MAXSUM \<and>
         (\<acute>tsum i < MAXSUM \<and> array_nth (\<acute>tarr i) (\<acute>ti i) < MAXSUM \<longrightarrow>
       \<acute>tsum i = local_sum (take (Suc (unat (\<acute>ti i))) (\<acute>tarr i))) \<and>
         (array_nth (\<acute>tarr i) (\<acute>ti i) \<ge> MAXSUM \<or> \<acute>tsum i \<ge> MAXSUM\<longrightarrow>
           local_sum (\<acute>tarr i) = MAXSUM)  \<and>
       \<acute>sumarr_inv_till_lock i \<rbrace>
     (InvalidMem, \<lbrace> array_in_bound (\<acute>tarr i)  (\<acute>ti i) \<rbrace>) \<longmapsto>
       \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and>
         (\<acute>tsum i < MAXSUM \<and> array_nth (\<acute>tarr i) (\<acute>ti i) < MAXSUM \<longrightarrow>
           \<acute>tsum i = local_sum (take (Suc (unat (\<acute>ti i))) (\<acute>tarr i))) \<and>
         (array_nth (\<acute>tarr i) (\<acute>ti i) \<ge> MAXSUM \<or> \<acute>tsum i \<ge> MAXSUM \<longrightarrow>
           local_sum (\<acute>tarr i) = MAXSUM) \<and>
         \<acute>sumarr_inv_till_lock i\<rbrace>
       IF array_nth (\<acute>tarr i) (\<acute>ti i) \<ge> MAXSUM \<or> \<acute>tsum i \<ge> MAXSUM
       THEN
         \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and> local_sum (\<acute>tarr i) = MAXSUM \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
         \<acute>tsum:=\<acute>tsum(i:=MAXSUM);;
         \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and> \<acute>tsum i \<le> MAXSUM \<and>
           \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>sumarr_inv_till_lock i \<rbrace>
         THROW
       ELSE
         \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and> \<acute>tsum i \<le> MAXSUM \<and>
           \<acute>tsum i = local_sum (take (Suc (unat (\<acute>ti i))) (\<acute>tarr i)) \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
         SKIP
       FI;;
     \<lbrace> \<acute>sumarr_inv i \<and> \<acute>ti i < NSUM \<and> \<acute>tsum i \<le> MAXSUM \<and>
       \<acute>tsum i = local_sum (take (Suc (unat (\<acute>ti i))) (\<acute>tarr i)) \<and> \<acute>sumarr_inv_till_lock i \<rbrace>
     \<acute>ti:=\<acute>ti(i:=\<acute>ti i + 1)
    OD
  CATCH
    \<lbrace> \<acute>sumarr_inv i \<and> \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>sumarr_inv_till_lock i\<rbrace> SKIP
  END;;
  \<lbrace> \<acute>sumarr_inv i \<and> \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
  SCALL (''lock'', i) 0;;
  \<lbrace> \<acute>sumarr_inv i \<and> \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>glock = 1 \<and>
    \<acute>ghost_lock i \<and> \<acute>sumarr_inv_till_lock i \<rbrace>
  \<acute>gsum:=\<acute>gsum + \<acute>tsum i ;;
  \<lbrace> \<acute>sumarr_inv i \<and> \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>glock = 1 \<and>
    \<acute>ghost_lock i \<and> \<acute>sumarr_in_lock1 i \<rbrace>
  \<acute>gdone:=(\<acute>gdone OR \<acute>tid i) ;;
  \<lbrace> \<acute>sumarr_inv i \<and> \<acute>tsum i = local_sum (\<acute>tarr i) \<and> \<acute>glock = 1 \<and>
    \<acute>ghost_lock i \<and> bit \<acute>gdone (unat (\<acute>tid i - 1)) \<and> \<acute>sumarr_in_lock2 i \<rbrace>
  SCALL (''unlock'', i) 0"

definition
 precond
where
 "precond s \<equiv> (glock s) = 0 \<and> (gsum s) = 0\<and> (gdone s) = 0 \<and>
               (\<exists>a b. garr s = [a, b]) \<and>
               (\<forall>xs\<in>set (garr s). length xs = unat NSUM) \<and>
               (ghost_lock s) 0 = False \<and> (ghost_lock s) 1 = False"

definition
 postcond
where
 "postcond s \<equiv> (gsum s) = global_sum (garr s) \<and>
               (\<forall>i < 2. bit (gdone s) i)"

definition
  "call_sumarr i \<equiv>
    \<lbrace>length (\<acute>garr ! i) = unat NSUM \<and> \<acute>lock_inv \<and> \<acute>garr_inv i \<and>
     \<acute>sumarr_inv_till_lock i\<rbrace>
    CALLX (\<lambda>s. s\<lparr>tarr:=(tarr s)(i:=garr s ! i),
                 tid:=(tid s)(i:=of_nat i+1),
                 ti:=(ti s)(i:=undefined),
                 tsum:=(tsum s)(i:=undefined)\<rparr>)
          \<lbrace>\<acute>sumarr_inv i \<and> \<acute>sumarr_inv_till_lock i\<rbrace>
          (''sumarr'', i) 0
          (\<lambda>s t. t\<lparr>tarr:= (tarr t)(i:=(tarr s) i),
                   tid:=(tid t)(i:=(tid s i)),
                   ti:=(ti t)(i:=(ti s i)),
                   tsum:=(tsum t)(i:=(tsum s i))\<rparr>)
          (\<lambda>_ _. Skip)
          \<lbrace>\<acute>local_postcond i\<rbrace> \<lbrace>\<acute>local_postcond i\<rbrace>
          \<lbrace>False\<rbrace> \<lbrace>False\<rbrace>"

definition
  "\<Gamma> \<equiv> map_of (map (\<lambda>i. ((''sumarr'', i), com (sumarr i))) [0..<2]) ++
  map_of (map (\<lambda>i. ((''lock'', i), com (lock i))) [0..<2]) ++
  map_of (map (\<lambda>i. ((''unlock'', i), com (unlock i))) [0..<2])"

definition
  "\<Theta> \<equiv> map_of (map (\<lambda>i. ((''sumarr'', i), [ann (sumarr i)])) [0..<2]) ++
  map_of (map (\<lambda>i. ((''lock'', i), [ann (lock i)])) [0..<2]) ++
  map_of (map (\<lambda>i. ((''unlock'', i), [ann (unlock i)])) [0..<2])"

declare [[goals_limit = 10]]

lemma MAXSUM_le_plus:
  "x < MAXSUM \<Longrightarrow> MAXSUM \<le> MAXSUM + x"
  unfolding MAXSUM_def
  apply (rule word_le_plus[rotated], assumption)
  apply clarsimp
 done

lemma local_sum_Suc:
  "\<lbrakk>n < length arr; local_sum (take n arr) + arr ! n < MAXSUM;
    arr ! n < MAXSUM\<rbrakk> \<Longrightarrow>
    local_sum (take n arr) + arr ! n =
      local_sum (take (Suc n) arr)"
  apply (subst take_Suc_conv_app_nth)
   apply clarsimp
  apply (clarsimp simp: local_sum_def array_nat_sum_def )
   apply (subst (asm) min_def, clarsimp split: if_splits)
   apply (clarsimp simp: MAXSUM_le_plus word_not_le[symmetric])
  apply (subst min_absorb2)
   apply (subst of_nat_mono_maybe_le[where 'a=32])
     apply (clarsimp simp: MAXSUM_def)
    apply (clarsimp simp: MAXSUM_def)
    apply unat_arith
   apply (clarsimp simp: MAXSUM_def)
   apply unat_arith
  apply clarsimp
 done

lemma local_sum_MAXSUM:
  "k < length arr \<Longrightarrow> MAXSUM \<le> arr ! k \<Longrightarrow> local_sum arr = MAXSUM"
  apply (clarsimp simp: local_sum_def array_nat_sum_def)
  apply (rule word_unat.Rep_inverse')
  apply (rule min_absorb1[symmetric])
  apply (subst (asm) word_le_nat_alt)
  apply (rule le_trans[rotated])
   apply (rule elem_le_sum_list)
   apply simp
  apply clarsimp
 done

lemma local_sum_MAXSUM':
  \<open>local_sum arr = MAXSUM\<close>
  if \<open>k < length arr\<close>
    \<open>MAXSUM \<le> local_sum (take k arr) + arr ! k\<close>
    \<open>local_sum (take k arr) \<le> MAXSUM\<close>
    \<open>arr ! k \<le> MAXSUM\<close>
proof -
  define vs u ws where \<open>vs = take k arr\<close> \<open>u = arr ! k\<close> \<open>ws = drop (Suc k) arr\<close>
  with \<open>k < length arr\<close> have *: \<open>arr = vs @ u # ws\<close>
    and **: \<open>take k arr = vs\<close> \<open>arr ! k = u\<close>
    by (simp_all add: id_take_nth_drop)
  from that show ?thesis
    apply (simp add: **)
    apply (simp add: *)
    apply (simp add: local_sum_def array_nat_sum_def ac_simps)
    apply (rule word_unat.Rep_inverse')
    apply (rule min_absorb1[symmetric])
    apply (subst (asm) word_le_nat_alt)
    apply (subst (asm) unat_plus_simple[THEN iffD1])
     apply (rule word_add_le_mono2[where i=0, simplified])
     apply (clarsimp simp: MAXSUM_def)
     apply unat_arith
    apply (rule le_trans, assumption)
    apply (rule add_mono)
     apply simp_all
    apply (subst le_unat_uoi)
    apply (rule min.cobounded1)
     apply simp
    done
qed

lemma word_min_0[simp]:
 "min (x::'a::len word) 0 = 0"
 "min 0 (x::'a::len word) = 0"
 by (simp add:min_def)+

ML \<open>fun TRY' tac i = TRY (tac i)\<close>

lemma imp_disjL_context':
  "((P \<longrightarrow> R) \<and> (Q \<longrightarrow> R)) = ((P \<longrightarrow> R) \<and> (\<not>P \<and> Q \<longrightarrow> R))"
by auto

lemma map_of_prod_1[simp]:
  "i < n \<Longrightarrow>
    map_of (map (\<lambda>i. ((p, i), g i)) [0..<n])
       (p, i) = Some (g i)"
  apply (rule map_of_is_SomeI)
   apply (clarsimp simp: distinct_map o_def)
   apply (meson inj_onI prod.inject)
  apply clarsimp
  done

lemma map_of_prod_2[simp]:
  "i < n \<Longrightarrow> p \<noteq> q \<Longrightarrow>
    (m ++
    map_of (map (\<lambda>i. ((p, i), g i)) [0..<n]))
       (q, i) = m (q, i)"
  apply (rule map_add_dom_app_simps)
  apply (subst dom_map_of_conv_image_fst)
  apply clarsimp
  done

lemma sumarr_proc_simp[unfolded oghoare_simps]:
 "n < 2 \<Longrightarrow> \<Gamma> (''sumarr'',n) = Some (com (sumarr n))"
 "n < 2 \<Longrightarrow> \<Theta> (''sumarr'',n) = Some ([ann (sumarr n)])"
 "n < 2 \<Longrightarrow> \<Gamma> (''lock'',n) = Some (com (lock n))"
 "n < 2 \<Longrightarrow> \<Theta> (''lock'',n) = Some ([ann (lock n)])"
 "n < 2 \<Longrightarrow> \<Gamma> (''unlock'',n) = Some (com (unlock n))"
 "n < 2 \<Longrightarrow> \<Theta> (''unlock'',n) = Some ([ann (unlock n)])"
 "[ann (sumarr n)]!0 = ann (sumarr n)"
 "[ann (lock n)]!0 = ann (lock n)"
 "[ann (unlock n)]!0 = ann (unlock n)"
 by (simp add: \<Gamma>_def \<Theta>_def)+

lemmas sumarr_proc_simp_unfolded = sumarr_proc_simp[unfolded sumarr_def unlock_def lock_def oghoare_simps]

lemma oghoare_sumarr:
  \<open>\<Gamma>, \<Theta> |\<turnstile>\<^bsub>/F\<^esub> sumarr i \<lbrace>\<acute>local_postcond i\<rbrace>, \<lbrace>False\<rbrace>\<close> if \<open>i < 2\<close>
proof -
  from that have \<open>i = 0 \<or> i = 1\<close> by auto
  note sumarr_proc_simp_unfolded[proc_simp add]
  show ?thesis
  using that apply -
  unfolding sumarr_def unlock_def lock_def
    ann_call_def call_def block_def
  apply simp
  apply oghoare (*24*)
  unfolding tarr_inv_def array_length_def array_nth_def array_in_bound_def
    sumarr_in_lock1_def sumarr_in_lock2_def
  apply (tactic "PARALLEL_ALLGOALS ((TRY' o SOLVED')
          (clarsimp_tac (@{context} addsimps
                @{thms local_postcond_def global_sum_def ex_in_conv[symmetric]})
          THEN_ALL_NEW fast_force_tac
             (@{context} addSDs @{thms less_2_cases}
                         addIs @{thms local_sum_Suc unat_mono}
                        )
          ))") (*4*)
  using \<open>i = 0 \<or> i = 1\<close> apply rule
      apply (clarsimp simp add: bit_simps even_or_iff)
      apply (clarsimp simp add: bit_simps even_or_iff)
   apply clarsimp
   apply (rule conjI)
    apply (fastforce intro!: local_sum_Suc unat_mono)
   apply (subst imp_disjL_context')
   apply (rule conjI)
    apply clarsimp
    apply (erule local_sum_MAXSUM[rotated])
    apply unat_arith
   apply (clarsimp simp: not_le)
   apply (erule (1) local_sum_MAXSUM'[rotated] ; unat_arith)
  apply clarsimp
    apply unat_arith
  apply (fact that)
 done
qed

lemma less_than_two_2[simp]:
  "i < 2 \<Longrightarrow> Suc 0 - i < 2"
  by arith

lemma oghoare_call_sumarr:
notes sumarr_proc_simp[proc_simp add]
shows
  "i < 2 \<Longrightarrow>
  \<Gamma>, \<Theta> |\<turnstile>\<^bsub>/F\<^esub> call_sumarr i \<lbrace>\<acute>local_postcond i\<rbrace>, \<lbrace>False\<rbrace>"
  unfolding call_sumarr_def ann_call_def call_def block_def
    tarr_inv_def
  apply oghoare (*10*)

  apply (clarsimp; fail | ((simp only: pre.simps)?, rule  oghoare_sumarr))+
  apply (clarsimp simp: sumarr_def tarr_inv_def)
  apply (clarsimp simp: local_postcond_def; fail)+
  done

lemma less_than_two_inv[simp]:
  "i < 2 \<Longrightarrow> j < 2 \<Longrightarrow> i \<noteq> j \<Longrightarrow> Suc 0 - i = j"
  by simp

lemma inter_aux_call_sumarr [simplified]:
  notes sumarr_proc_simp_unfolded [proc_simp add]
     com.simps [oghoare_simps add]
     bit_simps [simp]
  shows
  "i < 2 \<Longrightarrow> j < 2 \<Longrightarrow> i \<noteq> j \<Longrightarrow> interfree_aux \<Gamma> \<Theta>
     F (com (call_sumarr i), (ann (call_sumarr i), \<lbrace>\<acute>local_postcond i\<rbrace>, \<lbrace>False\<rbrace>),
        com (call_sumarr j), ann (call_sumarr j))"
  unfolding call_sumarr_def ann_call_def call_def block_def
    tarr_inv_def sumarr_def lock_def unlock_def
  apply oghoare_interfree_aux (*650*)
  unfolding
    tarr_inv_def local_postcond_def sumarr_in_lock1_def
    sumarr_in_lock2_def
  by (tactic "PARALLEL_ALLGOALS (
                  TRY' (remove_single_Bound_mem @{context}) THEN'
                  (TRY' o SOLVED')
                  (clarsimp_tac @{context} THEN_ALL_NEW
                    fast_force_tac (@{context} addSDs @{thms less_2_cases})
                  ))") (* 2 minutes *)

lemma pre_call_sumarr:
  "i < 2 \<Longrightarrow> precond x \<Longrightarrow> x \<in> pre (ann (call_sumarr i))"
  unfolding precond_def call_sumarr_def ann_call_def
  by (fastforce dest: less_2_cases simp: array_length_def)

lemma post_call_sumarr:
  "local_postcond x 0 \<Longrightarrow> local_postcond x 1 \<Longrightarrow> postcond x"
  unfolding postcond_def local_postcond_def
  by (fastforce dest: less_2_cases split: if_splits)

lemma sumarr_correct:
  "\<Gamma>, \<Theta> |\<tturnstile>\<^bsub>/F\<^esub> \<lbrace>\<acute>precond\<rbrace>
    COBEGIN
      SCHEME [0 \<le> m < 2]
      call_sumarr m
      \<lbrace>\<acute>local_postcond m\<rbrace>,\<lbrace>False\<rbrace>
    COEND
   \<lbrace>\<acute>postcond\<rbrace>, \<lbrace>False\<rbrace>"
  apply oghoare (* 5 subgoals *)
      apply (fastforce simp: pre_call_sumarr)
     apply (rule oghoare_call_sumarr, simp)
    apply (clarsimp simp: post_call_sumarr)
   apply (simp add: inter_aux_call_sumarr)
  apply clarsimp
 done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(* Utility lemmas related to the mapping of separating conjunctions over sets and lists *)

theory Mapped_Separating_Conjunction
imports
  Sep_Algebra.Extended_Separation_Algebra
  "HOL-Library.Multiset"
begin

lemmas sep_map_set_conj_set_cong = arg_cong[where f="sep_map_set_conj P" for P]

lemma sep_map_set_conj_set_elim:
  "sep_map_set_conj P xs s \<Longrightarrow> \<lbrakk> \<And>x s. x \<in> xs \<Longrightarrow> P x s = Q x s\<rbrakk> \<Longrightarrow>  sep_map_set_conj Q xs s"
  apply (induct xs arbitrary: s rule: infinite_finite_induct)
    apply fastforce
   apply fastforce
  apply clarsimp
  apply (erule sep_conj_impl; blast)
  done

lemma split_filter_set: "xs = {x \<in> xs. P x} \<union> {x \<in> xs. \<not>P x}"
  by blast

lemma set_minus_not_filter[simp]: "{x \<in> xs. P x} - {x \<in> xs. \<not>P x} = {x \<in> xs. P x}"
  by blast

lemma set_minus_not_filter'[simp]: "{x \<in> xs. \<not>P x} - {x \<in> xs. P x} = {x \<in> xs. \<not>P x}"
  by blast

lemma set_inter_not_filter[simp]: "{x \<in> xs. P x} \<inter> {x \<in> xs. \<not>P x} = {}"
  by blast

declare sep_list_conj_map_add[simp]

lemma sep_map_list_conj_decomp[simp]:
  "sep_map_list_conj (\<lambda>(x, y). P x y \<and>* Q x y) xs =
     (sep_map_list_conj (\<lambda>(x, y). P x y) xs \<and>* sep_map_list_conj (\<lambda>(x , y). Q x y) xs)"
  apply (intro ext iffI)
   apply (induct xs; clarsimp)
   apply sep_cancel+
   apply fastforce
  apply (induct xs; clarsimp)
  apply sep_cancel+
  apply fastforce
  done

lemma image_insertD: "insert (P x) (P ` S) = Q ` S' \<Longrightarrow> \<exists>s\<in>S'. Q s = P x "
  by (metis imageE insertI1)

lemma sep_map_set_inj_eqI:
  "inj_on P xs \<Longrightarrow> inj_on Q ys \<Longrightarrow> P ` xs = Q ` ys \<Longrightarrow>
   sep_map_set_conj P xs = sep_map_set_conj Q ys"
  apply (induct xs arbitrary: ys rule: infinite_finite_induct)
    apply clarsimp
    defer
    apply clarsimp+
   apply (frule image_insertD)
   apply clarsimp
   apply atomize
   apply (erule_tac x="ys - {s}" in allE)
   apply (drule mp)
    apply (simp add: inj_on_diff)
   apply (drule mp)
    apply (metis (no_types, opaque_lifting) image_insert inj_on_insert insert_Diff_single
                                       insert_absorb insert_ident)
   apply clarsimp
   apply (subgoal_tac "finite ys")
    apply (simp add: sep.prod.remove)
   apply (metis finite.insertI finite_image_iff)
  apply (subgoal_tac "infinite ys", clarsimp)
  using finite_image_iff by fastforce

lemma add_mset_eq_mem:
  "add_mset (P x) (image_mset P (mset_set F)) = image_mset Q (mset_set S')
   \<Longrightarrow> \<exists>y. Q y = P x \<and> y \<in> S'"
  apply (drule union_single_eq_member)
  apply clarsimp
  by (metis elem_mset_set empty_iff infinite_set_mset_mset_set)

lemma sep_map_set_conj_mset_eq:
  "\<lbrakk>image_mset P (mset_set S) = image_mset Q (mset_set S');
    finite S; finite S'\<rbrakk>
   \<Longrightarrow> sep_map_set_conj P S = sep_map_set_conj Q S'"
  apply (induction S arbitrary: S' rule: infinite_finite_induct; clarsimp)
   apply (simp add: mset_set_empty_iff)
  apply (subgoal_tac "\<exists>y. y \<in> S' \<and> Q y = P x")
   apply (clarsimp simp: sep.prod.remove mset_set.remove)
  by (fastforce dest: union_single_eq_member)

lemma sep_map_set_conj_multisetE:
  "\<lbrakk>sep_map_set_conj P S s; finite S; finite S';
    image_mset P (mset_set S) = image_mset Q (mset_set S')\<rbrakk>
   \<Longrightarrow> sep_map_set_conj Q S' s"
  by (subst sep_map_set_conj_mset_eq; fastforce)

lemma not_in_image_vimage: "x \<notin> P ` S \<Longrightarrow> P -` {x} \<inter> S = {}"
  by blast

lemma bij_image_mset_eq:
  "\<lbrakk>finite S; finite S'; P ` S = Q ` S';
    (\<And>x. x \<in> P ` S \<Longrightarrow> \<exists>f. bij_betw f (P -` {x} \<inter> S) (Q -` {x} \<inter> S'))\<rbrakk>
   \<Longrightarrow> image_mset P (mset_set S) = image_mset Q (mset_set S')"
  apply (rule multiset_eqI)
  apply (clarsimp simp: count_image_mset)
  apply (case_tac "x \<in> Q ` S'"; clarsimp simp: bij_betw_iff_card not_in_image_vimage )
  done

lemma sep_map_set_elim:
  "\<lbrakk>sep_map_set_conj P xs s;
    xs = ys;
    (\<And>x s. x \<in> xs \<Longrightarrow> P x s \<Longrightarrow> Q x s)\<rbrakk>
   \<Longrightarrow> sep_map_set_conj Q ys s"
  apply clarsimp
  apply (case_tac "finite xs")
   apply clarsimp
   apply (erule sep_map_set_conj_impl)
    apply atomize
    apply (erule_tac x=x in allE)
    apply clarsimp
   apply clarsimp
  apply clarsimp
  done

lemma sep_map_set_conj_Union:
  "\<lbrakk>\<forall>s \<in> S. finite s;
    \<forall>s s'. s \<in> S \<and> s' \<in> S \<longrightarrow> s \<noteq> s' \<longrightarrow> s \<inter> s' = {}\<rbrakk>
   \<Longrightarrow> sep_map_set_conj (sep_map_set_conj P) S = sep_map_set_conj P (\<Union> S) "
  apply (induct S rule: infinite_finite_induct; clarsimp)
   apply (metis (no_types) finite_UnionD sep.prod.infinite)
  apply (subst sep.prod.union_disjoint; clarsimp?)
  by blast

lemma sep_map_set_quotient_split:
  "\<lbrakk>finite xs; equiv xs R\<rbrakk>
   \<Longrightarrow> sep_map_set_conj P xs = sep_map_set_conj (sep_map_set_conj P ) (xs//R) "
  apply (subst sep_map_set_conj_Union; clarsimp)
    apply (meson in_quotient_imp_subset infinite_super)
   apply (fastforce dest: quotient_disj)
  by (simp add: Union_quotient)

lemma sep_map_set_conj_congE:
  "\<lbrakk>sep_map_set_conj (sep_map_set_conj P) xs s;
    finite xs;
    finite ys;
    xs - {{}} = ys - {{}}\<rbrakk>
   \<Longrightarrow> sep_map_set_conj (sep_map_set_conj P) ys s"
  apply clarsimp
  apply (induct xs arbitrary:ys s rule: infinite_finite_induct)
    apply clarsimp+
   apply (subgoal_tac "ys = {{}} \<or> ys = {}")
    apply (erule disjE; clarsimp)
   apply blast
  apply clarsimp
  apply (case_tac "x = {}")
   apply (metis Diff_idemp Diff_insert_absorb Sep_Tactic_Helpers.sep_conj_empty sep.prod.empty)
  apply (subgoal_tac "x \<in> ys")
   apply (clarsimp simp: sep.prod.remove)
   apply sep_cancel
   apply (metis Diff_insert Diff_insert2 Diff_insert_absorb finite_Diff)
  apply blast
  done

lemma sep_map_set_conj_cong_empty_eq:
  "\<lbrakk>finite xs;
    finite ys;
    xs - {{}} = ys - {{}}\<rbrakk>
   \<Longrightarrow> sep_map_set_conj (sep_map_set_conj P) xs = sep_map_set_conj (sep_map_set_conj P) ys "
  apply clarsimp
  apply (intro ext iffI; erule sep_map_set_conj_congE)
  by blast+

lemma sep_map_set_conj_match:
  "sep_map_set_conj P S s \<Longrightarrow> (\<And>x s. x \<in> S \<Longrightarrow> P x s \<Longrightarrow> Q x s) \<Longrightarrow> sep_map_set_conj Q S s"
  apply (induct rule: infinite_finite_induct; clarsimp)
  apply (erule sep_conj_impl)
   apply blast
  by (metis sep_map_set_elim)

lemma sep_map_set_squash:
  "\<lbrakk>\<forall>x y. x \<in> S \<longrightarrow> y \<in> S \<longrightarrow> x \<noteq> y \<longrightarrow> f x = f y \<longrightarrow> f x = {}; finite S\<rbrakk>
   \<Longrightarrow> sep_map_set_conj (\<lambda>v. sep_map_set_conj P (f v)) S =
      sep_map_set_conj (sep_map_set_conj P) (f ` S)"
  apply (induction S rule: infinite_finite_induct; clarsimp)
  apply (case_tac "f x \<in> f ` F"; clarsimp)
  apply (subgoal_tac "f x = {}")
   apply clarsimp
  apply blast
  done

lemma sep_map_set_conj_subst:
  "(\<And>x. x \<in> S \<Longrightarrow> Q x = Q' x) \<Longrightarrow> sep_map_set_conj Q S = sep_map_set_conj Q' S"
  by clarsimp

lemma sep_map_zip_fst:
  "(\<And>* map (\<lambda>(a,b). f a) (zip xs ys)) s =
   (\<And>* map (\<lambda>a. f (fst a)) (zip xs ys)) s"
  by (simp add: case_prod_unfold)

lemma sep_map_zip_snd:
  "(\<And>* map (\<lambda>(a, b). f b) (zip xs ys)) s =
   (\<And>* map (\<lambda>a. f (snd a)) (zip xs ys)) s"
  by (simp add: case_prod_unfold)

declare sep_map_zip_fst[THEN iffD1, sep_cancel] sep_map_zip_fst[THEN iffD2, sep_cancel]
        sep_map_zip_snd[THEN iffD1, sep_cancel] sep_map_zip_snd[THEN iffD2, sep_cancel]

lemma precise_non_dup: "precise P \<Longrightarrow> \<not>P 0  \<Longrightarrow> \<not> (P \<and>* P) (s :: ('a :: cancellative_sep_algebra))"
  apply (rule ccontr, simp)
  apply (clarsimp simp: sep_conj_def)
  apply (clarsimp simp: precise_def)
  apply (erule_tac x="x+y" in allE)
  apply (erule_tac x=x in allE)
  apply (erule_tac x=y in allE)
  apply (clarsimp)
  apply (drule mp)
  using sep_disj_commuteI sep_substate_disj_add sep_substate_disj_add' apply blast
  apply (clarsimp)
  by (metis disjoint_zero_sym sep_add_cancel sep_add_zero_sym sep_disj_positive)

lemma duplicate_inj: "finite S \<Longrightarrow> sep_map_set_conj f S s \<Longrightarrow> (\<And>s. \<forall>x\<in>(f ` S). \<not>(x \<and>* x) s) \<Longrightarrow> inj_on f S"
 apply (clarsimp simp: inj_on_def)
 apply (erule contrapos_pp[where Q="f _ = f _"])
 apply (clarsimp simp: sep.prod.remove)
 apply (subst (asm) sep.prod.remove[where x=y])
 apply (clarsimp)+
 by (metis sep_conj_assoc sep_conj_false_left sep_globalise)

lemma inj_on_sep_set_conj: "inj_on f S \<Longrightarrow> sep_map_set_conj f S = sep_set_conj (f ` S)"
  by (simp add: sep.prod.reindex_cong sep_set_conj_def)

lemma image_remove: "(f ` (S - {x. f x = \<box>})) = (f ` S - {\<box>})"
 apply (intro set_eqI iffI; clarsimp )
done

lemma sep_prod_setdiff_sep_empty: "finite S \<Longrightarrow> sep.Prod (f ` (S - {x. f x = \<box>})) s \<Longrightarrow> sep.Prod (f ` S) s"
 apply (subst sep.prod.setdiff_irrelevant[symmetric]; clarsimp simp: image_remove)
done

lemma "sep_map_set_conj f S s \<Longrightarrow> finite S \<Longrightarrow> (\<forall>P\<in>(f ` S) - {\<box>}. precise P) \<Longrightarrow> sep_set_conj (f ` S) s"
  apply (subst (asm)  sep.prod.setdiff_irrelevant[symmetric])
   apply (clarsimp)
  apply (frule duplicate_inj[rotated])
    apply (clarsimp)
    apply (erule_tac x="f x" in ballE)
     apply (frule precise_non_dup)
      apply (clarsimp simp: sep_empty_def)
  apply (metis (mono_tags, opaque_lifting) disjoint_zero_sym precise_def sep_add_zero
                                      sep_disj_zero sep_substate_disj_add')
     apply (fastforce)
    apply (blast)
   apply (blast)
  apply (clarsimp simp: inj_on_sep_set_conj)
  apply (clarsimp simp: sep_set_conj_def)
  apply (erule (1) sep_prod_setdiff_sep_empty)
done

end


section \<open> Reactive Conditions \<close>

theory utp_rea_cond
  imports utp_rea_rel
begin

subsection \<open> Healthiness Conditions \<close>

definition RC1 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "RC1(P) = (\<not>\<^sub>r (\<not>\<^sub>r P) ;; true\<^sub>r)"

definition RC :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "RC = RC1 \<circ> RR"

lemma RC_intro: "\<lbrakk> P is RR; ((\<not>\<^sub>r (\<not>\<^sub>r P) ;; true\<^sub>r) = P) \<rbrakk> \<Longrightarrow> P is RC"
  by (simp add: Healthy_def RC1_def RC_def)

lemma RC_intro': "\<lbrakk> P is RR; P is RC1 \<rbrakk> \<Longrightarrow> P is RC"
  by (simp add: Healthy_def RC1_def RC_def)
lemma RC1_idem: "RC1(RC1(P)) = RC1(P)"
  by (rel_auto, (blast intro: dual_order.trans)+)

lemma RC1_mono: "P \<sqsubseteq> Q \<Longrightarrow> RC1(P) \<sqsubseteq> RC1(Q)"
  by (rel_blast)

lemma RC1_prop:
  assumes "P is RC1"
  shows "(\<not>\<^sub>r P) ;; R1 true = (\<not>\<^sub>r P)"
proof -
  have "(\<not>\<^sub>r P) = (\<not>\<^sub>r (RC1 P))"
    by (simp add: Healthy_if assms)
  also have "... = (\<not>\<^sub>r P) ;; R1 true"
    by (simp add: RC1_def rpred closure)
  finally show ?thesis ..
qed

lemma R2_RC: "R2 (RC P) = RC P"
proof -
  have "\<not>\<^sub>r RR P is RR"
    by (metis (no_types) Healthy_Idempotent RR_Idempotent RR_rea_not)
  then show ?thesis
    by (metis (no_types) Healthy_def' R1_R2c_seqr_distribute R2_R2c_def RC1_def RC_def RR_implies_R1 RR_implies_R2c comp_apply rea_not_R2_closed rea_true_R1 rea_true_R2c)
qed

lemma RC_R2_def: "RC = RC1 \<circ> RR"
  by (auto simp add: RC_def fun_eq_iff R1_R2c_commute[THEN sym] R1_R2c_is_R2)

lemma RC_implies_R2: "P is RC \<Longrightarrow> P is R2"
  by (metis Healthy_def' R2_RC)

lemma RC_ex_ok_wait: "(\<exists> {$ok, $ok\<acute>, $wait, $wait\<acute>} \<bullet> RC P) = RC P"
  by (rel_auto)

text \<open> An important property of reactive conditions is they are monotonic with respect to the trace.
  That is, $P$ with a shorter trace is refined by $P$ with a longer trace. \<close>

lemma RC_prefix_refine:
  assumes "P is RC" "s \<le> t"
  shows "P\<lbrakk>0,\<guillemotleft>s\<guillemotright>/$tr,$tr\<acute>\<rbrakk> \<sqsubseteq> P\<lbrakk>0,\<guillemotleft>t\<guillemotright>/$tr,$tr\<acute>\<rbrakk>"
proof -
  from assms(2) have "(RC P)\<lbrakk>0,\<guillemotleft>s\<guillemotright>/$tr,$tr\<acute>\<rbrakk> \<sqsubseteq> (RC P)\<lbrakk>0,\<guillemotleft>t\<guillemotright>/$tr,$tr\<acute>\<rbrakk>"
    apply (rel_auto)
    using dual_order.trans apply blast
    done
  thus ?thesis
    by (simp only: assms(1) Healthy_if)
qed

text \<open> The @{term RC} healthy relations can also be defined in terms of prefix closure,
  which is characterised by the healthiness condition below. \<close>

definition RC2 :: "('t::trace, '\<alpha>, '\<beta>) rel_rp \<Rightarrow> ('t, '\<alpha>, '\<beta>) rel_rp" where
[upred_defs]: "RC2(P) = R1(P ;; ($tr\<acute> \<le>\<^sub>u $tr))"

lemma RC2_RR_commute:
  "RC2(RR(P)) = RR(RC2(P))"
  apply (rel_auto)
  using minus_cancel_le apply blast
  apply (metis diff_add_cancel_left' le_add trace_class.add_diff_cancel_left trace_class.add_left_mono)
  done

text \<open> Intuitive meaning of @{term RC2} \<close>

lemma RC2_form_1:
  assumes "P is RR"
  shows "RC2(P) = (\<^bold>\<exists> tr\<^sub>0 \<bullet> (\<exists> $\<Sigma>\<^sub>R\<acute> \<bullet> P)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> \<and> $tr\<acute> \<le>\<^sub>u \<guillemotleft>tr\<^sub>0\<guillemotright> \<and> $tr \<le>\<^sub>u $tr\<acute>)"
proof -
  have "RC2(RR(P)) = (\<^bold>\<exists> tr\<^sub>0 \<bullet> (\<exists> $\<Sigma>\<^sub>R\<acute> \<bullet> RR P)\<lbrakk>\<guillemotleft>tr\<^sub>0\<guillemotright>/$tr\<acute>\<rbrakk> \<and> $tr\<acute> \<le>\<^sub>u \<guillemotleft>tr\<^sub>0\<guillemotright> \<and> $tr \<le>\<^sub>u $tr\<acute>)"
    by (rel_blast)
  thus ?thesis
    by (metis (mono_tags, lifting) Healthy_if assms shEx_cong)
qed

lemma RC2_form_2:
  assumes "P is RR"
    shows "RC2(P) = (\<^bold>\<exists> (t\<^sub>0, t\<^sub>1) \<bullet> (\<exists> $\<Sigma>\<^sub>R\<acute> \<bullet> P)\<lbrakk>0,\<guillemotleft>t\<^sub>1\<guillemotright>/$tr,$tr\<acute>\<rbrakk> \<and> \<guillemotleft>t\<^sub>0\<guillemotright> \<le>\<^sub>u \<guillemotleft>t\<^sub>1\<guillemotright> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>t\<^sub>0\<guillemotright>)"
proof -
  have "RC2(RR(P)) = (\<^bold>\<exists> (t\<^sub>0, t\<^sub>1) \<bullet> (\<exists> $\<Sigma>\<^sub>R\<acute> \<bullet> RR(P))\<lbrakk>0,\<guillemotleft>t\<^sub>1\<guillemotright>/$tr,$tr\<acute>\<rbrakk> \<and> \<guillemotleft>t\<^sub>0\<guillemotright> \<le>\<^sub>u \<guillemotleft>t\<^sub>1\<guillemotright> \<and> $tr\<acute> =\<^sub>u $tr + \<guillemotleft>t\<^sub>0\<guillemotright>)"
    apply (rel_auto)
    apply (metis diff_add_cancel_left' trace_class.add_le_imp_le_left)
    apply (metis le_add trace_class.add_diff_cancel_left trace_class.add_left_mono)
    done
  thus ?thesis
    by (simp add: Healthy_if assms)
qed

text \<open> Every reactive condition is prefix closed \<close>

lemma RC_prefix_closed:
  assumes "P is RC"
  shows "P is RC2"
proof -
  have "RC2(RC(P)) = RC(P)"
    by (rel_auto)
  thus ?thesis
    by (metis Healthy_def assms)
qed

lemma RC2_RR_is_RC1:
  assumes "P is RR" "P is RC2"
  shows "P is RC1"
proof -
  have "RC1(RC2(RR(P))) = RC2(RR(P))"
    apply (rel_auto) using dual_order.trans by blast
  thus ?thesis
    by (metis Healthy_def assms(1) assms(2))
qed

text \<open> @{term RC} closure can be demonstrated in terms of prefix closure. \<close>

lemma RC_intro_prefix_closed:
  assumes "P is RR" "P is RC2"
  shows "P is RC"
  by (simp add: RC2_RR_is_RC1 RC_intro' assms)

subsection \<open> Closure laws \<close>

lemma RC_implies_RR [closure]:
  assumes "P is RC"
  shows "P is RR"
  by (metis Healthy_def RC_ex_ok_wait RC_implies_R2 RR_def assms)

lemma RC_implies_RC1: "P is RC \<Longrightarrow> P is RC1"
  by (metis Healthy_def RC_R2_def RC_implies_RR comp_eq_dest_lhs)

lemma RC1_trace_ext_prefix:
  "out\<alpha> \<sharp> e \<Longrightarrow> RC1(\<not>\<^sub>r $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>) = (\<not>\<^sub>r $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute>)"
  by (rel_auto, blast, metis (no_types, lifting) dual_order.trans)

lemma RC1_conj [rpred]: "RC1(P \<and> Q) = (RC1(P) \<and> RC1(Q))"
  by (rel_blast)

lemma conj_RC1_closed [closure]:
  "\<lbrakk> P is RC1; Q is RC1 \<rbrakk> \<Longrightarrow> P \<and> Q is RC1"
  by (simp add: Healthy_def RC1_conj)

lemma disj_RC1_closed [closure]:
  assumes "P is RC1" "Q is RC1"
  shows "(P \<or> Q) is RC1"
proof -
  have 1:"RC1(RC1(P) \<or> RC1(Q)) = (RC1(P) \<or> RC1(Q))"
    apply (rel_auto) using dual_order.trans by blast+
  show ?thesis
    by (metis (no_types) Healthy_def 1 assms)
qed

lemma conj_RC_closed [closure]:
  assumes "P is RC" "Q is RC"
  shows "(P \<and> Q) is RC"
  by (metis Healthy_def RC_R2_def RC_implies_RR assms comp_apply conj_RC1_closed conj_RR)

lemma rea_true_RC [closure]: "true\<^sub>r is RC"
  by (rel_auto)

lemma false_RC [closure]: "false is RC"
  by (rel_auto)

lemma disj_RC_closed [closure]: "\<lbrakk> P is RC; Q is RC \<rbrakk> \<Longrightarrow> (P \<or> Q) is RC"
  by (metis Healthy_def RC_R2_def RC_implies_RR comp_apply disj_RC1_closed disj_RR)

lemma UINF_mem_RC1_closed [closure]:
  assumes "\<And> i. P i is RC1"
  shows "(\<Sqinter> i\<in>A \<bullet> P i) is RC1"
proof -
  have 1:"RC1(\<Sqinter> i\<in>A \<bullet> RC1(P i)) = (\<Sqinter> i\<in>A \<bullet> RC1(P i))"
    by (rel_auto, meson order.trans)
  show ?thesis
    by (metis (mono_tags, lifting) "1" Healthy_def UINF_cong assms)
qed

lemma UINF_mem_RC_closed [closure]:
  assumes "\<And> i. P i is RC"
  shows "(\<Sqinter> i\<in>A \<bullet> P i) is RC"
proof -
  have "RC(\<Sqinter> i\<in>A \<bullet> P i) = (RC1 \<circ> RR)(\<Sqinter> i\<in>A \<bullet> P i)"
    by (simp add: RC_def)
  also have "... = RC1(\<Sqinter> i\<in>A \<bullet> RR(P i))"
    by (rel_blast)
  also have "... = RC1(\<Sqinter> i\<in>A \<bullet> RC1(P i))"
    by (simp add: Healthy_if RC_implies_RR RC_implies_RC1 assms)
  also have "... = (\<Sqinter> i\<in>A \<bullet> RC1(P i))"
    by (rel_auto, meson order.trans)
  also have "... = (\<Sqinter> i\<in>A \<bullet> P i)"
    by (simp add: Healthy_if RC_implies_RC1 assms)
  finally show ?thesis
    by (simp add: Healthy_def)
qed

lemma UINF_ind_RC_closed [closure]:
  assumes "\<And> i. P i is RC"
  shows "(\<Sqinter> i \<bullet> P i) is RC"
  by (metis (no_types) UINF_as_Sup_collect' UINF_as_Sup_image UINF_mem_RC_closed assms)

lemma USUP_mem_RC1_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RC1" "A \<noteq> {}"
  shows "(\<Squnion> i\<in>A \<bullet> P i) is RC1"
proof -
  have "RC1(\<Squnion> i\<in>A \<bullet> P i) = RC1(\<Squnion> i\<in>A \<bullet> RC1(P i))"
    by (simp add: Healthy_if assms(1) cong: USUP_cong)
  also from assms(2) have "... = (\<Squnion> i\<in>A \<bullet> RC1(P i))"
    using dual_order.trans by (rel_blast)
  also have "... = (\<Squnion> i\<in>A \<bullet> P i)"
    by (simp add: Healthy_if assms(1) cong: USUP_cong)
  finally show ?thesis
    using Healthy_def by blast
qed

lemma USUP_mem_RC_closed [closure]:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is RC" "A \<noteq> {}"
  shows "(\<Squnion> i\<in>A \<bullet> P i) is RC"
  by (rule RC_intro', simp_all add: closure assms RC_implies_RC1)

lemma USUP_ind_RC_closed [closure]:
  "\<lbrakk> \<And> i. P i is RC \<rbrakk> \<Longrightarrow> (\<Squnion> i \<bullet> P i) is RC"
  by (metis UNIV_not_empty USUP_mem_RC_closed)

lemma neg_trace_ext_prefix_RC [closure]:
  "\<lbrakk> $tr \<sharp> e; $ok \<sharp> e; $wait \<sharp> e; out\<alpha> \<sharp> e \<rbrakk> \<Longrightarrow> \<not>\<^sub>r $tr ^\<^sub>u e \<le>\<^sub>u $tr\<acute> is RC"
  by (rule RC_intro, simp add: closure, metis RC1_def RC1_trace_ext_prefix)

lemma RC1_unrest:
  "\<lbrakk> mwb_lens x; x \<bowtie> tr \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> RC1(P)"
  by (simp add: RC1_def unrest)

lemma RC_unrest_dashed [unrest]:
  "\<lbrakk> P is RC; mwb_lens x; x \<bowtie> tr \<rbrakk> \<Longrightarrow> $x\<acute> \<sharp> P"
  by (metis Healthy_if RC1_unrest RC_implies_RC1)

lemma RC1_RR_closed [closure]: "P is RR \<Longrightarrow> RC1(P) is RR"
  by (simp add: RC1_def closure)

end