theory Execution imports
  Main HOL.String Deduction
begin

(* 9. (a) *)

lemma "maps_exists":
  assumes "b \<in> set (List.maps f as)"
  shows "\<exists>a \<in> set as. b \<in> set (f a)"
  using assms
  apply (induction as)
   apply (simp add: maps_simps(2))
  by (metis Un_iff list.set_intros(1) list.set_intros(2) maps_simps(1) set_append)

lemma "exists_maps":
  assumes "\<exists>a \<in> set as. b \<in> set (f a)"
  shows "b \<in> set (List.maps f as)"
  using assms
  apply (induction as)
   apply simp
  by (metis Un_iff maps_simps(1) set_ConsD set_append)

(* successors of a constraint using Unif rule of rer1 *)
fun c_unify :: "constraint \<Rightarrow> (constraint_system \<times> m_subst) list" where
  "c_unify (M | A \<triangleright> (Var _)) = []"
| "c_unify (M | A \<triangleright> t) = List.maps (\<lambda>u. case m_unify [(t, u)] of Some \<sigma> \<Rightarrow> [([], \<sigma>)] | None \<Rightarrow> []) (M @ A)"

(* soundness of c_unify *)
lemma "c_unify_rer1":
  assumes "(cs, \<sigma>) \<in> set (c_unify (M | A \<triangleright> t))"
  shows "rer1 (M | A \<triangleright> t) \<sigma> cs"
  proof -
    have "not_is_var": "\<not>is_var t"
      using assms is_var.simps
      by auto
    obtain u where "u \<in> set (M @ A)" and "(cs, \<sigma>) \<in> set (case m_unify [(t, u)] of Some \<sigma> \<Rightarrow> [([], \<sigma>)] | None \<Rightarrow> [])"
      using assms maps_exists
      apply (cases t)
      by force+
    then show ?thesis
      using not_is_var
      by fastforce
  qed

(* successors of a constraint using Comp rules of rer1 *)
fun c_comp :: "constraint \<Rightarrow> (constraint_system \<times> m_subst) list" where
  "c_comp (M | A \<triangleright> Hash t) = [([M | A \<triangleright> t], Var)]"
| "c_comp (M | A \<triangleright> Pair t1 t2) = [([M | A \<triangleright> t1, M | A \<triangleright> t2], Var)]"
| "c_comp (M | A \<triangleright> Sym_encrypt m k) = [([M | A \<triangleright> m, M | A \<triangleright> k], Var)]"
| "c_comp (M | A \<triangleright> Public_key_encrypt m k) = [([M | A \<triangleright> m, M | A \<triangleright> k], Var)]"
| "c_comp (M | A \<triangleright> Signature t (Cons i)) = (if i = \<iota> then [([M | A \<triangleright> t], Var)] else [])"
| "c_comp (M | A \<triangleright> _) = []"

(* soundness of c_comp *)
lemma "c_comp_rer1":
  assumes "(cs, \<sigma>) \<in> set (c_comp (M | A \<triangleright> t))"
  shows "rer1 (M | A \<triangleright> t) \<sigma> cs"
  using assms
proof (cases t)
  case (Signature t k)
  then show ?thesis
    using assms
    proof (cases k)
      case (Cons i)
      then show ?thesis
        using Signature assms intruder_def
        by auto
    qed auto
  qed force+

(* helper function for Analysis rules of rer1 providing successors of analyzing one message from M *)
fun "c_dec_term" :: "constraint \<Rightarrow> msg \<Rightarrow> (constraint_system \<times> m_subst) list" where
  "c_dec_term (M | A \<triangleright> t) (Pair u v) = (let M' = removeAll (Pair u v) M in [([(u # v # M') | (Pair u v # A) \<triangleright> t], Var)])"
| "c_dec_term (M | A \<triangleright> t) (Sym_encrypt u k) = (let M' = removeAll (Sym_encrypt u k) M in [([(u # M') | (Sym_encrypt u k # A) \<triangleright> t, M' | (Sym_encrypt u k # A) \<triangleright> k], Var)])"
| "c_dec_term (M | A \<triangleright> t) (Public_key_encrypt u (Cons i)) = (if i = \<iota> then let M' = removeAll (Public_key_encrypt u intruder) M in [([(u # M') | (Public_key_encrypt u intruder # A) \<triangleright> t], Var)] else [])"
| "c_dec_term (M | A \<triangleright> t) (Public_key_encrypt u (Var x)) = (let \<sigma> = Var(x := intruder) in [([c_sapply \<sigma> (M | A \<triangleright> t)], \<sigma>)])"
| "c_dec_term (M | A \<triangleright> t) _ = []"

(* soundness of c_dec_term *)
lemma "c_dec_term_rer1":
  assumes "(cs, \<sigma>) \<in> set (c_dec_term (M | A \<triangleright> t) m)" and "m \<in> set M"
  shows "rer1 (M | A \<triangleright> t) \<sigma> cs"
  using assms
proof (cases m)
  case (Sym_encrypt m k)
  then show ?thesis
    using assms
    apply auto
    by (metis empty_set fst_conv list.set(2) rer1.Sdec singletonD snd_conv)
next
  case (Public_key_encrypt u k)
  then show ?thesis
    using assms
    proof (cases k)
      case (Cons i)
      then show ?thesis
        using intruder_def Public_key_encrypt assms(1) assms(2)
        by auto
    next
      case (Var x)
      then show ?thesis
        using assms Ksub Public_key_encrypt
        by (metis c_dec_term.simps(4) Pair_inject empty_set list.set(2) singletonD)
    qed auto
qed auto

(* successors of a constraint using Analysis rules of rer1 *)
fun "c_dec" :: "constraint \<Rightarrow> (constraint_system \<times> m_subst) list" where
  "c_dec (M | A \<triangleright> t) = List.maps (c_dec_term (M | A \<triangleright> t)) M"

(* soundness of c_dec *)
lemma "c_dec_rer1":
  assumes "(cs, \<sigma>) \<in> set (c_dec (M | A \<triangleright> t))"
  shows "rer1 (M | A \<triangleright> t) \<sigma> cs"
proof -
  obtain m where "m \<in> set M" and "(cs, \<sigma>) \<in> set (c_dec_term (M | A \<triangleright> t) m)"
    using assms maps_exists
    by force
  then show ?thesis
    using c_dec_term_rer1
    by simp
qed

(* successors of a constraint under rer1 *)
definition "c_succ" :: "constraint \<Rightarrow> (constraint_system \<times> m_subst) list" where
  "c_succ c = c_unify c @ c_comp c @ c_dec c"

(* soundness of c_succ *)
lemma "c_succ_rer1":
  assumes "(cs, \<sigma>) \<in> set (c_succ c)"
  shows "rer1 c \<sigma> cs"
proof -
  obtain M A t where "c = M | A \<triangleright> t"
    using assms c_derives.cases by blast
  then show ?thesis
    using assms c_unify_rer1 c_comp_rer1 c_dec_rer1 c_succ_def by auto
qed

(* completeness of c_succ w.r.t. rer1 *)
lemma "c_rer1_succ": "rer1 c \<sigma> cs \<Longrightarrow> (cs, \<sigma>) \<in> set (c_succ c)"
proof (induction rule: rer1.induct)
  case (Unif t M A \<sigma>)
  then obtain u where "u \<in> set (M @ A)" and "m_unify [(t, u)] = Some \<sigma>"
    by auto
  then have "([], \<sigma>) \<in> set (List.maps (\<lambda>u. case m_unify [(t, u)] of Some \<sigma> \<Rightarrow> [([], \<sigma>)] | None \<Rightarrow> []) (M @ A))"
    using exists_maps[of "M @ A" "([], \<sigma>)" "(\<lambda>u. case m_unify [(t, u)] of Some \<sigma> \<Rightarrow> [([], \<sigma>)] | None \<Rightarrow> [])"]
    by force
  then have "([], \<sigma>) \<in> set (c_unify (M | A \<triangleright> t))"
    using Unif(1) is_var.intros
    apply (cases t)
    by force+
  then show ?case
    by (simp add: c_succ_def)
