section \<open>ICF-setup for Automatic Refinement\<close>
theory ICF_Autoref
imports
  ICF_Refine_Monadic
  "../GenCF/Intf/Intf_Set"
  "../GenCF/Intf/Intf_Map"
begin

subsection \<open>Unique Priority Queue\<close>
consts i_prio :: "interface \<Rightarrow> interface \<Rightarrow> interface"
definition [simp]: "op_uprio_empty \<equiv> Map.empty"
definition [simp]: "op_uprio_is_empty x \<equiv> x = Map.empty"
definition [simp]: "op_uprio_insert s e a \<equiv> s(e \<mapsto> a)"
definition op_uprio_prio :: "('e\<rightharpoonup>'a)\<Rightarrow>'e\<rightharpoonup>'a"
  where [simp]: "op_uprio_prio s e \<equiv> s e"

(* FIXME: Tune id-(phase) such that it can distinguish those patterns!
  For now: Only include this patterns on demand!
*)
context begin interpretation autoref_syn .

lemma uprio_pats:
  fixes s :: "'e\<rightharpoonup>'a"
  shows
  "Map.empty::'e\<rightharpoonup>'a \<equiv> op_uprio_empty"
  "s e \<equiv> op_uprio_prio$s$e"
  "s(e\<mapsto>a) \<equiv> op_uprio_insert$s$e$a"

  "dom s = {} \<equiv> op_uprio_is_empty$s"
  "{} = dom s \<equiv> op_uprio_is_empty$s"
  "s=Map.empty \<equiv> op_uprio_is_empty$s"
  "Map.empty=s \<equiv> op_uprio_is_empty$s"
  by (auto intro!: eq_reflection)

end

term prio_pop_min

lemma [autoref_itype]:
  "op_uprio_empty ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio"
  "op_uprio_prio ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ia\<rangle>\<^sub>ii_option"
  "op_uprio_is_empty ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i i_bool"
  "op_uprio_insert ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i Ia \<rightarrow>\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio"
  "prio_pop_min ::\<^sub>i \<langle>Ie,Ia\<rangle>\<^sub>ii_prio \<rightarrow>\<^sub>i \<langle>\<langle>Ie,\<langle>Ia,\<langle>Ie,Ia\<rangle>\<^sub>ii_prio\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
  by simp_all

context uprio begin
  definition rel_def_internal:
    "\<And>Re Ra. rel Re Ra \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
  lemma rel_def:
    "\<And>Re Ra. \<langle>Re,Ra\<rangle>rel \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_sv[relator_props]:
    "\<And>Re Ra. \<lbrakk>Range Re = UNIV; single_valued Ra\<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,Ra\<rangle>rel)"
    unfolding rel_def by tagged_solver

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_prio]
end

lemma (in uprio) rel_alt: "\<langle>Id,Rv\<rangle>rel =
  { (c,a). \<forall>x. (\<alpha> c x,a x)\<in>\<langle>Rv\<rangle>option_rel \<and> invar c }"
  by (auto simp: rel_def br_def dest: fun_relD)

lemma (in uprio_empty) autoref_empty[autoref_rules]:
  "\<And>Re Ra. PREFER_id Re \<Longrightarrow> (empty (),op_uprio_empty)\<in>\<langle>Re,Ra\<rangle>rel"
  by (auto simp: empty_correct rel_alt)

lemma (in uprio_isEmpty) autoref_is_empty[autoref_rules]:
  "\<And>Re Ra. PREFER_id Re \<Longrightarrow> (isEmpty,op_uprio_is_empty)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>bool_rel"
  by (auto simp: isEmpty_correct rel_alt intro!: ext)

lemma (in uprio_prio) autoref_prio[autoref_rules]:
  "\<And>Re Ra. PREFER_id Re \<Longrightarrow> (prio,op_uprio_prio)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>Re\<rightarrow>\<langle>Ra\<rangle>option_rel"
  by (auto simp: prio_correct rel_alt intro!: ext)

lemma (in uprio_insert) autoref_insert[autoref_rules]:
  "\<And>Re Ra. PREFER_id Re \<Longrightarrow> (insert,op_uprio_insert)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>Re\<rightarrow>Ra\<rightarrow>\<langle>Re,Ra\<rangle>rel"
  by (auto simp: insert_correct rel_alt intro!: ext)

lemma (in uprio_pop) autoref_prio_pop_min[autoref_rules]:
  "\<And>Re Ra. \<lbrakk>PREFER_id Re; PREFER_id Ra \<rbrakk>
  \<Longrightarrow> (\<lambda>s. RETURN (pop s),prio_pop_min)\<in>\<langle>Re,Ra\<rangle>rel\<rightarrow>\<langle>\<langle>Re,\<langle>Ra,\<langle>Re,Ra\<rangle>rel\<rangle>prod_rel\<rangle>prod_rel\<rangle>nres_rel"
  apply simp
  apply (intro fun_relI nres_relI)
  by (rule prio_pop_min_refine)

context set begin
  definition rel_def_internal: "rel R \<equiv> br \<alpha> invar O \<langle>R\<rangle>set_rel"
  lemma rel_def: "\<langle>R\<rangle>rel \<equiv> br \<alpha> invar O \<langle>R\<rangle>set_rel"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id\<rangle>rel = br \<alpha> invar" by (simp add: rel_def)

  lemma rel_sv[relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>rel)"
    unfolding rel_def by tagged_solver

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_set]

end

context map begin
  definition rel_def_internal:
    "rel Rk Rv \<equiv> br \<alpha> invar O (Rk \<rightarrow> \<langle>Rv\<rangle> option_rel)"
  lemma rel_def:
    "\<langle>Rk,Rv\<rangle>rel \<equiv> br \<alpha> invar O (Rk \<rightarrow> \<langle>Rv\<rangle> option_rel)"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id,Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]:
    "\<lbrakk>Range Rk = UNIV; single_valued Rv\<rbrakk> \<Longrightarrow> single_valued (\<langle>Rk,Rv\<rangle>rel)"
    unfolding rel_def
    by (tagged_solver (trace))

  lemmas [autoref_rel_intf] = REL_INTFI[of rel i_map]

end

(*
context list begin
  definition rel_def_internal:
    "rel R \<equiv> br \<alpha> invar O R"
  lemma rel_def: "\<langle>R\<rangle>rel \<equiv> br \<alpha> invar O R"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>rel)"
    unfolding rel_def by refine_post
end

context al begin
  definition rel_def_internal:
    "rel Re Ra \<equiv> br \<alpha> invar O \<langle>\<langle>Re,Ra\<rangle> prod_rel\<rangle>list_rel"
  lemma rel_def:
    "\<langle>Re,Ra\<rangle>rel \<equiv> br \<alpha> invar O \<langle>\<langle>Re,Ra\<rangle> prod_rel\<rangle>list_rel"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id,Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]:
    "\<lbrakk>single_valued Re; single_valued Ra\<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,Ra\<rangle>rel)"
    unfolding rel_def by refine_post

end

context prio begin
  (* TODO: Fix that to use multiset_rel! *)
  definition rel_def[simp]: "rel \<equiv> br \<alpha> invar"
  lemma rel_sv: "single_valued rel" unfolding rel_def by refine_post
end

context uprio begin
  definition rel_def_internal:
    "rel Re Ra \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
  lemma rel_def:
    "\<langle>Re,Ra\<rangle>rel \<equiv> br \<alpha> invar O (Re \<rightarrow> \<langle>Ra\<rangle> option_rel)"
    by (simp add: rel_def_internal relAPP_def)

  lemma rel_id[simp]: "\<langle>Id,Id\<rangle>rel = br \<alpha> invar"
    by (simp add: rel_def)

  lemma rel_sv[relator_props]:
    "\<lbrakk>Range Re = UNIV; single_valued Ra\<rbrakk> \<Longrightarrow> single_valued (\<langle>Re,Ra\<rangle>rel)"
    unfolding rel_def by refine_post

end
*)

setup \<open>Revert_Abbrev.revert_abbrev "Autoref_Binding_ICF.*.rel"\<close>

(* TODO: Move *)
lemma Collect_x_x_pairs_rel_image[simp]: "{p. \<exists>x. p = (x, x)}``x = x"
    by auto

subsection "Set"

lemma (in set_empty) empty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (empty (), {}) \<in> \<langle>Rk\<rangle>rel"
  by (simp add: br_def empty_correct)

lemma (in set_memb) memb_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (memb,(\<in>))\<in>Rk\<rightarrow>\<langle>Rk\<rangle>rel\<rightarrow>Id"
  apply simp
  by (auto simp add: memb_correct br_def)

lemma (in set_ins) ins_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (ins,Set.insert)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>rel\<rightarrow>\<langle>Rk\<rangle>rel"
  by simp (auto simp add: ins_correct br_def)

context set_ins_dj begin
context begin interpretation autoref_syn .
lemma ins_dj_autoref[autoref_rules]:
  assumes "SIDE_PRECOND_OPT (x'\<notin>s')"
  assumes "PREFER_id Rk"
  assumes "(x,x')\<in>Rk"
  assumes "(s,s')\<in>\<langle>Rk\<rangle>rel"
  shows "(ins_dj x s,(OP Set.insert ::: Rk \<rightarrow> \<langle>Rk\<rangle>rel \<rightarrow> \<langle>Rk\<rangle>rel)$x'$s')\<in>\<langle>Rk\<rangle>rel"
  using assms
  apply simp
  apply (auto simp add: ins_dj_correct br_def)
  done
end
end

lemma (in set_delete) delete_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (delete,op_set_delete)\<in>Rk\<rightarrow>\<langle>Rk\<rangle>rel\<rightarrow>\<langle>Rk\<rangle>rel"
  by simp (auto simp add: delete_correct op_set_delete_def br_def)

lemma (in set_isEmpty) isEmpty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isEmpty,op_set_isEmpty) \<in> \<langle>Rk\<rangle>rel\<rightarrow>Id"
  apply (simp add: br_def)
  apply (fastforce simp: isEmpty_correct)
  done

lemma (in set_isSng) isSng_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isSng,op_set_isSng) \<in> \<langle>Rk\<rangle>rel\<rightarrow>Id"
  by simp
    (auto simp add: isSng_correct op_set_isSng_def br_def card_Suc_eq)

lemma (in set_ball) ball_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (ball,Set.Ball) \<in> \<langle>Rk\<rangle>rel\<rightarrow>(Rk\<rightarrow>Id)\<rightarrow>Id"
  by simp (auto simp add: ball_correct fun_rel_def br_def)

lemma (in set_bex) bex_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (bex,Set.Bex) \<in> \<langle>Rk\<rangle>rel\<rightarrow>(Rk\<rightarrow>Id)\<rightarrow>Id"
  apply simp
  apply (auto simp: bex_correct fun_rel_def br_def intro!: ext)
  done

lemma (in set_size) size_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size,card) \<in> \<langle>Rk\<rangle>rel \<rightarrow> Id"
  by simp (auto simp add: size_correct br_def)

lemma (in set_size_abort) size_abort_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size_abort,op_set_size_abort) \<in> Id \<rightarrow> \<langle>Rk\<rangle>rel \<rightarrow> Id"
  by simp
    (auto simp add: size_abort_correct op_set_size_abort_def br_def)

lemma (in set_union) union_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (union,(\<union>))\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>\<langle>Rk\<rangle>s3.rel"
  by simp (auto simp add: union_correct br_def)

context set_union_dj begin
context begin interpretation autoref_syn .

lemma union_dj_autoref[autoref_rules]:
  assumes "PREFER_id Rk"
  assumes "SIDE_PRECOND_OPT (a'\<inter>b'={})"
  assumes "(a,a')\<in>\<langle>Rk\<rangle>s1.rel"
  assumes "(b,b')\<in>\<langle>Rk\<rangle>s2.rel"
  shows "(union_dj a b,(OP (\<union>) ::: \<langle>Rk\<rangle>s1.rel \<rightarrow> \<langle>Rk\<rangle>s2.rel \<rightarrow> \<langle>Rk\<rangle>s3.rel)$a'$b')
    \<in>\<langle>Rk\<rangle>s3.rel"
  using assms
  by simp (auto simp: union_dj_correct br_def)
end
end

lemma (in set_diff) diff_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (diff,(-))\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>\<langle>Rk\<rangle>s1.rel"
  by simp (auto simp add: diff_correct br_def)

lemma (in set_filter) filter_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (filter,op_set_filter)\<in>(Rk \<rightarrow> Id) \<rightarrow> \<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel"
  by simp (auto simp add: filter_correct op_set_filter_def fun_rel_def
    br_def)

lemma (in set_inter) inter_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (inter,(\<inter>))\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>\<langle>Rk\<rangle>s3.rel"
  by simp (auto simp add: inter_correct br_def)

lemma (in set_subset) subset_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (subset,(\<subseteq>))\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>Id"
  by simp (auto simp add: subset_correct br_def)

