(*******************************************************************************

  Project: Development of Security Protocols by Refinement

  Module:  Refinement/a0n_agree.thy (Isabelle/HOL 2016-1)
  ID:      $Id: a0n_agree.thy 134924 2017-05-24 17:23:15Z csprenge $
  Author:  Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  One-Way authentication protocols
  Initial Model: Non-injective agreement

  Copyright (c) 2009-2016 Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Non-injective Agreement\<close>

theory a0n_agree imports Refinement Agents
begin

text \<open>The initial model abstractly specifies entity authentication, where
one agent/role authenticates another. More precisely, this property corresponds
to non-injective agreement on a data set \<open>ds\<close>. We use Running and Commit
signals to obtain a protocol-independent extensional specification.\<close>

text \<open>Proof tool configuration. Avoid annoying automatic unfolding of
\<open>dom\<close>.\<close>

declare domIff [simp, iff del]

(******************************************************************************)
subsection \<open>State\<close>
(******************************************************************************)

text \<open>Signals. At this stage there are no protocol runs yet. All we model
are the signals that indicate a certain progress of a protocol run by one
agent/role (Commit signal) and the other role (Running signal). The signals
contain a list of agents that are assumed to be honest and a polymorphic data
set to be agreed upon, which is instantiated later.

Usually, the agent list will contain the names of the two agents who want to
agree on the data, but sometimes one of the agents is honest by assumption
(e.g., the server) or the honesty of additional agents needs to be assumed
for the agreement to hold.\<close>

datatype 'ds signal =
  Running "agent list" "'ds"
| Commit "agent list" "'ds"

record 'ds a0n_state =
  signals :: "'ds signal \<Rightarrow> nat"    \<comment> \<open>multi-set of signals\<close>
  corrupted :: "'ds set"            \<comment> \<open>set of corrupted data\<close>

type_synonym
  'ds a0n_obs = "'ds a0n_state"

(******************************************************************************)
subsection \<open>Events\<close>
(******************************************************************************)

definition
  a0n_init :: "'ds a0n_state set"
where
  "a0n_init \<equiv> {s. \<exists>ds. s = \<lparr>
     signals = \<lambda>s. 0,
     corrupted = ds
  \<rparr> }"

text \<open>Running signal, indicating end of responder run.\<close>

definition
  a0n_running :: "[agent list, 'ds] \<Rightarrow> ('ds a0n_state \<times> 'ds a0n_state) set"
where
  "a0n_running h d \<equiv> {(s, s').
    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      signals := (signals s)(Running h d := signals s (Running h d) + 1)
    \<rparr>
  }"

text \<open>Commit signal, marking end of initiator run.\<close>

definition
  a0n_commit :: "[agent list, 'ds] \<Rightarrow> ('ds a0n_state \<times> 'ds a0n_state) set"
where
  "a0n_commit h d \<equiv> {(s, s').
    \<comment> \<open>guards:\<close>
    (set h \<subseteq> good \<longrightarrow> d \<notin> corrupted s \<longrightarrow> signals s (Running h d) > 0) \<and>

    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      signals := (signals s)(Commit h d := signals s (Commit h d) + 1)
    \<rparr>
  }"

text \<open>Data corruption.\<close>

definition
  a0n_corrupt :: "'ds set \<Rightarrow> ('ds a0n_state \<times> 'ds a0n_state) set"
where
  "a0n_corrupt ds \<equiv> {(s, s').
    \<comment> \<open>actions:\<close>
    s' = s\<lparr>
      corrupted := corrupted s \<union> ds
    \<rparr>
  }"

text \<open>Transition system.\<close>

definition
  a0n_trans :: "('ds a0n_state \<times> 'ds a0n_state) set" where
  "a0n_trans \<equiv> (\<Union>h d ds.
     a0n_running h d \<union>
     a0n_commit h d \<union>
     a0n_corrupt ds \<union>
     Id
  )"

definition
  a0n :: "('ds a0n_state, 'ds a0n_obs) spec" where
  "a0n \<equiv> \<lparr>
    init = a0n_init,
    trans = a0n_trans,
    obs = id
  \<rparr>"

lemmas a0n_defs =
  a0n_def a0n_init_def a0n_trans_def
  a0n_running_def a0n_commit_def a0n_corrupt_def

text \<open>Any property is trivially observable.\<close>

lemma a0n_obs [simp]: "obs a0n= id"
by (simp add: a0n_def)

lemma a0n_anyP_observable [iff]: "observable (obs a0n) P"
by (auto)

(******************************************************************************)
subsection \<open>Invariants\<close>
(******************************************************************************)

subsection \<open>inv1: non-injective agreement\<close>
(******************************************************************************)

text \<open>This is an extensional variant of Lowe's \emph{non-injective agreement}
of the first with the second agent (by convention) in \<open>h\<close> on data
\<open>d\<close> [Lowe97].
\<close>

definition
  a0n_inv1_niagree :: "'ds a0n_state set"
where
  "a0n_inv1_niagree \<equiv> {s. \<forall>h d.
     set h \<subseteq> good \<longrightarrow> d \<notin> corrupted s \<longrightarrow>
       signals s (Commit h d) > 0 \<longrightarrow> signals s (Running h d) > 0
  }"

lemmas a0n_inv1_niagreeI =
  a0n_inv1_niagree_def [THEN setc_def_to_intro, rule_format]
lemmas a0n_inv1_niagreeE [elim] =
  a0n_inv1_niagree_def [THEN setc_def_to_elim, rule_format]
lemmas a0n_inv1_niagreeD =
  a0n_inv1_niagree_def [THEN setc_def_to_dest, rule_format, rotated 2]

text \<open>Invariance proof.\<close>

lemma PO_a0n_inv1_niagree_init [iff]:
  "init a0n \<subseteq> a0n_inv1_niagree"
by (auto simp add: a0n_defs intro!: a0n_inv1_niagreeI)

lemma PO_a0n_inv1_niagree_trans [iff]:
  "{a0n_inv1_niagree} trans a0n {> a0n_inv1_niagree}"
apply (auto simp add: PO_hoare_defs a0n_defs intro!: a0n_inv1_niagreeI)
apply (auto dest!: a0n_inv1_niagreeD dest: dom_lemmas)
done

lemma PO_a0n_inv1_niagree [iff]: "reach a0n \<subseteq> a0n_inv1_niagree"
by (rule inv_rule_basic) (auto)

text \<open>This is also an external invariant.\<close>

lemma a0n_obs_inv1_niagree [iff]:
  "oreach a0n \<subseteq> a0n_inv1_niagree"
apply (rule external_from_internal_invariant, fast)
apply (subst a0n_def, auto)
done

end


subsection \<open>CISK (Controlled Interruptible Separation Kernel)\<close>

theory CISK
  imports ISK
begin

text \<open>
  This section presents a generic model of a Controlled Interruptible Separation Kernel (CISK).
  It formulates security, i.e., intransitive noninterference.
  For a presentation of this model, see Section 2 of~\cite{Verbeek2013}.
\<close>

text \<open>
  First, a locale is defined that defines all generic functions and all proof obligations (see Section 2.3 of ~\cite{Verbeek2013}).
\<close>
locale Controllable_Interruptible_Separation_Kernel = \<comment> \<open>CISK\<close>
fixes kstep :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'state_t" \<comment> \<open>Executes one atomic kernel action\<close>
  and output_f :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'output_t" \<comment> \<open>Returns the observable behavior\<close>
  and s0 :: "'state_t" \<comment> \<open>The initial state\<close>
  and current :: "'state_t => 'dom_t" \<comment> \<open>Returns the currently active domain\<close>
  and cswitch :: "time_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t" \<comment> \<open>Performs a context switch\<close>
  and interrupt :: "time_t \<Rightarrow> bool" \<comment> \<open>Returns t iff an interrupt occurs in the given state at the given time\<close>
  and kinvolved :: "'action_t \<Rightarrow> 'dom_t set" \<comment> \<open>Returns the set of domains that are involved in the given action\<close>
  and ifp :: "'dom_t \<Rightarrow> 'dom_t \<Rightarrow> bool" \<comment> \<open>The security policy.\<close>
  and vpeq :: "'dom_t \<Rightarrow> 'state_t \<Rightarrow> 'state_t \<Rightarrow> bool" \<comment> \<open>View partitioning equivalence\<close>
  and AS_set :: "('action_t list) set" \<comment> \<open>Returns a set of valid action sequences, i.e., the attack surface\<close>
  and invariant :: "'state_t \<Rightarrow> bool" \<comment> \<open>Returns an inductive state-invariant\<close>
  and AS_precondition :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" \<comment> \<open>Returns the preconditions under which the given action can be executed.\<close>
  and aborting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" \<comment> \<open>Returns true iff the action is aborted.\<close>
  and waiting :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t \<Rightarrow> bool" \<comment> \<open>Returns true iff execution of the given action is delayed.\<close>
  and set_error_code :: "'state_t \<Rightarrow> 'action_t \<Rightarrow> 'state_t" \<comment> \<open>Sets an error code when actions are aborted.\<close>