next
  case (Proj u v M M' A t)
  then have "c_dec_term (M | A \<triangleright> t) (Pair u v) = [([(u # v # M') | (Pair u v # A) \<triangleright> t], Var)]"
    by simp
  then have "([(u # v # M') | (Pair u v # A) \<triangleright> t], Var) \<in> set (c_dec (M | A \<triangleright> t))"
    using exists_maps
    by (metis (full_types) Proj.hyps(1) c_dec.simps list.set_intros(1))
  then show ?case
    by (simp add: c_succ_def)
next
  case (Sdec u k M M' A t)
  then have "c_dec_term (M | A \<triangleright> t) (Sym_encrypt u k) = [([(u # M') | (Sym_encrypt u k # A) \<triangleright> t, M' | (Sym_encrypt u k # A) \<triangleright> k], Var)]"
    using c_dec_term.simps(2)
    by metis
  then have "([(u # M') | (Sym_encrypt u k # A) \<triangleright> t, M' | (Sym_encrypt u k # A) \<triangleright> k], Var) \<in> set (c_dec (M | A \<triangleright> t))"
    using exists_maps
    by (metis (full_types) Sdec.hyps(1) c_dec.simps list.set_intros(1))
  then show ?case
    by (simp add: c_succ_def)
next
  case (Adec u M M' A t)
  then have "c_dec_term (M | A \<triangleright> t) (Public_key_encrypt u (Cons \<iota>)) = [([(u # M') | (Public_key_encrypt u intruder # A) \<triangleright> t], Var)]"
    by simp
  then have "([(u # M') | (Public_key_encrypt u intruder # A) \<triangleright> t], Var) \<in> set (c_dec (M | A \<triangleright> t))"
    using exists_maps
    by (metis (full_types) Adec.hyps(1) c_dec.simps intruder_def list.set_intros(1))
  then show ?case
    by (simp add: c_succ_def)
next
  case (Ksub u x M \<sigma> A t)
  then have "c_dec_term (M | A \<triangleright> t) (Public_key_encrypt u (Var x)) = [([c_sapply \<sigma> (M | A \<triangleright> t)], \<sigma>)]"
    using c_dec_term.simps(4)
    by metis
  then have "([c_sapply \<sigma> (M | A \<triangleright> t)], \<sigma>) \<in> set (c_dec (M | A \<triangleright> t))"
    using exists_maps
    by (metis (full_types) Ksub.hyps(1) c_dec.simps list.set_intros(1))
  then show ?case
    by (simp add: c_succ_def)
qed (simp add: c_succ_def intruder_def)+

(* successors of a constraint system under rer, i.e., using rule Context *)
fun "cs_succ_aux" :: "constraint_system \<Rightarrow> constraint_system \<Rightarrow> (constraint_system \<times> m_subst) list" where
  "cs_succ_aux _ [] = []"
| "cs_succ_aux cs' (c # cs'') = map (\<lambda>(cs, \<sigma>). (cs_sapply \<sigma> cs' @ cs @ cs_sapply \<sigma> cs'', \<sigma>)) (c_succ c)
                              @ cs_succ_aux (cs' @ [c]) cs''"

(* helper lemma for soundness of cs_succ_aux_rer *)
lemma "cs_succ_aux_rer":
  assumes "(ocs, \<sigma>) \<in> set (cs_succ_aux pcs ics)"
  shows "rer (pcs @ ics) \<sigma> ocs"
  using assms
proof (induction ics arbitrary: pcs)
  case (Cons c ics)
  then show ?case
    proof (cases "(ocs, \<sigma>) \<in> set (cs_succ_aux (pcs @ [c]) ics)")
      case False
      then obtain cs where "(cs, \<sigma>) \<in> set (c_succ c)" and "ocs_def": "ocs = cs_sapply \<sigma> pcs @ cs @ cs_sapply \<sigma> ics"
        using Cons False
        by auto
      then show ?thesis
        by (simp add: Context c_succ_rer1)
    qed fastforce
qed simp

(* helper lemma for completeness of cs_succ_aux w.r.t. rer1 *)
lemma "cs_rer_succ_aux":
  assumes "rer1 c \<sigma> cs"
  shows "(cs_sapply \<sigma> (pcs @ cs') @ cs @ cs_sapply \<sigma> cs'', \<sigma>) \<in> set (cs_succ_aux pcs (cs' @ [c] @ cs''))"
proof (induction cs' arbitrary: pcs)
  case Nil
  have "(cs, \<sigma>) \<in> set (c_succ c)"
    using assms c_rer1_succ
    by simp
  then show ?case
    using Nil
    by auto
next
  case (Cons a cs')
  then show ?case
    using Cons[of "pcs @ [a]"]
    by simp
qed

(* successors of a constraint system under rer *)
definition "cs_succ" :: "constraint_system \<Rightarrow> (constraint_system \<times> m_subst) list" where
  "cs_succ cs = cs_succ_aux [] cs"

(* soundness of cs_succ *)
lemma "cs_succ_rer": "(cs, \<sigma>) \<in> set (cs_succ ics) \<Longrightarrow> rer ics \<sigma> cs"
  unfolding cs_succ_def
  using cs_succ_aux_rer by fastforce

(* completeness of cs_succ w.r.t. rer *)
lemma "cs_rer_succ": "rer ics \<sigma> cs \<Longrightarrow> (cs, \<sigma>) \<in> set (cs_succ ics)"
  unfolding cs_succ_def
  apply (induction rule: rer.induct)
  subgoal for c \<sigma> cs cs' cs''
    using cs_rer_succ_aux[of c \<sigma> cs "[]" cs' cs'']
    by simp
  done

(* needed for termination proof of search *)
lemma "cs_succ_rer_any": "(cs, \<sigma>) \<in> set (cs_succ ics) \<Longrightarrow> rer_any cs ics"
  using cs_succ_rer rer_any.intros
  by blast

(* 9. (b) *)

(* map a list until an element is mapped to Some _ and return it *)
fun "fold_option" :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b option" where
  "fold_option f [] = None"
| "fold_option f (a # as) = (case f a of Some b \<Rightarrow> Some b | None \<Rightarrow> fold_option f as)"

lemma "fold_option_exists":
  assumes "fold_option f as = Some b"
  shows "\<exists>a \<in> set as. f a = Some b"
  using assms
  apply (induction as)
   apply simp_all
  by (metis option.case_eq_if option.collapse)

lemma "exists_fold_option":
  assumes "\<exists>a \<in> set as. \<not>Option.is_none (f a)"
  shows "\<not>Option.is_none (fold_option f as)"
  using assms
  apply (induction as)
   apply simp_all
  by (simp add: Option.is_none_def option.case_eq_if)

lemma "fold_option_cong": "xs = ys \<Longrightarrow> (\<And>a. a \<in> set xs \<Longrightarrow> f a = f' a) \<Longrightarrow> fold_option f xs = fold_option f' ys"
proof (induction xs arbitrary: ys)
  case (Cons a as)
  then obtain a' as' where "ys = a' # as'"
    by blast
  then show ?case
    by (metis Cons.IH Cons.prems(1) Cons.prems(2) fold_option.simps(2) list.set_intros(1) list.set_intros(2))
qed simp

context notes fold_option_cong[fundef_cong] begin
(* main search function *)
function search :: "constraint_system \<Rightarrow> (constraint_system \<times> m_subst) option" where
  "search ics = (if cs_simple ics then Some (ics, Var)
                 else fold_option id (map (\<lambda>(cs, \<sigma>). case search cs of Some (cs', \<sigma>') \<Rightarrow> Some (cs', m_scomp \<sigma>' \<sigma>) | None \<Rightarrow> None) (cs_succ ics)))"
  by pat_completeness auto
termination
  apply (relation "{(x, y). rer_any x y}")
  using rer_any_wf wfP_def apply blast
  using cs_succ_rer_any by auto
end

lemma "fold_option_map": "fold_option id (map f xs) = fold_option f xs"
  apply (induction xs)
   apply simp
  by (metis fold_option.simps(2) id_apply list.simps(9))

(* define fast search code equation for search *)
lemmas search_code[code] = search.simps[unfolded fold_option_map]
(* slow search function *)
definition "search_slow = search"
lemmas search_slow_code[code] = search.simps[folded search_slow_def]

(* 9. (c) *)

(* Key transport protocol *)
definition ktp :: "constraint_system" where
  "ktp = [[Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Pair (Var ''A0'') (Var ''B0''),
               [Public_key_encrypt (Pair (Cons ''k0'') (Signature (Cons ''k0'') (Var ''A0''))) (Var ''B0''), Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Public_key_encrypt (Pair (Var ''K1'') (Signature (Var ''K1'') (Cons ''a''))) (Cons ''b''),
               [Sym_encrypt (Cons ''m1'') (Var ''K1''), Public_key_encrypt (Pair (Cons ''k0'') (Signature (Cons ''k0'') (Var ''A0''))) (Var ''B0''), Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Sym_encrypt (Var ''Z0'') (Cons ''k0''),
               [Sym_encrypt (Cons ''m1'') (Var ''K1''), Public_key_encrypt (Pair (Cons ''k0'') (Signature (Cons ''k0'') (Var ''A0''))) (Var ''B0''), Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Pair (Var ''K1'') (Cons ''m1'')]"
definition ktp_vars :: "string list" where
  "ktp_vars = [''A0'', ''B0'', ''K1'', ''Z0'']"

(* Needham-Schroeder Public-Key protocol *)
definition nspk :: "constraint_system" where
  "nspk = [[Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Pair (Var ''A0'') (Var ''B0''),
               [Public_key_encrypt (Pair (Cons ''na0'') (Var ''A0'')) (Var ''B0''), Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Public_key_encrypt (Pair (Var ''NA1'') (Cons ''a'')) (Cons ''b''),
               [Public_key_encrypt (Pair (Var ''NA1'') (Cons ''nb1'')) (Cons ''a''), Public_key_encrypt (Pair (Cons ''na0'') (Var ''A0'')) (Var ''B0''), Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Public_key_encrypt (Pair (Cons ''na0'') (Var ''NB0'')) (Var ''A0''),
               [Public_key_encrypt (Var ''NB0'') (Var ''B0''), Public_key_encrypt (Pair (Var ''NA1'') (Cons ''nb1'')) (Cons ''a''), Public_key_encrypt (Pair (Cons ''na0'') (Var ''A0'')) (Var ''B0''), Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Public_key_encrypt (Cons ''nb1'') (Cons ''b''),
               [Public_key_encrypt (Var ''NB0'') (Var ''B0''), Public_key_encrypt (Pair (Var ''NA1'') (Cons ''nb1'')) (Cons ''a''), Public_key_encrypt (Pair (Cons ''na0'') (Var ''A0'')) (Var ''B0''), Cons ''a'', Cons ''b'', intruder] | [] \<triangleright> Pair (Var ''NA1'') (Cons ''nb1'')]"
definition nspk_vars :: "string list" where
  "nspk_vars = [''A0'', ''B0'', ''NA1'', ''NB0'']"

(* pretty-print functions for exporting the code *)
definition print_list :: "('a \<Rightarrow> string) \<Rightarrow> 'a list \<Rightarrow> string" where
  "print_list f M = ''['' @ foldl (\<lambda>out m. out @ (if out = [] then [] else '', '')  @ f m) [] M @ '']''"

fun print_msg :: "msg \<Rightarrow> string" where
  "print_msg (Cons s) = ''(Cons '' @ s @ '')''"
| "print_msg (Var s) = ''(Var '' @ s @ '')''"
| "print_msg (Hash m) = ''(Hash '' @ print_msg m @ '')''"
| "print_msg (Pair u v) = ''(Pair '' @ print_msg u @ '' '' @ print_msg v @ '')''"
| "print_msg (Sym_encrypt m k) = ''(Sym_encrypt '' @ print_msg m @ '' '' @ print_msg k @ '')''"
| "print_msg (Public_key_encrypt m k) = ''(Public_key_encrypt '' @ print_msg m @ '' '' @ print_msg k @ '')''"
| "print_msg (Signature m k) = ''(Signature '' @ print_msg m @ '' '' @ print_msg k @ '')''"

fun print_c :: "constraint \<Rightarrow> string" where
  "print_c (M | A \<triangleright> t) = ''('' @ print_list print_msg M @ '' | '' @ print_list print_msg A @ '' --> '' @ print_msg t @ '')''"

fun print_search_result :: "(constraint list \<times> (char list \<times> msg) list) option \<Rightarrow> string" where
  "print_search_result None = ''No solution.''"
| "print_search_result (Some (cs, \<sigma>)) = ''Simple constraints: '' @ print_list print_c cs @ ''; Substitutions: '' @ print_list (\<lambda>(s, m). ''('' @ s @ '' --> '' @ print_msg m @ '')'') \<sigma>"

definition print_search :: "string list \<Rightarrow> constraint_system \<Rightarrow> String.literal" where
  "print_search ns cs = String.implode (print_search_result (map_option (\<lambda>(cs, \<sigma>). (cs, map (\<lambda>v. (v, \<sigma> v)) ns)) (search cs)))"

definition print_search_slow :: "string list \<Rightarrow> constraint_system \<Rightarrow> String.literal" where
  "print_search_slow ns cs = String.implode (print_search_result (map_option (\<lambda>(cs, \<sigma>). (cs, map (\<lambda>v. (v, \<sigma> v)) ns)) (search_slow cs)))"

definition "print_search_KTP = print_search ktp_vars ktp"
definition "print_search_slow_KTP = print_search_slow ktp_vars ktp"

definition "print_search_NSPK = print_search nspk_vars nspk"
definition "print_search_slow_NSPK = print_search_slow nspk_vars nspk"

value "print_search_KTP"
(* value "print_search_slow_KTP" *)

value "print_search_NSPK"
(* value "print_search_slow_NSPK" *)

export_code print_search_KTP print_search_slow_KTP print_search_NSPK print_search_slow_NSPK in Haskell module_name Search file "./ghc"
export_code print_search print_search_slow ktp_vars ktp nspk_vars nspk in SML module_name Search file "./sml/Search.sml"

(* 10. (a) *)

(* soundness of search *)
lemma "search_sound":
  assumes "search ics = Some (cs', \<sigma>'')"
  shows "rer_star ics \<sigma>'' cs' \<and> cs_simple cs'"
  using assms
  apply (induction arbitrary: cs' \<sigma>'' rule: search.induct)
  subgoal premises prems for ics cs' \<sigma>''
    using prems
    proof (cases "cs_simple ics")
      case False
      then have "search ics = fold_option (\<lambda>(cs, \<sigma>). case search cs of Some (cs', \<sigma>') \<Rightarrow> Some (cs', m_scomp \<sigma>' \<sigma>) | None \<Rightarrow> None) (cs_succ ics)"
        by (simp add: fold_option_map)
      then have "fold_option (\<lambda>(cs, \<sigma>). case search cs of Some (cs', \<sigma>') \<Rightarrow> Some (cs', m_scomp \<sigma>' \<sigma>) | None \<Rightarrow> None) (cs_succ ics) = Some (cs', \<sigma>'')"
        using prems(2)
        by simp
      then obtain cs \<sigma> where $: "(cs, \<sigma>) \<in> set (cs_succ ics)" and "(case search cs of Some (cs', \<sigma>') \<Rightarrow> Some (cs', m_scomp \<sigma>' \<sigma>) | None \<Rightarrow> None) = Some (cs', \<sigma>'')"
        using fold_option_exists[of "(\<lambda>(cs, \<sigma>). case search cs of Some (cs', \<sigma>') \<Rightarrow> Some (cs', m_scomp \<sigma>' \<sigma>) | None \<Rightarrow> None)" "(cs_succ ics)" "(cs', \<sigma>'')"]
        by auto
      then obtain \<sigma>' where "search cs = Some (cs', \<sigma>')" and "m_scomp_sigma": "\<sigma>'' = m_scomp \<sigma>' \<sigma>"
        by (cases "search cs") auto
      then have "sub": "cs_simple cs' \<and> rer_star cs \<sigma>' cs'"
        using prems(1) False $
        by blast
      have "rer ics \<sigma> cs"
        using $
        by (simp add: cs_succ_rer)
      then show ?thesis
        using m_scomp_sigma sub Trans
        by blast
    qed (simp add: Refl)
  done

(* 10. (b) *)

(* completeness of search w.r.t. rer_star *)
lemma "search_complete":
  assumes "rer_star ics \<sigma>'' cs'" and "cs_simple cs'"
  shows "\<exists>x. search ics = Some x"
  using assms
  apply (induction rule: rer_star.induct)
   apply simp
  subgoal premises prems for ics \<sigma> cs \<sigma>' cs'
    using prems
    proof (cases "cs_simple ics")
      case False
      have $: "(cs, \<sigma>) \<in> set (cs_succ ics)"
        using prems(1)
        by (simp add: cs_rer_succ)
      obtain css' \<sigma>s' where "search cs = Some (css', \<sigma>s')"
        using prems
        by auto
      then have "\<exists>x \<in> set (cs_succ ics). \<not>Option.is_none ((\<lambda>(cs, \<sigma>). case search cs of Some (cs', \<sigma>') \<Rightarrow> Some (cs', m_scomp \<sigma>' \<sigma>) | None \<Rightarrow> None) x)"
        using $
        by force
      then have "\<exists>z. z \<noteq> None \<and> search ics = z"
        using False exists_fold_option[of "(cs_succ ics)" "(\<lambda>(cs, \<sigma>). case search cs of Some (cs', \<sigma>') \<Rightarrow> Some (cs', m_scomp \<sigma>' \<sigma>) | None \<Rightarrow> None)"]
        by (simp add: Option.is_none_def fold_option_map)
      then show ?thesis
        by blast
    qed simp
  done

end


(*  Title:      HOL/Auth/flash_data_cub.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The flash_data_cub Protocol Case Study*}

theory flash_data_cub imports flash_data_cub_lemma_invs_on_rules flash_data_cub_on_inis
begin
lemma main:
assumes a1: "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
and a2: "0 < N"
shows "\<forall> f. f \<in> (invariants N) --> formEval f s"
proof (rule consistentLemma)
show "consistent (invariants N) {andList (allInitSpecs N)} (rules N)"
proof (cut_tac a1, unfold consistent_def, rule conjI)
show "\<forall> f ini s. f \<in> (invariants N) --> ini \<in> {andList (allInitSpecs N)} --> formEval ini s --> formEval f s"
proof ((rule allI)+, (rule impI)+)
  fix f ini s
  assume b1: "f \<in> (invariants N)" and b2: "ini \<in> {andList (allInitSpecs N)}" and b3: "formEval ini s"
  have b4: "formEval (andList (allInitSpecs N)) s"
  apply (cut_tac b2 b3, simp) done
  show "formEval f s"
  apply (rule on_inis, cut_tac b1, assumption, cut_tac b2, assumption, cut_tac b3, assumption) done
qed
next show "\<forall> f r s. f \<in> invariants N --> r \<in> rules N --> invHoldForRule s f r (invariants N)"
proof ((rule allI)+, (rule impI)+)
  fix f r s
  assume b1: "f \<in> invariants N" and b2: "r \<in> rules N"
  show "invHoldForRule s f r (invariants N)"
  apply (rule invs_on_rules, cut_tac b1, assumption, cut_tac b2, assumption) done
qed
qed
next show "s \<in> reachableSet {andList (allInitSpecs N)} (rules N)"
  apply (metis a1) done
qed
end


section \<open> External Choice \<close>

theory utp_sfrd_extchoice
  imports
    utp_sfrd_healths
    utp_sfrd_rel
begin

subsection \<open> Definitions and syntax \<close>

definition EXTCHOICE :: "'a set \<Rightarrow> ('a \<Rightarrow> ('\<sigma>, '\<phi>) action) \<Rightarrow> ('\<sigma>, '\<phi>) action" where
ExtChoice_def [upred_defs]: "EXTCHOICE A F = \<^bold>R\<^sub>s((\<Squnion> P\<in>A \<bullet> pre\<^sub>R(F P)) \<turnstile> ((\<Squnion> P\<in>A \<bullet> cmt\<^sub>R(F P)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter> P\<in>A \<bullet> cmt\<^sub>R(F P))))"

abbreviation ExtChoice :: "('\<sigma>, '\<phi>) action set \<Rightarrow> ('\<sigma>, '\<phi>) action" where
"ExtChoice A \<equiv> EXTCHOICE A id"

syntax
  "_ExtChoice" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<box> _\<in>_ \<bullet>/ _)" [0, 0, 10] 10)
  "_ExtChoice_simp" :: "pttrn \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<box> _ \<bullet>/ _)" [0, 10] 10)

translations
  "\<box>P\<in>A \<bullet> B"   \<rightleftharpoons> "CONST EXTCHOICE A (\<lambda>P. B)"
  "\<box>P \<bullet> B"     \<rightleftharpoons> "CONST EXTCHOICE (CONST UNIV) (\<lambda>P. B)"

definition extChoice ::
  "('\<sigma>, '\<phi>) action \<Rightarrow> ('\<sigma>, '\<phi>) action \<Rightarrow> ('\<sigma>, '\<phi>) action" (infixl "\<box>" 59) where
[upred_defs]: "P \<box> Q \<equiv> ExtChoice {P, Q}"

text \<open> Small external choice as an indexed big external choice. \<close>

lemma extChoice_alt_def:
  "P \<box> Q = (\<box>i::nat\<in>{0,1} \<bullet> P \<triangleleft> \<guillemotleft>i = 0\<guillemotright> \<triangleright> Q)"
  by (simp add: extChoice_def ExtChoice_def)

subsection \<open> Basic laws \<close>

subsection \<open> Algebraic laws \<close>

lemma ExtChoice_empty: "EXTCHOICE {} F = Stop"
  by (simp add: ExtChoice_def cond_def Stop_def)

lemma ExtChoice_single:
  "P is CSP \<Longrightarrow> ExtChoice {P} = P"
  by (simp add: ExtChoice_def usup_and uinf_or SRD_reactive_design_alt)

subsection \<open> Reactive design calculations \<close>

lemma ExtChoice_rdes:
  assumes "\<And> i. $ok\<acute> \<sharp> P(i)" "A \<noteq> {}"
  shows "(\<box>i\<in>A \<bullet> \<^bold>R\<^sub>s(P(i) \<turnstile> Q(i))) = \<^bold>R\<^sub>s((\<Squnion>i\<in>A \<bullet> P(i)) \<turnstile> ((\<Squnion>i\<in>A \<bullet> Q(i)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> Q(i))))"
proof -
  have "(\<box>i\<in>A \<bullet> \<^bold>R\<^sub>s(P(i) \<turnstile> Q(i))) =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> pre\<^sub>R (\<^bold>R\<^sub>s (P i \<turnstile> Q i))) \<turnstile>
            ((\<Squnion>i\<in>A \<bullet> cmt\<^sub>R (\<^bold>R\<^sub>s (P i \<turnstile> Q i)))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
             (\<Sqinter>i\<in>A \<bullet> cmt\<^sub>R (\<^bold>R\<^sub>s (P i \<turnstile> Q i)))))"
    by (simp add: ExtChoice_def)
  also have "... =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> R1 (R2c (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            ((\<Squnion>i\<in>A \<bullet> R1(R2c(cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i)))))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
             (\<Sqinter>i\<in>A \<bullet> R1(R2c(cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i)))))))"
    by (simp add: rea_pre_RHS_design rea_cmt_RHS_design)
  also have "... =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> R1 (R2c (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            R1(R2c
            ((\<Squnion>i\<in>A \<bullet> R1(R2c(cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i)))))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
             (\<Sqinter>i\<in>A \<bullet> R1(R2c(cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i))))))))"
    by (metis (no_types, lifting) RHS_design_export_R1 RHS_design_export_R2c)
  also have "... =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> R1 (R2c (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            R1(R2c
            ((\<Squnion>i\<in>A \<bullet> (cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i))))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
             (\<Sqinter>i\<in>A \<bullet> (cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i)))))))"
    by (simp add: R2c_UINF R2c_condr R1_cond R1_idem R1_R2c_commute R2c_idem R1_UINF assms R1_USUP R2c_USUP)
  also have "... =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> R1 (R2c (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            cmt\<^sub>s \<dagger>
            ((\<Squnion>i\<in>A \<bullet> (cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i))))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
             (\<Sqinter>i\<in>A \<bullet> (cmt\<^sub>s \<dagger> (P(i) \<Rightarrow> Q(i))))))"
    by (metis (no_types, lifting) RHS_design_export_R1 RHS_design_export_R2c rdes_export_cmt)
  also have "... =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> R1 (R2c (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            cmt\<^sub>s \<dagger>
            ((\<Squnion>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
             (\<Sqinter>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))))"
    by (simp add: usubst)
  also have "... =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> R1 (R2c (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            ((\<Squnion>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i))) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))))"
    by (simp add: rdes_export_cmt)
  also have "... =
        \<^bold>R\<^sub>s ((R1(R2c(\<Squnion>i\<in>A \<bullet> (pre\<^sub>s \<dagger> P(i))))) \<turnstile>
            ((\<Squnion>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i))) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))))"
    by (simp add: not_UINF R1_UINF R2c_UINF assms)
  also have "... =
        \<^bold>R\<^sub>s ((R2c(\<Squnion>i\<in>A \<bullet> (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            ((\<Squnion>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i))) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))))"
    by (simp add: R1_design_R1_pre)
  also have "... =
        \<^bold>R\<^sub>s (((\<Squnion>i\<in>A \<bullet> (pre\<^sub>s \<dagger> P(i)))) \<turnstile>
            ((\<Squnion>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i))) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))))"
    by (metis (no_types, lifting) RHS_design_R2c_pre)
  also have "... =
        \<^bold>R\<^sub>s (([$ok \<mapsto>\<^sub>s true, $wait \<mapsto>\<^sub>s false] \<dagger> (\<Squnion>i\<in>A \<bullet> P(i))) \<turnstile>
            ((\<Squnion>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i))) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))))"
  proof -
    from assms have "\<And> i. pre\<^sub>s \<dagger> P(i) = [$ok \<mapsto>\<^sub>s true, $wait \<mapsto>\<^sub>s false] \<dagger> P(i)"
      by (rel_auto)
    thus ?thesis
      by (simp add: usubst)
  qed
  also have "... =
        \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> P(i)) \<turnstile> ((\<Squnion>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i))) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> (P(i) \<Rightarrow> Q(i)))))"
    by (simp add: rdes_export_pre not_UINF)
  also have "... = \<^bold>R\<^sub>s ((\<Squnion>i\<in>A \<bullet> P(i)) \<turnstile> ((\<Squnion>i\<in>A \<bullet> Q(i)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter>i\<in>A \<bullet> Q(i))))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto, blast+)

  finally show ?thesis .