lemma (in set_equal) equal_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (equal,(=))\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>Id"
  by simp (auto simp add: equal_correct br_def)

lemma (in set_disjoint) disjoint_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (disjoint,op_set_disjoint)\<in>\<langle>Rk\<rangle>s1.rel\<rightarrow>\<langle>Rk\<rangle>s2.rel\<rightarrow>Id"
  by simp (auto simp add: disjoint_correct op_set_disjoint_def br_def)

lemma (in list_to_set) to_set_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (to_set,set)\<in>\<langle>Rk\<rangle>list_rel \<rightarrow> \<langle>Rk\<rangle>rel"
  apply simp
  apply (auto simp add: to_set_correct br_def)
  done

context set_sel' begin
context begin interpretation autoref_syn .

lemma autoref_op_set_pick[autoref_rules]:
  assumes "SIDE_PRECOND (s'\<noteq>{})"
  assumes "PREFER_id Rk"
  assumes "(s,s')\<in>\<langle>Rk\<rangle>rel"
  shows "(RETURN (the (sel' s (\<lambda>_. True))),
          (OP op_set_pick ::: \<langle>Rk\<rangle>rel \<rightarrow> \<langle>Rk\<rangle>nres_rel) $ s')
    \<in> \<langle>Rk\<rangle>nres_rel"
  using assms
  apply (clarsimp simp add: br_def nres_rel_def ex_in_conv[symmetric])
  apply (erule (1) sel'E[OF _ _ TrueI])
  apply (auto intro: RES_refine)
  done
end
end

lemma (in poly_set_iteratei) proper[proper_it]:
  "proper_it' iteratei iteratei"
  apply (rule proper_it'I)
  by (rule pi_iteratei)

lemma (in poly_set_iteratei) autoref_iteratei[autoref_ga_rules]:
  "REL_IS_ID Rk \<Longrightarrow> is_set_to_list Rk rel (it_to_list iteratei)"
  unfolding is_set_to_list_def is_set_to_sorted_list_def it_to_list_def
    it_to_sorted_list_def
  apply (simp add: br_def, intro allI impI)
  apply (drule iteratei_correct)
  unfolding set_iterator_def set_iterator_genord_foldli_conv
  apply (elim exE)
  apply clarsimp
  apply (drule fun_cong[where x="\<lambda>_::'x list. True"])
  apply simp
  done

lemma (in poly_set_iterateoi) proper_o[proper_it]:
  "proper_it' iterateoi iterateoi"
  apply (rule proper_it'I)
  by (rule pi_iterateoi)

lemma (in poly_set_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]:
  "REL_IS_ID Rk \<Longrightarrow>
    is_set_to_sorted_list (\<ge>) Rk rel (it_to_list rev_iterateoi)"
  unfolding is_set_to_sorted_list_def it_to_list_def it_to_sorted_list_def
  apply (simp add: br_def, intro allI impI)
  apply (drule rev_iterateoi_correct)
  unfolding set_iterator_rev_linord_def set_iterator_genord_foldli_conv
  apply (elim exE)
  apply clarsimp
  apply (drule fun_cong[where x="\<lambda>_::'x list. True"])
  apply simp
  done

lemma (in poly_set_rev_iterateoi) proper_ro[proper_it]:
  "proper_it' rev_iterateoi rev_iterateoi"
  apply (rule proper_it'I)
  by (rule pi_rev_iterateoi)

subsection "Map"

lemma (in map) rel_alt: "\<langle>Id,Rv\<rangle>rel =
  { (c,a). \<forall>x. (\<alpha> c x,a x)\<in>\<langle>Rv\<rangle>option_rel \<and> invar c }"
  by (auto simp: rel_def br_def dest: fun_relD)

lemma (in map_empty) empty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (empty (),op_map_empty)\<in>\<langle>Rk,Rv\<rangle>rel"
  by (auto simp: empty_correct rel_alt)

lemma (in map_lookup) lookup_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (lookup,op_map_lookup)\<in>Rk\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rv\<rangle>option_rel"
  apply (intro fun_relI option_relI)
  apply (auto simp: lookup_correct rel_alt
    dest: fun_relD2)
  done

lemma (in map_update) update_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (update,op_map_update)\<in>Rk\<rightarrow>Rv\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel"
  apply (intro fun_relI)
  apply (simp add: update_correct rel_alt)
  done

context map_update_dj begin
context begin interpretation autoref_syn .

lemma update_dj_autoref[autoref_rules]:
  assumes "SIDE_PRECOND_OPT (k'\<notin>dom m')"
  assumes "PREFER_id Rk"
  assumes "(k,k')\<in>Rk"
  assumes "(v,v')\<in>Rv"
  assumes "(m,m')\<in>\<langle>Rk,Rv\<rangle>rel"
  shows "(update_dj k v m,
    (OP op_map_update ::: Rk \<rightarrow> Rv \<rightarrow> \<langle>Rk,Rv\<rangle>rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel)$k'$v'$m'
  )\<in>\<langle>Rk,Rv\<rangle>rel"
  using assms
  apply (subgoal_tac "k\<notin>dom (\<alpha> m)")
  apply (simp add: update_dj_correct rel_alt)
  apply (auto simp add: rel_alt option_rel_def)
  apply (metis option.simps(3))
  done
end
end

lemma (in map_delete) delete_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (delete,op_map_delete)\<in>Rk\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel"
  apply (intro fun_relI)
  apply (simp add: delete_correct restrict_map_def rel_alt)
  done

lemma (in map_restrict) restrict_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow>
    (restrict,op_map_restrict)
    \<in> (\<langle>Rk,Rv\<rangle>prod_rel \<rightarrow> Id) \<rightarrow> \<langle>Rk,Rv\<rangle>m1.rel \<rightarrow> \<langle>Rk,Rv\<rangle>m2.rel"
  apply (intro fun_relI)
  apply (simp add: restrict_correct br_comp_alt m1.rel_def m2.rel_def )
  apply (intro fun_relI)
  apply (auto simp: restrict_map_def split: if_split_asm)
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def) []
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def) []
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
  apply (drule (1) fun_relD2)
  apply (auto simp: option_rel_def prod_rel_def fun_rel_def) []
  done

lemma (in map_add) add_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (add,(++))\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>\<langle>Rk,Rv\<rangle>rel"
  apply (auto simp add: add_correct rel_alt Map.map_add_def
    split: option.split)
  apply (drule_tac x=x in spec)+
  apply simp
  apply (metis option.simps(3) option_rel_simp(2))
  by (metis (lifting) option_rel_simp(3))

context map_add_dj begin
context begin interpretation autoref_syn .

lemma add_dj_autoref[autoref_rules]:
  assumes "PREFER_id Rk"
  assumes "SIDE_PRECOND_OPT (dom a' \<inter> dom b' = {})"
  assumes "(a,a')\<in>\<langle>Rk,Rv\<rangle>rel"
  assumes "(b,b')\<in>\<langle>Rk,Rv\<rangle>rel"
  shows "(add_dj a b, (OP (++) ::: \<langle>Rk,Rv\<rangle>rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel) $ a' $ b')\<in>\<langle>Rk,Rv\<rangle>rel"
  using assms
  apply simp
  apply (subgoal_tac "dom (\<alpha> a) \<inter> dom (\<alpha> b) = {}")
  apply (clarsimp simp add: add_dj_correct rel_def br_comp_alt)
  apply (auto
    simp add: rel_def br_comp_alt Map.map_add_def
    split: option.split
    elim: fun_relE1 dest: fun_relD1 intro: option_relI
  ) []

  apply (clarsimp simp add: rel_def br_comp_alt)

  apply (auto simp: dom_def)
  apply (drule (1) fun_relD1)
  apply (drule (1) fun_relD1)
  apply (auto simp: option_rel_def)
  done
end
end

lemma (in map_isEmpty) isEmpty_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isEmpty,op_map_isEmpty)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  by (auto simp: isEmpty_correct rel_alt
    intro!: ext)

lemma sngI:
  assumes "m k = Some v"
  assumes "\<forall>k'. k'\<noteq>k \<longrightarrow> m k' = None"
  shows "m = [k\<mapsto>v]"
  using assms
  by (auto intro!: ext)

lemma (in map_isSng) isSng_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (isSng,op_map_isSng)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  (* TODO: Clean up this mess *)
  apply (auto simp add: isSng_correct rel_alt)
  apply (rule_tac x=k in exI)
  apply (rule_tac x="the (a' k)" in exI)
  apply (rule sngI)
  apply (drule_tac x=k in spec)
  apply (auto elim: option_relE) []
  apply (force elim: option_relE) []

  apply (rule_tac x=k in exI)
  apply (rule_tac x="the (\<alpha> a k)" in exI)
  apply (rule sngI)
  apply (drule_tac x=k in spec)
  apply (auto elim: option_relE) []
  apply (force elim: option_relE) []
  done

lemma (in map_ball) ball_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (ball,op_map_ball)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>(\<langle>Rk,Rv\<rangle>prod_rel\<rightarrow>Id)\<rightarrow>Id"
  apply (auto simp: ball_correct rel_alt map_to_set_def
    option_rel_def prod_rel_def fun_rel_def)
  apply (metis option.inject option.simps(3))+
  done

lemma (in map_bex) bex_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (bex,op_map_bex)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>(\<langle>Rk,Rv\<rangle>prod_rel\<rightarrow>Id)\<rightarrow>Id"
  apply (auto simp: bex_correct map_to_set_def rel_alt
    option_rel_def prod_rel_def fun_rel_def)
  apply (metis option.inject option.simps(3))+
  done

lemma (in map_size) size_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size,op_map_size)\<in>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  apply (auto simp: size_correct rel_alt option_rel_def dom_def
    intro!: arg_cong[where f=card])
  apply (metis option.simps(3))+
  done

lemma (in map_size_abort) size_abort_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (size_abort,op_map_size_abort)\<in>Id\<rightarrow>\<langle>Rk,Rv\<rangle>rel\<rightarrow>Id"
  apply (auto simp: size_abort_correct
    rel_alt option_rel_def
    dom_def intro!: arg_cong[where f=card] cong[OF arg_cong[where f=min]])
  apply (metis option.simps(3))+
  done

lemma (in list_to_map) to_map_autoref[autoref_rules]:
  "PREFER_id Rk \<Longrightarrow> (to_map,map_of)\<in> \<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel \<rightarrow> \<langle>Rk,Rv\<rangle>rel"
proof (intro fun_relI)
  fix l :: "('u\<times>'v) list" and l' :: "('u\<times>'a) list"
  assume "PREFER_id Rk" hence [simp]: "Rk=Id" by simp
  assume "(l,l')\<in>\<langle>\<langle>Rk,Rv\<rangle>prod_rel\<rangle>list_rel"
  thus "(to_map l, map_of l') \<in> \<langle>Rk,Rv\<rangle>rel"
    apply (simp add: list_rel_def)
  proof (induct rule: list_all2_induct)
    case Nil thus ?case
      by (auto simp add: to_map_correct rel_alt)
  next
    case (Cons x x' l l') thus ?case
      by (auto simp add: to_map_correct
        rel_alt prod_rel_def)
  qed
qed

(* TODO: Move *)
lemma key_rel_true[simp]: "key_rel (\<lambda>_ _. True) = (\<lambda>_ _. True)"
  by (auto intro!: ext simp: key_rel_def)