assumes vpeq_transitive: " \<forall> a b c u. (vpeq u a b \<and> vpeq u b c) \<longrightarrow> vpeq u a c"
    and vpeq_symmetric: "\<forall> a b u. vpeq u a b \<longrightarrow> vpeq u b a"
    and vpeq_reflexive: "\<forall> a u. vpeq u a a"
    and ifp_reflexive: "\<forall> u . ifp u u"
    and weakly_step_consistent: "\<forall> s t u a. vpeq u s t \<and> vpeq (current s) s t \<and> invariant s \<and> AS_precondition s (current s) a \<and> invariant t \<and> AS_precondition t (current t) a \<and> current s = current t  \<longrightarrow> vpeq u (kstep s a) (kstep t a)"
    and locally_respects: "\<forall> a s u. \<not>ifp (current s) u  \<and> invariant s \<and> AS_precondition s (current s) a \<longrightarrow> vpeq u s (kstep s a)"
    and output_consistent: "\<forall> a s t. vpeq (current s) s t \<and> current s = current t \<longrightarrow> (output_f s a) = (output_f t a)"
    and step_atomicity: "\<forall> s a . current (kstep s a) = current s"
    and cswitch_independent_of_state: "\<forall> n s t . current s = current t \<longrightarrow> current (cswitch n s) = current (cswitch n t)"
    and cswitch_consistency: "\<forall> u s t n . vpeq u s t \<longrightarrow> vpeq u (cswitch n s) (cswitch n t)"
    and empty_in_AS_set: "[] \<in> AS_set"
    and invariant_s0: "invariant s0"
    and invariant_after_cswitch: "\<forall> s n . invariant s \<longrightarrow> invariant (cswitch n s)"
    and precondition_after_cswitch: "\<forall> s d n a. AS_precondition s d a \<longrightarrow> AS_precondition (cswitch n s) d a"
    and AS_prec_first_action: "\<forall> s d aseq . invariant s \<and> aseq \<in> AS_set \<and> aseq \<noteq> [] \<longrightarrow> AS_precondition s d (hd aseq)"
    and AS_prec_after_step: "\<forall> s a a' . (\<exists> aseq \<in> AS_set . is_sub_seq a a' aseq) \<and> invariant s \<and> AS_precondition s (current s) a \<and> \<not>aborting s (current s) a \<and> \<not> waiting s (current s) a\<longrightarrow> AS_precondition (kstep s a) (current s) a'"
    and AS_prec_dom_independent: "\<forall> s d a a' . current s \<noteq> d \<and> AS_precondition s d a \<longrightarrow> AS_precondition (kstep s a') d a"
    and spec_of_invariant: "\<forall> s a . invariant s \<longrightarrow> invariant (kstep s a)"
    and aborting_switch_independent: "\<forall> n s . aborting (cswitch n s) = aborting s"
    and aborting_error_update: "\<forall> s d a' a . current s \<noteq> d \<and> aborting s d a \<longrightarrow> aborting (set_error_code s a') d a"
    and aborting_after_step: "\<forall> s a d . current s \<noteq> d \<longrightarrow> aborting (kstep s a) d = aborting s d" (* TODO: I think this PO can be removed *)
    and aborting_consistent: "\<forall> s t u . vpeq u s t \<longrightarrow> aborting s u = aborting t u"
    and waiting_switch_independent: "\<forall> n s . waiting (cswitch n s) = waiting s"
    and waiting_error_update: "\<forall> s d a' a . current s \<noteq> d \<and> waiting s d a \<longrightarrow> waiting (set_error_code s a') d a"
    and waiting_consistent: "\<forall>s t u a . vpeq (current s) s t \<and> (\<forall> d \<in> kinvolved a . vpeq d s t) \<and> vpeq u s t \<longrightarrow> waiting s u a = waiting t u a"
    and spec_of_waiting: "\<forall> s a . waiting s (current s) a \<longrightarrow> kstep s a = s"
    and set_error_consistent: "\<forall> s t u a . vpeq u s t \<longrightarrow> vpeq u (set_error_code s a) (set_error_code t a)"
    and set_error_locally_respects: "\<forall> s u a . \<not>ifp (current s) u \<longrightarrow> vpeq u s (set_error_code s a)"
    and current_set_error_code: "\<forall> s a . current (set_error_code s a) = current s"
    and precondition_after_set_error_code: "\<forall> s d a a'. AS_precondition s d a \<and> aborting s (current s) a' \<longrightarrow> AS_precondition (set_error_code s a') d a"
    and invariant_after_set_error_code: "\<forall> s a . invariant s \<longrightarrow> invariant (set_error_code s a)"
    and involved_ifp: "\<forall> s a . \<forall> d \<in> (kinvolved a) . AS_precondition s (current s) a \<longrightarrow> ifp d (current s)"
begin

subsubsection\<open>Execution semantics\<close>

text\<open>
  Control is based on generic functions \emph{aborting}, \emph{waiting} and \emph{set\_error\_code}.
  Function \emph{aborting} decides whether a certain action is aborting, given its domain and the state.
  If so, then function set\_error\_code will be used to update the state, possibly communicating to other domains that an action has been aborted.
  Function \emph{waiting} can delay the execution of an action.
  This behavior is implemented in function CISK\_control.