qed

lemma ExtChoice_tri_rdes:
  assumes "\<And> i . $ok\<acute> \<sharp> P\<^sub>1(i)" "A \<noteq> {}"
  shows "(\<box> i\<in>A \<bullet> \<^bold>R\<^sub>s(P\<^sub>1(i) \<turnstile> P\<^sub>2(i) \<diamondop> P\<^sub>3(i))) =
         \<^bold>R\<^sub>s ((\<Squnion> i\<in>A \<bullet> P\<^sub>1(i)) \<turnstile> (((\<Squnion> i\<in>A \<bullet> P\<^sub>2(i)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> i\<in>A \<bullet> P\<^sub>2(i))) \<diamondop> (\<Sqinter> i\<in>A \<bullet> P\<^sub>3(i))))"
proof -
  have "(\<box> i\<in>A \<bullet> \<^bold>R\<^sub>s(P\<^sub>1(i) \<turnstile> P\<^sub>2(i) \<diamondop> P\<^sub>3(i))) =
         \<^bold>R\<^sub>s ((\<Squnion> i\<in>A \<bullet> P\<^sub>1(i)) \<turnstile> ((\<Squnion> i\<in>A \<bullet> P\<^sub>2(i) \<diamondop> P\<^sub>3(i)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter> i\<in>A \<bullet> P\<^sub>2(i) \<diamondop> P\<^sub>3(i))))"
    by (simp add: ExtChoice_rdes assms)
  also
  have "... =
         \<^bold>R\<^sub>s ((\<Squnion> i\<in>A \<bullet> P\<^sub>1(i)) \<turnstile> ((\<Squnion> i\<in>A \<bullet> P\<^sub>2(i) \<diamondop> P\<^sub>3(i)) \<triangleleft> $wait\<acute> \<and> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> i\<in>A \<bullet> P\<^sub>2(i) \<diamondop> P\<^sub>3(i))))"
    by (simp add: conj_comm)
  also
  have "... =
         \<^bold>R\<^sub>s ((\<Squnion> i\<in>A \<bullet> P\<^sub>1(i)) \<turnstile> (((\<Squnion> i\<in>A \<bullet> P\<^sub>2(i) \<diamondop> P\<^sub>3(i)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> i\<in>A \<bullet> P\<^sub>2(i) \<diamondop> P\<^sub>3(i))) \<diamondop> (\<Sqinter> i\<in>A \<bullet> P\<^sub>2(i) \<diamondop> P\<^sub>3(i))))"
    by (simp add: cond_conj wait'_cond_def)
  also
  have "... = \<^bold>R\<^sub>s ((\<Squnion> i\<in>A \<bullet> P\<^sub>1(i)) \<turnstile> (((\<Squnion> i\<in>A \<bullet> P\<^sub>2(i)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> i\<in>A \<bullet> P\<^sub>2(i))) \<diamondop> (\<Sqinter> i\<in>A \<bullet> P\<^sub>3(i))))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  finally show ?thesis .
qed

lemma ExtChoice_tri_rdes' [rdes_def]:
  assumes "\<And> i . $ok\<acute> \<sharp> P\<^sub>1(i)" "A \<noteq> {}"
  shows "(\<box> i\<in>A \<bullet> \<^bold>R\<^sub>s(P\<^sub>1(i) \<turnstile> P\<^sub>2(i) \<diamondop> P\<^sub>3(i))) =
         \<^bold>R\<^sub>s ((\<Squnion> i\<in>A \<bullet> P\<^sub>1(i)) \<turnstile> (((\<Squnion> i\<in>A \<bullet> R5(P\<^sub>2(i))) \<or> (\<Sqinter> i\<in>A \<bullet> R4(P\<^sub>2(i)))) \<diamondop> (\<Sqinter> i\<in>A \<bullet> P\<^sub>3(i))))"
  by (simp add: ExtChoice_tri_rdes assms, rel_auto, simp_all add: less_le assms)

lemma ExtChoice_tri_rdes_def:
  assumes "\<And> i. i\<in>A \<Longrightarrow> F i is CSP"
  shows "(\<box> i\<in>A \<bullet> F i) = \<^bold>R\<^sub>s ((\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P)) \<turnstile> (((\<Squnion> P\<in>A \<bullet> peri\<^sub>R (F P)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> P\<in>A \<bullet> peri\<^sub>R (F P))) \<diamondop> (\<Sqinter> P\<in>A \<bullet> post\<^sub>R (F P))))"
proof -
  have "((\<Squnion> P\<in>A \<bullet> cmt\<^sub>R (F P)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (\<Sqinter> P\<in>A \<bullet> cmt\<^sub>R (F P))) =
        (((\<Squnion> P\<in>A \<bullet> cmt\<^sub>R (F P)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> P\<in>A \<bullet> cmt\<^sub>R (F P))) \<diamondop> (\<Sqinter> P\<in>A \<bullet> cmt\<^sub>R (F P)))"
    by (rel_auto)
  also have "... = (((\<Squnion> P\<in>A \<bullet> peri\<^sub>R (F P)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (\<Sqinter> P\<in>A \<bullet> peri\<^sub>R (F P))) \<diamondop> (\<Sqinter> P\<in>A \<bullet> post\<^sub>R (F P)))"
    by (rel_auto)
  finally show ?thesis
    by (simp add: ExtChoice_def)
qed

lemma extChoice_rdes:
  assumes "$ok\<acute> \<sharp> P\<^sub>1" "$ok\<acute> \<sharp> Q\<^sub>1"
  shows "\<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> P\<^sub>2) \<box> \<^bold>R\<^sub>s(Q\<^sub>1 \<turnstile> Q\<^sub>2) = \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> ((P\<^sub>2 \<and> Q\<^sub>2) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (P\<^sub>2 \<or> Q\<^sub>2)))"
proof -
  have "(\<box>i::nat\<in>{0, 1} \<bullet> \<^bold>R\<^sub>s (P\<^sub>1 \<turnstile> P\<^sub>2) \<triangleleft> \<guillemotleft>i = 0\<guillemotright> \<triangleright> \<^bold>R\<^sub>s (Q\<^sub>1 \<turnstile> Q\<^sub>2)) = (\<box>i::nat\<in>{0, 1} \<bullet> \<^bold>R\<^sub>s ((P\<^sub>1 \<turnstile> P\<^sub>2) \<triangleleft> \<guillemotleft>i = 0\<guillemotright> \<triangleright> (Q\<^sub>1 \<turnstile> Q\<^sub>2)))"
    by (simp only: RHS_cond R2c_lit)
  also have "... = (\<box>i::nat\<in>{0, 1} \<bullet> \<^bold>R\<^sub>s ((P\<^sub>1 \<triangleleft> \<guillemotleft>i = 0\<guillemotright> \<triangleright> Q\<^sub>1) \<turnstile> (P\<^sub>2 \<triangleleft> \<guillemotleft>i = 0\<guillemotright> \<triangleright> Q\<^sub>2)))"
    by (simp add: design_condr)
  also have "... = \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> ((P\<^sub>2 \<and> Q\<^sub>2) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (P\<^sub>2 \<or> Q\<^sub>2)))"
    by (subst ExtChoice_rdes, simp_all add: assms unrest uinf_or usup_and)
  finally show ?thesis by (simp add: extChoice_alt_def)
qed

lemma extChoice_tri_rdes:
  assumes "$ok\<acute> \<sharp> P\<^sub>1" "$ok\<acute> \<sharp> Q\<^sub>1"
  shows "\<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) \<box> \<^bold>R\<^sub>s(Q\<^sub>1 \<turnstile> Q\<^sub>2 \<diamondop> Q\<^sub>3) =
         \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> (((P\<^sub>2 \<and> Q\<^sub>2) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (P\<^sub>2 \<or> Q\<^sub>2)) \<diamondop> (P\<^sub>3 \<or> Q\<^sub>3)))"
