(*  Title:      JinjaThreads/Framework/FWLock.thy
    Author:     Andreas Lochbihler
*)

header {* \isaheader{All about a managing a single lock} *}

theory FWLock
imports
  FWState
begin

fun has_locks :: "'t lock \<Rightarrow> 't \<Rightarrow> nat" where
  "has_locks None t = 0"
| "has_locks \<lfloor>(t', n)\<rfloor> t = (if t = t' then Suc n else 0)"

lemma has_locks_iff:
  "has_locks l t = n \<longleftrightarrow>
  (l = None \<and> n = 0) \<or>
  (\<exists>n'. l = \<lfloor>(t, n')\<rfloor> \<and> Suc n' = n) \<or> (\<exists>t' n'. l = \<lfloor>(t', n')\<rfloor> \<and> t' \<noteq> t \<and> n = 0)"
by(cases l, auto)

lemma has_locksE:
  "\<lbrakk> has_locks l t = n;
     \<lbrakk> l = None; n = 0 \<rbrakk> \<Longrightarrow> P;
     \<And>n'. \<lbrakk> l = \<lfloor>(t, n')\<rfloor>; Suc n' = n \<rbrakk> \<Longrightarrow> P;
     \<And>t' n'. \<lbrakk> l = \<lfloor>(t', n')\<rfloor>; t' \<noteq> t; n = 0 \<rbrakk> \<Longrightarrow> P \<rbrakk>
  \<Longrightarrow> P"
by(auto simp add: has_locks_iff split: split_if_asm prod.split_asm)

inductive may_lock :: "'t lock \<Rightarrow> 't \<Rightarrow> bool" where
  "may_lock None t"
| "may_lock \<lfloor>(t, n)\<rfloor> t"

lemma may_lock_iff [code]:
  "may_lock l t = (case l of None \<Rightarrow> True | \<lfloor>(t', n)\<rfloor> \<Rightarrow> t = t')"
by(auto intro: may_lock.intros elim: may_lock.cases)

lemma may_lockI:
  "l = None \<or> (\<exists>n. l = \<lfloor>(t, n)\<rfloor>) \<Longrightarrow> may_lock l t"
by(cases l, auto intro: may_lock.intros)

lemma may_lockE [consumes 1, case_names None Locked]:
  "\<lbrakk> may_lock l t; l = None \<Longrightarrow> P; \<And>n. l = \<lfloor>(t, n)\<rfloor>  \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by(auto elim: may_lock.cases)

lemma may_lock_may_lock_t_eq:
  "\<lbrakk> may_lock l t; may_lock l t' \<rbrakk> \<Longrightarrow> (l = None) \<or> (t = t')"
by(auto elim!: may_lockE)

abbreviation has_lock :: "'t lock \<Rightarrow> 't \<Rightarrow> bool"
where "has_lock l t \<equiv> 0 < has_locks l t"

lemma has_locks_Suc_has_lock:
  "has_locks l t = Suc n \<Longrightarrow> has_lock l t"
by(auto)

lemmas has_lock_has_locks_Suc = gr0_implies_Suc[where n = "has_locks l t"]

lemma has_lock_has_locks_conv:
  "has_lock l t \<longleftrightarrow> (\<exists>n. has_locks l t = (Suc n))"
by(auto intro: has_locks_Suc_has_lock has_lock_has_locks_Suc)

lemma has_lock_may_lock_t_eq:
  "\<lbrakk> has_lock l t; may_lock l t' \<rbrakk> \<Longrightarrow> t = t'"
by(auto elim!: may_lockE split: split_if_asm)

lemma has_locks_has_locks_t_eq:
  "\<lbrakk>has_locks l t = Suc n; has_locks l t' = Suc n'\<rbrakk> \<Longrightarrow> t = t'"
by(auto elim: has_locksE)

lemma has_lock_has_lock_t_eq:
  "\<lbrakk> has_lock l t; has_lock l t' \<rbrakk> \<Longrightarrow> t = t'"
unfolding has_lock_has_locks_conv
by(auto intro: has_locks_has_locks_t_eq)

lemma not_may_lock_conv:
  "\<not> may_lock l t \<longleftrightarrow> (\<exists>t'. t' \<noteq> t \<and> has_lock l t')"
by(cases l, auto intro: may_lock.intros elim: may_lockE)

(* State update functions for locking *)

fun lock_lock :: "'t lock \<Rightarrow> 't \<Rightarrow> 't lock" where
  "lock_lock None t = \<lfloor>(t, 0)\<rfloor>"
| "lock_lock \<lfloor>(t', n)\<rfloor> t = \<lfloor>(t', Suc n)\<rfloor>"

fun unlock_lock :: "'t lock \<Rightarrow> 't lock" where
  "unlock_lock None = None"
| "unlock_lock \<lfloor>(t, n)\<rfloor> = (case n of 0 \<Rightarrow> None | Suc n' \<Rightarrow> \<lfloor>(t, n')\<rfloor>)"

fun release_all :: "'t lock \<Rightarrow> 't \<Rightarrow> 't lock" where
  "release_all None t = None"
| "release_all \<lfloor>(t', n)\<rfloor> t = (if t = t' then None else \<lfloor>(t', n)\<rfloor>)"

fun acquire_locks :: "'t lock \<Rightarrow> 't \<Rightarrow> nat \<Rightarrow> 't lock" where
  "acquire_locks L t 0 = L"
| "acquire_locks L t (Suc m) = acquire_locks (lock_lock L t) t m"

lemma acquire_locks_conv:
  "acquire_locks L t n = (case L of None \<Rightarrow> (case n of 0 \<Rightarrow> None | Suc m \<Rightarrow> \<lfloor>(t, m)\<rfloor>) | \<lfloor>(t', m)\<rfloor> \<Rightarrow> \<lfloor>(t', n + m)\<rfloor>)"
by(induct n arbitrary: L)(auto)

lemma lock_lock_ls_Some:
  "\<exists>t' n. lock_lock l t = \<lfloor>(t', n)\<rfloor>"
by(cases l, auto)

lemma unlock_lock_SomeD:
  "unlock_lock l = \<lfloor>(t', n)\<rfloor> \<Longrightarrow> l = \<lfloor>(t', Suc n)\<rfloor>"
by(cases l, auto split: nat.split_asm)

lemma has_locks_Suc_lock_lock_has_locks_Suc_Suc:
  "has_locks l t = Suc n \<Longrightarrow> has_locks (lock_lock l t) t = Suc (Suc n)"
by(auto elim!: has_locksE)

lemma has_locks_lock_lock_conv [simp]:
  "may_lock l t \<Longrightarrow> has_locks (lock_lock l t) t = Suc (has_locks l t)"
by(auto elim: may_lockE)

lemma has_locks_release_all_conv [simp]:
  "has_locks (release_all l t) t = 0"
by(cases l, auto split: split_if_asm)

lemma may_lock_lock_lock_conv [simp]: "may_lock (lock_lock l t) t = may_lock l t"
by(cases l, auto elim!: may_lock.cases intro: may_lock.intros)

lemma has_locks_acquire_locks_conv [simp]:
  "may_lock l t \<Longrightarrow> has_locks (acquire_locks l t n) t = has_locks l t + n"
by(induct n arbitrary: l, auto)

lemma may_lock_unlock_lock_conv [simp]:
  "has_lock l t \<Longrightarrow> may_lock (unlock_lock l) t = may_lock l t"
by(cases l)(auto split: split_if_asm nat.splits elim!: may_lock.cases intro: may_lock.intros)

lemma may_lock_release_all_conv [simp]:
  "may_lock (release_all l t) t = may_lock l t"
by(cases l, auto split: split_if_asm intro!: may_lockI elim: may_lockE)

lemma may_lock_t_may_lock_unlock_lock_t:
  "may_lock l t \<Longrightarrow> may_lock (unlock_lock l) t"
by(auto intro: may_lock.intros elim!: may_lockE split: nat.split)

lemma may_lock_has_locks_lock_lock_0:
  "\<lbrakk>may_lock l t'; t \<noteq> t'\<rbrakk> \<Longrightarrow> has_locks (lock_lock l t') t = 0"
by(auto elim!: may_lock.cases)

lemma has_lock_lock_lock_unlock_lock_id [simp]:
  "has_lock l t \<Longrightarrow> lock_lock (unlock_lock l) t = l"
by(cases l)(auto split: split_if_asm nat.split)

lemma may_lock_unlock_lock_lock_lock_id [simp]:
  "may_lock l t \<Longrightarrow> unlock_lock (lock_lock l t) = l"
by(cases l) auto

lemma may_lock_has_locks_0:
  "\<lbrakk> may_lock l t; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_locks l t' = 0"
by(auto elim!: may_lockE)

fun upd_lock :: "'t lock \<Rightarrow> 't \<Rightarrow> lock_action \<Rightarrow> 't lock"
where
  "upd_lock l t Lock = lock_lock l t"
| "upd_lock l t Unlock = unlock_lock l"
| "upd_lock l t UnlockFail = l"
| "upd_lock l t ReleaseAquire = release_all l t"

fun upd_locks :: "'t lock \<Rightarrow> 't \<Rightarrow> lock_action list \<Rightarrow> 't lock"
where
  "upd_locks l t [] = l"
| "upd_locks l t (L # Ls) = upd_locks (upd_lock l t L) t Ls"

lemma upd_locks_append [simp]:
  "upd_locks l t (Ls @ Ls') = upd_locks (upd_locks l t Ls) t Ls'"
by(induct Ls arbitrary: l, auto)

lemma upd_lock_Some_thread_idD:
  assumes ul: "upd_lock l t L = \<lfloor>(t', n)\<rfloor>"
  and tt': "t \<noteq> t'"
  shows "\<exists>n. l = \<lfloor>(t', n)\<rfloor>"
proof(cases L)
  case Lock
  with ul tt' show ?thesis
    by(cases l, auto)
next
  case Unlock
  with ul tt' show ?thesis
    by(auto dest: unlock_lock_SomeD)
next
  case UnlockFail
  with ul show ?thesis by(simp)
next
  case ReleaseAcquire
  with ul show ?thesis
    by(cases l, auto split: split_if_asm)
qed

lemma has_lock_upd_lock_implies_has_lock:
  "\<lbrakk> has_lock (upd_lock l t L) t'; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_lock l t'"
by(cases l L rule: option.exhaust[case_product lock_action.exhaust])(auto split: split_if_asm nat.split_asm)

lemma has_lock_upd_locks_implies_has_lock:
  "\<lbrakk> has_lock (upd_locks l t Ls) t'; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_lock l t'"
by(induct l t Ls rule: upd_locks.induct)(auto intro: has_lock_upd_lock_implies_has_lock)

(* Preconditions for lock actions *)

fun lock_action_ok :: "'t lock \<Rightarrow> 't \<Rightarrow> lock_action \<Rightarrow> bool" where
  "lock_action_ok l t Lock = may_lock l t"
| "lock_action_ok l t Unlock = has_lock l t"
| "lock_action_ok l t UnlockFail = (\<not> has_lock l t)"
| "lock_action_ok l t ReleaseAcquire = True"

fun lock_actions_ok :: "'t lock \<Rightarrow> 't \<Rightarrow> lock_action list \<Rightarrow> bool" where
  "lock_actions_ok l t [] = True"
| "lock_actions_ok l t (L # Ls) = (lock_action_ok l t L \<and> lock_actions_ok (upd_lock l t L) t Ls)"

lemma lock_actions_ok_append [simp]:
  "lock_actions_ok l t (Ls @ Ls') \<longleftrightarrow> lock_actions_ok l t Ls \<and> lock_actions_ok (upd_locks l t Ls) t Ls'"
by(induct Ls arbitrary: l) auto

