(*  Title:       Exploit Logic
    Authors:     Freek Verbeek, Nico Naus, Marc Schoolderman
    Year:        2021
    Maintainer:  Freek Verbeek (freek@vt.edu)
*)

theory ExploitLogic
  imports Main "HOL-Library.Word"
begin

(*
  TYPES: Variables, Meta-Variables, Operations, Regions in memory, Expressions, Predicates

  An expression of type E is deterministic. It may contain meta-variables, which should be closed
  by an existential quantifier.

  For example, the predicate:

    Exists ID\<^sub>0 (MetaVar ID\<^sub>0 \<le>\<^sub>s 100) (MetaVar ID\<^sub>0 + MetaVar ID\<^sub>0 ==\<^sub>s Num 0)

  can be read as:

    \<exists> v\<^sub>0 \<le> 100 \<cdot> v\<^sub>0 + v\<^sub>0 == 0

  An expression of type E' can be non-deterministic. For example, the expression:

    NDExpr ID\<^sub>0 (MetaVar ID\<^sub>0 \<le>\<^sub>s 100)

  can be read as:

    { v\<^sub>0 .  v\<^sub>0 \<le> 100 }

*)
type_synonym V  = string
type_synonym \<mu>V = int

datatype Op = Plus | Mult | Eq | Le | And | Or
datatype R =  Region E nat ("\<lbrakk>_,_\<rbrakk>")
     and E =
    Num "64 word"   \<comment> \<open>Immediate number\<close>
  | Var V           \<comment> \<open>Normal variable\<close>
  | MetaVar \<mu>V      \<comment> \<open>Meta variable\<close>
  | Deref R         \<comment> \<open>Read from region\<close>
  | SP_AL R R E E   \<comment> \<open>Case split for separation and aliasing\<close>
  | App E Op E      \<comment> \<open>Application of the pure operator op to LHS and RHS\<close>

datatype E' =
    DExpr E     \<comment> \<open>deterministic\<close>
  | NDExpr \<mu>V E \<comment> \<open>non-deterministic\<close>

datatype P = Exists \<mu>V E P | Expr E

(*
  TYPES: Statements, Blocks, Programs
*)
datatype Statement =
    Assign V E' (infixl "::=" 40)
  | Store R V

datatype Block =
    Seq Statement Block (infixl ";" 30)
  | Jump E E E
  | Exit

locale program =
  fixes entry  :: "64 word"           \<comment> \<open>Entry address\<close>
    and blocks :: "64 word \<Rightarrow> Block"  \<comment> \<open>Blocks per address\<close>

(*
  Some notation for symbolic operators
*)
abbreviation plus_s (infixl "+\<^sub>s" 65)
  where "e0 +\<^sub>s e1 \<equiv> App e0 Plus e1"
abbreviation mult_s (infixl "*\<^sub>s" 70)
  where "e0 *\<^sub>s e1 \<equiv> App e0 Mult e1"
abbreviation equal_s (infixl "==\<^sub>s" 49)
  where "e0 ==\<^sub>s e1 \<equiv> App e0 Eq e1"
abbreviation less_equal_s (infixl "\<le>\<^sub>s" 49)
  where "e0 \<le>\<^sub>s e1 \<equiv> App e0 Le e1"
abbreviation and_s  (infixr "\<and>\<^sub>s" 35)
  where "e0 \<and>\<^sub>s e1 \<equiv> App e0 And e1"
abbreviation or_s  (infixr "\<or>\<^sub>s" 35)
  where "e0 \<or>\<^sub>s e1 \<equiv> App e0 Or e1"
abbreviation not_s :: "E \<Rightarrow> E"  ("\<not>\<^sub>s _" [40] 40)
  where "\<not>\<^sub>s e \<equiv> e ==\<^sub>s Num 0"

(*
  As state, we simply assign words to variable names.
  Moreover, there is some polymorhpic type 'M representing memory.
*)
record 'M state =
  mem  :: 'M
  vars :: "V \<Rightarrow> 64 word"

locale memory = program +
  fixes write_region :: "64 word \<times> nat \<Rightarrow> 64 word \<Rightarrow> 'M state \<Rightarrow> 'M state"
    and read_region  :: "64 word \<times> nat \<Rightarrow> 'M state \<Rightarrow> 64 word"
    and separate     :: "64 word \<times> nat \<Rightarrow> 64 word \<times> nat \<Rightarrow> bool" (infixl "\<bowtie>" 55)
    and aliasing     :: "64 word \<times> nat \<Rightarrow> 64 word \<times> nat \<Rightarrow> bool" (infixl "\<simeq>" 55)
  assumes read_write_SP:                 "r' \<bowtie> r \<Longrightarrow> read_region r (write_region r' v \<sigma>) = read_region r \<sigma>"
      and read_write_AL:                 "read_region r (write_region r v \<sigma>) = v"
      and regs_after_write_region[simp]: "vars (write_region r v \<sigma>) = vars \<sigma>"
      and read_region_reg_update[simp]:  "read_region r (\<sigma>\<lparr>vars := x\<rparr>) = read_region r \<sigma>"
      and separate_irreflexive[simp]:    "\<not> separate r r"
      and separate_symmetric[symmetric]: "r \<bowtie> r' = r' \<bowtie> r"
      and separate_or_aliasing:          "r \<bowtie> r' \<or> r \<simeq> r'"
      and aliasing_def:                  "r \<simeq> r' \<equiv> r = r'"
      and finite_states:                 "finite (UNIV :: 'M state set)"
begin

(* Evaluation *)
abbreviation "bool2expr f e0 e1 \<equiv> if f e0 e1 then 1 else 0"

primrec eval_Op
  where
    "eval_Op Plus = (+)"
  | "eval_Op Mult = (*)"
  | "eval_Op Eq   = bool2expr (=)"
  | "eval_Op Le   = bool2expr (\<le>)"
  | "eval_Op And  = bool2expr (\<lambda> e0 e1 . e0 \<noteq> 0 \<and> e1 \<noteq> 0)"
  | "eval_Op Or   = bool2expr (\<lambda> e0 e1 . e0 \<noteq> 0 \<or> e1 \<noteq> 0)"

(* to evaluate an expression and a predicate, a valuation \<phi> is needed, i.e., an assignment of values to metavariables *)
fun eval_E :: "'M state \<Rightarrow> (\<mu>V \<Rightarrow> 64 word) \<Rightarrow> E \<Rightarrow> 64 word"
  where
    "eval_E s \<phi> (Num n)          = n"
  | "eval_E s \<phi> (Var v)          = vars s v"
  | "eval_E s \<phi> (MetaVar v)      = \<phi> v"
  | "eval_E s \<phi> (Deref \<lbrakk>a,si\<rbrakk>)    = read_region (eval_E s \<phi> a,si) s"
  | "eval_E s \<phi> (SP_AL \<lbrakk>a0,s0\<rbrakk> \<lbrakk>a1,s1\<rbrakk> e0 e1) =
      (if  (eval_E s \<phi> a0,s0) \<bowtie> (eval_E s \<phi> a1,s1) then eval_E s \<phi> e0 else eval_E s \<phi> e1)"
  | "eval_E s \<phi> (App e0 op e1)  =  eval_Op op (eval_E s \<phi> e0) (eval_E s \<phi> e1)"

primrec eval_E' :: "'M state \<Rightarrow> (\<mu>V \<Rightarrow> 64 word) \<Rightarrow> E' \<Rightarrow> 64 word set"
  where "eval_E' s \<phi> (DExpr e) = {eval_E s \<phi> e}"
  | "eval_E' s \<phi> (NDExpr \<mu>v e) = { i . eval_E s (\<phi>(\<mu>v := i)) e \<noteq> 0 }"

fun eval_P
  where
    "eval_P s \<phi> (Expr e) m = (eval_E s \<phi> e = m)"
  | "eval_P s \<phi> (Exists \<mu>v e P) m = (\<exists> i . eval_E s (\<phi>(\<mu>v := i)) e \<noteq> 0 \<and> eval_P s (\<phi>(\<mu>v := i)) P m)"

(*
  A predicate holds if it holds for some initial valuation
*)
definition holds_P :: "'M state \<Rightarrow> P \<Rightarrow> bool"
  where "holds_P s P \<equiv> \<exists> \<phi> i . eval_P s \<phi> P i \<and> i \<noteq> 0"

(* Semantics: the step function

  Loop B C:
    goes from state s to s' if there exists some path [s, ...s\<^sub>n, s'] where B holds for all states other than s'
    n may be zero, i.e., it may be that s == s'
  While B C:
    goes from state s to s' if Loop B C goes from s to s' and B does not hold in state s'.

  The reason for the split between Loop and While is because it makes proving easier.
*)
inductive step\<^sub>S :: "Statement \<Rightarrow> 'M state \<Rightarrow> 'M state \<Rightarrow> bool"
  where
    "m \<in> eval_E' s \<phi> e' \<Longrightarrow> s' = s\<lparr>vars := (vars s)(v := m)\<rparr> \<Longrightarrow> step\<^sub>S (v ::= e') s s'"
  | "eval_E s \<phi> a = m \<Longrightarrow> eval_E s \<phi> (Var v) = m' \<Longrightarrow> s' = write_region (m,si) m' s \<Longrightarrow> step\<^sub>S (Store \<lbrakk>a,si\<rbrakk> v) s s'"

inductive step\<^sub>B :: "Block \<Rightarrow> 'M state \<Rightarrow> 'M state \<Rightarrow> bool"
  where
    "step\<^sub>S S s s' \<Longrightarrow> step\<^sub>B B s' s'' \<Longrightarrow>  step\<^sub>B (S;B) s s''"
  | "holds_P s (Expr e) \<Longrightarrow> m = eval_E s \<phi> a\<^sub>0 \<Longrightarrow> step\<^sub>B (blocks m) s s' \<Longrightarrow> step\<^sub>B (Jump e a\<^sub>0 a\<^sub>1) s s'"
  | "holds_P s (Expr (\<not>\<^sub>s e)) \<Longrightarrow> m = eval_E s \<phi> a\<^sub>1 \<Longrightarrow>  step\<^sub>B (blocks m) s s' \<Longrightarrow> step\<^sub>B (Jump e a\<^sub>0 a\<^sub>1) s s'"
  | "s = s' \<Longrightarrow> step\<^sub>B Exit s s'"