proof -
  have "\<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) \<box> \<^bold>R\<^sub>s(Q\<^sub>1 \<turnstile> Q\<^sub>2 \<diamondop> Q\<^sub>3) =
        \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> ((P\<^sub>2 \<diamondop> P\<^sub>3 \<and> Q\<^sub>2 \<diamondop> Q\<^sub>3) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (P\<^sub>2 \<diamondop> P\<^sub>3 \<or> Q\<^sub>2 \<diamondop> Q\<^sub>3)))"
    by (simp add: extChoice_rdes assms)
  also
  have "... = \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> ((P\<^sub>2 \<diamondop> P\<^sub>3 \<and> Q\<^sub>2 \<diamondop> Q\<^sub>3) \<triangleleft> $wait\<acute> \<and> $tr\<acute> =\<^sub>u $tr \<triangleright> (P\<^sub>2 \<diamondop> P\<^sub>3 \<or> Q\<^sub>2 \<diamondop> Q\<^sub>3)))"
    by (simp add: conj_comm)
  also
  have "... = \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile>
               (((P\<^sub>2 \<diamondop> P\<^sub>3 \<and> Q\<^sub>2 \<diamondop> Q\<^sub>3) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (P\<^sub>2 \<diamondop> P\<^sub>3 \<or> Q\<^sub>2 \<diamondop> Q\<^sub>3)) \<diamondop> (P\<^sub>2 \<diamondop> P\<^sub>3 \<or> Q\<^sub>2 \<diamondop> Q\<^sub>3)))"
    by (simp add: cond_conj wait'_cond_def)
  also
  have "... = \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> (((P\<^sub>2 \<and> Q\<^sub>2) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (P\<^sub>2 \<or> Q\<^sub>2)) \<diamondop> (P\<^sub>3 \<or> Q\<^sub>3)))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  finally show ?thesis .
qed

lemma extChoice_rdes_def:
  assumes "P\<^sub>1 is RR" "Q\<^sub>1 is RR"
  shows "\<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) \<box> \<^bold>R\<^sub>s(Q\<^sub>1 \<turnstile> Q\<^sub>2 \<diamondop> Q\<^sub>3) =
         \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> (((P\<^sub>2 \<and> Q\<^sub>2) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (P\<^sub>2 \<or> Q\<^sub>2)) \<diamondop> (P\<^sub>3 \<or> Q\<^sub>3)))"
  by (subst extChoice_tri_rdes, simp_all add: assms unrest)