lemma (in poly_map_iteratei) proper[proper_it]:
  "proper_it' iteratei iteratei"
  apply (rule proper_it'I)
  by (rule pi_iteratei)

lemma (in poly_map_iteratei) autoref_iteratei[autoref_ga_rules]:
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_list Rk Rv rel (it_to_list iteratei)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def is_map_to_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m') \<in> br \<alpha> invar"
    hence I: "invar m" and M': "m' = \<alpha> m" by (simp_all add: br_def)

    have [simp]: "\<And>c. (\<lambda>(_,_). c) = (\<lambda>_. c)" by auto

    from map_it_to_list_genord_correct[where it = iteratei,
      where R="\<lambda>_ _. True", simplified, OF
      iteratei_correct[OF I, unfolded set_iterator_def]
    ] have
        M: "Map.map_of (it_to_list iteratei m) = \<alpha> m"
        and D: "distinct (List.map fst (it_to_list iteratei m))"
      by (simp_all)

    from D show "distinct (it_to_list iteratei m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list iteratei m)"
      by (simp add: M' map_of_map_to_set[OF D])
  qed
qed

lemma (in poly_map_iterateoi) proper_o[proper_it]:
  "proper_it' iterateoi iterateoi"
  apply (rule proper_it'I)
  by (rule pi_iterateoi)

lemma (in poly_map_iterateoi) autoref_iterateoi[autoref_ga_rules]:
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_sorted_list (\<le>) Rk Rv rel (it_to_list iterateoi)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m') \<in> br \<alpha> invar"
    hence I: "invar m" and M': "m' = \<alpha> m" by (simp_all add: br_def)

    have [simp]: "\<And>c. (\<lambda>(_,_). c) = (\<lambda>_. c)" by auto

    from map_it_to_list_linord_correct[where it = iterateoi,
      OF iterateoi_correct[OF I]
    ] have
        M: "map_of (it_to_list iterateoi m) = \<alpha> m"
        and D: "distinct (map fst (it_to_list iterateoi m))"
        and S: "sorted (map fst (it_to_list iterateoi m))"
      by (simp_all)

    from D show "distinct (it_to_list iterateoi m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list iterateoi m)"
      by (simp add: M' map_of_map_to_set[OF D])

    from S show "sorted_wrt (key_rel (\<le>)) (it_to_list iterateoi m)"
      by (simp add: key_rel_def[abs_def])

  qed
qed

lemma (in poly_map_rev_iterateoi) proper_ro[proper_it]:
  "proper_it' rev_iterateoi rev_iterateoi"
  apply (rule proper_it'I)
  by (rule pi_rev_iterateoi)

lemma (in poly_map_rev_iterateoi) autoref_rev_iterateoi[autoref_ga_rules]:
  assumes ID: "REL_IS_ID Rk"
    "REL_IS_ID Rv" (* TODO: Unnecessary*)
  shows "is_map_to_sorted_list (\<ge>) Rk Rv rel (it_to_list rev_iterateoi)"
proof -
  from ID have [simp]: "Rk=Id" "Rv = Id" by simp_all

  show ?thesis
    unfolding is_map_to_sorted_list_def
      it_to_sorted_list_def
    apply simp
    apply (intro allI impI conjI)
  proof -
    fix m m'
    assume "(m, m') \<in> br \<alpha> invar"
    hence I: "invar m" and M': "m' = \<alpha> m" by (simp_all add: br_def)

    have [simp]: "\<And>c. (\<lambda>(_,_). c) = (\<lambda>_. c)" by auto

    from map_it_to_list_rev_linord_correct[where it = rev_iterateoi,
      OF rev_iterateoi_correct[OF I]
    ] have
        M: "map_of (it_to_list rev_iterateoi m) = \<alpha> m"
        and D: "distinct (map fst (it_to_list rev_iterateoi m))"
        and S: "sorted (rev (map fst (it_to_list rev_iterateoi m)))"
      by (simp_all)

    from D show "distinct (it_to_list rev_iterateoi m)"
      by (rule distinct_mapI)

    from M show "map_to_set m' = set (it_to_list rev_iterateoi m)"
      by (simp add: M' map_of_map_to_set[OF D])

    from S show "sorted_wrt (key_rel (\<ge>)) (it_to_list rev_iterateoi m)"
      by (simp add: key_rel_def[abs_def])

  qed
qed

end


(*
 * Copyright 2014, NICTA
 *
 * 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(NICTA_BSD)
 *)

(*
* Zhe Hou: I modified this file to model a deterministic monad instead of
* a non-deterministic monad. Features that are irrelevant to deterministic
* moands are removed. I also removed the section for loops, which are not
* used in the modelling of the SPARC architecture.
*)

(*
   Deterministic state and error monads with failure in Isabelle.
*)

(*chapter "Deterministic State Monad with Failure"*)

theory DetMonad
imports "../Lib"
begin

text {*
  \label{c:monads}

  State monads are used extensively in the seL4 specification. They are
  defined below.
*}

section "The Monad"

text {*
  The basic type of the deterministic state monad with failure is
  very similar to the normal state monad. Instead of a pair consisting
  of result and new state, we return a pair coupled with
  a failure flag. The flag is @{const True} if the computation have failed.
  Conversely, if the flag is @{const False}, the computation resulting in
  the returned result have succeeded.  *}
type_synonym ('s,'a) det_monad = "'s \<Rightarrow> ('a \<times> 's) \<times> bool"

text {*
  The definition of fundamental monad functions @{text return} and
  @{text bind}. The monad function @{text "return x"} does not change
  the  state, does not fail, and returns @{text "x"}.
*}
definition
  return :: "'a \<Rightarrow> ('s,'a) det_monad" where
  "return a \<equiv> \<lambda>s. ((a,s),False)"

text {*
  The monad function @{text "bind f g"}, also written @{text "f >>= g"},
  is the execution of @{term f} followed by the execution of @{text g}.
  The function @{text g} takes the result value \emph{and} the result
  state of @{text f} as parameter. The definition says that the result of
  the combined operation is the result which is created
  by @{text g} applied to the result of @{text f}. The combined
  operation may have failed, if @{text f} may have failed or @{text g} may
  have failed on the result of @{text f}.
*}

text {*
 David Sanan and Zhe Hou: The original definition of bind is very inefficient
 when converted to executable code. Here we change it to a more efficient
 version for execution. The idea remains the same.
*}

definition "h1 f s = f s"
definition "h2 g fs = (let (a,b) = fst (fs) in g a b)"
definition bind:: "('s, 'a) det_monad \<Rightarrow> ('a \<Rightarrow> ('s, 'b) det_monad) \<Rightarrow>
           ('s, 'b) det_monad" (infixl ">>=" 60)
where
"bind f g \<equiv> \<lambda>s. (
  let fs = h1 f s;
      v = h2 g fs
  in
  (fst v, (snd v \<or> snd fs)))"

text {*
  Sometimes it is convenient to write @{text bind} in reverse order.
*}
abbreviation(input)
  bind_rev :: "('c \<Rightarrow> ('a, 'b) det_monad) \<Rightarrow> ('a, 'c) det_monad \<Rightarrow>
               ('a, 'b) det_monad" (infixl "=<<" 60) where
  "g =<< f \<equiv> f >>= g"

text {*
  The basic accessor functions of the state monad. @{text get} returns
  the current state as result, does not fail, and does not change the state.
  @{text "put s"} returns nothing (@{typ unit}), changes the current state
  to @{text s} and does not fail.
*}
definition
  get :: "('s,'s) det_monad" where
  "get \<equiv> \<lambda>s. ((s,s), False)"

definition
  put :: "'s \<Rightarrow> ('s, unit) det_monad" where
  "put s \<equiv> \<lambda>_. (((),s), False)"

subsection "Failure"

text {* The monad function that always fails. Returns the current
  state and sets the failure flag. *}
definition
  fail :: "'a \<Rightarrow> ('s, 'a) det_monad" where
 "fail a \<equiv> \<lambda>s. ((a,s), True)"

text {* Assertions: fail if the property @{text P} is not true *}
definition
  assert :: "bool \<Rightarrow> ('a, unit) det_monad" where
 "assert P \<equiv> if P then return () else fail ()"

text {* An assertion that also can introspect the current state. *}

definition
  state_assert :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, unit) det_monad"
where
  "state_assert P \<equiv> get >>= (\<lambda>s. assert (P s))"

subsection "Generic functions on top of the state monad"

text {* Apply a function to the current state and return the result
without changing the state. *}
definition
  gets :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s, 'a) det_monad" where
 "gets f \<equiv> get >>= (\<lambda>s. return (f s))"

text {* Modify the current state using the function passed in. *}
definition
  modify :: "('s \<Rightarrow> 's) \<Rightarrow> ('s, unit) det_monad" where
 "modify f \<equiv> get >>= (\<lambda>s. put (f s))"

lemma simpler_gets_def: "gets f = (\<lambda>s. ((f s, s), False))"
  apply (simp add: gets_def return_def bind_def h1_def h2_def get_def)
  done

lemma simpler_modify_def:
  "modify f = (\<lambda>s. (((), f s), False))"
  by (simp add: modify_def bind_def h1_def h2_def get_def put_def)

text {* Execute the given monad when the condition is true,
  return @{text "()"} otherwise. *}
definition
  when1 :: "bool \<Rightarrow> ('s, unit) det_monad \<Rightarrow>
           ('s, unit) det_monad" where
  "when1 P m \<equiv> if P then m else return ()"

text {* Execute the given monad unless the condition is true,
  return @{text "()"} otherwise. *}
definition
  unless :: "bool \<Rightarrow> ('s, unit) det_monad \<Rightarrow>
            ('s, unit) det_monad" where
  "unless P m \<equiv> when1 (\<not>P) m"

text {*
  Perform a test on the current state, performing the left monad if
  the result is true or the right monad if the result is false.
*}
definition
  condition :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'r) det_monad \<Rightarrow> ('s, 'r) det_monad \<Rightarrow> ('s, 'r) det_monad"
where
  "condition P L R \<equiv> \<lambda>s. if (P s) then (L s) else (R s)"

notation (output)
  condition  ("(condition (_)//  (_)//  (_))" [1000,1000,1000] 1000)

subsection {* The Monad Laws *}

text {* Each monad satisfies at least the following three laws. *}

text {* @{term return} is absorbed at the left of a @{term bind},
  applying the return value directly: *}
lemma return_bind [simp]: "(return x >>= f) = f x"
  by (simp add: return_def bind_def h1_def h2_def)

text {* @{term return} is absorbed on the right of a @{term bind} *}
lemma bind_return [simp]: "(m >>= return) = m"
  apply (rule ext)
  apply (simp add: bind_def h1_def h2_def return_def split_def)
  done

text {* @{term bind} is associative *}
lemma bind_assoc:
  fixes m :: "('a,'b) det_monad"
  fixes f :: "'b \<Rightarrow> ('a,'c) det_monad"
  fixes g :: "'c \<Rightarrow> ('a,'d) det_monad"
  shows "(m >>= f) >>= g  =  m >>= (\<lambda>x. f x >>= g)"
  apply (unfold bind_def h1_def h2_def Let_def split_def)
  apply (rule ext)
  apply clarsimp
  done

section {* Adding Exceptions *}

text {*
  The type @{typ "('s,'a) det_monad"} gives us determinism and
  failure. We now extend this monad with exceptional return values
  that abort normal execution, but can be handled explicitly.
  We use the sum type to indicate exceptions.

  In @{typ "('s, 'e + 'a) det_monad"}, @{typ "'s"} is the state,
  @{typ 'e} is an exception, and @{typ 'a} is a normal return value.

  This new type itself forms a monad again. Since type classes in
  Isabelle are not powerful enough to express the class of monads,
  we provide new names for the @{term return} and @{term bind} functions
  in this monad. We call them @{text returnOk} (for normal return values)
  and @{text bindE} (for composition). We also define @{text throwError}
  to return an exceptional value.
*}
definition
  returnOk :: "'a \<Rightarrow> ('s, 'e + 'a) det_monad" where
  "returnOk \<equiv> return o Inr"

definition
  throwError :: "'e \<Rightarrow> ('s, 'e + 'a) det_monad" where
  "throwError \<equiv> return o Inl"

text {*
  Lifting a function over the exception type: if the input is an
  exception, return that exception; otherwise continue execution.
*}
definition
  lift :: "('a \<Rightarrow> ('s, 'e + 'b) det_monad) \<Rightarrow>
           'e +'a \<Rightarrow> ('s, 'e + 'b) det_monad"
where
  "lift f v \<equiv> case v of Inl e \<Rightarrow> throwError e
                      | Inr v' \<Rightarrow> f v'"

text {*
  The definition of @{term bind} in the exception monad (new
  name @{text bindE}): the same as normal @{term bind}, but
  the right-hand side is skipped if the left-hand side
  produced an exception.
*}
definition
  bindE :: "('s, 'e + 'a) det_monad \<Rightarrow>
            ('a \<Rightarrow> ('s, 'e + 'b) det_monad) \<Rightarrow>
            ('s, 'e + 'b) det_monad"  (infixl ">>=E" 60)
where
  "bindE f g \<equiv> bind f (lift g)"

text {*
  Lifting a normal deterministic monad into the
  exception monad is achieved by always returning its
  result as normal result and never throwing an exception.
*}
definition
  liftE :: "('s,'a) det_monad \<Rightarrow> ('s, 'e+'a) det_monad"
where
  "liftE f \<equiv> f >>= (\<lambda>r. return (Inr r))"

text {*
  Since the underlying type and @{text return} function changed,
  we need new definitions for when and unless:
*}
definition
  whenE :: "bool \<Rightarrow> ('s, 'e + unit) det_monad \<Rightarrow>
            ('s, 'e + unit) det_monad"
  where
  "whenE P f \<equiv> if P then f else returnOk ()"

definition
  unlessE :: "bool \<Rightarrow> ('s, 'e + unit) det_monad \<Rightarrow>
            ('s, 'e + unit) det_monad"
  where
  "unlessE P f \<equiv> if P then returnOk () else f"

text {*
  Throwing an exception when the parameter is @{term None}, otherwise
  returning @{term "v"} for @{term "Some v"}.
*}
definition
  throw_opt :: "'e \<Rightarrow> 'a option \<Rightarrow> ('s, 'e + 'a) det_monad" where
  "throw_opt ex x \<equiv>
  case x of None \<Rightarrow> throwError ex | Some v \<Rightarrow> returnOk v"

subsection "Monad Laws for the Exception Monad"

text {* More direct definition of @{const liftE}: *}
lemma liftE_def2:
  "liftE f = (\<lambda>s. ((\<lambda>(v,s'). (Inr v, s'))  (fst (f s)), snd (f s)))"
  by (auto simp: Let_def liftE_def return_def split_def bind_def h1_def h2_def)

text {* Left @{const returnOk} absorbtion over @{term bindE}: *}
(*lemma returnOk_bindE [simp]: "(returnOk x >>=E f) = f x"
  apply (unfold bindE_def return_def returnOk_def)
  apply (clarsimp simp: lift_def)
  done*)

lemma lift_return [simp]:
  "lift (return \<circ> Inr) = return"
  by (rule ext)
     (simp add: lift_def throwError_def split: sum.splits)

text {* Right @{const returnOk} absorbtion over @{term bindE}: *}
lemma bindE_returnOk [simp]: "(m >>=E returnOk) = m"
  by (simp add: bindE_def returnOk_def)

text {* Associativity of @{const bindE}: *}
lemma bindE_assoc:
  "(m >>=E f) >>=E g = m >>=E (\<lambda>x. f x >>=E g)"
  apply (simp add: bindE_def bind_assoc)
  apply (rule arg_cong [where f="\<lambda>x. m >>= x"])
  apply (rule ext)
  apply (case_tac x, simp_all add: lift_def throwError_def)
  done

text {* @{const returnOk} could also be defined via @{const liftE}: *}
lemma returnOk_liftE:
  "returnOk x = liftE (return x)"
  by (simp add: liftE_def returnOk_def)

text {* Execution after throwing an exception is skipped: *}
lemma throwError_bindE [simp]:
  "(throwError E >>=E f) = throwError E"
  by (simp add: bindE_def bind_def h1_def h2_def throwError_def lift_def return_def)

section "Syntax"

text {* This section defines traditional Haskell-like do-syntax
  for the state monad in Isabelle. *}

subsection "Syntax for the Nondeterministic State Monad"

text {* We use @{text K_bind} to syntactically indicate the
  case where the return argument of the left side of a @{term bind}
  is ignored *}
definition
  K_bind_def [iff]: "K_bind \<equiv> \<lambda>x y. x"

nonterminal
  dobinds and dobind and nobind

syntax
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ <-/ _)" 10)
  ""           :: "dobind => dobinds"                 ("_")
  "_nobind"    :: "'a => dobind"                      ("_")
  "_dobinds"   :: "[dobind, dobinds] => dobinds"      ("(_);//(_)")

  "_do"        :: "[dobinds, 'a] => 'a"               ("(do ((_);//(_))//od)" 100)
syntax (xsymbols)
  "_dobind"    :: "[pttrn, 'a] => dobind"             ("(_ \<leftarrow>/ _)" 10)

translations
  "_do (_dobinds b bs) e"  == "_do b (_do bs e)"
  "_do (_nobind b) e"      == "b >>= (CONST K_bind e)"
  "do x <- a; e od"        == "a >>= (\<lambda>x. e)"

text {* Syntax examples: *}
lemma "do x \<leftarrow> return 1;
          return (2::nat);
          return x
       od =
       return 1 >>=
       (\<lambda>x. return (2::nat) >>=
            K_bind (return x))"
  by (rule refl)

lemma "do x \<leftarrow> return 1;
          return 2;
          return x
       od = return 1"
  by simp

subsection "Syntax for the Exception Monad"

text {*
  Since the exception monad is a different type, we
  need to syntactically distinguish it in the syntax.
  We use @{text doE}/@{text odE} for this, but can re-use
  most of the productions from @{text do}/@{text od}
  above.
*}

syntax
  "_doE" :: "[dobinds, 'a] => 'a"  ("(doE ((_);//(_))//odE)" 100)

translations
  "_doE (_dobinds b bs) e"  == "_doE b (_doE bs e)"
  "_doE (_nobind b) e"      == "b >>=E (CONST K_bind e)"
  "doE x <- a; e odE"       == "a >>=E (\<lambda>x. e)"

text {* Syntax examples: *}
lemma "doE x \<leftarrow> returnOk 1;
           returnOk (2::nat);
           returnOk x
       odE =
       returnOk 1 >>=E
       (\<lambda>x. returnOk (2::nat) >>=E
            K_bind (returnOk x))"
  by (rule refl)

(*lemma "doE x \<leftarrow> returnOk 1;
           returnOk 2;
           returnOk x
       odE = returnOk 1"
  by simp*)

section "Library of Monadic Functions and Combinators"

text {* Lifting a normal function into the monad type: *}
definition
  liftM :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('s, 'b) det_monad"
where
  "liftM f m \<equiv> do x \<leftarrow> m; return (f x) od"

text {* The same for the exception monad: *}
definition
  liftME :: "('a \<Rightarrow> 'b) \<Rightarrow> ('s,'e+'a) det_monad \<Rightarrow> ('s,'e+'b) det_monad"
where
  "liftME f m \<equiv> doE x \<leftarrow> m; returnOk (f x) odE"

text {*
  Run a sequence of monads from left to right, ignoring return values. *}
definition
  sequence_x :: "('s, 'a) det_monad list \<Rightarrow> ('s, unit) det_monad"
where
  "sequence_x xs \<equiv> foldr (\<lambda>x y. x >>= (\<lambda>_. y)) xs (return ())"

text {*
  Map a monadic function over a list by applying it to each element
  of the list from left to right, ignoring return values.
*}
definition
  mapM_x :: "('a \<Rightarrow> ('s,'b) det_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, unit) det_monad"
where
  "mapM_x f xs \<equiv> sequence_x (map f xs)"

text {*
  Map a monadic function with two parameters over two lists,
  going through both lists simultaneously, left to right, ignoring
  return values.
*}
definition
  zipWithM_x :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) det_monad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, unit) det_monad"
where
  "zipWithM_x f xs ys \<equiv> sequence_x (zipWith f xs ys)"

text {* The same three functions as above, but returning a list of
return values instead of @{text unit} *}
definition
  sequence :: "('s, 'a) det_monad list \<Rightarrow> ('s, 'a list) det_monad"
where
  "sequence xs \<equiv> let mcons = (\<lambda>p q. p >>= (\<lambda>x. q >>= (\<lambda>y. return (x#y))))
                 in foldr mcons xs (return [])"

definition
  mapM :: "('a \<Rightarrow> ('s,'b) det_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'b list) det_monad"
where
  "mapM f xs \<equiv> sequence (map f xs)"

definition
  zipWithM :: "('a \<Rightarrow> 'b \<Rightarrow> ('s,'c) det_monad) \<Rightarrow>
                 'a list \<Rightarrow> 'b list \<Rightarrow> ('s, 'c list) det_monad"
where
  "zipWithM f xs ys \<equiv> sequence (zipWith f xs ys)"

definition
  foldM :: "('b \<Rightarrow> 'a \<Rightarrow> ('s, 'a) det_monad) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('s, 'a) det_monad"
where
  "foldM m xs a \<equiv> foldr (\<lambda>p q. q >>= m p) xs (return a) "

text {* The sequence and map functions above for the exception monad,
with and without lists of return value *}
definition
  sequenceE_x :: "('s, 'e+'a) det_monad list \<Rightarrow> ('s, 'e+unit) det_monad"
where
  "sequenceE_x xs \<equiv> foldr (\<lambda>x y. doE _ <- x; y odE) xs (returnOk ())"

definition
  mapME_x :: "('a \<Rightarrow> ('s,'e+'b) det_monad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+unit) det_monad"
where
  "mapME_x f xs \<equiv> sequenceE_x (map f xs)"

definition
  sequenceE :: "('s, 'e+'a) det_monad list \<Rightarrow> ('s, 'e+'a list) det_monad"
where
  "sequenceE xs \<equiv> let mcons = (\<lambda>p q. p >>=E (\<lambda>x. q >>=E (\<lambda>y. returnOk (x#y))))
                 in foldr mcons xs (returnOk [])"

definition
  mapME :: "('a \<Rightarrow> ('s,'e+'b) det_monad) \<Rightarrow> 'a list \<Rightarrow>
              ('s,'e+'b list) det_monad"
where
  "mapME f xs \<equiv> sequenceE (map f xs)"

text {* Filtering a list using a monadic function as predicate: *}
primrec
  filterM :: "('a \<Rightarrow> ('s, bool) det_monad) \<Rightarrow> 'a list \<Rightarrow> ('s, 'a list) det_monad"
where
  "filterM P []       = return []"
| "filterM P (x # xs) = do
     b  <- P x;
     ys <- filterM P xs;
     return (if b then (x # ys) else ys)
   od"

section "Catching and Handling Exceptions"

text {*
  Turning an exception monad into a normal state monad
  by catching and handling any potential exceptions:
*}
definition
  catch :: "('s, 'e + 'a) det_monad \<Rightarrow>
            ('e \<Rightarrow> ('s, 'a) det_monad) \<Rightarrow>
            ('s, 'a) det_monad" (infix "<catch>" 10)
where
  "f <catch> handler \<equiv>
     do x \<leftarrow> f;
        case x of
          Inr b \<Rightarrow> return b
        | Inl e \<Rightarrow> handler e
     od"

text {*
  Handling exceptions, but staying in the exception monad.
  The handler may throw a type of exceptions different from
  the left side.
*}
definition
  handleE' :: "('s, 'e1 + 'a) det_monad \<Rightarrow>
               ('e1 \<Rightarrow> ('s, 'e2 + 'a) det_monad) \<Rightarrow>
               ('s, 'e2 + 'a) det_monad" (infix "<handle2>" 10)
where
  "f <handle2> handler \<equiv>
   do
      v \<leftarrow> f;
      case v of
        Inl e \<Rightarrow> handler e
      | Inr v' \<Rightarrow> return (Inr v')
   od"

text {*
  A type restriction of the above that is used more commonly in
  practice: the exception handle (potentially) throws exception
  of the same type as the left-hand side.
*}
definition
  handleE :: "('s, 'x + 'a) det_monad \<Rightarrow>
              ('x \<Rightarrow> ('s, 'x + 'a) det_monad) \<Rightarrow>
              ('s, 'x + 'a) det_monad" (infix "<handle>" 10)
where
  "handleE \<equiv> handleE'"

text {*
  Handling exceptions, and additionally providing a continuation
  if the left-hand side throws no exception:
*}
definition
  handle_elseE :: "('s, 'e + 'a) det_monad \<Rightarrow>
                   ('e \<Rightarrow> ('s, 'ee + 'b) det_monad) \<Rightarrow>
                   ('a \<Rightarrow> ('s, 'ee + 'b) det_monad) \<Rightarrow>
                   ('s, 'ee + 'b) det_monad"
  ("_ <handle> _ <else> _" 10)
where
  "f <handle> handler <else> continue \<equiv>
   do v \<leftarrow> f;
   case v of Inl e  \<Rightarrow> handler e
           | Inr v' \<Rightarrow> continue v'
   od"

section "Hoare Logic"

subsection "Validity"

text {* This section defines a Hoare logic for partial correctness for
  the deterministic state monad as well as the exception monad.
  The logic talks only about the behaviour part of the monad and ignores
  the failure flag.

  The logic is defined semantically. Rules work directly on the
  validity predicate.

  In the deterministic state monad, validity is a triple of precondition,
  monad, and postcondition. The precondition is a function from state to
  bool (a state predicate), the postcondition is a function from return value
  to state to bool. A triple is valid if for all states that satisfy the
  precondition, all result values and result states that are returned by
  the monad satisfy the postcondition. Note that if the computation returns
  the empty set, the triple is trivially valid. This means @{term "assert P"}
  does not require us to prove that @{term P} holds, but rather allows us
  to assume @{term P}! Proving non-failure is done via separate predicate and
  calculus (see below).
*}
definition
  valid :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace> \<equiv> \<forall>s. P s \<longrightarrow> (\<forall>r s'. ((r,s') = fst (f s) \<longrightarrow> Q r s'))"

text {*
  Validity for the exception monad is similar and build on the standard
  validity above. Instead of one postcondition, we have two: one for
  normal and one for exceptional results.
*}
definition
  validE :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) det_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>)")
where
  "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace> \<equiv> \<lbrace>P\<rbrace> f \<lbrace> \<lambda>v s. case v of Inr r \<Rightarrow> Q r s | Inl e \<Rightarrow> E e s \<rbrace>"

text {*
  The following two instantiations are convenient to separate reasoning
  for exceptional and normal case.
*}
definition
  validE_R :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'e + 'a) det_monad \<Rightarrow>
               ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>, -")
where
 "\<lbrace>P\<rbrace> f \<lbrace>Q\<rbrace>,- \<equiv> validE P f Q (\<lambda>x y. True)"

definition
  validE_E :: "('s \<Rightarrow> bool) \<Rightarrow>  ('s, 'e + 'a) det_monad \<Rightarrow>
               ('e \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
   ("\<lbrace>_\<rbrace>/ _ /-, \<lbrace>_\<rbrace>")
where
 "\<lbrace>P\<rbrace> f -,\<lbrace>Q\<rbrace> \<equiv> validE P f (\<lambda>x y. True) Q"

text {* Abbreviations for trivial preconditions: *}
abbreviation(input)
  top :: "'a \<Rightarrow> bool" ("\<top>")
where
  "\<top> \<equiv> \<lambda>_. True"

abbreviation(input)
  bottom :: "'a \<Rightarrow> bool" ("\<bottom>")
where
  "\<bottom> \<equiv> \<lambda>_. False"

text {* Abbreviations for trivial postconditions (taking two arguments): *}
abbreviation(input)
  toptop :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<top>\<top>")
where
 "\<top>\<top> \<equiv> \<lambda>_ _. True"

abbreviation(input)
  botbot :: "'a \<Rightarrow> 'b \<Rightarrow> bool" ("\<bottom>\<bottom>")
where
 "\<bottom>\<bottom> \<equiv> \<lambda>_ _. False"

text {*
  Lifting @{text "\<and>"} and @{text "\<or>"} over two arguments.
  Lifting @{text "\<and>"} and @{text "\<or>"} over one argument is already
  defined (written @{text "and"} and @{text "or"}).
*}
definition
  bipred_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "And" 96)
where
  "bipred_conj P Q \<equiv> \<lambda>x y. P x y \<and> Q x y"

definition
  bipred_disj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool)"
  (infixl "Or" 91)
where
  "bipred_disj P Q \<equiv> \<lambda>x y. P x y \<or> Q x y"

subsection "Determinism"

text {* A monad of type @{text det_monad} is deterministic iff it
returns exactly one state and result and does not fail *}
definition
  det :: "('a,'s) det_monad \<Rightarrow> bool"
where
  "det f \<equiv> \<forall>s. \<exists>r. f s = (r,False)"

text {* A deterministic @{text det_monad} can be turned
  into a normal state monad: *}
definition
  the_run_state :: "('s,'a) det_monad \<Rightarrow> 's \<Rightarrow> 'a \<times> 's"
where
  "the_run_state M \<equiv> \<lambda>s. THE s'. fst (M s) = s'"

subsection "Non-Failure"

text {*
  With the failure flag, we can formulate non-failure separately
  from validity. A monad @{text m} does not fail under precondition
  @{text P}, if for no start state in that precondition it sets
  the failure flag.
*}
definition
  no_fail :: "('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> bool"
where
  "no_fail P m \<equiv> \<forall>s. P s \<longrightarrow> \<not> (snd (m s))"

text {*
  It is often desired to prove non-failure and a Hoare triple
  simultaneously, as the reasoning is often similar. The following
  definitions allow such reasoning to take place.
*}

definition
  validNF ::"('s \<Rightarrow> bool) \<Rightarrow> ('s,'a) det_monad \<Rightarrow> ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
      ("\<lbrace>_\<rbrace>/ _ /\<lbrace>_\<rbrace>!")
where
  "validNF P f Q \<equiv> valid P f Q \<and> no_fail P f"

definition
  validE_NF :: "('s \<Rightarrow> bool) \<Rightarrow> ('s, 'a + 'b) det_monad \<Rightarrow>
             ('b \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow>
             ('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace>/ _ /(\<lbrace>_\<rbrace>,/ \<lbrace>_\<rbrace>!)")
where
  "validE_NF P f Q E \<equiv> validE P f Q E \<and> no_fail P f"

lemma validE_NF_alt_def:
  "\<lbrace> P \<rbrace> B \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>! = \<lbrace> P \<rbrace> B \<lbrace> \<lambda>v s. case v of Inl e \<Rightarrow> E e s | Inr r \<Rightarrow> Q r s \<rbrace>!"
  by (clarsimp simp: validE_NF_def validE_def validNF_def)

section "Basic exception reasoning"

text {*
  The following predicates @{text no_throw} and @{text no_return} allow
  reasoning that functions in the exception monad either do
  no throw an exception or never return normally.
*}

definition "no_throw P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace> \<lambda>_ _. True \<rbrace>,\<lbrace> \<lambda>_ _. False \<rbrace>"

definition "no_return P A \<equiv> \<lbrace> P \<rbrace> A \<lbrace>\<lambda>_ _. False\<rbrace>,\<lbrace>\<lambda>_ _. True \<rbrace>"

end


section \<open> Stateful-Failure Healthiness Conditions \<close>

theory utp_sfrd_healths
  imports utp_sfrd_rel
begin

section \<open> Definitions \<close>

text \<open> We here define extra healthiness conditions for stateful-failure reactive designs. \<close>

abbreviation CSP1 :: "(('\<sigma>, '\<phi>) sfrd \<times> ('\<sigma>, '\<phi>) sfrd) health"
where "CSP1(P) \<equiv> RD1(P)"

abbreviation CSP2 :: "(('\<sigma>, '\<phi>) sfrd \<times> ('\<sigma>, '\<phi>) sfrd) health"
where "CSP2(P) \<equiv> RD2(P)"

abbreviation CSP :: "(('\<sigma>, '\<phi>) sfrd \<times> ('\<sigma>, '\<phi>) sfrd) health"
where "CSP(P) \<equiv> SRD(P)"

definition STOP :: "'\<phi> process" where
[upred_defs]: "STOP = CSP1($ok\<acute> \<and> R3c($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"

definition SKIP :: "'\<phi> process" where
[upred_defs]: "SKIP = \<^bold>R\<^sub>s(\<exists> $ref \<bullet> CSP1(II))"

definition Stop :: "('\<sigma>, '\<phi>) action" where
[upred_defs]: "Stop = \<^bold>R\<^sub>s(true \<turnstile> ($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>))"

definition Skip :: "('\<sigma>, '\<phi>) action" where
[upred_defs]: "Skip = \<^bold>R\<^sub>s(true \<turnstile> ($tr\<acute> =\<^sub>u $tr \<and> \<not> $wait\<acute> \<and> $st\<acute> =\<^sub>u $st))"

definition CSP3 :: "(('\<sigma>, '\<phi>) sfrd \<times> ('\<sigma>, '\<phi>) sfrd) health" where
[upred_defs]: "CSP3(P) = (Skip ;; P)"

definition CSP4 :: "(('\<sigma>, '\<phi>) sfrd \<times> ('\<sigma>, '\<phi>) sfrd) health" where
[upred_defs]: "CSP4(P) = (P ;; Skip)"

definition NCSP :: "(('\<sigma>, '\<phi>) sfrd \<times> ('\<sigma>, '\<phi>) sfrd) health" where
[upred_defs]: "NCSP = CSP3 \<circ> CSP4 \<circ> CSP"

text \<open> Productive and normal processes \<close>

abbreviation "PCSP \<equiv> Productive \<circ> NCSP"

text \<open> Instantaneous and normal processes \<close>

abbreviation "ICSP \<equiv> ISRD1 \<circ> NCSP"

subsection \<open> Healthiness condition properties \<close>

text \<open> @{term SKIP} is the same as @{term Skip}, and @{term STOP} is the same as @{term Stop},
  when we consider stateless CSP processes. This is because any reference to the @{term st}
  variable degenerates when the alphabet type coerces its type to be empty. We therefore
  need not consider @{term SKIP} and @{term STOP} actions. \<close>

theorem SKIP_is_Skip [simp]: "SKIP = Skip"
  by (rel_auto)

theorem STOP_is_Stop [simp]: "STOP = Stop"
  by (rel_auto)

theorem Skip_UTP_form: "Skip = \<^bold>R\<^sub>s(\<exists> $ref \<bullet> CSP1(II))"
  by (rel_auto)

lemma Skip_is_CSP [closure]:
  "Skip is CSP"
  by (simp add: Skip_def RHS_design_is_SRD unrest)

lemma Skip_RHS_tri_design:
  "Skip = \<^bold>R\<^sub>s(true \<turnstile> (false \<diamondop> ($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st)))"
  by (rel_auto)

lemma Skip_RHS_tri_design' [rdes_def]:
  "Skip = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> (false \<diamondop> \<Phi>(true,id\<^sub>s,\<guillemotleft>[]\<guillemotright>)))"
  by (rel_auto)

lemma Skip_frame [frame]: "vwb_lens a \<Longrightarrow> a:[Skip]\<^sub>R\<^sup>+ = Skip"
  by (rdes_eq)

lemma Stop_is_CSP [closure]:
  "Stop is CSP"
  by (simp add: Stop_def RHS_design_is_SRD unrest)

lemma Stop_RHS_tri_design: "Stop = \<^bold>R\<^sub>s(true \<turnstile> ($tr\<acute> =\<^sub>u $tr) \<diamondop> false)"
  by (rel_auto)

lemma Stop_RHS_rdes_def [rdes_def]: "Stop = \<^bold>R\<^sub>s(true\<^sub>r \<turnstile> \<E>(true,\<guillemotleft>[]\<guillemotright>,{}\<^sub>u) \<diamondop> false)"
  by (rel_auto)

lemma preR_Skip [rdes]: "pre\<^sub>R(Skip) = true\<^sub>r"
  by (rel_auto)

lemma periR_Skip [rdes]: "peri\<^sub>R(Skip) = false"
  by (rel_auto)

lemma postR_Skip [rdes]: "post\<^sub>R(Skip) = \<Phi>(true,id\<^sub>s,\<guillemotleft>[]\<guillemotright>)"
  by (rel_auto)

lemma Productive_Stop [closure]:
  "Stop is Productive"
  by (simp add: Stop_RHS_tri_design Healthy_def Productive_RHS_design_form unrest closure)

lemma Skip_left_lemma:
  assumes "P is CSP"
  shows "Skip ;; P = \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> pre\<^sub>R P) \<turnstile> (\<exists> $ref \<bullet> cmt\<^sub>R P))"
proof -
  have "Skip ;; P =
        \<^bold>R\<^sub>s (($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st) wp\<^sub>r pre\<^sub>R P \<turnstile>
            ($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st) ;; peri\<^sub>R P \<diamondop>
            ($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st) ;; post\<^sub>R P)"
    by (simp add: SRD_composition_wp alpha rdes closure wp assms rpred C1, rel_auto)
  also have "... = \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> pre\<^sub>R P) \<turnstile>
                      ($tr\<acute> =\<^sub>u $tr \<and> \<not> $wait\<acute> \<and> $st\<acute> =\<^sub>u $st) ;; ((\<exists> $st \<bullet> \<lceil>II\<rceil>\<^sub>D) \<triangleleft> $wait \<triangleright> cmt\<^sub>R P))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... = \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> pre\<^sub>R P) \<turnstile> (\<exists> $ref \<bullet> cmt\<^sub>R P))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  finally show ?thesis .