lemma not_lock_action_okE [consumes 1, case_names Lock Unlock UnlockFail]:
  "\<lbrakk> \<not> lock_action_ok l t L;
     \<lbrakk> L = Lock; \<not> may_lock l t \<rbrakk> \<Longrightarrow> Q;
     \<lbrakk> L = Unlock; \<not> has_lock l t \<rbrakk> \<Longrightarrow> Q;
     \<lbrakk> L = UnlockFail; has_lock l t \<rbrakk> \<Longrightarrow> Q\<rbrakk>
  \<Longrightarrow> Q"
by(cases L) auto

lemma may_lock_upd_lock_conv [simp]:
  "lock_action_ok l t L \<Longrightarrow> may_lock (upd_lock l t L) t = may_lock l t"
by(cases L) auto

lemma may_lock_upd_locks_conv [simp]:
  "lock_actions_ok l t Ls \<Longrightarrow> may_lock (upd_locks l t Ls) t = may_lock l t"
by(induct l t Ls rule: upd_locks.induct) simp_all

lemma lock_actions_ok_Lock_may_lock:
  "\<lbrakk> lock_actions_ok l t Ls; Lock \<in> set Ls \<rbrakk> \<Longrightarrow> may_lock l t"
by(induct l t Ls rule: lock_actions_ok.induct) auto

lemma has_locks_lock_lock_conv' [simp]:
  "\<lbrakk> may_lock l t'; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_locks (lock_lock l t') t = has_locks l t"
by(cases l)(auto elim: may_lock.cases)

lemma has_locks_unlock_lock_conv' [simp]:
  "\<lbrakk> has_lock l t'; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_locks (unlock_lock l) t = has_locks l t"
by(cases l)(auto split: split_if_asm nat.split)

lemma has_locks_release_all_conv' [simp]:
  "t \<noteq> t' \<Longrightarrow> has_locks (release_all l t') t = has_locks l t"
by(cases l) auto

lemma has_locks_acquire_locks_conv' [simp]:
  "\<lbrakk> may_lock l t; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_locks (acquire_locks l t n) t' = has_locks l t'"
by(induct l t n rule: acquire_locks.induct) simp_all

lemma lock_action_ok_has_locks_upd_lock_eq_has_locks [simp]:
  "\<lbrakk> lock_action_ok l t' L; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_locks (upd_lock l t' L) t = has_locks l t"
by(cases L) auto

lemma lock_actions_ok_has_locks_upd_locks_eq_has_locks [simp]:
  "\<lbrakk> lock_actions_ok l t' Ls; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_locks (upd_locks l t' Ls) t = has_locks l t"
