(*
  Goal verification framework
    - Actions
*)

\<comment> \<open>This theory sets up the concepts of agents, actions, transitions and traces.
    We extend the language for mental state formulas with enabledness of actions.
    We provide its syntax, semantics and a sound proof system.\<close>

theory Gvf_Actions imports Gvf_Mental_States begin

section \<open>Actions\<close>

\<comment> \<open>The identifier for basic actions is a natural number.\<close>
type_synonym Bcap = string

\<comment> \<open>Agent capability is a basic capability, adopt or drop (the latter two are built into GOAL).\<close>
datatype cap = basic (bcap: Bcap) | adopt (cget: \<Phi>\<^sub>L) | drop (cget: \<Phi>\<^sub>L)

\<comment> \<open>Type for conditional action that is a pair: a condition on the mental state and a basic action.\<close>
type_synonym cond_act = \<open>\<Phi>\<^sub>M \<times> cap\<close>

\<comment> \<open>Atoms are extended with enabled for basic/conditional actions.\<close>
datatype Atom\<^sub>E = Bl\<^sub>E \<Phi>\<^sub>L | Gl\<^sub>E \<Phi>\<^sub>L | enabled_basic cap | enabled_cond cond_act
\<comment> \<open>The simple type theory makes it less delicate to extend types, so we redefine the belief
    and goal operators while adding two new options: one for basic and one for conditional actions.\<close>

\<comment> \<open>The type for mental state formulas concerning enabledness.\<close>
type_synonym \<Phi>\<^sub>E = \<open>Atom\<^sub>E \<Phi>\<^sub>P\<close>

\<comment> \<open>Introducing some notation.\<close>
abbreviation \<open>B\<^sub>E \<Phi> \<equiv> Atom (Bl\<^sub>E \<Phi>)\<close>
abbreviation \<open>G\<^sub>E \<Phi> \<equiv> Atom (Gl\<^sub>E \<Phi>)\<close>
abbreviation \<open>enabledb\<^sub>E c \<equiv> Atom (enabled_basic c)\<close>
abbreviation \<open>enabled\<^sub>E c \<equiv> Atom (enabled_cond c)\<close>
abbreviation \<open>enabledb c \<equiv> Atom (enabled_basic c)\<close>
abbreviation \<open>enabled c \<equiv> Atom (enabled_cond c)\<close>
abbreviation cond_act_pair :: \<open>\<Phi>\<^sub>M \<Rightarrow> cap \<Rightarrow> cond_act\<close> (\<open>_ \<triangleright> do _\<close>) where \<open>\<phi> \<triangleright> do a \<equiv> (\<phi>, a)\<close>

\<comment> \<open>Auxiliary function that converts mental state formulas to the type including enabledness.\<close>
fun to_\<Phi>\<^sub>E :: \<open>\<Phi>\<^sub>M \<Rightarrow> \<Phi>\<^sub>E\<close> (\<open>_\<^sup>E\<close> [100]) where
  \<open>(Atom (Bl \<Phi>))\<^sup>E = Atom (Bl\<^sub>E \<Phi>)\<close> |
  \<open>(Atom (Gl \<Phi>))\<^sup>E = Atom (Gl\<^sub>E \<Phi>)\<close> |
  \<open>\<^bold>\<bottom>\<^sup>E = \<^bold>\<bottom>\<close> |
  \<open>(\<^bold>\<not> \<phi>)\<^sup>E = \<^bold>\<not> (\<phi>\<^sup>E)\<close> |
  \<open>(\<phi>\<^sub>1 \<^bold>\<longrightarrow> \<phi>\<^sub>2)\<^sup>E = \<phi>\<^sub>1\<^sup>E \<^bold>\<longrightarrow> \<phi>\<^sub>2\<^sup>E\<close> |
  \<open>(\<phi>\<^sub>1 \<^bold>\<or> \<phi>\<^sub>2)\<^sup>E = \<phi>\<^sub>1\<^sup>E \<^bold>\<or> \<phi>\<^sub>2\<^sup>E\<close> |
  \<open>(\<phi>\<^sub>1 \<^bold>\<and> \<phi>\<^sub>2)\<^sup>E = \<phi>\<^sub>1\<^sup>E \<^bold>\<and> \<phi>\<^sub>2\<^sup>E\<close>

fun to_\<Phi>\<^sub>M :: \<open>\<Phi>\<^sub>E \<Rightarrow> \<Phi>\<^sub>M option\<close> where
  \<open>to_\<Phi>\<^sub>M (Atom (Bl\<^sub>E \<Phi>)) = Some (Atom (Bl \<Phi>))\<close> |
  \<open>to_\<Phi>\<^sub>M (Atom (Gl\<^sub>E \<Phi>)) = Some (Atom (Gl \<Phi>))\<close> |
  \<open>to_\<Phi>\<^sub>M \<^bold>\<bottom> = Some \<^bold>\<bottom>\<close> |
  \<open>to_\<Phi>\<^sub>M (\<^bold>\<not> \<phi>) = (case to_\<Phi>\<^sub>M \<phi> of Some \<phi>' \<Rightarrow> Some (\<^bold>\<not> \<phi>') | _ \<Rightarrow> None)\<close> |
  \<open>to_\<Phi>\<^sub>M (\<phi>\<^sub>1 \<^bold>\<longrightarrow> \<phi>\<^sub>2) = (case (to_\<Phi>\<^sub>M \<phi>\<^sub>1, to_\<Phi>\<^sub>M \<phi>\<^sub>2) of (Some \<phi>\<^sub>1', Some \<phi>\<^sub>2') \<Rightarrow> Some (\<phi>\<^sub>1' \<^bold>\<longrightarrow> \<phi>\<^sub>2') | _ \<Rightarrow> None)\<close> |
  \<open>to_\<Phi>\<^sub>M (\<phi>\<^sub>1 \<^bold>\<or> \<phi>\<^sub>2) = (case (to_\<Phi>\<^sub>M \<phi>\<^sub>1, to_\<Phi>\<^sub>M \<phi>\<^sub>2) of (Some \<phi>\<^sub>1', Some \<phi>\<^sub>2') \<Rightarrow> Some (\<phi>\<^sub>1' \<^bold>\<or> \<phi>\<^sub>2') | _ \<Rightarrow> None)\<close> |
  \<open>to_\<Phi>\<^sub>M (\<phi>\<^sub>1 \<^bold>\<and> \<phi>\<^sub>2) = (case (to_\<Phi>\<^sub>M \<phi>\<^sub>1, to_\<Phi>\<^sub>M \<phi>\<^sub>2) of (Some \<phi>\<^sub>1', Some \<phi>\<^sub>2') \<Rightarrow> Some (\<phi>\<^sub>1' \<^bold>\<and> \<phi>\<^sub>2') | _ \<Rightarrow> None)\<close> |
  \<open>to_\<Phi>\<^sub>M _ = None\<close>

section \<open>Semantics of GOAL\<close>

\<comment> \<open>The type for the function \<T> that gives the agent's belief update capabilities.\<close>
type_synonym bel_upd_t = \<open>Bcap \<Rightarrow> mental_state \<Rightarrow> \<Phi>\<^sub>L list option\<close>
\<comment> \<open>We replace notion of undefined (from paper) with an optional value, i.e. \<T> a \<Sigma> = None means
    that basic action a is not defined for \<Sigma>.
    We further assume that the goal base (entire mental state) is added to the input.\<close>