lemma extChoice_rdes_def' [rdes_def]:
  assumes "P\<^sub>1 is RR" "Q\<^sub>1 is RR"
  shows "\<^bold>R\<^sub>s(P\<^sub>1 \<turnstile> P\<^sub>2 \<diamondop> P\<^sub>3) \<box> \<^bold>R\<^sub>s(Q\<^sub>1 \<turnstile> Q\<^sub>2 \<diamondop> Q\<^sub>3) =
         \<^bold>R\<^sub>s ((P\<^sub>1 \<and> Q\<^sub>1) \<turnstile> ((R5(P\<^sub>2 \<and> Q\<^sub>2) \<or> R4(P\<^sub>2 \<or> Q\<^sub>2)) \<diamondop> (P\<^sub>3 \<or> Q\<^sub>3)))"
  by (simp add: extChoice_rdes_def assms, rel_auto, simp_all add: less_le)

lemma CSP_ExtChoice [closure]:
  "EXTCHOICE A F is CSP"
  by (simp add: ExtChoice_def RHS_design_is_SRD unrest)

lemma CSP_extChoice [closure]:
  "P \<box> Q is CSP"
  by (simp add: CSP_ExtChoice extChoice_def)

lemma preR_EXTCHOICE [rdes]:
  assumes "A \<noteq> {}" "\<And> i. i\<in>A \<Longrightarrow> F i is NCSP"
  shows "pre\<^sub>R(EXTCHOICE A F) = (\<Squnion> P\<in>A \<bullet> pre\<^sub>R(F P))"
  by (simp add: ExtChoice_tri_rdes_def closure rdes assms)

lemma preR_ExtChoice:
  assumes "A \<noteq> {}" "\<forall> P\<in>A. P is NCSP"
  shows "pre\<^sub>R(ExtChoice A) = (\<Squnion> P\<in>A \<bullet> pre\<^sub>R(P))"
  using assms by (auto simp add: preR_EXTCHOICE)