by(induct l t' Ls rule: upd_locks.induct) simp_all

lemma has_lock_acquire_locks_implies_has_lock:
  "\<lbrakk> has_lock (acquire_locks l t n) t'; t \<noteq> t' \<rbrakk> \<Longrightarrow> has_lock l t'"
 unfolding acquire_locks_conv
 by(cases n)(auto split: split_if_asm)

lemma has_lock_has_lock_acquire_locks:
  "has_lock l T \<Longrightarrow> has_lock (acquire_locks l t n) T"
  unfolding acquire_locks_conv
  by(auto)

fun lock_actions_ok' :: "'t lock \<Rightarrow> 't \<Rightarrow> lock_action list \<Rightarrow> bool" where
  "lock_actions_ok' l t [] = True"
| "lock_actions_ok' l t (L#Ls) = ((L = Lock \<and> \<not> may_lock l t) \<or>
                                  lock_action_ok l t L \<and> lock_actions_ok' (upd_lock l t L) t Ls)"

lemma lock_actions_ok'_iff:
  "lock_actions_ok' l t las \<longleftrightarrow>
   lock_actions_ok l t las \<or> (\<exists>xs ys. las = xs @ Lock # ys \<and> lock_actions_ok l t xs \<and> \<not> may_lock (upd_locks l t xs) t)"
proof(induct l t las rule: lock_actions_ok.induct)
  case (2 L t LA LAS)
  show ?case
  proof(cases "LA = Lock \<and> \<not> may_lock L t")
    case True
    hence "(\<exists>ys. Lock # LAS = [] @ Lock # ys) \<and> lock_actions_ok L t [] \<and> \<not> may_lock (upd_locks L t []) t"
      by(simp)
    with True show ?thesis by(simp (no_asm))(blast)
  next
    case False
    with 2 show ?thesis
      by(fastforce simp add: Cons_eq_append_conv elim: allE[where x="LA # xs" for xs])
  qed
qed simp

lemma lock_actions_ok'E[consumes 1, case_names ok Lock]:
  "\<lbrakk> lock_actions_ok' l t las;
     lock_actions_ok l t las \<Longrightarrow> P;
     \<And>xs ys. \<lbrakk> las = xs @ Lock # ys; lock_actions_ok l t xs; \<not> may_lock (upd_locks l t xs) t \<rbrakk> \<Longrightarrow> P \<rbrakk>
  \<Longrightarrow> P"
by(auto simp add: lock_actions_ok'_iff)

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(GD_GPL)
 *)

(* Title:   Confinement_S
 * Description: confinement proof of the security model
 *)

theory Confine_S
imports System_S
begin

(* These translate Create into all_rights *)
definition
  extra_rights :: "cap \<Rightarrow> cap" where
  "extra_rights c \<equiv>
  if (Create \<in> rights c)
  then c\<lparr>rights := all_rights\<rparr>
  else c"

lemma extra_rights_idem [simp]:
  "(extra_rights (extra_rights c)) = (extra_rights c)"
  apply (clarsimp simp add: extra_rights_def)
  done

lemma extra_rights_image_idem [simp]:
  "(extra_rights ` (extra_rights ` S)) = (extra_rights ` S)"
  by (rule set_eqI) (simp add: image_iff)

lemma extra_rights_empty_rights_ident [simp]:
   "extra_rights \<lparr> target = e, rights = {} \<rparr> = \<lparr> target = e, rights = {} \<rparr>"
  by (simp add: extra_rights_def)

lemma entity_extra_rights [simp]:
  "target (extra_rights c) = target c"
  by (simp add: extra_rights_def)

lemma rights_extra_rights:
  "rights (extra_rights c) =
   (if Create \<in> (rights c)
    then all_rights
    else rights c)"
  by (simp add: extra_rights_def)

(* The following two definitions both translate Create into all_rights *)

(* A cap is in a set, or a cap with more access is. *)
definition
  cap_in_caps :: "cap \<Rightarrow> cap set \<Rightarrow> bool" (infix "\<in>cap" 50) where
  "c \<in>cap C \<equiv> \<exists>c' \<in> C. target c = target c' \<and> rights (extra_rights c) \<subseteq> rights (extra_rights c')"

abbreviation not_cap_in_caps where
  "not_cap_in_caps x A \<equiv> ~ (x \<in>cap A)" -- "non-membership"

notation (input) cap_in_caps (infix ":cap" 50)
notation (latex output)  cap_in_caps (infix "\<in>\<^sub>c\<^sub>a\<^sub>p" 50)

notation
  not_cap_in_caps  ("op \<notin>cap") and
  not_cap_in_caps  ("(_/ \<notin>cap _)" [51, 51] 50)

notation (latex output)
  not_cap_in_caps  ("op \<notin>\<^sub>c\<^sub>a\<^sub>p") and
  not_cap_in_caps  (infix "\<notin>\<^sub>c\<^sub>a\<^sub>p" 50)

(* A set of caps "caps" have less (or equal) access to an entity as "cap" does. *)
definition
  caps_dominated_by :: "cap set \<Rightarrow> cap \<Rightarrow> bool" (infix "\<le>cap" 50) where
  "caps \<le>cap cap \<equiv> \<forall>cap' \<in> caps. target cap' = target cap \<longrightarrow> rights (extra_rights cap') \<subseteq> rights (extra_rights cap)"

notation (input) caps_dominated_by (infix "<=cap" 50)
notation (latex output) caps_dominated_by (infix "\<unlhd>\<^sub>c\<^sub>a\<^sub>p" 50)

definition
  shares_caps :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" where
  "shares_caps s e\<^sub>x e\<^sub>y \<equiv> \<exists>e\<^sub>i . (e\<^sub>x, e\<^sub>i) \<in> store_connected s \<and> (e\<^sub>y, e\<^sub>i) \<in> store_connected s"

definition
  leak :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" ("_ \<turnstile> _ \<rightarrow> _") where
  "leak s e\<^sub>x e\<^sub>y \<equiv> take_cap e\<^sub>x \<in>cap caps_of s e\<^sub>y \<or> grant_cap e\<^sub>y \<in>cap caps_of s e\<^sub>x \<or> shares_caps s e\<^sub>x e\<^sub>y"

definition
  directly_tgs_connected :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "directly_tgs_connected s \<equiv> {(e\<^sub>x, e\<^sub>y). leak s e\<^sub>x e\<^sub>y \<or> leak s e\<^sub>y e\<^sub>x}"

lemma directly_tgs_connected_def2:
  "(e\<^sub>x, e\<^sub>y) \<in> directly_tgs_connected s = (leak s e\<^sub>x e\<^sub>y \<or> leak s e\<^sub>y e\<^sub>x)"
  by (simp add: directly_tgs_connected_def)

abbreviation
  in_directly_tgs_connected :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" ("_ \<turnstile> _ \<leftrightarrow> _" [60,0,60] 61)
where
  "s \<turnstile> x \<leftrightarrow> y \<equiv> (x,y) \<in> directly_tgs_connected s"

definition
  tgs_connected :: "state \<Rightarrow> (entity_id \<times> entity_id) set" where
  "tgs_connected s \<equiv> (directly_tgs_connected s)\<^sup>*"

abbreviation
  in_tgs_connected :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" ("_ \<turnstile> _ \<leftrightarrow>* _" [60,0,60] 61)
where
  "s \<turnstile> x \<leftrightarrow>* y == (x,y) \<in> tgs_connected s"

notation (latex output)
  in_tgs_connected ("_ \<turnstile> _ \<leftrightarrow>\<^sup>* _" [60,0,60] 61)

translations
  "\<not> (s \<turnstile> x \<leftrightarrow> y)" <= "(x,y) \<notin> CONST directly_tgs_connected s"
  "\<not> (s \<turnstile> x \<leftrightarrow>* y)" <= "(x,y) \<notin> CONST tgs_connected s"

lemma shares_caps_sym [simp]:
 "shares_caps s y x = shares_caps s x y"
  by (auto simp: shares_caps_def)

lemma directly_tgs_connected_def4:
  "s \<turnstile> e\<^sub>x \<leftrightarrow> e\<^sub>y = (take_cap e\<^sub>x \<in>cap caps_of s e\<^sub>y \<or> take_cap e\<^sub>y \<in>cap caps_of s e\<^sub>x \<or>
                  grant_cap e\<^sub>y \<in>cap caps_of s e\<^sub>x \<or> grant_cap e\<^sub>x \<in>cap caps_of s e\<^sub>y \<or>
                  shares_caps s e\<^sub>x e\<^sub>y)"
  by (auto simp: directly_tgs_connected_def leak_def)

(* Note: e\<^sub>0 is unused. *)
definition
  generalOperation ::
  "entity_id \<Rightarrow> entity_id \<Rightarrow> cap \<Rightarrow> right set \<Rightarrow> modify_state" where
  "generalOperation e\<^sub>0 e\<^sub>1 c r s \<equiv>
  s (e\<^sub>1 \<mapsto> Entity ( insert (diminish r (extra_rights c)) (direct_caps_of s e\<^sub>1) ))"

lemma is_entity_general [simp]:
  "is_entity s e\<^sub>1 \<Longrightarrow> is_entity (generalOperation e\<^sub>0 e\<^sub>1 c r s) e' = is_entity s e'"
  by (simp add: is_entity_def generalOperation_def)

definition
  make_entity :: "entity_id \<Rightarrow> modify_state" where
  "make_entity n s \<equiv>
  s (n \<mapsto> null_entity)"

lemma direct_caps_of_store_connected_eq:
  "\<forall> e. direct_caps_of s e = direct_caps_of s' e
  \<Longrightarrow> store_connected s = store_connected s'"
  by (simp add: store_connected_def store_connected_direct_def
                direct_caps_of_def)

lemma direct_caps_of_caps_of_eq:
  "\<forall> e. direct_caps_of s e = direct_caps_of s' e \<Longrightarrow> caps_of s e = caps_of s' e"
  by (simp add: caps_of_def store_connected_def store_connected_direct_def
                direct_caps_of_def)

lemma direct_caps_of_caps_of_eq2:
  "\<lbrakk>\<forall> e. direct_caps_of s e = direct_caps_of s' e; c \<in>cap caps_of s e\<rbrakk> \<Longrightarrow> c \<in>cap caps_of s' e"
  apply (drule direct_caps_of_caps_of_eq)
  apply (simp add: cap_in_caps_def)
  by auto

lemma direct_caps_of_directly_tgs_connected_eq:
  "\<forall> e. direct_caps_of s e = direct_caps_of s' e \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y = s' \<turnstile> x \<leftrightarrow> y"
  apply (simp add: directly_tgs_connected_def4 shares_caps_def)
  apply rule
   apply (erule disjE, drule (1) direct_caps_of_caps_of_eq2, clarsimp)+
   apply (drule direct_caps_of_store_connected_eq, clarsimp)
  apply (erule disjE, drule direct_caps_of_caps_of_eq2 [rotated, where s=s' and s'=s], simp+)+
  apply (drule direct_caps_of_store_connected_eq, simp)
  done

lemma direct_caps_of_make_entity:
  "\<not> is_entity s n \<Longrightarrow> direct_caps_of (make_entity n s) e = direct_caps_of s e"
  by (simp add: direct_caps_of_def make_entity_def is_entity_def
                null_entity_def)

lemma caps_of_make_entity:
  "\<not> is_entity s n \<Longrightarrow> caps_of (make_entity n s) e = caps_of s e"
  apply (rule direct_caps_of_caps_of_eq)
  apply clarsimp
  apply (erule direct_caps_of_make_entity)
  done

lemma caps_of_make_entity2:
  "\<lbrakk>\<not> is_entity s n; c \<in> caps_of (make_entity n s) e\<rbrakk> \<Longrightarrow> c \<in> caps_of s e"
  apply (drule caps_of_make_entity)
  apply fastforce
  done

lemma directly_tgs_connected_make_entity:
 "\<not> is_entity s n \<Longrightarrow> make_entity n s \<turnstile> x \<leftrightarrow> y = s \<turnstile> x \<leftrightarrow> y"
  apply (rule direct_caps_of_directly_tgs_connected_eq)
  apply clarsimp
  apply (drule (1) direct_caps_of_make_entity)
  done

lemma directly_tgs_connected_make_entity2:
 "\<lbrakk>\<not> is_entity s n; make_entity n s \<turnstile> x \<leftrightarrow> y\<rbrakk> \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  apply (drule directly_tgs_connected_make_entity)
  apply fastforce
  done

lemma diminish_extra_rights [simp]:
  "diminish (rights c) (extra_rights c) = c"
  by (simp add: diminish_def all_rights_def rights_extra_rights)

lemma diminish_extra_rights2 [simp]:
  "diminish (r \<inter> rights c) (extra_rights c) = diminish r c"
  apply (simp add: diminish_def extra_rights_def all_rights_def)
  apply (simp add: Int_commute)
  apply (subgoal_tac "rights c \<inter> (r \<inter> rights c) = r \<inter> rights c")
   apply simp
  apply fastforce
  done

lemma create_general_helper:
  "Create \<in> rights c\<^sub>2 \<Longrightarrow>
   \<lparr>target = target c\<^sub>2, rights = UNIV\<rparr> = c\<^sub>2\<lparr>rights := UNIV\<rparr>"
  by auto

lemma extra_rights_full_cap [simp]:
  "extra_rights (full_cap e) = full_cap e"
  by (simp add: extra_rights_def)

lemma create_general_alt:
  "createOperation e c\<^sub>1 c\<^sub>2 s =
   make_entity (target c\<^sub>2)
               (generalOperation  e (target c\<^sub>1) (full_cap (target c\<^sub>2)) (all_rights) s)"
  by (simp add: createOperation_def generalOperation_def make_entity_def)

lemma create_general:
  "Create \<in> rights c\<^sub>2 \<Longrightarrow> createOperation e c\<^sub>1 c\<^sub>2 s =
   make_entity (target c\<^sub>2)
               (generalOperation  e (target c\<^sub>1) c\<^sub>2 (all_rights) s)"
  by (simp add: createOperation_def generalOperation_def make_entity_def
                full_cap_def all_rights_def diminish_def
                extra_rights_def create_general_helper null_entity_def)

lemma take_general:
  "takeOperation e c\<^sub>1 c\<^sub>2 r s =
   generalOperation (target c\<^sub>1) e c\<^sub>2 (r \<inter> rights c\<^sub>2) s"
  by (simp add: takeOperation_def generalOperation_def)

lemma grant_general:
  "grantOperation e c\<^sub>1 c\<^sub>2 r s =
   generalOperation e (target c\<^sub>1) c\<^sub>2 (r \<inter> rights c\<^sub>2) s"
  by (simp add: grantOperation_def generalOperation_def)

lemma copy_general:
  "copyOperation e c\<^sub>1 c\<^sub>2 r s =
   generalOperation e (target c\<^sub>1) c\<^sub>2 (r \<inter> rights c\<^sub>2) s"
  by (simp add: copyOperation_def generalOperation_def)

(* Lemmas on the directly_tgs_connected predicate *)
lemma directly_tgs_connected_comm:
  "s \<turnstile> x \<leftrightarrow> y \<Longrightarrow> s \<turnstile> y \<leftrightarrow> x"
  by(auto simp: directly_tgs_connected_def)

lemma tgs_connected_refl [simp]:
  "s \<turnstile> x \<leftrightarrow>* x"
  by (metis tgs_connected_def rtrancl.rtrancl_refl)

lemma tgs_connected_comm:
  "s \<turnstile> x \<leftrightarrow>* y \<Longrightarrow> s \<turnstile> y \<leftrightarrow>* x"
  apply(simp add: tgs_connected_def)
  apply(erule rtrancl_induct, simp)
  apply(case_tac "s \<turnstile> z \<leftrightarrow> y")
   apply(simp add: directly_tgs_connected_comm)
  apply(simp add: directly_tgs_connected_comm)
  done

lemma tgs_connected_comm_eq:
  "s \<turnstile> x \<leftrightarrow>* y = s \<turnstile> y \<leftrightarrow>* x"
  by (metis tgs_connected_comm)

lemmas tgs_connected_trans =
       rtrancl_trans [where r="directly_tgs_connected s", simplified tgs_connected_def[symmetric]]

lemmas directly_tgs_connected_rtrancl_into_rtrancl =
       rtrancl_into_rtrancl [where r="directly_tgs_connected s", simplified tgs_connected_def[symmetric]]

lemma take_caps_directly_tgs_connected:
  "\<lbrakk>c \<in> caps_of s e; Take \<in> rights c\<rbrakk> \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c"
  by (auto simp: directly_tgs_connected_def leak_def take_cap_def cap_in_caps_def extra_rights_def all_rights_def)

lemma grant_caps_directly_tgs_connected:
  "\<lbrakk>c \<in> caps_of s e; Grant \<in> rights c\<rbrakk> \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c"
  by (auto simp: directly_tgs_connected_def leak_def grant_cap_def cap_in_caps_def extra_rights_def all_rights_def)

lemma create_caps_directly_tgs_connected:
  "\<lbrakk>c \<in> caps_of s e; Create \<in> rights c\<rbrakk> \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c"
  by (auto simp: directly_tgs_connected_def leak_def cap_in_caps_def rights_extra_rights all_rights_def)

lemma store_connected_directly_tgs_connected:
  "(x, y) \<in> store_connected s \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  by (auto simp: directly_tgs_connected_def leak_def shares_caps_def store_connected_def)

(* Lemmas on caps *)

lemma cap_in_caps_insert [simp]:
  "c \<in>cap insert c' S = (target c = target c' \<and>
  rights (extra_rights c) \<subseteq> rights (extra_rights c') \<or> c \<in>cap S)"
  by (simp add: cap_in_caps_def)

lemma cap_in_caps_singleton [simp]:
  "c \<in>cap {c'} = (target c = target c' \<and> rights (extra_rights c) \<subseteq> rights (extra_rights c'))"
  by (simp add: cap_in_caps_def)

lemma not_in [simp]:
  "{} \<le>cap c"
  by(simp add: caps_dominated_by_def)

lemma extra_rights_diminish:
  "x \<in> rights (extra_rights (diminish r c))
   \<Longrightarrow> x \<in> rights (extra_rights c)"
  by (auto simp: rights_extra_rights all_rights_def split:if_split_asm)

(* Lemmas on system operations *)

definition
  in_store_connected :: "state \<Rightarrow> entity_id \<Rightarrow> entity_id \<Rightarrow> bool" where
  "in_store_connected s x y \<equiv> (x, y) \<in> store_connected s"

(* Lemmas about the general operation *)

lemma direct_caps_of_generalOp:
  "direct_caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) e =
  (if e = e\<^sub>1
   then insert (diminish r (extra_rights c)) (direct_caps_of s (e\<^sub>1))
   else direct_caps_of s e)"
  by (clarsimp simp: generalOperation_def direct_caps_of_def split:option.splits)

lemma direct_caps_of_generalOp2:
  "\<lbrakk>c' \<in> direct_caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x\<rbrakk> \<Longrightarrow>
   c' \<in> direct_caps_of s x \<or> (c' \<in>cap {c} \<and> x = e\<^sub>1)"
  apply (clarsimp simp: direct_caps_of_generalOp extra_rights_diminish
           split:if_split_asm)
  apply (drule extra_rights_diminish)
  by simp

lemma store_connected_direct_generalOp:
  "\<lbrakk>(x, y) \<in> store_connected_direct (generalOperation e\<^sub>0 e\<^sub>1 c r s)\<rbrakk> \<Longrightarrow>
   (x, y) \<in> store_connected_direct s \<or>
   (x = e\<^sub>1 \<and> y = target c \<and> Store \<in> rights (extra_rights c))"
  by (auto simp: store_connected_direct_def direct_caps_of_generalOp all_rights_def
          split: if_split_asm)

lemma store_connected_generalOp:
  "\<lbrakk>(x, y) \<in> store_connected (generalOperation e\<^sub>0 e\<^sub>1 c r s)\<rbrakk> \<Longrightarrow>
   (x, y) \<in> store_connected s \<or>
   ((x, e\<^sub>1) \<in> store_connected s \<and>
   (e\<^sub>1, target c) \<in> store_connected_direct (generalOperation e\<^sub>0 e\<^sub>1 c r s) \<and>
   (target c, y) \<in> store_connected s)"
  apply (unfold store_connected_def)
  apply (erule rtrancl_induct)
   apply clarsimp
  apply (clarsimp)
  apply (fold store_connected_def)
  apply (subgoal_tac "(y, z) \<in> store_connected_direct s")
   apply (clarsimp simp: store_connected_def)
   apply (erule disjE)
    apply fastforce
   apply clarsimp
   apply (erule notE)
   apply fastforce
  apply (frule store_connected_direct_generalOp)
  apply (clarsimp simp: store_connected_def)
  done

lemma store_connected_generalOp_not_new:
  "\<lbrakk>(e\<^sub>1, target c) \<in> store_connected_direct (generalOperation e\<^sub>0 e\<^sub>1 c r s);
   c \<in> caps_of s e\<^sub>0\<rbrakk> \<Longrightarrow>
   (e\<^sub>1, target c) \<in> store_connected_direct s \<or>
   (e\<^sub>0, target c) \<in> store_connected s \<or>
   Create \<in> rights c"
  apply (drule store_connected_direct_generalOp)
  apply (clarsimp simp: rights_extra_rights split:if_split_asm)
   apply (drule (1) store_caps_store_connected, simp)
  done

lemma store_connected_generalOp2:
  "\<lbrakk>(x, y) \<in> store_connected (generalOperation e\<^sub>0 e\<^sub>1 c r s);
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk> \<Longrightarrow>
   s \<turnstile> x \<leftrightarrow>* y"
  apply (drule store_connected_generalOp)
  apply (erule disjE)
   apply (simp add: tgs_connected_def)
   apply (drule store_connected_directly_tgs_connected, simp)
  apply clarsimp
  apply (drule store_connected_directly_tgs_connected [where x=x and y=e\<^sub>1])
  apply (drule store_connected_directly_tgs_connected [where x="target c" and y=y])
  apply (drule (1) store_connected_generalOp_not_new)
  apply (erule disjE)
   apply (drule store_connected_direct_in_store_connected)
   apply (drule store_connected_directly_tgs_connected [where x=e\<^sub>1 and y="target c"])
   apply (simp add: tgs_connected_def)
  apply (drule directly_tgs_connected_comm [where x="e\<^sub>0" and y="e\<^sub>1"])
  apply (erule disjE)
   apply (drule store_connected_directly_tgs_connected [where x=e\<^sub>0 and y="target c"])
   apply (simp add: tgs_connected_def)
  apply (drule (1) create_caps_directly_tgs_connected)
  apply (simp add: tgs_connected_def)
  done

lemma shares_caps_of_generalOp:
  "\<lbrakk>shares_caps (generalOperation e\<^sub>0 e\<^sub>1 c r s) x y;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (clarsimp simp: shares_caps_def)
  apply (frule (2) store_connected_generalOp2 [where x=x])
  apply (drule (2) store_connected_generalOp2 [where x=y])
  apply (drule tgs_connected_comm [where x=y])
  apply (simp add: tgs_connected_def)
  done

lemma caps_of_generalOp:
  "\<lbrakk>c' \<in> caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (simp add: caps_of_def[where e=x])
  apply clarsimp
  apply (frule (2) store_connected_generalOp2)
  apply (drule direct_caps_of_generalOp2)
  apply (erule disjE)
   apply (drule direct_cap_in_cap)
   apply (fastforce simp: cap_in_caps_def)
  apply (subgoal_tac "s \<turnstile> x \<leftrightarrow>* e\<^sub>0")
   apply (subgoal_tac "c' \<in>cap caps_of s e\<^sub>0")
    apply fastforce
   apply (fastforce simp: cap_in_caps_def)
  apply clarsimp
  apply (drule directly_tgs_connected_comm [where x="e\<^sub>0" and y="e\<^sub>1"])
  apply (simp add: tgs_connected_def)
  done

lemma take_cap_generalOp:
  "\<lbrakk>take_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> \<exists>z.  s \<turnstile> x \<leftrightarrow>* z \<and> take_cap y \<in>cap caps_of s z"
  apply (simp add: cap_in_caps_def)
  apply clarsimp
  apply (drule (2) caps_of_generalOp)
  apply (fastforce simp: cap_in_caps_def)
  done

lemma grant_cap_generalOp:
  "\<lbrakk>grant_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> \<exists>z.  s \<turnstile> x \<leftrightarrow>* z \<and> grant_cap y \<in>cap caps_of s z"
  apply (simp add: cap_in_caps_def)
  apply clarsimp
  apply (drule (2) caps_of_generalOp)
  apply (fastforce simp: cap_in_caps_def)
  done

lemma take_cap_generalOp2:
  "\<lbrakk>take_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply (drule (2) take_cap_generalOp)
  apply clarsimp
  apply (subgoal_tac "s \<turnstile> z \<leftrightarrow> y")
   apply (simp add: tgs_connected_def)
  apply (simp add: directly_tgs_connected_def leak_def)
  done

lemma grant_cap_generalOp2:
  "\<lbrakk>grant_cap y \<in>cap caps_of (generalOperation e\<^sub>0 e\<^sub>1 c r s) x;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply (drule (2) grant_cap_generalOp)
  apply clarsimp
  apply (subgoal_tac "s \<turnstile> z \<leftrightarrow> y")
   apply (simp add: tgs_connected_def)
  apply (simp add: directly_tgs_connected_def leak_def)
  done

lemma generalOp_directly_tgs_connected:
 "\<lbrakk>generalOperation e\<^sub>0 e\<^sub>1 c r s \<turnstile> x \<leftrightarrow> y;
   c \<in> caps_of s e\<^sub>0; s \<turnstile> e\<^sub>0 \<leftrightarrow> e\<^sub>1\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (simp add: directly_tgs_connected_def [where s="generalOperation e\<^sub>0 e\<^sub>1 c r s"] leak_def)
  apply safe
       apply (rule tgs_connected_comm)
       apply (drule (3) take_cap_generalOp2)
      apply (drule (3) grant_cap_generalOp2)
     apply (erule (2) shares_caps_of_generalOp)
    apply (drule (3) take_cap_generalOp2)
   apply (rule tgs_connected_comm)
   apply (drule (3) grant_cap_generalOp2)
  apply (erule (2) shares_caps_of_generalOp)
  done

(* results from general operation *)

lemma create_legal_directly_tgs_connected:
  "legal (SysCreate e c\<^sub>1 c\<^sub>2) s \<Longrightarrow> s  \<turnstile> target c\<^sub>1 \<leftrightarrow> e"
  apply clarsimp
  apply (rule directly_tgs_connected_comm)
  apply (drule (1) create_caps_directly_tgs_connected)
  apply (drule (1) store_caps_store_connected)
  apply (drule (1) store_connected_directly_tgs_connected)
  done

lemma take_legal_directly_tgs_connected:
  "legal (SysTake e c\<^sub>1 c\<^sub>2 r) s \<Longrightarrow> s  \<turnstile> target c\<^sub>1 \<leftrightarrow> e"
  apply clarsimp
  apply (rule directly_tgs_connected_comm)
  apply (drule (2) take_caps_directly_tgs_connected)
  done

lemma grant_legal_directly_tgs_connected:
  "legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c\<^sub>1"
  apply clarsimp
  apply (drule (2) grant_caps_directly_tgs_connected)
  done

lemma copy_legal_directly_tgs_connected:
  "legal (SysCopy e c\<^sub>1 c\<^sub>2 r) s \<Longrightarrow> s \<turnstile> e \<leftrightarrow> target c\<^sub>1"
  apply clarsimp
  apply (drule (1) store_caps_store_connected)
  apply (drule (1) store_connected_directly_tgs_connected)
  done

lemma caps_of_create:
  "\<lbrakk>c' \<in> caps_of (createOperation e c\<^sub>1 c\<^sub>2 s) x; legal (SysCreate e c\<^sub>1 c\<^sub>2) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule create_legal_directly_tgs_connected)
  apply (clarsimp simp: create_general)
  apply (drule caps_of_make_entity2 [rotated], clarsimp)
  apply (drule (1) caps_of_generalOp)
   apply (drule (2) directly_tgs_connected_comm)
  done

lemma caps_of_take:
  "\<lbrakk>c' \<in> caps_of (takeOperation e c\<^sub>1 c\<^sub>2 r s) x; legal (SysTake e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule take_legal_directly_tgs_connected)
  apply (clarsimp simp: take_general)
  apply (drule (2) caps_of_generalOp)
   apply (drule (1) directly_tgs_connected_comm)
  done

lemma caps_of_grant:
  "\<lbrakk>c' \<in> caps_of (grantOperation e c\<^sub>1 c\<^sub>2 r s) x; legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule grant_legal_directly_tgs_connected)
  apply (clarsimp simp: grant_general)
  apply (drule (2) caps_of_generalOp)
   apply (drule (1) directly_tgs_connected_comm)
  done

lemma caps_of_copy:
  "\<lbrakk>c' \<in> caps_of (copyOperation e c\<^sub>1 c\<^sub>2 r s) x; legal (SysCopy e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> \<exists>z. (x,z) \<in> tgs_connected s \<and> c' \<in>cap caps_of s z"
  apply (frule copy_legal_directly_tgs_connected)
  apply (clarsimp simp: copy_general)
  apply (drule (2) caps_of_generalOp)
   apply (drule (1) directly_tgs_connected_comm)
  done

lemma create_directly_tgs_connected:
 "\<lbrakk>createOperation e c\<^sub>1 c\<^sub>2 s \<turnstile> x \<leftrightarrow> y; legal (SysCreate e c\<^sub>1 c\<^sub>2) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule create_legal_directly_tgs_connected)
  apply (clarsimp simp: create_general)
  apply (drule directly_tgs_connected_make_entity2 [rotated], clarsimp)
  apply (drule (1) generalOp_directly_tgs_connected)
   apply (drule (2) directly_tgs_connected_comm)
  done

lemma take_directly_tgs_connected:
 "\<lbrakk>takeOperation e c\<^sub>1 c\<^sub>2 r s \<turnstile> x \<leftrightarrow> y; legal (SysTake e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule take_legal_directly_tgs_connected)
  apply (clarsimp simp: take_general)
  apply (drule (3) generalOp_directly_tgs_connected)
  done

lemma grant_directly_tgs_connected:
 "\<lbrakk>grantOperation e c\<^sub>1 c\<^sub>2 r s \<turnstile> x \<leftrightarrow> y; legal (SysGrant e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule grant_legal_directly_tgs_connected)
  apply (clarsimp simp: grant_general)
  apply (drule (3) generalOp_directly_tgs_connected)
  done

lemma copy_directly_tgs_connected:
 "\<lbrakk>copyOperation e c\<^sub>1 c\<^sub>2 r s \<turnstile> x \<leftrightarrow> y; legal (SysCopy e c\<^sub>1 c\<^sub>2 r) s\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* y"
  apply (frule copy_legal_directly_tgs_connected)
  apply (clarsimp simp: copy_general)
  apply (drule (3) generalOp_directly_tgs_connected)
  done

lemma create_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysCreate e c\<^sub>1 c\<^sub>2)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule create_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