\<comment> \<open>The mental state transformer gives the agent's mental state update capabilities.\<close>
fun mental_state_transformer :: \<open>bel_upd_t \<Rightarrow> cap \<Rightarrow> mental_state \<Rightarrow> mental_state option\<close> (\<open>\<M>*\<close>) where
  \<comment> \<open>If \<T> a \<Sigma> is defined, update the goal base accordingly.\<close>
  \<open>\<M>* \<T> (basic n) (\<Sigma>, \<Gamma>) = (case \<T> n (\<Sigma>, \<Gamma>) of Some \<Sigma>' \<Rightarrow> Some (\<Sigma>', [\<psi>\<leftarrow>\<Gamma>. \<not> \<Sigma>' \<^bold>\<Turnstile>\<^sub>P \<psi>]) | _ \<Rightarrow> None)\<close> |
  \<comment> \<open>Remove the goals that entail \<Phi>.\<close>
  \<open>\<M>* \<T> (drop \<Phi>) (\<Sigma>, \<Gamma>) = Some (\<Sigma>, [\<psi>\<leftarrow>\<Gamma>. \<not> [\<psi>] \<^bold>\<Turnstile>\<^sub>P \<Phi>])\<close> |
  \<comment> \<open>Add the goal \<Phi> if it is consistent and not entailed by the belief base.\<close>
  \<open>\<M>* \<T> (adopt \<Phi>) (\<Sigma>, \<Gamma>) = (if \<not> \<Turnstile>\<^sub>P (\<^bold>\<not> \<Phi>) \<and> \<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<Phi> then Some (\<Sigma>, List.insert \<Phi> \<Gamma>) else None)\<close>

lemma mst_none: \<open>\<M>* \<T> (basic a) M = None \<longleftrightarrow> \<T> a M = None\<close>
proof (cases M)
  case (Pair \<Sigma> \<Gamma>)
  have \<open>\<M>* \<T> (basic a) (\<Sigma>, \<Gamma>) = None \<longleftrightarrow> \<T> a (\<Sigma>, \<Gamma>) = None\<close> by (cases \<open>\<T> a (\<Sigma>, \<Gamma>)\<close>) auto
  with Pair show ?thesis by simp
qed

lemma new_base_is_mst: \<open>\<not> \<Sigma>' \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom> \<Longrightarrow> \<nabla>(\<Sigma>, \<Gamma>) \<Longrightarrow> \<nabla>(\<Sigma>', [\<psi>\<leftarrow>\<Gamma>. \<not> \<Sigma>' \<^bold>\<Turnstile>\<^sub>P \<psi>])\<close>
  unfolding is_mental_state_def by simp

\<comment> \<open>We fix to a single agent and assume a given belief update function,
    a set of conditional actions and an initial state.\<close>
locale single_agent =
  fixes
    \<T>  :: bel_upd_t and
    \<Pi> :: \<open>cond_act set\<close> and
    M\<^sub>0 :: mental_state
  assumes
    \<comment> \<open>Non-empty set of conditional actions and initial state is a mental state.\<close>
    is_agent: \<open>\<Pi> \<noteq> {} \<and> \<nabla> M\<^sub>0\<close> and
    \<comment> \<open>\<T> preserves consistency.\<close>
    \<T>_consistent: \<open>\<nabla>(\<Sigma>, \<Gamma>) \<longrightarrow> (\<exists>\<phi>. (\<phi>, basic a) \<in> \<Pi>) \<longrightarrow> \<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom> \<longrightarrow> \<T> a (\<Sigma>, \<Gamma>) \<noteq> None \<longrightarrow> \<not> the (\<T> a (\<Sigma>, \<Gamma>)) \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom>\<close> and
    \<comment> \<open>\<T> only for defined actions.\<close>
    \<T>_in_domain: \<open>\<T> a (\<Sigma>, \<Gamma>) \<noteq> None \<longrightarrow> (\<exists>\<phi>. (\<phi>, basic a) \<in> \<Pi>)\<close>

\<comment> \<open>Working in the context of single_agent, means that we can base definitions, proofs etc. around
    fixed variables for which a number of assumptions apply. For a specific agent, we need to prove
    that the assumptions apply for the given input variables. By doing so, we get immediate access
    to everything defined within the single_agent context.\<close>
context single_agent
begin

\<comment> \<open>Basic capabilities derived from the set of conditional actions.\<close>
definition Cap :: \<open>cap set\<close> where
  \<open>Cap \<equiv> { basic a | a. \<exists>\<phi>. (\<phi>, basic a) \<in> \<Pi> } \<union> range adopt \<union> range drop\<close>
\<comment> \<open>We assume that a basic capability is represented by at least one conditional action.\<close>

lemma adopt_Cap: \<open>adopt \<Phi> \<in> Cap\<close> unfolding Cap_def by simp
lemma drop_Cap: \<open>drop \<Phi> \<in> Cap\<close> unfolding Cap_def by simp

\<comment> \<open>Define mental state transformer local to the agent.\<close>
abbreviation \<open>\<M> a M \<equiv> \<M>* \<T> a M\<close>

\<comment> \<open>Examples.\<close>
lemma
  assumes \<open>\<T> n ([P], [Q]) = Some [P, Q]\<close>
  shows \<open>\<M> (basic n) ([P], [Q]) = Some ([P, Q], [])\<close>
using assms by simp

lemma \<open>\<M> (drop \<^bold>\<top>) ([], [P, Q]) = Some ([], [])\<close> by simp

lemma
  assumes \<open>\<not> \<Turnstile>\<^sub>P (\<^bold>\<not> Q)\<close> and \<open>\<not> \<Turnstile>\<^sub>P Q\<close>
  shows \<open>\<M> (adopt Q) ([], [P]) = Some ([], List.insert Q [P])\<close>
  using assms by simp

\<comment> \<open>The mental state transformer is only defined for actions of \<Pi>.\<close>
lemma \<M>_some_in_\<Pi>:
  assumes \<open>\<M> (basic a) M \<noteq> None\<close>
    shows \<open>\<exists>\<phi>. (\<phi>, (basic a)) \<in> \<Pi>\<close>
proof (cases M)
  case (Pair \<Sigma> \<Gamma>)
  with assms obtain \<Sigma>' \<Gamma>' where someM: \<open>\<M> (basic a) (\<Sigma>, \<Gamma>) = Some (\<Sigma>', \<Gamma>')\<close> by auto
  then have \<open>\<T> a (\<Sigma>, \<Gamma>) = Some \<Sigma>'\<close>
  proof (cases \<open>\<T> a (\<Sigma>, \<Gamma>)\<close>)
    case None
    then have \<open>\<M> (basic a) (\<Sigma>, \<Gamma>) = None\<close> by simp
    with someM show ?thesis by simp
  next
    case (Some \<Sigma>'')
    moreover have \<open>fst (the (\<M> (basic a) (\<Sigma>, \<Gamma>))) = \<Sigma>''\<close> using Some by simp
    moreover have \<open>fst (the (\<M> (basic a) (\<Sigma>, \<Gamma>))) = \<Sigma>'\<close> using someM by simp
    ultimately show ?thesis by simp
  qed
  with \<T>_in_domain show ?thesis by blast
qed

\<comment> \<open>The mental state transformer is only defined for basic capabilities of Cap.\<close>
lemma \<M>_some_Cap:
  assumes \<open>\<M> a M \<noteq> None\<close>
  shows \<open>a \<in> Cap\<close>
  using assms \<M>_some_in_\<Pi>
  unfolding Cap_def
  by (cases a) auto

\<comment> \<open>Mental state transformer preserves properties of mental states (when \<T> preserves consistency).\<close>
lemma \<M>_preserves_mst: \<open>\<nabla> (\<Sigma>, \<Gamma>) \<Longrightarrow> \<M> c (\<Sigma>, \<Gamma>) \<noteq> None \<Longrightarrow> \<nabla> (the (\<M> c (\<Sigma>, \<Gamma>)))\<close>
proof (induct c)
  case basic: (basic a)
  then obtain \<Sigma>' where \<Sigma>': \<open>\<T> a (\<Sigma>, \<Gamma>) = Some \<Sigma>'\<close> by fastforce
  have \<open>\<nabla> (\<Sigma>', [\<psi>\<leftarrow>\<Gamma>. \<not> \<Sigma>' \<^bold>\<Turnstile>\<^sub>P \<psi>])\<close> (is \<open>\<nabla> (\<Sigma>', ?\<Gamma>')\<close>)
  proof -
    have \<open>\<not> \<Sigma>' \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom>\<close>
    proof -
      from basic(1) have \<open>\<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom>\<close> unfolding is_mental_state_def by simp
      moreover have \<open>\<exists>\<phi>. (\<phi>, basic a) \<in> \<Pi>\<close> using \<M>_some_in_\<Pi> basic.prems(2) by blast
      ultimately have \<open>\<not> the (\<T> a (\<Sigma>, \<Gamma>)) \<^bold>\<Turnstile>\<^sub>P \<^bold>\<bottom>\<close> using \<Sigma>' \<T>_consistent basic by blast
      with \<Sigma>' show ?thesis by simp
    qed
    moreover from basic(1) have \<open>\<forall>\<gamma>\<in> set ?\<Gamma>'. \<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<gamma> \<and> \<not> \<Turnstile>\<^sub>P (\<^bold>\<not> \<gamma>)\<close>
      unfolding is_mental_state_def by simp
    ultimately show ?thesis unfolding is_mental_state_def by simp
  qed
  with \<Sigma>' show ?case by simp
next
  case adopt: (adopt \<Phi>)
  with mental_state_transformer.simps(3) have mst_goal: \<open>\<not> \<Turnstile>\<^sub>P (\<^bold>\<not> \<Phi>) \<and> \<not> \<Sigma> \<^bold>\<Turnstile>\<^sub>P \<Phi>\<close> by metis
  with adopt(1) have \<open>\<nabla> (\<Sigma>, List.insert \<Phi> \<Gamma>)\<close> unfolding is_mental_state_def by simp
  with mst_goal show ?case by simp
next
  case (drop \<Phi>)
  then have \<open>\<nabla> (\<Sigma>, [\<psi>\<leftarrow>\<Gamma>. \<not> [\<psi>] \<^bold>\<Turnstile>\<^sub>P \<Phi>])\<close> unfolding is_mental_state_def by simp
  then show ?case by simp
qed

section \<open>Traces\<close>

\<comment> \<open>Transition relation between states due to an action.\<close>
definition transition :: \<open>mental_state \<Rightarrow> cond_act \<Rightarrow> mental_state \<Rightarrow> bool\<close> (\<open>_ \<rightarrow>_ _\<close>) where
  \<open>M \<rightarrow>b M' \<equiv> b \<in> \<Pi> \<and> M \<Turnstile>\<^sub>M (fst b) \<and> \<M> (snd b) M = Some M'\<close>
\<comment> \<open>If b is a conditional action, and the condition true in M, then there is possible transition
    between M and M' where M' is the result of applying \<M> for a to M.\<close>

\<comment> \<open>Chain of transitions (computation steps) gives the computation relation.\<close>
inductive computation :: \<open>mental_state \<Rightarrow> mental_state \<Rightarrow> bool\<close> (\<open>_ \<rightarrow>* _\<close>) where
  \<comment> \<open>The base step from the initial mental state.\<close>
  basis: \<open>M\<^sub>0 \<rightarrow>b M' \<Longrightarrow> M\<^sub>0 \<rightarrow>* M'\<close> |
  \<comment> \<open>Inductive step from an existing computation given a transition.\<close>
  step: \<open>M \<rightarrow>* M' \<Longrightarrow> M' \<rightarrow>b M'' \<Longrightarrow> M \<rightarrow>* M''\<close>

\<comment> \<open>Example\<close>
lemma \<open>M\<^sub>0 \<rightarrow>a M\<^sub>1 \<Longrightarrow> M\<^sub>1 \<rightarrow>b M\<^sub>2 \<Longrightarrow> M\<^sub>0 \<rightarrow>* M\<^sub>2\<close>
  using basis step by blast

\<comment> \<open>Traces are infinite structures.\<close>
codatatype trace = Trace mental_state \<open>cond_act \<times> trace\<close>
\<comment> \<open>trace := mental state, conditional action, trace\<close>

\<comment> \<open>Example.\<close>
value \<open>Trace M\<^sub>0 (a, (Trace M\<^sub>1 (b, (Trace M\<^sub>2 X))))\<close>

\<comment> \<open>Retrieve the nth conditional action of the trace.\<close>
fun act_nth :: \<open>trace \<Rightarrow> nat \<Rightarrow> cond_act\<close> where
  \<open>act_nth (Trace _ (b, _)) 0 = b\<close> |
  \<open>act_nth (Trace _ (_, S)) n = act_nth S (n-1)\<close>

\<comment> \<open>Example.\<close>
lemma \<open>b = act_nth (Trace M\<^sub>0 (a, (Trace M\<^sub>1 (b, (Trace M\<^sub>2 X))))) 1\<close> by simp

\<comment> \<open>Retrieve the nth mental state of the trace.\<close>
fun st_nth :: \<open>trace \<Rightarrow> nat \<Rightarrow> mental_state\<close> where
  \<open>st_nth (Trace M (_, _)) 0 = M\<close> |
  \<open>st_nth (Trace _ (_, S)) n = st_nth S (n-1)\<close>

\<comment> \<open>Example.\<close>
lemma \<open>M\<^sub>1 = st_nth (Trace M\<^sub>0 (a, (Trace M\<^sub>1 (b, (Trace M\<^sub>2 X))))) 1\<close> by simp

\<comment> \<open>if (\<psi>, a) is the ith conditional action of trace s, then the first value of (act_nth s i)
    is \<psi>. This is intuitively easy to see, but pattern matching using equality can be problematic.\<close>
lemma fst_act_nth: \<open>(\<psi>, a) = act_nth s i \<Longrightarrow> fst (act_nth s i) = \<psi>\<close>
  by (metis fstI)

\<comment> \<open>The same as above but for the second value.\<close>
lemma snd_act_nth: \<open>(\<psi>, a) = act_nth s i \<Longrightarrow> snd (act_nth s i) = a\<close>
  by (metis sndI)

\<comment> \<open>The definition of a trace (not every element of the datatype trace qualifies).\<close>
definition is_trace :: \<open>trace \<Rightarrow> bool\<close> where
  \<open>is_trace s \<equiv>
    \<forall>i. (act_nth s i) \<in> \<Pi> \<and> (((st_nth s i) \<rightarrow>(act_nth s i) (st_nth s (i+1))) \<or>
        \<not>(\<exists>M. ((st_nth s i) \<rightarrow>(act_nth s i) M)) \<and> (st_nth s i) = (st_nth s (i+1)))\<close>
\<comment> \<open>For all i there is a transition between M_i and M_(i+1) due to an action, or the action
    is not enabled and the successor state (M_(i+1)) is equal to the current (M_i).\<close>

\<comment> \<open>The nth conditional action of a trace is in \<Pi>.\<close>
lemma trace_in_\<Pi>:
  assumes \<open>is_trace s\<close>
  shows \<open>act_nth s i \<in> \<Pi>\<close>
  using assms unfolding is_trace_def transition_def by auto

\<comment> \<open>If there is no transition between a state and its successor in a trace, they must be equal.\<close>
lemma not_transition_eq:
  assumes \<open>is_trace s\<close>
  shows \<open>\<not>((st_nth s i) \<rightarrow>(act_nth s i) (st_nth s (i+1))) \<longrightarrow> (st_nth s i) = (st_nth s (i+1))\<close>
  (is \<open>\<not>(?M \<rightarrow>?b ?M') \<longrightarrow> ?M = ?M'\<close>)
proof
  assume \<open>\<not>(?M \<rightarrow>?b ?M')\<close>
  with assms show \<open>?M = ?M'\<close> unfolding is_trace_def by auto
qed

\<comment> \<open>A fair trace ensures that there always is a future point where an actions is scheduled.\<close>
definition fair_trace :: \<open>trace \<Rightarrow> bool\<close> where
  \<open>fair_trace s \<equiv> \<forall> b \<in> \<Pi>. \<forall>i. \<exists> j > i. act_nth s j = b\<close>

\<comment> \<open>An agent is defined as the set of fair traces starting from the initial state.\<close>
definition Agent :: \<open>trace set\<close> where
  \<open>Agent \<equiv> {s . is_trace s \<and> fair_trace s \<and> st_nth s 0 = M\<^sub>0}\<close>

\<comment> \<open>If the mental state transformer is defined for a state in the trace, then it gives the successor state.\<close>
lemma \<M>_suc_state:
  assumes \<open>s \<in> Agent\<close>
      and \<open>\<M> (snd (act_nth s i)) (st_nth s i) \<noteq> None\<close>
      and \<open>st_nth s i \<Turnstile>\<^sub>M fst (act_nth s i)\<close>
    shows \<open>st_nth s (i+1) = the (\<M> (snd (act_nth s i)) (st_nth s i))\<close>
      (is \<open>?M = the (\<M> ?a ?M')\<close>)
proof -
  from assms(1) have \<open>is_trace s\<close> unfolding Agent_def by simp
  then have
    \<open>(act_nth s i) \<in> \<Pi> \<and> (((st_nth s i) \<rightarrow>(act_nth s i) (st_nth s (i+1))) \<or>
        \<not>(\<exists>M. ((st_nth s i) \<rightarrow>(act_nth s i) M)) \<and> (st_nth s i) = (st_nth s (i+1)))\<close>
    unfolding is_trace_def by simp
  moreover from trace_in_\<Pi> have \<open>act_nth s i \<in> \<Pi>\<close> using \<open>is_trace s\<close> assms(2) by simp
  ultimately show ?thesis using assms(2,3) unfolding transition_def by auto
qed

\<comment> \<open>All states in trace comply to mental state definition.\<close>
lemma is_mst_trace:
  assumes \<open>s \<in> Agent\<close>
  shows   \<open>\<nabla> (st_nth s n)\<close>
proof (induct n)
  case 0
  with assms show ?case using is_agent unfolding Agent_def by simp
next
  case (Suc n)
  let ?M = \<open>st_nth s n\<close> and ?M' = \<open>st_nth s (Suc n)\<close> and ?b = \<open>act_nth s n\<close>
  have trace_n: \<open>(?M \<rightarrow>?b ?M') \<or> ?M = ?M'\<close>
  proof -
    from assms(1) have \<open>is_trace s\<close> unfolding Agent_def by simp
    then show ?thesis unfolding is_trace_def by auto
  qed
  then show ?case
  proof (cases \<open>?M \<rightarrow>?b ?M'\<close>)
    case True
    then have *: \<open>st_nth s n \<Turnstile>\<^sub>M fst (act_nth s n) \<and> \<M> (snd (act_nth s n)) (st_nth s n) \<noteq> None\<close>
      unfolding transition_def by simp
    with \<M>_preserves_mst have \<open>\<nabla> (the (\<M> (snd ?b) ?M))\<close>
      using Suc by (cases ?M) simp
    with \<M>_suc_state show ?thesis using assms * unfolding Agent_def by simp
  next
    case False
    then have \<open>?M = ?M'\<close> using trace_n by blast
    with Suc show ?thesis by simp
  qed
qed

fun the_Some :: \<open>('a \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 'a)\<close> where
  \<open>the_Some f x = (if f x = None then x else the (f x))\<close>

abbreviation mst_basic_trace where
  \<open>mst_basic_trace \<equiv> foldr (\<lambda>a M. the_Some (\<M> a) M)\<close>

definition mst_reachable_basic :: \<open>mental_state \<Rightarrow> bool\<close> where
 \<open>mst_reachable_basic M \<equiv> \<exists>S. mst_basic_trace S M\<^sub>0 = M\<close>

lemma \<open>mst_basic_trace [a,b,c] M\<^sub>0 = the_Some (\<M> a) (the_Some (\<M> b) (the_Some (\<M> c) M\<^sub>0))\<close> by simp

lemma mst_basic_trace_preserves_mst: \<open>\<nabla>(mst_basic_trace s M\<^sub>0) \<Longrightarrow> \<M> a (mst_basic_trace s M\<^sub>0) \<noteq> None \<Longrightarrow> \<nabla>(mst_basic_trace (a # s) M\<^sub>0)\<close>
proof -
  assume \<open>\<nabla>(mst_basic_trace s M\<^sub>0)\<close> (is \<open>\<nabla>?M\<close>)
  moreover assume \<open>\<M> a ?M \<noteq> None\<close>
  ultimately have \<open>\<nabla>(the (\<M> a ?M))\<close> using \<M>_preserves_mst by (cases ?M) simp
  with \<open>\<nabla>?M\<close> show ?thesis by simp
qed

lemma mst_reachable_basic_is_mst: \<open>mst_reachable_basic M \<Longrightarrow> \<nabla>M\<close>
  unfolding mst_reachable_basic_def
proof -
  assume \<open>\<exists>s. mst_basic_trace s M\<^sub>0 = M\<close>
  then obtain s where \<open>mst_basic_trace s M\<^sub>0 = M\<close> by auto
  moreover from is_agent have \<open>\<nabla> M\<^sub>0\<close> by simp
  then have \<open>\<nabla>(mst_basic_trace s M\<^sub>0)\<close>
  proof (induct s)
    case (Cons a s)
    then have \<open>\<nabla>(mst_basic_trace s M\<^sub>0)\<close> .
    with mst_basic_trace_preserves_mst show ?case by (cases \<open>\<M> a (mst_basic_trace s M\<^sub>0)\<close>) (simp, blast)
  qed simp
  ultimately show ?thesis by simp
qed

lemma mst_reachable_basic_\<M>: \<open>mst_reachable_basic M \<Longrightarrow> \<M> a M \<noteq> None \<Longrightarrow> mst_reachable_basic (the (\<M> a M))\<close>
proof -
  assume \<open>mst_reachable_basic M\<close>
  then obtain S where \<open>mst_basic_trace S M\<^sub>0 = M\<close> unfolding mst_reachable_basic_def by auto
  moreover assume \<open>\<M> a M \<noteq> None\<close>
  ultimately have \<open>mst_basic_trace (a # S) M\<^sub>0 = the (\<M> a M)\<close> by auto
  then show ?thesis unfolding mst_reachable_basic_def by blast
qed

lemma mst_reachable_basic_trace:
  assumes \<open>s \<in> Agent\<close>
  shows   \<open>mst_reachable_basic (st_nth s i)\<close>
proof (induct i)
  case 0
  with assms have \<open>st_nth s 0 = M\<^sub>0\<close> unfolding Agent_def by simp
  then have \<open>mst_basic_trace [] M\<^sub>0 = (st_nth s 0)\<close> by simp
  then show ?case unfolding mst_reachable_basic_def by blast
next
  case (Suc i)
  then obtain S where *: \<open>mst_basic_trace S M\<^sub>0 = st_nth s i\<close> unfolding mst_reachable_basic_def by auto
  from assms have \<open>is_trace s\<close> unfolding Agent_def by simp
  then have
    \<open>(((st_nth s i) \<rightarrow>(act_nth s i) (st_nth s (i+1))) \<or>
        \<not>(\<exists>M. ((st_nth s i) \<rightarrow>(act_nth s i) M)) \<and> (st_nth s i) = (st_nth s (i+1)))\<close>
    unfolding is_trace_def by auto
  then show ?case
  proof
    assume \<open>(st_nth s i) \<rightarrow>(act_nth s i) (st_nth s (i+1))\<close>
    moreover from this \<M>_suc_state have \<open>(st_nth s (i+1)) = the (\<M> (snd (act_nth s i)) (st_nth s i))\<close>
      using \<open>s \<in> Agent\<close> unfolding transition_def by (metis option.distinct(1))
    ultimately show ?thesis using Suc mst_reachable_basic_\<M> unfolding transition_def by fastforce
  next
    assume \<open>\<not>(\<exists>M. ((st_nth s i) \<rightarrow>(act_nth s i) M)) \<and> (st_nth s i) = (st_nth s (i+1))\<close>
    with * show ?thesis unfolding mst_reachable_basic_def by auto
  qed
qed

section \<open>Semantics\<close>

\<comment> \<open>Truth of enabledness (semantics).\<close>
fun semantics\<^sub>E' :: \<open>mental_state \<Rightarrow> Atom\<^sub>E \<Rightarrow> bool\<close> where
  \<comment> \<open>Semantics of B and G are the same as for mental state formulas without enabled.\<close>
  \<open>semantics\<^sub>E' M (Bl\<^sub>E \<Phi>) = (M \<Turnstile>\<^sub>M* Atom\<^sub>M.Bl \<Phi>)\<close> |
  \<open>semantics\<^sub>E' M (Gl\<^sub>E \<Phi>) = (M \<Turnstile>\<^sub>M* Atom\<^sub>M.Gl \<Phi>)\<close> |
  \<comment> \<open>a is defined for the action and \<M> a is defined for M.\<close>
  \<open>semantics\<^sub>E' M (enabled_basic a) = (a \<in> Cap \<and> \<M> a M \<noteq> None)\<close> |
  \<comment> \<open>Conditional action b is enabled if there exists a transition from M to M' using b for some M'.\<close>
  \<open>semantics\<^sub>E' M (enabled_cond b) = (\<exists>M'. (M \<rightarrow>b M'))\<close>

\<comment> \<open>Semantics of atoms with enabled can be seen as an interpretation given a mental state.\<close>
abbreviation semantics\<^sub>E :: \<open>mental_state \<Rightarrow> \<Phi>\<^sub>E \<Rightarrow> bool\<close> (infix \<open>\<Turnstile>\<^sub>E\<close> 50) where
  \<open>M \<Turnstile>\<^sub>E \<phi> \<equiv> semantics\<^sub>P (semantics\<^sub>E' M) \<phi>\<close>

abbreviation semantics\<^sub>_all\<^sub>E :: \<open>\<Phi>\<^sub>E \<Rightarrow> bool\<close> (\<open>\<^bold>\<Turnstile>\<^sub>E\<close>) where
  \<open>\<^bold>\<Turnstile>\<^sub>E \<phi> \<equiv> (\<forall>M. mst_reachable_basic M \<longrightarrow> M \<Turnstile>\<^sub>E \<phi>)\<close>

abbreviation semantics\<^sub>_all\<^sub>M :: \<open>\<Phi>\<^sub>M \<Rightarrow> bool\<close> (\<open>\<^bold>\<Turnstile>\<^sub>M\<close>) where
  \<open>\<^bold>\<Turnstile>\<^sub>M \<phi> \<equiv> (\<forall>M. mst_reachable_basic M \<longrightarrow> M \<Turnstile>\<^sub>M \<phi>)\<close>

\<comment> \<open>Bel-upd-t not enabled\<close>
lemma bel_upd_not_enabled: \<open>\<T> a M = None \<Longrightarrow> \<not> M \<Turnstile>\<^sub>E enabledb (basic a)\<close>
proof -
  assume \<open>\<T> a M = None\<close>
  with mst_none have \<open>\<M> (basic a) M = None\<close> by simp
  then show \<open>\<not> M \<Turnstile>\<^sub>E enabledb (basic a)\<close> by simp
qed

\<comment> \<open>The semantics of a converted formula is equal to the original.\<close>
lemma transfer_semantics\<^sub>M: \<open>M \<Turnstile>\<^sub>M \<phi> \<longleftrightarrow> M \<Turnstile>\<^sub>E \<phi>\<^sup>E\<close>
proof (induct \<phi>)
  case (Atom x)
  show ?case by (cases x) simp_all
qed simp_all

\<comment> \<open>Formula conversion preserves semantics\<close>
lemma sem_preserve_to_\<Phi>\<^sub>M: \<open>to_\<Phi>\<^sub>M \<phi> \<noteq> None \<Longrightarrow> M \<Turnstile>\<^sub>E \<phi> \<longleftrightarrow> M \<Turnstile>\<^sub>M (the (to_\<Phi>\<^sub>M \<phi>))\<close>
proof (induct \<phi>)
  case (Atom x)
  then show ?case by (induct x) auto
next
  case (Negation \<phi>)
  moreover from this have \<open>to_\<Phi>\<^sub>M \<phi> \<noteq> None\<close> by (metis option.simps(4) to_\<Phi>\<^sub>M.simps(4))
  ultimately show ?case by auto
next
  case (Implication \<phi>\<^sub>1 \<phi>\<^sub>2)
  moreover from this have \<open>to_\<Phi>\<^sub>M \<phi>\<^sub>1 \<noteq> None\<close> \<open>to_\<Phi>\<^sub>M \<phi>\<^sub>2 \<noteq> None\<close>
    using case_prod_conv to_\<Phi>\<^sub>M.simps(5)
      by (metis option.simps(4), metis (no_types, lifting) option.case_eq_if)
    ultimately show ?case by auto
next
  case (Disjunction \<phi>\<^sub>1 \<phi>\<^sub>2)
  moreover from this have \<open>to_\<Phi>\<^sub>M \<phi>\<^sub>1 \<noteq> None\<close> \<open>to_\<Phi>\<^sub>M \<phi>\<^sub>2 \<noteq> None\<close>
    using case_prod_conv to_\<Phi>\<^sub>M.simps(6)
      by (metis option.simps(4), metis (no_types, lifting) option.case_eq_if)
    ultimately show ?case by auto
next
  case (Conjunction \<phi>\<^sub>1 \<phi>\<^sub>2)
  moreover from this have \<open>to_\<Phi>\<^sub>M \<phi>\<^sub>1 \<noteq> None\<close> \<open>to_\<Phi>\<^sub>M \<phi>\<^sub>2 \<noteq> None\<close>
    using case_prod_conv to_\<Phi>\<^sub>M.simps(7)
      by (metis option.simps(4), metis (no_types, lifting) option.case_eq_if)
    ultimately show ?case by auto
qed simp

lemma sem_set_preserve_to_\<Phi>\<^sub>M:
  assumes \<open>None \<notin> set (map to_\<Phi>\<^sub>M \<Delta>)\<close>
  shows   \<open>\<forall>\<phi> \<in> set \<Delta>. M \<Turnstile>\<^sub>E \<phi> \<longleftrightarrow> M \<Turnstile>\<^sub>M (the (to_\<Phi>\<^sub>M \<phi>))\<close>
proof
  fix \<phi>
  assume \<open>\<phi> \<in> set \<Delta>\<close>
  with assms have \<open>to_\<Phi>\<^sub>M \<phi> \<noteq> None\<close> by force
  with sem_preserve_to_\<Phi>\<^sub>M show \<open>(M \<Turnstile>\<^sub>E \<phi>) = (M \<Turnstile>\<^sub>M the (to_\<Phi>\<^sub>M \<phi>))\<close> by simp
qed

\<comment> \<open>Example.\<close>
lemma \<open>(M\<^sub>0 \<rightarrow>b M\<^sub>1) \<Longrightarrow> M\<^sub>0 \<Turnstile>\<^sub>E enabled b\<close>
proof -
  assume \<open>M\<^sub>0 \<rightarrow>b M\<^sub>1\<close>
  then have \<open>\<exists>M'. (M\<^sub>0 \<rightarrow>b M')\<close> by blast
  then show \<open>M\<^sub>0 \<Turnstile>\<^sub>E enabled b\<close> by simp
qed

section \<open>Proof system\<close>

inductive gen\<^sub>E :: \<open>Atom\<^sub>E gen_rules\<close> where
  E1\<^sub>E: \<open>(\<phi> \<triangleright> do a) \<in> \<Pi> \<Longrightarrow> enabled (\<phi> \<triangleright> do a) \<^bold>\<longleftrightarrow> (\<phi>\<^sup>E \<^bold>\<and> enabledb a) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>E \<Gamma> \<Delta>\<close> |
  E2\<^sub>E: \<open>enabledb (drop \<Phi>) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>E \<Gamma> \<Delta>\<close> |
  R3\<^sub>E: \<open>\<not> \<Turnstile>\<^sub>P (\<^bold>\<not> \<Phi>) \<Longrightarrow> \<^bold>\<not> (B\<^sub>E \<Phi>) \<^bold>\<longleftrightarrow> enabledb (adopt \<Phi>) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>E \<Gamma> \<Delta>\<close> |
  R4\<^sub>E: \<open>\<Turnstile>\<^sub>P (\<^bold>\<not> \<Phi>) \<Longrightarrow> \<^bold>\<not> (enabledb (adopt \<Phi>)) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>E \<Gamma> \<Delta>\<close> |
  R5\<^sub>E: \<open>\<forall>M. \<nabla>M \<longrightarrow> \<T> a M \<noteq> None \<Longrightarrow> enabledb (basic a) \<in> set \<Delta> \<Longrightarrow> gen\<^sub>E \<Gamma> \<Delta>\<close> |
  R_M: \<open>gen\<^sub>M \<Gamma> \<Delta> \<Longrightarrow> gen\<^sub>E (map to_\<Phi>\<^sub>E \<Gamma>) (map to_\<Phi>\<^sub>E \<Delta>)\<close>

abbreviation derive\<^sub>M_multi :: \<open>\<Phi>\<^sub>E list \<Rightarrow> \<Phi>\<^sub>E list \<Rightarrow> bool\<close> (infix \<open>\<turnstile>\<^sub>E#\<close> 40) where
  \<open>\<Gamma> \<turnstile>\<^sub>E# \<Delta> \<equiv> gen_sc (Some gen\<^sub>E) \<Gamma> \<Delta>\<close>

abbreviation derive\<^sub>E :: \<open>\<Phi>\<^sub>E \<Rightarrow> bool\<close> (\<open>\<turnstile>\<^sub>E _\<close> 40) where
  \<open>\<turnstile>\<^sub>E \<phi> \<equiv> [] \<turnstile>\<^sub>E# [ \<phi> ]\<close>

section \<open>Soundness\<close>

\<comment> \<open>The soundness theorem.\<close>

lemma soundness\<^sub>_gen\<^sub>E:
  assumes \<open>\<nabla> M\<close>
  shows \<open>gen\<^sub>E \<Gamma> \<Delta> \<Longrightarrow> \<forall>\<gamma> \<in> set \<Gamma>. M \<Turnstile>\<^sub>E \<gamma> \<Longrightarrow> \<exists>\<Phi> \<in> set \<Delta>. M \<Turnstile>\<^sub>E \<Phi>\<close>
proof (induct rule: gen\<^sub>E.induct)
  case (E1\<^sub>E \<phi> a \<Gamma> \<Delta>)
  have \<open>M \<Turnstile>\<^sub>E enabled (\<phi> \<triangleright> do a) \<longleftrightarrow> M \<Turnstile>\<^sub>M \<phi> \<and> M \<Turnstile>\<^sub>E enabledb a\<close>
  proof -
    have \<open>M \<Turnstile>\<^sub>E enabled (\<phi> \<triangleright> do a) \<longleftrightarrow> (\<exists>M'. (M \<rightarrow>(\<phi> \<triangleright> do a) M'))\<close> by simp
    also have \<open>\<dots> \<longleftrightarrow> (\<exists>M'. (\<phi> \<triangleright> do a) \<in> \<Pi> \<and> M \<Turnstile>\<^sub>M \<phi> \<and> \<M> a M = Some M')\<close>
      unfolding transition_def by simp
    finally show ?thesis using \<open>(\<phi> \<triangleright> do a) \<in> \<Pi>\<close> \<M>_some_Cap by fastforce
  qed
  with transfer_semantics\<^sub>M have \<open>M \<Turnstile>\<^sub>E enabled (\<phi> \<triangleright> do a) \<^bold>\<longleftrightarrow> (\<phi>\<^sup>E \<^bold>\<and> enabledb a)\<close> by simp
  with E1\<^sub>E show ?case by blast
next
  case (E2\<^sub>E \<Phi> \<Delta> \<Gamma>)
  moreover have \<open>\<M> (drop \<Phi>) M \<noteq> None\<close> using mental_state_transformer.simps(2) by (cases M) simp
  ultimately show ?case using \<M>_some_Cap by (metis semantics\<^sub>E'.simps(3) semantics\<^sub>P.simps(1))
next
  case (R3\<^sub>E \<Phi>)
  with adopt_Cap have \<open>M \<Turnstile>\<^sub>E \<^bold>\<not> (B\<^sub>E \<Phi>) \<^bold>\<longleftrightarrow> enabledb (adopt \<Phi>)\<close> using \<M>_some_Cap by (cases M) simp
  with R3\<^sub>E show ?case by blast
next
  case (R4\<^sub>E \<Phi> \<Delta> \<Gamma>)
  then have \<open>\<forall>M. \<M> (adopt \<Phi>) M = None\<close> by fastforce
  then have \<open>\<M> (adopt \<Phi>) M = None\<close> by blast
  then have \<open>M \<Turnstile>\<^sub>E \<^bold>\<not> (enabledb (adopt \<Phi>))\<close> by simp
  with R4\<^sub>E show ?case by blast
next
  case (R5\<^sub>E a \<Delta> \<Gamma>)
  then have \<open>\<T> a M \<noteq> None\<close> using \<open>\<nabla>M\<close> by blast
  then have \<open>\<M> (basic a) M \<noteq> None\<close> by (cases M) auto
  with \<M>_some_Cap have \<open>M \<Turnstile>\<^sub>E enabledb (basic a)\<close> by simp
  with R5\<^sub>E show ?case by blast
next
  case (R_M \<Gamma> \<Delta>)
  with transfer_semantics\<^sub>M have \<open>\<forall>\<gamma> \<in> set \<Gamma>. M \<Turnstile>\<^sub>M \<gamma>\<close> by simp
  with soundness\<^sub>_gen\<^sub>M have \<open>\<exists>\<Phi> \<in> set \<Delta>. M \<Turnstile>\<^sub>M \<Phi>\<close>  using R_M assms by simp
  with transfer_semantics\<^sub>M show ?case by simp
qed

lemma soundness\<^sub>E':
  assumes \<open>\<nabla> M\<close>
  shows \<open>gen_sc R \<Gamma> \<Delta> \<Longrightarrow> R = Some gen\<^sub>E \<Longrightarrow> \<forall>\<gamma> \<in> set \<Gamma>. M \<Turnstile>\<^sub>E \<gamma> \<Longrightarrow> \<exists>\<Phi> \<in> set \<Delta>. M \<Turnstile>\<^sub>E \<Phi>\<close>
proof (induct rule: gen_sc.induct)
  case (Gen R \<Gamma> \<Delta>)
  with soundness\<^sub>_gen\<^sub>E show ?case using assms by simp
qed auto

theorem soundness\<^sub>E:
  assumes \<open>\<nabla> M\<close>
  shows \<open>\<turnstile>\<^sub>E \<phi> \<Longrightarrow> M \<Turnstile>\<^sub>E \<phi>\<close>
  using soundness\<^sub>E' assms by fastforce

end
end


theory ExtExecution
imports
  "../Protocol"
  ExecMessage
  WelltypedSubst
  ThreadPool
begin

section{* Execution Model *}

subsection{* Types and Operations *}

subsubsection{* Execution Events *}

datatype execevent =
    FromIK0 execmsg
  | MkStep tid rolestep
  | MkHash execmsg
  | MkUnt  execmsg execmsg
  | MkTup  execmsg execmsg
  | MkEncr execmsg execmsg
  | MkDecr execmsg execmsg

types trace = "execevent list"

text{*
  The eventMsg is a technical construction used as an over-approximation
  over the input and output messages in order to simplify formulating
  the lemma about all messages of past events in the system being ground.
*}

fun eventMsg :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg"
where
  "eventMsg s (MkStep tid (Send lbl msg)) = subst s (s2e msg tid)"
| "eventMsg s (MkStep tid (Recv lbl msg)) = subst s (s2e msg tid)"
| "eventMsg s (FromIK0 m) = m"
| "eventMsg s (MkTup x y)  = Tup x y"
| "eventMsg s (MkUnt x y)  = Tup x y"
| "eventMsg s (MkHash m)   = Hash m"
| "eventMsg s (MkEncr m k) = Enc m k"
| "eventMsg s (MkDecr m k) = Enc m k"

subsubsection{* Intruder Knowledge *}

fun knows :: "wt_subst \<Rightarrow> trace \<Rightarrow> execmsg set"
where
  "knows s [] = {}"
| "knows s (MkStep tid (Send lbl msg) # es) =
     insert (subst s (s2e msg tid)) (knows s es)"
| "knows s (MkStep tid (Recv lbl msg) # es) = (knows s es)"
| "knows s (FromIK0 m # es)  = insert m           (knows s es)"
| "knows s (MkTup x y # es)  = insert (Tup x y)   (knows s es)"
| "knows s (MkUnt x y # es)  = insert x (insert y (knows s es))"
| "knows s (MkHash m   # es) = insert (Hash m)    (knows s es)"
| "knows s (MkEncr m k # es) = insert (Enc m k)   (knows s es)"
| "knows s (MkDecr m k # es) = insert m           (knows s es)"

fun eout :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "eout s (MkStep tid (Send lbl msg)) =
     {subst s (s2e msg tid)}"
| "eout s (MkStep tid (Recv lbl msg)) = {}"
| "eout s (FromIK0 m)                 = {m}"
| "eout s (MkTup x y )                = {Tup x y}"
| "eout s (MkUnt x y )                = {x,y}"
| "eout s (MkHash m  )                = {Hash m}"
| "eout s (MkEncr m k)                = {Enc m k}"
| "eout s (MkDecr m k)                = {m}"

subsubsection{* Reachable States during Execution *}

types state = "trace \<times> rolestep threadpool \<times> wt_subst"

text{* access the state's substitution *}
fun sts :: "state \<Rightarrow> wt_subst"
where "sts (t,r,s) = s"

inductive_set
  reachable :: "proto \<Rightarrow> state set"
  for P     :: "proto"
where
  init: "([], empty, empty_wts) \<in> reachable P"

| create:"\<lbrakk> (t, r, s) \<in> reachable P;
            tid \<notin> dom r;
            R \<in> P;
            dom_wts \<alpha> = {EVar (AVar a) tid | a tid. True};
            ran_wts \<alpha> = {Lit (EHonest a)   | a. True}
          \<rbrakk>
          \<Longrightarrow> (t, r(tid \<mapsto> newThread (Rep_role R)), extend_wts s \<alpha>) \<in> reachable P"

| send:  "\<lbrakk> (t, r, s) \<in> reachable P;
            Some (Send l msg) = curStep r tid
          \<rbrakk>
          \<Longrightarrow> (t @ [MkStep tid (Send l msg)], nextStep r tid, s) \<in> reachable P"

| recv:  "\<lbrakk> (t, r, s) \<in> reachable P;
            Some (Recv l msg) = curStep r tid;
            dom_wts \<alpha> = { EVar v tid | v. v \<in> FV msg };
            subst (extend_wts s \<alpha>) (s2e msg tid) \<in> knows s t
          \<rbrakk>
          \<Longrightarrow> (t @ [MkStep tid (Recv l msg)], nextStep r tid, extend_wts s \<alpha>) \<in> reachable P"

| ik0:   "\<lbrakk> (t, r, s) \<in> reachable P;
            m \<in> IK0
          \<rbrakk>
          \<Longrightarrow> (t @ [FromIK0 m], r, s) \<in> reachable P"

| hash:  "\<lbrakk> (t, r, s) \<in> reachable P;
            m \<in> knows s t
          \<rbrakk>
          \<Longrightarrow> (t @ [MkHash m], r, s) \<in> reachable P"

| tuple: "\<lbrakk> (t, r, s) \<in> reachable P;
            x \<in> knows s t;
            y \<in> knows s t
          \<rbrakk>
          \<Longrightarrow> (t @ [MkTup x y], r, s) \<in> reachable P"

| untup: "\<lbrakk> (t, r, s) \<in> reachable P;
            Tup x y \<in> knows s t
          \<rbrakk>
          \<Longrightarrow> (t @ [MkUnt x y], r, s) \<in> reachable P"

| encr:  "\<lbrakk> (t, r, s) \<in> reachable P;
            m \<in> knows s t;
            k \<in> knows s t
          \<rbrakk>
          \<Longrightarrow> (t @ [MkEncr m k], r, s) \<in> reachable P"

| decr:  "\<lbrakk> (t, r, s) \<in> reachable P;
            Enc m k \<in> knows s t;
            inv k \<in> knows s t
          \<rbrakk>
          \<Longrightarrow> (t @ [MkDecr m k], r, s) \<in> reachable P"

subsection{* Properties *}

subsubsection{* Execution Events *}

lemma eventMsg_ground_extend_wts:
  "ground (eventMsg s e) \<Longrightarrow>
   eventMsg (extend_wts s s') e = eventMsg s e"
  apply(induct rule: eventMsg.induct)
  by(simp_all add: extend_wts_conv_subst)

lemma knows_append[simp]:
  "knows s (t @ t') = knows s t \<union> knows s t'"
  by(induct t rule: knows.induct, auto )

lemma knows_MkHash: "MkHash m \<in> set t \<Longrightarrow> Hash m \<in> knows s t"
  by(induct t rule: knows.induct, auto )

lemma knows_MkTup: "MkTup x y \<in> set t \<Longrightarrow> Tup x y \<in> knows s t"
  by(induct t rule: knows.induct, auto )

lemma knows_MkUnt1: "MkUnt x y \<in> set t \<Longrightarrow> x \<in> knows s t"
  by(induct t rule: knows.induct, auto )

lemma knows_MkUnt2: "MkUnt x y \<in> set t \<Longrightarrow> y \<in> knows s t"
  by(induct t rule: knows.induct, auto )

lemma knows_MkEncr: "MkEncr m k \<in> set t \<Longrightarrow> Enc m k \<in> knows s t"
  by(induct t rule: knows.induct, auto )

lemma knows_MkDecr: "MkDecr m k \<in> set t \<Longrightarrow> m \<in> knows s t"
  by(induct t rule: knows.induct, auto )

lemma knows_ground_extend_wts:
  "\<lbrakk> \<And> m. m \<in> knows s t \<Longrightarrow> ground m \<rbrakk> \<Longrightarrow>
   knows (extend_wts s s') t = knows s t"
  apply(induct rule: knows.induct)
  apply(simp_all add: extend_wts_conv_subst)
  done

lemma eout_ground_by_eventMsg_ground:
  "\<lbrakk> m \<in> eout s e; ground (eventMsg s e) \<rbrakk> \<Longrightarrow> ground m"
  by(induct e rule: eout.induct, auto)

lemma knows_conv_eout:
  "knows s t = (\<Union> e \<in> set t. eout s e)"
  by(induct t rule: knows.induct, auto)

subsubsection{* Reachable States *}

lemma reachable_proto_roles:
  "\<lbrakk> (t,r,s) \<in> reachable P; r tid = Some (todo,done) \<rbrakk>
  \<Longrightarrow> \<exists> R \<in> P. Rep_role R = rev done @ todo"
  apply(induct arbitrary: tid todo "done" rule: reachable.induct)
  apply(auto simp: newThread_def curStep_def nextStep_def split: if_splits option.splits list.splits)
  done

lemma reachable_Step_in_threadpool:
  "\<lbrakk> MkStep tid step \<in> set t; (t,r,s) \<in> reachable P \<rbrakk>
  \<Longrightarrow> \<exists> todo done. r tid = Some (todo,done)"
  by(rotate_tac 1, induct rule: reachable.induct, auto simp: nextStep_def)

lemma reachable_todo_notin_trace:
  "\<lbrakk> r tid = Some (todo,done); step \<in> set todo; (t,r,s) \<in> reachable P \<rbrakk> \<Longrightarrow>
     MkStep tid step \<notin> set t"
  apply(rotate_tac -1)
  proof(induct arbitrary: tid todo "done" rule: reachable.induct)
    case init thus ?case by simp next
    case (create t r s tid' R \<alpha>) thus ?case
      apply(clarsimp simp: newThread_def curStep_def split: option.splits if_splits)
      apply(drule reachable_Step_in_threadpool, assumption, simp)
      apply(auto)
      done
  next
    case (send t r s l msg tid') thus ?case
      apply(clarsimp simp: nextStep_def curStep_def
                    split: option.splits if_splits list.splits)
      apply(drule reachable_proto_roles, assumption)
      apply(clarsimp)
      apply(subgoal_tac "distinct (Rep_role R)")
      apply(force)
      apply(rule Rep_role_distinct)
      apply(force)
      done
  next
    case (recv t r s l msg tid \<alpha> tid' todo "done") thus ?case
      apply(clarsimp simp: nextStep_def curStep_def
                    split: option.splits if_splits list.splits)
      apply(drule reachable_proto_roles, assumption)
      apply(clarsimp)
      apply(subgoal_tac "distinct (Rep_role R)")
      apply(force)
      apply(rule Rep_role_distinct)
      apply(force)
      done
  next case hash thus ?case by auto
  next case encr thus ?case by auto
  next case decr thus ?case by auto
  next case tuple thus ?case by auto
  next case untup thus ?case by auto
  next case ik0 thus ?case by auto
qed

lemma reachable_done_in_trace:
  "\<lbrakk> r tid = Some (todo,done); step \<in> set done; (t,r,s) \<in> reachable P \<rbrakk> \<Longrightarrow>
     MkStep tid step \<in> set t"
  apply(rotate_tac -1)
  proof(induct arbitrary: tid todo "done" rule: reachable.induct)
    case init thus ?case by simp next
    case (create t r s tid' R \<alpha>) thus ?case
      apply(clarsimp simp: newThread_def curStep_def split: option.splits if_splits)
      apply(rule FalseE)
      apply(thin_tac "dom_wts ?x = ?X")
      apply(auto)
      done
  next
    case (send t r s l msg tid') thus ?case
      apply(clarsimp simp: nextStep_def curStep_def
                    split: option.splits if_splits list.splits)
      apply(auto)
      done
  next
    case (recv t r s l msg tid \<alpha> tid' todo "done") thus ?case
      apply(clarsimp simp: nextStep_def curStep_def
                    split: option.splits if_splits list.splits)
      apply(thin_tac "dom_wts ?x = ?X", force)+
      done
  next case hash thus ?case by auto
  next case encr thus ?case by auto
  next case decr thus ?case by auto
  next case tuple thus ?case by auto
  next case untup thus ?case by auto
  next case ik0 thus ?case by auto
qed

lemma reachable_roleOrd:
  "\<lbrakk> (t, r, s) \<in> reachable P; r tid = Some (todo,done);
     (prev, step) \<in> listOrd (rev done) \<rbrakk>
   \<Longrightarrow> (MkStep tid prev, MkStep tid step) \<in> listOrd (rev (remdups (rev t)))"
  proof (induct arbitrary: tid todo "done" rule: reachable.induct)
    case init thus ?case by simp
  next
    case (create t r s tid' R \<alpha>) thus ?case
      by(auto simp: newThread_def split: if_splits)
  next
   case (send t r s l msg tid') thus ?case
      apply(clarsimp simp: nextStep_def curStep_def
                    split: option.splits if_splits list.splits)
      apply(frule reachable_proto_roles, assumption)
      apply(auto dest: reachable_todo_notin_trace reachable_done_in_trace)
      apply(force)
      done
  next
   case (recv t r s l msg tid') thus ?case
      apply(thin_tac "dom_wts ?x = ?X")
      apply(clarsimp simp: nextStep_def curStep_def
                    split: option.splits if_splits list.splits)
      apply(frule reachable_proto_roles, assumption)
      apply(auto dest: reachable_todo_notin_trace reachable_done_in_trace)
      apply(force)
      done
  next case hash thus ?case by auto
  next case encr thus ?case by auto
  next case decr thus ?case by auto
  next case tuple thus ?case by auto
  next case untup thus ?case by auto
  next case ik0 thus ?case by auto
qed

lemma reachable_subst_dom_AVar:
  "\<lbrakk> (t,r,s) \<in> reachable P; r tid = Some thread \<rbrakk>
  \<Longrightarrow> EVar (AVar a) tid \<in> dom_wts s"
  apply(induct arbitrary: tid thread rule: reachable.induct, simp_all)
  by(simp_all add: curStep_def nextStep_def split: option.splits if_splits)

lemma reachable_subst_dom_MVar:
  "\<lbrakk> (t,r,s) \<in> reachable P;
     r tid = Some (todo,done); Recv l msg \<in> set done;
     MVar v \<in> FV msg
   \<rbrakk> \<Longrightarrow>
   EVar (MVar v) tid \<in> dom_wts s"
proof(induct arbitrary: tid todo "done" rule: reachable.induct)
  case init thus ?case by simp next
  case create thus ?case
    by(auto simp: newThread_def split: option.splits if_splits)
next
  case (send t r s lbl msg' tid tid') thus ?case
    apply(clarsimp simp: curStep_def nextStep_def
                  split: option.splits if_splits list.splits)
    by(auto)
next
  case (recv t r s lbl msg' tid \<alpha> tid') thus ?case
    apply(clarsimp simp: curStep_def nextStep_def
                  split: option.splits if_splits list.splits)
    apply(thin_tac "dom_wts \<alpha> = ?X", force)
    apply(thin_tac "?x = ?y", force)
    done
next
  case hash thus ?case by auto next
  case tuple thus ?case by auto next
  case encr thus ?case by auto next
  case decr thus ?case by auto next
  case ik0 thus ?case by auto
qed

lemma reachable_eventMsg_ground:
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t \<rbrakk> \<Longrightarrow> ground (eventMsg s e)"
proof (induct arbitrary: m e rule: reachable.induct)
  case init thus ?case by auto
next
  case (hash t r s m m') thus ?case
    apply(auto simp add: knows_conv_eout)
    apply(force dest: eout_ground_by_eventMsg_ground)
    done
next
  case ik0 thus ?case by auto
next
  case encr thus ?case
    apply(auto simp add: knows_conv_eout)
    apply(auto dest: eout_ground_by_eventMsg_ground)
    done
next
  case (decr t r s m k m') thus ?case
    apply(auto simp add: knows_conv_eout)
    apply(auto dest: eout_ground_by_eventMsg_ground)
    done
next
  case tuple thus ?case
    apply(auto simp add: knows_conv_eout)
    apply(auto dest: eout_ground_by_eventMsg_ground)
    done
next
  case (untup t r s x y m) thus ?case
    apply(auto simp add: knows_conv_eout)
    apply(auto dest: eout_ground_by_eventMsg_ground)
    done
next
  case (create t r s tid' R \<alpha> m) thus ?case
    by(auto simp: eventMsg_ground_extend_wts)
next
  case (send t r s l msg tid m) thus ?case
    apply(auto)
    apply(subst ground_subst_s2e_conv_FV)
    apply(clarsimp)
    apply(case_tac v, simp_all)
    apply(drule Some_curStepD, clarsimp)
    apply(rule reachable_subst_dom_AVar, assumption+)
    apply(drule Some_curStepD, clarsimp)
    apply(frule reachable_proto_roles, assumption, clarsimp)
    apply(auto dest!: Rep_role_Send_FV intro: reachable_subst_dom_MVar)
    done
next
  case (recv t r s l msg tid \<alpha> m) thus ?case
    by(auto simp: eventMsg_ground_extend_wts ground_subst_s2e_conv_FV)
qed

lemma reachable_Send_ground:
  "\<lbrakk> (t,r,s) \<in> reachable P;
     Some (Send l msg) = curStep r tid
   \<rbrakk>
   \<Longrightarrow> ground (subst s (s2e msg tid))"
  apply(subgoal_tac
   "(t@[MkStep tid (Send l msg)],nextStep r tid,s) \<in> reachable P")
  apply(auto dest: reachable_eventMsg_ground intro!: reachable.send)
  done

lemma reachable_knows_ground:
  "\<lbrakk> (t,r,s) \<in> reachable P; m \<in> knows s t \<rbrakk> \<Longrightarrow> ground m"
  by(auto simp: reachable_eventMsg_ground knows_conv_eout
         elim!: eout_ground_by_eventMsg_ground)

lemma reachable_eout_ground:
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t; m \<in> eout s e; m \<notin> IK0 \<rbrakk>
   \<Longrightarrow> ground m"
  by(auto dest!: reachable_knows_ground simp: knows_conv_eout)

lemma reachable_eout_extend_wts [simp]:
  "\<lbrakk> (t,r,s) \<in> reachable P; e \<in> set t \<rbrakk> \<Longrightarrow>
   eout (extend_wts s \<alpha>) e = eout s e"
  apply(induct rule: eout.induct)
  apply(auto dest: reachable_eventMsg_ground
             simp: extend_wts_conv_subst)
  done

lemma reachable_knows_extend_wts [simp]:
  "(t,r,s) \<in> reachable P \<Longrightarrow> knows (extend_wts s s') t = knows s t"
  by(simp add: knows_conv_eout)

end


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

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_on_inv__7 imports n_germanSimp_base
begin
section{*All lemmas on causal relation between inv__7 and some rule r*}
lemma n_SendInv__part__0Vsinv__7:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__7:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__7:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__7:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__7:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''ExGntd'')) (Const false)) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv3) ''State'')) (Const E))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__7:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__7:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv3 p__Inv4 where a2:"p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i=p__Inv3)\<or>(i~=p__Inv3\<and>i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv3)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const GntE)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv3) ''Cmd'')) (Const GntE))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv3\<and>i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__7:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvInvAckVsinv__7:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqE__part__0Vsinv__7:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqE__part__1Vsinv__7:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

lemma n_RecvReqSVsinv__7:
  assumes a1: "\<exists> i. i\<le>N\<and>r=n_RecvReqS N i" and
  a2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__7  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


theory UnpairedLogic
imports
  UnpairedExecution
begin

subsection{* Input Terms *}

fun inp :: "wt_subst \<Rightarrow> execevent \<Rightarrow> execmsg set"
where
  "inp s (MkStep tid (Send l msg)) = {}"
| "inp s (MkStep tid (Recv l msg)) = unpair (subst s (s2e msg tid))"
| "inp s (FromIK0 m)               = {}"
| "inp s (MkHash m)                = unpair m"
| "inp s (MkTup x y)               = unpair x \<union> unpair y"
| "inp s (MkFst x y)               = {Tup x y}"
| "inp s (MkSnd x y)               = {Tup x y}"
| "inp s (MkEncr m k)              = unpair m \<union> unpair k"
| "inp s (MkDecr m k)              = insert (Enc m k) (unpair (inv k))"

lemma inp_ground_by_eventMsg_ground:
  "\<lbrakk> m \<in> inp s e; ground (eventMsg s e) \<rbrakk> \<Longrightarrow> ground m"
  apply(induct e rule: inp.induct)
  apply(auto intro: ground_unpaired)
  apply(rule_tac m="inv k" in ground_unpaired, auto)
  done

fun ucUnpairMsg :: "execmsg \<Rightarrow> knevent list"
where
  "ucUnpairMsg (Tup x y) =
    \<Delta> MkFst x y # \<star> x # ucUnpairMsg x @
    \<Delta> MkSnd x y # \<star> y # ucUnpairMsg y"
| "ucUnpairMsg m = []"

lemma set_unpairMsg_subset_set_ucUnpairMsg:
  "set (unpairMsg knows m) \<subseteq> set (ucUnpairMsg m)"
  by(induct m arbitrary: knows, auto split: if_splits)

lemmas set_unpairMsg_subset_set_ucUnpairMsgD =
  subsetD[OF set_unpairMsg_subset_set_ucUnpairMsg, rule_format]

declare reachable_state.intro[intro!, simp]

context reachable_state begin

lemma ground_by_eventMsg:
  "\<lbrakk> \<Delta>(e) \<in> set t; eventMsg s e = m \<rbrakk> \<Longrightarrow> ground m"
  by(auto dest!: eventMsg_ground)

lemma inp_extend_wts:
  "\<Delta>(e) \<in> set t \<Longrightarrow> inp (extend_wts s s') e = inp s e"
  apply(insert reachable)
  apply(induct rule: inp.induct)
  apply(simp_all add: extend_wts_conv_subst)
  apply(subst subst_ground_msg)
  apply(auto intro!: reachable_state.ground_by_eventMsg)
  done

declare reachable_state.inp_extend_wts
          [OF reachable_state.intro, simp]

lemma MkFst_unpairMsg_inp_known:
  "\<Delta> (MkFst x y) \<in> set (unpairMsg knows m) \<Longrightarrow>
   Tup x y \<in> knows \<or> Tup x y \<in> pairParts m"
  by(induct m arbitrary: knows, auto split: if_splits)

lemma MkSnd_unpairMsg_inp_known:
  "\<Delta> (MkSnd x y) \<in> set (unpairMsg knows m) \<Longrightarrow>
   Tup x y \<in> knows \<or> Tup x y \<in> pairParts m"
  by(induct m arbitrary: knows, auto split: if_splits)

lemma Knows_inp_unpairMsg:
  "\<lbrakk> \<Delta> e \<in> set (unpairMsg knows m); m' \<in> inp s' e; m' \<notin> knows; m' \<noteq> m \<rbrakk> \<Longrightarrow>
   \<star> m' \<in> set (unpairMsg knows m)"
  apply(frule in_set_unpairMsg_casesD)
  apply(auto dest!: MkFst_unpairMsg_inp_known MkSnd_unpairMsg_inp_known
             elim!: Knows_in_set_unpairMsgI)
  done

lemma Knows_mostly_unpaired:
  "\<lbrakk> t = t' @ \<Delta> e # t''; \<star> m \<in> set t'; m' \<in> pairParts m \<rbrakk> \<Longrightarrow>
   \<star> m' \<in> set t'"
  apply(insert reachable, rotate_tac -1)
proof(induct arbitrary: e m m' t' t'' rule: reachable.induct)
  case (hash t r s m e m' x t' t'')
  show ?case using prems(4-9)
thm prems(3)
    apply(subst (asm) append_eq_append_conv2)
    apply(clarsimp)
    apply(erule disjE)
    apply(simp)
    apply(erule disjE)
    apply(rule prems(3))
    apply(subst (asm) append_eq_Cons_conv)
    apply(clarsimp)
    apply(erule disjE)
    apply(auto)
  thus ?case

  case (send t r s l msg tid m e m')
  show ?case using prems(4,6-7)
    by(auto dest: Knows_inp_unpairMsg
           elim!: prems(3))
next

lemma Knows_inp:
  "\<lbrakk> \<Delta>(e) \<in> set t; m \<in> inp s e \<rbrakk> \<Longrightarrow> \<star>(m) \<in> set t"
  apply(insert reachable, rotate_tac -1)
proof(induct arbitrary: e m rule: reachable.induct)
  case (send t r s l msg tid m e m')
  show ?case using prems(4,6-7)
    by(auto dest: Knows_inp_unpairMsg
           elim!: prems(3))
next
  case (hash t r s m e m')
  show ?case using prems(4-8)
    apply(simp)
    apply(erule disjE)
    apply(simp)
    apply(auto dest: prems(3))
thm prems(3)

lemma Knows_before_inp:
  "\<lbrakk> \<Delta>(e) \<in> set t; m \<in> inp s e \<rbrakk> \<Longrightarrow> \<star>(m) \<prec> \<Delta>(e)"
  apply(simp add: pred_def)
  apply(insert reachable, rotate_tac -1)
  apply(induct arbitrary: e m rule: reachable.induct)
  apply(simp)
  apply(case_tac "\<Delta>(e) \<in> set t",simp,simp)
  apply(case_tac "\<Delta>(e) \<in> set t",simp,force split: if_splits)
  apply(case_tac "\<Delta>(e) \<in> set t",simp,force)+
  done

end

subsection{* Learning from a message *}

fun fromMsg_raw :: "wt_subst \<Rightarrow> kntrace \<Rightarrow> specmsg \<Rightarrow> tid \<Rightarrow> execmsg \<Rightarrow> bool"
where
  "fromMsg_raw s t (Enc msg key) tid m =
   (
     (subst s (s2e (Enc msg key) tid) = m) \<or>
     ( (nextRel t (\<Delta>(MkDecr (subst s (s2e msg tid))
                            (subst s (s2e key tid))))
                  (\<star>(subst s (s2e msg tid)))
       ) \<and>
       fromMsg_raw s t msg tid m
     )
   )"
| "fromMsg_raw s t (Tup x y) tid m =
   (
     (subst s (s2e (Tup x y) tid) = m) \<or>
     ( (nextRel t (\<Delta>(MkFst (subst s (s2e x tid))
                           (subst s (s2e y tid))))
                  (\<star>(subst s (s2e x tid)))
       ) \<and>
       fromMsg_raw s t x tid m
     ) \<or>
     ( (nextRel t (\<Delta>(MkSnd (subst s (s2e x tid))
                           (subst s (s2e y tid))))
                  (\<star>(subst s (s2e y tid)))
       ) \<and>
       fromMsg_raw s t y tid m
     )
   )"
| "fromMsg_raw s t msg tid m =
     (subst s (s2e msg tid) = m)"

lemma nextRel_appendI1:
  "nextRel xs x y \<Longrightarrow> nextRel (xs@ys) x y"
  by(induct xs, simp, case_tac xs, auto)

lemma fromMsg_raw_appendI1:
  "fromMsg_raw s t msg tid m \<Longrightarrow>
   fromMsg_raw s (t@t') msg tid m"
  apply(induct arbitrary: s t rule: fromMsg_raw.induct)
  by(auto intro!: nextRel_appendI1)

lemma fromMsg_rawI1:
  "\<lbrakk> subst s (s2e msg tid) = m; ground m \<rbrakk>
   \<Longrightarrow> fromMsg_raw s t msg tid m"
  by(induct arbitrary: s rule: fromMsg_raw.induct, auto)

lemma fromMsg_raw_Snoc_MkDecrI:
  "\<lbrakk> ground m; fromMsg_raw s t msg tid (Enc m k) \<rbrakk> \<Longrightarrow>
   fromMsg_raw s (t @ [\<Delta> MkDecr m k, \<star> m]) msg tid m"
  apply(induct arbitrary: m k s t rule: fromMsg_raw.induct)
  apply(auto intro: nextRelI fromMsg_rawI1 nextRel_appendI1)
  apply(case_tac v, auto)
  done

lemma fromMsg_raw_Snoc_MkFstI:
  "\<lbrakk> ground x; fromMsg_raw s t msg tid (Tup x y) \<rbrakk> \<Longrightarrow>
   fromMsg_raw s (t @ [\<Delta> MkFst x y, \<star> x]) msg tid x"
  apply(induct arbitrary: x y s t rule: fromMsg_raw.induct)
  apply(auto intro: nextRelI fromMsg_rawI1 nextRel_appendI1)
  apply(case_tac v, auto)
  done

lemma fromMsg_raw_Snoc_MkSndI:
  "\<lbrakk> ground y; fromMsg_raw s t msg tid (Tup x y) \<rbrakk> \<Longrightarrow>
   fromMsg_raw s (t @ [\<Delta> MkSnd x y, \<star> y]) msg tid y"
  apply(induct arbitrary: x y s t rule: fromMsg_raw.induct)
  apply(auto intro: nextRelI fromMsg_rawI1 nextRel_appendI1)
  apply(case_tac v, auto)
  done

definition eruns :: "rolestep threadpool \<Rightarrow> tid \<Rightarrow> role \<Rightarrow> bool"
where "eruns r tid R \<equiv> (case r tid of
                         Some (todo,done) \<Rightarrow> Rep_role R = rev done @ todo
                       | None             \<Rightarrow> False)"

lemma eruns_nextStep [simp]:
  "eruns (nextStep r tid) tid' R = eruns r tid' R"
  by(simp add: nextStep_def eruns_def split: option.splits list.splits)

context reachable_state begin

lemma fromMsg_raw_extend_wtsI:
  "\<lbrakk> fromMsg_raw s t msg tid m; ground (subst s (s2e msg tid)) \<rbrakk>
   \<Longrightarrow> fromMsg_raw (extend_wts s s') t msg tid m"
  apply(induct arbitrary: s rule: fromMsg_raw.induct)
  apply(simp_all add: extend_wts_conv_subst)
  apply(auto simp: extend_wts_def)
  done

lemma nextRel_rev:
  "nextRel (rev xs) x y = nextRel xs y x"
  apply(simp add: nextRel_conv)
  apply(auto)
  apply(drule_tac f=rev in arg_cong, simp)
  apply(rule_tac x="rev zs" in exI, simp)+
  done

lemma nextRel_Snoc_simps:
  "nextRel (xs@[a])   x y = nextRel (a#rev xs)   y x"
  "nextRel (xs@[a,b]) x y = nextRel (b#a#rev xs) y x"
  by(subst nextRel_rev[symmetric], simp)+

lemma nextRel_Cons_simps:
  "x \<noteq> y \<Longrightarrow> nextRel (x#xs) y z = nextRel xs y z"
  "x' \<noteq> z \<Longrightarrow> nextRel (x#x'#xs) y z = nextRel (x'#xs) y z"
  by(case_tac xs, simp+)

lemmas nextRel_simps [simp] = nextRel_rev nextRel_Snoc_simps nextRel_Cons_simps

lemma nextRel_FromIK0D: "nextRel t (\<Delta> FromIK0 m) (\<star> m') \<Longrightarrow> m' \<in> IK0"
  apply(insert reachable, rotate_tac -1)
  by(induct rule: reachable.induct, auto split: if_splits)

lemma nextRelI [simp,intro!]: "nextRel (xs@x#y#ys) x y"
  by(auto simp: nextRel_conv)

lemma notin_IK0 [iff]:
  "Enc m k \<notin> IK0"
  "Hash m \<notin> IK0"
  "Lit (ENonce n tid) \<notin> IK0"
  "Tup x y \<notin> IK0"
  by(auto simp: IK0_def)
(* TODO: Move and add K Eve Eve *)

lemma knows_cases_raw:
  "\<star>(m') \<in> set t \<Longrightarrow>
   (\<Delta>(FromIK0 m') \<prec>\<^sub>1 \<star>(m')) \<or>
   (\<exists> m.   m' = Hash m   \<and> \<Delta>(MkHash m)   \<prec>\<^sub>1 \<star>(Hash m)) \<or>
   (\<exists> m k. m' = Enc  m k \<and> \<Delta>(MkEncr m k) \<prec>\<^sub>1 \<star>(Enc m k)) \<or>
   (\<exists> x y. m' = Tup  x y \<and> \<Delta>(MkTup x y)  \<prec>\<^sub>1 \<star>(Tup x y)) \<or>
   (\<exists> R \<in> P. \<exists> tid. eruns r tid R \<and>
      (\<exists> l msg.
         Send l msg \<in> roleEvs R \<and>
         \<Delta>(MkStep tid (Send l msg)) \<prec>\<^sub>1 \<star>(subst s (s2e msg tid)) \<and>
         fromMsg_raw s t msg tid m'
      )
   )"
  apply(simp add: next_def)
  apply(insert reachable, rotate_tac -1)
proof (induct arbitrary: m' rule: reachable.induct)
  case init thus ?case by simp
next
  case (hash t r s m) show ?case using prems(4-7)
    apply(simp)
    apply(erule disjE, simp)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(auto intro!: fromMsg_raw_appendI1)
    done
next
  case (tuple t r s x y) thus ?case
    apply(simp)
    apply(erule disjE, simp)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(auto intro!: fromMsg_raw_appendI1)
    done
(*
    apply(case_tac "\<star>(m') \<in> set t", simp)
    apply(rule knows_cases_appendI1)
    apply(erule prems)
    apply(simp)
    done
*)
next
  case (encr t r s m k) thus ?case
    apply(simp)
    apply(erule disjE, simp)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(auto intro!: fromMsg_raw_appendI1)
    done
next
  case (ik0 t r s m) thus ?case
    apply(simp)
    apply(erule disjE, simp)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(auto intro!: fromMsg_raw_appendI1)
    done
next
  case (send t r s l msg tid m m')
    then interpret old_state: reachable_state P t r s by unfold_locales
    show ?case using prems(4-6)
    apply(simp split: if_splits)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(force intro!: fromMsg_raw_appendI1)

    apply(erule disjE)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(force intro!: fromMsg_raw_appendI1)

    apply(rule disjI2)+
    apply(simp)
    apply(drule Some_curStepD)
    apply(clarsimp)
    apply(frule old_state.proto_roles)
    apply(clarsimp)
    apply(rule_tac x=R in bexI)
    apply(rule_tac x=tid in exI)
    apply(rule conjI)
    apply(simp add: eruns_def)
    apply(rule_tac x=l in exI)
    apply(rule_tac x=msg in exI)
    apply(rule conjI)
    apply(simp add: roleEvs_def)
    apply(simp)
    apply(rule fromMsg_rawI1)
    apply(simp)
    apply(rule old_state.Send_ground)
    apply(simp add: curStep_def)
    apply(simp)
    done
next
  case (decr t r s m k m')
    then interpret old_state: reachable_state P t r s by unfold_locales
    show ?case using prems(4-8)
    apply(subgoal_tac "ground m'")
    apply(case_tac "\<star>(m') \<in> set t", simp)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(force intro!: fromMsg_raw_appendI1)

    apply(drule prems(3), simp)

    apply(erule disjE)
    apply(drule old_state.nextRel_FromIK0D, simp)

    apply(erule disjE)
    apply(drule in_set_nextRel1)
    apply(drule old_state.Knows_inp)
    apply(force,simp)

    apply(rule disjI2)+
    apply(clarsimp)
    apply(rule_tac x=R in bexI)
    apply(rule_tac x=tid in exI)
    apply(simp)
    apply(rule exI)+
    apply(rule conjI, simp+)
    apply(rule fromMsg_raw_Snoc_MkDecrI)
    apply(simp)+
    apply(force dest!: old_state.Knows_ground
                 simp: old_state.Knows_ground)
    done
next
  case (fst t r s x y m')
    then interpret old_state: reachable_state P t r s by unfold_locales
    show ?case using prems(4-7)
    apply(subgoal_tac "ground m'")
    apply(case_tac "\<star>(m') \<in> set t", simp)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(force intro!: fromMsg_raw_appendI1)

    apply(drule prems(3), simp)

    apply(erule disjE)
    apply(drule old_state.nextRel_FromIK0D, simp)

    apply(erule disjE)
    apply(drule in_set_nextRel1)
    apply(drule old_state.Knows_inp)
    apply(force,simp)

    apply(rule disjI2)+
    apply(clarsimp)
    apply(rule_tac x=R in bexI)
    apply(rule_tac x=tid in exI)
    apply(simp)
    apply(rule exI)+
    apply(rule conjI, simp+)
    apply(rule fromMsg_raw_Snoc_MkFstI)
    apply(simp)+
    apply(force dest!: old_state.Knows_ground
                 simp: old_state.Knows_ground)
    done
next
  case (snd t r s x y m')
    then interpret old_state: reachable_state P t r s by unfold_locales
    show ?case using prems(4-7)
    apply(subgoal_tac "ground m'")
    apply(case_tac "\<star>(m') \<in> set t", simp)
    apply(drule_tac m'=m' in prems(3))
    apply(erule disjE, clarsimp)+
    apply(rule disjI2)+
    apply(force intro!: fromMsg_raw_appendI1)

    apply(drule prems(3), simp)

    apply(erule disjE)
    apply(drule old_state.nextRel_FromIK0D, simp)

    apply(erule disjE)
    apply(drule in_set_nextRel1)
    apply(drule old_state.Knows_inp)
    apply(force,simp)

    apply(rule disjI2)+
    apply(clarsimp)
    apply(rule_tac x=R in bexI)
    apply(rule_tac x=tid in exI)
    apply(simp)
    apply(rule exI)+
    apply(rule conjI, simp+)
    apply(rule fromMsg_raw_Snoc_MkSndI)
    apply(simp)+
    apply(force dest!: old_state.Knows_ground
                 simp: old_state.Knows_ground)
    done
next
  case (create t r s tid R \<alpha> m')
    then interpret old_state: reachable_state P t r s by unfold_locales
    show ?case using prems(4,5,8)
      apply(simp)
      apply(drule prems)
      apply(erule disjE, clarsimp)+
      apply(rule disjI2)+
      apply(erule bexE, erule exE, erule conjE)
      apply(erule exE, erule exE, (erule conjE)+)
      apply(rule_tac x=Ra in bexI)
      apply(rule_tac x=tida in exI)
      apply(rule conjI)
      apply(clarsimp simp: eruns_def newThread_def split: option.splits)
      apply(rule_tac x=l in exI, rule_tac x=msg in exI)
      apply(frule in_set_nextRel2)
      apply(drule old_state.Knows_ground)
      apply(auto simp: extend_wts_conv_subst old_state.fromMsg_raw_extend_wtsI)
      done
next
  case (recv t r s l msg tid \<alpha> m')
    then interpret old_state: reachable_state P t r s by unfold_locales
    show ?case using prems(4,6,7)
      apply(subgoal_tac "ground m'")
      apply(simp)
      apply(drule_tac m'=m' in prems(3))
      apply(erule disjE, clarsimp)+
      apply(rule disjI2)+
      apply(erule bexE, erule exE, erule conjE)
      apply(erule exE, erule exE, (erule conjE)+)
      apply(rule_tac x=R in bexI)
      apply(rule_tac x=tida in exI)
      apply(rule conjI)
      apply(clarsimp simp: eruns_def newThread_def split: option.splits)
      apply(rule_tac x=la in exI, rule_tac x=msga in exI)
      apply(frule in_set_nextRel2)
      apply(auto simp: extend_wts_conv_subst old_state.fromMsg_raw_extend_wtsI
               intro!: fromMsg_raw_appendI1
                dest!: old_state.Knows_ground
                 simp: old_state.Knows_ground)
      done
qed

end

fun fromMsg :: "wt_subst \<Rightarrow> kntrace \<Rightarrow> specmsg \<Rightarrow> tid \<Rightarrow> execmsg \<Rightarrow> bool"
where
  "fromMsg s t (Enc msg key) tid m =
   (
     (subst s (s2e (Enc msg key) tid) = m) \<or>
     (listOrd t (\<star> Enc (subst s (s2e msg tid)) (subst s (s2e key tid)))
                (\<star> subst s (s2e msg tid))
      \<and>
      listOrd t (\<star> subst s (s2e (inv key) tid))
                (\<star> subst s (s2e msg tid))
      \<and>
      fromMsg s t msg tid m
     )
   )"
| "fromMsg s t (Tup x y) tid m =
   (
     (subst s (s2e (Tup x y) tid) = m) \<or>
     (listOrd t (\<star> Tup (subst s (s2e x tid)) (subst s (s2e y tid)))
                (\<star> subst s (s2e x tid))
      \<and>
      fromMsg s t x tid m
     ) \<or>
     (listOrd t (\<star> Tup (subst s (s2e x tid)) (subst s (s2e y tid)))
                (\<star> subst s (s2e y tid))
      \<and>
      fromMsg s t y tid m
     )
   )"
| "fromMsg s t msg tid m = (subst s (s2e msg tid) = m)"

context reachable_state begin

lemma fromMsg_raw_imp_fromMsg:
  "fromMsg_raw s t msg tid m \<Longrightarrow> fromMsg s t msg tid m"
  apply(induct msg)
  apply(simp_all add: next_def[symmetric] pred_def[symmetric])
  apply(erule disjE, simp)
  apply(erule disjE, simp)
  apply(erule conjE)
  apply(drule next_imp_less)
  apply(frule Knows_before_inp[OF in_set_less1])
  apply(simp, force)
  apply(erule conjE)
  apply(drule next_imp_less)
  apply(frule Knows_before_inp[OF in_set_less1])
  apply(simp)
  apply(force intro: less_trans)
  apply(erule disjE, simp)
  apply(erule conjE)
  apply(drule next_imp_less)
  apply(rule disjI2, rule conjI)
  apply(frule Knows_before_inp[OF in_set_less1]) prefer 3
  apply(frule Knows_before_inp[OF in_set_less1])
  apply(simp, rule disjI2)
  apply(auto intro: less_trans)
  done

lemma knows_cases:
  "\<star>(m') \<in> set t \<Longrightarrow>
   (m' \<in> IK0) \<or>
   (\<exists> m. m' = Hash m \<and>  \<star> m \<prec> \<star> Hash m ) \<or>
   (\<exists> m k. m' = Enc  m k \<and> \<star> m \<prec> \<star> Enc m k \<and> \<star> k \<prec> \<star> Enc m k) \<or>
   (\<exists> x y. m' = Tup  x y \<and> \<star> x \<prec> \<star> Tup x y \<and> \<star> y \<prec> \<star> Tup x y) \<or>
   (\<exists> R \<in> P. \<exists> tid. eruns r tid R \<and>
      (\<exists> l msg.
         Send l msg \<in> roleEvs R \<and>
         \<Delta>(MkStep tid (Send l msg)) \<prec> \<star>(subst s (s2e msg tid)) \<and>
         fromMsg s t msg tid m'
      )
   )"
  apply(drule knows_cases_raw)
  apply(erule disjE)
  apply(rule disjI1, rule nextRel_FromIK0D)
  apply(simp add: next_def)
  apply(erule disjE)
  apply(rule disjI2, rule disjI1)
  apply(clarify)
  apply(drule next_imp_less)
  apply(frule in_set_less1)
  apply(force dest: Knows_before_inp)
  apply(erule disjE)
  apply(rule disjI2, rule disjI2, rule disjI1)
  apply(clarify)
  apply(drule next_imp_less)
  apply(frule in_set_less1)
  apply(force dest: Knows_before_inp)
  apply(erule disjE)
  apply(rule disjI2, rule disjI2, rule disjI2, rule disjI1)
  apply(clarify)
  apply(drule next_imp_less)
  apply(frule in_set_less1)
  apply(force dest: Knows_before_inp)
  apply(rule disjI2)+
  apply(auto dest!: next_imp_less intro!: fromMsg_raw_imp_fromMsg)
  done

lemmas Knows_less_cases = knows_cases[OF in_set_less1, rule_format]

lemma Recv_before_Send:
  "\<lbrakk> \<Delta> MkStep tid (Send l msg) \<prec> \<star> m; eruns r tid R;
     (Recv l' msg', Send l msg) \<in> roleOrd R \<rbrakk> \<Longrightarrow>
   \<star> subst s (s2e msg' tid) \<prec> \<star> m"
  apply(clarsimp simp: eruns_def roleOrd_def split: option.splits)
  apply(erule disjE)
  apply(drule roleOrd)
  apply(simp)
  apply(frule_tac x="\<Delta> MkStep tid (Recv l' msg')" in in_set_less1)
  apply(force dest: Knows_before_inp)
  apply(auto dest!: in_set_less1 in_set_listOrd2 todo_notin_trace)
  done

(*

(* OLD Developments *)

lemma listOrd_in_listOrdD: "x \<sqsubset>\<^bsub>t\<^esub> y \<Longrightarrow> (x,y) \<in>listOrd t"
  by(induct t arbitrary: x y, simp, case_tac t, auto)

lemma listOrd_distinct_conv_predOrd:
  "distinct t \<Longrightarrow> listOrd t = {(x, y) |x y. x \<sqsubset>\<^bsub>t\<^esub> y}\<^sup>+"
  apply(rule set_ext, auto)
  apply(induct t rule: listOrd.induct)
  apply(simp)
  apply(simp)
  apply(erule disjE)
  apply(clarify)
  apply(case_tac "xs")
  apply(simp)
  apply(simp)
  apply(erule disjE)
  apply(rule trancl.intros)
  apply(simp)
  apply(rule trancl_trans)
  apply(rule trancl.intros)
  apply(force)
  apply(rule_tac r="{(x, y). x \<sqsubset>\<^bsub>(aa # list)\<^esub> y}" in trancl_mono)
  apply(simp)
  apply(force)
  apply(rule_tac r="{(x, y). x \<sqsubset>\<^bsub>xs\<^esub> y}" in trancl_mono)
  apply(force)
  apply(case_tac xs)
  apply(simp)
  apply(force)

  apply(erule trancl.induct)
  apply(auto dest!: predOrd_in_listOrdD intro: listOrd_distinct_trans)
  done

fun predOrd :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
where
  "predOrd []       a b = False"
| "predOrd [x]      a b = False"
| "predOrd (x#y#xs) a b = ((a = x \<and> b = y) \<or> (predOrd (y#xs) a b))"

locale partial_ord =
  fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubseteq>" 50)
  assumes refl [intro, simp]: "x \<sqsubseteq> x"
  and       anti_sym [intro]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> x \<rbrakk> \<Longrightarrow> x = y"
  and          trans [trans]: "\<lbrakk> x \<sqsubseteq> y; y \<sqsubseteq> z \<rbrakk> \<Longrightarrow> x \<sqsubseteq> z"

definition (in partial_ord)
  less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<sqsubset>" 50)
  where "(x \<sqsubset> y) = (x \<sqsubseteq> y \<and> x \<noteq> y)"

locale distinct_list =
  fixes   xs :: "knevent list"
  assumes distinct: "distinct xs"

sublocale distinct_list \<subseteq> partial_ord "predOrd xs"
  apply(unfold_locales)
  apply(induct xs arbitrary: x, simp)

locale REACHABLE =
  fixes P :: proto
  and   t :: kntrace
  and   r :: "rolestep threadpool"
  and   s :: wt_subst
  assumes reachable [simp,intro!]: "(t,r,s) \<in> reachable P"

sublocale REACHABLE \<subseteq> distinct_list t
  apply(unfold_locales)
  apply(rule reachable_distinct_trace[OF reachable])
  done

context REACHABLE begin

lemmas distinct_trace [simp,intro!] = reachable_distinct_trace[OF reachable]

lemma knI: "\<star>(subst s m) \<in> set t \<Longrightarrow> kn (kntrace2trace t,r,s) m"
  by(auto simp: kn_def intro!: reachable_Knows_spies_kntrace2trace)

end

print_locale! REACHABLE

thm reachable

lemma kn_reachableI:
  "\<lbrakk> (t,r,s) \<in> reachable P; \<star>(subst s m) \<in> set t \<rbrakk>
  \<Longrightarrow> kn (kntrace2trace t,r,s) m"
  by(simp add: kn_def reachable_Knows_spies_kntrace2trace)

lemma st_conv_kntrace:
  "st (kntrace2trace t,r,s) (tid,step) =
   (\<Delta>(MkStep tid step) \<in> set t)"
  by(simp add: st_def)

(* MOVE *)

syntax "@listOrd" :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
       ("_ \<prec>\<^bsub>_\<^esub>/ _" [900, 900, 900] 900)

thm listOrd_def

translations
  "x \<prec>\<^bsub>t\<^esub> y" == "(x,y) \<in> ListOrd.listOrd t"

lemma stepOrd_conv_kntrace:
  "((tid,step) \<prec>\<^bsub>kntrace2trace t\<^esub> (tid',step')) =
   (\<Delta>(MkStep tid step) \<prec>\<^bsub>t\<^esub>  \<Delta>(MkStep tid' step'))"
  by(induct t rule: kntrace2trace.induct, auto)

*)

end

end