(*  Title:      HOL/HOLCF/IOA/RefCorrectness.thy
    Author:     Olaf Müller
*)

section \<open>Correctness of Refinement Mappings in HOLCF/IOA\<close>

theory RefCorrectness
imports RefMappings
begin

definition corresp_exC ::
    "('a, 's2) ioa \<Rightarrow> ('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) pairs \<rightarrow> ('s1 \<Rightarrow> ('a, 's2) pairs)"
  where "corresp_exC A f =
    (fix \<cdot>
      (LAM h ex.
        (\<lambda>s. case ex of
          nil \<Rightarrow> nil
        | x ## xs \<Rightarrow>
            flift1 (\<lambda>pr.
              (SOME cex. move A cex (f s) (fst pr) (f (snd pr))) @@ ((h \<cdot> xs) (snd pr))) \<cdot> x)))"

definition corresp_ex ::
    "('a, 's2) ioa \<Rightarrow> ('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) execution \<Rightarrow> ('a, 's2) execution"
  where "corresp_ex A f ex = (f (fst ex), (corresp_exC A f \<cdot> (snd ex)) (fst ex))"

definition is_fair_ref_map ::
    "('s1 \<Rightarrow> 's2) \<Rightarrow> ('a, 's1) ioa \<Rightarrow> ('a, 's2) ioa \<Rightarrow> bool"
  where "is_fair_ref_map f C A \<longleftrightarrow>
    is_ref_map f C A \<and> (\<forall>ex \<in> executions C. fair_ex C ex \<longrightarrow> fair_ex A (corresp_ex A f ex))"

text \<open>
  Axioms for fair trace inclusion proof support, not for the correctness proof
  of refinement mappings!

  Note: Everything is superseded by \<^file>\<open>LiveIOA.thy\<close>.
\<close>

axiomatization where
  corresp_laststate:
    "Finite ex \<Longrightarrow> laststate (corresp_ex A f (s, ex)) = f (laststate (s, ex))"

axiomatization where
  corresp_Finite: "Finite (snd (corresp_ex A f (s, ex))) = Finite ex"

axiomatization where
  FromAtoC:
    "fin_often (\<lambda>x. P (snd x)) (snd (corresp_ex A f (s, ex))) \<Longrightarrow>
      fin_often (\<lambda>y. P (f (snd y))) ex"

axiomatization where
  FromCtoA:
    "inf_often (\<lambda>y. P (fst y)) ex \<Longrightarrow>
      inf_often (\<lambda>x. P (fst x)) (snd (corresp_ex A f (s,ex)))"

text \<open>
  Proof by case on \<open>inf W\<close> in ex: If so, ok. If not, only \<open>fin W\<close> in ex, ie.
  there is an index \<open>i\<close> from which on no \<open>W\<close> in ex. But \<open>W\<close> inf enabled, ie at
  least once after \<open>i\<close> \<open>W\<close> is enabled. As \<open>W\<close> does not occur after \<open>i\<close> and \<open>W\<close>
  is \<open>enabling_persistent\<close>, \<open>W\<close> keeps enabled until infinity, ie. indefinitely
\<close>

axiomatization where
  persistent:
    "inf_often (\<lambda>x. Enabled A W (snd x)) ex \<Longrightarrow> en_persistent A W \<Longrightarrow>
      inf_often (\<lambda>x. fst x \<in> W) ex \<or> fin_often (\<lambda>x. \<not> Enabled A W (snd x)) ex"

axiomatization where
  infpostcond:
    "is_exec_frag A (s,ex) \<Longrightarrow> inf_often (\<lambda>x. fst x \<in> W) ex \<Longrightarrow>
      inf_often (\<lambda>x. set_was_enabled A W (snd x)) ex"

subsection \<open>\<open>corresp_ex\<close>\<close>

lemma corresp_exC_unfold:
  "corresp_exC A f =
    (LAM ex.
      (\<lambda>s.
        case ex of
          nil \<Rightarrow> nil
        | x ## xs \<Rightarrow>
            (flift1 (\<lambda>pr.
              (SOME cex. move A cex (f s) (fst pr) (f (snd pr))) @@
              ((corresp_exC A f \<cdot> xs) (snd pr))) \<cdot> x)))"
  apply (rule trans)
  apply (rule fix_eq2)
  apply (simp only: corresp_exC_def)
  apply (rule beta_cfun)
  apply (simp add: flift1_def)
  done

lemma corresp_exC_UU: "(corresp_exC A f \<cdot> UU) s = UU"
  apply (subst corresp_exC_unfold)
  apply simp
  done

lemma corresp_exC_nil: "(corresp_exC A f \<cdot> nil) s = nil"
  apply (subst corresp_exC_unfold)
  apply simp
  done

lemma corresp_exC_cons:
  "(corresp_exC A f \<cdot> (at \<leadsto> xs)) s =
     (SOME cex. move A cex (f s) (fst at) (f (snd at))) @@
     ((corresp_exC A f \<cdot> xs) (snd at))"
  apply (rule trans)
  apply (subst corresp_exC_unfold)
  apply (simp add: Consq_def flift1_def)
  apply simp
  done

declare corresp_exC_UU [simp] corresp_exC_nil [simp] corresp_exC_cons [simp]

subsection \<open>Properties of move\<close>

lemma move_is_move:
  "is_ref_map f C A \<Longrightarrow> reachable C s \<Longrightarrow> (s, a, t) \<in> trans_of C \<Longrightarrow>
    move A (SOME x. move A x (f s) a (f t)) (f s) a (f t)"
  apply (unfold is_ref_map_def)
  apply (subgoal_tac "\<exists>ex. move A ex (f s) a (f t) ")
  prefer 2
  apply simp
  apply (erule exE)
  apply (rule someI)
  apply assumption
  done

lemma move_subprop1:
  "is_ref_map f C A \<Longrightarrow> reachable C s \<Longrightarrow> (s, a, t) \<in> trans_of C \<Longrightarrow>
    is_exec_frag A (f s, SOME x. move A x (f s) a (f t))"
  apply (cut_tac move_is_move)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

lemma move_subprop2:
  "is_ref_map f C A \<Longrightarrow> reachable C s \<Longrightarrow> (s, a, t) \<in> trans_of C \<Longrightarrow>
    Finite ((SOME x. move A x (f s) a (f t)))"
  apply (cut_tac move_is_move)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

lemma move_subprop3:
  "is_ref_map f C A \<Longrightarrow> reachable C s \<Longrightarrow> (s, a, t) \<in> trans_of C \<Longrightarrow>
     laststate (f s, SOME x. move A x (f s) a (f t)) = (f t)"
  apply (cut_tac move_is_move)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

lemma move_subprop4:
  "is_ref_map f C A \<Longrightarrow> reachable C s \<Longrightarrow> (s, a, t) \<in> trans_of C \<Longrightarrow>
    mk_trace A \<cdot> ((SOME x. move A x (f s) a (f t))) =
      (if a \<in> ext A then a \<leadsto> nil else nil)"
  apply (cut_tac move_is_move)
  defer
  apply assumption+
  apply (simp add: move_def)
  done

subsection \<open>TRACE INCLUSION Part 1: Traces coincide\<close>

subsubsection \<open>Lemmata for \<open>\<Longleftarrow>\<close>\<close>

text \<open>Lemma 1.1: Distribution of \<open>mk_trace\<close> and \<open>@@\<close>\<close>

lemma mk_traceConc:
  "mk_trace C \<cdot> (ex1 @@ ex2) = (mk_trace C \<cdot> ex1) @@ (mk_trace C \<cdot> ex2)"
  by (simp add: mk_trace_def filter_act_def MapConc)

text \<open>Lemma 1 : Traces coincide\<close>

lemma lemma_1:
  "is_ref_map f C A \<Longrightarrow> ext C = ext A \<Longrightarrow>
    \<forall>s. reachable C s \<and> is_exec_frag C (s, xs) \<longrightarrow>
      mk_trace C \<cdot> xs = mk_trace A \<cdot> (snd (corresp_ex A f (s, xs)))"
  supply if_split [split del]
  apply (unfold corresp_ex_def)
  apply (pair_induct xs simp: is_exec_frag_def)
  text \<open>cons case\<close>
  apply (auto simp add: mk_traceConc)
  apply (frule reachable.reachable_n)
  apply assumption
  apply (auto simp add: move_subprop4 split: if_split)
  done

subsection \<open>TRACE INCLUSION Part 2: corresp_ex is execution\<close>

subsubsection \<open>Lemmata for \<open>==>\<close>\<close>

text \<open>Lemma 2.1\<close>

lemma lemma_2_1 [rule_format]:
  "Finite xs \<longrightarrow>
    (\<forall>s. is_exec_frag A (s, xs) \<and> is_exec_frag A (t, ys) \<and>
      t = laststate (s, xs) \<longrightarrow> is_exec_frag A (s, xs @@ ys))"
  apply (rule impI)
  apply Seq_Finite_induct
  text \<open>main case\<close>
  apply (auto simp add: split_paired_all)
  done

text \<open>Lemma 2 : \<open>corresp_ex\<close> is execution\<close>

lemma lemma_2:
  "is_ref_map f C A \<Longrightarrow>
    \<forall>s. reachable C s \<and> is_exec_frag C (s, xs) \<longrightarrow>
      is_exec_frag A (corresp_ex A f (s, xs))"
  apply (unfold corresp_ex_def)

  apply simp
  apply (pair_induct xs simp: is_exec_frag_def)

  text \<open>main case\<close>
  apply auto
  apply (rule_tac t = "f x2" in lemma_2_1)

  text \<open>\<open>Finite\<close>\<close>
  apply (erule move_subprop2)
  apply assumption+
  apply (rule conjI)

  text \<open>\<open>is_exec_frag\<close>\<close>
  apply (erule move_subprop1)
  apply assumption+
  apply (rule conjI)

  text \<open>Induction hypothesis\<close>
  text \<open>\<open>reachable_n\<close> looping, therefore apply it manually\<close>
  apply (erule_tac x = "x2" in allE)
  apply simp
  apply (frule reachable.reachable_n)
  apply assumption
  apply simp

  text \<open>\<open>laststate\<close>\<close>
  apply (erule move_subprop3 [symmetric])
  apply assumption+
  done

subsection \<open>Main Theorem: TRACE -- INCLUSION\<close>

theorem trace_inclusion:
  "ext C = ext A \<Longrightarrow> is_ref_map f C A \<Longrightarrow> traces C \<subseteq> traces A"

  apply (unfold traces_def)

  apply (simp add: has_trace_def2)
  apply auto

  text \<open>give execution of abstract automata\<close>
  apply (rule_tac x = "corresp_ex A f ex" in bexI)

  text \<open>Traces coincide, Lemma 1\<close>
  apply (pair ex)
  apply (erule lemma_1 [THEN spec, THEN mp])
  apply assumption+
  apply (simp add: executions_def reachable.reachable_0)

  text \<open>\<open>corresp_ex\<close> is execution, Lemma 2\<close>
  apply (pair ex)
  apply (simp add: executions_def)
  text \<open>start state\<close>
  apply (rule conjI)
  apply (simp add: is_ref_map_def corresp_ex_def)
  text \<open>\<open>is_execution_fragment\<close>\<close>
  apply (erule lemma_2 [THEN spec, THEN mp])
  apply (simp add: reachable.reachable_0)
  done

subsection \<open>Corollary:  FAIR TRACE -- INCLUSION\<close>

lemma fininf: "(~inf_often P s) = fin_often P s"
  by (auto simp: fin_often_def)

lemma WF_alt: "is_wfair A W (s, ex) =
  (fin_often (\<lambda>x. \<not> Enabled A W (snd x)) ex \<longrightarrow> inf_often (\<lambda>x. fst x \<in> W) ex)"
  by (auto simp add: is_wfair_def fin_often_def)

lemma WF_persistent:
  "is_wfair A W (s, ex) \<Longrightarrow> inf_often (\<lambda>x. Enabled A W (snd x)) ex \<Longrightarrow>
    en_persistent A W \<Longrightarrow> inf_often (\<lambda>x. fst x \<in> W) ex"
  apply (drule persistent)
  apply assumption
  apply (simp add: WF_alt)
  apply auto
  done

lemma fair_trace_inclusion:
  assumes "is_ref_map f C A"
    and "ext C = ext A"
    and "\<And>ex. ex \<in> executions C \<Longrightarrow> fair_ex C ex \<Longrightarrow>
      fair_ex A (corresp_ex A f ex)"
  shows "fairtraces C \<subseteq> fairtraces A"
  apply (insert assms)
  apply (simp add: fairtraces_def fairexecutions_def)
  apply auto
  apply (rule_tac x = "corresp_ex A f ex" in exI)
  apply auto

  text \<open>Traces coincide, Lemma 1\<close>
  apply (pair ex)
  apply (erule lemma_1 [THEN spec, THEN mp])
  apply assumption+
  apply (simp add: executions_def reachable.reachable_0)

  text \<open>\<open>corresp_ex\<close> is execution, Lemma 2\<close>
  apply (pair ex)
  apply (simp add: executions_def)
  text \<open>start state\<close>
  apply (rule conjI)
  apply (simp add: is_ref_map_def corresp_ex_def)
  text \<open>\<open>is_execution_fragment\<close>\<close>
  apply (erule lemma_2 [THEN spec, THEN mp])
  apply (simp add: reachable.reachable_0)
  done