qed

lemma Skip_left_unit_ref_unrest:
  assumes "P is CSP" "$ref \<sharp> P\<lbrakk>false/$wait\<rbrakk>"
  shows "Skip ;; P = P"
  using assms
  by (simp add: Skip_left_lemma)
     (metis SRD_reactive_design_alt all_unrest cmt_unrest_ref cmt_wait_false ex_unrest pre_unrest_ref pre_wait_false)

lemma CSP3_intro:
  "\<lbrakk> P is CSP; $ref \<sharp> P\<lbrakk>false/$wait\<rbrakk> \<rbrakk> \<Longrightarrow> P is CSP3"
  by (simp add: CSP3_def Healthy_def' Skip_left_unit_ref_unrest)

lemma ref_unrest_RHS_design:
  assumes "$ref \<sharp> P" "$ref \<sharp> Q\<^sub>1" "$ref \<sharp> Q\<^sub>2"
  shows "$ref \<sharp> (\<^bold>R\<^sub>s(P \<turnstile> Q\<^sub>1 \<diamondop> Q\<^sub>2)) \<^sub>f"
  by (simp add: RHS_def R1_def R2c_def R2s_def R3h_def design_def unrest usubst assms)

lemma CSP3_SRD_intro:
  assumes "P is CSP" "$ref \<sharp> pre\<^sub>R(P)" "$ref \<sharp> peri\<^sub>R(P)" "$ref \<sharp> post\<^sub>R(P)"
  shows "P is CSP3"
proof -
  have P: "\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) = P"
    by (simp add: SRD_reactive_design_alt assms(1) wait'_cond_peri_post_cmt[THEN sym])
  have "\<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> peri\<^sub>R(P) \<diamondop> post\<^sub>R(P)) is CSP3"
    by (rule CSP3_intro, simp add: assms P, simp add: ref_unrest_RHS_design assms)
  thus ?thesis
    by (simp add: P)
qed

lemma Skip_unrest_ref [unrest]: "$ref \<sharp> Skip\<lbrakk>false/$wait\<rbrakk>"
  by (simp add: Skip_def RHS_def R1_def R2c_def R2s_def R3h_def design_def usubst unrest)

lemma Skip_unrest_ref' [unrest]: "$ref\<acute> \<sharp> Skip\<lbrakk>false/$wait\<rbrakk>"
  by (simp add: Skip_def RHS_def R1_def R2c_def R2s_def R3h_def design_def usubst unrest)

lemma CSP3_iff:
  assumes "P is CSP"
  shows "P is CSP3 \<longleftrightarrow> ($ref \<sharp> P\<lbrakk>false/$wait\<rbrakk>)"
proof
  assume 1: "P is CSP3"
  have "$ref \<sharp> (Skip ;; P)\<lbrakk>false/$wait\<rbrakk>"
    by (simp add: usubst unrest)
  with 1 show "$ref \<sharp> P\<lbrakk>false/$wait\<rbrakk>"
    by (metis CSP3_def Healthy_def)
next
  assume 1:"$ref \<sharp> P\<lbrakk>false/$wait\<rbrakk>"
  show "P is CSP3"
    by (simp add: 1 CSP3_intro assms)
qed

lemma CSP3_unrest_ref [unrest]:
  assumes "P is CSP" "P is CSP3"
  shows "$ref \<sharp> pre\<^sub>R(P)" "$ref \<sharp> peri\<^sub>R(P)" "$ref \<sharp> post\<^sub>R(P)"
proof -
  have a:"($ref \<sharp> P\<lbrakk>false/$wait\<rbrakk>)"
    using CSP3_iff assms by blast
  from a show "$ref \<sharp> pre\<^sub>R(P)"
    by (rel_blast)
  from a show "$ref \<sharp> peri\<^sub>R(P)"
    by (rel_blast)
  from a show "$ref \<sharp> post\<^sub>R(P)"
    by (rel_blast)
qed

lemma CSP3_rdes:
  assumes "P is RR" "Q is RR" "R is RR"
  shows "CSP3(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) = \<^bold>R\<^sub>s((\<forall> $ref \<bullet> P) \<turnstile> (\<exists> $ref \<bullet> Q) \<diamondop> (\<exists> $ref \<bullet> R))"
  by (simp add: CSP3_def Skip_left_lemma closure assms rdes, rel_auto)

lemma CSP3_form:
  assumes "P is CSP"
  shows "CSP3(P) = \<^bold>R\<^sub>s((\<forall> $ref \<bullet> pre\<^sub>R(P)) \<turnstile> (\<exists> $ref \<bullet> peri\<^sub>R(P)) \<diamondop> (\<exists> $ref \<bullet> post\<^sub>R(P)))"
  by (simp add: CSP3_def Skip_left_lemma assms, rel_auto)

lemma CSP3_Skip [closure]:
  "Skip is CSP3"
  by (rule CSP3_intro, simp add: Skip_is_CSP, simp add: Skip_def unrest)

lemma CSP3_Stop [closure]:
  "Stop is CSP3"
  by (rule CSP3_intro, simp add: Stop_is_CSP, simp add: Stop_def unrest)

lemma CSP3_Idempotent [closure]: "Idempotent CSP3"
  by (metis (no_types, lifting) CSP3_Skip CSP3_def Healthy_if Idempotent_def seqr_assoc)

lemma CSP3_Continuous: "Continuous CSP3"
  by (simp add: Continuous_def CSP3_def seq_Sup_distl)

lemma Skip_right_lemma:
  assumes "P is CSP"
  shows "P ;; Skip = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P) \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> cmt\<^sub>R P)))"
proof -
  have "P ;; Skip = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> (\<exists> $st\<acute> \<bullet> peri\<^sub>R P) \<diamondop> post\<^sub>R P ;; ($tr\<acute> =\<^sub>u $tr \<and> $st\<acute> =\<^sub>u $st))"
    by (simp add: SRD_composition_wp closure assms wp rdes rpred, rel_auto)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile>
                       ((cmt\<^sub>R P ;; (\<exists> $st \<bullet> \<lceil>II\<rceil>\<^sub>D)) \<triangleleft> $wait\<acute> \<triangleright> (cmt\<^sub>R P ;; ($tr\<acute> =\<^sub>u $tr \<and> \<not> $wait \<and> $st\<acute> =\<^sub>u $st))))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile>
                       ((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P) \<triangleleft> $wait\<acute> \<triangleright> (cmt\<^sub>R P ;; ($tr\<acute> =\<^sub>u $tr \<and> \<not> $wait \<and> $st\<acute> =\<^sub>u $st))))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P) \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> cmt\<^sub>R P)))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  finally show ?thesis .