lemma periR_ExtChoice [rdes]:
  assumes "A \<noteq> {}" "\<And> i. i\<in>A \<Longrightarrow> F i is NCSP"
  shows "peri\<^sub>R(EXTCHOICE A F) = (((\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r (\<Squnion> P\<in>A \<bullet> peri\<^sub>R (F P))) \<triangleleft> \<^U>($tr\<acute> = $tr) \<triangleright> (\<Sqinter> P\<in>A \<bullet> peri\<^sub>R (F P)))"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = ((\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r (\<Squnion> P\<in>A \<bullet> peri\<^sub>R (F P)) \<triangleleft> \<^U>($tr\<acute> = $tr) \<triangleright> (\<Sqinter> P\<in>A \<bullet> peri\<^sub>R (F P)))"
    by (simp add: ExtChoice_tri_rdes_def closure rdes assms)
  also have "... = ((\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r (\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P) \<Rightarrow>\<^sub>r peri\<^sub>R (F P)) \<triangleleft> \<^U>($tr\<acute> = $tr) \<triangleright> (\<Sqinter> P\<in>A \<bullet> pre\<^sub>R (F P) \<Rightarrow>\<^sub>r peri\<^sub>R (F P)))"
    by (simp add: NSRD_peri_under_pre assms closure cong: UINF_cong USUP_cong)
  also have "... = ((\<Squnion> P\<in>A \<bullet> RR(pre\<^sub>R (F P))) \<Rightarrow>\<^sub>r (\<Squnion> P\<in>A \<bullet> RR(pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r RR(peri\<^sub>R (F P))) \<triangleleft> \<^U>($tr\<acute> = $tr) \<triangleright> (\<Sqinter> P\<in>A \<bullet> RR(pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r RR(peri\<^sub>R (F P))))"
    by (simp add: Healthy_if assms closure cong: UINF_cong USUP_cong)
  also from assms(1) have "... = ((\<Squnion> P\<in>A \<bullet> RR(pre\<^sub>R (F P))) \<Rightarrow>\<^sub>r (\<Squnion> P\<in>A \<bullet> RR(pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r RR(peri\<^sub>R (F P)))) \<triangleleft> \<^U>($tr\<acute> = $tr) \<triangleright> ((\<Sqinter> P\<in>A \<bullet> RR(pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r RR(peri\<^sub>R (F P))))"
    by (rel_auto)
  finally show ?thesis
    by (simp add: Healthy_if NSRD_peri_under_pre assms closure cong: UINF_cong USUP_cong)
qed

lemma periR_ExtChoice':
  assumes "A \<noteq> {}" "\<And> i. i\<in>A \<Longrightarrow> F i is NCSP"
  shows "peri\<^sub>R(EXTCHOICE A F) = (R5((\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r (\<Squnion> P\<in>A \<bullet> peri\<^sub>R (F P))) \<or> R4(\<Sqinter> P\<in>A \<bullet> peri\<^sub>R (F P)))"
  by (simp add: periR_ExtChoice assms, rel_auto)

lemma postR_ExtChoice [rdes]:
  assumes "A \<noteq> {}" "\<And> i. i\<in>A \<Longrightarrow> F i is NCSP"
  shows "post\<^sub>R(EXTCHOICE A F) = (\<Sqinter> P\<in>A \<bullet> post\<^sub>R (F P))"
  (is "?lhs = ?rhs")
proof -
  have "?lhs = ((\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r (\<Sqinter> P\<in>A \<bullet> post\<^sub>R (F P)))"
    by (simp add: ExtChoice_tri_rdes_def closure rdes assms)
  also have "... = ((\<Squnion> P\<in>A \<bullet> pre\<^sub>R (F P)) \<Rightarrow>\<^sub>r (\<Sqinter> P\<in>A \<bullet> pre\<^sub>R (F P) \<Rightarrow>\<^sub>r post\<^sub>R (F P)))"
    by (simp add: NSRD_post_under_pre assms closure cong: UINF_cong)
  also have "... = (\<Sqinter> P\<in>A \<bullet> pre\<^sub>R (F P) \<Rightarrow>\<^sub>r post\<^sub>R (F P))"
    by (rel_auto)
  finally show ?thesis
    by (simp add: NSRD_post_under_pre assms closure cong: UINF_cong)
qed

lemma preR_extChoice' [rdes]:
  assumes "P is NCSP" "Q is NCSP"
  shows "pre\<^sub>R(P \<box> Q) = (pre\<^sub>R(P) \<and> pre\<^sub>R(Q))"
  by (simp add: extChoice_def preR_ExtChoice assms closure usup_and)

lemma periR_extChoice [rdes]:
  assumes "P is NCSP" "Q is NCSP"
  shows "peri\<^sub>R(P \<box> Q) = ((pre\<^sub>R(P) \<and> pre\<^sub>R(Q) \<Rightarrow>\<^sub>r peri\<^sub>R(P) \<and> peri\<^sub>R(Q)) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<triangleright> (peri\<^sub>R(P) \<or> peri\<^sub>R(Q)))"
  using assms
  by (simp add: extChoice_def, subst periR_ExtChoice, auto simp add: usup_and uinf_or)

lemma postR_extChoice [rdes]:
  assumes "P is NCSP" "Q is NCSP"
  shows "post\<^sub>R(P \<box> Q) = (post\<^sub>R(P) \<or> post\<^sub>R(Q))"
  using assms
  by (simp add: extChoice_def, subst postR_ExtChoice, auto simp add: usup_and uinf_or)

lemma ExtChoice_cong:
  assumes "\<And> P. P \<in> A \<Longrightarrow> F(P) = G(P)"
  shows "(\<box> P\<in>A \<bullet> F(P)) = (\<box> P\<in>A \<bullet> G(P))"
  by (simp add: ExtChoice_def assms cong: UINF_cong USUP_cong)

lemma ref_unrest_ExtChoice:
  assumes
    "\<And> P. P \<in> A \<Longrightarrow> $ref \<sharp> pre\<^sub>R(P)"
    "\<And> P. P \<in> A \<Longrightarrow> $ref \<sharp> cmt\<^sub>R(P)"
  shows "$ref \<sharp> (ExtChoice A)\<lbrakk>false/$wait\<rbrakk>"
proof -
  have "\<And> P. P \<in> A \<Longrightarrow> $ref \<sharp> pre\<^sub>R(P\<lbrakk>0/$tr\<rbrakk>)"
    using assms by (rel_blast)
  with assms show ?thesis
    by (simp add: ExtChoice_def RHS_def R1_def R2c_def R2s_def R3h_def design_def usubst unrest)
qed

lemma CSP4_ExtChoice:
  assumes "\<And> i. i\<in>A \<Longrightarrow> F i is NCSP"
  shows "EXTCHOICE A F is CSP4"
proof (cases "A = {}")
  case True thus ?thesis
    by (simp add: ExtChoice_empty Healthy_def CSP4_def, simp add: Skip_is_CSP Stop_left_zero)
next
  case False
  have 1:"(\<not>\<^sub>r (\<not>\<^sub>r pre\<^sub>R (EXTCHOICE A F)) ;;\<^sub>h R1 true) = pre\<^sub>R (EXTCHOICE A F)"
  proof -
    have "\<And> P. P \<in> A \<Longrightarrow> (\<not>\<^sub>r pre\<^sub>R(F P)) ;; R1 true = (\<not>\<^sub>r pre\<^sub>R(F P))"
      by (simp add: NCSP_Healthy_subset_member NCSP_implies_NSRD NSRD_neg_pre_unit assms)
    thus ?thesis
      apply (simp add: False preR_EXTCHOICE closure NCSP_set_unrest_pre_wait' assms not_UINF seq_UINF_distr not_USUP)
      apply (rule USUP_cong)
      apply (simp add: rpred assms closure)
      done
  qed
  have 2: "$st\<acute> \<sharp> peri\<^sub>R (EXTCHOICE A F)"
  proof -
    have a: "\<And> P. P \<in> A \<Longrightarrow> $st\<acute> \<sharp> pre\<^sub>R(F P)"
      by (simp add: NCSP_Healthy_subset_member NCSP_implies_NSRD NSRD_st'_unrest_pre assms)
    have b: "\<And> P. P \<in> A \<Longrightarrow> $st\<acute> \<sharp> peri\<^sub>R(F P)"
      by (simp add: NCSP_Healthy_subset_member NCSP_implies_NSRD NSRD_st'_unrest_peri assms)
    from a b show ?thesis
      apply (subst periR_ExtChoice)
        apply (simp_all add: assms closure unrest CSP4_set_unrest_pre_st' NCSP_set_unrest_pre_wait' False)
      done
  qed
  have 3: "$ref\<acute> \<sharp> post\<^sub>R (EXTCHOICE A F)"
  proof -
    have a: "\<And> P. P \<in> A \<Longrightarrow> $ref\<acute> \<sharp> pre\<^sub>R(F P)"
      by (simp add: CSP4_ref'_unrest_pre assms closure)
    have b: "\<And> P. P \<in> A \<Longrightarrow> $ref\<acute> \<sharp> post\<^sub>R(F P)"
      by (simp add: CSP4_ref'_unrest_post assms closure)
    from a b show ?thesis
      by (subst postR_ExtChoice, simp_all add: assms CSP4_set_unrest_pre_st' NCSP_set_unrest_pre_wait' unrest False)
  qed
  show ?thesis
    by (rule CSP4_tri_intro, simp_all add: 1 2 3 assms closure)
       (metis "1" R1_seqr_closure rea_not_R1 rea_not_not rea_true_R1)
qed

lemma CSP4_extChoice [closure]:
  assumes "P is NCSP" "Q is NCSP"
  shows "P \<box> Q is CSP4"
  by (simp add: extChoice_def, rule CSP4_ExtChoice, auto simp add: assms)

lemma NCSP_ExtChoice [closure]:
  assumes "\<And> i. i\<in>A \<Longrightarrow> F i is NCSP"
  shows "EXTCHOICE A F is NCSP"
proof (cases "A = {}")
  case True
  then show ?thesis by (simp add: ExtChoice_empty closure)
next
  case False
  show ?thesis
  proof (rule NCSP_intro)
    show 1:"EXTCHOICE A F is CSP"
      by (metis (mono_tags) CSP_ExtChoice)
    show "EXTCHOICE A F is CSP3"
      by (rule_tac CSP3_SRD_intro, simp_all add: CSP_Healthy_subset_member CSP3_Healthy_subset_member closure rdes unrest assms 1 False)
    show "EXTCHOICE A F is CSP4"
      by (simp add: CSP4_ExtChoice assms)
  qed
qed

lemma ExtChoice_NCSP_closed [closure]:
  assumes "\<And> i. i \<in> I \<Longrightarrow> P(i) is NCSP"
  shows "(\<box> i\<in>I \<bullet> P(i)) is NCSP"
  by (simp add: NCSP_ExtChoice assms image_subset_iff)

lemma NCSP_extChoice [closure]:
  assumes "P is NCSP" "Q is NCSP"
  shows "P \<box> Q is NCSP"
  unfolding extChoice_def
  by (auto intro: NCSP_ExtChoice simp add: assms)

subsection \<open> Productivity and Guardedness \<close>

lemma Productive_ExtChoice [closure]:
  assumes "\<And> i. i \<in> I \<Longrightarrow> P(i) is NCSP" "\<And> i. i \<in> I \<Longrightarrow> P(i) is Productive"
  shows "EXTCHOICE I P is Productive"
proof (cases "I = {}")
  case True
  then show ?thesis
    by (simp add: ExtChoice_empty Productive_Stop)
next
  case False
  have 1: "\<And> i. i \<in> I \<Longrightarrow> $wait\<acute> \<sharp> pre\<^sub>R(P i)"
    using NCSP_implies_NSRD NSRD_wait'_unrest_pre assms(1) by blast

  show ?thesis
  proof (rule Productive_intro, simp_all add: assms closure rdes unrest 1 False)
    have "((\<Squnion> i\<in>I \<bullet> pre\<^sub>R (P i)) \<and> (\<Sqinter> i\<in>I \<bullet> post\<^sub>R (P i))) =
          ((\<Squnion> i\<in>I \<bullet> pre\<^sub>R (P i)) \<and> (\<Sqinter> i\<in>I \<bullet> (pre\<^sub>R (P i) \<and> post\<^sub>R (P i))))"
      by (rel_auto)
    moreover have "(\<Sqinter> i\<in>I \<bullet> (pre\<^sub>R (P i) \<and> post\<^sub>R (P i))) = (\<Sqinter> i\<in>I \<bullet> ((pre\<^sub>R (P i) \<and> post\<^sub>R (P i)) \<and> $tr <\<^sub>u $tr\<acute>))"
      by (rule UINF_cong, metis (no_types, lifting) "1" NCSP_implies_CSP Productive_post_refines_tr_increase assms utp_pred_laws.inf.absorb1)

    ultimately show "U($tr < $tr\<acute>) \<sqsubseteq> ((\<Squnion> i\<in>I \<bullet> pre\<^sub>R (P i)) \<and> ((\<Sqinter> i\<in>I \<bullet> post\<^sub>R (P i))))"
      by (rel_auto)
  qed
qed

lemma Productive_extChoice [closure]:
  assumes "P is NCSP" "Q is NCSP" "P is Productive" "Q is Productive"
  shows "P \<box> Q is Productive"
  unfolding extChoice_def
  by (auto intro: Productive_ExtChoice simp add: assms)

lemma ExtChoice_Guarded [closure]:
  assumes  "\<And> P. P \<in> A \<Longrightarrow> Guarded P"
  shows "Guarded (\<lambda> X. \<box>P\<in>A \<bullet> P(X))"
proof (rule GuardedI)
  fix X n
  have "\<And> Y. ((\<box>P\<in>A \<bullet> P Y) \<and> gvrt(n+1)) = ((\<box>P\<in>A \<bullet> (P Y \<and> gvrt(n+1))) \<and> gvrt(n+1))"
  proof -
    fix Y
    let ?lhs = "((\<box>P\<in>A \<bullet> P Y) \<and> gvrt(n+1))" and ?rhs = "((\<box>P\<in>A \<bullet> (P Y \<and> gvrt(n+1))) \<and> gvrt(n+1))"
    have a:"?lhs\<lbrakk>false/$ok\<rbrakk> = ?rhs\<lbrakk>false/$ok\<rbrakk>"
      by (rel_auto)
    have b:"?lhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>true/$wait\<rbrakk> = ?rhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>true/$wait\<rbrakk>"
      by (rel_auto)
    have c:"?lhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>false/$wait\<rbrakk> = ?rhs\<lbrakk>true/$ok\<rbrakk>\<lbrakk>false/$wait\<rbrakk>"
      by (simp add: ExtChoice_def RHS_def R1_def R2c_def R2s_def R3h_def design_def usubst unrest, rel_blast)
    show "?lhs = ?rhs"
      using a b c
      by (rule_tac bool_eq_splitI[of "in_var ok"], simp, rule_tac bool_eq_splitI[of "in_var wait"], simp_all)
  qed
  moreover have "((\<box>P\<in>A \<bullet> (P X \<and> gvrt(n+1))) \<and> gvrt(n+1)) =  ((\<box>P\<in>A \<bullet> (P (X \<and> gvrt(n)) \<and> gvrt(n+1))) \<and> gvrt(n+1))"
  proof -
    have "(\<box>P\<in>A \<bullet> (P X \<and> gvrt(n+1))) = (\<box>P\<in>A \<bullet> (P (X \<and> gvrt(n)) \<and> gvrt(n+1)))"
    proof (rule ExtChoice_cong)
      fix P assume "P \<in> A"
      thus "(P X \<and> gvrt(n+1)) = (P (X \<and> gvrt(n)) \<and> gvrt(n+1))"
        using Guarded_def assms by blast
    qed
    thus ?thesis by simp
  qed
  ultimately show "((\<box>P\<in>A \<bullet> P X) \<and> gvrt(n+1)) = ((\<box>P\<in>A \<bullet> (P (X \<and> gvrt(n)))) \<and> gvrt(n+1))"
    by simp
qed

lemma ExtChoice_image: "ExtChoice (P ` A) = EXTCHOICE A P"
  by (rel_auto)

lemma extChoice_Guarded [closure]:
  assumes "Guarded P" "Guarded Q"
  shows "Guarded (\<lambda> X. P(X) \<box> Q(X))"
proof -
  have "Guarded (\<lambda> X. \<box>F\<in>{P,Q} \<bullet> F(X))"
    by (rule ExtChoice_Guarded, auto simp add: assms)
  thus ?thesis
    by (subst (asm) ExtChoice_image[THEN sym], simp add: extChoice_def)
qed

subsection \<open> Algebraic laws \<close>

lemma extChoice_comm:
  "P \<box> Q = Q \<box> P"
  by (unfold extChoice_def, simp add: insert_commute)

lemma extChoice_idem:
  "P is CSP \<Longrightarrow> P \<box> P = P"
  by (unfold extChoice_def, simp add: ExtChoice_single)

lemma extChoice_assoc:
  assumes "P is CSP" "Q is CSP" "R is CSP"
  shows "P \<box> Q \<box> R = P \<box> (Q \<box> R)"
proof -
  have "P \<box> Q \<box> R = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> cmt\<^sub>R(P)) \<box> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> cmt\<^sub>R(Q)) \<box> \<^bold>R\<^sub>s(pre\<^sub>R(R) \<turnstile> cmt\<^sub>R(R))"
    by (simp add: SRD_reactive_design_alt assms(1) assms(2) assms(3))
  also have "... =
    \<^bold>R\<^sub>s (((pre\<^sub>R P \<and> pre\<^sub>R Q) \<and> pre\<^sub>R R) \<turnstile>
          (((cmt\<^sub>R P \<and> cmt\<^sub>R Q) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (cmt\<^sub>R P \<or> cmt\<^sub>R Q) \<and> cmt\<^sub>R R)
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
           ((cmt\<^sub>R P \<and> cmt\<^sub>R Q) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (cmt\<^sub>R P \<or> cmt\<^sub>R Q) \<or> cmt\<^sub>R R)))"
    by (simp add: extChoice_rdes unrest)
  also have "... =
    \<^bold>R\<^sub>s (((pre\<^sub>R P \<and> pre\<^sub>R Q) \<and> pre\<^sub>R R) \<turnstile>
          (((cmt\<^sub>R P \<and> cmt\<^sub>R Q) \<and> cmt\<^sub>R R)
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
            ((cmt\<^sub>R P \<or> cmt\<^sub>R Q) \<or> cmt\<^sub>R R)))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... =
    \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> pre\<^sub>R Q \<and> pre\<^sub>R R) \<turnstile>
          ((cmt\<^sub>R P \<and> (cmt\<^sub>R Q \<and> cmt\<^sub>R R) )
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
           (cmt\<^sub>R P \<or> (cmt\<^sub>R Q \<or> cmt\<^sub>R R))))"
    by (simp add: conj_assoc disj_assoc)
  also have "... =
    \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> pre\<^sub>R Q \<and> pre\<^sub>R R) \<turnstile>
          ((cmt\<^sub>R P \<and> (cmt\<^sub>R Q \<and> cmt\<^sub>R R) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (cmt\<^sub>R Q \<or> cmt\<^sub>R R))
              \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
           (cmt\<^sub>R P \<or> (cmt\<^sub>R Q \<and> cmt\<^sub>R R) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (cmt\<^sub>R Q \<or> cmt\<^sub>R R))))"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> cmt\<^sub>R(P)) \<box> (\<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> cmt\<^sub>R(Q)) \<box> \<^bold>R\<^sub>s(pre\<^sub>R(R) \<turnstile> cmt\<^sub>R(R)))"
    by (simp add: extChoice_rdes unrest)
  also have "... = P \<box> (Q \<box> R)"
    by (simp add: SRD_reactive_design_alt assms(1) assms(2) assms(3))
  finally show ?thesis .
qed

lemma extChoice_Stop:
  assumes "Q is CSP"
  shows "Stop \<box> Q = Q"
  using assms
proof -
  have "Stop \<box> Q = \<^bold>R\<^sub>s (true \<turnstile> ($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>)) \<box> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> cmt\<^sub>R(Q))"
    by (simp add: Stop_def SRD_reactive_design_alt assms)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R Q \<turnstile> ((($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute>) \<and> cmt\<^sub>R Q) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> ($tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<or> cmt\<^sub>R Q)))"
    by (simp add: extChoice_rdes unrest)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R Q \<turnstile> (cmt\<^sub>R Q \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> cmt\<^sub>R Q))"
    by (metis (no_types, lifting) cond_def eq_upred_sym neg_conj_cancel1 utp_pred_laws.inf.left_idem)
  also have "... = \<^bold>R\<^sub>s (pre\<^sub>R Q \<turnstile> cmt\<^sub>R Q)"
    by (simp add: cond_idem)
  also have "... = Q"
    by (simp add: SRD_reactive_design_alt assms)
  finally show ?thesis .