lemma take_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysTake e c\<^sub>1 c\<^sub>2 r)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule take_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

lemma grant_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysGrant e c\<^sub>1 c\<^sub>2 r)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule grant_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

lemma copy_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysCopy e c\<^sub>1 c\<^sub>2 r)\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
   apply (erule disjE, fastforce simp: tgs_connected_def, clarsimp)
   apply (drule copy_directly_tgs_connected, clarsimp, assumption)
  apply (simp add: tgs_connected_def)
  done

(* Lemmas about destroy *)

lemma direct_caps_of_destroy:
  "c \<in> direct_caps_of (s(e := None)) x \<Longrightarrow> c \<in> direct_caps_of s x"
  by (simp add: direct_caps_of_def split: option.splits split: if_split_asm)

lemma store_connected_destroy:
 "(x, y) \<in> store_connected (s(e := None)) \<Longrightarrow> (x, y) \<in> store_connected s"
  apply (simp add: store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply (fold store_connected_def)
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (fastforce simp: store_connected_def)
  apply (simp add: store_connected_direct_def)
  apply clarsimp
  by (metis direct_caps_of_destroy)

lemma shares_caps_destroy:
  "shares_caps (destroyOperation e c s) x y
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def destroyOperation_def)
  apply (frule store_connected_destroy [where x=x])
  apply (drule store_connected_destroy [where x=y])
  by auto

lemma caps_of_destroy:
  "c \<in> caps_of (destroyOperation e' c' s) e \<Longrightarrow>
  c \<in> caps_of s e"
  apply (clarsimp simp add: destroyOperation_def caps_of_def)
  apply (rule_tac x=x in exI)
  apply (drule direct_caps_of_destroy)
  apply simp
  apply (erule store_connected_destroy)
  done