qed

lemma Skip_right_tri_lemma:
  assumes "P is CSP"
  shows "P ;; Skip = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R P) \<diamondop> (\<exists> $ref\<acute> \<bullet> post\<^sub>R P)))"
proof -
  have "((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P) \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> cmt\<^sub>R P)) = ((\<exists> $st\<acute> \<bullet> peri\<^sub>R P) \<diamondop> (\<exists> $ref\<acute> \<bullet> post\<^sub>R P))"
    by (rel_auto)
  thus ?thesis by (simp add: Skip_right_lemma[OF assms])
qed

lemma CSP4_intro:
  assumes "P is CSP" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; R1(true) = (\<not>\<^sub>r pre\<^sub>R(P))"
          "$st\<acute> \<sharp> (cmt\<^sub>R P)\<lbrakk>true/$wait\<acute>\<rbrakk>" "$ref\<acute> \<sharp> (cmt\<^sub>R P)\<lbrakk>false/$wait\<acute>\<rbrakk>"
  shows "P is CSP4"
proof -
  have "CSP4(P) = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P) \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> cmt\<^sub>R P)))"
    by (simp add: CSP4_def Skip_right_lemma assms(1))
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R(P) \<turnstile> ((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P)\<lbrakk>true/$wait\<acute>\<rbrakk> \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> cmt\<^sub>R P)\<lbrakk>false/$wait\<acute>\<rbrakk>))"
    by (simp add: wp_rea_def assms(2) rpred closure cond_var_subst_left cond_var_subst_right)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R(P) \<turnstile> ((\<exists> $st\<acute> \<bullet> (cmt\<^sub>R P)\<lbrakk>true/$wait\<acute>\<rbrakk>) \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> (cmt\<^sub>R P)\<lbrakk>false/$wait\<acute>\<rbrakk>)))"
    by (simp add: usubst unrest)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> ((cmt\<^sub>R P)\<lbrakk>true/$wait\<acute>\<rbrakk> \<triangleleft> $wait\<acute> \<triangleright> (cmt\<^sub>R P)\<lbrakk>false/$wait\<acute>\<rbrakk>))"
    by (simp add: ex_unrest assms)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R P \<turnstile> cmt\<^sub>R P)"
    by (simp add: cond_var_split)
  also have "... = P"
    by (simp add: SRD_reactive_design_alt assms(1))
  finally show ?thesis
    by (simp add: Healthy_def')
qed

lemma CSP4_RC_intro:
  assumes "P is CSP" "pre\<^sub>R(P) is RC"
          "$st\<acute> \<sharp> (cmt\<^sub>R P)\<lbrakk>true/$wait\<acute>\<rbrakk>" "$ref\<acute> \<sharp> (cmt\<^sub>R P)\<lbrakk>false/$wait\<acute>\<rbrakk>"
  shows "P is CSP4"
proof -
  have "(\<not>\<^sub>r pre\<^sub>R(P)) ;; R1(true) = (\<not>\<^sub>r pre\<^sub>R(P))"
    by (metis (no_types, lifting) R1_seqr_closure assms(2) rea_not_R1 rea_not_false rea_not_not wp_rea_RC_false wp_rea_def)
  thus ?thesis
    by (simp add: CSP4_intro assms)
qed

lemma CSP4_rdes:
  assumes "P is RR" "Q is RR" "R is RR"
  shows "CSP4(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R)) = \<^bold>R\<^sub>s ((\<not>\<^sub>r P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> Q) \<diamondop> (\<exists> $ref\<acute> \<bullet> R)))"
  by (simp add: CSP4_def Skip_right_lemma closure assms rdes, rel_auto, blast+)

lemma CSP4_form:
  assumes "P is CSP"
  shows "CSP4(P) =   \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R P) \<diamondop> (\<exists> $ref\<acute> \<bullet> post\<^sub>R P)))"
  by (simp add: CSP4_def Skip_right_tri_lemma assms)

lemma Skip_srdes_right_unit:
  "(Skip :: ('\<sigma>,'\<phi>) action) ;; II\<^sub>R = Skip"
  by (rdes_simp)

lemma Skip_srdes_left_unit:
  "II\<^sub>R ;; (Skip :: ('\<sigma>,'\<phi>) action) = Skip"
  by (rdes_eq)

lemma CSP4_right_subsumes_RD3: "RD3(CSP4(P)) = CSP4(P)"
  by (metis (no_types, opaque_lifting) CSP4_def RD3_def Skip_srdes_right_unit seqr_assoc)

lemma CSP4_implies_RD3: "P is CSP4 \<Longrightarrow> P is RD3"
  by (metis CSP4_right_subsumes_RD3 Healthy_def)

lemma CSP4_tri_intro:
  assumes "P is CSP" "(\<not>\<^sub>r pre\<^sub>R(P)) ;; R1(true) = (\<not>\<^sub>r pre\<^sub>R(P))" "$st\<acute> \<sharp> peri\<^sub>R(P)" "$ref\<acute> \<sharp> post\<^sub>R(P)"
  shows "P is CSP4"
  using assms
  by (rule_tac CSP4_intro, simp_all add: pre\<^sub>R_def peri\<^sub>R_def post\<^sub>R_def usubst cmt\<^sub>R_def)

lemma CSP4_NSRD_intro:
  assumes "P is NSRD" "$ref\<acute> \<sharp> post\<^sub>R(P)"
  shows "P is CSP4"
  by (simp add: CSP4_tri_intro NSRD_is_SRD NSRD_neg_pre_unit NSRD_st'_unrest_peri assms)

lemma CSP3_commutes_CSP4: "CSP3(CSP4(P)) = CSP4(CSP3(P))"
  by (simp add: CSP3_def CSP4_def seqr_assoc)

lemma NCSP_implies_CSP [closure]: "P is NCSP \<Longrightarrow> P is CSP"
  by (metis (no_types, opaque_lifting) CSP3_def CSP4_def Healthy_def NCSP_def SRD_idem SRD_seqr_closure Skip_is_CSP comp_apply)

lemma NCSP_elim [RD_elim]:
  "\<lbrakk> X is NCSP; P(\<^bold>R\<^sub>s(pre\<^sub>R(X) \<turnstile> peri\<^sub>R(X) \<diamondop> post\<^sub>R(X))) \<rbrakk> \<Longrightarrow> P(X)"
  by (simp add: SRD_reactive_tri_design closure)

lemma NCSP_implies_CSP3 [closure]:
  "P is NCSP \<Longrightarrow> P is CSP3"
  by (metis (no_types, lifting) CSP3_def Healthy_def' NCSP_def Skip_is_CSP Skip_left_unit_ref_unrest Skip_unrest_ref comp_apply seqr_assoc)

lemma NCSP_implies_CSP4 [closure]:
  "P is NCSP \<Longrightarrow> P is CSP4"
  by (metis (no_types, opaque_lifting) CSP3_commutes_CSP4 Healthy_def NCSP_def NCSP_implies_CSP NCSP_implies_CSP3 comp_apply)

lemma NCSP_implies_RD3 [closure]: "P is NCSP \<Longrightarrow> P is RD3"
  by (metis CSP3_commutes_CSP4 CSP4_right_subsumes_RD3 Healthy_def NCSP_def comp_apply)

lemma NCSP_implies_NSRD [closure]: "P is NCSP \<Longrightarrow> P is NSRD"
  by (simp add: NCSP_implies_CSP NCSP_implies_RD3 SRD_RD3_implies_NSRD)

lemma NCSP_subset_implies_CSP [closure]:
  "A \<subseteq> \<lbrakk>NCSP\<rbrakk>\<^sub>H \<Longrightarrow> A \<subseteq> \<lbrakk>CSP\<rbrakk>\<^sub>H"
  using NCSP_implies_CSP by blast

lemma NCSP_subset_implies_NSRD [closure]:
  "A \<subseteq> \<lbrakk>NCSP\<rbrakk>\<^sub>H \<Longrightarrow> A \<subseteq> \<lbrakk>NSRD\<rbrakk>\<^sub>H"
  using NCSP_implies_NSRD by blast

lemma CSP_Healthy_subset_member: "\<lbrakk> P \<in> A; A \<subseteq> \<lbrakk>CSP\<rbrakk>\<^sub>H \<rbrakk> \<Longrightarrow> P is CSP"
  by (simp add: is_Healthy_subset_member)

lemma CSP3_Healthy_subset_member: "\<lbrakk> P \<in> A; A \<subseteq> \<lbrakk>CSP3\<rbrakk>\<^sub>H \<rbrakk> \<Longrightarrow> P is CSP3"
  by (simp add: is_Healthy_subset_member)

lemma CSP4_Healthy_subset_member: "\<lbrakk> P \<in> A; A \<subseteq> \<lbrakk>CSP4\<rbrakk>\<^sub>H \<rbrakk> \<Longrightarrow> P is CSP4"
  by (simp add: is_Healthy_subset_member)

lemma NCSP_Healthy_subset_member: "\<lbrakk> P \<in> A; A \<subseteq> \<lbrakk>NCSP\<rbrakk>\<^sub>H \<rbrakk> \<Longrightarrow> P is NCSP"
  by (simp add: is_Healthy_subset_member)

lemma NCSP_intro:
  assumes "P is CSP" "P is CSP3" "P is CSP4"
  shows "P is NCSP"
  by (metis Healthy_def NCSP_def assms comp_eq_dest_lhs)

lemma Skip_left_unit: "P is NCSP \<Longrightarrow> Skip ;; P = P"
  by (metis (full_types) CSP3_def Healthy_if NCSP_implies_CSP3)

lemma Skip_right_unit: "P is NCSP \<Longrightarrow> P ;; Skip = P"
  by (metis (full_types) CSP4_def Healthy_if NCSP_implies_CSP4)

lemma NCSP_NSRD_intro:
  assumes "P is NSRD" "$ref \<sharp> pre\<^sub>R(P)" "$ref \<sharp> peri\<^sub>R(P)" "$ref \<sharp> post\<^sub>R(P)" "$ref\<acute> \<sharp> post\<^sub>R(P)"
  shows "P is NCSP"
  by (simp add: CSP3_SRD_intro CSP4_NSRD_intro NCSP_intro NSRD_is_SRD assms)

lemma CSP4_neg_pre_unit:
  assumes "P is CSP" "P is CSP4"
  shows "(\<not>\<^sub>r pre\<^sub>R(P)) ;; R1(true) = (\<not>\<^sub>r pre\<^sub>R(P))"
  by (simp add: CSP4_implies_RD3 NSRD_neg_pre_unit SRD_RD3_implies_NSRD assms(1) assms(2))

lemma NSRD_CSP4_intro:
  assumes "P is CSP" "P is CSP4"
  shows "P is NSRD"
  by (simp add: CSP4_implies_RD3 SRD_RD3_implies_NSRD assms(1) assms(2))

lemma NCSP_form:
  "NCSP P = \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> (\<not>\<^sub>r pre\<^sub>R(P)) wp\<^sub>r false) \<turnstile> ((\<exists> $ref \<bullet> \<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> (\<exists> $ref \<bullet> \<exists> $ref\<acute> \<bullet> post\<^sub>R(P))))"
proof -
  have "NCSP P = CSP3 (CSP4 (NSRD P))"
    by (metis (no_types, opaque_lifting) CSP4_def NCSP_def NSRD_alt_def RA1 RD3_def Skip_srdes_left_unit o_apply)
  also
  have "... =  \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> (\<not>\<^sub>r pre\<^sub>R (NSRD P)) wp\<^sub>r false) \<turnstile>
                   (\<exists> $ref \<bullet> \<exists> $st\<acute> \<bullet> peri\<^sub>R (NSRD P)) \<diamondop>
                   (\<exists> $ref \<bullet> \<exists> $ref\<acute> \<bullet> post\<^sub>R (NSRD P)))"
    by (simp add: CSP3_form CSP4_form closure unrest rdes, rel_auto)
  also have "... = \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> (\<not>\<^sub>r pre\<^sub>R(P)) wp\<^sub>r false) \<turnstile> ((\<exists> $ref \<bullet> \<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> (\<exists> $ref \<bullet> \<exists> $ref\<acute> \<bullet> post\<^sub>R(P))))"
    by (simp add: NSRD_form rdes closure, rel_blast)
  finally show ?thesis .
qed

lemma CSP4_st'_unrest_peri [unrest]:
  assumes "P is CSP" "P is CSP4"
  shows "$st\<acute> \<sharp> peri\<^sub>R(P)"
  by (simp add: NSRD_CSP4_intro NSRD_st'_unrest_peri assms)

lemma CSP4_healthy_form:
  assumes "P is CSP" "P is CSP4"
  shows "P = \<^bold>R\<^sub>s((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> (\<exists> $ref\<acute> \<bullet> post\<^sub>R(P))))"
proof -
  have "P = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P) \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> cmt\<^sub>R P)))"
    by (metis CSP4_def Healthy_def Skip_right_lemma assms(1) assms(2))
  also have "... = \<^bold>R\<^sub>s ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> cmt\<^sub>R P)\<lbrakk>true/$wait\<acute>\<rbrakk> \<triangleleft> $wait\<acute> \<triangleright> (\<exists> $ref\<acute> \<bullet> cmt\<^sub>R P)\<lbrakk>false/$wait\<acute>\<rbrakk>))"
    by (metis (no_types, opaque_lifting) subst_wait'_left_subst subst_wait'_right_subst wait'_cond_def)
  also have "... = \<^bold>R\<^sub>s((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> (\<exists> $ref\<acute> \<bullet> post\<^sub>R(P))))"
    by (simp add: wait'_cond_def usubst peri\<^sub>R_def post\<^sub>R_def cmt\<^sub>R_def unrest)
  finally show ?thesis .
qed

lemma CSP4_ref'_unrest_pre [unrest]:
  assumes "P is CSP" "P is CSP4"
  shows "$ref\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  have "pre\<^sub>R(P) = pre\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> (\<exists> $ref\<acute> \<bullet> post\<^sub>R(P)))))"
    using CSP4_healthy_form assms(1) assms(2) by fastforce
  also have "... = (\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false"
    by (simp add: rea_pre_RHS_design wp_rea_def usubst unrest
        CSP4_neg_pre_unit R1_rea_not R2c_preR R2c_rea_not assms)
  also have "$ref\<acute> \<sharp> ..."
    by (simp add: wp_rea_def unrest)
  finally show ?thesis .
qed

lemma NCSP_set_unrest_pre_wait':
  assumes "A \<subseteq> \<lbrakk>NCSP\<rbrakk>\<^sub>H"
  shows "\<And> P. P \<in> A \<Longrightarrow> $wait\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  fix P
  assume "P \<in> A"
  hence "P is NSRD"
    using NCSP_implies_NSRD assms by auto
  thus "$wait\<acute> \<sharp> pre\<^sub>R(P)"
    using NSRD_wait'_unrest_pre by blast
qed

lemma CSP4_set_unrest_pre_st':
  assumes "A \<subseteq> \<lbrakk>CSP\<rbrakk>\<^sub>H" "A \<subseteq> \<lbrakk>CSP4\<rbrakk>\<^sub>H"
  shows "\<And> P. P \<in> A \<Longrightarrow> $st\<acute> \<sharp> pre\<^sub>R(P)"
proof -
  fix P
  assume "P \<in> A"
  hence "P is NSRD"
    using NSRD_CSP4_intro assms(1) assms(2) by blast
  thus "$st\<acute> \<sharp> pre\<^sub>R(P)"
    using NSRD_st'_unrest_pre by blast
qed

lemma CSP4_ref'_unrest_post [unrest]:
  assumes "P is CSP" "P is CSP4"
  shows "$ref\<acute> \<sharp> post\<^sub>R(P)"
proof -
  have "post\<^sub>R(P) = post\<^sub>R(\<^bold>R\<^sub>s((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<turnstile> ((\<exists> $st\<acute> \<bullet> peri\<^sub>R(P)) \<diamondop> (\<exists> $ref\<acute> \<bullet> post\<^sub>R(P)))))"
    using CSP4_healthy_form assms(1) assms(2) by fastforce
  also have "... = R1 (R2c ((\<not>\<^sub>r pre\<^sub>R P) wp\<^sub>r false \<Rightarrow>\<^sub>r (\<exists> $ref\<acute> \<bullet> post\<^sub>R P)))"
    by (simp add: rea_post_RHS_design usubst unrest wp_rea_def)
  also have "$ref\<acute> \<sharp> ..."
    by (simp add: R1_def R2c_def wp_rea_def unrest)
  finally show ?thesis .
qed

lemma CSP3_Chaos [closure]: "Chaos is CSP3"
  by (simp add: Chaos_def, rule CSP3_intro, simp_all add: RHS_design_is_SRD unrest)

lemma CSP4_Chaos [closure]: "Chaos is CSP4"
  by (rule CSP4_tri_intro, simp_all add: closure rdes unrest)

lemma NCSP_Chaos [closure]: "Chaos is NCSP"
  by (simp add: NCSP_intro closure)

lemma CSP3_Miracle [closure]: "Miracle is CSP3"
  by (simp add: Miracle_def, rule CSP3_intro, simp_all add: RHS_design_is_SRD unrest)

lemma CSP4_Miracle [closure]: "Miracle is CSP4"
  by (rule CSP4_tri_intro, simp_all add: closure rdes unrest)

lemma NCSP_Miracle [closure]: "Miracle is NCSP"
  by (simp add: NCSP_intro closure)

lemma NCSP_seqr_closure [closure]:
  assumes "P is NCSP" "Q is NCSP"
  shows "P ;; Q is NCSP"
  by (metis (no_types, lifting) CSP3_def CSP4_def Healthy_def' NCSP_implies_CSP NCSP_implies_CSP3
      NCSP_implies_CSP4 NCSP_intro SRD_seqr_closure assms(1) assms(2) seqr_assoc)

lemma CSP4_Skip [closure]: "Skip is CSP4"
  apply (rule CSP4_intro, simp_all add: Skip_is_CSP)
  apply (simp_all add: Skip_def rea_pre_RHS_design rea_cmt_RHS_design usubst unrest R2c_true)
done

lemma NCSP_Skip [closure]: "Skip is NCSP"
  by (metis CSP3_Skip CSP4_Skip Healthy_def NCSP_def Skip_is_CSP comp_apply)

lemma CSP4_Stop [closure]: "Stop is CSP4"
  apply (rule CSP4_intro, simp_all add: Stop_is_CSP)
  apply (simp_all add: Stop_def rea_pre_RHS_design rea_cmt_RHS_design usubst unrest R2c_true)
done

lemma NCSP_Stop [closure]: "Stop is NCSP"
  by (metis CSP3_Stop CSP4_Stop Healthy_def NCSP_def Stop_is_CSP comp_apply)

lemma CSP4_Idempotent: "Idempotent CSP4"
  by (metis (no_types, lifting) CSP3_Skip CSP3_def CSP4_def Healthy_if Idempotent_def seqr_assoc)

lemma CSP4_Continuous: "Continuous CSP4"
  by (simp add: Continuous_def CSP4_def seq_Sup_distr)

lemma rdes_frame_ext_NCSP_closed [closure]:
  assumes "vwb_lens a" "P is NCSP"
  shows "a:[P]\<^sub>R\<^sup>+ is NCSP"
  by (metis (no_types, lifting) CSP3_def CSP4_def Healthy_intro NCSP_Skip NCSP_implies_NSRD NCSP_intro NSRD_is_SRD Skip_frame Skip_left_unit Skip_right_unit assms(1) assms(2) rdes_frame_ext_NSRD_closed seq_srea_frame)

lemma preR_Stop [rdes]: "pre\<^sub>R(Stop) = true\<^sub>r"
  by (simp add: Stop_def Stop_is_CSP rea_pre_RHS_design unrest usubst R2c_true)

lemma periR_Stop [rdes]: "peri\<^sub>R(Stop) = \<E>(true,\<guillemotleft>[]\<guillemotright>,{}\<^sub>u)"
  by (rel_auto)

lemma postR_Stop [rdes]: "post\<^sub>R(Stop) = false"
  by (rel_auto)

lemma cmtR_Stop [rdes]: "cmt\<^sub>R(Stop) = ($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>)"
  by (rel_auto)

lemma NCSP_Idempotent [closure]: "Idempotent NCSP"
  by (clarsimp simp add: NCSP_def Idempotent_def)
     (metis (no_types, opaque_lifting) CSP3_Idempotent CSP3_def CSP4_Idempotent CSP4_def Healthy_def Idempotent_def SRD_idem SRD_seqr_closure Skip_is_CSP seqr_assoc)

lemma NCSP_Continuous [closure]: "Continuous NCSP"
  by (simp add: CSP3_Continuous CSP4_Continuous Continuous_comp NCSP_def SRD_Continuous)

lemma preR_CRR [closure]: "P is NCSP \<Longrightarrow> pre\<^sub>R(P) is CRR"
  by (rule CRR_intro, simp_all add: closure unrest)

lemma periR_CRR [closure]: "P is NCSP \<Longrightarrow> peri\<^sub>R(P) is CRR"
  by (rule CRR_intro, simp_all add: closure unrest)

lemma postR_CRR [closure]: "P is NCSP \<Longrightarrow> post\<^sub>R(P) is CRR"
  by (rule CRR_intro, simp_all add: closure unrest)

lemma NCSP_rdes_intro [closure]:
  assumes "P is CRC" "Q is CRR" "R is CRR"
          "$st\<acute> \<sharp> Q" "$ref\<acute> \<sharp> R"
  shows "\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R) is NCSP"
  apply (rule NCSP_intro)
    apply (simp_all add: closure assms)
   apply (rule CSP3_SRD_intro)
      apply (simp_all add: rdes closure assms unrest)
  apply (rule CSP4_tri_intro)
     apply (simp_all add: rdes closure assms unrest)
  apply (metis (no_types, lifting) CRC_implies_RC R1_seqr_closure assms(1) rea_not_R1 rea_not_false rea_not_not wp_rea_RC_false wp_rea_def)
  done

lemma NCSP_preR_CRC [closure]:
  assumes "P is NCSP"
  shows "pre\<^sub>R(P) is CRC"
  by (rule CRC_intro, simp_all add: closure assms unrest)

lemma NCSP_postR_CRF [closure]: "P is NCSP \<Longrightarrow> post\<^sub>R P is CRF"
  by (rule CRF_intro, simp_all add: unrest closure)

lemma CSP3_Sup_closure [closure]:
  "A \<subseteq> \<lbrakk>CSP3\<rbrakk>\<^sub>H \<Longrightarrow> (\<Sqinter> A) is CSP3"
  apply (auto simp add: CSP3_def Healthy_def seq_Sup_distl)
  apply (rule cong[of Sup])
   apply (simp)
  using image_iff apply force
  done

lemma CSP4_Sup_closure [closure]:
  "A \<subseteq> \<lbrakk>CSP4\<rbrakk>\<^sub>H \<Longrightarrow> (\<Sqinter> A) is CSP4"
  apply (auto simp add: CSP4_def Healthy_def seq_Sup_distr)
  apply (rule cong[of Sup])
   apply (simp)
  using image_iff apply force
  done

lemma NCSP_Sup_closure [closure]: "\<lbrakk> A \<subseteq> \<lbrakk>NCSP\<rbrakk>\<^sub>H; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> A) is NCSP"
  apply (rule NCSP_intro, simp_all add: closure)
   apply (metis (no_types, lifting) Ball_Collect CSP3_Sup_closure NCSP_implies_CSP3)
  apply (metis (no_types, lifting) Ball_Collect CSP4_Sup_closure NCSP_implies_CSP4)
  done

lemma NCSP_SUP_closure [closure]: "\<lbrakk> \<And> i. P(i) is NCSP; A \<noteq> {} \<rbrakk> \<Longrightarrow> (\<Sqinter> i\<in>A. P(i)) is NCSP"
  by (metis (mono_tags, lifting) Ball_Collect NCSP_Sup_closure image_iff image_is_empty)

lemma PCSP_implies_NCSP [closure]:
  assumes "P is PCSP"
  shows "P is NCSP"
proof -
  have "P = Productive(NCSP(NCSP P))"
    by (metis (no_types, opaque_lifting) Healthy_def' Idempotent_def NCSP_Idempotent assms comp_apply)

  also have "... = \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> (\<not>\<^sub>r pre\<^sub>R(NCSP P)) wp\<^sub>r false) \<turnstile>
                       (\<exists> $ref \<bullet> \<exists> $st\<acute> \<bullet> peri\<^sub>R(NCSP P)) \<diamondop>
                       ((\<exists> $ref \<bullet> \<exists> $ref\<acute> \<bullet> post\<^sub>R (NCSP P)) \<and> $tr <\<^sub>u $tr\<acute>))"
    by (simp add: NCSP_form Productive_RHS_design_form unrest closure)
  also have "... is NCSP"
    apply (rule NCSP_rdes_intro)
        apply (rule CRC_intro)
         apply (simp_all add: unrest ex_unrest all_unrest closure)
    done
  finally show ?thesis .
qed

lemma PCSP_elim [RD_elim]:
  assumes "X is PCSP" "P (\<^bold>R\<^sub>s ((pre\<^sub>R X) \<turnstile> peri\<^sub>R X \<diamondop> (R4(post\<^sub>R X))))"
  shows "P X"
  by (metis R4_def Healthy_if NCSP_implies_CSP PCSP_implies_NCSP Productive_form assms comp_apply)

lemma R5_alt_def: "R5(P) = (P \<and> $tr\<acute> =\<^sub>u $tr)"
  by rel_auto

lemma ICSP_implies_NCSP [closure]:
  assumes "P is ICSP"
  shows "P is NCSP"
proof -
  have "P = ISRD1(NCSP(NCSP P))"
    by (metis (no_types, opaque_lifting) Healthy_def' Idempotent_def NCSP_Idempotent assms comp_apply)
  also have "... = ISRD1 (\<^bold>R\<^sub>s ((\<forall> $ref \<bullet> (\<not>\<^sub>r pre\<^sub>R (NCSP P)) wp\<^sub>r false) \<turnstile>
                              (\<exists> $ref \<bullet> \<exists> $st\<acute> \<bullet> peri\<^sub>R (NCSP P)) \<diamondop>
                              (\<exists> $ref \<bullet> \<exists> $ref\<acute> \<bullet> post\<^sub>R (NCSP P))))"
    by (simp add: NCSP_form)
  also have "... = \<^bold>R\<^sub>s ((\<forall> $ref \<bullet> (\<not>\<^sub>r pre\<^sub>R(NCSP P)) wp\<^sub>r false) \<turnstile>
                       false \<diamondop>
                       ((\<exists> $ref \<bullet> \<exists> $ref\<acute> \<bullet> post\<^sub>R (NCSP P)) \<and> $tr\<acute> =\<^sub>u $tr))"
    by (simp_all add: ISRD1_RHS_design_form R5_alt_def closure rdes unrest)
  also have "... is NCSP"
    apply (rule NCSP_rdes_intro)
        apply (rule CRC_intro)
         apply (simp_all add: unrest ex_unrest all_unrest closure)
    done
  finally show ?thesis .