qed

lemma extChoice_Chaos:
  assumes "Q is CSP"
  shows "Chaos \<box> Q = Chaos"
proof -
  have "Chaos \<box> Q = \<^bold>R\<^sub>s (false \<turnstile> true) \<box> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> cmt\<^sub>R(Q))"
    by (simp add: Chaos_def SRD_reactive_design_alt assms)
  also have "... = \<^bold>R\<^sub>s (false \<turnstile> (cmt\<^sub>R Q \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> true))"
    by (simp add: extChoice_rdes unrest)
  also have "... = \<^bold>R\<^sub>s (false \<turnstile> true)"
    by (rule cong[of "\<^bold>R\<^sub>s" "\<^bold>R\<^sub>s"], simp, rel_auto)
  also have "... = Chaos"
    by (simp add: Chaos_def)
  finally show ?thesis .
qed

lemma extChoice_Dist:
  assumes "P is CSP" "S \<subseteq> \<lbrakk>CSP\<rbrakk>\<^sub>H" "S \<noteq> {}"
  shows "P \<box> (\<Sqinter> S) = (\<Sqinter> Q\<in>S. P \<box> Q)"
proof -
  let ?S1 = "pre\<^sub>R ` S" and ?S2 = "cmt\<^sub>R ` S"
  have "P \<box> (\<Sqinter> S) = P \<box> (\<Sqinter> Q\<in>S \<bullet> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> cmt\<^sub>R(Q)))"
    by (simp add: SRD_as_reactive_design[THEN sym] Healthy_SUPREMUM UINF_as_Sup_collect assms)
  also have "... = \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> cmt\<^sub>R(P)) \<box> \<^bold>R\<^sub>s((\<Squnion> Q \<in> S \<bullet> pre\<^sub>R(Q)) \<turnstile> (\<Sqinter> Q \<in> S \<bullet> cmt\<^sub>R(Q)))"
    by (simp add: RHS_design_USUP SRD_reactive_design_alt assms)
  also have "... = \<^bold>R\<^sub>s ((pre\<^sub>R(P) \<and> (\<Squnion> Q \<in> S \<bullet> pre\<^sub>R(Q))) \<turnstile>
                       ((cmt\<^sub>R(P) \<and> (\<Sqinter> Q \<in> S \<bullet> cmt\<^sub>R(Q)))
                         \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright>
                        (cmt\<^sub>R(P) \<or> (\<Sqinter> Q \<in> S \<bullet> cmt\<^sub>R(Q)))))"
    by (simp add: extChoice_rdes unrest)
  also have "... = \<^bold>R\<^sub>s ((\<Squnion> Q\<in>S \<bullet> pre\<^sub>R P \<and> pre\<^sub>R Q) \<turnstile>
                       (\<Sqinter> Q\<in>S \<bullet> (cmt\<^sub>R P \<and> cmt\<^sub>R Q) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (cmt\<^sub>R P \<or> cmt\<^sub>R Q)))"
    by (simp add: conj_USUP_dist conj_UINF_dist disj_UINF_dist cond_UINF_dist assms)
  also have "... = (\<Sqinter> Q \<in> S \<bullet> \<^bold>R\<^sub>s ((pre\<^sub>R P \<and> pre\<^sub>R Q) \<turnstile>
                                  ((cmt\<^sub>R P \<and> cmt\<^sub>R Q) \<triangleleft> $tr\<acute> =\<^sub>u $tr \<and> $wait\<acute> \<triangleright> (cmt\<^sub>R P \<or> cmt\<^sub>R Q))))"
    by (simp add: assms RHS_design_USUP)
  also have "... = (\<Sqinter> Q\<in>S \<bullet> \<^bold>R\<^sub>s(pre\<^sub>R(P) \<turnstile> cmt\<^sub>R(P)) \<box> \<^bold>R\<^sub>s(pre\<^sub>R(Q) \<turnstile> cmt\<^sub>R(Q)))"
    by (simp add: extChoice_rdes unrest)
  also have "... = (\<Sqinter> Q\<in>S. P \<box> CSP(Q))"
    by (simp add: UINF_as_Sup_collect, metis (no_types, lifting) Healthy_if SRD_as_reactive_design assms(1))
  also have "... = (\<Sqinter> Q\<in>S. P \<box> Q)"
    by (rule SUP_cong, simp_all add: Healthy_subset_member[OF assms(2)])
  finally show ?thesis .
qed

lemma extChoice_dist:
  assumes "P is CSP" "Q is CSP" "R is CSP"
  shows "P \<box> (Q \<sqinter> R) = (P \<box> Q) \<sqinter> (P \<box> R)"
  using assms extChoice_Dist[of P "{Q, R}"] by simp

lemma ExtChoice_seq_distr:
  assumes "\<And> i. i \<in> A \<Longrightarrow> P i is PCSP" "Q is NCSP"
  shows "(\<box> i\<in>A \<bullet> P i) ;; Q = (\<box> i\<in>A \<bullet> P i ;; Q)"
proof (cases "A = {}")
  case True
  then show ?thesis
    by (simp add: ExtChoice_empty NCSP_implies_CSP Stop_left_zero assms(2))
next
  case False
  show ?thesis
  proof -
    have 1:"(\<box> i\<in>A \<bullet> P i) = (\<box> i\<in>A \<bullet> (\<^bold>R\<^sub>s ((pre\<^sub>R (P i)) \<turnstile> peri\<^sub>R (P i) \<diamondop> (R4(post\<^sub>R (P i))))))"
      (is "?X = ?Y")
      by (rule ExtChoice_cong, metis (no_types, opaque_lifting) R4_def Healthy_if NCSP_implies_CSP PCSP_implies_NCSP Productive_form assms(1) comp_apply)
    have 2:"(\<box> i\<in>A \<bullet> P i ;; Q) = (\<box> i\<in>A \<bullet> (\<^bold>R\<^sub>s ((pre\<^sub>R (P i)) \<turnstile> peri\<^sub>R (P i) \<diamondop> (R4(post\<^sub>R (P i))))) ;; Q)"
      (is "?X = ?Y")
      by (rule ExtChoice_cong, metis (no_types, opaque_lifting) R4_def Healthy_if NCSP_implies_CSP PCSP_implies_NCSP Productive_form assms(1) comp_apply)
    show ?thesis
      by (simp add: 1 2, rdes_eq cls: assms False cong: ExtChoice_cong USUP_cong)
  qed
qed