lemma destroy_directly_tgs_connected:
  "\<lbrakk>s' \<in> step (SysDestroy e c) s; (x, y) \<in> directly_tgs_connected s'\<rbrakk> \<Longrightarrow>
  (x, y) \<in> directly_tgs_connected s"
  apply(clarsimp simp: step_def split: if_split_asm)
  apply(erule disjE, simp)
  apply(simp add: directly_tgs_connected_def leak_def)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (erule disjE)
   apply (drule shares_caps_destroy, simp)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (erule disjE)
   apply(fastforce simp add: cap_in_caps_def dest!: caps_of_destroy)
  apply (drule shares_caps_destroy, simp)
  done

lemma destroy_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysDestroy e c)\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  by(auto dest!: destroy_directly_tgs_connected)

(* lemmas about remove *)

lemma direct_caps_of_remove:
  "c \<in> direct_caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x \<Longrightarrow>
  c \<in> direct_caps_of s x"
  by (clarsimp simp: removeOperation_simpler direct_caps_of_def
              split: option.splits if_split_asm)

lemma direct_caps_of_remove_eq:
  "direct_caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x =
  ( if   is_entity s (target c\<^sub>1) \<and> x = target c\<^sub>1
   then  direct_caps_of s (target c\<^sub>1) - {c\<^sub>2}
   else  direct_caps_of s x )"
  by(simp add: direct_caps_of_def is_entity_def removeOperation_def)

lemma store_connected_remove [rule_format]:
  "(x, y) \<in> store_connected (s(e \<mapsto> Entity C')) \<Longrightarrow>
  s e = Some (Entity C) \<longrightarrow> C' \<subseteq> C \<longrightarrow> (x, y) \<in> store_connected s"
  apply (unfold store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply clarsimp
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (erule rtrancl_trans)
   apply fastforce
  apply (fold store_connected_def)
  apply (clarsimp simp add: store_connected_direct_def)
  apply (fastforce simp: direct_caps_of_def
                  split: option.splits if_split_asm)
  done

lemma caps_of_remove:
  "c \<in> caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x \<Longrightarrow>
  c \<in> caps_of s x"
  apply (clarsimp simp: caps_of_def)
  apply (rule_tac x=xa in exI)
  apply (drule direct_caps_of_remove)
  apply (simp add: removeOperation_simpler
            split: option.splits)
  apply (erule (1) store_connected_remove)
  apply blast
  done

(* Might equal either  "caps s (target c\<^sub>1) - {c\<^sub>2}" or "caps s x" depending if the caps are duplicated.*)
lemma caps_of_remove2:
  "caps_of (removeOperation e c\<^sub>1 c\<^sub>2 s) x \<subseteq> caps_of s x"
  apply(simp add: caps_of_def is_entity_def removeOperation_def direct_caps_of_def)
  apply (clarsimp split: if_split_asm)
   apply (auto dest!: store_connected_remove)
  done

lemma shares_caps_remove:
  "shares_caps (removeOperation e c\<^sub>1 c\<^sub>2 s) x y
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def removeOperation_simpler
                 split:option.splits)
  apply (frule (1) store_connected_remove [where x=x], clarsimp)
  apply (drule (1) store_connected_remove [where x=y], clarsimp)
  by auto

lemma remove_directly_tgs_connected:
  "\<lbrakk>s' \<in> step (SysRemove e c\<^sub>1 c\<^sub>2) s; (x, y) \<in> directly_tgs_connected s'\<rbrakk> \<Longrightarrow>
  (x, y) \<in> directly_tgs_connected s"
  apply(simp add: step_def split: if_split_asm)
  apply(erule disjE, simp)
  apply(simp add: directly_tgs_connected_def leak_def)
  apply(simp add: cap_in_caps_def)
  apply(clarsimp)
  apply safe
     prefer 3
     apply (drule shares_caps_remove, simp)
    prefer 5
    apply (drule shares_caps_remove, simp)
   apply(auto dest!: caps_of_remove)
  done

lemma remove_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysRemove e c\<^sub>1 c\<^sub>2)\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  by(auto dest!: remove_directly_tgs_connected)

lemma direct_caps_of_removeSet:
  "c' \<in> direct_caps_of (removeSetOperation e c C s) x \<Longrightarrow>
  c' \<in> direct_caps_of s x"
  by (clarsimp simp: removeSetOperation_simpler direct_caps_of_def
              split: option.splits if_split_asm)

lemma caps_of_removeSet:
  "c' \<in> caps_of (removeSetOperation e c C s) x \<Longrightarrow>
  c' \<in> caps_of s x"
  apply (clarsimp simp: caps_of_def)
  apply (rule_tac x=xa in exI)
  apply (drule direct_caps_of_removeSet)
  apply (simp add: removeSetOperation_simpler split: option.splits)
  apply (erule (1) store_connected_remove)
  apply blast
  done

lemma shares_caps_removeSet:
  "shares_caps (removeSetOperation e c C s) x y
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def removeSetOperation_simpler split:option.splits)
  apply (frule (1) store_connected_remove [where x=x], clarsimp)
  apply (drule (1) store_connected_remove [where x=y], clarsimp)
  by auto

lemma removeSet_connected:
  " \<lbrakk>s' \<in> step (SysRemoveSet e c C) s; s' \<turnstile> x \<leftrightarrow> y\<rbrakk> \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  apply(simp add: step_def split: if_split_asm)
  apply(erule disjE, simp)
  apply(simp add: directly_tgs_connected_def leak_def)
  apply(simp add: cap_in_caps_def)
  apply(clarsimp)
  apply safe
     prefer 3
     apply (drule shares_caps_removeSet, simp)
    prefer 5
    apply (drule shares_caps_removeSet, simp)
   apply (auto dest!: caps_of_removeSet)
  done

lemma removeSet_conTrans:
  "\<lbrakk>s' \<in> step cmd s; s' \<turnstile> x \<leftrightarrow> y; cmd = (SysRemoveSet n c C)\<rbrakk>
  \<Longrightarrow> s \<turnstile> x \<leftrightarrow> y"
  by(auto dest!: removeSet_connected)

(* lemmas about revoke *)
lemma direct_caps_of_removeSetOfCaps:
  "c' \<in> direct_caps_of (removeSetOfCaps cap_map s) x \<Longrightarrow>
  c' \<in> direct_caps_of s x"
  by (clarsimp simp: removeSetOfCaps_def direct_caps_of_def
              split: option.splits if_split_asm)
thm store_connected_remove