qed

lemma ICSP_implies_ISRD [closure]:
  assumes "P is ICSP"
  shows "P is ISRD"
  by (metis (no_types, opaque_lifting) Healthy_def ICSP_implies_NCSP ISRD_def NCSP_implies_NSRD assms comp_apply)

lemma ICSP_elim [RD_elim]:
  assumes "X is ICSP" "P (\<^bold>R\<^sub>s ((pre\<^sub>R X) \<turnstile> false \<diamondop> R5(post\<^sub>R X)))"
  shows "P X"
  by (metis Healthy_if NCSP_implies_CSP ICSP_implies_NCSP ISRD1_form assms comp_apply)

lemma ICSP_Stop_right_zero_lemma:
  "(P \<and> ($tr\<acute> =\<^sub>u $tr)) ;; true\<^sub>r = true\<^sub>r \<Longrightarrow> (P \<and> ($tr\<acute> =\<^sub>u $tr)) ;; ($tr\<acute> =\<^sub>u $tr) = ($tr\<acute> =\<^sub>u $tr)"
  by (rel_blast)

lemma ICSP_Stop_right_zero:
  assumes "P is ICSP" "pre\<^sub>R(P) = true\<^sub>r" "post\<^sub>R(P) ;; true\<^sub>r = true\<^sub>r"
  shows "P ;; Stop = Stop"