lemma fair_trace_inclusion2:
  "inp C = inp A \<Longrightarrow> out C = out A \<Longrightarrow> is_fair_ref_map f C A \<Longrightarrow>
    fair_implements C A"
  apply (simp add: is_fair_ref_map_def fair_implements_def fairtraces_def fairexecutions_def)
  apply auto
  apply (rule_tac x = "corresp_ex A f ex" in exI)
  apply auto

  text \<open>Traces coincide, Lemma 1\<close>
  apply (pair ex)
  apply (erule lemma_1 [THEN spec, THEN mp])
  apply (simp (no_asm) add: externals_def)
  apply (auto)[1]
  apply (simp add: executions_def reachable.reachable_0)

  text \<open>\<open>corresp_ex\<close> is execution, Lemma 2\<close>
  apply (pair ex)
  apply (simp add: executions_def)
  text \<open>start state\<close>
  apply (rule conjI)
  apply (simp add: is_ref_map_def corresp_ex_def)
  text \<open>\<open>is_execution_fragment\<close>\<close>
  apply (erule lemma_2 [THEN spec, THEN mp])
  apply (simp add: reachable.reachable_0)
  done

end


(*  Title:      Containers/Mapping_Impl.thy
    Author:     Andreas Lochbihler, KIT
                René Thiemann, UIBK *)

theory Mapping_Impl imports
  RBT_Mapping2
  AssocList
  "HOL-Library.Mapping"
  Set_Impl
  Containers_Generator
begin

section \<open>Different implementations of maps\<close>

code_identifier
  code_module Mapping \<rightharpoonup> (SML) Mapping_Impl
| code_module Mapping_Impl \<rightharpoonup> (SML) Mapping_Impl

subsection \<open>Map implementations\<close>

definition Assoc_List_Mapping :: "('a, 'b) alist \<Rightarrow> ('a, 'b) mapping"
where [simp]: "Assoc_List_Mapping al = Mapping.Mapping (DAList.lookup al)"

definition RBT_Mapping :: "('a :: ccompare, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping"
where [simp]: "RBT_Mapping t = Mapping.Mapping (RBT_Mapping2.lookup t)"

code_datatype Assoc_List_Mapping RBT_Mapping Mapping

subsection \<open>Map operations\<close>

declare [[code drop: Mapping.lookup]]

lemma lookup_Mapping_code [code]:
  "Mapping.lookup (Assoc_List_Mapping al) = DAList.lookup al"
  "Mapping.lookup (RBT_Mapping t) = RBT_Mapping2.lookup t"
by(simp_all)(transfer, rule)+

declare [[code drop: Mapping.is_empty]]

lemma is_empty_transfer [transfer_rule]:
  includes lifting_syntax
  shows "(pcr_mapping (=) (=) ===> (=)) (\<lambda>m. m = Map.empty) Mapping.is_empty"
unfolding mapping.pcr_cr_eq
apply(rule rel_funI)
apply(case_tac y)
apply(simp add: Mapping.is_empty_def cr_mapping_def Mapping_inverse Mapping.keys.rep_eq)
done

lemma is_empty_Mapping [code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.is_empty (Assoc_List_Mapping al) \<longleftrightarrow> al = DAList.empty"
  "Mapping.is_empty (RBT_Mapping t) \<longleftrightarrow>
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''is_empty RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.is_empty (RBT_Mapping t))
                     | Some _ \<Rightarrow> RBT_Mapping2.is_empty t)"
apply(simp_all split: option.split)
 apply(transfer, case_tac al, simp_all)
apply(transfer, simp)
done

declare [[code drop: Mapping.update]]

lemma update_Mapping [code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.update k v (Mapping m) = Mapping (m(k \<mapsto> v))"
  "Mapping.update k v (Assoc_List_Mapping al) = Assoc_List_Mapping (DAList.update k v al)"
  "Mapping.update k v (RBT_Mapping t) =
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''update RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.update k v (RBT_Mapping t))
                     | Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.insert k v t))" (is ?RBT)
by(simp_all split: option.split)(transfer, simp)+

declare [[code drop: Mapping.delete]]

lemma delete_Mapping [code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.delete k (Mapping m) = Mapping (m(k := None))"
  "Mapping.delete k (Assoc_List_Mapping al) = Assoc_List_Mapping (AssocList.delete k al)"
  "Mapping.delete k (RBT_Mapping t) =
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''delete RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.delete k (RBT_Mapping t))
                     | Some _ \<Rightarrow> RBT_Mapping (RBT_Mapping2.delete k t))"
by(simp_all split: option.split)(transfer, simp)+

declare [[code drop: Mapping.keys]]

theorem rbt_comp_lookup_map_const: "rbt_comp_lookup c (RBT_Impl.map (\<lambda>_. f) t) = map_option f \<circ> rbt_comp_lookup c t"
by(induct t)(auto simp: fun_eq_iff split: order.split)