lemma store_connected_removeSetOfCaps:
  "(x, y) \<in> store_connected (\<lambda>e. if is_entity s e
                                 then Some (Entity (direct_caps_of s e - cap_map e))
                                 else None) \<Longrightarrow>
    (x, y) \<in> store_connected s"
  apply (unfold store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (erule rtrancl_trans)
   apply fastforce
  apply (fold store_connected_def)
  apply (clarsimp simp add: store_connected_direct_def)
  apply (fastforce simp: direct_caps_of_def
                  split: option.splits if_split_asm)
  done

lemma caps_of_removeSetOfCaps:
  "c' \<in> caps_of (removeSetOfCaps cap_map s) x \<Longrightarrow>
  c' \<in> caps_of s x"
  apply (clarsimp simp: caps_of_def)
  apply (rule_tac x=xa in exI)
  apply (drule direct_caps_of_removeSetOfCaps)
  apply (simp add: removeSetOfCaps_def split: option.splits)
  apply (erule store_connected_removeSetOfCaps)
  done

lemma caps_of_revoke:
  "\<lbrakk>s' \<in> revokeOperation sub c\<^sub>1 s ;  c \<in> caps_of s' e \<rbrakk>
  \<Longrightarrow> c \<in> caps_of s e"
  apply (clarsimp simp: revokeOperation_def
                 split: if_split_asm)
  apply (drule (1) caps_of_removeSetOfCaps)
  done

lemma direct_caps_of_revoke:
  "\<lbrakk>s' \<in> revokeOperation e c s; c' \<in> direct_caps_of s' x\<rbrakk>
   \<Longrightarrow> c' \<in> direct_caps_of s x"
  apply (clarsimp simp: revokeOperation_def
                 split: if_split_asm)
  apply (drule (1) direct_caps_of_removeSetOfCaps)
  done

lemma store_connected_revoke:
 "\<lbrakk>(x, y) \<in> store_connected s'; s' \<in> revokeOperation e c s\<rbrakk>
  \<Longrightarrow> (x, y) \<in> store_connected s"
  apply (simp add: store_connected_def)
  apply (erule rtrancl_induct)
   apply simp
  apply (fold store_connected_def)
  apply (subgoal_tac "(y,z) \<in> store_connected_direct s")
   apply (fastforce simp: store_connected_def)
  apply (clarsimp simp: store_connected_direct_def)
  apply (metis direct_caps_of_revoke)
  done

lemma shares_caps_revoke:
  "\<lbrakk>shares_caps s' x y; s' \<in> revokeOperation e c s\<rbrakk>
  \<Longrightarrow> shares_caps s x y"
  apply (clarsimp simp: shares_caps_def)
  apply (frule (1) store_connected_revoke [where x=x])
  apply (drule (1) store_connected_revoke [where x=y])
  by auto

lemma removeOperation_entity_ids [simp]:
  "is_entity (removeOperation e c c' s) e' = is_entity s e'"
  by (simp add: is_entity_def removeOperation_def)

lemma removeSetOfCaps_entity_ids [simp]:
  "is_entity (removeSetOfCaps cap_map s) e' = is_entity s e'"
  by (simp add: is_entity_def removeSetOfCaps_def)

lemma revoke_entities:
  "s' \<in> revokeOperation sub c\<^sub>1 s \<Longrightarrow> is_entity s' e = is_entity s e"
  by (clarsimp simp: revokeOperation_def split: if_split_asm)

lemma revoke_directly_tgs_connected:
  "\<lbrakk>s' \<in> step (SysRevoke n c\<^sub>1) s; (x, y) \<in> directly_tgs_connected s'\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  apply (simp add: step_def split: if_split_asm)
  apply (erule disjE, simp)
  apply (simp add: directly_tgs_connected_def leak_def)
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (erule disjE)
   apply (drule (1) shares_caps_revoke, simp)
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (erule disjE)
   apply(auto simp add: cap_in_caps_def dest!: caps_of_revoke)[1]
  apply (drule (1) shares_caps_revoke, simp)
  done

lemma revoke_conTrans:
  "\<lbrakk>s' \<in> step cmd s; (x, y) \<in> directly_tgs_connected s'; cmd = (SysRevoke n c\<^sub>1)\<rbrakk>
  \<Longrightarrow> (x, y) \<in>  directly_tgs_connected s"
  by(auto dest!: revoke_directly_tgs_connected)

(* lemmas about grant *)

lemma is_entity_grant [simp]:
  "is_entity s (target c\<^sub>1) \<Longrightarrow>
  is_entity (grantOperation e c\<^sub>1 c\<^sub>2 r s) e' = is_entity s e'"
  by (simp add: is_entity_def grantOperation_def)

lemma is_entity_destroy:
  "is_entity (destroyOperation e' c s) e \<Longrightarrow> is_entity s e"
  by (simp add: destroyOperation_def is_entity_def split: if_split_asm)

(********************************************
 ********************************************
 ***** Connected transitively preserved *****
 ********************************************
 ********************************************)

lemma connected_tgs_connected:
  "\<lbrakk>s' \<in> step cmd s; (e\<^sub>x, e\<^sub>y) \<in> directly_tgs_connected s'\<rbrakk> \<Longrightarrow>
  (e\<^sub>x, e\<^sub>y) \<in> tgs_connected s"
  apply(case_tac "(e\<^sub>x, e\<^sub>y) \<in> directly_tgs_connected s")
   apply(simp add: tgs_connected_def)
   apply(case_tac cmd)
         apply(rule create_conTrans, fastforce+)
        apply(rule take_conTrans, fastforce+)
       apply(rule grant_conTrans, fastforce+)
      apply(frule copy_conTrans, fastforce+)
     apply(frule remove_conTrans, fastforce+)
    apply(frule removeSet_conTrans, fastforce+)
   apply(frule revoke_conTrans, fastforce+)
  apply(frule destroy_conTrans, fastforce+)
  done

lemma tgs_connected_preserved_step:
  "\<lbrakk>s' \<in> step cmd s; s' \<turnstile> x \<leftrightarrow>* z\<rbrakk> \<Longrightarrow> s \<turnstile> x \<leftrightarrow>* z"
  thm rtrancl_induct [where r="directly_tgs_connected s'" and a=x and b=z and P="\<lambda>z. (x, z) \<in> (directly_tgs_connected s)\<^sup>*", simplified,
                      simplified tgs_connected_def [symmetric]]
  apply(erule rtrancl_induct [where r="directly_tgs_connected s'",
                              simplified tgs_connected_def [symmetric]], simp)
  apply(case_tac "s \<turnstile> y \<leftrightarrow>* z")
   apply (erule (1) tgs_connected_trans)
  apply (simp add: connected_tgs_connected)
  done

lemma leakImplyConnected:
  "leak s\<^sub>i e\<^sub>x e\<^sub>i \<Longrightarrow> (e\<^sub>x, e\<^sub>i) \<in> directly_tgs_connected s\<^sub>i"
 by(simp add: directly_tgs_connected_def)

lemma leakImplyConnectedTrans:
  "leak s\<^sub>i e\<^sub>x e\<^sub>i \<Longrightarrow> (e\<^sub>x, e\<^sub>i) \<in> tgs_connected s\<^sub>i"
  by(simp add: tgs_connected_def, frule leakImplyConnected, auto)

lemma tgs_connected_preserved [rule_format]:
  "\<forall>s'. s' \<in> execute cmds s \<longrightarrow>
    s' \<turnstile> x \<leftrightarrow>* y \<longrightarrow>
    s \<turnstile> x \<leftrightarrow>* y"
  apply(induct_tac cmds, simp)
  apply clarsimp
  apply(rename_tac cmd cmds s'' s')
  apply(erule_tac x=s' in allE)
  apply(simp add: tgs_connected_preserved_step)
  done

lemma leak_conTrans [rule_format]:
  "\<lbrakk>s \<in> execute cmds s\<^sub>0; leak s x y\<rbrakk>
  \<Longrightarrow> (x, y) \<in> tgs_connected s\<^sub>0"
  by (auto intro: leakImplyConnectedTrans tgs_connected_preserved)

lemma leakage_rule:
  "\<lbrakk>s' \<in> execute cmds s; \<not> s \<turnstile> x \<leftrightarrow>* y\<rbrakk> \<Longrightarrow> \<not> (s' \<turnstile> x \<rightarrow> y)"
  by(auto simp add: leak_conTrans)

(*******************************************
 *******************************************
 *****      Authority confinement     *****
 *******************************************
 *******************************************)

lemma caps_of_op:
  "\<lbrakk>s' \<in> step cmd s; c' \<in> caps_of s' x\<rbrakk>
  \<Longrightarrow> \<exists>z. s \<turnstile> x \<leftrightarrow>* z \<and> c' \<in>cap caps_of s z"
  apply (simp add: step_def split:if_split_asm)
   prefer 2
   apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  apply (erule disjE)
   apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  apply (case_tac cmd)
         apply (simp add: caps_of_create)
        apply (simp add: caps_of_take)
       apply (simp add: caps_of_grant)
      apply (simp add: caps_of_copy)
     apply (clarsimp, drule caps_of_remove)
     apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
    apply (clarsimp, drule caps_of_removeSet)
    apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
   apply (clarsimp, drule (1) caps_of_revoke)
   apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  apply (clarsimp, drule caps_of_destroy)
  apply (fastforce simp: cap_in_caps_def tgs_connected_def rights_extra_rights)
  done

lemma authority_confinement_induct_step:
  "\<lbrakk>s' \<in> step cmd s;
    \<forall>e\<^sub>i. s \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s e\<^sub>i \<le>cap c\<rbrakk>
  \<Longrightarrow> caps_of s' e\<^sub>x \<le>cap c"
  apply (clarsimp simp: caps_dominated_by_def)
  apply (drule (1) caps_of_op)
  apply (fastforce simp: cap_in_caps_def)
  done

lemma authority_confinement_helper:
  "s' \<in> execute cmds s \<longrightarrow>
   (\<forall>e\<^sub>i. s \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s e\<^sub>i \<le>cap c) \<longrightarrow>
   (\<forall>e\<^sub>i. s' \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s' e\<^sub>i \<le>cap c)"
proof (induct cmds arbitrary: s')
case Nil
  show ?case by clarsimp
next
case (Cons cmd cmds s')
show ?case
  apply clarsimp
  apply (rule authority_confinement_induct_step, assumption)
  apply clarsimp
  apply (rule Cons.hyps[rule_format], simp_all)
  apply (drule(1) tgs_connected_preserved_step)
  apply (simp add: tgs_connected_def)
  done
qed

lemma authority_confinement:
  "\<lbrakk>s' \<in> execute cmds s;
    \<forall>e\<^sub>i. s \<turnstile> e\<^sub>x \<leftrightarrow>* e\<^sub>i \<longrightarrow> caps_of s e\<^sub>i \<le>cap c\<rbrakk>
  \<Longrightarrow> caps_of s' e\<^sub>x \<le>cap c"
  by (erule authority_confinement_helper [rule_format, where e\<^sub>x=e\<^sub>x], simp_all)

end


theory proof_state_facts
imports program_proof_rules_loops
begin

lemma ps_wellFormed_to_wf:
  assumes wf: "proof_state_wellFormed S"
  obtains CS where "proof_state_rel S CS" and "state_wellFormed CS"
  using local.wf proof_state_rel_wf proof_state_wellFormed_def by blast

lemma ps_wellFormed_state_causality:
  assumes wf: "proof_state_wellFormed S"
  shows "causallyConsistent (happensBefore S) (ps_vis S)"
  by (smt FieldI1 FieldI2 Un_iff causallyConsistent_def disjoint_iff_not_equal local.wf proof_state_rel_facts(1) proof_state_rel_hb proof_state_rel_vis proof_state_wellFormed_def proof_state_wellFormed_disjoint_happensBefore_localCalls updateHb_simp2 wf_vis_downwards_closed2)

lemma ps_wellFormed_state_hb_trans:
  assumes wf: "proof_state_wellFormed S"
  shows "trans (happensBefore S)"
  by (smt FieldI2 disjoint_iff_not_equal happensBefore_transitive local.wf proof_state_rel_facts(1) proof_state_rel_hb proof_state_wellFormed_def proof_state_wellFormed_disjoint_happensBefore_localCalls trans_def updateHb_simp2)

lemma ps_localCalls_no_origin:
  assumes wf: "proof_state_wellFormed S"
    and "c \<in> set (ps_localCalls S)"
  shows "callOrigin S c = None"
  by (meson assms(2) disjoint_iff_not_equal domIff local.wf proof_state_rel_callOrigin_localCalls_disjoint ps_wellFormed_to_wf)

lemma ps_not_localCalls_not_tx:
  assumes wf: "proof_state_wellFormed S"
    and "c \<notin> set (ps_localCalls S)"
    and "ps_tx S \<triangleq> tx"
  shows "callOrigin S c \<noteq> Some tx"
  by (metis (mono_tags, lifting) assms(2) assms(3) local.wf map_update_all_get mem_Collect_eq option.simps(5) proof_state_rel_callOrigin proof_state_rel_localCalls ps_wellFormed_to_wf)

lemma rel_callOrigin_vis:
  assumes rel: "proof_state_rel S CS"
    and "c \<in> ps_vis S"
  shows "callOrigin CS c = callOrigin S c"
proof -
  have co: "callOrigin CS = map_update_all (callOrigin S) (ps_localCalls S) (the (ps_tx S))"
    using proof_state_rel_def rel by blast
  show ?thesis
    using `c \<in> ps_vis S`
    by (metis Set.set_insert co disjoint_insert(1) map_update_all_get proof_state_rel_vis_localCalls_disjoint rel)
qed

lemma rel_callOrigin_ls:
  assumes rel: "proof_state_rel S CS"
    and "c \<in> set (ps_localCalls S)"
  shows "callOrigin CS c = ps_tx S"
  using assms(2) map_update_all_Some_same proof_state_rel_callOrigin proof_state_wellFormed_localCalls rel show_proof_state_wellFormed by fastforce

lemma rel_callOrigin_ls_rev:
  assumes rel: "proof_state_rel S CS"
    and "callOrigin CS c \<triangleq> tx"
    and "ps_tx S \<triangleq> tx"
  shows "c \<in> set (ps_localCalls S)"
  by (metis (no_types, lifting) assms(2) assms(3) map_update_all_get proof_state_rel_callOrigin ps_not_localCalls_not_tx rel show_proof_state_wellFormed)

lemma rel_callOrigin_vis2:
  assumes  rel: "proof_state_rel S CS"
    and sameOrigin: "callOrigin S c = callOrigin S c'"
    and \<open>c \<in> ps_vis S\<close>
  shows "callOrigin CS c = callOrigin CS c'"
  by (metis (no_types, lifting) assms(3) map_update_all_get option.distinct(1) proof_state_rel_callOrigin proof_state_rel_calls proof_state_rel_wf proof_state_wellFormed_vis_subset_calls' ps_localCalls_no_origin rel rel_callOrigin_vis sameOrigin show_proof_state_wellFormed wf_callOrigin_and_calls)

lemma ps_wellFormed_state_transaction_consistent1:
  assumes wf: "proof_state_wellFormed S"
    and c_vis: "c\<in>ps_vis S"
    and sameOrigin: "callOrigin S c = callOrigin S c'"
  shows "c'\<in>ps_vis S"
proof (rule ps_wellFormed_to_wf[OF wf])
  fix CS
  assume rel: "proof_state_rel S CS"
    and CS_wf: "state_wellFormed CS"

  have vis: "visibleCalls CS (ps_i S) \<triangleq> (ps_vis S \<union> set (ps_localCalls S))"
    by (simp add: proof_state_rel_vis rel)

  have "c' \<in> (ps_vis S \<union> set (ps_localCalls S))"
    using CS_wf vis
  proof (rule wellFormed_state_transaction_consistent(2))
    show "c \<in> ps_vis S \<union> set (ps_localCalls S)"
      by (simp add: c_vis)
    show "callOrigin CS c = callOrigin CS c'"
      by (smt CS_wf \<open>c \<in> ps_vis S \<union> set (ps_localCalls S)\<close> c_vis disjoint_iff_not_equal in_dom local.wf map_update_all_None map_update_all_get proof_state_rel_callOrigin proof_state_rel_vis_localCalls_disjoint ps_localCalls_no_origin rel sameOrigin vis wellFormed_callOrigin_dom wellFormed_visibleCallsSubsetCalls_h(2))
  qed

  show "c' \<in> ps_vis S"
    by (metis CS_wf UnE \<open>c' \<in> ps_vis S \<union> set (ps_localCalls S)\<close> c_vis local.wf ps_localCalls_no_origin rel rel_callOrigin_vis rel_callOrigin_vis2 sameOrigin vis wellFormed_callOrigin_dom3 wellFormed_visibleCallsSubsetCalls2)

qed

lemma rel_callOrigin_different:
  assumes a0: "callOrigin S x \<noteq> callOrigin S y"
    and wf: "proof_state_wellFormed S"
    and rel: "proof_state_rel S CS"
  shows "callOrigin CS x \<noteq> callOrigin CS y"
  by (smt a0 empty_iff empty_set local.wf map_update_all_get option.exhaust_sel proof_state_rel_callOrigin proof_state_wellFormed_localCalls ps_localCalls_no_origin ps_not_localCalls_not_tx rel)

lemma rel_callOrigin_same:
  assumes "callOrigin S x \<triangleq> xtx"
    and a1: "callOrigin S x = callOrigin S x'"
    and  wf: "proof_state_wellFormed S"
    and rel: "proof_state_rel S CS"
  shows "callOrigin CS x = callOrigin CS x'"
  by (metis (no_types, lifting) \<open>callOrigin S x \<triangleq> xtx\<close> a1 local.wf map_update_all_get option.simps(3) proof_state_rel_callOrigin ps_localCalls_no_origin rel)

lemma rel_noCallOrigin_noHappensBefore:
  assumes "callOrigin S x = None"
    and rel: "proof_state_rel S CS"
    and  wf: "proof_state_wellFormed S"
  shows "(x,y) \<notin> happensBefore S"
  by (metis (no_types, lifting) FieldI1 assms(1) disjoint_iff_not_equal domIff local.wf map_update_all_None proof_state_rel_calls proof_state_rel_facts(4) proof_state_rel_happensBefore_localCalls_disjoint proof_state_rel_wf proof_state_wellFormed_happensBefore_subset_calls rel subsetD wellFormed_callOrigin_dom)

lemma rel_noCallOrigin_noHappensBefore_r:
  assumes "callOrigin S x = None"
    and rel: "proof_state_rel S CS"
    and  wf: "proof_state_wellFormed S"
  shows "(y,x) \<notin> happensBefore S"
  by (metis (no_types, lifting) FieldI2 assms(1) disjoint_iff_not_equal domIff local.wf map_update_all_None proof_state_rel_calls proof_state_rel_facts(4) proof_state_rel_wf proof_state_wellFormed_disjoint_happensBefore_localCalls proof_state_wellFormed_happensBefore_subset_calls rel subsetD wellFormed_callOrigin_dom)

lemma ps_wellFormed_state_transaction_consistent_hb:
  assumes wf: "proof_state_wellFormed S"
    and a0: "callOrigin S x \<noteq> callOrigin S y"
    and a1: "callOrigin S x = callOrigin S x'"
    and a2: "callOrigin S y = callOrigin S y'"
  shows "(x,y) \<in> happensBefore S \<longleftrightarrow> (x', y') \<in> happensBefore S"
proof (rule ps_wellFormed_to_wf[OF wf])
  fix CS
  assume  rel: "proof_state_rel S CS"
    and CS_wf: "state_wellFormed CS"

  {
    fix xtx ytx
    assume "callOrigin S x \<triangleq> xtx"
      and "callOrigin S y \<triangleq> ytx"

    have "((x, y) \<in> happensBefore CS) = ((x', y') \<in> happensBefore CS)"
      using CS_wf
    proof (rule wellFormed_state_transaction_consistent(3))
      show "callOrigin CS x \<noteq> callOrigin CS y"
        using a0 local.wf rel rel_callOrigin_different by blast
      show "callOrigin CS x = callOrigin CS x'"
        using \<open>callOrigin S x \<triangleq> xtx\<close> a1 local.wf rel rel_callOrigin_same by blast
      show "callOrigin CS y = callOrigin CS y'"
        using \<open>callOrigin S y \<triangleq> ytx\<close> a2 local.wf rel rel_callOrigin_same by blast
    qed

    hence "((x, y) \<in> happensBefore S) \<longleftrightarrow> ((x', y') \<in> happensBefore S)"
      by (metis \<open>callOrigin S y \<triangleq> ytx\<close> a2 local.wf option.simps(3) proof_state_rel_hb ps_localCalls_no_origin rel updateHb_simp2)
  }
  moreover
  {
    assume "callOrigin S x = None"
    hence "(x,y) \<notin> happensBefore S"
      using local.wf rel rel_noCallOrigin_noHappensBefore by blast
    have "callOrigin S x' = None"
      using \<open>callOrigin S x = None\<close> a1 by auto
    hence "(x',y') \<notin> happensBefore S"
      using local.wf rel rel_noCallOrigin_noHappensBefore by blast
    hence "((x, y) \<in> happensBefore S) \<longleftrightarrow> ((x', y') \<in> happensBefore S)"
      using \<open>(x, y) \<notin> happensBefore S\<close> by blast
  }
  moreover
  {
    assume "callOrigin S y = None"
    hence "(x,y) \<notin> happensBefore S"
      using local.wf rel rel_noCallOrigin_noHappensBefore_r by blast
    have "callOrigin S y' = None"
      using \<open>callOrigin S y = None\<close> a2 by auto
    hence "(x',y') \<notin> happensBefore S"
      using local.wf rel rel_noCallOrigin_noHappensBefore_r by blast
    hence "((x, y) \<in> happensBefore S) \<longleftrightarrow> ((x', y') \<in> happensBefore S)"
      using \<open>(x, y) \<notin> happensBefore S\<close> by blast
  }
  ultimately show ?thesis
    by blast
qed

lemma ps_wellFormed_state_consistent_snapshot:
assumes wf: "proof_state_wellFormed S"
assumes noTx: "\<And>c tx. ps_tx S \<triangleq> tx \<Longrightarrow> callOrigin S c \<noteq> Some tx"
shows "consistentSnapshotH (calls S) (happensBefore S) (callOrigin S) (\<lambda>x. Some Committed) (ps_vis S)"
  by (simp add: local.wf proof_state_wellFormed_vis_subset_calls ps_wellFormed_state_causality ps_wellFormed_state_transaction_consistent1 show_consistentSnapshot show_transactionConsistent)

lemma ps_wf_happensBefore_irrefl:
assumes wf: "proof_state_wellFormed S"
shows "irrefl (happensBefore S)"
  by (metis (no_types, hide_lams) happensBefore_irrefl  irrefl_def local.wf proof_state_rel_hb ps_wellFormed_to_wf updateHb_simp_distinct2)

lemma ps_wf_happensBefore_acyclic:
assumes wf: "proof_state_wellFormed S"
shows "acyclic (happensBefore S)"
  by (simp add: acyclic_irrefl local.wf ps_wf_happensBefore_irrefl ps_wellFormed_state_hb_trans)

lemma ps_wf_vis_downwards_closed:
  assumes wf: "proof_state_wellFormed S"
    and "(x,y) \<in> happensBefore S"
    and "y\<in>ps_vis S"
  shows "x\<in>ps_vis S"
  by (meson assms(2) assms(3) causallyConsistent_def local.wf ps_wellFormed_state_causality)

lemma ps_wf_happensBefore_txns_left:
  assumes wf: "proof_state_wellFormed S"
  assumes "(x,y) \<in> happensBefore S"
    and "callOrigin S x = callOrigin S x'"
    and "callOrigin S x \<noteq> callOrigin S y"
  shows "(x',y) \<in> happensBefore S"
  using assms(2) assms(3) assms(4) local.wf ps_wellFormed_state_transaction_consistent_hb by blast

lemma causallyConsistent_downwards_closure:
assumes wf: "proof_state_wellFormed S"
shows "causallyConsistent (happensBefore S) (cs \<down> happensBefore S)"
  by (smt causallyConsistent_def downwardsClosure_in local.wf ps_wellFormed_state_hb_trans transD)

lemma ps_wf_current_tx_not_before_others:
  assumes wf: "proof_state_wellFormed S"
    and "ps_tx S \<triangleq> tx"
    and "callOrigin S x \<triangleq> tx"
    and "callOrigin S y \<noteq> Some tx"
  shows "(x,y) \<notin> happensBefore S"
  by (meson assms(2) assms(3) domI domIff local.wf ps_localCalls_no_origin ps_not_localCalls_not_tx)

(*
lemma ps_i_callOriginI_notI1:
  assumes "proof_state_wellFormed S_pre"
    and "invocOp S_pre i = None"
  shows "i_callOriginI S_pre c \<noteq> Some i"

  by (metis (no_types, lifting) assms(1) assms(2) i_callOriginI_h_def option.case_eq_if option.simps(3) proof_state_rel_invocOp proof_state_rel_txOrigin proof_state_rel_wf proof_state_wellFormed_def wf_no_invocation_no_origin)
*)
(*
lemma ps_i_callOriginI_notI2:
  assumes "proof_state_wellFormed S_pre"
    and "i_callOriginI S_pre c = Some i"
  shows "invocOp S_pre i \<noteq> None"
  using assms(1) assms(2) ps_i_callOriginI_notI1 by auto
*)

lemma ps_wellFormed_current_transaction_origin:
  assumes "proof_state_wellFormed S"
    and "ps_tx S \<triangleq> tx"
  shows "txOrigin S tx = None"
  using assms(1) assms(2) proof_state_rel_txOriginNone proof_state_wellFormed_def by blast

lemma ps_wellFormed_ls_visibleCalls_callOrigin:
  assumes "proof_state_wellFormed S"
    and "callOrigin S c \<triangleq> tx"
    and "txOrigin S tx \<triangleq> ps_i S"
  shows "c \<in> ps_vis S"
  by (metis assms(1) assms(2) assms(3) i_callOriginI_h_simp proof_state_rel_see_my_updates ps_wellFormed_to_wf)

lemma ps_wf_queryspec:
  assumes wf: "proof_state_wellFormed S"
    and "calls S c \<triangleq> Call op r"
    and "prevCalls = {c'. (c',c)\<in>updateHb (happensBefore S) (ps_vis S) (ps_localCalls S)}"
    and "ctxt = getContextH (calls S |` prevCalls) (updateHb (happensBefore S) (ps_vis S) (ps_localCalls S) |r prevCalls) (Some prevCalls)"
  shows "querySpec (ps_prog S) op ctxt r"
proof (rule ps_wellFormed_to_wf[OF wf])
  fix CS
  assume rel: "proof_state_rel S CS"
    and CS_wf: "state_wellFormed CS"

  have "querySpec (prog CS) op ctxt r"
    using CS_wf
  proof (rule wf_queryspec)
    show "calls CS c \<triangleq> Call op r"
      using assms(2) proof_state_rel_calls rel by fastforce
    show "prevCalls = {c'. (c', c) \<in> happensBefore CS}"
      using assms(3) proof_state_rel_hb rel by force
    show "ctxt = getContextH (calls CS |` prevCalls) (happensBefore CS |r prevCalls) (Some prevCalls)"
      using assms(4) proof_state_rel_calls proof_state_rel_hb rel by fastforce
  qed

  thus "querySpec (ps_prog S) op ctxt r"
    using proof_state_rel_prog rel by force
qed

lemma ps_growing_no_localCalls1:
  assumes "ps_growing S S' t"
  shows "ps_localCalls S = []"
  using assms  by (auto simp add: ps_growing_def)

lemma ps_growing_no_localCalls2:
  assumes "ps_growing S S' t"
  shows "ps_localCalls S' = []"
  using assms  by (auto simp add: ps_growing_def)

lemma ps_growing_no_tx1:
  assumes "ps_growing S S' t"
  shows "ps_tx S = None"
  using assms  by (auto simp add: ps_growing_def)

lemma ps_growing_no_tx2:
  assumes "ps_growing S S' t"
  shows "ps_tx S' \<triangleq> t"
  using assms  by (auto simp add: ps_growing_def)

lemma ps_growing_rule:
  assumes "ps_growing S S' t"
    and "\<And>CS CS'.
       \<lbrakk>proof_state_rel S CS; proof_state_rel S' CS';
        state_monotonicGrowth (ps_i S) CS
         (CS'\<lparr>txStatus := (txStatus CS')(t := None),
                txOrigin := (txOrigin CS')(t := None),
                currentTx := (currentTx CS')(ps_i S := None),
                localState := (localState CS')(ps_i S := localState CS (ps_i S)),
                visibleCalls := (visibleCalls CS')(ps_i S := visibleCalls CS (ps_i S))\<rparr>)\<rbrakk>
       \<Longrightarrow> P"
  shows P
  using assms by (auto simp add: ps_growing_def)

lemma ps_monotonicGrowth_txOrigin_i:
  assumes "ps_growing S S' tx"
    and "t \<noteq> tx"
  shows "txOrigin S' t \<triangleq> ps_i S \<longleftrightarrow> txOrigin S t \<triangleq> ps_i S"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S CS"
    and rel2: "proof_state_rel S' CS'"
    and g: "state_monotonicGrowth (ps_i S) CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S := None),                 localState := (localState CS')(ps_i S := localState CS (ps_i S)),                 visibleCalls := (visibleCalls CS')(ps_i S := visibleCalls CS (ps_i S))\<rparr>)"

  from state_monotonicGrowth_txOrigin_i[OF g, where t=t, simplified]
  have "txOrigin CS' t \<triangleq> ps_i S \<longleftrightarrow> txOrigin CS t \<triangleq> ps_i S"
    by (simp add: `t \<noteq> tx`)

  thus "txOrigin S' t \<triangleq> ps_i S = txOrigin S t \<triangleq> ps_i S"
    unfolding proof_state_rel_txOrigin[OF rel1] proof_state_rel_txOrigin[OF rel2]
    by (metis (no_types, lifting) assms(1) assms(2) fun_upd_other option.case_eq_if option.sel ps_growing_no_tx1 ps_growing_no_tx2)
qed

lemma ps_monotonicGrowth_no_new_calls_before_existing1:
  assumes "ps_growing S' S t"
    and "c2\<in>dom (calls S')"
    and "ps_vis S' = ps_vis S"
  shows "(c1,c2)\<in>happensBefore S \<longleftrightarrow> (c1,c2)\<in>happensBefore S'"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(t := None),                 txOrigin := (txOrigin CS')(t := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  from state_monotonicGrowth_no_new_calls_before_existing1[OF g, simplified, of c2 c1]
  have "((c1, c2) \<in> happensBefore CS') \<longleftrightarrow> ((c1, c2) \<in> happensBefore CS)"
    using assms(2) proof_state_rel_calls rel1 by fastforce

  hence "((c1, c2) \<in> updateHb (happensBefore S) (ps_vis S) (ps_localCalls S))
    \<longleftrightarrow>  ((c1, c2) \<in> updateHb (happensBefore S') (ps_vis S') (ps_localCalls S'))"
    unfolding proof_state_rel_hb[OF rel1] proof_state_rel_hb[OF rel2] .

  thus "((c1, c2) \<in> happensBefore S) = ((c1, c2) \<in> happensBefore S')"
    by (metis assms(1) ps_growing_no_localCalls1 ps_growing_no_localCalls2 single_invocation_correctness.updateHb_nil)
qed

lemma ps_monotonicGrowth_no_new_calls_before_existing:
  assumes "ps_growing S' S t"
    and "calls S' c = None"
    and "calls S c \<triangleq> x"
    and "calls S' c' \<triangleq> y"
  shows "(c,c') \<notin> happensBefore S'"
  using assms
  by (meson FieldI1 domIff proof_state_wellFormed_happensBefore_subset_calls ps_growing_rule show_proof_state_wellFormed subset_h1)

lemma ps_monotonicGrowth_txOrigin:
  assumes "ps_growing S' S tx"
    and "txOrigin S' t \<triangleq> i'"
    and "tx \<noteq> t"
  shows "txOrigin S t \<triangleq> i'"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  have "txOrigin CS t \<triangleq> i'"
    using assms(1) assms(2) proof_state_rel_txOrigin ps_growing_no_tx1 rel1 by fastforce

  from state_monotonicGrowth_txOrigin[OF g `txOrigin CS t \<triangleq> i'`]
  have "txOrigin CS' t \<triangleq> i'"
    using assms(3) by auto

  thus "txOrigin S t \<triangleq> i'"
    using assms(1) assms(3) proof_state_rel_txOrigin ps_growing_no_tx2 rel2 by fastforce
qed

lemma ps_monotonicGrowth_calls:
  assumes "ps_growing S' S tx"
    and "calls S' c \<triangleq> info"
  shows "calls S c \<triangleq> info"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  have "calls CS c \<triangleq> info"
    using assms(2) proof_state_rel_calls rel1 by force

  from state_monotonicGrowth_calls[OF g `calls CS c \<triangleq> info`]
  show "calls S c \<triangleq> info"
    using proof_state_rel_calls rel2 by fastforce
qed

lemma ps_monotonicGrowth_happensBefore:
  assumes "ps_growing S' S tx"
  and "c2\<in>dom (calls S')"
shows "((c1,c2)\<in>happensBefore S \<longleftrightarrow> (c1,c2)\<in>happensBefore S')"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  have "c2 \<in> dom (calls CS)"
    using assms(2) proof_state_rel_calls rel1 by fastforce

  have "ps_localCalls S' = []"
    using assms(1) ps_growing_no_localCalls1 by blast

  from state_monotonicGrowth_happensBefore[OF g `c2 \<in> dom (calls CS)`, simplified]
  have "((c1, c2) \<in> happensBefore CS') = ((c1, c2) \<in> happensBefore CS)" .

  thus ?thesis
    using \<open>ps_localCalls S' = []\<close> assms(1) proof_state_rel_facts(3) ps_growing_no_localCalls2 rel1 rel2 by fastforce
qed

lemma ps_monotonicGrowth_callOrigin:
  assumes "ps_growing S' S tx"
    and "callOrigin S' c \<triangleq> t"
  shows "callOrigin S c \<triangleq> t"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  have "callOrigin CS c \<triangleq> t"
    using assms(1) assms(2) proof_state_rel_callOrigin ps_growing_no_localCalls1 rel1 by fastforce

  from state_monotonicGrowth_callOrigin[OF g `callOrigin CS c \<triangleq> t`]
  show "callOrigin S c \<triangleq> t"
    using assms(1) proof_state_rel_callOrigin ps_growing_no_localCalls2 rel2 by fastforce
qed

lemma ps_monotonicGrowth_callOrigin2:
  assumes "ps_growing S' S t"
  shows "callOrigin S c = None \<Longrightarrow> callOrigin S' c = None"
  by (metis assms option.exhaust ps_monotonicGrowth_callOrigin)

lemma ps_monotonicGrowth_knownIds:
  assumes "ps_growing S' S tx"
  shows "knownIds S' \<subseteq> knownIds S"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  from state_monotonicGrowth_knownIds[OF g, simplified]
  have "knownIds CS \<subseteq> knownIds CS'" .

  thus "knownIds S' \<subseteq> knownIds S"
    using proof_state_rel_knownIds rel1 rel2 by auto
qed

lemma ps_monotonicGrowth_invocOp:
  assumes "ps_growing S' S tx"
    and "invocOp S' s \<triangleq> info"
  shows "invocOp S s \<triangleq> info"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  have "invocOp CS s \<triangleq> info"
    using assms(2) proof_state_rel_invocOp rel1 by force

  from state_monotonicGrowth_invocOp[OF g `invocOp CS s \<triangleq> info`, simplified]
  show ?thesis
    using proof_state_rel_invocOp rel2 by fastforce
qed

lemma ps_growing_same_i:
assumes "ps_growing S' S tx"
shows "ps_i S = ps_i S'"
  using assms ps_growing_def by blast

lemma ps_monotonicGrowth_invocOp_i:
  assumes "ps_growing S' S tx"
  shows "invocOp S (ps_i S) = invocOp S' (ps_i S)"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  from state_monotonicGrowth_invocOp_i[OF g]
  have "invocOp CS' (ps_i S') = invocOp CS (ps_i S')" by simp
  thus ?thesis
    by (metis (no_types, lifting) assms proof_state_rel_invocOp ps_growing_same_i rel1 rel2)
qed

lemma ps_monotonicGrowth_invocRes:
  assumes "ps_growing S' S tx"
    and "invocRes S' s \<triangleq> info"
  shows "invocRes S s \<triangleq> info"
  using assms(1) proof (rule ps_growing_rule)
  fix CS CS'
  assume rel1: "proof_state_rel S' CS"
    and rel2: "proof_state_rel S CS'"
    and g: "state_monotonicGrowth (ps_i S') CS          (CS'\<lparr>txStatus := (txStatus CS')(tx := None),                 txOrigin := (txOrigin CS')(tx := None),                 currentTx := (currentTx CS')(ps_i S' := None),                 localState := (localState CS')(ps_i S' := localState CS (ps_i S')),                 visibleCalls := (visibleCalls CS')(ps_i S' := visibleCalls CS (ps_i S'))\<rparr>)"

  have "invocRes CS s \<triangleq> info"
    using assms(2) proof_state_rel_invocRes rel1 by fastforce

  from state_monotonicGrowth_invocRes[OF g `invocRes CS s \<triangleq> info`, simplified]
  have "invocRes CS' s \<triangleq> info" .
  thus ?thesis
    using proof_state_rel_invocRes rel2 by force
qed

lemma ps_monotonicGrowth_invocRes_i:
  assumes "ps_growing S' S t"
  shows "invocRes S' (ps_i S') = invocRes S (ps_i S')"
  by (smt assms proof_state_rel_invocRes proof_state_rel_ls proof_state_rel_wf ps_growing_rule ps_growing_same_i wf_localState_noReturn)

lemma ps_monotonicGrowth_prog:
  assumes "ps_growing S' S t"
  shows "ps_prog S = ps_prog S'"
  using assms ps_growing_def by blast

lemma ps_monotonicGrowth_invocOp2:
  assumes "ps_growing S' S t"
  shows "(invocOp S' \<subseteq>\<^sub>m invocOp S) "
  using assms map_le_def ps_monotonicGrowth_invocOp by fastforce

lemma ps_monotonicGrowth_current_transactions_fixed:
  assumes "ps_growing S S' t"
    and "ps_tx S \<triangleq> tx"
  shows "callOrigin S c \<triangleq> tx \<longleftrightarrow> callOrigin S' c \<triangleq> tx"
  using assms(1) assms(2) ps_growing_no_tx1 by force

end


;;; -*- syntax: common-lisp; package: KEIM; base: 10; mode: LISP -*-
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;;                                                                          ;;
;;   Copyright (C) 1996 by AG Siekmann, Fachbereich Informatik,             ;;
;;   Universitaet des Saarlandes, Saarbruecken, Germany.                    ;;
;;   All rights reserved.                                                   ;;
;;   For information about this program, write to:                          ;;
;;     OMEGA Project                                                         ;;
;;     AG Siekmann/FB Informatik                                            ;;
;;     Universitaet des Saarlandes                                          ;;
;;     Postfach 1150                                                        ;;
;;     D-66041 Saarbruecken                                                 ;;
;;     Germany                                                              ;;
;;   electronic mail: keim@cs.uni-sb.de                                     ;;
;;                                                                          ;;
;;   The author makes no representations about the suitability of this      ;;
;;   software for any purpose.  It is provided "AS IS" without express or   ;;
;;   implied warranty.  In particular, it must be understood that this      ;;
;;   software is an experimental version, and is not suitable for use in    ;;
;;   any safety-critical application, and the author denies a license for   ;;
;;   such use.                                                              ;;
;;                                                                          ;;
;;   You may use, copy, modify and distribute this software for any         ;;
;;   noncommercial and non-safety-critical purpose.  Use of this software   ;;
;;   in a commercial product is not included under this license.  You must  ;;
;;   maintain this copyright statement in all copies of this software that  ;;
;;   you modify or distribute.                                              ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;

(in-package :omega)

(th~deftheorem submodule-property
	       (in module)
	       (conclusion
		(all-types aa bb
		 (forall (lam (M (o bb))
		  (forall (lam (madd (bb bb bb))
		   (forall (lam (R (o aa))
		    (forall (lam (radd (aa aa aa))
		     (forall (lam (rmul (aa aa aa))
		      (forall (lam (rmmul (bb bb aa))
		       (forall (lam (A (o bb))
			 (implies (and (and (module M madd R radd rmul rmmul)
					    (subset A M))
				       (and (closed-under A madd)
					    (and (in (group-unit M madd) A)
						 (and (forall-sort (lam (m1 bb)
						       (forall-sort (lam (m2 bb)
							(in (madd m1 ((group-inverse M madd) m2)) A))
								    A))
								   A)
						      (forall-sort (lam (r1 aa)
						       (forall-sort (lam (m1 bb)
							(in (rmmul r1 m1) A))
								    A))
								   R)))))
				  (submodule A M madd R radd rmul rmmul)))))))))))))))))))