lemma extChoice_seq_distr:
  assumes "P is PCSP" "Q is PCSP" "R is NCSP"
  shows "(P \<box> Q) ;; R = (P ;; R \<box> Q ;; R)"
  by (rdes_eq' cls: assms)

lemma extChoice_seq_distl:
  assumes "P is ICSP" "Q is ICSP" "R is NCSP"
  shows "P ;; (Q \<box> R) = (P ;; Q \<box> P ;; R)"
  by (rdes_eq cls: assms)

lemma extchoice_StateInvR_refine:
  assumes
    "P is NCSP" "Q is NCSP"
    "sinv\<^sub>R(b) \<sqsubseteq> P" "sinv\<^sub>R(b) \<sqsubseteq> Q"
  shows "sinv\<^sub>R(b) \<sqsubseteq> P \<box> Q"
proof -
  have "P is R2" "Q is R2" by (simp_all add: closure assms)
  hence 1:
    "pre\<^sub>R P \<sqsubseteq> [b]\<^sub>S\<^sub><" "[b]\<^sub>S\<^sub>> \<sqsubseteq> ([b]\<^sub>S\<^sub>< \<and> post\<^sub>R P)"
    "pre\<^sub>R Q \<sqsubseteq> [b]\<^sub>S\<^sub><" "[b]\<^sub>S\<^sub>> \<sqsubseteq> ([b]\<^sub>S\<^sub>< \<and> post\<^sub>R Q)"
    by (metis (no_types, lifting) CRR_implies_RR NCSP_implies_CSP RHS_tri_design_refine SRD_reactive_tri_design StateInvR_def assms periR_RR postR_RR preR_CRR rea_st_cond_RR rea_true_RR refBy_order st_post_CRR)+
  show ?thesis
    by (rdes_refine_split cls: assms(1-2), simp_all add: 1 closure assms truer_bottom_rpred  utp_pred_laws.inf_sup_distrib1)
qed

end


(*  Title:      HOL/Library/BNF_Corec.thy
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
    Author:     Aymeric Bouzy, Ecole polytechnique
    Author:     Dmitriy Traytel, ETH Zurich
    Copyright   2015, 2016

Generalized corecursor sugar ("corec" and friends).
*)

section \<open>Generalized Corecursor Sugar (corec and friends)\<close>

theory BNF_Corec
imports MainRLT
keywords
  "corec" :: thy_defn and
  "corecursive" :: thy_goal_defn and
  "friend_of_corec" :: thy_goal_defn and
  "coinduction_upto" :: thy_decl
begin

lemma obj_distinct_prems: "P \<longrightarrow> P \<longrightarrow> Q \<Longrightarrow> P \<Longrightarrow> Q"
  by auto

lemma inject_refine: "g (f x) = x \<Longrightarrow> g (f y) = y \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
  by (metis (no_types))

lemma convol_apply: "BNF_Def.convol f g x = (f x, g x)"
  unfolding convol_def ..

lemma Grp_UNIV_id: "BNF_Def.Grp UNIV id = (=)"
  unfolding BNF_Def.Grp_def by auto

lemma sum_comp_cases:
  assumes "f \<circ> Inl = g \<circ> Inl" and "f \<circ> Inr = g \<circ> Inr"
  shows "f = g"
proof (rule ext)
  fix a show "f a = g a"
    using assms unfolding comp_def fun_eq_iff by (cases a) auto
qed

lemma case_sum_Inl_Inr_L: "case_sum (f \<circ> Inl) (f \<circ> Inr) = f"
  by (metis case_sum_expand_Inr')

lemma eq_o_InrI: "\<lbrakk>g \<circ> Inl = h; case_sum h f = g\<rbrakk> \<Longrightarrow> f = g \<circ> Inr"
  by (auto simp: fun_eq_iff split: sum.splits)

lemma id_bnf_o: "BNF_Composition.id_bnf \<circ> f = f"
  unfolding BNF_Composition.id_bnf_def by (rule o_def)

lemma o_id_bnf: "f \<circ> BNF_Composition.id_bnf = f"
  unfolding BNF_Composition.id_bnf_def by (rule o_def)

lemma if_True_False:
  "(if P then True else Q) \<longleftrightarrow> P \<or> Q"
  "(if P then False else Q) \<longleftrightarrow> \<not> P \<and> Q"
  "(if P then Q else True) \<longleftrightarrow> \<not> P \<or> Q"
  "(if P then Q else False) \<longleftrightarrow> P \<and> Q"
  by auto

lemma if_distrib_fun: "(if c then f else g) x = (if c then f x else g x)"
  by simp

subsection \<open>Coinduction\<close>

lemma eq_comp_compI: "a \<circ> b = f \<circ> x \<Longrightarrow> x \<circ> c = id \<Longrightarrow> f = a \<circ> (b \<circ> c)"
  unfolding fun_eq_iff by simp

lemma self_bounded_weaken_left: "(a :: 'a :: semilattice_inf) \<le> inf a b \<Longrightarrow> a \<le> b"
  by (erule le_infE)

lemma self_bounded_weaken_right: "(a :: 'a :: semilattice_inf) \<le> inf b a \<Longrightarrow> a \<le> b"
  by (erule le_infE)

lemma symp_iff: "symp R \<longleftrightarrow> R = R\<inverse>\<inverse>"
  by (metis antisym conversep.cases conversep_le_swap predicate2I symp_def)

lemma equivp_inf: "\<lbrakk>equivp R; equivp S\<rbrakk> \<Longrightarrow> equivp (inf R S)"
  unfolding equivp_def inf_fun_def inf_bool_def by metis

lemma vimage2p_rel_prod:
  "(\<lambda>x y. rel_prod R S (BNF_Def.convol f1 g1 x) (BNF_Def.convol f2 g2 y)) =
   (inf (BNF_Def.vimage2p f1 f2 R) (BNF_Def.vimage2p g1 g2 S))"
  unfolding vimage2p_def rel_prod.simps convol_def by auto

lemma predicate2I_obj: "(\<forall>x y. P x y \<longrightarrow> Q x y) \<Longrightarrow> P \<le> Q"
  by auto

lemma predicate2D_obj: "P \<le> Q \<Longrightarrow> P x y \<longrightarrow> Q x y"
  by auto

locale cong =
  fixes rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool)"
    and eval :: "'b \<Rightarrow> 'a"
    and retr :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
  assumes rel_mono: "\<And>R S. R \<le> S \<Longrightarrow> rel R \<le> rel S"
    and equivp_retr: "\<And>R. equivp R \<Longrightarrow> equivp (retr R)"
    and retr_eval: "\<And>R x y. \<lbrakk>(rel_fun (rel R) R) eval eval; rel (inf R (retr R)) x y\<rbrakk> \<Longrightarrow>
      retr R (eval x) (eval y)"
begin

definition cong :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
  "cong R \<equiv> equivp R \<and> (rel_fun (rel R) R) eval eval"

lemma cong_retr: "cong R \<Longrightarrow> cong (inf R (retr R))"
  unfolding cong_def
  by (auto simp: rel_fun_def dest: predicate2D[OF rel_mono, rotated]
    intro: equivp_inf equivp_retr retr_eval)

lemma cong_equivp: "cong R \<Longrightarrow> equivp R"
  unfolding cong_def by simp

definition gen_cong :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "gen_cong R j1 j2 \<equiv> \<forall>R'. R \<le> R' \<and> cong R' \<longrightarrow> R' j1 j2"

lemma gen_cong_reflp[intro, simp]: "x = y \<Longrightarrow> gen_cong R x y"
  unfolding gen_cong_def by (auto dest: cong_equivp equivp_reflp)

lemma gen_cong_symp[intro]: "gen_cong R x y \<Longrightarrow> gen_cong R y x"
  unfolding gen_cong_def by (auto dest: cong_equivp equivp_symp)

lemma gen_cong_transp[intro]: "gen_cong R x y \<Longrightarrow> gen_cong R y z \<Longrightarrow> gen_cong R x z"
  unfolding gen_cong_def by (auto dest: cong_equivp equivp_transp)

lemma equivp_gen_cong: "equivp (gen_cong R)"
  by (intro equivpI reflpI sympI transpI) auto

lemma leq_gen_cong: "R \<le> gen_cong R"
  unfolding gen_cong_def[abs_def] by auto

lemmas imp_gen_cong[intro] = predicate2D[OF leq_gen_cong]

lemma gen_cong_minimal: "\<lbrakk>R \<le> R'; cong R'\<rbrakk> \<Longrightarrow> gen_cong R \<le> R'"
  unfolding gen_cong_def[abs_def] by (rule predicate2I) metis

lemma congdd_base_gen_congdd_base_aux:
  "rel (gen_cong R) x y \<Longrightarrow> R \<le> R' \<Longrightarrow> cong R' \<Longrightarrow> R' (eval x) (eval y)"
   by (force simp: rel_fun_def gen_cong_def cong_def dest: spec[of _ R'] predicate2D[OF rel_mono, rotated -1, of _ _ _ R'])

lemma cong_gen_cong: "cong (gen_cong R)"
proof -
  { fix R' x y
    have "rel (gen_cong R) x y \<Longrightarrow> R \<le> R' \<Longrightarrow> cong R' \<Longrightarrow> R' (eval x) (eval y)"
      by (force simp: rel_fun_def gen_cong_def cong_def dest: spec[of _ R']
        predicate2D[OF rel_mono, rotated -1, of _ _ _ R'])
  }
  then show "cong (gen_cong R)" by (auto simp: equivp_gen_cong rel_fun_def gen_cong_def cong_def)
qed

lemma gen_cong_eval_rel_fun:
  "(rel_fun (rel (gen_cong R)) (gen_cong R)) eval eval"
  using cong_gen_cong[of R] unfolding cong_def by simp

lemma gen_cong_eval:
  "rel (gen_cong R) x y \<Longrightarrow> gen_cong R (eval x) (eval y)"
  by (erule rel_funD[OF gen_cong_eval_rel_fun])

lemma gen_cong_idem: "gen_cong (gen_cong R) = gen_cong R"
  by (simp add: antisym cong_gen_cong gen_cong_minimal leq_gen_cong)

lemma gen_cong_rho:
  "\<rho> = eval \<circ> f \<Longrightarrow> rel (gen_cong R) (f x) (f y) \<Longrightarrow> gen_cong R (\<rho> x) (\<rho> y)"
  by (simp add: gen_cong_eval)
lemma coinduction:
  assumes coind: "\<forall>R. R \<le> retr R \<longrightarrow> R \<le> (=)"
  assumes cih: "R \<le> retr (gen_cong R)"
  shows "R \<le> (=)"
  apply (rule order_trans[OF leq_gen_cong mp[OF spec[OF coind]]])
  apply (rule self_bounded_weaken_left[OF gen_cong_minimal])
   apply (rule inf_greatest[OF leq_gen_cong cih])
  apply (rule cong_retr[OF cong_gen_cong])
  done

end

lemma rel_sum_case_sum:
  "rel_fun (rel_sum R S) T (case_sum f1 g1) (case_sum f2 g2) = (rel_fun R T f1 f2 \<and> rel_fun S T g1 g2)"
  by (auto simp: rel_fun_def rel_sum.simps split: sum.splits)

context
  fixes rel eval rel' eval' retr emb
  assumes base: "cong rel eval retr"
  and step: "cong rel' eval' retr"
  and emb: "eval' \<circ> emb = eval"
  and emb_transfer: "rel_fun (rel R) (rel' R) emb emb"
begin

interpretation base: cong rel eval retr by (rule base)
interpretation step: cong rel' eval' retr by (rule step)

lemma gen_cong_emb: "base.gen_cong R \<le> step.gen_cong R"
proof (rule base.gen_cong_minimal[OF step.leq_gen_cong])
  note step.gen_cong_eval_rel_fun[transfer_rule] emb_transfer[transfer_rule]
  have "(rel_fun (rel (step.gen_cong R)) (step.gen_cong R)) eval eval"
    unfolding emb[symmetric] by transfer_prover
  then show "base.cong (step.gen_cong R)"
    by (auto simp: base.cong_def step.equivp_gen_cong)
qed

end

named_theorems friend_of_corec_simps

ML_file \<open>../Tools/BNF/bnf_gfp_grec_tactics.ML\<close>
ML_file \<open>../Tools/BNF/bnf_gfp_grec.ML\<close>
ML_file \<open>../Tools/BNF/bnf_gfp_grec_sugar_util.ML\<close>
ML_file \<open>../Tools/BNF/bnf_gfp_grec_sugar_tactics.ML\<close>
ML_file \<open>../Tools/BNF/bnf_gfp_grec_sugar.ML\<close>
ML_file \<open>../Tools/BNF/bnf_gfp_grec_unique_sugar.ML\<close>

method_setup transfer_prover_eq = \<open>
  Scan.succeed (SIMPLE_METHOD' o BNF_GFP_Grec_Tactics.transfer_prover_eq_tac)
\<close> "apply transfer_prover after folding relator_eq"

method_setup corec_unique = \<open>
  Scan.succeed (SIMPLE_METHOD' o BNF_GFP_Grec_Unique_Sugar.corec_unique_tac)
\<close> "prove uniqueness of corecursive equation"

end