\<close>
function CISK_control :: "'state_t \<Rightarrow> 'dom_t \<Rightarrow> 'action_t execution \<Rightarrow> ('action_t option \<times> 'action_t execution \<times> 'state_t)"
where "CISK_control s d []                = (None,[],s)" \<comment> \<open>The thread is empty\<close>
    | "CISK_control s d ([]#[])           = (None,[],s)" \<comment> \<open>The current action sequence has been finished and the thread has no next action sequences to execute\<close>
    | "CISK_control s d ([]#(as'#execs')) = (None,as'#execs',s)" \<comment> \<open>The current action sequence has been finished. Skip to the next sequence\<close>
    | "CISK_control s d ((a#as)#execs')   = (if aborting s d a then
                                                  (None, execs',set_error_code s a)
                                               else if waiting s d a then
                                                  (Some a, (a#as)#execs',s)
                                               else
                                                  (Some a, as#execs',s))" \<comment> \<open>Executing an action sequence\<close>
by pat_completeness auto
termination by lexicographic_order

text\<open>
  Function \emph{run} defines the execution semantics.
  This function is presented in ~\cite{Verbeek2013} by pseudo code (see Algorithm 1).
  Before defining the run function, we define accessor functions for the control mechanism.
  Functions next\_action, next\_execs and next\_state correspond to ``control.a'', ``control.x'' and ``control.s'' in ~\cite{Verbeek2013}.
\<close>
abbreviation next_action::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'action_t option"
where "next_action \<equiv> Kernel.next_action current CISK_control"
abbreviation next_execs::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution)"
where "next_execs  \<equiv> Kernel.next_execs current CISK_control"
abbreviation next_state::"'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'state_t"
where "next_state  \<equiv> Kernel.next_state current CISK_control"
text \<open>
\<close>
text \<open>
  A thread is empty iff either it has no further action sequences to execute, or when the current action sequence is finished and there are no further action sequences to execute.
\<close>
abbreviation thread_empty::"'action_t execution \<Rightarrow> bool"
where "thread_empty exec \<equiv> exec = [] \<or> exec = [[]]"

text\<open>
  The following function defines the execution semantics of CISK, using function CISK\_control.
\<close>
function run :: "time_t \<Rightarrow> 'state_t \<Rightarrow> ('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> 'state_t"
where "run 0 s execs = s"
| "interrupt (Suc n) \<Longrightarrow> run (Suc n) s execs = run n (cswitch (Suc n) s) execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> thread_empty(execs (current s)) \<Longrightarrow> run (Suc n) s execs = run n s execs"
| "\<not>interrupt (Suc n) \<Longrightarrow> \<not>thread_empty(execs (current s)) \<Longrightarrow>
      run (Suc n) s execs = (let control_a = next_action s execs;
                                 control_s = next_state s execs;
                                 control_x = next_execs s execs in
                             case control_a of None \<Rightarrow> run n control_s control_x
                                         | (Some a) \<Rightarrow> run n (kstep control_s a) control_x)"
using not0_implies_Suc by (metis prod_cases3,auto)
termination by lexicographic_order

subsubsection \<open>Formulations of security\<close>

text\<open>
  The definitions of security as presented in Section 2.2 of~\cite{Verbeek2013}.
\<close>

abbreviation kprecondition
  where "kprecondition s a \<equiv> invariant s \<and> AS_precondition s (current s) a"
definition realistic_execution
where "realistic_execution aseq \<equiv> set aseq \<subseteq> AS_set"
definition realistic_executions :: "('dom_t \<Rightarrow> 'action_t execution) \<Rightarrow> bool"
where "realistic_executions execs \<equiv> \<forall>d. realistic_execution (execs d)"
abbreviation involved where "involved \<equiv> Kernel.involved kinvolved"
abbreviation step where "step \<equiv> Kernel.step kstep"
abbreviation purge where "purge \<equiv> Separation_Kernel.purge realistic_execution ifp"
abbreviation ipurge_l where "ipurge_l \<equiv> Separation_Kernel.ipurge_l kinvolved ifp"
abbreviation ipurge_r where "ipurge_r \<equiv> Separation_Kernel.ipurge_r realistic_execution kinvolved ifp"

definition NI_unrelated::bool
where "NI_unrelated
  \<equiv> \<forall> execs a n . realistic_executions execs \<longrightarrow>
                      (let s_f = run n s0 execs in
                         output_f s_f a = output_f (run n s0 (purge execs (current s_f))) a)"
definition NI_indirect_sources::bool
where "NI_indirect_sources
  \<equiv> \<forall> execs a n. realistic_executions execs \<longrightarrow>
                    (let s_f = run n s0 execs in
                      output_f (run n s0 (ipurge_l execs (current s_f))) a =
                      output_f (run n s0 (ipurge_r execs (current s_f))) a)"
definition isecure::bool
where "isecure \<equiv> NI_unrelated \<and> NI_indirect_sources"

subsubsection \<open>Proofs\<close>
text\<open>
  The final theorem is unwinding\_implies\_isecure\_CISK.
  This theorem shows that any interpretation of locale CISK is secure.

  To prove this theorem, the refinement framework is used.
  CISK is a refinement of ISK, as the only idfference is the control function.
  In ISK, this function is a generic function called \emph{control}, in CISK it is interpreted in function \emph{CISK\_control}.
  It is proven that function \emph{CISK\_control} satisfies all the proof obligations concerning generic function \emph{control}.
  In other words, \emph{CISK\_control} is proven to be an interpretation of control.
  Therefore, all theorems on run\_total apply to the run function of CISK as well.
\<close>

lemma next_action_consistent:
shows "\<forall> s t execs . vpeq (current s) s t \<and> (\<forall> d \<in>  involved (next_action s execs) . vpeq d s t) \<and> current s = current t  \<longrightarrow> next_action s execs = next_action t execs"
proof-
{
  fix s t execs
  assume vpeq: "vpeq (current s) s t"
  assume vpeq_involved: "\<forall> d \<in>  involved (next_action s execs) . vpeq d s t"
  assume current_s_t: "current s = current t"
  from aborting_consistent current_s_t vpeq
   have "aborting t (current s) = aborting s (current s)" by auto
  from current_s_t this waiting_consistent vpeq_involved
    have "next_action s execs = next_action t execs"
    unfolding Kernel.next_action_def
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_execs_consistent:
shows "\<forall> s t execs . vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow> fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
proof-
{
  fix s t execs
  assume vpeq: "vpeq (current s) s t"
  assume vpeq_involved: "\<forall> d \<in> involved (next_action s execs) . vpeq d s t"
  assume current_s_t: "current s = current t"
  from aborting_consistent current_s_t vpeq
     have 1: "aborting t (current s) = aborting s (current s)" by auto
  from 1 vpeq current_s_t vpeq_involved waiting_consistent[THEN spec,THEN spec,THEN spec,THEN spec,where x3=s and x2=t and x1="current s" and x="the (next_action s execs)"]
    have "fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
    unfolding Kernel.next_action_def Kernel.involved_def
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split: if_split_asm)
}
thus ?thesis by auto
qed

lemma next_state_consistent:
shows "\<forall> s t u execs . vpeq (current s) s t \<and> vpeq u s t \<and> current s = current t \<longrightarrow> vpeq u (next_state s execs) (next_state t execs)"
proof-
{
  fix s t u execs
  assume vpeq_s_t: "vpeq (current s) s t \<and> vpeq u s t"
  assume current_s_t: "current s = current t"
  from vpeq_s_t current_s_t
    have "vpeq u (next_state s execs) (next_state t execs)"
    unfolding Kernel.next_state_def
    using aborting_consistent set_error_consistent
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma current_next_state:
shows "\<forall> s execs . current (next_state s execs) = current s"
proof-
{
  fix s execs
  have "current (next_state s execs) = current s"
    unfolding Kernel.next_state_def
    using current_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma locally_respects_next_state:
shows "\<forall> s u execs. \<not>ifp (current s) u \<longrightarrow> vpeq u s (next_state s execs)"
proof-
{
  fix s u execs
  assume "\<not>ifp (current s) u"
  hence "vpeq u s (next_state s execs)"
    unfolding Kernel.next_state_def
    using vpeq_reflexive set_error_locally_respects
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma CISK_control_spec:
shows "\<forall>s d aseqs.
       case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
proof-
{
  fix s d aseqs
  have "case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
  by(cases "(s,d,aseqs)" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_after_cswitch:
shows "\<forall> s n d aseqs . fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
proof-
{
  fix s n d aseqs
  have "fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
  using aborting_switch_independent waiting_switch_independent
  by(cases "(s,d,aseqs)" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_after_next_state:
shows "\<forall> s execs d . current s \<noteq> d \<longrightarrow> fst (CISK_control (next_state s execs) d (execs d)) = None \<or> fst (CISK_control (next_state s execs) d (execs d)) = fst (CISK_control s d (execs d))"
proof-
{
  fix s execs d aseqs
  assume 1: "current s \<noteq> d"
  have "fst (CISK_control (next_state s execs) d aseqs) = None \<or> fst (CISK_control (next_state s execs) d aseqs) = fst (CISK_control s d aseqs)"
    proof(cases "(s,d,aseqs)" rule: CISK_control.cases,simp,simp,simp)
    case (4 sa da a as execs')
      thus ?thesis
          unfolding Kernel.next_state_def
          using aborting_error_update waiting_error_update 1
          by(cases "(sa,current sa,execs (current sa))" rule: CISK_control.cases,auto split: if_split_asm)
    qed
}
thus ?thesis by auto
qed

lemma next_action_after_step:
shows "\<forall> s a d aseqs . current s \<noteq> d \<longrightarrow> fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
proof-
{
  fix s a d aseqs
  assume 1: "current s \<noteq> d"
  from this aborting_after_step
    have  "fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
    unfolding Kernel.step_def
    by(cases "(s,d,aseqs)" rule: CISK_control.cases,simp,simp,simp,cases a,auto)
}
thus ?thesis by auto
qed

lemma next_state_precondition:
shows "\<forall>s d a execs. AS_precondition s d a \<longrightarrow> AS_precondition (next_state s execs) d a"
proof-
{
  fix s a d execs
  assume "AS_precondition s d a"
  hence "AS_precondition (next_state s execs) d a"
    unfolding Kernel.next_state_def
    using precondition_after_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_state_invariant:
shows "\<forall>s execs. invariant s \<longrightarrow> invariant (next_state s execs)"
proof-
{
  fix s execs
  assume "invariant s"
  hence "invariant (next_state s execs)"
    unfolding Kernel.next_state_def
    using invariant_after_set_error_code
    by(cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto)
}
thus ?thesis by auto
qed

lemma next_action_from_execs:
shows "\<forall> s execs . next_action s execs \<rightharpoonup> (\<lambda> a . a \<in> actions_in_execution (execs (current s)))"
proof-
{
  fix s execs
  {
    fix a
    assume 1: "next_action s execs = Some a"
    from 1 have "a \<in> actions_in_execution (execs (current s))"
      unfolding Kernel.next_action_def actions_in_execution_def
      by (cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split: if_split_asm)
  }
  hence "next_action s execs \<rightharpoonup> (\<lambda> a . a \<in> actions_in_execution (execs (current s)))"
    unfolding B_def
    by (cases "next_action s execs",auto)
}
thus ?thesis unfolding B_def by (auto)
qed

lemma next_execs_subset:
shows "\<forall>s execs u . actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
proof-
{
  fix s execs u
  have "actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
    unfolding Kernel.next_execs_def actions_in_execution_def
    by (cases "(s,(current s),execs (current s))" rule: CISK_control.cases,auto split: if_split_asm)
}
thus ?thesis by auto
qed

theorem unwinding_implies_isecure_CISK:
shows isecure
proof-
  interpret int: Interruptible_Separation_Kernel kstep output_f s0 current cswitch interrupt kprecondition realistic_execution CISK_control kinvolved ifp vpeq AS_set invariant AS_precondition aborting waiting
    proof (unfold_locales)
      show "\<forall>a b c u. vpeq u a b \<and> vpeq u b c \<longrightarrow> vpeq u a c"
        using vpeq_transitive by blast
      show "\<forall>a b u. vpeq u a b \<longrightarrow> vpeq u b a"
        using vpeq_symmetric by blast
      show "\<forall>a u. vpeq u a a"
        using vpeq_reflexive by blast
      show "\<forall>u. ifp u u"
        using ifp_reflexive by blast
      show "\<forall> s t u a. vpeq u s t \<and> vpeq (current s) s t \<and> kprecondition s a \<and> kprecondition t a \<and> current s = current t  \<longrightarrow> vpeq u (kstep s a) (kstep t a)"
        using weakly_step_consistent by blast
      show "\<forall> a s u. \<not>ifp (current s) u  \<and> kprecondition s a \<longrightarrow> vpeq u s (kstep s a)"
        using locally_respects by blast
      show "\<forall> a s t. vpeq (current s) s t \<and> current s = current t \<longrightarrow> (output_f s a) = (output_f t a)"
        using output_consistent by blast
      show "\<forall> s a . current (kstep s a) = current s"
        using step_atomicity by blast
      show "\<forall> n s t . current s = current t \<longrightarrow> current (cswitch n s) = current (cswitch n t)"
        using cswitch_independent_of_state by blast
      show "\<forall> u s t n . vpeq u s t \<longrightarrow> vpeq u (cswitch n s) (cswitch n t)"
        using cswitch_consistency by blast
      show "\<forall>s t execs. vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow> next_action s execs = next_action t execs"
        using next_action_consistent by blast
      show "\<forall>s t execs.
        vpeq (current s) s t \<and> (\<forall> d \<in> involved (next_action s execs) . vpeq d s t) \<and> current s = current t \<longrightarrow>
        fst (snd (CISK_control s (current s) (execs (current s)))) = fst (snd (CISK_control t (current s) (execs (current s))))"
        using next_execs_consistent by blast
      show " \<forall>s t u execs. vpeq (current s) s t \<and> vpeq u s t \<and> current s = current t \<longrightarrow> vpeq u (next_state s execs) (next_state t execs)"
        using next_state_consistent by auto
      show " \<forall>s execs. current (next_state s execs) = current s"
        using current_next_state by auto
      show "\<forall>s u execs. \<not> ifp (current s) u \<longrightarrow> vpeq u s (next_state s execs)"
        using locally_respects_next_state by auto
      show "[] \<in> AS_set"
        using empty_in_AS_set by blast
      show "\<forall> s n . invariant s \<longrightarrow> invariant (cswitch n s)"
        using invariant_after_cswitch by blast
      show "\<forall> s d n a. AS_precondition s d a \<longrightarrow> AS_precondition (cswitch n s) d a"
        using precondition_after_cswitch by blast
      show "invariant s0"
        using invariant_s0 by blast
      show "\<forall> s d aseq . invariant s \<and> aseq \<in> AS_set \<and> aseq \<noteq> [] \<longrightarrow> AS_precondition s d (hd aseq)"
        using AS_prec_first_action by blast
      show "\<forall>s a a'. (\<exists>aseq\<in>AS_set. is_sub_seq a a' aseq) \<and> invariant s \<and> AS_precondition s (current s) a \<and> \<not> aborting s (current s) a \<and> \<not> waiting s (current s) a \<longrightarrow>
             AS_precondition (kstep s a) (current s) a'"
        using AS_prec_after_step by blast
      show "\<forall> s d a a' . current s \<noteq> d \<and> AS_precondition s d a \<longrightarrow> AS_precondition (kstep s a') d a"
        using AS_prec_dom_independent by blast
      show "\<forall> s a . invariant s \<longrightarrow> invariant (kstep s a)"
        using spec_of_invariant by blast
      show "\<And>s a. kprecondition s a \<equiv> kprecondition s a"
        by auto
      show "\<And>aseq. realistic_execution aseq \<equiv> set aseq \<subseteq> AS_set"
        unfolding realistic_execution_def
        by auto
      show "\<forall>s a. \<forall> d \<in> involved a. kprecondition s (the a) \<longrightarrow> ifp d (current s)"
        using involved_ifp unfolding Kernel.involved_def by (auto split: option.splits)
      show "\<forall>s execs. next_action s execs \<rightharpoonup> (\<lambda>a. a \<in> actions_in_execution (execs (current s)))"
        using next_action_from_execs by blast
      show "\<forall>s execs u. actions_in_execution (next_execs s execs u) \<subseteq> actions_in_execution (execs u)"
        using next_execs_subset by blast
      show "\<forall>s d aseqs.
       case CISK_control s d aseqs of
       (a, aseqs', s') \<Rightarrow>
         thread_empty aseqs \<and> (a, aseqs') = (None, []) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> \<not> aborting s' d (the a) \<and> \<not> waiting s' d (the a) \<and> (a, aseqs') = (Some (hd (hd aseqs)), tl (hd aseqs) # tl aseqs) \<or>
         aseqs \<noteq> [] \<and> hd aseqs \<noteq> [] \<and> waiting s' d (the a) \<and> (a, aseqs', s') = (Some (hd (hd aseqs)), aseqs, s) \<or> (a, aseqs') = (None, tl aseqs)"
        using CISK_control_spec by blast
      show "\<forall>s n d aseqs. fst (CISK_control (cswitch n s) d aseqs) = fst (CISK_control s d aseqs)"
        using next_action_after_cswitch by auto
      show "\<forall>s execs d.
       current s \<noteq> d \<longrightarrow>
       fst (CISK_control (next_state s execs) d (execs d)) = None \<or> fst (CISK_control (next_state s execs) d (execs d)) = fst (CISK_control s d (execs d))"
        using next_action_after_next_state by auto
      show "\<forall>s a d aseqs. current s \<noteq> d \<longrightarrow> fst (CISK_control (step s a) d aseqs) = fst (CISK_control s d aseqs)"
        using next_action_after_step by auto
      show "\<forall>s d a execs. AS_precondition s d a \<longrightarrow> AS_precondition (next_state s execs) d a"
        using next_state_precondition by auto
      show "\<forall>s execs. invariant s \<longrightarrow> invariant (next_state s execs)"
        using next_state_invariant by auto
      show "\<forall>s a. waiting s (current s) a \<longrightarrow> kstep s a = s"
        using spec_of_waiting by blast
  qed

  note interpreted = int.Interruptible_Separation_Kernel_axioms
  note run_total_induct = Interruptible_Separation_Kernel.run_total.induct[of kstep output_f s0 current cswitch kprecondition realistic_execution
                                                                             CISK_control kinvolved ifp vpeq AS_set invariant AS_precondition aborting waiting _ interrupt]
  have run_equals_run_total:
     "\<And> n s execs . run n s execs \<equiv> Interruptible_Separation_Kernel.run_total kstep current cswitch interrupt CISK_control n s execs"
     proof-
        fix n s execs
        show "run n s execs \<equiv> Interruptible_Separation_Kernel.run_total kstep current cswitch interrupt CISK_control n s execs"
          using interpreted int.step_def
          by(induct n s execs rule: run_total_induct,auto split: option.splits)
     qed
  from interpreted
    have 0: "Interruptible_Separation_Kernel.isecure_total kstep output_f s0 current cswitch interrupt realistic_execution CISK_control kinvolved ifp"
    by (metis int.unwinding_implies_isecure_total)
  from 0 run_equals_run_total
    have 1: "NI_unrelated"
    by (metis realistic_executions_def int.isecure_total_def int.realistic_executions_def int.NI_unrelated_total_def NI_unrelated_def)
  from 0 run_equals_run_total
    have 2: "NI_indirect_sources"
    by (metis realistic_executions_def int.NI_indirect_sources_total_def int.isecure_total_def int.realistic_executions_def NI_indirect_sources_def)
  from 1 2 show ?thesis unfolding isecure_def by auto
qed

end
end


section "Packed Traces"
theory packed_traces
  imports commutativity
begin

text "In this section we show that traces can be packed.
Intuitively a transaction is packed, if there are no steps from other invocations between a
@{term ABeginAtomic} and @{term AEndAtomic} action.

The following definition defines that such a step exists at an index @{term k}.
"

definition indexInOtherTransaction :: "('proc, 'op, 'any) trace \<Rightarrow> txId \<Rightarrow> nat \<Rightarrow> bool" where
  "indexInOtherTransaction tr tx k \<equiv>
  \<exists>i s ntxns.
      k<length tr
    \<and> i<k
    \<and> tr!i = (s, ABeginAtomic tx ntxns)
    \<and> get_invoc (tr!k) \<noteq> s
    \<and> \<not>(\<exists>j. i < j \<and> j < k \<and> tr!j = (s, AEndAtomic))"

text "With this we can define that a trace is packed, if no such step exists:"

definition transactionIsPacked :: "('proc, 'op, 'any) trace \<Rightarrow> txId \<Rightarrow> bool" where
  "transactionIsPacked tr tx \<equiv>
  \<forall>k. \<not>indexInOtherTransaction tr tx k"

\<comment> \<open>this is an alternative definition, which might be easier to work with in some cases\<close>
definition transactionIsPackedAlt :: "('proc, 'op, 'any) trace \<Rightarrow> txId \<Rightarrow> bool" where
  "transactionIsPackedAlt tr tx \<equiv>
  if \<exists>i s ntxns. i < length tr \<and> tr!i = (s, ABeginAtomic tx ntxns) then
    \<exists>i s end ntxns.
         i < length tr
        \<and> tr!i = (s, ABeginAtomic tx ntxns)
        \<and> end > i
        \<and> (end < length tr \<and> tr!end = (s, AEndAtomic) \<or> end = length tr)
        \<and> (\<forall>j. i\<le>j \<and> j< end \<longrightarrow> get_invoc (tr!j) = s)
  else
    True
  "

lemma transactionIsPackedAlt_case_tx_exists:
  assumes "(s, ABeginAtomic tx ntxns) \<in> set tr"
  shows "transactionIsPackedAlt tr tx \<equiv>
    \<exists>i s end ntxns.
         i < length tr
        \<and> tr!i = (s, ABeginAtomic tx ntxns)
        \<and> end > i
        \<and> (end < length tr \<and> tr!end = (s, AEndAtomic) \<or> end = length tr)
        \<and> (\<forall>j. i\<le>j \<and> j< end \<longrightarrow> get_invoc (tr!j) = s)
  "
  by (subst transactionIsPackedAlt_def,
      subst if_P,
      insert assms,
      meson in_set_conv_nth, simp)

lemma transactionIsPackedAlt_eq:
  assumes uniqueTxs: "\<And>i j s s' tnxns tnxns'. \<lbrakk>i<length tr; j<length tr; tr!i = (s, ABeginAtomic tx tnxns); tr!j = (s', ABeginAtomic tx tnxns')\<rbrakk> \<Longrightarrow> i = j"
  shows "transactionIsPackedAlt tr tx = transactionIsPacked tr tx"
proof (auto simp add: transactionIsPackedAlt_def )
  fix i s ntxns ia sa ntxns'
  assume a0: "i < length tr"
    and a1: "tr ! i = (s, ABeginAtomic tx ntxns)"
    and a2: "ia < length tr"
    and a3: "tr ! ia = (sa, ABeginAtomic tx ntxns')"
    and a4: "\<forall>j. ia \<le> j \<and> j < length tr \<longrightarrow> get_invoc (tr ! j) = sa"

  have [simp]: "ia = i"
    using a2 a0 a3 a1 by (rule uniqueTxs)

  then have [simp]: "sa = s"
    using a1 a3 by auto
  then have a4': "\<And>j. i \<le> j \<Longrightarrow> j < length tr \<Longrightarrow> get_invoc (tr ! j) = s"
    using a4 by auto

  show "transactionIsPacked tr tx"
    by (auto simp add: transactionIsPacked_def indexInOtherTransaction_def,
        smt \<open>ia = i\<close> \<open>sa = s\<close> a2 a3 a4' le_eq_less_or_eq le_less_trans prod.inject uniqueTxs)
next
  fix i s ntxns
  assume a0: "i < length tr"
    and a1: "tr ! i = (s, ABeginAtomic tx ntxns)"
    and a2: "transactionIsPacked tr tx"

  from a2
  have a2': "get_invoc (tr ! k) = s \<or> (\<exists>j<k. i < j \<and> tr ! j = (s, AEndAtomic))"
    if "k<length tr" "i<k"
    for k
    using a1 that by (auto simp add: transactionIsPacked_def indexInOtherTransaction_def)

  show "\<exists>i<length tr. \<exists>s. (\<exists>ntxns. tr ! i = (s, ABeginAtomic tx ntxns)) \<and> (\<exists>end>i. (end < length tr \<and> tr ! end = (s, AEndAtomic) \<or> end = length tr) \<and> (\<forall>j. i \<le> j \<and> j < end \<longrightarrow> get_invoc (tr ! j) = s))"
  proof (rule exI[where x=i], (auto simp add: a0))
    show "\<exists>s. (\<exists>ntxns. tr ! i = (s, ABeginAtomic tx ntxns)) \<and> (\<exists>end>i. (end < length tr \<and> tr ! end = (s, AEndAtomic) \<or> end = length tr) \<and> (\<forall>j. i \<le> j \<and> j < end \<longrightarrow> get_invoc (tr ! j) = s))"
    proof (rule exI[where x=s], safe)
      show "\<exists>ntxns. tr ! i = (s, ABeginAtomic tx ntxns)"
        by (simp add: a1)
      define endPos where "endPos = (if \<exists>j. i<j \<and> j<length tr \<and> tr!j = (s, AEndAtomic) then LEAST j. i<j \<and> j<length tr \<and> tr!j = (s, AEndAtomic) else length tr)"
      show "\<exists>end>i. (end < length tr \<and> tr ! end = (s, AEndAtomic) \<or> end = length tr) \<and> (\<forall>j. i \<le> j \<and> j < end \<longrightarrow> get_invoc (tr ! j) = s) "
      proof (rule exI[where x="endPos"], (auto simp add: endPos_def))
        show "\<And>j. \<lbrakk>i < j; j < length tr; tr ! j = (s, AEndAtomic); (LEAST j. i < j \<and> j < length tr \<and> tr ! j = (s, AEndAtomic)) \<noteq> length tr\<rbrakk> \<Longrightarrow> (LEAST j. i < j \<and> j < length tr \<and> tr ! j = (s, AEndAtomic)) < length tr"
          by (smt less_trans neqE not_less_Least)
        show "\<And>j. \<lbrakk>i < j; j < length tr; tr ! j = (s, AEndAtomic); (LEAST j. i < j \<and> j < length tr \<and> tr ! j = (s, AEndAtomic)) \<noteq> length tr\<rbrakk> \<Longrightarrow> tr ! (LEAST j. i < j \<and> j < length tr \<and> tr ! j = (s, AEndAtomic)) = (s, AEndAtomic)"
          by (smt LeastI)
        show "\<And>j ja. \<lbrakk>i < j; j < length tr; tr ! j = (s, AEndAtomic); i \<le> ja; ja < (LEAST j. i < j \<and> j < length tr \<and> tr ! j = (s, AEndAtomic))\<rbrakk> \<Longrightarrow> get_invoc (tr ! ja) = s"
          by (smt a1 a2' dual_order.strict_trans fst_conv neqE not_le not_less_Least)
        show "\<And>j. \<lbrakk>\<forall>j<length tr. i < j \<longrightarrow> tr ! j \<noteq> (s, AEndAtomic); i \<le> j; j < length tr\<rbrakk> \<Longrightarrow> get_invoc (tr ! j) = s"
          by (metis a1 a2' dual_order.strict_trans fst_conv le_eq_less_or_eq)
        show "\<And>j. \<lbrakk>i < j; j < length tr; tr ! j = (s, AEndAtomic)\<rbrakk> \<Longrightarrow> i < (LEAST j. i < j \<and> j < length tr \<and> tr ! j = (s, AEndAtomic))"
          by (metis (mono_tags, lifting) LeastI_ex)
        show "\<forall>j<length tr. i < j \<longrightarrow> tr ! j \<noteq> (s, AEndAtomic) \<Longrightarrow> i < length tr"
          using a0 by blast
      qed
    qed
  qed
next
  show "\<forall>i<length tr. \<forall>s ntxns. tr ! i \<noteq> (s, ABeginAtomic tx ntxns) \<Longrightarrow> transactionIsPacked tr tx"
    by (auto simp add: transactionIsPacked_def indexInOtherTransaction_def)
next
  fix i s ntxns ia sa ntxns' ende
  assume a0: "i < length tr"
    and a1: "tr ! i = (s, ABeginAtomic tx ntxns)"
    and a3: "tr ! ia = (sa, ABeginAtomic tx ntxns')"
    and a7: "ia < ende"
    and a4: "\<forall>j. ia \<le> j \<and> j < ende \<longrightarrow> get_invoc (tr ! j) = sa"
    and a5: "ende < length tr"
    and a6: "tr ! ende = (sa, AEndAtomic)"

  have a2: "ia < length tr"
    using a5 a7 less_trans by blast

  with uniqueTxs have [simp]: "ia = i"
    using a0 a1 a3 by blast

  then have [simp]: "sa = s"
    using a1 a3 by auto

  have a4': "get_invoc (tr ! j) = s" if "i \<le> j" and "j < ende" for j
    by (auto simp add: that a4)

  show "transactionIsPacked tr tx"
  proof (auto simp add: transactionIsPacked_def indexInOtherTransaction_def)
    fix k i' s' ntxns
    assume b0: "k < length tr"
      and b1: "i' < k"
      and b2: "tr ! i' = (s', ABeginAtomic tx ntxns)"
      and b3: "\<forall>j>i'. j < k \<longrightarrow> tr ! j \<noteq> (s', AEndAtomic)"
      and b4: "get_invoc (tr ! k) \<noteq> s'"

    have " i' < length tr"
      using b0 b1 order.strict_trans by blast

    then have [simp]: "i' = i"
      using uniqueTxs b2 a1 a0 by blast

    then have [simp]: "s' = s"
      using a1 b2 by auto

    have b3': "\<forall>j>i. j < k \<longrightarrow> tr ! j \<noteq> (s, AEndAtomic)"
      using b3 by simp
    have "get_invoc (tr ! k) = s"
    proof (cases "k < ende")
      case True
      show ?thesis
      proof (rule a4')
        show "i \<le> k"
          using \<open>i' = i\<close> b1 dual_order.strict_implies_order by blast
        show "k < ende" using True .
      qed
    next case False
      then have "k \<ge> ende" by simp
      show ?thesis
      proof (cases "k = ende")
        case True
        then show ?thesis
          by (simp add: a6)
      next
        case False
        then have "k > ende"
          by (simp add: \<open>ende \<le> k\<close> dual_order.strict_iff_order)
        from b3' have "ende>i \<and> ende < k \<longrightarrow> tr ! ende \<noteq> (s, AEndAtomic)"
          by blast
        with \<open>k > ende\<close> have "tr ! ende \<noteq> (s, AEndAtomic)"
          using \<open>ia = i\<close> a7 by blast

        then show ?thesis
          by (simp add: a6)
      qed
    qed
    with b4 show False  by simp
  qed
qed

lemma transactionIsPackedAlt_eq2:
  assumes steps: "initialState p ~~ tr \<leadsto>* S"
  shows "transactionIsPackedAlt tr tx = transactionIsPacked tr tx"
  by (auto simp add: transactionIdsUnique[OF steps] transactionIsPackedAlt_eq)

lemma transactionIsPacked_show:
  assumes steps: "initialState p ~~ tr \<leadsto>* S"
    and beginAtomic1: "beginAtomic < endAtomic"
    and beginAtomic2: "tr!beginAtomic = (s, ABeginAtomic tx ntxns)"
    and endAtomic1: "endAtomic < length tr"
    and endAtomic2: "tr!endAtomic = (s, AEndAtomic)"
    and a1: "\<forall>i. beginAtomic \<le> i \<and> i \<le> endAtomic \<longrightarrow> get_invoc (tr ! i) = s"
  shows "transactionIsPacked tr tx"
proof (auto simp add: transactionIsPacked_def indexInOtherTransaction_def)
  fix k i s' ntxns
  assume b0: "k < length tr"
    and b1: "i < k"
    and b2: "tr ! i = (s', ABeginAtomic tx ntxns)"
    and b3: "\<forall>j>i. j < k \<longrightarrow> tr ! j \<noteq> (s', AEndAtomic)"
    and b4: "get_invoc (tr ! k) \<noteq> s'"

  from b2
  have "i = beginAtomic"
    using b0 b1 beginAtomic1 beginAtomic2 endAtomic1 transactionIdsUnique[OF steps] by auto
  then have "s' = s"
    using b2 beginAtomic2 by auto

  from b3
  have "k \<le> endAtomic"
    using \<open>i = beginAtomic\<close> \<open>s' = s\<close> beginAtomic1 endAtomic2 leI by blast

  with b4 show False
    using \<open>i = beginAtomic\<close> \<open>k \<le> endAtomic\<close> a1 b1 b2 by auto
qed

\<comment> \<open>the set of transactions occurring in the trace\<close>
definition traceTransactions :: "('proc, 'op, 'any) trace \<Rightarrow> txId set" where
  "traceTransactions tr \<equiv> {tx | s tx txns. (s, ABeginAtomic tx txns) \<in> set tr}"

text \<open>between begin and end of a transaction there are no actions from other sessions\<close>
definition transactionsArePacked :: "('proc, 'op, 'any) trace \<Rightarrow> bool" where
  "transactionsArePacked tr \<equiv>
  \<forall>i k s t txns.
      i<k
    \<and> k<length tr
    \<and> tr!i = (s, ABeginAtomic t txns)
    \<and> get_invoc (tr!k) \<noteq> s
    \<longrightarrow>  (\<exists>j. i < j \<and> j < k \<and> tr!j = (s, AEndAtomic))"

text \<open>
For termination proofs, we want to measure how far a trace is from being packed.
For this we take the sum over all actions in the trace and count in how many transactions
it appears.
\<close>

\<comment> \<open>checks if sessions s is in a transaction at position i in trace tr\<close>
definition inTransaction :: "('proc, 'op, 'any) trace \<Rightarrow> nat \<Rightarrow> invocId \<Rightarrow> bool"  where
  "inTransaction tr i s \<equiv>
  \<exists>j. j\<le>i \<and> i<length tr \<and> (\<exists>t txns. tr!j = (s, ABeginAtomic t txns))
     \<and> (\<forall>k. j<k \<and> k < length tr \<and> k\<le>i \<longrightarrow> tr!k \<noteq> (s, AEndAtomic))
"

\<comment> \<open>returns the set of all transactions, which are in a transaction at point i in the trace\<close>
definition sessionsInTransaction :: "('proc, 'op, 'any) trace \<Rightarrow> nat \<Rightarrow> invocId set"  where
  "sessionsInTransaction tr i \<equiv> {s. inTransaction tr i s}"

lemma sessionsInTransaction_h1: " sessionsInTransaction [(s\<^sub>1, ABeginAtomic t\<^sub>1 txns), (s\<^sub>1, AEndAtomic)] 3 = {}"
  by (auto simp add: sessionsInTransaction_def  inTransaction_def nth_Cons' split: if_splits)

lemma sessionsInTransaction_h2: " sessionsInTransaction [(s1, ABeginAtomic t\<^sub>1 txns)] 0= {s1}"
  by (auto simp add: sessionsInTransaction_def inTransaction_def nth_Cons' split: if_splits)

lemma sessionsInTransaction_h3: " sessionsInTransaction [(s\<^sub>1, ABeginAtomic t\<^sub>1 txns), (s\<^sub>1, AEndAtomic)] 1 = {}"
  by (auto simp add: sessionsInTransaction_def inTransaction_def nth_Cons' split: if_splits )

lemma sessionsInTransaction_append:
  "i<length xs \<Longrightarrow> sessionsInTransaction (xs@ys) i = sessionsInTransaction xs i"
  by (auto simp add: nth_append sessionsInTransaction_def inTransaction_def)

lemma not_packed_example:
  assumes notPacked: "\<not>transactionsArePacked tr"
  shows "\<exists>i k s t ts a s'.
      tr ! k = (s', a)
    \<and> i<k
    \<and> k<length tr
    \<and> tr!i = (s, ABeginAtomic t ts)
    \<and> s' \<noteq> s
    \<and>  (\<forall>j. i < j \<and> j < k \<longrightarrow> tr!j \<noteq> (s, AEndAtomic))"
  using assms by (auto simp add: transactionsArePacked_def, metis prod.collapse)

lemma show_traceCorrect_same:
  assumes sameTraceContent: "set tr = set tr'"
  shows "traceCorrect tr' = traceCorrect tr"
  using assms by (auto simp add: traceCorrect_def)

definition allowed_context_switch where
  "allowed_context_switch action \<equiv>
            (\<exists>txId txns. action = ABeginAtomic txId txns)
          \<or> (\<exists>p. action = AInvoc p)"

lemma allowed_context_switch_cases[consumes 1, elim, case_names invoc beginAtomic]:
  assumes "allowed_context_switch action"
    and "\<And>p. action = AInvoc p \<Longrightarrow> P"
    and "\<And>txId txns. action = ABeginAtomic txId txns \<Longrightarrow> P"
  shows P
  using allowed_context_switch_def assms by blast

lemma allowed_context_switch_simps:
  shows "\<not>allowed_context_switch (ALocal ok)"
    and "\<not>allowed_context_switch (ANewId uid)"
    and "allowed_context_switch (ABeginAtomic t ats)"
    and "\<not>allowed_context_switch AEndAtomic"
    and "\<not>allowed_context_switch (ADbOp c x ar)"
    and "allowed_context_switch (AInvoc p)"
    and "\<not>allowed_context_switch (AReturn ir)"
    and "\<not>allowed_context_switch ACrash"
    and "\<not>allowed_context_switch (AInvcheck invr)" by (auto simp add: allowed_context_switch_def)

lemma canSwap_when_allowed:
  assumes no_ctxt_switch: "\<not>allowed_context_switch b"
    and no_invcheck_a: "\<not>is_AInvcheck a"
    and no_invcheck_b: "\<not>is_AInvcheck b"
    and no_fail_a: "a \<noteq> ACrash"
    and no_fail_b: "b \<noteq> ACrash"
  shows "canSwap t a b"
  by (metis allowed_context_switch_def canSwap_cases no_ctxt_switch no_fail_a no_fail_b no_invcheck_a no_invcheck_b)

definition packed_trace :: "('proc, 'op, 'any) trace \<Rightarrow> bool" where
  "packed_trace tr \<equiv>
  \<forall>i.
      0<i
    \<longrightarrow> i<length tr
    \<longrightarrow> get_invoc (tr!(i-1)) \<noteq> get_invoc (tr!i)
    \<longrightarrow> (allowed_context_switch (get_action (tr!i)))"

text \<open>\DefineSnippet{packed_trace_def}{
  @{thm [display] packed_trace_def[unfolded imp_conjL[symmetric]]}
}%EndSnippet\<close>

text \<open>\DefineSnippet{allowed_context_switch_def}{
  @{thm [display] allowed_context_switch_def}
}%EndSnippet\<close>

lemmas use_packed_trace = iffD1[OF packed_trace_def[THEN meta_eq_to_obj_eq], rule_format]

lemma prefixes_are_packed:
  assumes "packed_trace tr'"
    and "isPrefix tr tr'"
  shows "packed_trace tr"
  using \<open>packed_trace tr'\<close> by (auto simp add: packed_trace_def,
      metis (no_types, lifting) Suc_leI assms(2) diff_less_Suc isPrefix_len isPrefix_same less_le_trans)

lemma context_switches_in_packed:
  assumes packed: "packed_trace tr"
    and split_tr: "tr = tr1@[(s,a),(s',a')]@tr2"
    and differentSession: "s \<noteq> s'"
  shows "allowed_context_switch a'"
proof -
  have "a' = get_action(tr!(1+length tr1))"
    using split_tr by (auto simp add: nth_append)

  moreover
  have "allowed_context_switch (get_action(tr!(1+length tr1)))"
    using packed proof (rule use_packed_trace)
    show "0 < 1 + length tr1" by simp
    show "1 + length tr1 < length tr" using split_tr by auto
    show "get_invoc (tr ! (1 + length tr1 - 1)) \<noteq> get_invoc (tr ! (1 + length tr1))" using split_tr \<open>s \<noteq> s'\<close> by (auto simp add: nth_append)
  qed
  ultimately
  show ?thesis by simp
qed

definition packed_trace_i :: "('proc, 'op, 'any) trace \<Rightarrow> invocId \<Rightarrow> bool" where
  "packed_trace_i tr i \<equiv>
  \<forall>k.
      0<k
    \<longrightarrow> k<length tr
    \<longrightarrow> get_invoc (tr!k) = i
    \<longrightarrow> get_invoc (tr!(k-1)) \<noteq> i
    \<longrightarrow> (allowed_context_switch (get_action (tr!k)))"

text_raw \<open>\DefineSnippet{pack_trace_for_one_session}{\<close>
lemma pack_trace_for_one_session:
  assumes steps: "initialState program ~~ tr1 \<leadsto>* C"
    and noFail: "\<And>s. (s, ACrash) \<notin> set tr1" (is "\<And>s. _ \<notin> set ?tr")
    and noInvcheck: "\<And>s a. (s, a)\<in>set tr1 \<Longrightarrow> \<not>is_AInvcheck a "
  shows "\<exists>tr'. packed_trace_i tr' s
        \<and> (initialState program ~~ tr' \<leadsto>* C)
        \<and> (\<forall>s. packed_trace_i tr1 s \<longrightarrow> packed_trace_i tr' s)
        \<and> (set tr' = set tr1)"
text_raw \<open>}%EndSnippet\<close>
  text \<open>By induction over the minimal index that is not packed.\<close>
proof -

  have "\<exists>tr'.
      (\<forall>i<length tr1. \<not>(0 < i
                      \<and>  get_invoc (tr'!(i-1)) \<noteq> s
                      \<and> get_invoc (tr'!i) = s
                      \<and> \<not>(allowed_context_switch (get_action(tr'!i))) )  )
        \<and> (initialState program ~~ tr' \<leadsto>* C)
        \<and> (length tr' = length tr1)
        \<and> (\<forall>s. packed_trace_i tr1 s \<longrightarrow> packed_trace_i tr' s)
        \<and> (set tr' = set tr1)" (is "\<exists>tr'. ?P tr'")
  proof (rule fix_smallest_induct, auto simp add: assms disj_imp rewrite_and_implies, rename_tac tr i)

    show "\<exists>tr'.
      (\<forall>j\<le>i. 0 < j
          \<longrightarrow> get_invoc (tr' ! (j - Suc 0)) \<noteq> get_invoc (tr ! i)
          \<longrightarrow> get_invoc (tr' ! j) = get_invoc (tr ! i)
          \<longrightarrow> allowed_context_switch (get_action (tr' ! j)))
      \<and> initialState program ~~ tr' \<leadsto>* C
      \<and> length tr' = length tr1
      \<and> (\<forall>s. packed_trace_i tr1 s \<longrightarrow> packed_trace_i tr' s)
      \<and> set tr' = set tr1"
      if c0: "\<And>j. j < i \<Longrightarrow> 0 < j \<longrightarrow> get_invoc (tr ! (j - Suc 0)) \<noteq> get_invoc (tr ! i) \<longrightarrow> get_invoc (tr ! j) = get_invoc (tr ! i) \<longrightarrow> allowed_context_switch (get_action (tr ! j))"
        and c1: "i < length tr1"
        and c2: "initialState program ~~ tr \<leadsto>* C"
        and i1[simp]: "0 < i"
        and c4: "length tr = length tr1"
        and c5: "get_invoc (tr ! (i - Suc 0)) \<noteq> get_invoc (tr ! i)"
        and c6: "\<forall>s. packed_trace_i tr1 s \<longrightarrow> packed_trace_i tr s"
        and same_tr: "set tr = set tr1"
        and i5: "\<not> allowed_context_switch (get_action (tr ! i))"
        and c8: "s = get_invoc (tr ! i)"
      for  tr i
    proof -

      have i2: "i<length tr"
        by (simp add: c1 c4)

      have i4: "get_invoc (tr!i) = s"
        by (simp add: c8)

      text \<open>There must be a previous action on the same invocId (at least the invocId should be there, since i is no invocId).\<close>
      obtain prev
        where prev1: "get_invoc(tr!prev) = s"
          and prev2: "prev < i"
          and prev3: "\<And>j. \<lbrakk>prev < j; j < i\<rbrakk> \<Longrightarrow> get_invoc(tr!j) \<noteq> s"
      proof (atomize_elim)
        from \<open>initialState program ~~ tr \<leadsto>* C\<close> \<open>i<length tr\<close> \<open>get_invoc (tr!i) = s\<close>
        have "\<exists>j<i. get_invoc (tr ! j) = s \<and> (\<exists>p. get_action (tr ! j) = AInvoc p)"
        proof (rule exists_invoc)
          show "\<And>p. get_action (tr ! i) \<noteq> AInvoc p"
            using allowed_context_switch_def[where action="get_action (tr ! i)"] i5 by blast
          show "\<not> is_AInvcheck (get_action (tr ! i))"
            by (metis i2 noInvcheck nth_mem prod.collapse same_tr)
        qed
        then have "\<exists>j<i. get_invoc (tr ! j) = s"
          by auto
        then have "\<exists>j. (j<i \<and> get_invoc (tr ! j) = s) \<and> (\<forall>j'. j'<i \<and> get_invoc (tr ! j') = s \<longrightarrow> j'\<le>j)"
        proof (rule exists_greatest')
          show "\<exists>bound. \<forall>j. j < i \<and> get_invoc (tr ! j) = s \<longrightarrow> j \<le> bound"
            using less_or_eq_imp_le by blast
        qed
        from this obtain j where "(j<i \<and> get_invoc (tr ! j) = s) \<and> (\<forall>j'. j'<i \<and> get_invoc (tr ! j') = s \<longrightarrow> j'\<le>j)"
          by blast
        then have "get_invoc (tr ! j) = s \<and> j < i \<and> (\<forall>j'>j. j' < i \<longrightarrow> get_invoc (tr ! j') \<noteq> s)"
          by auto

        then show "\<exists>prev. get_invoc (tr ! prev) = s \<and> prev < i \<and> (\<forall>j>prev. j < i \<longrightarrow> get_invoc (tr ! j) \<noteq> s)"  ..
      qed

      have [simp]: "prev < length tr"
        using i2 order.strict_trans prev2 by blast
      have [simp]: "min (length tr) prev = prev"
        using i2 prev2 by linarith
      have [simp]: "min (length tr) i = i"
        using i2  by linarith

      text \<open>Then we can split the trace, so that we have (one action from s) -- (many other actions) -- (action i form s)\<close>
      have tr_split: "tr = take prev tr @ [tr!prev] @ drop (Suc prev) (take i tr) @ [tr!i] @ drop (Suc i) tr"
      proof (rule nth_equalityI)
        show "length tr = length (take prev tr @ [tr ! prev] @ drop (Suc prev) (take i tr) @ [tr ! i] @ drop (Suc i) tr)"
          using i2 prev2 by auto
        show "tr ! ia = (take prev tr @ [tr ! prev] @ drop (Suc prev) (take i tr) @ [tr ! i] @ drop (Suc i) tr) ! ia" if "ia<length tr"for ia
          using that by (auto simp add: nth_append nth_Cons'  Suc_leI less_diff_conv prev2)

      qed

      text \<open>Because of the swap lemma we can change this to (one action from s) -- (action i form s) -- (many other actions)\<close>
      define tr' where "tr' = take prev tr @ [tr!prev, tr!i] @ drop (Suc prev) (take i tr)  @ drop (Suc i) tr"

      have tr'sameLength: "length tr' = length tr"
        using i2 prev2  by (auto simp add: tr'_def)

      have tr'_sameSet: "set tr' = set tr"
        by (subst tr_split, subst  tr'_def, auto)

      have tr'1: "tr'!x = tr!x" if "x \<le> prev" for x
        using that by (auto simp add: tr'_def nth_append)
      moreover have tr'2: "tr'!x = tr!i" if "x=Suc prev" for x
        using that by (auto simp add: tr'_def nth_append)
      moreover have tr'3: "tr'!x = tr!(x-1)" if "x>Suc prev"  and "x<i" for x
        using that by (auto simp add: tr'_def nth_append nth_Cons',
            metis Suc_diff_Suc diff_Suc_less dual_order.strict_trans less_2_cases not_less_eq numeral_2_eq_2)
      moreover have tr'4: "tr'!x = tr!(x-1)" if  "x = i" for x
        using that prev2 antisym  prev1 c5 c8  by (auto simp add: tr'_def nth_append nth_Cons' Suc_diff_Suc numeral_2_eq_2, fastforce)
      moreover have tr'5: "tr'!x = tr!x" if "x > i" and "x < length tr" for x
        using that prev2 by (auto simp add: tr'_def nth_append nth_Cons')
      ultimately have tr'i_def: "tr'!x = (if x\<le>prev then tr!x else if x=Suc prev then tr!i else if x\<le>i then tr!(x-1) else tr!x)" if "x<length tr" for x
        by (metis antisym_conv2 not_le not_less_eq_eq that)

      have "initialState program ~~ (take prev tr @ [tr!prev]) @ [tr!i] @ drop (Suc prev) (take i tr)  @ drop (Suc i) tr \<leadsto>* C"
      proof (rule swapMany_middle')
        show "initialState program ~~ (take prev tr @ [tr ! prev]) @ drop (Suc prev) (take i tr) @ [tr ! i] @ drop (Suc i) tr \<leadsto>* C"
          using tr_split c2 by auto

        show "\<And>x. x \<in> set (drop (Suc prev) (take i tr)) \<Longrightarrow> get_invoc x \<noteq> get_invoc (tr ! i)"
          using prev3 by (auto simp add: in_set_conv_nth,
              metis add.commute add_Suc_right fst_conv i4 less_add_Suc1 less_diff_conv)

        from i5
        show "canSwap t (get_action x) (get_action (tr ! i))" if "x \<in> set (drop (Suc prev) (take i tr))" for x t
        proof (rule canSwap_when_allowed)
          from that obtain k
            where k1: "x = tr!k"
              and k2: "k<i"
              and k3: "k>prev"
            by (auto simp add: in_set_conv_nth)

          then have k4: "x\<in>set tr"
            using dual_order.strict_trans i2 nth_mem by blast

          show "\<not> is_AInvcheck (get_action x)"
            by (metis k4 noInvcheck prod.collapse same_tr)
          show "\<not> is_AInvcheck (get_action (tr ! i))"
            by (metis i2 noInvcheck nth_mem prod.collapse same_tr)
          show "get_action x \<noteq> ACrash"
            by (metis k4 noFail prod.collapse same_tr)
          show "get_action (tr ! i) \<noteq> ACrash"
            by (metis c1 c4 noFail nth_mem same_tr surjective_pairing)
        qed

        show "state_wellFormed (initialState program)"
          by (simp add: state_wellFormed_init)

        from noFail
        show "\<And>i. (i, ACrash) \<notin> set (take prev tr @ [tr ! prev])"
          by (metis Un_iff same_tr set_append tr_split)
        from noFail
        show "\<And>ia. (ia, ACrash) \<notin> set (drop (Suc prev) (take i tr))"
          using in_set_dropD in_set_takeD same_tr by fastforce
      qed

      then have "initialState program ~~ tr' \<leadsto>* C"
        by (simp add: tr'_def)

      have tr'packed: "packed_trace_i tr' s" if "packed_trace_i tr s" for s
        using that Suc_leI prev2
        by (auto simp add: packed_trace_i_def tr'i_def tr'sameLength i4 prev1,
            metis Suc_pred c8 diff_le_self le_less_Suc_eq le_zero_eq not_le_imp_less,
            metis Suc_pred c5 i2 i5 le_less_Suc_eq not_le_imp_less not_less0 not_less_iff_gr_or_eq)

      show "\<exists>tr'. (\<forall>j\<le>i. 0 < j \<longrightarrow>
                  get_invoc (tr' ! (j - Suc 0)) \<noteq> get_invoc (tr ! i) \<longrightarrow>
                  get_invoc (tr' ! j) = get_invoc (tr ! i) \<longrightarrow> allowed_context_switch (get_action (tr' ! j))) \<and>
          (initialState program ~~ tr' \<leadsto>* C) \<and>
          length tr' = length tr1 \<and> (\<forall>s. packed_trace_i tr1 s \<longrightarrow> packed_trace_i tr' s) \<and> set tr' = set tr1"
      proof (rule exI[where x=tr'], intro conjI impI allI)

        show "initialState program ~~ tr' \<leadsto>* C"
          by (simp add: \<open>initialState program ~~ tr' \<leadsto>* C\<close>)
        show "length tr' = length tr1"
          using c4 tr'sameLength by auto

        show "\<And>s. packed_trace_i tr1 s \<Longrightarrow> packed_trace_i tr' s"
          using c6 tr'packed by blast

        show "allowed_context_switch (get_action (tr' ! j))"
          if d0: "j \<le> i"
            and d1: "0 < j"
            and d2: "get_invoc (tr' ! (j - Suc 0)) \<noteq> get_invoc (tr ! i)"
            and d3: "get_invoc (tr' ! j) = get_invoc (tr ! i)"
          for  j
        proof (cases "j = i")
          case True
          then show ?thesis
            using c5 d3 tr'4  by (auto simp add: tr'_def nth_append nth_Cons' split: if_splits)
        next
          case False
          hence "j < i"
            using antisym_conv2 d0 by blast
          hence "allowed_context_switch (get_action (tr ! j))"
            by (smt Suc_pred c0 c1 c4 c8 d0 d1 d2 d3 diff_Suc_1 leD less_trans not_le_imp_less not_less_eq prev1 prev3 tr'i_def)

          thus "allowed_context_switch (get_action (tr' ! j))"
            using \<open>j < i\<close> c1 c4 c8 d2 d3 less_trans prev1 prev3 tr'i_def by auto
        qed

        show " set tr' = set tr1"
          by (simp add: same_tr tr'_sameSet)
      qed
    qed
  qed

  thus ?thesis
    by (metis packed_trace_i_def)

qed

lemma packed_trace_iff_all_sessions_packed:
  "packed_trace tr \<longleftrightarrow> (\<forall>i. packed_trace_i tr i)"
  by (auto simp add: packed_trace_def packed_trace_i_def)

text \<open>\DefineSnippet{packed_trace_i_def}{
  @{thm [display] packed_trace_i_def[unfolded imp_conjL[symmetric]]}
}%EndSnippet\<close>

text \<open>\DefineSnippet{packed_trace_iff_all_sessions_packed}{
  @{thm [display] packed_trace_iff_all_sessions_packed}
}%EndSnippet\<close>

text \<open>Now we can just repeat fixing invocId by invocId, until all sessions are packed.\<close>
lemma pack_trace:
  assumes steps: "initialState program ~~ tr \<leadsto>* C"
    and noFail: "\<And>s. (s, ACrash) \<notin> set tr"
    and noInvcheck: "\<And>s a. (s, a)\<in>set tr \<Longrightarrow> \<not>is_AInvcheck a "
  shows "\<exists>tr'. packed_trace tr'
        \<and> (initialState program ~~ tr' \<leadsto>* C)
        \<and> (set tr' = set tr)"
proof -
  have "{s. \<not>packed_trace_i tr s } \<subseteq> set (map get_invoc tr)"
    by (auto simp add: packed_trace_i_def)

  then have "finite {s. \<not>packed_trace_i tr s }"
    using infinite_super by blast

  from this and assms
  show ?thesis
  proof (induct "{s. \<not>packed_trace_i tr s }" arbitrary: tr rule: finite_psubset_induct)
    case psubset

    show ?case
    proof (cases "{s. \<not>packed_trace_i tr s } = {}")
      case True
      then have "packed_trace tr"
        by (auto simp add: packed_trace_iff_all_sessions_packed)
      then show ?thesis
        using psubset.prems by blast
    next
      case False
      from this obtain s where "\<not> packed_trace_i tr s"
        by blast

      from \<open>initialState program ~~ tr \<leadsto>* C\<close> \<open>\<And>s. (s, ACrash) \<notin> set tr\<close> \<open>\<And>s a. (s, a) \<in> set tr \<Longrightarrow> \<not> is_AInvcheck a\<close>
      have "\<exists>tr'. packed_trace_i tr' s
          \<and> (initialState program ~~ tr' \<leadsto>* C)
          \<and> (\<forall>s. packed_trace_i tr s \<longrightarrow> packed_trace_i tr' s)
          \<and> (set tr' = set tr)"
        by (rule pack_trace_for_one_session; force)

      from this
      obtain tr'
        where tr'1: "packed_trace_i tr' s"
          and tr'2: "initialState program ~~ tr' \<leadsto>* C"
          and tr'3: "\<forall>s. packed_trace_i tr s \<longrightarrow> packed_trace_i tr' s"
          and tr'4: "set tr' = set tr"
        by blast

      from tr'1 tr'3 \<open>\<not> packed_trace_i tr s\<close>
      have subset: "{s. \<not>packed_trace_i tr' s } \<subset> {s. \<not>packed_trace_i tr s }"
        by auto

      from subset tr'2
      have " \<exists>tr''. packed_trace tr'' \<and> (initialState program ~~ tr'' \<leadsto>* C) \<and> set tr'' = set tr'"
      proof (rule psubset.hyps(2))
        show "\<And>s. (s, ACrash) \<notin> set tr'"
          by (simp add: psubset.prems(2) tr'4)
        show "\<And>s a. (s, a) \<in> set tr' \<Longrightarrow> \<not> is_AInvcheck a"
          using psubset.prems(3) tr'4 by blast
      qed

      thus ?thesis
        by (simp add: tr'4)
    qed
  qed
qed

lemma remove_invchecks:
  assumes "(S ~~ tr \<leadsto>* S') "
  shows "(S ~~ filter (\<lambda>a. \<not>is_AInvcheck (get_action a)) tr \<leadsto>* S')"
  using assms proof (induct rule: steps_induct)
  case initial
  then show ?case
    by (simp add: steps_refl)
next
  case (step S' tr a S'')
  then show ?case
    by( auto simp add: is_AInvcheck_def step.simps steps_step steps_empty)
qed

text_raw \<open>\DefineSnippet{pack_incorrect_trace}{\<close>
lemma pack_incorrect_trace:
  assumes steps: "initialState program ~~ tr \<leadsto>* C"
    and noFail: "\<And>s. (s, ACrash) \<notin> set tr"
    and notCorrect: "\<not>traceCorrect tr"
  shows "\<exists>tr' C'. packed_trace tr'
        \<and> (initialState program ~~ tr' \<leadsto>* C')
        \<and> (\<forall>s. (s, ACrash) \<notin> set tr')
        \<and> \<not>traceCorrect tr'"
text_raw \<open>}%EndSnippet\<close>
proof -
  text \<open>As the trace is not correct, there must be a failing invariant:\<close>

  show ?thesis
  proof (cases "\<exists>failPos1 < length tr. \<exists>s. tr ! failPos1 = (s, AInvcheck False)")
    case True

    from this
    obtain failPos1
      where failPos1_props: "failPos1 < length tr \<and> (\<exists>s. tr ! failPos1 = (s, AInvcheck False))"
      by blast

    text \<open>Now take the minimal failing position.\<close>
    then have "\<exists>failPos1. (failPos1 < length tr \<and> (\<exists>s. tr ! failPos1 = (s, AInvcheck False)))
           \<and> (\<forall>i. (i < length tr \<and> (\<exists>s. tr ! i = (s, AInvcheck False))) \<longrightarrow> i \<ge> failPos1)"
      by (rule ex_has_least_nat)
    from this
    obtain failPos failPos_s
      where failPos_len: "failPos < length tr"
        and failPos_fail: "tr ! failPos = (failPos_s, AInvcheck False)"
        and failPos_min: "\<And> i. \<lbrakk>i < length tr; \<exists>s txns. tr ! i = (s, AInvcheck False)\<rbrakk> \<Longrightarrow> i\<ge>failPos"
      by auto

    text \<open>Only the part leading to the invariant violation is relevant ...\<close>

    define tr' where "tr' = take failPos tr"

    from steps
    obtain C' where tr'_steps: "initialState program ~~ tr' \<leadsto>* C'"
      by (metis append_take_drop_id steps_append tr'_def)

    from steps
    have "initialState program ~~ (tr'@[tr!failPos]@drop (Suc failPos) tr) \<leadsto>* C"
      by (metis \<open>failPos < length tr\<close> append.assoc append_take_drop_id take_Suc_conv_app_nth tr'_def)
    then have "\<exists>C''. C' ~~ tr ! failPos  \<leadsto>  C''"
      using  tr'_steps by (auto simp add: steps_append2 steps_appendFront)

    then have C'_fails: "\<And>s. C' ~~ (s, AInvcheck False) \<leadsto> C'"
      by (auto simp add: failPos_fail step_simps)

    text \<open>Now remove all other invariant checks\<close>
    define tr'' where "tr'' = filter (\<lambda>a. \<not>is_AInvcheck (get_action a)) tr'"

    from tr'_steps
    have tr''_steps:  "initialState program ~~ tr'' \<leadsto>* C'"
      using remove_invchecks tr''_def by blast

    have no_crash'': "\<And>s. (s, ACrash) \<notin> set tr''"
      using noFail by (auto simp add: tr'_def tr''_def dest: in_set_takeD)
    have no_invcheck'': "\<And>s a. (s, a) \<in> set tr'' \<Longrightarrow> \<not> is_AInvcheck a"
      by (auto simp add: tr''_def)

    from tr''_steps no_crash'' no_invcheck''
    have "\<exists>tr'''. packed_trace tr''' \<and> (initialState program ~~ tr''' \<leadsto>* C') \<and> (set tr''' = set tr'')"
      by (rule pack_trace)

    from this
    obtain tr'''
      where tr'''1: "packed_trace tr'''"
        and tr'''2: "initialState program ~~ tr''' \<leadsto>* C'"
        and tr'''3: "set tr''' = set tr''"
      by blast

    define tr4 where "tr4 = tr''' @ [(get_invoc (last tr'''), AInvcheck False)]"

    from \<open>packed_trace tr'''\<close>
    have "packed_trace tr4"
      by (auto simp add: packed_trace_def tr4_def nth_append,
          metis One_nat_def gr_implies_not_zero last_conv_nth length_0_conv less_SucE)

    moreover have "initialState program ~~ tr4 \<leadsto>* C'"
      using C'_fails steps_append2 steps_single tr'''2 tr4_def by blast
    moreover have "\<forall>s. (s, ACrash) \<notin> set tr4"
      by (simp add: no_crash'' tr'''3 tr4_def)
    moreover have "\<not> traceCorrect tr4"
      by (simp add: actionCorrect_def tr4_def traceCorrect_def)

    ultimately show ?thesis by blast
  next
    case False
    hence "(i, AInvcheck False) \<notin> set tr" for i
      by (meson in_set_conv_nth)
    hence assertionError: "\<exists>i. (i, ALocal False) \<in> set tr"
      using notCorrect by (auto simp add: traceCorrect_def actionCorrect_def)

    text \<open>Remove all invariant checks\<close>
    define tr' where "tr' = filter (\<lambda>a. \<not>is_AInvcheck (get_action a)) tr"

    from steps
    have tr'_steps:  "initialState program ~~ tr' \<leadsto>* C"
      using remove_invchecks tr'_def by blast

    have noFail': "\<And>s. (s, ACrash) \<notin> set tr'"
      by (simp add: noFail tr'_def)

    have "\<exists>tr''. packed_trace tr''
    \<and> (initialState program ~~ tr'' \<leadsto>* C)
    \<and> (set tr'' = set tr')"
    proof (rule pack_trace[OF tr'_steps noFail'])
      show "\<And>s a. (s, a) \<in> set tr' \<Longrightarrow> \<not> is_AInvcheck a"
        by (simp add: tr'_def)
    qed

    from this obtain tr''
      where "packed_trace tr'' "
        and "initialState program ~~ tr'' \<leadsto>* C"
        and "set tr'' = set tr'"
      by blast

    show ?thesis
    proof (intro exI[where x=tr''] exI[where x=C] conjI)
      show " packed_trace tr''"
        by (simp add: \<open>packed_trace tr''\<close>)

      show " initialState program ~~ tr'' \<leadsto>* C"
        by (simp add: \<open>initialState program ~~ tr'' \<leadsto>* C\<close>)

      show " \<forall>s. (s, ACrash) \<notin> set tr''"
        by (simp add: \<open>set tr'' = set tr'\<close> noFail')

      from assertionError
      show " \<not> traceCorrect tr''"
        using  `set tr'' = set tr'` is_AInvcheck_def
        by (auto simp add: tr'_def traceCorrect_def actionCorrect_def)
    qed
  qed
qed

end