definition step\<^sub>P :: "64 word \<Rightarrow> 'M state \<Rightarrow> 'M state \<Rightarrow> bool"
  where "step\<^sub>P addr \<equiv> step\<^sub>B (blocks addr)"

(*
   The definition of an exploit-triple:
    If P holds, then after execution of code C, postcondition Q may hold.
 *)
definition exploit_triple :: "P \<Rightarrow> Block \<Rightarrow> P \<Rightarrow> bool" ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>")
  where "\<lbrace>P\<rbrace> b \<lbrace>Q\<rbrace> \<equiv> \<forall> s . holds_P s P \<longrightarrow> (\<exists> s' . step\<^sub>B b s s' \<and> holds_P s' Q)"

definition exploit_tripleS :: "P \<Rightarrow> Statement \<Rightarrow> P \<Rightarrow> bool" ("\<lbrace>_\<rbrace>\<^sub>S _ \<lbrace>_\<rbrace>")
  where "\<lbrace>P\<rbrace>\<^sub>S S \<lbrace>Q\<rbrace> \<equiv> \<forall> s . holds_P s P \<longrightarrow> (\<exists> s' . step\<^sub>S S s s' \<and> holds_P s' Q)"

(*
  Substitution: replacing a variable with an expression, i.e:

    subst_E v e' e

  is equal to:

    e[v := e']
*)
fun subst_E :: "V \<Rightarrow> E \<Rightarrow> E \<Rightarrow> E"
  where
    "subst_E v e' (Num n)                    = Num n"
  | "subst_E v e' (Var v')                   = (if v = v' then e' else Var v')"
  | "subst_E v e' (MetaVar v')               = MetaVar v'"
  | "subst_E v e' (Deref \<lbrakk>a,s\<rbrakk>)               = Deref \<lbrakk>subst_E v e' a,s\<rbrakk>"
  | "subst_E v e' (SP_AL \<lbrakk>a,s\<rbrakk> \<lbrakk>a',s'\<rbrakk> e0 e1) = SP_AL \<lbrakk>subst_E v e' a,s\<rbrakk> \<lbrakk>subst_E v e' a',s'\<rbrakk> (subst_E v e' e0) (subst_E v e' e1)"
  | "subst_E v e' (App e0 f e1)              = App (subst_E v e' e0) f (subst_E v e' e1)"

primrec subst_P :: "V \<Rightarrow> E \<Rightarrow> P \<Rightarrow> P"
  where "subst_P v e' (Expr e'') = Expr (subst_E v e' e'')"
  | "subst_P v e' (Exists v'' e'' P) = Exists v'' (subst_E v e' e'') (subst_P v e' P)"

(*
  Substitution: replacing a meta variable with another meta-variable:

    subst_\<mu>v \<mu>v \<mu>v' e

  is equal to:

    e[\<mu>v := \<mu>v']
*)
fun subst_\<mu>v :: "\<mu>V \<Rightarrow> \<mu>V \<Rightarrow> E \<Rightarrow> E"
  where
    "subst_\<mu>v \<mu>v \<mu>v' (Num n)                    = Num n"
  | "subst_\<mu>v \<mu>v \<mu>v' (Var v)                    = Var v"
  | "subst_\<mu>v \<mu>v \<mu>v' (MetaVar \<mu>v'')             = (if \<mu>v'' = \<mu>v then MetaVar \<mu>v' else MetaVar \<mu>v'')"
  | "subst_\<mu>v \<mu>v \<mu>v' (Deref \<lbrakk>a,s\<rbrakk>)               = Deref \<lbrakk>subst_\<mu>v \<mu>v \<mu>v' a,s\<rbrakk>"
  | "subst_\<mu>v \<mu>v \<mu>v' (SP_AL \<lbrakk>a,s\<rbrakk> \<lbrakk>a',s'\<rbrakk> e0 e1) = SP_AL \<lbrakk>subst_\<mu>v \<mu>v \<mu>v' a,s\<rbrakk> \<lbrakk>subst_\<mu>v \<mu>v \<mu>v' a',s'\<rbrakk> (subst_\<mu>v \<mu>v \<mu>v' e0) (subst_\<mu>v \<mu>v \<mu>v' e1)"
  | "subst_\<mu>v \<mu>v \<mu>v' (App e0 f e1)              = App (subst_\<mu>v \<mu>v \<mu>v' e0) f (subst_\<mu>v \<mu>v \<mu>v' e1)"

(*
  The set of metavariables from the expression/predicate
*)
fun \<mu>vars :: "E \<Rightarrow> \<mu>V list"
  where
    "\<mu>vars (Num n) = []"
  | "\<mu>vars (Var v) = []"
  | "\<mu>vars (MetaVar v) = [v]"
  | "\<mu>vars (Deref \<lbrakk>a,s\<rbrakk>) = \<mu>vars a"
  | "\<mu>vars (SP_AL \<lbrakk>a,s\<rbrakk> \<lbrakk>a',s'\<rbrakk>  e0 e1) = \<mu>vars a @ \<mu>vars a' @ \<mu>vars e0 @ \<mu>vars e1"
  | "\<mu>vars (App e0 op e1) = \<mu>vars e0 @ \<mu>vars e1"

primrec \<mu>vars_P
  where "\<mu>vars_P (Expr e) = \<mu>vars e"
  | "\<mu>vars_P (Exists \<mu>v e P) = [\<mu>v] @ \<mu>vars e @ \<mu>vars_P P"

(*
  Conjunction of a predicate and an expression
*)
primrec and_P :: "P \<Rightarrow> E \<Rightarrow> P"  (infixr "\<and>\<^sub>P" 35)
  where
    "(Expr e \<and>\<^sub>P e0) = Expr (e \<and>\<^sub>s e0)"
  | "(Exists v e P \<and>\<^sub>P e0) = Exists v e (P \<and>\<^sub>P e0)"

(*
  Implication for predicates
*)

definition implies_P :: "[P,P] \<Rightarrow> bool"  (infixr "\<longrightarrow>\<^sub>P" 25)
  where "P \<longrightarrow>\<^sub>P Q \<equiv> \<forall> s . holds_P s P \<longrightarrow> holds_P s Q"

(* Predicate transformation *)

(* First, predicate transformation for dealing with writing to memory (store) *)
fun \<tau>_store_E   :: "Statement \<Rightarrow> E \<Rightarrow> E"
and \<tau>_store_R :: "Statement \<Rightarrow> R \<Rightarrow> E"
  where
    "\<tau>_store_E c (Deref \<lbrakk>a,s\<rbrakk>)               = \<tau>_store_R c \<lbrakk>a,s\<rbrakk> "
  | "\<tau>_store_E c (SP_AL \<lbrakk>a,s\<rbrakk> \<lbrakk>a',s'\<rbrakk> e0 e1)  = (SP_AL \<lbrakk>\<tau>_store_E c a,s\<rbrakk> \<lbrakk>\<tau>_store_E c a',s'\<rbrakk>) (\<tau>_store_E c e0) (\<tau>_store_E c e1)"
  | "\<tau>_store_E c (App e0 op e1)              = App (\<tau>_store_E c e0) op (\<tau>_store_E c e1)"
  | "\<tau>_store_E c (Num n)                     = Num n"
  | "\<tau>_store_E c (Var v)                     = Var v"
  | "\<tau>_store_E c (MetaVar v)                 = MetaVar v"
  | "\<tau>_store_R   (Store \<lbrakk>a',s'\<rbrakk> v) \<lbrakk>a,s\<rbrakk>      = (let a_\<tau> = \<tau>_store_E (Store \<lbrakk>a',s'\<rbrakk> v) a in
                                                  SP_AL \<lbrakk>a_\<tau>,s\<rbrakk> \<lbrakk>a',s'\<rbrakk> (Deref \<lbrakk>a_\<tau>,s\<rbrakk>) (Var v))"

primrec \<tau>_store_P :: "Statement \<Rightarrow> P \<Rightarrow> P"
  where
    "\<tau>_store_P c (Expr e)       = Expr (\<tau>_store_E c e)"
  | "\<tau>_store_P c (Exists v e P) = Exists v (\<tau>_store_E c e) (\<tau>_store_P c P)"

definition "fresh_\<mu>var P \<equiv> foldr max (\<mu>vars_P P) 0 + 1"

(* The complete predicate transformation function *)
inductive \<tau>\<^sub>S :: "Statement \<Rightarrow> P \<Rightarrow> P \<Rightarrow> bool"
  where
  \<tau>_assign_D:  "\<mu>vars e = [] \<Longrightarrow> P = subst_P v e Q \<Longrightarrow> \<tau>\<^sub>S (v ::= DExpr e) P Q"
| \<tau>_assign_ND: "\<mu>v\<^sub>f = fresh_\<mu>var (Q \<and>\<^sub>P e) \<Longrightarrow> P = Exists \<mu>v\<^sub>f (subst_\<mu>v \<mu>v \<mu>v\<^sub>f e) (subst_P v (MetaVar \<mu>v\<^sub>f) Q) \<Longrightarrow> \<tau>\<^sub>S (v ::= NDExpr \<mu>v e) P Q"
| \<tau>_store:     "case r of \<lbrakk>a,si\<rbrakk> \<Rightarrow> \<mu>vars a = [] \<Longrightarrow> P = \<tau>_store_P (Store r v) Q \<Longrightarrow> \<tau>\<^sub>S (Store r v) P Q"

definition possible :: "P \<Rightarrow> bool"
  where "possible P \<equiv> \<exists> s . holds_P s P"

definition jump_target
  where "jump_target e a\<^sub>0 a\<^sub>1 P m \<equiv> (P \<and>\<^sub>P  ((e \<and>\<^sub>s Num m ==\<^sub>s a\<^sub>0) \<or>\<^sub>s ((\<not>\<^sub>s e) \<and>\<^sub>s Num m ==\<^sub>s a\<^sub>1)))"

inductive \<tau>\<^sub>B :: "Block \<Rightarrow> P \<Rightarrow> P \<Rightarrow> bool"
  where
  \<tau>_seq:      "\<tau>\<^sub>B B Q R \<Longrightarrow> \<tau>\<^sub>S S P Q \<Longrightarrow> \<tau>\<^sub>B (S;B) P R"
| \<tau>_jump:    "\<mu>vars e = [] \<Longrightarrow> \<mu>vars a\<^sub>0 = [] \<Longrightarrow> \<mu>vars a\<^sub>1 = [] \<Longrightarrow>
              \<forall> m . possible (jump_target e a\<^sub>0 a\<^sub>1 P m) \<longrightarrow> (\<exists> P' . (P \<longrightarrow>\<^sub>P P') \<and> \<tau>\<^sub>B (blocks m) P' Q) \<Longrightarrow> \<tau>\<^sub>B (Jump e a\<^sub>0 a\<^sub>1) P Q"
| \<tau>_exit:     "P = Q \<Longrightarrow> \<tau>\<^sub>B Exit P Q"

definition \<tau>\<^sub>P :: "P \<Rightarrow> P \<Rightarrow> bool"
  where "\<tau>\<^sub>P \<equiv> \<tau>\<^sub>B (blocks entry)"

(*
Some logic lemma's over holds_P:
*)

lemma unsat_preserves:
  assumes "\<lbrace>P\<rbrace> b \<lbrace>Q\<rbrace>"
  shows "\<forall> s' . \<not> (holds_P s' Q) \<Longrightarrow> \<not> (holds_P s P) "
  using assms
  using exploit_triple_def by blast

lemma valuation_independent:
  shows "\<mu>vars e = [] \<Longrightarrow> eval_E s \<phi> e = eval_E s \<phi>' e"
  by (induct s \<phi> e rule: eval_E.induct ,auto)

lemma eval_P_conj1:
  shows "i \<noteq> 0 \<Longrightarrow> eval_P s \<phi> (P \<and>\<^sub>P B) i \<Longrightarrow> \<exists>i. eval_P s \<phi> P i \<and> i \<noteq> 0"
  apply (induct s \<phi> P i rule: eval_P.induct)
  apply (auto simp add: split: if_split_asm)
  by blast

lemma holds_P_conj1:
  shows "holds_P s (P\<^sub>1 \<and>\<^sub>P B) \<Longrightarrow> holds_P s P\<^sub>1"
  apply (auto simp add: holds_P_def)
  using eval_P_conj1 by blast

lemma eval_P_conj2:
  shows "i \<noteq> 0 \<Longrightarrow> \<mu>vars B = [] \<Longrightarrow> eval_P s \<phi> (P \<and>\<^sub>P B) i \<Longrightarrow> \<exists>i. i \<noteq> 0 \<and> eval_E s \<phi> B = i"
  apply (induct s \<phi> P i rule: eval_P.induct)
  apply (auto simp add: split: if_split_asm)
  by (metis valuation_independent)

lemma holds_P_conj2:
  shows "holds_P s' (P\<^sub>1 \<and>\<^sub>P B) \<Longrightarrow> \<mu>vars B = [] \<Longrightarrow> holds_P s' (Expr B)"
  apply (auto simp add: holds_P_def )
  using eval_P_conj2 by blast

lemma holds_P_conj_Expr:
  assumes "\<mu>vars e\<^sub>0 = []"
      and "\<mu>vars e\<^sub>1 = []"
    shows "holds_P s (Expr (e\<^sub>0 \<and>\<^sub>s e\<^sub>1)) \<longleftrightarrow> (holds_P s (Expr e\<^sub>0) \<and> holds_P s (Expr e\<^sub>1))"
  using assms
  apply (auto simp add: holds_P_def )
  by (metis valuation_independent)

lemma eval_P_conjI:
assumes "eval_P s \<phi> P i' \<and> i' \<noteq> 0"
    and "\<mu>vars e = []"
    and "eval_E s \<phi>' e \<noteq> 0"
  shows "eval_P s \<phi> (P \<and>\<^sub>P e) 1"
  using assms
  apply (induct P arbitrary: \<phi>,auto)
  by (metis valuation_independent)

lemma holds_P_conjI:
  assumes "\<mu>vars e = []"
    shows "holds_P s (P \<and>\<^sub>P e) \<longleftrightarrow> (holds_P s P \<and> holds_P s (Expr e))"
  using assms
  apply (auto simp add: holds_P_def )
  using holds_P_conj1 holds_P_def apply blast
  using eval_P_conj2 apply blast
  by (metis eval_P_conjI zero_neq_one)

lemma holds_P_disjE:
  assumes "holds_P s (Expr (e\<^sub>0 \<or>\<^sub>s e\<^sub>1))"
    shows "holds_P s (Expr e\<^sub>0) \<or> holds_P s (Expr e\<^sub>1)"
  using assms
  apply (auto simp add: holds_P_def)
  by meson

lemma holds_P_disjI1:
  assumes "holds_P s (Expr e\<^sub>0)"
    shows "holds_P s (Expr (e\<^sub>0 \<or>\<^sub>s e\<^sub>1))"
  using assms
  by (auto simp add: holds_P_def)

lemma holds_P_disjI2:
  assumes "holds_P s (Expr e\<^sub>1)"
    shows "holds_P s (Expr (e\<^sub>0 \<or>\<^sub>s e\<^sub>1))"
  using assms
  by (auto simp add: holds_P_def)

lemma holds_P_not_Expr:
  assumes "\<mu>vars e = []"
    shows "holds_P s (Expr (\<not>\<^sub>s e)) \<longleftrightarrow> \<not>(holds_P s (Expr e))"
  using assms
  apply (auto simp add: holds_P_def)
  by (metis valuation_independent)

(*
  Some convenient rewrite lemma's
*)
lemma step\<^sub>S_DExpr:
assumes "\<mu>vars e = []"
  shows "step\<^sub>S (v ::= DExpr e) s s' \<longleftrightarrow> s' = s\<lparr>vars := (vars s)(v := eval_E s undefined e)\<rparr>"
  using assms step\<^sub>S.intros(1)[of "eval_E s undefined e" s undefined "DExpr e" s' v] valuation_independent
  apply auto
  apply (cases "v ::= DExpr e" s s' rule: step\<^sub>S.cases)
  apply auto
  by (metis)

lemma step\<^sub>S_NDExpr:
  shows "step\<^sub>S (v ::= NDExpr \<mu>v e) s s' \<longleftrightarrow> (\<exists> m \<phi> . m \<in> eval_E' s \<phi> (NDExpr \<mu>v e) \<and> s' = s\<lparr>vars := (vars s)(v := m)\<rparr>)"
  using step\<^sub>S.intros(1)[of _ s _ "NDExpr \<mu>v e" s' v]
  apply auto
  apply (cases "v ::= NDExpr \<mu>v e" s s' rule: step\<^sub>S.cases)
  by auto

lemma step\<^sub>S_Store:
  shows "step\<^sub>S (Store \<lbrakk>a,si\<rbrakk> v) s s' \<longleftrightarrow> (\<exists> \<phi> . s' = write_region (eval_E s \<phi> a,si) (eval_E s \<phi> (Var v)) s)"
  using step\<^sub>S.intros(2)[of s _ a _ v _ s' si]
  apply auto
  apply (cases "Store \<lbrakk>a,si\<rbrakk> v" s s' rule: step\<^sub>S.cases)
  by auto

lemma step\<^sub>B_jump:
  assumes "\<mu>vars e = []"
  and "\<mu>vars a\<^sub>0 = []"
  and "\<mu>vars a\<^sub>1 = []"
  shows "step\<^sub>B (Jump e a\<^sub>0 a\<^sub>1) s s' \<longleftrightarrow> step\<^sub>B (blocks (eval_E s undefined (if holds_P s (Expr e) then a\<^sub>0 else a\<^sub>1))) s s'"
  using assms step\<^sub>B.intros(2)
        step\<^sub>B.intros(3) holds_P_not_Expr
  apply auto
  by (cases "Jump e a\<^sub>0 a\<^sub>1" s s' rule: step\<^sub>B.cases,auto,metis valuation_independent)+

lemma step\<^sub>B_exit:
  shows "step\<^sub>B Exit s s' \<longleftrightarrow> s = s'"
  using step\<^sub>B.intros(4)
  apply auto
  by (cases "Exit" s s' rule: step\<^sub>B.cases)

(*
   We prove soundness of tau.
  First, substitution lemma's:
*)

(* For determinstic expressions *)
lemma eval_E_subst_E:
  shows "eval_E s \<phi> (subst_E v e e') = eval_E (s\<lparr>vars := (vars s)(v := eval_E s \<phi> e)\<rparr>) \<phi> e'"
  by (induct v e e' rule: subst_E.induct,auto)

lemma eval_P_subst_P:
assumes "\<mu>vars e = []"
  shows "eval_P s \<phi> (subst_P v e c) i \<longleftrightarrow> eval_P (s\<lparr>vars := (vars s)(v := eval_E s \<phi> e)\<rparr>) \<phi> c i"
  using assms
  apply (induct "s\<lparr>vars := (vars s)(v := eval_E s \<phi> e)\<rparr>" \<phi> c i rule: eval_P.induct,auto simp add: eval_E_subst_E fun_upd_twist valuation_independent)
  by (metis (full_types) valuation_independent)+

lemma holds_P_subst_P:
assumes "\<mu>vars e = []"
    shows "holds_P s (subst_P v e Q) \<longleftrightarrow> (\<exists> \<phi> . holds_P (s\<lparr>vars := (vars s)(v := eval_E s \<phi> e)\<rparr>) Q)"
  using assms
  apply (auto simp add: holds_P_def eval_P_subst_P)
  by (metis valuation_independent)

(* For non-deterministic expressions *)
lemma eval_E_subst_E_\<mu>var:
  assumes "\<mu>v \<notin> set (\<mu>vars e)"
  shows "eval_E s (\<phi>(\<mu>v := m)) (subst_E v (MetaVar \<mu>v) e) = eval_E (s\<lparr>vars := (vars s)(v := m)\<rparr>) \<phi> e"
  using assms
  by (induct v "MetaVar \<mu>v" e rule: subst_E.induct,auto)

lemma eval_P_subst_P_\<mu>var:
assumes "\<mu>v  \<notin> set (\<mu>vars_P c)"
shows "eval_P s (\<phi>(\<mu>v := m)) (subst_P v (MetaVar \<mu>v) c) i \<longleftrightarrow> eval_P (s\<lparr>vars := (vars s)(v := m)\<rparr>) \<phi> c i"
  using assms
  by (induct "s\<lparr>vars := (vars s)(v := m)\<rparr>" \<phi> c i arbitrary: m rule: eval_P.induct,auto simp add: eval_E_subst_E_\<mu>var fun_upd_twist)

lemma holds_P_subst_P_\<mu>var:
assumes "\<mu>v \<notin> set (\<mu>vars_P Q)"
    and "holds_P s (Exists \<mu>v e (subst_P v (MetaVar \<mu>v) Q))"
  shows "\<exists> \<phi> m . eval_E s (\<phi>(\<mu>v := m)) e \<noteq> 0 \<and> holds_P (s\<lparr>vars := (vars s)(v := m)\<rparr>) Q"
  using assms
  by (auto simp add: holds_P_def eval_P_subst_P_\<mu>var)

lemma eval_E_subst_fresh_\<mu>var:
  assumes "\<mu>v\<^sub>f \<notin> set (\<mu>vars e)"
  shows "eval_E s (\<phi>(\<mu>v\<^sub>f := m)) (subst_\<mu>v \<mu>v \<mu>v\<^sub>f e) = eval_E s (\<phi>(\<mu>v := m)) e"
  using assms
  by (induct s "(\<phi>(\<mu>v := m))" e rule: eval_E.induct ,auto)

lemma foldr_max_is_max:
  fixes a :: int
  assumes "a \<in> set s"
  shows "foldr max s 0 \<ge> a"
  using assms
  by (induct s arbitrary: a,auto simp add: max.coboundedI2)

lemma fresh_\<mu>var_is_fresh:
  shows "fresh_\<mu>var P \<notin> set (\<mu>vars_P P)"
  using foldr_max_is_max[of "foldr max (\<mu>vars_P P) 0 + 1" "\<mu>vars_P P"]
  by (auto simp add: fresh_\<mu>var_def)

lemma \<mu>vars_and_P:
  shows "set (\<mu>vars_P (P \<and>\<^sub>P e)) = (set (\<mu>vars_P P) \<union> set (\<mu>vars e))"
  by (induct P,auto)

(* we prove soundness of the transformation for a Store *)
lemma \<tau>_store_E_sound_store:
  assumes "c = Store \<lbrakk>a,si\<rbrakk> v"
      and "s' = write_region (eval_E s \<phi> a, si) (vars s v) s"
  shows "eval_E s' \<phi> e          = eval_E s \<phi> (\<tau>_store_E c e)"
    and "eval_E s' \<phi> (Deref r') = eval_E s \<phi> (\<tau>_store_R c r')"
  using assms
  apply (induct c e and c r' rule:  \<tau>_store_E_\<tau>_store_R.induct)
  apply (auto simp add: Let_def read_write_SP separate_symmetric)
  using aliasing_def read_write_AL separate_or_aliasing by metis

lemma \<tau>_store_P_sound_store:
 assumes "\<mu>vars a = []"
  shows "eval_P (write_region (eval_E s \<phi> a, si) (vars s v) s) \<phi> Q i \<longleftrightarrow> eval_P s \<phi> (\<tau>_store_P (Store \<lbrakk>a,si\<rbrakk> v) Q) i"
  using assms
proof(induct Q arbitrary: \<phi>)
  case (Exists \<mu>v' e Q)
  thus ?case
    using Exists valuation_independent
    apply auto
    by (metis \<tau>_store_E_sound_store(1))+
next
  case (Expr x)
  then show ?case
    apply auto
    using \<tau>_store_E_sound_store(1)
    apply presburger
    by (meson \<tau>_store_E_sound_store(1))
qed

lemma not_in_butlast:
  shows "a \<in> set p \<Longrightarrow> a \<notin> set (butlast p) \<Longrightarrow> a = last p"
  by (induct p,auto)

theorem \<tau>\<^sub>S_sound:
  assumes "\<tau>\<^sub>S S P Q"
      and "holds_P s P"
  shows "\<exists> s' . step\<^sub>S S s s' \<and> holds_P s' Q"
  using assms
proof(cases)
  case (\<tau>_assign_D e v)
  {
    fix s
    assume "holds_P s P"
    hence "holds_P s (subst_P v e Q)"
      using \<tau>_assign_D
      by simp
    then obtain \<phi> where "holds_P (s\<lparr>vars := (vars s)(v := eval_E s \<phi> e)\<rparr>) Q"
      using holds_P_subst_P[of e s v Q] \<tau>_assign_D(2)
      by auto
    moreover
    hence "step\<^sub>S (v ::= DExpr e) s (s\<lparr>vars := (vars s)(v := eval_E s \<phi> e)\<rparr>)"
      using step\<^sub>S.intros(1)[of "eval_E s \<phi> e" s \<phi> "DExpr e" "s\<lparr>vars := (vars s)(v := eval_E s \<phi> e)\<rparr>" v]
      by auto
    ultimately
    have "\<exists> s' . step\<^sub>S (v ::= DExpr e) s s' \<and> holds_P s' Q"
      by auto
  }
  thus ?thesis
    using assms(2) \<tau>_assign_D
    by (auto)
next
  case (\<tau>_assign_ND \<mu>v\<^sub>f e \<mu>v v)
  {
    fix s
    assume "holds_P s P"
    hence "holds_P s (Exists \<mu>v\<^sub>f (subst_\<mu>v \<mu>v \<mu>v\<^sub>f e) (subst_P v (MetaVar \<mu>v\<^sub>f) Q))"
      using \<tau>_assign_ND
      by simp
    then obtain \<phi> m where "eval_E s (\<phi>(\<mu>v\<^sub>f := m)) (subst_\<mu>v \<mu>v \<mu>v\<^sub>f e) \<noteq> 0 \<and> holds_P (s\<lparr>vars := (vars s)(v := m)\<rparr>) Q"
      using holds_P_subst_P_\<mu>var[of \<mu>v\<^sub>f Q s "subst_\<mu>v \<mu>v \<mu>v\<^sub>f e" v] \<tau>_assign_ND(1,2) fresh_\<mu>var_is_fresh[of "Q \<and>\<^sub>P e"]
      by (auto simp add: \<mu>vars_and_P)
    hence "eval_E s (\<phi>(\<mu>v := m)) e \<noteq> 0 \<and> holds_P (s\<lparr>vars := (vars s)(v := m)\<rparr>) Q"
      using \<tau>_assign_ND fresh_\<mu>var_is_fresh[of "Q \<and>\<^sub>P e"]
      by (auto simp add: eval_E_subst_fresh_\<mu>var \<mu>vars_and_P)
    moreover
    hence "step\<^sub>S (v ::= NDExpr \<mu>v e) s (s\<lparr>vars := (vars s)(v := m)\<rparr>)"
      using step\<^sub>S.intros(1)[of m s \<phi> "NDExpr \<mu>v e" "s\<lparr>vars := (vars s)(v := m)\<rparr>" v]
      by auto
    ultimately
    have "\<exists> s' . step\<^sub>S (v ::= NDExpr \<mu>v e) s s' \<and> holds_P s' Q"
      by auto
  }
  thus ?thesis
    using assms(2) \<tau>_assign_ND
    by (auto)
next
  case (\<tau>_store r v)
  {
    fix s
    assume "holds_P s P"
    hence P: "holds_P s (\<tau>_store_P (Store r v) Q)"
      using \<tau>_store
      by simp
    obtain a si where r: "r = \<lbrakk>a,si\<rbrakk>"
      by (cases r,auto)
    obtain i \<phi> where i: "i \<noteq> 0 \<and> eval_P s \<phi> (\<tau>_store_P (Store r v) Q) i"
      using P
      by (auto simp add: holds_P_def)
    let ?s' = "write_region (eval_E s \<phi> a, si) (eval_E s \<phi> (Var v)) s"
    have "step\<^sub>S (Store r v) s ?s'"
      using step\<^sub>S.intros(2) r
      by auto
    moreover
    have "i \<noteq> 0 \<and> eval_P ?s' \<phi> Q i"
      using \<tau>_store_P_sound_store[of a s \<phi> si v Q i] P i r \<tau>_store
      by auto
    ultimately
    have "\<exists> s' . step\<^sub>S (Store r v) s s' \<and> holds_P s' Q"
      by (auto simp add: holds_P_def)
  }
  thus ?thesis
    using assms(2) \<tau>_store
    by (auto simp add: exploit_triple_def)
qed

theorem \<tau>\<^sub>B_sound:
assumes "\<tau>\<^sub>B B P Q"
  shows "\<lbrace>P\<rbrace> B \<lbrace>Q\<rbrace>"
  using assms
proof(induct B P Q rule: \<tau>\<^sub>B.induct)
  case (\<tau>_seq B Q R S P)
    {
      fix s
      assume "holds_P s P"
      then obtain s' where 1: "step\<^sub>S S s s' \<and> holds_P s' Q"
        using \<tau>\<^sub>S_sound[of S P Q s] \<tau>_seq(3)
        by auto
      then obtain s'' where "step\<^sub>B B s' s'' \<and> holds_P s'' R"
        using \<tau>_seq(2)
        by (auto simp add: exploit_triple_def)
      hence "\<exists> s'' . step\<^sub>B (S ; B) s s'' \<and> holds_P s'' R"
        using 1 step\<^sub>B.intros(1)[of _ _ s']
        by blast
    }
    thus ?case
      by (auto simp add: exploit_triple_def)
next
  case (\<tau>_jump e a\<^sub>0 a\<^sub>1 P Q)
    {
      fix s
      assume 3: "holds_P s P"
      consider "holds_P s (Expr e)" | "holds_P s (Expr (\<not>\<^sub>s e))"
        using holds_P_not_Expr \<tau>_jump(1)
        by auto
      hence "\<exists> s' . step\<^sub>B (Jump e a\<^sub>0 a\<^sub>1) s s' \<and> holds_P s' Q"
      proof(cases)
        case 1
        let ?m = "eval_E s undefined a\<^sub>0"
        have "possible (jump_target e a\<^sub>0 a\<^sub>1 P ?m)"
          using 1 3
          apply (auto simp add: possible_def jump_target_def holds_P_conjI \<tau>_jump)
          apply (rule exI[of _ s])
          apply (auto)
          apply (rule holds_P_disjI1)
          apply (auto simp add: holds_P_conj_Expr \<tau>_jump)
          by (auto simp add: holds_P_def)
        then obtain P' where P': "\<tau>\<^sub>B (blocks ?m) P' Q \<and> \<lbrace>P'\<rbrace> blocks ?m \<lbrace>Q\<rbrace> \<and> (P \<longrightarrow>\<^sub>P P')"
          using \<tau>_jump
          by auto
        then obtain s' where "step\<^sub>B (blocks ?m) s s' \<and> holds_P s' Q"
          using 3
          apply (auto simp add: exploit_triple_def holds_P_def implies_P_def split: if_split_asm)
          by blast
        thus ?thesis
          using 1 3 step\<^sub>B.intros(2)[of s e ?m undefined a\<^sub>0 s' a\<^sub>1]
          by auto
      next
        case 2
        let ?m = "eval_E s undefined a\<^sub>1"
        have "possible (jump_target e a\<^sub>0 a\<^sub>1 P ?m)"
          using 2 3
          apply (auto simp add: possible_def jump_target_def holds_P_conjI \<tau>_jump)
          apply (rule exI[of _ s])
          apply (auto)
          apply (rule holds_P_disjI2)
          apply (auto simp add: holds_P_conj_Expr \<tau>_jump)
          by (auto simp add: holds_P_def)
        then obtain P' where P': "\<tau>\<^sub>B (blocks ?m) P' Q \<and> \<lbrace>P'\<rbrace> blocks ?m \<lbrace>Q\<rbrace> \<and> (P \<longrightarrow>\<^sub>P P')"
          using \<tau>_jump
          by auto
        then obtain s' where "step\<^sub>B (blocks ?m) s s' \<and> holds_P s' Q"
          using 3
          apply (auto simp add: exploit_triple_def holds_P_def implies_P_def split: if_split_asm)
          by blast
        thus ?thesis
          using 2 3 step\<^sub>B.intros(3)[of s e ?m undefined a\<^sub>1 s' a\<^sub>0]
          by auto
      qed
    }
    thus ?case
      by (auto simp add: exploit_triple_def)
next
  case (\<tau>_exit P Q)
  thus ?case
    using step\<^sub>B.intros(4)
    by (auto simp add: exploit_triple_def)
qed

(*
  Completeness
*)

lemma DAssign_completeness:
  assumes "\<lbrace>P\<rbrace>\<^sub>S v ::= DExpr e \<lbrace>Q\<rbrace>"
     and "\<mu>vars e = []"
   shows "P \<longrightarrow>\<^sub>P subst_P v e Q"
  using assms
  apply (auto simp add: implies_P_def holds_P_subst_P exploit_tripleS_def)
  by (subst (asm) step\<^sub>S_DExpr,simp,auto)

lemma valuation_independent_one_\<mu>var:
  shows "set (\<mu>vars e) \<subseteq> {\<mu>v} \<Longrightarrow> eval_E s (\<phi>(\<mu>v := m)) e = eval_E s (\<phi>'(\<mu>v := m)) e"
  by (induct s "\<phi>(\<mu>v := m)" e rule: eval_E.induct ,auto)

lemma NDAssign_completeness:
  assumes "\<lbrace>P\<rbrace>\<^sub>S v ::= NDExpr \<mu>v e \<lbrace>Q\<rbrace>"
      and "\<mu>vars e = [\<mu>v]"
  shows "P \<longrightarrow>\<^sub>P (let \<mu>v\<^sub>f = fresh_\<mu>var (Q \<and>\<^sub>P e) in Exists \<mu>v\<^sub>f (subst_\<mu>v \<mu>v \<mu>v\<^sub>f e) (subst_P v (MetaVar \<mu>v\<^sub>f) Q))"
proof-
  {
    fix s
    assume "holds_P s P"
    then obtain m \<phi> s' where 0: "m \<in> eval_E' s \<phi> (NDExpr \<mu>v e) \<and> s' = s\<lparr>vars := (vars s)(v := m)\<rparr> \<and> holds_P s' Q"
      using assms
      by (auto simp add: exploit_tripleS_def step\<^sub>S_NDExpr)
    have 1: "fresh_\<mu>var (Q \<and>\<^sub>P e) \<notin> set (\<mu>vars e)"
      using \<mu>vars_and_P fresh_\<mu>var_is_fresh
      by auto
    have 2: "fresh_\<mu>var (Q \<and>\<^sub>P e) \<notin> set (\<mu>vars_P Q)"
      using \<mu>vars_and_P fresh_\<mu>var_is_fresh
      by auto
    have "holds_P s (let \<mu>v\<^sub>f = fresh_\<mu>var (Q \<and>\<^sub>P e) in Exists \<mu>v\<^sub>f (subst_\<mu>v \<mu>v \<mu>v\<^sub>f e) (subst_P v (MetaVar \<mu>v\<^sub>f) Q))"
      using 1 2 0 assms
      apply (auto simp add: holds_P_def Let_def eval_E_subst_fresh_\<mu>var eval_P_subst_P_\<mu>var)
      subgoal for \<phi>' i
        apply (rule exI[of _ \<phi>'])
        apply (rule exI[of _ i])
        apply simp
        apply (rule exI[of _ m])
        by (auto simp add: valuation_independent_one_\<mu>var[of e \<mu>v s \<phi> m \<phi>'])
      done
  }
  thus ?thesis
    by (auto simp add: implies_P_def)
qed

lemma Store_completeness:
assumes "\<lbrace>P\<rbrace>\<^sub>S Store \<lbrakk>a,si\<rbrakk> v \<lbrace>Q\<rbrace>"
    and "\<mu>vars a = []"
  shows "P \<longrightarrow>\<^sub>P \<tau>_store_P (Store \<lbrakk>a,si\<rbrakk> v) Q"
proof-
  {
    fix s
    assume "holds_P s P"
    then obtain \<phi> s' where s': "s' = write_region (eval_E s \<phi> a,si) (eval_E s \<phi> (Var v)) s \<and> holds_P s' Q"
      using assms
      by (auto simp add: exploit_tripleS_def step\<^sub>S_Store)
    then obtain \<phi>' i where "eval_P s' \<phi>' Q i \<and> i \<noteq> 0"
      by (auto simp add: holds_P_def)
    have "holds_P s (\<tau>_store_P (Store \<lbrakk>a,si\<rbrakk> v) Q)"
      using \<tau>_store_P_sound_store assms(2) s'
      apply (auto simp add: holds_P_def)
      by (metis valuation_independent)
  }
  thus ?thesis
    by (auto simp add: implies_P_def)
qed

(*
  Basic sanity conditions: no meta variables in the program other than in ND expressions.
  If indirections_allowed == False, then all jumps must be direct.
*)
fun sane_stmt
  where
  "sane_stmt (Assign v (DExpr e))     =  (\<mu>vars e = [])"
| "sane_stmt (Assign v (NDExpr \<mu>v e)) = (\<mu>vars e = [\<mu>v])"
| "sane_stmt (Store \<lbrakk>a,si\<rbrakk> v)         = (\<mu>vars a = [])"

definition direct_jump
  where "direct_jump e a\<^sub>0 a\<^sub>1 \<equiv> \<forall> m s P . possible (jump_target e a\<^sub>0 a\<^sub>1 P m) \<longrightarrow> eval_E s undefined (if holds_P s (Expr e) then a\<^sub>0 else a\<^sub>1) = m"

primrec sane_block
  where
  "sane_block indirections_allowed (S;B)         =  (sane_stmt S \<and> sane_block indirections_allowed B)"
| "sane_block indirections_allowed (Jump e a\<^sub>0 a\<^sub>1) = (\<mu>vars e = [] \<and> \<mu>vars a\<^sub>0 = [] \<and> \<mu>vars a\<^sub>1 = [] \<and> (indirections_allowed \<or> direct_jump e a\<^sub>0 a\<^sub>1))"
| "sane_block indirections_allowed (Exit)        = True"

lemma \<tau>\<^sub>S_completeness:
  assumes "\<lbrace>P\<rbrace>\<^sub>S S \<lbrace>Q\<rbrace>"
      and "sane_stmt S"
  shows "\<exists> P' . \<tau>\<^sub>S S P' Q \<and> (P \<longrightarrow>\<^sub>P P')"
proof(cases S)
  case (Assign v e')
  show ?thesis
  proof(cases e')
    case (DExpr e)
    thus ?thesis
      using Assign DAssign_completeness[of P v e Q] \<tau>_assign_D assms
      apply (auto)
      by blast
  next
    case (NDExpr \<mu>v e)
    thus ?thesis
      using Assign NDAssign_completeness[of P v \<mu>v e Q] assms \<tau>_assign_D
      apply auto
      by (meson \<tau>_assign_ND)
  qed
next
  case (Store r v)
  obtain a si where r: "r = \<lbrakk>a,si\<rbrakk>"
    by (cases r,auto)
  thus ?thesis
    using Store Store_completeness[of P a si v Q] assms
    apply auto
    using R.case \<tau>_store
    by force
qed

lemma \<tau>\<^sub>S_sound_and_complete:
assumes "sane_stmt S"
  shows "\<lbrace>P\<rbrace>\<^sub>S S \<lbrace>Q\<rbrace> \<longleftrightarrow> (\<exists> P' . \<tau>\<^sub>S S P' Q \<and> (P \<longrightarrow>\<^sub>P P'))"
  using assms \<tau>\<^sub>S_completeness \<tau>\<^sub>S_sound
  by (auto simp add: implies_P_def exploit_tripleS_def)

lemma set_of_states_describable:
  fixes S :: "'M state set"
assumes state_describable: "\<forall> s . \<exists> e . \<forall> s' . holds_P s' (Expr e) = (s = s')"
  shows "\<exists> P . \<forall> s. holds_P s P \<longleftrightarrow> s \<in> S"
proof-
  obtain L where L: "set L = S"
    using finite_list[of S] finite_states
    by (meson finite_subset top_greatest)
  have "\<exists> e . \<forall> s. holds_P s (Expr e) \<longleftrightarrow> s \<in> set L"
  proof(induct L)
    case Nil
    thus ?case
      apply (rule exI[of _ "(Num 42) ==\<^sub>s (Num 43)"])
      by (auto simp add: holds_P_def)
  next
    case (Cons s L)
    then obtain e where e: "\<forall>s. holds_P s (Expr e) = (s \<in> set L)"
      by auto
    obtain e' where e': "\<forall>s'. holds_P s' (Expr e') = (s = s')"
      using assms
      by auto
    show ?case
      apply (rule exI[of _ "e \<or>\<^sub>s e'"])
      using e e'
      apply auto
      apply (metis holds_P_disjE)
      using holds_P_disjI2 apply presburger
      using holds_P_disjI1 apply blast
      done
  qed
  then obtain e where e: "\<forall>s. holds_P s (Expr e) = (s \<in> set L)"
    by auto
  show ?thesis
    apply (rule exI[of _ "Expr e"])
    using e L
    by auto
qed

function exec_block :: "Block \<Rightarrow> P \<Rightarrow> bool"
  where "exec_block (S;B) P = (\<exists> Q . \<lbrace>P\<rbrace>\<^sub>S S \<lbrace>Q\<rbrace> \<and> exec_block B Q)"
  | "exec_block (Jump e a\<^sub>0 a\<^sub>1) P = (\<exists> m \<in> {m . possible (jump_target e a\<^sub>0 a\<^sub>1 P m)} . exec_block (blocks m) P)"
  | "exec_block (Exit) P = True"
  by (pat_completeness,auto)

lemma \<tau>\<^sub>B_complete:
assumes "exec_block_dom (B,P)"
    and "sane_block False B"
    and "\<forall> m . sane_block False (blocks m)"
    and state_describable: "\<forall> s . \<exists> e . \<forall> s' . holds_P s' (Expr e) = (s = s')"
    and "\<lbrace>P\<rbrace> B \<lbrace>Q\<rbrace>"
  shows "\<exists> P' . \<tau>\<^sub>B B P' Q \<and> (P \<longrightarrow>\<^sub>P P')"
  using assms(1,2,5)
proof(induct B P rule: exec_block.pinduct)
  case (1 S B P)
  from 1(4) have 0: "\<forall> s . holds_P s P \<longrightarrow> (\<exists> s' s'' . step\<^sub>S S s s' \<and> step\<^sub>B B s' s'' \<and> holds_P s'' Q)"
    apply (auto simp add: exploit_triple_def)
    using step\<^sub>B.cases
    by fastforce
  let ?S' = "{ s' . \<exists> s s'' . holds_P s P \<and> step\<^sub>S S s s' \<and> step\<^sub>B B s' s'' \<and> holds_P s'' Q }"
  obtain P' where P': "\<forall> s' . holds_P s' P' \<longleftrightarrow> s' \<in> ?S'"
    using set_of_states_describable[OF state_describable]
    by presburger
  have 2: "\<lbrace>P'\<rbrace> B \<lbrace>Q\<rbrace>"
    using P'
    by (auto simp add: exploit_triple_def)
  then obtain P\<^sub>B where P\<^sub>B: "\<tau>\<^sub>B B P\<^sub>B Q \<and> (P' \<longrightarrow>\<^sub>P P\<^sub>B)"
    using 1(2)[of P'] 1(3)
    by auto
  hence 3: "\<lbrace>P\<rbrace>\<^sub>S S \<lbrace>P\<^sub>B\<rbrace>"
    using 0 P'
    apply (auto simp add: exploit_tripleS_def implies_P_def)
    by blast
  then obtain P\<^sub>S where P\<^sub>S: "\<tau>\<^sub>S S P\<^sub>S P\<^sub>B \<and> (P \<longrightarrow>\<^sub>P P\<^sub>S)"
    using \<tau>\<^sub>S_completeness[of P S P\<^sub>B] 1(3)
    by auto
  have "\<tau>\<^sub>B (S;B) P\<^sub>S Q \<and> (P \<longrightarrow>\<^sub>P P\<^sub>S)"
    using P\<^sub>B P\<^sub>S \<tau>_seq[of _ P\<^sub>B]
    by auto
  then show ?case
    by auto
next
  case (2 e a\<^sub>0 a\<^sub>1 P)
  have 3: "\<mu>vars e = []" and 4: "\<mu>vars a\<^sub>0 = []" and 5: "\<mu>vars a\<^sub>1 = []"
    using 2(3)
    by auto
  {
    fix m
    assume m: "possible (jump_target e a\<^sub>0 a\<^sub>1 P m)"
    have "\<lbrace>P\<rbrace> blocks m \<lbrace>Q\<rbrace>"
    proof-
      {
        fix s
        assume "holds_P s P"
        then obtain s' where "step\<^sub>B (blocks (eval_E s undefined (if holds_P s (Expr e) then a\<^sub>0 else a\<^sub>1))) s s' \<and> holds_P s' Q"
          using 2(4) 3 4 5 step\<^sub>B_jump[of e a\<^sub>0 a\<^sub>1]
          by (auto simp add: exploit_triple_def)
        moreover
        have "direct_jump e a\<^sub>0 a\<^sub>1"
          using 2(3)
          by auto
        hence "eval_E s undefined (if holds_P s (Expr e) then a\<^sub>0 else a\<^sub>1) = m"
          using m
          apply (auto simp add: direct_jump_def)
          by force+
        ultimately
        have "\<exists> s' . step\<^sub>B (blocks m) s s' \<and> holds_P s' Q"
          by auto
      }
      thus ?thesis
        by (auto simp add: exploit_triple_def)
    qed
    hence "\<exists>P'. \<tau>\<^sub>B (blocks m) P' Q \<and> (P \<longrightarrow>\<^sub>P P')"
      using 2(2)[of m] m assms(3)
      by auto
  }
  note 1 = this
  show ?case
    apply (rule exI,auto)
    apply (rule \<tau>_jump[of _ _ _ P])
    using 1 3 4 5
    by (auto simp add: implies_P_def)
next
  case (3 P)
  show ?case
    apply (rule exI[of _ Q],auto)
     apply (rule \<tau>_exit)
    using 3
    by (auto simp add: implies_P_def exploit_triple_def step\<^sub>B_exit)
qed

(*
  FINAL THEOREMS
*)

theorem \<tau>\<^sub>P_sound:
assumes "\<tau>\<^sub>P P Q"                                              \<comment> \<open>P is derived from Q\<close>
  shows "\<lbrace>P\<rbrace> blocks entry \<lbrace>Q\<rbrace>"                                \<comment> \<open>P is an exploit for Q\<close>
  using \<tau>\<^sub>B_sound assms
  by (auto simp add: \<tau>\<^sub>P_def)

lemma \<tau>\<^sub>P_complete:
assumes "exec_block_dom (blocks entry,P)"                     \<comment> \<open>execution of the entry block terminates\<close>
    and "\<forall> m . sane_block False (blocks m)"                   \<comment> \<open>no indirections\<close>
    and "\<forall> s . \<exists> e . \<forall> s' . holds_P s' (Expr e) = (s = s')"   \<comment> \<open>states can precisely be described by a predicate\<close>

    and "\<lbrace>P\<rbrace> blocks entry \<lbrace>Q\<rbrace>"                                 \<comment> \<open>P is an exploit for Q\<close>
  shows "\<exists> P' . \<tau>\<^sub>B (blocks entry) P' Q \<and> (P \<longrightarrow>\<^sub>P P')"          \<comment> \<open>some precondition weaker than P is derived from Q\<close>
  using \<tau>\<^sub>B_complete assms
  by (auto simp add: \<tau>\<^sub>P_def)

end
end


section {*L\_ATS\_Simulation\_Configuration\_WeakLRB*}
theory
  L_ATS_Simulation_Configuration_WeakLRB

imports
  L_ATS_Simulation_Configuration_Weak

begin

locale ATS_Simulation_Configuration_WeakLRB =
  ATS_Simulation_Configuration_Weak
  "TSstructure1 :: 'TSstructure1 \<Rightarrow> bool"
  "configurations1 :: 'TSstructure1 \<Rightarrow> 'conf1 set"
  "initial_configurations1 :: 'TSstructure1 \<Rightarrow> 'conf1 set"
  "step_labels1 :: 'TSstructure1 \<Rightarrow> 'label1 set"
  "step_relation1 :: 'TSstructure1 \<Rightarrow> 'conf1 \<Rightarrow> 'label1 \<Rightarrow> 'conf1 \<Rightarrow> bool"
  "effects1 :: 'TSstructure1 \<Rightarrow> 'event1 set"
  "marking_condition1 :: 'TSstructure1 \<Rightarrow> ('label1,'conf1)derivation \<Rightarrow> bool"
  "marked_effect1 :: 'TSstructure1 \<Rightarrow> ('label1,'conf1)derivation \<Rightarrow> 'event1 set"
  "unmarked_effect1 :: 'TSstructure1 \<Rightarrow> ('label1,'conf1)derivation \<Rightarrow> 'event1 set"
  "TSstructure2 :: 'TSstructure2 \<Rightarrow> bool"
  "configurations2 :: 'TSstructure2 \<Rightarrow> 'conf2 set"
  "initial_configurations2 :: 'TSstructure2 \<Rightarrow> 'conf2 set"
  "step_labels2 :: 'TSstructure2 \<Rightarrow> 'label2 set"
  "step_relation2 :: 'TSstructure2 \<Rightarrow> 'conf2 \<Rightarrow> 'label2 \<Rightarrow> 'conf2 \<Rightarrow> bool"
  "effects2 :: 'TSstructure2 \<Rightarrow> 'event2 set"
  "marking_condition2 :: 'TSstructure2 \<Rightarrow> ('label2,'conf2)derivation \<Rightarrow> bool"
  "marked_effect2 :: 'TSstructure2 \<Rightarrow> ('label2,'conf2)derivation \<Rightarrow> 'event2 set"
  "unmarked_effect2 :: 'TSstructure2 \<Rightarrow> ('label2,'conf2)derivation \<Rightarrow> 'event2 set"
  "relation_configuration :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2 \<Rightarrow> bool"
  "relation_initial_configuration :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2 \<Rightarrow> bool"
  "relation_effect :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'event1 \<Rightarrow> 'event2 \<Rightarrow> bool"
  "relation_TSstructure :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> bool"
  for
    TSstructure1 configurations1 initial_configurations1 step_labels1 step_relation1 effects1 marking_condition1 marked_effect1 unmarked_effect1 TSstructure2 configurations2 initial_configurations2 step_labels2 step_relation2 effects2 marking_condition2 marked_effect2 unmarked_effect2 relation_configuration relation_initial_configuration relation_effect relation_TSstructure
    +

fixes AX_relation_initial_simulationB :: "'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2 \<Rightarrow> (nat \<Rightarrow> ('label2, 'conf2) derivation_configuration option) \<Rightarrow> bool"

fixes AX_relation_step_simulationB :: "'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'label1 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2 \<Rightarrow> (nat \<Rightarrow> ('label2, 'conf2) derivation_configuration option) \<Rightarrow> bool"

assumes AX_relation_initial_simulationB: "
  relation_TSstructure G1 G2
  \<Longrightarrow> c1 \<in> initial_configurations1 G1
  \<Longrightarrow> relation_configuration G1 G2 c1 c2
  \<Longrightarrow> \<exists>d2 n.
  GR.derivation_initial G2 d2
  \<and> relation_initial_configuration G1 G2 c1 (the(get_configuration(d2 0)))
  \<and> AX_relation_initial_simulationB G1 G2 c1 c2 d2
  \<and> maximum_of_domain d2 n
  \<and> get_configuration (d2 n) = Some c2"

assumes AX_relation_step_simulationB: "
  relation_TSstructure G1 G2
  \<Longrightarrow> relation_configuration G1 G2 c1 c2
  \<Longrightarrow> e1 \<in> step_labels1 G1
  \<Longrightarrow> c1' \<in> configurations1 G1
  \<Longrightarrow> step_relation1 G1 c1' e1 c1
  \<Longrightarrow> \<exists>d2 n.
  GR.derivation G2 d2
  \<and> GR.belongs G2 d2
  \<and> the(get_configuration(d2 n)) = c2
  \<and> AX_relation_step_simulationB G1 G2 c1' e1 c1 c2 d2
  \<and> maximum_of_domain d2 n
  \<and> relation_configuration G1 G2 c1' (the(get_configuration(d2 0)))"

assumes AX_initial_contained: "
  relation_TSstructure G1 G2
  \<Longrightarrow> relation_initial_configuration G1 G2 c1 c2
  \<Longrightarrow> relation_configuration G1 G2 c1 c2"

context ATS_Simulation_Configuration_WeakLRB begin

lemma ATS_Simulation_Configuration_WeakLRB_simulation_derivation_exists: "
  relation_TSstructure G1 G2
  \<Longrightarrow> GL.derivation G1 d1
  \<Longrightarrow> GL.belongs G1 d1
  \<Longrightarrow> d1 x = Some (pair e1x c1x)
  \<Longrightarrow> d1 y = Some (pair e1y c1y)
  \<Longrightarrow> x\<le>y
  \<Longrightarrow> relation_configuration G1 G2 c1y c2y
  \<Longrightarrow> \<exists>d2 n2.
  GR.derivation G2 d2
  \<and> maximum_of_domain d2 n2
  \<and> relation_configuration G1 G2 c1x (the (get_configuration (d2 0)))
  \<and> c2y = (the (get_configuration (d2 n2)))
  \<and> (c1x \<in> initial_configurations1 G1 \<longrightarrow> (the (get_configuration (d2 0))) \<in> initial_configurations2 G2)"
  apply(induct "y-x" arbitrary: x e1x c1x)
   apply(rename_tac x e1x c1x)(*strict*)
   apply(clarsimp)
   apply(case_tac "c1y \<in> initial_configurations1 G1")
    apply(subgoal_tac "\<exists>d2 n. GR.derivation_initial G2 d2 \<and> relation_initial_configuration G1 G2 c1y (the(get_configuration(d2 0))) \<and> AX_relation_initial_simulationB G1 G2 c1y c2y d2 \<and> maximum_of_domain d2 n \<and> get_configuration (d2 n) = Some c2y")
     prefer 2
     apply(rule AX_relation_initial_simulationB)
       apply(force)
      apply(force)
     apply(force)
    apply(clarsimp)
    apply(rename_tac d2 n)(*strict*)
    apply(rule_tac
      x="d2"
      in exI)
    apply(rule conjI)
     apply(rename_tac d2 n)(*strict*)
     apply(rule GR.derivation_initial_is_derivation)
     apply(force)
    apply(rename_tac d2 n)(*strict*)
    apply(rule_tac
      x="n"
      in exI)
    apply(clarsimp)
    apply(subgoal_tac "\<exists>c. d2 0 = Some (pair None c)")
     apply(rename_tac d2 n)(*strict*)
     apply(clarsimp)
     apply(rename_tac d2 n c)(*strict*)
     apply(subgoal_tac "\<exists>e c. d2 n = Some (pair e c)")
      apply(rename_tac d2 n c)(*strict*)
      apply(clarsimp)
      apply(rename_tac d2 n c e ca)(*strict*)
      apply(simp add: get_configuration_def GR.derivation_initial_def)
      apply (metis AX_initial_contained)
     apply(rename_tac d2 n c)(*strict*)
     apply(simp add: get_configuration_def)
     apply(case_tac "d2 n")
      apply(rename_tac d2 n c)(*strict*)
      apply(clarsimp)
     apply(rename_tac d2 n c a)(*strict*)
     apply(case_tac a)
     apply(rename_tac d2 n c a option b)(*strict*)
     apply(clarsimp)
    apply(rename_tac d2 n)(*strict*)
    apply (metis GR.derivation_initial_is_derivation GR.some_position_has_details_at_0)
   apply(rule_tac
      x="der1 c2y"
      in exI)
   apply(rule conjI)
    apply(rule GR.der1_is_derivation)
   apply(rule_tac
      x="0"
      in exI)
   apply(rule conjI)
    apply(rule der1_maximum_of_domain)
   apply(simp add: der1_def get_configuration_def)
  apply(rename_tac xa x e1x c1x)(*strict*)
  apply(clarsimp)
  apply(case_tac y)
   apply(rename_tac xa x e1x c1x)(*strict*)
   apply(force)
  apply(rename_tac xa x e1x c1x nat)(*strict*)
  apply(clarsimp)
  apply(rename_tac y)
  apply(rename_tac xa x e1x c1x y)(*strict*)
  apply(erule_tac
      x="Suc x"
      in meta_allE)
  apply(clarsimp)
  apply(subgoal_tac "\<exists>e1 e2 c1 c2. d1 x = Some (pair e1 c1) \<and> d1 (Suc x) = Some (pair (Some e2) c2) \<and> step_relation1 G1 c1 e2 c2")
   apply(rename_tac xa x e1x c1x y)(*strict*)
   prefer 2
   apply(rule_tac
      m="Suc y"
      in GL.step_detail_before_some_position)
     apply(rename_tac xa x e1x c1x y)(*strict*)
     apply(force)
    apply(rename_tac xa x e1x c1x y)(*strict*)
    apply(force)
   apply(rename_tac xa x e1x c1x y)(*strict*)
   apply(force)
  apply(rename_tac xa x e1x c1x y)(*strict*)
  apply(clarsimp)
  apply(rename_tac xa x e1x c1x y e2 c2)(*strict*)
  apply(erule_tac
      x="Some e2"
      in meta_allE)
  apply(erule_tac
      x="c2"
      in meta_allE)
  apply(clarsimp)
  apply(erule meta_impE)
   apply(rename_tac xa x e1x c1x y e2 c2)(*strict*)
   apply(force)
  apply(rename_tac xa x e1x c1x y e2 c2)(*strict*)
  apply(erule meta_impE)
   apply(rename_tac xa x e1x c1x y e2 c2)(*strict*)
   apply(force)
  apply(rename_tac xa x e1x c1x y e2 c2)(*strict*)
  apply(clarsimp)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
  apply(subgoal_tac "\<exists>d2' n. GR.derivation G2 d2' \<and> GR.belongs G2 d2' \<and> the(get_configuration(d2' n)) = the(get_configuration(d2 0)) \<and> AX_relation_step_simulationB G1 G2 c1x e2 c2 (the(get_configuration(d2 0))) d2' \<and> maximum_of_domain d2' n \<and> relation_configuration G1 G2 c1x (the(get_configuration(d2' 0)))")
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
   prefer 2
   apply(rule AX_relation_step_simulationB)
       apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
       apply(force)
      apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
      apply(force)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
     apply(rule GL.AX_step_relation_preserves_belongsE)
       apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
       apply (metis AX_TSstructure_relation_TSstructure1_belongs)
      apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
      apply(force)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
     apply (metis GL.belongs_configurations)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
    apply (metis GL.belongs_configurations)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
   apply(force)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2)(*strict*)
  apply(clarsimp)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
  apply(case_tac "c1x \<in> initial_configurations1 G1")
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
   prefer 2
   apply(rule_tac
      x="derivation_append d2' d2 n"
      in exI)
   apply(rule conjI)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
    apply(rule GR.derivation_append_preserves_derivation)
      apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
      apply(force)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
     apply(force)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
    apply(simp add: maximum_of_domain_def)
    apply(clarsimp)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n ya yb)(*strict*)
    apply(case_tac yb)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n ya yb option b)(*strict*)
    apply(clarsimp)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n ya option b)(*strict*)
    apply(subgoal_tac "\<exists>c. d2 0 = Some (pair None c)")
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n ya option b)(*strict*)
     apply(clarsimp)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n ya option b c)(*strict*)
     apply(simp add: get_configuration_def)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n ya option b)(*strict*)
    apply (metis GR.some_position_has_details_at_0)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
   apply(rule_tac
      x="n+n2"
      in exI)
   apply(rule conjI)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
    apply (metis concat_has_max_dom)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
   apply(rule conjI)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
    apply (simp add: get_configuration_def derivation_append_def)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
   apply(rule conjI)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
    apply (simp add: get_configuration_def derivation_append_def)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
   apply(clarsimp)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
  apply(subgoal_tac "\<exists>d2 n. GR.derivation_initial G2 d2 \<and> relation_initial_configuration G1 G2 c1x (the(get_configuration(d2 0))) \<and> AX_relation_initial_simulationB G1 G2 c1x (the (get_configuration (d2' 0))) d2 \<and> maximum_of_domain d2 n \<and> get_configuration (d2 n) = Some (the (get_configuration (d2' 0)))")
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
   prefer 2
   apply(rule AX_relation_initial_simulationB)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
     apply(force)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
    apply(force)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
   apply(force)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n)(*strict*)
  apply(clarsimp)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
  apply(rule_tac
      x="derivation_append d2a (derivation_append d2' d2 n) na"
      in exI)
  apply(rule conjI)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply(rule GR.derivation_append_preserves_derivation)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
     apply(rule GR.derivation_initial_is_derivation)
     apply(force)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
    apply(rule GR.derivation_append_preserves_derivation)
      apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
      apply(force)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
     apply(force)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
    apply(subgoal_tac "\<exists>e c. d2' n = Some (pair e c)")
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
     apply(clarsimp)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c)(*strict*)
     apply(subgoal_tac "\<exists>c. d2 0 = Some (pair None c)")
      apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c)(*strict*)
      apply(clarsimp)
      apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c ca)(*strict*)
      apply(simp add: get_configuration_def GR.derivation_initial_def)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c)(*strict*)
     apply (metis GR.some_position_has_details_at_0)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
    apply(rule GR.some_position_has_details_before_max_dom)
      apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
      apply(force)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
     apply(force)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
    apply(force)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply(subgoal_tac "\<exists>e c. d2a na = Some (pair e c)")
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
    apply(clarsimp)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c)(*strict*)
    apply(simp add: derivation_append_def)
    apply(subgoal_tac "\<exists>c. d2' 0 = Some (pair None c)")
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c)(*strict*)
     apply(clarsimp)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c ca)(*strict*)
     apply(simp add: get_configuration_def)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na e c)(*strict*)
    apply (metis GR.some_position_has_details_at_0)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply(rule GR.some_position_has_details_before_max_dom)
     apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
     apply(rule GR.derivation_initial_is_derivation)
     apply(force)
    apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
    apply(force)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply(force)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
  apply(rule_tac
      x="na+(n+n2)"
      in exI)
  apply(rule conjI)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply (metis concat_has_max_dom)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
  apply(rule conjI)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply (simp add: get_configuration_def derivation_append_def)
   apply (metis get_configuration_def AX_initial_contained)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
  apply(rule conjI)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply (simp add: get_configuration_def derivation_append_def)
   apply(clarsimp)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
  apply(subgoal_tac "\<exists>c. d2a 0 = Some (pair None c)")
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
   apply(clarsimp)
   apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na c)(*strict*)
   apply (simp add: get_configuration_def derivation_append_def GR.derivation_initial_def)
  apply(rename_tac xa x e1x c1x y e2 c2 d2 n2 d2' n d2a na)(*strict*)
  apply (metis GR.derivation_initial_is_derivation GR.some_position_has_details_at_0)
  done

lemma ATS_Simulation_Configuration_WeakLRB_simulation_initial_derivation_exists: "
  relation_TSstructure G1 G2
  \<Longrightarrow> GL.derivation_initial G1 d1
  \<Longrightarrow> d1 x = Some (pair e1 c1)
  \<Longrightarrow> relation_configuration G1 G2 c1 c2
  \<Longrightarrow> \<exists>d2 n2.
  GR.derivation_initial G2 d2
  \<and> maximum_of_domain d2 n2
  \<and> c2 = (the (get_configuration (d2 n2)))"
  apply(subgoal_tac "\<exists>c. d1 0 = Some (pair None c)")
   apply(clarsimp)
   apply(rename_tac c)(*strict*)
   apply(subgoal_tac "\<exists>d2 n2. GR.derivation G2 d2 \<and> maximum_of_domain d2 n2 \<and> relation_configuration G1 G2 c (the (get_configuration (d2 0))) \<and> c2 = (the (get_configuration (d2 n2))) \<and> (c \<in> initial_configurations1 G1 \<longrightarrow> (the (get_configuration (d2 0))) \<in> initial_configurations2 G2)")
    apply(rename_tac c)(*strict*)
    prefer 2
    apply(rule_tac
      ?d1.0="d1"
      in ATS_Simulation_Configuration_WeakLRB_simulation_derivation_exists)
          apply(rename_tac c)(*strict*)
          apply(force)
         apply(rename_tac c)(*strict*)
         apply(rule GL.derivation_initial_is_derivation)
         apply(force)
        apply(rename_tac c)(*strict*)
        apply(rule GL.derivation_initial_belongs)
         apply(rename_tac c)(*strict*)
         apply (metis AX_TSstructure_relation_TSstructure1_belongs)
        apply(rename_tac c)(*strict*)
        apply(force)
       apply(rename_tac c)(*strict*)
       apply(force)
      apply(rename_tac c)(*strict*)
      apply(force)
     apply(rename_tac c)(*strict*)
     apply(force)
    apply(rename_tac c)(*strict*)
    apply(force)
   apply(rename_tac c)(*strict*)
   apply(clarsimp)
   apply(rename_tac c d2 n2)(*strict*)
   apply(subgoal_tac "\<exists>c. d2 0 = Some (pair None c)")
    apply(rename_tac c d2 n2)(*strict*)
    apply(rule_tac
      x="d2"
      in exI)
    apply(rule conjI)
     apply(rename_tac c d2 n2)(*strict*)
     apply(simp add: GR.derivation_initial_def)
     apply(clarsimp)
     apply(rename_tac c d2 n2 ca)(*strict*)
     apply (simp add: get_configuration_def)
     apply(erule impE)
      apply(rename_tac c d2 n2 ca)(*strict*)
      apply(simp add: GL.derivation_initial_def)
     apply(rename_tac c d2 n2 ca)(*strict*)
     apply(force)
    apply(rename_tac c d2 n2)(*strict*)
    apply(rule_tac
      x="n2"
      in exI)
    apply(clarsimp)
   apply(rename_tac c d2 n2)(*strict*)
   apply (metis GR.some_position_has_details_at_0)
  apply (metis GL.derivation_initial_is_derivation GL.some_position_has_details_at_0)
  done

theorem ATS_Simulation_Configuration_WeakLRB_get_accessible_configurations_transfer: "
  relation_TSstructure G1 G2
  \<Longrightarrow> relation_configuration G1 G2 c1 c2
  \<Longrightarrow> c1 \<in> GL.get_accessible_configurations G1
  \<Longrightarrow> c2 \<in> GR.get_accessible_configurations G2"
  apply(simp add: GL.get_accessible_configurations_def GR.get_accessible_configurations_def)
  apply(clarsimp)
  apply(rename_tac d i)(*strict*)
  apply(case_tac "d i")
   apply(rename_tac d i)(*strict*)
   apply(simp add: get_configuration_def)
  apply(rename_tac d i a)(*strict*)
  apply(clarsimp)
  apply(case_tac a)
  apply(rename_tac d i a option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac d i option b)(*strict*)
  apply(simp add: get_configuration_def)
  apply(subgoal_tac "\<exists>d2 n2. GR.derivation_initial G2 d2 \<and> maximum_of_domain d2 n2 \<and> c2 = (the (get_configuration (d2 n2)))")
   apply(rename_tac d i option b)(*strict*)
   prefer 2
   apply(rule ATS_Simulation_Configuration_WeakLRB_simulation_initial_derivation_exists)
      apply(rename_tac d i option b)(*strict*)
      apply(force)
     apply(rename_tac d i option b)(*strict*)
     apply(force)
    apply(rename_tac d i option b)(*strict*)
    apply(force)
   apply(rename_tac d i option b)(*strict*)
   apply(force)
  apply(rename_tac d i option b)(*strict*)
  apply(clarsimp)
  apply(rename_tac d i option d2 n2)(*strict*)
  apply(rule_tac
      x="d2"
      in exI)
  apply(clarsimp)
  apply(rule_tac
      x="n2"
      in exI)
  apply(simp add: get_configuration_def)
  apply(simp add: maximum_of_domain_def)
  apply(clarsimp)
  apply(rename_tac d i option d2 n2 y)(*strict*)
  apply(case_tac y)
  apply(rename_tac d i option d2 n2 y optiona conf)(*strict*)
  apply(clarsimp)
  done

end

end