lemma keys_Mapping [code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.keys (Mapping m) = Collect (\<lambda>k. m k \<noteq> None)" (is "?Mapping")
  "Mapping.keys (Assoc_List_Mapping al) = AssocList.keys al" (is "?Assoc_List")
  "Mapping.keys (RBT_Mapping t) = RBT_set (RBT_Mapping2.map (\<lambda>_ _. ()) t)" (is "?RBT")
proof -
  show ?Mapping by transfer auto
  show ?Assoc_List by simp(transfer, auto intro: rev_image_eqI)
  show ?RBT
    by(simp add: RBT_set_def, transfer, auto simp add: rbt_comp_lookup_map_const o_def)
qed

declare [[code drop: Mapping.size]]

lemma Mapping_size_transfer [transfer_rule]:
  includes lifting_syntax
  shows "(pcr_mapping (=) (=) ===> (=)) (card \<circ> dom) Mapping.size"
apply(rule rel_funI)
apply(case_tac y)
apply(simp add: Mapping.size_def Mapping.keys.rep_eq Mapping_inverse mapping.pcr_cr_eq cr_mapping_def)
done

lemma size_Mapping [code]:
  fixes t :: "('a :: ccompare, 'b) mapping_rbt" shows
  "Mapping.size (Assoc_List_Mapping al) = size al"
  "Mapping.size (RBT_Mapping t) =
  (case ID CCOMPARE('a) of None \<Rightarrow> Code.abort (STR ''size RBT_Mapping: ccompare = None'') (\<lambda>_. Mapping.size (RBT_Mapping t))
                     | Some _ \<Rightarrow> length (RBT_Mapping2.entries t))"
apply(simp_all split: option.split)
apply(transfer, simp add: dom_map_of_conv_image_fst set_map[symmetric] distinct_card del: set_map)
apply transfer
apply(clarsimp simp add: size_eq_card_dom_lookup)
apply(simp add: linorder.rbt_lookup_keys[OF ID_ccompare] ord.is_rbt_rbt_sorted RBT_Impl.keys_def distinct_card linorder.distinct_entries[OF ID_ccompare] del: set_map)
done

declare [[code drop: Mapping.tabulate]]
declare tabulate_fold [code]

datatype mapping_impl = Mapping_IMPL
declare
  mapping_impl.eq.simps [code del]
  mapping_impl.rec [code del]
  mapping_impl.case [code del]

definition mapping_Choose :: mapping_impl where [simp]: "mapping_Choose = Mapping_IMPL"
definition mapping_Assoc_List :: mapping_impl where [simp]: "mapping_Assoc_List = Mapping_IMPL"
definition mapping_RBT :: mapping_impl where [simp]: "mapping_RBT = Mapping_IMPL"
definition mapping_Mapping :: mapping_impl where [simp]: "mapping_Mapping = Mapping_IMPL"

code_datatype mapping_Choose mapping_Assoc_List mapping_RBT mapping_Mapping

definition mapping_empty_choose :: "('a, 'b) mapping"
where [simp]: "mapping_empty_choose = Mapping.empty"

lemma mapping_empty_choose_code [code]:
  "(mapping_empty_choose :: ('a :: ccompare, 'b) mapping) =
   (case ID CCOMPARE('a) of Some _  \<Rightarrow> RBT_Mapping RBT_Mapping2.empty
    | None \<Rightarrow> Assoc_List_Mapping DAList.empty)"
by(auto split: option.split simp add: DAList.lookup_empty[abs_def] Mapping.empty_def)

definition mapping_impl_choose2 :: "mapping_impl \<Rightarrow> mapping_impl \<Rightarrow> mapping_impl"
where [simp]: "mapping_impl_choose2 = (\<lambda>_ _. Mapping_IMPL)"

lemma mapping_impl_choose2_code [code]:
  "mapping_impl_choose2 x y = mapping_Choose"
  "mapping_impl_choose2 mapping_Mapping mapping_Mapping = mapping_Mapping"
  "mapping_impl_choose2 mapping_Assoc_List mapping_Assoc_List = mapping_Assoc_List"
  "mapping_impl_choose2 mapping_RBT mapping_RBT = mapping_RBT"
by(simp_all)

definition mapping_empty :: "mapping_impl \<Rightarrow> ('a, 'b) mapping"
where [simp]: "mapping_empty = (\<lambda>_. Mapping.empty)"

lemma mapping_empty_code [code]:
  "mapping_empty mapping_Choose = mapping_empty_choose"
  "mapping_empty mapping_Mapping = Mapping (\<lambda>_. None)"
  "mapping_empty mapping_Assoc_List = Assoc_List_Mapping DAList.empty"
  "mapping_empty mapping_RBT = RBT_Mapping RBT_Mapping2.empty"
by(simp_all add: Mapping.empty_def DAList.lookup_empty[abs_def])

subsection \<open>Type classes\<close>

class mapping_impl =
  fixes mapping_impl :: "('a, mapping_impl) phantom"

syntax (input)
  "_MAPPING_IMPL" :: "type => logic"  ("(1MAPPING'_IMPL/(1'(_')))")

parse_translation \<open>
let
  fun mapping_impl_tr [ty] =
     (Syntax.const @{syntax_const "_constrain"} $ Syntax.const @{const_syntax "mapping_impl"} $
       (Syntax.const @{type_syntax phantom} $ ty $ Syntax.const @{type_syntax mapping_impl}))
    | mapping_impl_tr ts = raise TERM ("mapping_impl_tr", ts);
in [(@{syntax_const "_MAPPING_IMPL"}, K mapping_impl_tr)] end
\<close>

declare [[code drop: Mapping.empty]]

lemma Mapping_empty_code [code, code_unfold]:
  "(Mapping.empty :: ('a :: mapping_impl, 'b) mapping) =
   mapping_empty (of_phantom MAPPING_IMPL('a))"
by simp

subsection \<open>Generator for the @{class mapping_impl}-class\<close>

text \<open>
This generator registers itself at the derive-manager for the classes @{class mapping_impl}.
Here, one can choose
the desired implementation via the parameter.

\begin{itemize}
\item \texttt{instantiation type :: (type,\ldots,type) (rbt,assoclist,mapping,choose, or arbitrary constant name) mapping-impl}
\end{itemize}
\<close>

text \<open>
This generator can be used for arbitrary types, not just datatypes.
\<close>

ML_file \<open>mapping_impl_generator.ML\<close>

derive (assoclist) mapping_impl unit bool
derive (rbt) mapping_impl nat
derive (mapping_RBT) mapping_impl int (* shows usage of constant names *)
derive (assoclist) mapping_impl Enum.finite_1 Enum.finite_2 Enum.finite_3
derive (rbt) mapping_impl integer natural
derive (rbt) mapping_impl char

instantiation sum :: (mapping_impl, mapping_impl) mapping_impl begin
definition "MAPPING_IMPL('a + 'b) = Phantom('a + 'b)
  (mapping_impl_choose2 (of_phantom MAPPING_IMPL('a)) (of_phantom MAPPING_IMPL('b)))"
instance ..
end

instantiation prod :: (mapping_impl, mapping_impl) mapping_impl begin
definition "MAPPING_IMPL('a * 'b) = Phantom('a * 'b)
  (mapping_impl_choose2 (of_phantom MAPPING_IMPL('a)) (of_phantom MAPPING_IMPL('b)))"
instance ..
end

derive (choose) mapping_impl list
derive (rbt) mapping_impl String.literal

instantiation option :: (mapping_impl) mapping_impl begin
definition "MAPPING_IMPL('a option) = Phantom('a option) (of_phantom MAPPING_IMPL('a))"
instance ..
end

derive (choose) mapping_impl set

instantiation phantom :: (type, mapping_impl) mapping_impl begin
definition "MAPPING_IMPL(('a, 'b) phantom) = Phantom (('a, 'b) phantom)
  (of_phantom MAPPING_IMPL('b))"
instance ..
end

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   June 2005 (modified)    |
            |                 August 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_domain
imports CSP_T.CSP_T_traces CSP_F_failures
begin

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  disj_not1: (~ P | Q) = (P --> Q)                   *)

declare disj_not1 [simp del]

(*********************************************************
                        domF
 *********************************************************)

(*--------------------------------*
 |             STOP               |
 *--------------------------------*)

(* T2 *)

lemma STOP_T2 : "HC_T2 (traces(STOP) (fstF o M), failures(STOP) M)"
by (simp add: HC_T2_def in_traces in_failures)

(* F3 *)

lemma STOP_F3 : "HC_F3 (traces(STOP) (fstF o M), failures(STOP) M)"
by (simp add: HC_F3_def in_traces in_failures)

(* T3_F4 *)

lemma STOP_T3_F4 : "HC_T3_F4 (traces(STOP) (fstF o M), failures(STOP) M)"
by (auto simp add: HC_T3_F4_def in_traces in_failures)

(*** STOP_domF ***)

lemma STOP_domF : "(traces(STOP) (fstF o M), failures(STOP) M) : domF"
apply (simp add: domF_iff)
apply (simp add: STOP_T2)
apply (simp add: STOP_F3)
apply (simp add: STOP_T3_F4)
done

(*--------------------------------*
 |             SKIP               |
 *--------------------------------*)

(* T2 *)

lemma SKIP_T2 : "HC_T2 (traces(SKIP) (fstF o M), failures(SKIP) M)"
by (simp add: HC_T2_def in_traces in_failures)

(* F3 *)

lemma SKIP_F3 : "HC_F3 (traces(SKIP) (fstF o M), failures(SKIP) M)"
apply (simp add: HC_F3_def in_traces in_failures)
by (auto simp add: Evset_def)

(* T3_F4 *)

lemma SKIP_T3_F4 : "HC_T3_F4 (traces(SKIP) (fstF o M), failures(SKIP) M)"
by (auto simp add: HC_T3_F4_def in_traces in_failures)

(*** SKIP_domF ***)

lemma SKIP_domF : "(traces(SKIP) (fstF o M), failures(SKIP) M) : domF"
apply (simp add: domF_iff)
apply (simp add: SKIP_T2)
apply (simp add: SKIP_F3)
apply (simp add: SKIP_T3_F4)
done

(*--------------------------------*
 |              DIV               |
 *--------------------------------*)

(* T2 *)

lemma DIV_T2 : "HC_T2 (traces(DIV) (fstF o M), failures(DIV) M)"
by (simp add: HC_T2_def in_traces in_failures)

(* F3 *)

lemma DIV_F3 : "HC_F3 (traces(DIV) (fstF o M), failures(DIV) M)"
by (simp add: HC_F3_def in_traces in_failures)

(* T3_F4 *)

lemma DIV_T3_F4 : "HC_T3_F4 (traces(DIV) (fstF o M), failures(DIV) M)"
by (auto simp add: HC_T3_F4_def in_traces in_failures)

(*** DIV_domF ***)

lemma DIV_domF : "(traces(DIV) (fstF o M), failures(DIV) M) : domF"
apply (simp add: domF_iff)
apply (simp add: DIV_T2)
apply (simp add: DIV_F3)
apply (simp add: DIV_T3_F4)
done

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

(* T2 *)

lemma Act_prefix_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> HC_T2 (traces(a -> P) (fstF o M), failures(a -> P) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE, simp)

apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(* F3 *)

lemma Act_prefix_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> HC_F3 (traces(a -> P) (fstF o M), failures(a -> P) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)

apply (elim conjE disjE, simp)
apply (case_tac "Ev a ~: Y", simp)  (* show "Ev a : Y --> contradict" *)
apply (drule_tac x="Ev a" in spec, simp)
apply (drule_tac x="<>" in spec, simp)

apply (elim conjE exE, simp)
apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="X" in spec)
apply (drule_tac x="Y" in spec)
apply (simp)

apply (drule mp)
 apply (intro allI impI)
 apply (drule_tac x="aa" in spec, simp)
 apply (drule_tac x="sa ^^^ <aa>" in spec)
apply (simp add: appt_assoc)
by (simp)

(* T3_F4 *)

lemma Act_prefix_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> HC_T3_F4 (traces(a -> P) (fstF o M), failures(a -> P) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (insert trace_nil_or_Tick_or_Ev)
apply (drule_tac x="s" in spec)

apply (erule disjE, simp)   (* s ^^^ <Tick> = <> --> contradict *)
apply (erule disjE, simp)   (* s = <> --> contradict *)
apply (erule disjE, simp)   (* s = <Tick> --> contradict *)

apply (elim conjE exE)      (* s = [Ev a]t ^^^ sb *)

apply (simp add: domF_iff HC_T3_F4_def)
apply (elim conjE exE)
apply (drule_tac x="sb" in spec)
apply (simp add: appt_assoc)
done

(*** Act_prefix_domF ***)

lemma Act_prefix_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
    ==> (traces(a -> P) (fstF o M), failures(a -> P) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Act_prefix_T2)
apply (simp add: Act_prefix_F3)
apply (simp add: Act_prefix_T3_F4)
done

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

(* T2 *)

lemma Ext_pre_choice_T2 :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> HC_T2 (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE, simp)

apply (drule_tac x="a" in spec)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(* F3 *)

lemma Ext_pre_choice_F3 :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> HC_F3 (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)

apply (elim conjE disjE, simp)

(* s = <> *)
apply (case_tac "EX a. Ev a :Ev ` X Int (Xa Un Y)")  (* show contradiction" *)
 apply (elim conjE exE)
 apply (drule_tac x="Ev a" in spec)
 apply (drule mp)
  apply (simp)                      (* show "Ev a : Y" *)
  apply (elim conjE disjE)
  apply (fast)                      (* contradict *)
  apply (simp)

 apply (drule_tac x="a" in spec)
 apply (drule_tac x="a" in spec)
 apply (simp)
 apply (drule_tac x="s" in spec)
 apply (simp)
 apply (fast)                      (* contradict *)
apply (fast)                       (* Ev ` X Int (Xa Un Y) = {} *)

(* s ~= <> *)
apply (elim conjE exE, simp)
apply (drule_tac x="a" in spec)
apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="Xa" in spec)
apply (drule_tac x="Y" in spec)
apply (simp)

apply (drule mp)
 apply (intro allI impI)
 apply (drule_tac x="aa" in spec, simp)
 apply (drule_tac x="a" in spec)
 apply (drule_tac x="sa ^^^ <aa>" in spec)
 apply (simp add: appt_assoc)
by (simp)

(* T3_F4 *)

lemma Ext_pre_choice_T3_F4 :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> HC_T3_F4 (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (insert trace_nil_or_Tick_or_Ev)
apply (drule_tac x="s" in spec)

apply (erule disjE, simp)   (* contradict *)
apply (erule disjE, simp)   (* s = <> --> contradict *)
apply (erule disjE, simp)   (* s = <Tick> --> contradict *)

apply (elim conjE exE)      (* s = [Ev aa]t ^^^ sb *)
apply (drule_tac x="a" in spec)
apply (simp add: domF_iff HC_T3_F4_def)
apply (elim conjE exE)
apply (drule_tac x="sb" in spec)
apply (simp add: appt_assoc)
done

(*** Ext_pre_choice_domF ***)

lemma Ext_pre_choice_domF :
  "ALL a. (traces(Pf a) (fstF o M), failures(Pf a) M) : domF
     ==> (traces(? :X -> Pf) (fstF o M), failures(? :X -> Pf) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Ext_pre_choice_T2)
apply (simp add: Ext_pre_choice_F3)
apply (simp add: Ext_pre_choice_T3_F4)
done

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

(* T2 *)

lemma Ext_choice_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P [+] Q) (fstF o M), failures(P [+] Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)

apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="s" in spec)
by (fast)

(* F3 *)

lemma Ext_choice_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P [+] Q) (fstF o M), failures(P [+] Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)

apply (elim conjE disjE)
apply (simp_all add: domF_def HC_F3_def)
by (auto simp add: Evset_def)

(* T3_F4 *)

lemma Ext_choice_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P [+] Q) (fstF o M), failures(P [+] Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)

apply (simp add: domF_iff HC_T3_F4_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="s" in spec)
by (auto)

(*** Ext_choice_domF ***)

lemma Ext_choice_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P [+] Q) (fstF o M), failures(P [+] Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Ext_choice_T2)
apply (simp add: Ext_choice_F3)
apply (simp add: Ext_choice_T3_F4)
done

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

(* T2 *)

lemma Int_choice_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P |~| Q) (fstF o M), failures(P |~| Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (simp add: domF_def HC_T2_def)
by (auto)

(* F3 *)

lemma Int_choice_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P |~| Q) (fstF o M), failures(P |~| Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (simp add: domF_def HC_F3_def)
by (auto)

(* T3_F4 *)

lemma Int_choice_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P |~| Q) (fstF o M), failures(P |~| Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (simp add: domF_iff HC_T3_F4_def)
by (auto)

(*** Int_choice_domF ***)

lemma Int_choice_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P |~| Q) (fstF o M), failures(P |~| Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Int_choice_T2)
apply (simp add: Int_choice_F3)
apply (simp add: Int_choice_T3_F4)
done

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

(* T2 *)

lemma Union_proc_T2:
  "ALL c. (Tf c, Ff c) : domF
   ==> HC_T2 ({t. t = <> | (EX c:C. t :t Tf c)}t,
                         {f. EX c:C. f :f Ff c}f)"
apply (simp add: HC_T2_def)
apply (simp add: in_traces)
apply (simp add: in_failures)
apply (intro allI impI)
apply (elim conjE bexE exE)
apply (rule disjI2)
apply (drule_tac x="c" in spec)
apply (rule_tac x="c" in bexI)
apply (simp add: domF_def HC_T2_def)
by (auto)

lemma Rep_int_choice_T2 :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> HC_T2 (traces(!! :C .. Pf) (fstF o M), failures(!! :C .. Pf) M)"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_T2)
done

(* F3 *)

lemma Union_proc_F3:
  "ALL c. (Tf c, Ff c) : domF
   ==>
   HC_F3 ({t. t = <> | (EX c:C. t :t Tf c)}t,
          {f. EX c:C. f :f Ff c}f)"
apply (simp add: HC_F3_def)
apply (simp add: in_traces)
apply (simp add: in_failures)
apply (intro allI)
apply (intro impI)
apply (elim conjE bexE)
apply (rule_tac x="c" in bexI)
apply (drule_tac x="c" in spec)
apply (rule domF_F3)
apply (auto)
done

lemma Rep_int_choice_nat :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> HC_F3 (traces(!! :C .. Pf) (fstF o M), failures(!! :C .. Pf) M)"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_F3)
done

(* T3_F4 *)

lemma Union_proc_T3_F4:
  "ALL c. (Tf c, Ff c) : domF
   ==>
   HC_T3_F4 ({t. t = <> | (EX c:C. t :t Tf c)}t,
             {f. EX c:C. f :f Ff c}f)"
apply (simp add: HC_T3_F4_def)
apply (simp add: in_traces)
apply (simp add: in_failures)
apply (auto)
apply (rule_tac x="c" in bexI)
apply (rule domF_F4)
apply (simp_all)
apply (rule_tac x="c" in bexI)
apply (rule domF_T3)
apply (simp_all)
done

lemma Rep_int_choice_T3_F4 :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> HC_T3_F4 (traces(!! :C .. Pf) (fstF o M),
                   failures(!! :C .. Pf) M)"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_T3_F4)
done

(*** F ***)

lemma Union_proc_domF:
  "ALL c. (Tf c, Ff c) : domF
   ==> ({t. t = <> | (EX c:C. t :t Tf c)}t,
        {f. EX c:C. f :f Ff c}f) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Union_proc_T2)
apply (simp add: Union_proc_F3)
apply (simp add: Union_proc_T3_F4)
done

(*** Rep_int_choice_domF ***)

lemma Rep_int_choice_domF :
  "ALL c. (traces(Pf c) (fstF o M), failures(Pf c) M) : domF
     ==> (traces(!! :C .. Pf) (fstF o M), failures(!! :C .. Pf) M) : domF"
apply (simp add: traces_iff failures_iff)
apply (simp add: Union_proc_domF)
done

(*--------------------------------*
 |               IF               |
 *--------------------------------*)

(* T2 *)

lemma IF_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(IF b THEN P ELSE Q) (fstF o M),
                failures(IF b THEN P ELSE Q) M)"
by (simp add: HC_T2_def in_traces in_failures domF_def)

(* F3 *)

lemma IF_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(IF b THEN P ELSE Q) (fstF o M), failures(IF b THEN P ELSE Q) M)"
by (simp add: HC_F3_def in_traces in_failures domF_def)

(* T3_F4 *)

lemma IF_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(IF b THEN P ELSE Q) (fstF o M),
                   failures(IF b THEN P ELSE Q) M)"
by (simp add: HC_T3_F4_def in_traces in_failures domF_iff)

(*** IF_domF ***)

lemma IF_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(IF b THEN P ELSE Q) (fstF o M),
          failures(IF b THEN P ELSE Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: IF_T2)
apply (simp add: IF_F3)
apply (simp add: IF_T3_F4)
done

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

(*** T2 ***)

lemma Parallel_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (rule_tac x="t" in exI)
apply (simp)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="t" in spec)

apply (drule mp, rule_tac x="Y" in exI, simp)
apply (drule mp, rule_tac x="Z" in exI, simp)
by (simp)

(*** F3 ***)

lemma Parallel_F3_lm1: "X1 Un (X2 Un X3) - X = (X1 - X) Un (X2 - X) Un (X3 - X)"
by (auto)

lemma Parallel_F3_lm2: "[| X1 = X2 ; Y1 = Y2 |] ==> X1 Un Y1 = X2 Un Y2"
by (auto)

lemma Parallel_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rename_tac u X12 Y X1 X2 s t)

(* (u, X12) :f [[P |[X]| Q]]F *)
(* (s, X1)  :f [[P]]F         *)
(* (t, X2)  :f [[Q]]F         *)
(*  X12 = X1 Un X2               *)

apply (rule_tac x=
        "X1 Un
         ({a. a : Y & (a = Tick | a : Ev ` X) & s ^^^ <a> ~:t traces(P) (fstF o M)} Un
          {a. a : Y & a ~= Tick & a ~: Ev ` X})" in exI)       (* Z1 *)
apply (rule_tac x=
        "X2 Un
         ({a. a : Y & (a = Tick | a : Ev ` X) & t ^^^ <a> ~:t traces(Q) (fstF o M)} Un
          {a. a : Y & a ~= Tick & a ~: Ev ` X})" in exI)       (* Z2 *)

apply (subgoal_tac "noTick s & noTick t", simp)
apply (rule conjI)

(* show X12 Un Y = X1 Un Z1 Un Z2 *)
apply (rule equalityI)

 (* <= *)
 apply (rule subsetI, simp)
 apply (erule disjE, simp)
 apply (erule disjE, simp)
 apply (simp)

 apply (drule_tac x="x" in spec, simp)
 apply (drule_tac x="s ^^^ <x>" in spec)
 apply (drule_tac x="t ^^^ <x>" in spec)

  (* no sync *)
  apply (case_tac "x ~= Tick & x ~: Ev ` X", simp)
  (* sync *)
  apply (simp add: par_tr_last)
  apply (erule disjE, simp)
  apply (force)

  apply (rotate_tac -2)
  apply (erule disjE, simp)
  apply (force)
  apply (simp)
  apply (force)

 (* => *)
 apply (force)

apply (rule conjI)

 (* show X1 Un ... = X2 Un ... *)
 apply (simp add: Parallel_F3_lm1)
 apply (rule Parallel_F3_lm2)
 apply (rule Parallel_F3_lm2)
 apply (simp)
 apply (force)
 apply (simp)

 (* condition 2 *)
 apply (rule_tac x="s" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)

 apply (simp add: domF_def HC_F3_def)
 apply (elim conjE)
 apply (drule_tac x="s" in spec)
 apply (drule_tac x="t" in spec)
 apply (drule_tac x="X1" in spec)
 apply (drule_tac x="X2" in spec)
 apply (drule_tac x=
   "{a. a : Y & (a = Tick | a : Ev ` X) & s ^^^ <a> ~:t traces(P) (fstF o M)} Un
    {a. a : Y & a ~= Tick & a ~: Ev ` X}" in spec)
 apply (drule_tac x=
   "{a. a : Y & (a = Tick | a : Ev ` X) & t ^^^ <a> ~:t traces(Q) (fstF o M)} Un
    {a. a : Y & a ~= Tick & a ~: Ev ` X}" in spec)
 apply (simp)

 (* left *)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (drule_tac x="s ^^^ <a>" in spec)
  apply (drule_tac x="t" in spec)
  apply (erule disjE)
  apply (simp add: par_tr_last)
  apply (fast)

  apply (erule disjE, simp)
  apply (simp add: HC_T2_def)
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="t" in spec)
  apply (force)

 (* right *)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="t ^^^ <a>" in spec)
  apply (erule disjE)
  apply (simp add: par_tr_last)
  apply (fast)

  apply (erule disjE)
  apply (simp add: HC_T2_def)
  apply (drule_tac x="s" in spec)
  apply (drule_tac x="t" in spec)
  apply (force)
  apply (simp)
 apply (simp)

(* notick s & notick t *)
apply (simp add: par_tr_noTick_decompo)
done

(* T3_F4 *)

lemma Parallel_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp add: par_tr_last)
apply (elim conjE exE)
apply (rule conjI)

 (* F4 *)
 apply (rule_tac x="Evset" in exI)
 apply (rule_tac x="Evset" in exI)
 apply (simp)
 apply (rule_tac x="s'" in exI)
 apply (rule_tac x="t'" in exI)
 apply (simp add: domF_def HC_F4_def)

 (* T3 *)
 apply (rule allI)
 apply (rule_tac x="Xa" in exI)
 apply (rule_tac x="Xa" in exI)
 apply (simp)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp add: domF_def HC_T3_def)
 apply (fast)
done

(*** Parallel_domF ***)

lemma Parallel_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P |[X]| Q) (fstF o M), failures(P |[X]| Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Parallel_T2)
apply (simp add: Parallel_F3)
apply (simp add: Parallel_T3_F4)
done

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

(*** T2 ***)

lemma Hiding_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T2 (traces(P -- X) (fstF o M), failures(P -- X) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(*** F3 ***)

lemma Hiding_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_F3 (traces(P -- X) (fstF o M), failures(P -- X) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rename_tac t Y Z s)
apply (rule_tac x="s" in exI, simp)

apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="Ev ` X Un Y" in spec)
apply (drule_tac x="Z - Ev ` X" in spec)
apply (simp)

apply (drule mp)
 apply (intro allI impI)
 apply (drule_tac x="a" in spec)
 apply (simp)

 apply (insert event_Tick_or_Ev)
 apply (drule_tac x="a" in spec)
 apply (erule disjE)
  (* Tick *)
  apply (drule_tac x="s ^^^ <Tick>" in spec)
  apply (simp)
  (* Ev *)
  apply (elim conjE exE)
  apply (drule_tac x="s ^^^ <Ev aa>" in spec)
  apply (simp)
  apply (subgoal_tac "aa ~: X", simp_all)
  apply (force)

apply (subgoal_tac "Ev ` X Un Y Un (Z - Ev ` X) = Ev ` X Un (Y Un Z)", simp)
by (auto)

(* T3_F4 *)

lemma Hiding_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T3_F4 (traces(P -- X) (fstF o M), failures(P -- X) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (drule sym)
apply (simp add: hide_tr_decompo)
apply (elim conjE exE)
apply (rotate_tac -1)
apply (drule sym)

apply (subgoal_tac "(EX t''. t' = t'' ^^^ <Tick> & sett t'' <= Ev ` X)")
 apply (elim conjE exE)
 apply (simp)

 (* F4 *)
 apply (rule conjI)
  apply (rule_tac x="s' ^^^ t''" in exI)
  apply (simp)
  apply (subgoal_tac "t'' --tr X = <>", simp)
   apply (simp add: domF_def HC_F4_def)
   apply (elim conjE)
   apply (drule_tac x="s' ^^^ t''" in spec)
   apply (subgoal_tac "noTick t''")
    apply (simp add: appt_assoc)
   apply (simp add: noTick_def)
   apply (force)
  apply (simp add: hide_tr_nilt_sett)

 (* T3 *)
 apply (rule allI)
 apply (rule_tac x="sa" in exI, simp)
 apply (simp add: domF_def HC_T3_def)
 apply (elim conjE)
 apply (drule_tac x="s' ^^^ t''" in spec, simp)
 apply (subgoal_tac "noTick t''")
  apply (simp add: appt_assoc)
 apply (simp add: noTick_def)
 apply (force)

apply (auto simp add: hide_tr_Tick_sett)
done

(*** Hiding_domF ***)

lemma Hiding_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> (traces(P -- X) (fstF o M), failures(P -- X) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Hiding_T2)
apply (simp add: Hiding_F3)
apply (simp add: Hiding_T3_F4)
done

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

(*** T2 ***)

lemma Renaming_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T2 (traces(P [[r]]) (fstF o M), failures(P [[r]]) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
by (force)

(*** F3 ***)

lemma Renaming_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_F3 (traces(P [[r]]) (fstF o M), failures(P [[r]]) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (rule_tac x="sa" in exI, simp)

apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="sa" in spec)
apply (drule_tac x="[[r]]inv X" in spec)
apply (drule_tac x="[[r]]inv Y" in spec)

apply (drule mp)
 apply (simp add: ren_tr_noTick_right)
 apply (intro allI impI)
 apply (simp add: ren_inv_def)
 apply (erule bexE)
 apply (fold ren_inv_def)
 apply (drule_tac x="eb" in spec, simp)

  (* Tick *)
  apply (erule disjE)
  apply (drule_tac x=" sa ^^^ <a>" in spec)
  apply (simp add: ren_tr_noTick_right)
  (* Ev *)
  apply (elim conjE exE)
  apply (drule_tac x=" sa ^^^ <Ev aa>" in spec)
  apply (simp add: ren_tr_noTick_right)
by (simp)

(* T3_F4 *)

lemma Renaming_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T3_F4 (traces(P [[r]]) (fstF o M), failures(P [[r]]) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp add: ren_tr_appt_decompo)
apply (elim conjE exE)
apply (case_tac "~ noTick s1", simp)
apply (simp)

 (* F4 *)
 apply (rule conjI)
 apply (rule_tac x="s1" in exI, simp)
 apply (simp add: domF_def HC_F4_def)
 apply (elim conjE)
 apply (drule_tac x="s1" in spec, simp)
 apply (rule memF_F2, simp, simp)

 (* T3 *)
 apply (rule allI)
 apply (rule_tac x="s1 ^^^ <Tick>" in exI)
 apply (simp add: domF_def HC_T3_def)
 apply (fast)
done

(*** Renaming_domF ***)

lemma Renaming_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> (traces(P [[r]]) (fstF o M), failures(P [[r]]) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Renaming_T2)
apply (simp add: Renaming_F3)
apply (simp add: Renaming_T3_F4)
done

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

(*** T2 ***)

lemma Seq_compo_T2 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T2 (traces(P ;; Q) (fstF o M), failures(P ;; Q) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI)
apply (rule conjI)

 (* case 1 *)
 apply (intro impI)
 apply (rule disjI1)
 apply (rule_tac x="s" in exI, simp)
 apply (simp add: domF_def HC_T2_def)
 apply (elim conjE)
 apply (drule_tac x="s" in spec)
 apply (force)

 (* case 2 *)
 apply (intro impI)
 apply (elim conjE exE disjE)
 apply (rule disjI2)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp add: domF_def HC_T2_def)
 apply (elim conjE)
 apply (rotate_tac 4)
 apply (drule_tac x="t" in spec)
 apply (force)
done

(*** F3 ***)

lemma Seq_compo_F3 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_F3 (traces(P ;; Q) (fstF o M), failures(P ;; Q) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE disjE)

 (* case 1 *)
 apply (simp add: domF_def HC_F3_def)
 apply (elim conjE)
 apply (drule_tac x="s" in spec)
 apply (drule_tac x="insert Tick X" in spec)
 apply (drule_tac x="Y-{Tick}" in spec)
 apply (simp)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (simp add: not_Tick_to_Ev)
  apply (elim conjE exE, simp)
  apply (rotate_tac -3)
  apply (drule_tac x="s ^^^ <Ev aa>" in spec, simp)
 apply (subgoal_tac
   "insert Tick (X Un (Y - {Tick})) = insert Tick (X Un Y)", simp)
 apply (force)

 (* case 2 *)
 apply (simp add: domF_def HC_F3_def)
 apply (elim conjE)
 apply (rotate_tac -2)
 apply (drule_tac x="t" in spec)
 apply (drule_tac x="X" in spec)
 apply (drule_tac x="Y" in spec)
 apply (simp)
 apply (drule mp)
  apply (intro allI impI)
  apply (drule_tac x="a" in spec, simp)
  apply (elim conjE)
  apply (rotate_tac -1)
  apply (drule_tac x="sa" in spec)
  apply (rotate_tac -1)
  apply (drule_tac x="t ^^^ <a>" in spec)
  apply (simp add: appt_assoc)
 apply (rule disjI2)
 apply (rule_tac x="sa" in exI)
 apply (rule_tac x="t" in exI)
 apply (simp)
done

(* T3_F4 *)

lemma Seq_compo_T3_F4 :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> HC_T3_F4 (traces(P ;; Q) (fstF o M), failures(P ;; Q) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE disjE)

 (* case 1 *)
 apply (elim conjE exE)
 apply (subgoal_tac "noTick (s ^^^ <Tick>) ~= noTick (rmTick sa)", simp)
 apply (simp (no_asm_use))
 apply (drule sym)
 apply (simp)

 (* case 2 *)
 apply (elim conjE exE)
 apply (case_tac "~ noTick sa", simp)
 apply (insert trace_last_nil_or_unnil)
 apply (drule_tac x="t" in spec)
 apply (simp)
  (* <> *)
  apply (erule disjE)
  apply (rotate_tac -5)
  apply (drule_tac sym, simp)   (* contradict *)

  (* ... <Tick> *)
  apply (elim conjE exE, simp)
  apply (simp add: appt_assoc_sym)
  apply (erule conjE)
  apply (rule conjI)

   (* F4 *)
   apply (rule disjI2)
   apply (rule_tac x="sa" in exI)
   apply (rule_tac x="sb" in exI)
   apply (simp add: domF_def HC_F4_def)

   (* T3 *)
   apply (rule allI)
   apply (rule_tac x="sa" in exI)
   apply (rule_tac x="t" in exI)
   apply (simp add: appt_assoc_sym domF_def HC_T3_def)
done

(*** Seq_compo_domF ***)

lemma Seq_compo_domF :
  "[| (traces(P) (fstF o M), failures(P) M) : domF ;
      (traces(Q) (fstF o M), failures(Q) M) : domF |]
     ==> (traces(P ;; Q) (fstF o M), failures(P ;; Q) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Seq_compo_T2)
apply (simp add: Seq_compo_F3)
apply (simp add: Seq_compo_T3_F4)
done

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

(*** T2 ***)

lemma Depth_rest_T2 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T2 (traces(P |. n) (fstF o M), failures(P |. n) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp add: domF_def HC_T2_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
by (force)

(*** F3 ***)

lemma Depth_rest_F3 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_F3 (traces(P |. n) (fstF o M), failures(P |. n) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)

apply (simp add: domF_def HC_F3_def)
apply (elim conjE)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
apply (drule_tac x="Y" in spec)
apply (simp)
apply (erule disjE)
apply (simp)
apply (simp)
apply (elim conjE exE)
apply (simp)
done

(* T3_F4 *)

lemma Depth_rest_T3_F4 :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> HC_T3_F4 (traces(P |. n) (fstF o M), failures(P |. n) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (elim conjE exE)
apply (simp)

 (* F4 *)
 apply (rule conjI)
 apply (simp add: domF_def HC_F4_def)

 (* T3 *)
 apply (simp add: domF_def HC_T3_def)
 apply (case_tac "Suc (lengtht s) < n")
 apply (simp)
 apply (simp)
 apply (fast)
done

(*** Depth_rest_domF ***)

lemma Depth_rest_domF :
  "(traces(P) (fstF o M), failures(P) M) : domF
   ==> (traces(P |. n) (fstF o M), failures(P |. n) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Depth_rest_T2)
apply (simp add: Depth_rest_F3)
apply (simp add: Depth_rest_T3_F4)
done

(*--------------------------------*
 |        Proc_name_dom           |
 *--------------------------------*)

(*** T2 ***)

lemma Proc_name_T2 :
  "HC_T2 (traces ($p) (fstF o M), failures ($p) M)"
apply (simp add: HC_T2_def in_traces in_failures)
apply (intro allI impI)
apply (elim exE)
apply (simp add: pairF_domF_T2)
done

(*** F3 ***)

lemma Proc_name_F3 :
  "HC_F3 (traces ($p) (fstF o M), failures ($p) M)"
apply (simp add: HC_F3_def in_traces in_failures)
apply (intro allI impI)
apply (simp add: pairF_domF_F3)
done

(* T3_F4 *)

lemma Proc_name_T3_F4 :
  "HC_T3_F4 (traces ($p) (fstF o M), failures ($p) M)"
apply (simp add: HC_T3_F4_def in_traces in_failures)
apply (intro allI impI)
apply (simp add: pairF_domF_T3)
apply (simp add: pairF_domF_F4)
done

(*** Proc_name_domF ***)

lemma Proc_name_domF :
  "(traces ($p) (fstF o M), failures ($p) M) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: Proc_name_T2)
apply (simp add: Proc_name_F3)
apply (simp add: Proc_name_T3_F4)
done

(*--------------------------------*
 |             proc               |
 *--------------------------------*)

declare o_apply [simp del]

lemma proc_domF[simp]: "(traces(P) (fstF o M), failures(P) M) : domF"
apply (induct_tac P)
apply (simp add: STOP_domF)
apply (simp add: SKIP_domF)
apply (simp add: DIV_domF)
apply (simp add: Act_prefix_domF)
apply (simp add: Ext_pre_choice_domF)
apply (simp add: Ext_choice_domF)
apply (simp add: Int_choice_domF)
apply (simp add: Rep_int_choice_domF)
apply (simp add: IF_domF)
apply (simp add: Parallel_domF)
apply (simp add: Hiding_domF)
apply (simp add: Renaming_domF)
apply (simp add: Seq_compo_domF)
apply (simp add: Depth_rest_domF)
apply (simp add: Proc_name_domF)
done

declare o_apply [simp]

(*--------------------------------*
 |          fstF sndF             |
 *--------------------------------*)

lemma fstF_proc_domF[simp]:
   "fstF (traces(P) (fstF o M),, failures(P) M) = traces(P) (fstF o M)"
by (simp add: pairF)

lemma sndF_proc_domF[simp]:
   "sndF (traces(P) (fstF o M),, failures(P) M) = failures(P) M"
by (simp add: pairF)

lemma fstF_proc_domF2[simp]:
   "fstF (traces(P) (%x. fstF (M x)),, failures(P) M) = traces(P) (fstF o M)"
apply (fold comp_def)
apply (simp)
done

lemma sndF_proc_domF2[simp]:
   "sndF (traces(P) (%x. fstF (M x)),, failures(P) M) = failures(P) M"
apply (fold comp_def)
apply (simp)
done

lemma fstF_proc_domF_fun:
   "fstF o (%p. (traces(f p) (fstF o M),, failures(f p) M))
     = (%p. traces(f p) (fstF o M))"
apply (unfold comp_def)
apply (fold comp_def)
apply (simp add: fun_eq_iff)
done

lemma sndF_proc_domF_fun:
   "sndF o (%p. (traces(f p) (fstF o M),, failures(f p) M))
     = (%p.  failures(f p) M)"
apply (unfold comp_def)
apply (fold comp_def)
apply (simp add: fun_eq_iff)
done

lemma fstF_semFf[simp]: "fstF ([[P]]Ff M) = traces(P) (fstF o M)"
by (simp add: semFf_def)

lemma fstF_semF[simp]: "fstF ([[P]]F) = traces(P) (fstF o MF)"
by (simp add: semF_def)

lemma sndF_semFf[simp]: "sndF ([[P]]Ff M) = failures(P) M"
by (simp add: semFf_def)

lemma sndF_semF[simp]: "sndF ([[P]]F) = failures(P) MF"
by (simp add: semF_def)

(*** decomposition ***)

lemma semFf_decompo:
  "([[P]]Ff M = SF) = ((traces P (fstF o M) = fstF SF) &
                        failures P M = sndF SF)"
apply (simp add: semFf_def)
apply (rule)
apply (drule sym)
apply (simp)
apply (simp)
done

lemma semF_decompo:
  "([[P]]F = SF) = ((traces P (fstF o MF) = fstF SF) &
                     failures P MF = sndF SF)"
apply (simp add: semF_def)
apply (simp add: semFf_decompo)
done

lemma semFf_decompo_fstF:
  "([[P]]Ff M = SF) ==> traces P (fstF o M) = fstF SF"
by (simp add: semFf_decompo)

lemma semF_decompo_fstF:
  "([[P]]F = SF) ==> traces P (fstF o MF) = fstF SF"
by (simp add: semF_decompo)

lemma semFf_decompo_sndF:
  "([[P]]Ff M = SF) ==>  failures P M = sndF SF"
by (simp add: semFf_decompo)

lemma semF_decompo_sndF:
  "([[P]]F = SF) ==>  failures P MF = sndF SF"
by (simp add: semF_decompo)

(*--------------------------------*
 |            [[$p]]Ff            |
 *--------------------------------*)

lemma semFf_Proc_name: "[[$p]]Ff = (%M. M p)"
apply (simp add: semFf_def)
apply (simp add: traces_iff)
apply (simp add: failures_iff)
done

(*--------------------------------*
 |          =F and <=F            |
 *--------------------------------*)

lemma cspF_eqF_semantics:
  "(P =F[M1,M2] Q) =
       ((traces P (fstF o M1) = traces Q (fstF o M2)) &
        (failures P M1 = failures Q M2))"
apply (simp add: eqF_def)
apply (simp add: semFf_def)
apply (simp add: eqF_decompo)
done

lemma cspF_refF_semantics:
  "(P <=F[M1,M2] Q) =
       ((traces Q (fstF o M2) <= traces P (fstF o M1)) &
        (failures Q M2 <= failures P M1))"
apply (simp add: refF_def)
apply (simp add: semFf_def)
apply (simp add: subdomF_decompo)
done

lemmas cspF_semantics = cspF_eqF_semantics  cspF_refF_semantics

lemma cspF_cspT_eqF_semantics:
  "(P =F[M1,M2] Q) =
       ((P =T[fstF o M1,fstF o M2] Q) &
        (failures P M1 = failures Q M2))"
apply (simp add: cspF_eqF_semantics)
apply (simp add: eqT_def)
apply (simp add: semTf_def)
done

lemma cspF_cspT_refF_semantics:
  "(P <=F[M1,M2] Q) =
       ((P <=T[fstF o M1,fstF o M2] Q) &
        (failures Q M2 <= failures P M1))"
apply (simp add: cspF_refF_semantics)
apply (simp add: refT_def)
apply (simp add: semTf_def)
done

lemmas cspF_cspT_semantics = cspF_cspT_eqF_semantics  cspF_cspT_refF_semantics

(*--------------------------------*
 |            Timeout             |
 *--------------------------------*)

lemma in_failures_Timeout1:
  "(f :f failures(P [> Q) M) =
   (f :f failures(Q) M |
   (EX s X. f = (s, X) & s ~= <> & (s, X) :f failures(P) M) |
   (EX X. f = (<>, X) & X <= Evset & <Tick> :t traces(P) (fstF o M)))"
apply (rule)

(* <= *)
 apply (simp add: in_failures)
 apply (elim conjE exE disjE)
 apply (simp_all)
 apply (simp add: in_traces)
 apply (rule disjI1)
 apply (rule domF_F2_F4, simp_all)

 (* <= *)
 apply (simp add: in_failures in_traces)
 apply (elim conjE exE disjE, simp_all)
 apply (auto elim: memF_pairE)
done

lemma in_failures_Timeout2:
  "(f :f failures(P [>def Q) M) =
   (f :f failures(Q) M |
   (EX s X. f = (s, X) & s ~= <> & (s, X) :f failures(P) M) |
   (EX X. f = (<>, X) & X <= Evset & <Tick> :t traces(P) (fstF o M)))"
apply (simp add: Timeout_def)
apply (simp add: in_failures_Timeout1)
done

lemmas in_failures_Timeout = in_failures_Timeout1 in_failures_Timeout2

(*--------------------------------*
 |           Depth rest           |
 *--------------------------------*)

lemma semFf_Depth_rest: "[[P |. n]]Ff M = [[P]]Ff M .|. n"
apply (simp add: semFf_def)
apply (simp add: traces.simps)
apply (simp add: failures.simps)
apply (simp add: rest_domF_def)
apply (simp add: restTF_def)
apply (simp add: pairF_def)
apply (simp add: Abs_domF_inverse)
apply (simp add: pair_restriction_def)
done

lemma semF_Depth_rest: "[[P |. n]]F = [[P]]F .|. n"
apply (simp add: semF_def)
apply (simp add: semFf_Depth_rest)
done

(*---------------------------------------------------*
 |         Healthiness conditions for proc           |
 *---------------------------------------------------*)

lemma proc_T2:
    "(s, X) :f failures(P) M ==> s :t traces(P) (fstF o M)"
apply (insert pairF_domF_T2[of "s" "X" "(traces(P) (fstF o M),, failures(P) M)"])
by (simp)

lemma proc_T3:
  "[| s ^^^ <Tick> :t traces(P) (fstF o M); noTick s |]
   ==> (s ^^^ <Tick>, X) :f failures(P) M"
apply (insert pairF_domF_T3[of "s" "(traces(P) (fstF o M),, failures(P) M)" "X"])
by (simp)

lemma proc_T3_Tick:
  "<Tick> :t traces(P) (fstF o M) ==> (<Tick>, X) :f failures(P) M"
apply (insert proc_T3[of "<>" P M X])
by (simp)

lemma proc_F4:
  "[| s ^^^ <Tick> :t traces(P) (fstF o M) ; noTick s |]
   ==> (s, Evset) :f failures(P) M"
apply (insert pairF_domF_F4[of "s" "(traces(P) (fstF o M),, failures(P) M)"])
by (simp)

lemma proc_F3:
  "[| (s, X) :f failures(P) M ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t  traces(P) (fstF o M)) |]
   ==> (s, X Un Y) :f  failures(P) M"
apply (insert pairF_domF_F3[of "s" "X" "(traces(P) (fstF o M),, failures(P) M)" "Y"])
by (simp)

lemma proc_F3I:
  "[| (s, X) :f failures(P) M ; noTick s ;
      (ALL a. a : Y --> s ^^^ <a> ~:t traces(P) (fstF o M)) ;
      Z = X Un Y |]
   ==> (s, Z) :f failures(P) M"
by (simp add: proc_F3)

(*** F2_F4 ***)

lemma proc_F2_F4:
  "[| s ^^^ <Tick> :t traces(P) (fstF o M) ; noTick s ; X <= Evset|]
   ==> (s, X) :f failures(P) M"
apply (insert pairF_domF_F2_F4[of "s" "(traces(P) (fstF o M),, failures(P) M)" "X"])
by (simp)

(*** T2_T3 ***)

lemma proc_T2_T3:
  "[| (s ^^^ <Tick>, X) :f failures(P) M ; noTick s |]
  ==> (s ^^^ <Tick>, Y) :f failures(P) M"
apply (rule proc_T3)
apply (rule proc_T2)
by (simp_all)

(*------------------------------------------------------*
 |   Union in domF  (used for generic internal choice   |
 *------------------------------------------------------*)

lemma non_empty_UnionT_UnionF_T2:
 "Ps ~= {} ==>
  HC_T2 (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
         UnionF {(failures P M) |P. P : Ps})"
apply (simp add: HC_T2_def)
apply (intro allI impI)
apply (subgoal_tac "{(traces P (fstF o M)) |P. P : Ps} ~= {}")
apply (simp)
apply (elim conjE bexE exE)
apply (simp)
apply (rule_tac x="traces Pa (fstF o M)" in exI)
apply (rule conjI)
apply (rule_tac x="Pa" in exI)
apply (simp)
apply (simp add: proc_T2)
by (auto)

lemma non_empty_UnionT_UnionF_F3:
 "Ps ~= {} ==>
  HC_F3 (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
         UnionF {(failures P M) |P. P : Ps})"
apply (simp add: HC_F3_def)
apply (intro allI impI)
apply (subgoal_tac "{(traces P (fstF o M)) |P. P : Ps} ~= {}")
apply (simp)
apply (elim conjE exE)
apply (simp)
apply (rule_tac x="failures Pa M" in exI)
apply (rule conjI)
apply (rule_tac x="Pa" in exI)
apply (simp)
apply (rule proc_F3)
apply (simp_all)
apply (intro allI impI)
apply (drule_tac x="a" in spec)
apply (simp)
apply (drule_tac x="traces Pa  (fstF o M)" in spec)
apply (erule disjE)
apply (drule_tac x="Pa" in spec)
apply (simp)
apply (simp)
apply (auto)
done

lemma non_empty_UnionT_UnionF_T3_F4:
 "Ps ~= {} ==>
  HC_T3_F4 (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
            UnionF {(failures P M) |P. P : Ps})"
apply (simp add: HC_T3_F4_def)
apply (intro allI impI)
apply (subgoal_tac "{(traces P (fstF o M)) |P. P : Ps} ~= {}")
apply (simp)
apply (elim conjE bexE exE)
apply (simp)
apply (rule conjI)
 apply (rule_tac x="failures Pa M" in exI)
 apply (rule conjI)
 apply (fast)
 apply (rule proc_F4)
 apply (simp_all)

 apply (rule allI)
 apply (rule_tac x="failures Pa M" in exI)
 apply (rule conjI)
 apply (fast)
 apply (rule proc_T3)
 apply (simp_all)
by (auto)

lemma non_empty_UnionT_UnionF_domF:
 "Ps ~= {} ==>
  (UnionT {(traces P (fstF o M)) |P. P : Ps} ,
   UnionF {(failures P M) |P. P : Ps}) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: non_empty_UnionT_UnionF_T2)
apply (simp add: non_empty_UnionT_UnionF_F3)
apply (simp add: non_empty_UnionT_UnionF_T3_F4)
done

(*------------------------------------------------------*
 |   Union in domF  (used for generic internal choice   |
 *------------------------------------------------------*)

lemma UnionT_UnionF_T2:
 "HC_T2 ({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
         {f. EX P:Ps. f :f failures(P) M}f )"
apply (simp add: HC_T2_def)
apply (intro allI impI)
apply (simp add: in_traces_Union_proc)
apply (simp add: in_failures_Union_proc)
apply (elim conjE bexE exE)
apply (rule disjI2)
apply (rule_tac x="P" in bexI)
apply (simp add: proc_T2)
apply (simp)
done

lemma UnionT_UnionF_F3:
 "HC_F3 ({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
         {f. EX P:Ps. f :f failures(P) M}f )"
apply (simp add: HC_F3_def)
apply (intro allI impI)
apply (simp add: in_traces_Union_proc)
apply (simp add: in_failures_Union_proc)
apply (elim conjE bexE exE)
apply (simp)
apply (rule_tac x="P" in bexI)
apply (rule proc_F3)
apply (simp_all)
done

lemma UnionT_UnionF_T3_F4:
 "HC_T3_F4 ({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
            {f. EX P:Ps. f :f failures(P) M}f )"
apply (simp add: HC_T3_F4_def)
apply (intro allI impI)
apply (simp add: in_traces_Union_proc)
apply (simp add: in_failures_Union_proc)
apply (elim conjE bexE exE)
apply (simp)
apply (elim bexE)
apply (rule conjI)
 apply (rule_tac x="P" in bexI)
 apply (rule proc_F4)
 apply (simp_all)

 apply (rule allI)
 apply (rule_tac x="P" in bexI)
 apply (rule proc_T3)
 apply (simp_all)
done

lemma UnionT_UnionF_domF:
 "({t. t = <> | (EX P:Ps. t :t traces(P) (fstF o M)) }t ,
            {f. EX P:Ps. f :f failures(P) M}f) : domF"
apply (simp (no_asm) add: domF_iff)
apply (simp add: UnionT_UnionF_T2)
apply (simp add: UnionT_UnionF_F3)
apply (simp add: UnionT_UnionF_T3_F4)
done

(*-----------------------------------------*
 |              substitution               |
 *-----------------------------------------*)

lemma semF_subst:
  "[[P<<f]]F = [[P]]Ff (%q. [[f q]]F)"
apply (induct_tac P)
apply (simp add: semF_def semFf_def,
       simp add: eqF_decompo,
       simp add: traces_iff failures_iff)+
done

lemma semF_subst_semFfun:
  "(%q. [[ (Pf q)<<f ]]F) = ([[Pf]]Ffun (%q. [[f q]]F))"
apply (simp add: semFfun_def)
apply (simp add: fun_eq_iff)
apply (rule allI)
apply (simp add: semF_subst)
done

lemma failrues_subst:
  "failures(P<<f) M = failures P (%q. [[f q]]Ff M)"
apply (induct_tac P)
apply (simp_all add: semF_def semFf_def traces_iff failures_iff)+
apply (simp add: fstF_proc_domF_fun)
apply (simp add: traces_subst)

apply (simp add: fstF_proc_domF_fun)
apply (simp add: traces_subst)
done

(*-----------------------------------------*
 |               semT -- semF              |
 *-----------------------------------------*)

lemma semTfun_fstF_semFf:
  "[[Pf]]Tfun (fstF o M) p = fstF ([[Pf p]]Ff M)"
apply (simp add: semTfun_def)
apply (simp add: semTf_def)
done

(****************** to add them again ******************)

declare disj_not1   [simp]

end


text\<open>Facts about beta normalization involving theories\<close>

theory BetaNormProof
  imports BetaNorm Theory
begin

lemma beta_preserves_term_ok': "term_ok' \<Sigma> r \<Longrightarrow> r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> term_ok' \<Sigma> s"
proof (induction r arbitrary: s)
  case (Ct n T)
  then show ?case
    apply (simp add: tinstT_def split: option.splits)
    (* Seems like I miss a simp rule for Ct*)
    using beta_reducible.simps(7) beta_step_imp_beta_reducible by blast
next
  case (Fv n T)
  then show ?case
    by auto
next
  case (Bv n)
  then show ?case
    by auto
next
  case (Abs R r)
  then show ?case
    by auto
next
  case (App f u)
  then show ?case
    apply -
    apply (ind_cases "f $ u \<rightarrow>\<^sub>\<beta> s" for f u s)
    using term_ok'_subst_bv2 term_ok'.simps(4) term_ok'.simps(5) apply blast
    using term_ok'.simps(4) apply blast
    using term_ok'.simps(4) apply blast
    done
qed

lemma beta_preserves_term_ok: "term_ok \<Theta> r \<Longrightarrow> r \<rightarrow>\<^sub>\<beta> s \<Longrightarrow> term_ok \<Theta> s"
proof -
  assume a1: "term_ok \<Theta> r"
  assume a2: "r \<rightarrow>\<^sub>\<beta> s"
  then have "None \<noteq> typ_of1 [] s"
    using a1 beta_preserves_typ_of1
    by (metis has_typ1_imp_typ_of1 has_typ_def option.distinct(1) term_ok_def wt_term_def)
  then show ?thesis
    using a2 a1 beta_preserves_term_ok' has_typ_iff_typ_of wt_term_def typ_of_def
    by (meson beta_preserves_typ_of term_ok_def wf_term_iff_term_ok')
qed

lemma beta_star_preserves_term_ok': "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> term_ok' \<Sigma> r  \<Longrightarrow> term_ok' \<Sigma> s"
  by (induction rule: rtranclp.induct) (auto simp add: beta_preserves_term_ok')

corollary beta_star_preserves_term_ok: "r \<rightarrow>\<^sub>\<beta>\<^sup>* s \<Longrightarrow> term_ok thy r  \<Longrightarrow> term_ok thy s"
  using beta_star_preserves_term_ok' beta_star_preserves_typ_of1 wt_term_def typ_of_def by auto

corollary term_ok_beta_norm: "term_ok thy t \<Longrightarrow> beta_norm t = Some t'\<Longrightarrow> term_ok thy t'"
  using beta_norm_imp_beta_reds beta_star_preserves_term_ok by blast

end


(* Authors: Lammich, Wimmer *)
theory Recursion_Combinators
  imports "../../Refine_Imperative_HOL/IICF/IICF"
    "../../Refine_Foreach"
begin

context
begin

private definition for_comb where
  "for_comb f a0 n = nfoldli [0..<n + 1] (\<lambda> x. True) (\<lambda> k a. (f a k)) a0"

fun for_rec :: "('a \<Rightarrow> nat \<Rightarrow> 'a nrest) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a nrest" where
  "for_rec f a 0 = f a 0" |
  "for_rec f a (Suc n) = for_rec f a n \<bind> (\<lambda> x. f x (Suc n))"

lemma nfoldli_simps':
  "nfoldli [] c f = RETURNT" apply(rule ext) by auto

private lemma for_comb_for_rec: "for_comb f a n = for_rec f a n"
unfolding for_comb_def
proof (induction f a n rule: for_rec.induct)
  case 1 then show ?case by (auto simp: pw_eq_iff refine_pw_simps)
next
  case IH: (2 a n)
  from this[symmetric] show ?case apply (auto simp: nfoldli_append)
    apply(rule antisym)
    subgoal by (auto intro!: bindT_mono simp add: nfoldli_simps')
    subgoal by (auto intro!: bindT_mono simp add: nfoldli_simps')
    done
qed

private definition for_rec2' where
  "for_rec2' f a n i j =
    (if i = 0 then RETURNT a else for_rec (\<lambda>a i. for_rec (\<lambda> a. f a i) a n) a (i - 1))
    \<bind> (\<lambda> a. for_rec (\<lambda> a. f a i) a j)"

fun for_rec2 :: "('a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nrest) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nrest" where
  "for_rec2 f a n 0 0 = f a 0 0" |
  "for_rec2 f a n (Suc i) 0 = for_rec2 f a n i n \<bind> (\<lambda> a. f a (Suc i) 0)" |
  "for_rec2 f a n i (Suc j) = for_rec2 f a n i j \<bind> (\<lambda> a. f a i (Suc j))"

private lemma for_rec2_for_rec2':
  "for_rec2 f a n i j = for_rec2' f a n i j"
unfolding for_rec2'_def
 apply (induction f a n i j rule: for_rec2.induct)
 apply simp_all
 subgoal for f a n i
  apply (cases i)
 by auto
done

fun for_rec3 :: "('a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nrest) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nrest"
where
  "for_rec3 f m n 0       0       0        = f m 0 0 0" |
  "for_rec3 f m n (Suc k) 0       0        = for_rec3 f m n k n n \<bind> (\<lambda> a. f a (Suc k) 0 0)" |
  "for_rec3 f m n k       (Suc i) 0        = for_rec3 f m n k i n \<bind> (\<lambda> a. f a k (Suc i) 0)" |
  "for_rec3 f m n k       i       (Suc j)  = for_rec3 f m n k i j \<bind> (\<lambda> a. f a k i (Suc j))"

private definition for_rec3' where
  "for_rec3' f a n k i j =
    (if k = 0 then RETURNT a else for_rec (\<lambda>a k. for_rec2' (\<lambda> a. f a k) a n n n) a (k - 1))
    \<bind> (\<lambda> a. for_rec2' (\<lambda> a. f a k) a n i j)"

private lemma for_rec3_for_rec3':
  "for_rec3 f a n k i j = for_rec3' f a n k i j"
unfolding for_rec3'_def
 apply (induction f a n k i j rule: for_rec3.induct)
 apply (simp_all add: for_rec2_for_rec2'[symmetric])
 subgoal for f a n k
  apply (cases k)
 by auto
done

private lemma for_rec2'_for_rec:
  "for_rec2' f a n n n =
    for_rec (\<lambda>a i. for_rec (\<lambda> a. f a i) a n) a n"
unfolding for_rec2'_def by (cases n) auto

private lemma for_rec3'_for_rec:
  "for_rec3' f a n n n n =
    for_rec (\<lambda> a k. for_rec (\<lambda>a i. for_rec (\<lambda> a. f a k i) a n) a n) a n"
unfolding for_rec3'_def for_rec2'_for_rec by (cases n) auto

theorem for_rec_eq:
  "for_rec f a n = nfoldli [0..<n + 1] (\<lambda>x. True) (\<lambda>k a. f a k) a"
using for_comb_for_rec[unfolded for_comb_def, symmetric] .

theorem for_rec2_eq:
  "for_rec2 f a n n n =
     nfoldli [0..<n + 1] (\<lambda>x. True)
           (\<lambda>i. nfoldli [0..<n + 1] (\<lambda>x. True) (\<lambda>j a. f a i j)) a"
using
  for_rec2'_for_rec[
    unfolded for_rec2_for_rec2'[symmetric], unfolded for_comb_for_rec[symmetric] for_comb_def
  ] .

theorem for_rec3_eq:
  "for_rec3 f a n n n n =
    nfoldli [0..<n + 1] (\<lambda>x. True)
     (\<lambda>k. nfoldli [0..<n + 1] (\<lambda>x. True)
           (\<lambda>i. nfoldli [0..<n + 1] (\<lambda>x. True) (\<lambda>j a. f a k i j)))
     a"
using
  for_rec3'_for_rec[
    unfolded for_rec3_for_rec3'[symmetric], unfolded for_comb_for_rec[symmetric] for_comb_def
  ] .

end

lemmas [intf_of_assn] = intf_of_assnI[where R= "is_mtx n" and 'a= "'b i_mtx" for n]

declare param_upt[sepref_import_param]

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory SubMonadLib
imports
  Monads.Empty_Fail
  Corres_UL
begin

locale submonad_args =
  fixes fetch :: "'a \<Rightarrow> 'b"
  fixes replace :: "'b \<Rightarrow> 'a \<Rightarrow> 'a"
  fixes guard :: "'a \<Rightarrow> bool"

  assumes args:
   "\<forall>x s. guard s \<longrightarrow> fetch (replace x s) = x"
   "\<forall>x y s. replace x (replace y s) = replace x s"
   "\<forall>s. replace (fetch s) s = s"

  assumes replace_preserves_guard:
   "\<And>s x. guard (replace x s) = guard s"

definition
  submonad_fn :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow>
                  ('b, 'c) nondet_monad \<Rightarrow> ('a, 'c) nondet_monad"
where
 "submonad_fn fetch replace guard m \<equiv> do
    stateAssert guard [];
    substate \<leftarrow> gets fetch;
    (rv, substate') \<leftarrow> select_f (m substate);
    modify (replace substate');
    return rv
  od"

locale submonad = submonad_args +
  fixes fn :: "('b, 'c) nondet_monad \<Rightarrow> ('a, 'c) nondet_monad"

  assumes fn_is_sm: "fn = submonad_fn fetch replace guard"

lemma (in submonad_args) argsD1:
  "\<And>x s. guard s \<Longrightarrow> fetch (replace x s) = x"
  by (simp add: args)

lemma (in submonad) guarded_sm:
  "\<And>s. guard s \<Longrightarrow>
   fn m s = (do
     substate \<leftarrow> gets fetch;
     (rv, substate') \<leftarrow> select_f (m substate);
     modify (replace substate');
     return rv
   od) s"
  unfolding fn_is_sm submonad_fn_def
  by (simp add: stateAssert_def get_def assert_def bind_def return_def)

lemma modify_modify:
  "modify fn1 >>= (\<lambda>x. modify fn2) = modify (fn2 \<circ> fn1)"
  by (simp add: bind_def modify_def get_def put_def)

lemma select_f_walk:
  assumes m1: "empty_fail m1"
  assumes S: "fst S = {} \<Longrightarrow> snd S"
  shows "(do a \<leftarrow> m1; b \<leftarrow> select_f S; m2 a b od) = (do b \<leftarrow> select_f S; a \<leftarrow> m1; m2 a b od)"
  apply (rule ext)
  apply (rule prod.expand)
  apply (rule conjI)
   apply (simp add: select_f_def bind_def split_def)
   apply fastforce
  apply (simp add: select_f_def bind_def split_def)
  apply (case_tac "fst S = {}")
   apply clarsimp
   apply (case_tac "fst (m1 x) = {}")
    apply (simp add: empty_failD [OF m1] S)
   apply (frule S)
   apply force
  apply safe
     apply clarsimp
     apply force
    apply force
   apply clarsimp
   apply force
  apply clarsimp
  apply (case_tac "fst (m1 x) = {}", simp add: empty_failD [OF m1])
  apply force
  done

lemma stateAssert_stateAssert:
  "(stateAssert g [] >>= (\<lambda>u. stateAssert g' [])) = stateAssert (g and g') []"
  by (simp add: ext stateAssert_def bind_def get_def assert_def fail_def return_def)

lemma modify_stateAssert:
  "\<lbrakk> \<And>s x. g (r x s) = g s \<rbrakk> \<Longrightarrow>
   (modify (r x) >>= (\<lambda>u. stateAssert g []))
            = (stateAssert g [] >>= (\<lambda>u. modify (r x)))"
  by (simp add: ext stateAssert_def bind_def get_def assert_def fail_def
                return_def modify_def put_def)

lemma gets_stateAssert:
  "(gets f >>= (\<lambda>x. stateAssert g' [] >>= (\<lambda>u. m x)))
            = (stateAssert g' [] >>= (\<lambda>u. gets f >>= (\<lambda>x. m x)))"
  by (simp add: ext stateAssert_def bind_def gets_def get_def
                assert_def fail_def return_def)

lemma select_f_stateAssert:
  "empty_fail m \<Longrightarrow>
   (select_f (m a) >>= (\<lambda>x. stateAssert g [] >>= (\<lambda>u. n x))) =
   (stateAssert g [] >>= (\<lambda>u. select_f (m a) >>= (\<lambda>x. n x)))"
  apply (rule ext)
  apply (clarsimp simp: stateAssert_def bind_def select_f_def get_def
                        assert_def return_def fail_def split_def image_image)
  apply (simp only: image_def)
  apply (clarsimp simp: stateAssert_def bind_def select_f_def get_def
                        assert_def return_def fail_def split_def image_image)
  apply (simp only: image_def mem_simps empty_fail_def simp_thms)
  apply fastforce
  done

lemma bind_select_f_bind':
  shows "(select_f (m s) >>= (\<lambda>x. select_f (split n x))) = (select_f ((m >>= n) s))"
  apply (rule ext)
  apply (force simp: select_f_def bind_def split_def)
  done

lemma bind_select_f_bind:
  "(select_f (m1 s) >>= (\<lambda>x. select_f (m2 (fst x) (snd x)))) = (select_f ((m1 >>= m2) s))"
  by (insert bind_select_f_bind' [where m=m1 and n=m2 and s=s],
      simp add: split_def)

lemma select_from_gets: "select_f (gets f s) = return (f s, s)"
  apply (rule ext)
  apply (simp add: select_f_def return_def simpler_gets_def)
  done

lemma select_from_gets':
  "(select_f \<circ> gets f) = (\<lambda>s. return (f s, s))"
  apply (rule ext)
  apply (simp add: o_def select_from_gets)
  done

lemma bind_subst_lift:
  "(f >>= g) = h \<Longrightarrow> (do x \<leftarrow> f; y \<leftarrow> g x; j y od) = (h >>= j)"
  by (simp add: bind_assoc[symmetric])

lemma modify_gets:
  "\<lbrakk> \<And>x s. g (r x s) = g s; \<And>x s. g s \<longrightarrow> f (r x s) = x \<rbrakk>
   \<Longrightarrow> (modify (r x) >>= (\<lambda>u. stateAssert g [] >>= (\<lambda>u'. gets f)))
            = (stateAssert g [] >>= (\<lambda>u'. modify (r x) >>= (\<lambda>u. return x)))"
  by (simp add: ext stateAssert_def assert_def modify_def bind_def get_def
                put_def gets_def return_def fail_def)

lemma (in submonad_args) gets_modify:
  "\<And>s. guard s \<Longrightarrow>
   (do x \<leftarrow> gets fetch; u \<leftarrow> modify (replace x); f x od) s = ((gets fetch) >>= f) s"
  by (clarsimp simp: modify_def gets_def return_def bind_def
                     put_def args get_def
              split: option.split)

lemma submonad_bind:
  "\<lbrakk> submonad f r g m; submonad f r g m'; submonad f r g m'';
     empty_fail a; \<And>x. empty_fail (b x) \<rbrakk> \<Longrightarrow>
   m (a >>= b) = (m' a) >>= (\<lambda>rv. m'' (b rv))"
  apply (subst submonad.fn_is_sm, assumption)+
  apply (clarsimp simp: submonad_def bind_assoc split_def submonad_fn_def)
  apply (subst bind_subst_lift [OF modify_gets, unfolded bind_assoc])
    apply (simp add: submonad_args.args submonad_args.replace_preserves_guard)+
  apply (subst select_f_stateAssert, assumption)
  apply (subst gets_stateAssert)
  apply (subst bind_subst_lift [OF stateAssert_stateAssert])
  apply (clarsimp simp: bind_assoc split_def select_f_walk empty_failD pred_conj_def
                        bind_subst_lift[OF modify_modify] submonad_args.args o_def
                        bind_subst_lift[OF bind_select_f_bind])
  done

lemma (in submonad) guard_preserved:
  "\<And>s s'. \<lbrakk> (rv, s') \<in> fst (fn m s) \<rbrakk> \<Longrightarrow> guard s'"
  unfolding fn_is_sm submonad_fn_def
  by (clarsimp simp: stateAssert_def gets_def get_def bind_def modify_def put_def
                     return_def select_f_def replace_preserves_guard in_monad)

lemma fst_stateAssertD:
  "\<And>s s' v. (v, s') \<in> fst (stateAssert g [] s) \<Longrightarrow> s' = s \<and> g s"
  by (clarsimp simp: stateAssert_def in_monad)

lemma(in submonad) guarded_gets:
  "\<And>s. guard s \<Longrightarrow> fn (gets f) s = gets (f \<circ> fetch) s"
  apply (simp add: guarded_sm select_from_gets gets_modify)
  apply (simp add: gets_def)
  done

lemma (in submonad) guarded_return:
  "\<And>s. guard s \<Longrightarrow> fn (return x) s = return x s"
  using args guarded_gets
  by (fastforce simp: gets_def bind_def get_def)

lemma (in submonad_args) submonad_fn_gets:
  "submonad_fn fetch replace guard (gets f) =
   (stateAssert guard [] >>= (\<lambda>u. gets (f \<circ> fetch)))"
  apply (simp add: ext select_from_gets submonad_fn_def)
  apply (rule bind_cong [OF refl])
  apply (clarsimp simp: gets_modify dest!: fst_stateAssertD)
  apply (simp add: gets_def)
  done

lemma(in submonad) gets:
  "fn (gets f) = (stateAssert guard [] >>= (\<lambda>u. gets (f \<circ> fetch)))"
  unfolding fn_is_sm submonad_fn_gets
  by (rule refl)

lemma (in submonad) return:
  "fn (return x) = (stateAssert guard [] >>= (\<lambda>u. return x))"
  using args gets
  by (fastforce simp: gets_def bind_def get_def)

lemma (in submonad) mapM_guard_preserved:
  "\<And>s s'. \<lbrakk> guard s; \<exists>rv. (rv, s') \<in> fst (mapM (fn \<circ> m) xs s)\<rbrakk> \<Longrightarrow> guard s'"
proof (induct xs)
  case Nil
  thus ?case
    by (simp add: mapM_def sequence_def return_def)
  next
  case (Cons x xs)
  thus ?case
    apply (clarsimp simp: o_def mapM_Cons return_def bind_def)
    apply (drule guard_preserved)
    apply fastforce
    done
qed

lemma (in submonad) mapM_x_guard_preserved:
  "\<And>s s'. \<lbrakk> guard s; \<exists>rv. (rv, s') \<in> fst (mapM_x (fn \<circ> m) xs s)\<rbrakk> \<Longrightarrow> guard s'"
proof (induct xs)
  case Nil
  thus ?case
    by (simp add: mapM_x_def sequence_x_def return_def)
  next
  case (Cons x xs)
  thus ?case
    apply (clarsimp simp: o_def mapM_x_Cons return_def bind_def)
    apply (drule guard_preserved)
    apply fastforce
    done
qed

lemma (in submonad) stateAssert_fn:
  "stateAssert guard [] >>= (\<lambda>u. fn m) = fn m"
  by (simp add: fn_is_sm submonad_fn_def pred_conj_def
                bind_subst_lift [OF stateAssert_stateAssert])

lemma (in submonad) fn_stateAssert:
  "fn m >>= (\<lambda>x. stateAssert guard [] >>= (\<lambda>u. n x)) = (fn m >>= n)"
  apply (simp add: fn_is_sm submonad_fn_def bind_assoc split_def)
  apply (rule ext)
  apply (rule bind_apply_cong [OF refl])+
  apply (clarsimp simp: stateAssert_def bind_assoc in_monad select_f_def)
  apply (drule iffD2 [OF replace_preserves_guard])
  apply (fastforce simp: bind_def assert_def get_def return_def)
  done

lemma submonad_mapM:
  assumes sm: "submonad f r g sm" and sm': "submonad f r g sm'"
  assumes efm: "\<And>x. empty_fail (m x)"
  shows
  "(sm (mapM m l)) = (stateAssert g [] >>= (\<lambda>u. mapM (sm' \<circ> m) l))"
proof (induct l)
  case Nil
  thus ?case
    by (simp add: mapM_def sequence_def bind_def submonad.return [OF sm])
  next
  case (Cons x xs)
  thus ?case
    using sm sm' efm
    apply (simp add: mapM_Cons)
    apply (simp add: bind_subst_lift [OF submonad.stateAssert_fn])
    apply (simp add: bind_assoc submonad_bind submonad.return empty_fail_cond)
    apply (subst submonad.fn_stateAssert [OF sm'])
    apply (intro ext bind_apply_cong [OF refl])
    apply (subgoal_tac "g sta")
     apply (clarsimp simp: stateAssert_def bind_def get_def assert_def return_def)
    apply (frule(1) submonad.guard_preserved)
    apply (erule(1) submonad.mapM_guard_preserved, fastforce simp: o_def)
    done
qed

lemma submonad_mapM_x:
  assumes sm: "submonad f r g sm" and sm': "submonad f r g sm'"
  assumes efm: "\<And>x. empty_fail (m x)"
  shows
  "(sm (mapM_x m l)) = (stateAssert g [] >>= (\<lambda>u. mapM_x (sm' \<circ> m) l))"
proof (induct l)
  case Nil
  thus ?case
    by (simp add: mapM_x_def sequence_x_def bind_def submonad.return [OF sm])
  next
  case (Cons x xs)
  thus ?case
    using sm sm' efm
    apply (simp add: mapM_x_Cons)
    apply (simp add: bind_subst_lift [OF submonad.stateAssert_fn])
    apply (simp add: bind_assoc submonad_bind submonad.return)
    apply (subst submonad.fn_stateAssert [OF sm'])
    apply (intro ext bind_apply_cong [OF refl])
    apply (subgoal_tac "g st")
     apply (clarsimp simp: stateAssert_def bind_def get_def assert_def return_def)
    apply (frule(1) submonad.guard_preserved, simp)
    done
qed

lemma corres_select:
  "(\<forall>s' \<in> S'. \<exists>s \<in> S. rvr s s') \<Longrightarrow> corres_underlying sr nf nf' rvr \<top> \<top> (select S) (select S')"
  by (clarsimp simp: select_def corres_underlying_def)

lemma corres_select_f:
  "\<lbrakk> \<forall>s' \<in> fst S'. \<exists>s \<in> fst S. rvr s s'; nf' \<Longrightarrow> \<not> snd S' \<rbrakk>
      \<Longrightarrow> corres_underlying sr nf nf' rvr \<top> \<top> (select_f S) (select_f S')"
  by (clarsimp simp: select_f_def corres_underlying_def)

lemma corres_modify':
  "\<lbrakk> (\<forall>s s'. (s, s') \<in> sr \<longrightarrow> (f s, f' s') \<in> sr); r () () \<rbrakk>
      \<Longrightarrow> corres_underlying sr nf nf' r \<top> \<top> (modify f) (modify f')"
  by (clarsimp simp: modify_def corres_underlying_def bind_def get_def put_def)

(* FIXME: this should only be used for the lemma below *)
lemma corres_select_f_stronger:
  "\<lbrakk> \<forall>s' \<in> fst S'. \<exists>s \<in> fst S. rvr s s'; nf' \<Longrightarrow> \<not> snd S' \<rbrakk>
      \<Longrightarrow> corres_underlying sr nf nf' rvr \<top> \<top> (select_f S) (select_f S')"
  by (clarsimp simp: select_f_def corres_underlying_def)

lemma stateAssert_sp:
  "\<lbrace>P\<rbrace> stateAssert Q l \<lbrace>\<lambda>_. P and Q\<rbrace>"
  by (clarsimp simp: valid_def stateAssert_def in_monad)

lemma corres_submonad:
  "\<lbrakk> submonad f r g fn; submonad f' r' g' fn';
     \<forall>s s'. (s, s') \<in> sr \<and> g s \<and> g' s' \<longrightarrow> (f s, f' s') \<in> ssr;
     \<forall>s s' ss ss'. ((s, s') \<in> sr \<and> (ss, ss') \<in> ssr) \<longrightarrow> (r ss s, r' ss' s') \<in> sr;
     corres_underlying ssr False nf' rvr \<top> \<top> x x'\<rbrakk>
   \<Longrightarrow> corres_underlying sr False nf' rvr g g' (fn x) (fn' x')"
  apply (subst submonad.fn_is_sm, assumption)+
  apply (clarsimp simp: submonad_fn_def)
  apply (rule corres_underlying_split [OF _ _ stateAssert_sp stateAssert_sp])
   apply (fastforce simp: corres_underlying_def stateAssert_def get_def
                         assert_def return_def bind_def)
  apply (rule corres_underlying_split [where r'="\<lambda>x y. (x, y) \<in> ssr",
                             OF _ _ hoare_post_taut hoare_post_taut])
   apply clarsimp
  apply (rule corres_underlying_split [where r'="\<lambda>(x, x') (y, y'). rvr x y \<and> (x', y') \<in> ssr",
                             OF _ _ hoare_post_taut hoare_post_taut])
   defer
   apply clarsimp
   apply (rule corres_underlying_split [where r'=dc, OF _ _ hoare_post_taut hoare_post_taut])
    apply (simp add: corres_modify')
   apply clarsimp
  apply (rule corres_select_f_stronger)
   apply (clarsimp simp: corres_underlying_def)
   apply (drule (1) bspec, clarsimp)
   apply (drule (1) bspec, simp)
   apply blast
  apply (clarsimp simp: corres_underlying_def)
  apply (drule (1) bspec, clarsimp)
  done

lemma stateAssert_top [simp]:
  "stateAssert \<top> l >>= f = f ()"
  by (clarsimp simp add: stateAssert_def get_def bind_def return_def)

lemma stateAssert_A_top [simp]:
  "stateAssert \<top> l = return ()"
  by (simp add: stateAssert_def get_def bind_def return_def)

text \<open>Use of the submonad concept to demonstrate commutativity.\<close>

lemma gets_modify_comm:
  "\<And> s. \<lbrakk> g (f s) = g s \<rbrakk> \<Longrightarrow>
   (do x \<leftarrow> modify f; y \<leftarrow> gets g; m x y od) s =
   (do y \<leftarrow> gets g; x \<leftarrow> modify f; m x y od) s"
  by (simp add: modify_def gets_def get_def bind_def put_def return_def)

lemma bind_subst_lhs_inv:
  "\<And>s. \<lbrakk> \<And>x s'. P s' \<Longrightarrow> (f x >>= g x) s' = h x s'; \<lbrace>P\<rbrace> a \<lbrace>\<lambda>_. P\<rbrace>; P s \<rbrakk> \<Longrightarrow>
   (do x \<leftarrow> a; y \<leftarrow> f x; g x y od) s = (a >>= h) s"
  apply (rule bind_apply_cong [OF refl])
  apply (drule(2) use_valid)
  apply simp
  done

lemma gets_comm:
  "do x \<leftarrow> gets f; y \<leftarrow> gets g; m x y od = do y \<leftarrow> gets g; x \<leftarrow> gets f; m x y od"
  by (simp add: gets_def get_def return_def bind_def)

lemma submonad_comm:
  assumes x1: "submonad_args f r g" and x2: "submonad_args f' r' g'"
  assumes y: "m = submonad_fn f r g im" "m' = submonad_fn f' r' g' im'"
  assumes z: "\<And>s x x'. r x (r' x' s) = r' x' (r x s)"
  assumes gp: "\<And>s x. g (r' x s) = g s" and gp': "\<And>s x. g' (r x s) = g' s"
  assumes efim: "empty_fail im" and efim': "empty_fail im'"
  shows      "(do x \<leftarrow> m; y \<leftarrow> m'; n x y od) = (do y \<leftarrow> m'; x \<leftarrow> m; n x y od)"
proof -
  have P: "\<And>x s. g s \<Longrightarrow> f (r' x s) = f s"
    apply (subgoal_tac "f (r' x (r (f s) s)) = f s")
     apply (simp add: submonad_args.args[OF x1])
    apply (simp add: z[symmetric])
    apply (subst(asm) gp [symmetric])
    apply (fastforce dest: submonad_args.argsD1[OF x1])
    done
  have Q: "\<And>x s. g' s \<Longrightarrow> f' (r x s) = f' s"
    apply (subgoal_tac "f' (r x (r' (f' s) s)) = f' s")
     apply (simp add: submonad_args.args[OF x2])
    apply (simp add: z)
    apply (subst(asm) gp' [symmetric])
    apply (fastforce dest: submonad_args.argsD1[OF x2])
    done
  note empty_failD [OF efim, simp]
  note empty_failD [OF efim', simp]
  note empty_fail_select_f[simp]
  show ?thesis
    apply (clarsimp simp: submonad_fn_def y bind_assoc split_def)
    apply (subst bind_subst_lift [OF modify_stateAssert], rule gp gp')+
    apply (simp add: bind_assoc)
    apply (subst select_f_stateAssert, rule efim efim')+
    apply (subst gets_stateAssert bind_subst_lift [OF stateAssert_stateAssert])+
    apply (rule bind_cong)
     apply (simp add: pred_conj_def conj_comms)
    apply (simp add: bind_assoc select_f_walk[symmetric])
    apply (clarsimp dest!: fst_stateAssertD)
    apply (subst bind_assoc[symmetric],
           subst bind_subst_lhs_inv [OF gets_modify_comm],
           erule P Q, wp, simp, simp)+
    apply (simp add: bind_assoc)
    apply (simp add: select_f_walk[symmetric])
    apply (subst gets_comm)
    apply (rule bind_apply_cong [OF refl])+
    apply (subst select_f_walk, simp, simp,
           subst select_f_walk, simp, simp,
           rule bind_apply_cong [OF refl])
    apply (subst select_f_walk, simp, simp, rule bind_apply_cong [OF refl])
    apply (clarsimp simp: simpler_gets_def select_f_def)
    apply (simp add: bind_def get_def put_def modify_def z)
    done
qed

lemma submonad_comm2:
  assumes x1: "submonad_args f r g" and x2: "m = submonad_fn f r g im"
  assumes y: "submonad f' r' g' m'"
  assumes z: "\<And>s x x'. r x (r' x' s) = r' x' (r x s)"
  assumes gp: "\<And>s x. g (r' x s) = g s" and gp': "\<And>s x. g' (r x s) = g' s"
  assumes efim: "empty_fail im" and efim': "empty_fail im'"
  shows      "do x \<leftarrow> m; y \<leftarrow> m' im'; n x y od = do y \<leftarrow> m' im'; x \<leftarrow> m; n x y od"
  apply (rule submonad_comm[where f'=f' and r'=r', OF x1 _ x2 _ z])
       apply (insert y)
       apply (fastforce simp add: submonad_def)
      apply (fastforce dest: submonad.fn_is_sm)
     apply (simp add: efim efim' gp gp')+
  done

lemma submonad_bind_alt:
  assumes x: "submonad_args f r g"
  assumes y: "a = submonad_fn f r g a'" "\<And>rv. b rv = submonad_fn f r g (b' rv)"
  assumes efa: "empty_fail a'" and efb: "\<And>x. empty_fail (b' x)"
  shows      "(a >>= b) = submonad_fn f r g (a' >>= b')"
proof -
  have P: "submonad f r g (submonad_fn f r g)"
    by (simp add: x submonad_def submonad_axioms_def)
  have Q: "b = (\<lambda>rv. submonad_fn f r g (b' rv))"
    by (rule ext) fact+
  show ?thesis
    by (simp add: y Q submonad_bind [OF P P P efa efb])
qed

lemma submonad_singleton:
  "submonad_fn fetch replace \<top> (\<lambda>s. ({(rv s, s' s)}, False))
     = (\<lambda>s. ({(rv (fetch s), replace (s' (fetch s)) s)}, False))"
  apply (rule ext)
  apply (simp add: submonad_fn_def bind_def gets_def
                put_def get_def modify_def return_def
                select_f_def UNION_eq)
  done

lemma gets_submonad:
  "\<lbrakk> submonad_args fetch replace \<top>; \<And>s. f s = f' (fetch s); m = gets f' \<rbrakk>
   \<Longrightarrow> gets f = submonad_fn fetch replace \<top> m"
  apply (drule submonad_args.args(3))
  apply (clarsimp simp add: simpler_gets_def submonad_singleton)
  done

lemma modify_submonad:
  "\<lbrakk> \<And>s. f s = replace (K_record (f' (fetch s))) s; m = modify f' \<rbrakk>
     \<Longrightarrow> modify f = submonad_fn fetch (replace o K_record) \<top> m"
  by (simp add: simpler_modify_def submonad_singleton)

lemma fail_submonad:
  "fail = submonad_fn fetch replace \<top> fail"
  by (simp add: submonad_fn_def simpler_gets_def return_def
                simpler_modify_def select_f_def bind_def fail_def)

lemma return_submonad:
  "submonad_args fetch replace guard \<Longrightarrow>
   return v = submonad_fn fetch replace \<top> (return v)"
  by (simp add: return_def submonad_singleton submonad_args.args)

lemma assert_opt_submonad:
  "submonad_args fetch replace \<top> \<Longrightarrow>
   assert_opt v = submonad_fn fetch replace \<top> (assert_opt v)"
  apply (case_tac v, simp_all add: assert_opt_def)
   apply (rule fail_submonad)
  apply (rule return_submonad)
  apply assumption
  done

lemma is_stateAssert_gets:
  "\<lbrakk> \<forall>s. \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) s\<rbrace>; \<lbrace>\<top>\<rbrace> f \<lbrace>\<lambda>_. guard\<rbrace>;
     empty_fail f; no_fail guard f; \<lbrace>guard\<rbrace> f \<lbrace>\<lambda>rv s. fetch s = rv\<rbrace> \<rbrakk>
    \<Longrightarrow> f = do stateAssert guard []; gets fetch od"
  apply (rule ext)
  apply (clarsimp simp: bind_def empty_fail_def valid_def no_fail_def
                        stateAssert_def assert_def gets_def get_def
                        return_def fail_def image_def split_def)
  apply (case_tac "f x")
  apply (intro conjI impI)
   apply (drule_tac x=x in spec)+
   apply (subgoal_tac "\<forall>xa\<in>fst (f x). fst xa = fetch x \<and> snd xa = x")
    apply fastforce
   apply clarsimp
  apply (drule_tac x=x in spec)+
  apply fastforce
  done

lemma is_modify:
  "\<And>s. \<lbrakk> \<lbrace>(=) s\<rbrace> f \<lbrace>\<lambda>_. (=) (replace s)\<rbrace>; empty_fail f;
          no_fail guard f; guard s \<rbrakk>
    \<Longrightarrow> f s = modify replace s"
  apply (clarsimp simp: bind_def empty_fail_def valid_def no_fail_def
                        stateAssert_def assert_def modify_def get_def put_def
                        return_def fail_def image_def split_def)
  apply (case_tac "f s")
  apply force
  done

lemma submonad_comm':
  assumes sm1: "submonad f r g m" and sm2: "submonad f' r' g' m'"
  assumes z: "\<And>s x x'. r x (r' x' s) = r' x' (r x s)"
  assumes gp: "\<And>s x. g (r' x s) = g s" and gp': "\<And>s x. g' (r x s) = g' s"
  assumes efim: "empty_fail im" and efim': "empty_fail im'"
  shows      "(do x \<leftarrow> m im; y \<leftarrow> m' im'; n x y od) =
              (do y \<leftarrow> m' im'; x \<leftarrow> m im; n x y od)"
  apply (rule submonad_comm [where f'=f' and r'=r', OF _ _ _ _ z])
         apply (insert sm1 sm2)
         apply (fastforce dest: submonad.fn_is_sm simp: submonad_def)+
     apply (simp add: efim efim' gp gp')+
  done

end


theory Keep_Drop
  imports Base
begin

definition Keep_Drop where
  "Keep_Drop \<Gamma> K D \<equiv> \<Gamma> \<Longrightarrow>\<^sub>A K * D"

lemma init:
  assumes
    "\<Gamma> \<Longrightarrow>\<^sub>A K * D"
  shows
    "Keep_Drop \<Gamma> K D"
  unfolding Keep_Drop_def
  using assms by simp

lemma split:
  assumes
    "\<Gamma>\<^sub>1 \<Longrightarrow>\<^sub>A K\<^sub>1 * D\<^sub>1"
    "\<Gamma>\<^sub>2 \<Longrightarrow>\<^sub>A K\<^sub>2 * D\<^sub>2"
  shows
    "\<Gamma>\<^sub>1 * \<Gamma>\<^sub>2 \<Longrightarrow>\<^sub>A (K\<^sub>1 * K\<^sub>2) * (D\<^sub>1 * D\<^sub>2)"
  apply(sep_drule r: assms(1))
  apply(sep_drule r: assms(2))
  by sep_auto

lemma keep:
  assumes
    "\<Gamma> \<Longrightarrow>\<^sub>A \<Gamma>'"
  shows
    "\<Gamma> \<Longrightarrow>\<^sub>A \<Gamma>' * emp"
  using assms
  by sep_auto

lemma drop: "\<Gamma> \<Longrightarrow>\<^sub>A emp * \<Gamma>"
  by simp

method keep_drop_step methods keep_atom =
  rule split | (rule keep, keep_atom) | rule drop

method keep_drop methods keep_atom =
  rule init, ((keep_drop_step keep_atom)+; fail)

end