proof -
  from assms(3) have 1:"(post\<^sub>R P \<and> $tr\<acute> =\<^sub>u $tr) ;; true\<^sub>r = true\<^sub>r"
    by (rel_auto, metis (full_types, opaque_lifting) dual_order.antisym order_refl)
  show ?thesis
    by (rdes_simp cls: assms(1), simp add: R5_alt_def csp_enable_nothing assms(2) ICSP_Stop_right_zero_lemma[OF 1])
qed

lemma ICSP_intro: "\<lbrakk> P is NCSP; P is ISRD1 \<rbrakk> \<Longrightarrow> P is ICSP"
  using Healthy_comp by blast

lemma seq_ICSP_closed [closure]:
  assumes "P is ICSP" "Q is ICSP"
  shows "P ;; Q is ICSP"
  by (meson ICSP_implies_ISRD ICSP_implies_NCSP ICSP_intro ISRD_implies_ISRD1 NCSP_seqr_closure assms seq_ISRD_closed)

lemma Miracle_ICSP [closure]: "Miracle is ICSP"
  by (rule ICSP_intro, simp add: closure, simp add: ISRD1_rdes_intro rdes_def closure)

subsection \<open> CSP theories \<close>

lemma NCSP_false: "NCSP false = Miracle"
  by (simp add: NCSP_def srdes_theory.healthy_top[THEN sym], simp add: closure Healthy_if)

lemma NCSP_true: "NCSP true = Chaos"
  by (simp add: NCSP_def srdes_theory.healthy_bottom[THEN sym], simp add: closure Healthy_if)

interpretation csp_theory: utp_theory_kleene NCSP Skip
  rewrites "P \<in> carrier csp_theory.thy_order \<longleftrightarrow> P is NCSP"
  and "carrier csp_theory.thy_order \<rightarrow> carrier csp_theory.thy_order \<equiv> \<lbrakk>NCSP\<rbrakk>\<^sub>H \<rightarrow> \<lbrakk>NCSP\<rbrakk>\<^sub>H"
  and "le csp_theory.thy_order = (\<sqsubseteq>)"
  and "eq csp_theory.thy_order = (=)"
  and csp_top: "csp_theory.utp_top = Miracle"
  and csp_bottom: "csp_theory.utp_bottom = Chaos"
proof -
  have "utp_theory_continuous NCSP"
    by (unfold_locales, simp_all add: Healthy_Idempotent Healthy_if NCSP_Idempotent NCSP_Continuous)
  then interpret utp_theory_continuous NCSP
    by simp
  show t: "utp_top = Miracle" and b:"utp_bottom = Chaos"
    by (simp_all add: healthy_top healthy_bottom NCSP_false NCSP_true)
  show "utp_theory_kleene NCSP Skip"
    by (unfold_locales, simp_all add: closure Skip_left_unit Skip_right_unit Miracle_left_zero t)
qed (simp_all)

abbreviation TestC ("test\<^sub>C") where
"test\<^sub>C P \<equiv> csp_theory.utp_test P"

definition StarC :: "('\<sigma>, '\<phi>) action \<Rightarrow> ('\<sigma>, '\<phi>) action" ("_\<^sup>\<star>\<^sup>C" [999] 999) where
"StarC P \<equiv> csp_theory.utp_star P"

lemma StarC_unfold: "P is NCSP \<Longrightarrow> P\<^sup>\<star>\<^sup>C = Skip \<sqinter> (P ;; P\<^sup>\<star>\<^sup>C)"
  by (simp add: StarC_def csp_theory.Star_unfoldl_eq)

lemma sfrd_star_as_rdes_star:
  "P is NCSP \<Longrightarrow> P\<^sup>\<star>\<^sup>R ;; Skip = P\<^sup>\<star>\<^sup>C"
  by (simp add: csp_theory.Star_alt_def nsrdes_theory.Star_alt_def StarC_def StarR_def closure unrest Skip_srdes_left_unit csp_theory.Unit_Right)

lemma sfrd_star_as_rdes_star':
  "P is NCSP \<Longrightarrow> Skip ;; P\<^sup>\<star>\<^sup>R = P\<^sup>\<star>\<^sup>C"
  by (simp add: csp_theory.Star_alt_def nsrdes_theory.Star_alt_def StarC_def StarR_def closure unrest Skip_srdes_right_unit csp_theory.Unit_Left upred_semiring.distrib_left)

theorem csp_star_rdes_def [rdes_def]:
  assumes "P is CRC" "Q is CRR" "R is CRF" "$st\<acute> \<sharp> Q"
  shows "(\<^bold>R\<^sub>s(P \<turnstile> Q \<diamondop> R))\<^sup>\<star>\<^sup>C = \<^bold>R\<^sub>s(R\<^sup>\<star>\<^sup>c wp\<^sub>r P \<turnstile> (R\<^sup>\<star>\<^sup>c ;; Q) \<diamondop> R\<^sup>\<star>\<^sup>c)"
  apply (simp add: wp_rea_def sfrd_star_as_rdes_star[THEN sym] crf_star_as_rea_star assms seqr_assoc rpred closure unrest StarR_rdes_def)
  apply (simp add: rdes_def assms closure unrest wp_rea_def[THEN sym])
  apply (simp add: wp rpred assms closure)
  apply (simp add: csp_do_nothing)
  done

subsection \<open> Algebraic laws \<close>

lemma Stop_left_zero:
  assumes "P is CSP"
  shows "Stop ;; P = Stop"
  by (simp add: NSRD_seq_post_false assms NCSP_implies_NSRD NCSP_Stop postR_Stop)

end