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

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_on_inv__52 imports n_germanSimp_base
begin
section{*All lemmas on causal relation between inv__52 and some rule r*}
lemma n_RecvReqSVsinv__52:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__52  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqS N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__52  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (andForm (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const Empty)) (eqn (IVar (Para (Ident ''ShrSet'') p__Inv4)) (Const true))) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv4) ''State'')) (Const I))) (eqn (IVar (Ident ''CurCmd'')) (Const Empty))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (andForm (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const Empty)) (eqn (IVar (Para (Ident ''ShrSet'') p__Inv4)) (Const true))) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv4) ''State'')) (Const I))) (eqn (IVar (Ident ''CurCmd'')) (Const Empty))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

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

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

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

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

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

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

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

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

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

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

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

end


(*  Title:      HOL/MicroJava/J/Decl.thy

    Author:     David von Oheimb
    Copyright   1999 Technische Universitaet Muenchen
*)

section \<open>Class Declarations and Programs\<close>

theory Decl imports Type begin

type_synonym
  fdecl    = "vname \<times> ty"        \<comment> \<open>field declaration\<close>
type_synonym
  'm mdecl = "mname \<times> ty list \<times> ty \<times> 'm"     \<comment> \<open>method = name, arg.\ types, return type, body\<close>
type_synonym
  'm "class" = "cname \<times> fdecl list \<times> 'm mdecl list"       \<comment> \<open>class = superclass, fields, methods\<close>
type_synonym
  'm cdecl = "cname \<times> 'm class"  \<comment> \<open>class declaration\<close>
type_synonym
  'm prog  = "'m cdecl list"     \<comment> \<open>program\<close>

(*<*)
translations
  (type) "fdecl"   <= (type) "vname \<times> ty"
  (type) "'c mdecl" <= (type) "mname \<times> ty list \<times> ty \<times> 'c"
  (type) "'c class" <= (type) "cname \<times> fdecl list \<times> ('c mdecl) list"
  (type) "'c cdecl" <= (type) "cname \<times> ('c class)"
  (type) "'c prog" <= (type) "('c cdecl) list"
(*>*)

definition "class" :: "'m prog \<Rightarrow> cname \<rightharpoonup> 'm class"
where
  "class  \<equiv>  map_of"

definition is_class :: "'m prog \<Rightarrow> cname \<Rightarrow> bool"
where
  "is_class P C  \<equiv>  class P C \<noteq> None"

lemma finite_is_class: "finite {C. is_class P C}"

(*<*)
proof -
  have "{C. is_class P C} = dom (map_of P)"
   by (simp add: is_class_def class_def dom_def)
  thus ?thesis by (simp add: finite_dom_map_of)
qed
(*>*)

definition is_type :: "'m prog \<Rightarrow> ty \<Rightarrow> bool"
where
  "is_type P T  \<equiv>
  (case T of Void \<Rightarrow> True | Boolean \<Rightarrow> True | Integer \<Rightarrow> True | NT \<Rightarrow> True
   | Class C \<Rightarrow> is_class P C)"

lemma is_type_simps [simp]:
  "is_type P Void \<and> is_type P Boolean \<and> is_type P Integer \<and>
  is_type P NT \<and> is_type P (Class C) = is_class P C"
(*<*)by(simp add:is_type_def)(*>*)

abbreviation
  "types P == Collect (is_type P)"

end


(*  Title:      HOL/Auth/Recur.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge
*)

section\<open>The Otway-Bull Recursive Authentication Protocol\<close>

theory Recur imports Public begin

text\<open>End marker for message bundles\<close>
abbreviation
  END :: "msg" where
  "END == Number 0"

(*Two session keys are distributed to each agent except for the initiator,
        who receives one.
  Perhaps the two session keys could be bundled into a single message.
*)
inductive_set (*Server's response to the nested message*)
  respond :: "event list => (msg*msg*key)set"
  for evs :: "event list"
  where
   One:  "Key KAB \<notin> used evs
          ==> (Hash[Key(shrK A)] \<lbrace>Agent A, Agent B, Nonce NA, END\<rbrace>,
               \<lbrace>Crypt (shrK A) \<lbrace>Key KAB, Agent B, Nonce NA\<rbrace>, END\<rbrace>,
               KAB)   \<in> respond evs"

    (*The most recent session key is passed up to the caller*)
 | Cons: "[| (PA, RA, KAB) \<in> respond evs;
             Key KBC \<notin> used evs;  Key KBC \<notin> parts {RA};
             PA = Hash[Key(shrK A)] \<lbrace>Agent A, Agent B, Nonce NA, P\<rbrace> |]
          ==> (Hash[Key(shrK B)] \<lbrace>Agent B, Agent C, Nonce NB, PA\<rbrace>,
               \<lbrace>Crypt (shrK B) \<lbrace>Key KBC, Agent C, Nonce NB\<rbrace>,
                 Crypt (shrK B) \<lbrace>Key KAB, Agent A, Nonce NB\<rbrace>,
                 RA\<rbrace>,
               KBC)
              \<in> respond evs"

(*Induction over "respond" can be difficult due to the complexity of the
  subgoals.  Set "responses" captures the general form of certificates.
*)
inductive_set
  responses :: "event list => msg set"
  for evs :: "event list"
  where
    (*Server terminates lists*)
   Nil:  "END \<in> responses evs"

 | Cons: "[| RA \<in> responses evs;  Key KAB \<notin> used evs |]
          ==> \<lbrace>Crypt (shrK B) \<lbrace>Key KAB, Agent A, Nonce NB\<rbrace>,
                RA\<rbrace>  \<in> responses evs"

inductive_set recur :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> recur"

         (*The spy MAY say anything he CAN say.  Common to
           all similar protocols.*)
 | Fake: "[| evsf \<in> recur;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> recur"

         (*Alice initiates a protocol run.
           END is a placeholder to terminate the nesting.*)
 | RA1:  "[| evs1 \<in> recur;  Nonce NA \<notin> used evs1 |]
          ==> Says A B (Hash[Key(shrK A)] \<lbrace>Agent A, Agent B, Nonce NA, END\<rbrace>)
              # evs1 \<in> recur"

         (*Bob's response to Alice's message.  C might be the Server.
           We omit PA = \<lbrace>XA, Agent A, Agent B, Nonce NA, P\<rbrace> because
           it complicates proofs, so B may respond to any message at all!*)
 | RA2:  "[| evs2 \<in> recur;  Nonce NB \<notin> used evs2;
             Says A' B PA \<in> set evs2 |]
          ==> Says B C (Hash[Key(shrK B)] \<lbrace>Agent B, Agent C, Nonce NB, PA\<rbrace>)
              # evs2 \<in> recur"

         (*The Server receives Bob's message and prepares a response.*)
 | RA3:  "[| evs3 \<in> recur;  Says B' Server PB \<in> set evs3;
             (PB,RB,K) \<in> respond evs3 |]
          ==> Says Server B RB # evs3 \<in> recur"

         (*Bob receives the returned message and compares the Nonces with
           those in the message he previously sent the Server.*)
 | RA4:  "[| evs4 \<in> recur;
             Says B  C \<lbrace>XH, Agent B, Agent C, Nonce NB,
                         XA, Agent A, Agent B, Nonce NA, P\<rbrace> \<in> set evs4;
             Says C' B \<lbrace>Crypt (shrK B) \<lbrace>Key KBC, Agent C, Nonce NB\<rbrace>,
                         Crypt (shrK B) \<lbrace>Key KAB, Agent A, Nonce NB\<rbrace>,
                         RA\<rbrace> \<in> set evs4 |]
          ==> Says B A RA # evs4 \<in> recur"

   (*No "oops" message can easily be expressed.  Each session key is
     associated--in two separate messages--with two nonces.  This is
     one try, but it isn't that useful.  Re domino attack, note that
     Recur.thy proves that each session key is secure provided the two
     peers are, even if there are compromised agents elsewhere in
     the chain.  Oops cases proved using parts_cut, Key_in_keysFor_parts,
     etc.

   Oops:  "[| evso \<in> recur;  Says Server B RB \<in> set evso;
              RB \<in> responses evs';  Key K \<in> parts {RB} |]
           ==> Notes Spy \<lbrace>Key K, RB\<rbrace> # evso \<in> recur"
  *)

declare Says_imp_knows_Spy [THEN analz.Inj, dest]
declare parts.Body  [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un  [dest]

(** Possibility properties: traces that reach the end
        ONE theorem would be more elegant and faster!
        By induction on a list of agents (no repetitions)
**)

text\<open>Simplest case: Alice goes directly to the server\<close>
lemma "Key K \<notin> used []
       ==> \<exists>NA. \<exists>evs \<in> recur.
              Says Server A \<lbrace>Crypt (shrK A) \<lbrace>Key K, Agent Server, Nonce NA\<rbrace>,
                    END\<rbrace>  \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] recur.Nil [THEN recur.RA1,
                             THEN recur.RA3 [OF _ _ respond.One]])
apply (possibility, simp add: used_Cons)
done

text\<open>Case two: Alice, Bob and the server\<close>
lemma "[| Key K \<notin> used []; Key K' \<notin> used []; K \<noteq> K';
          Nonce NA \<notin> used []; Nonce NB \<notin> used []; NA < NB |]
       ==> \<exists>NA. \<exists>evs \<in> recur.
        Says B A \<lbrace>Crypt (shrK A) \<lbrace>Key K, Agent B, Nonce NA\<rbrace>,
                   END\<rbrace>  \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2]
          recur.Nil
           [THEN recur.RA1 [of _ NA],
            THEN recur.RA2 [of _ NB],
            THEN recur.RA3 [OF _ _ respond.One
                                     [THEN respond.Cons [of _ _ K _ K']]],
            THEN recur.RA4], possibility)
apply (auto simp add: used_Cons)
done

(*Case three: Alice, Bob, Charlie and the server Rather slow (5 seconds)*)
lemma "[| Key K \<notin> used []; Key K' \<notin> used [];
          Key K'' \<notin> used []; K \<noteq> K'; K' \<noteq> K''; K \<noteq> K'';
          Nonce NA \<notin> used []; Nonce NB \<notin> used []; Nonce NC \<notin> used [];
          NA < NB; NB < NC |]
       ==> \<exists>K. \<exists>NA. \<exists>evs \<in> recur.
             Says B A \<lbrace>Crypt (shrK A) \<lbrace>Key K, Agent B, Nonce NA\<rbrace>,
                        END\<rbrace>  \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2]
          recur.Nil [THEN recur.RA1,
                     THEN recur.RA2, THEN recur.RA2,
                     THEN recur.RA3
                          [OF _ _ respond.One
                                  [THEN respond.Cons, THEN respond.Cons]],
                     THEN recur.RA4, THEN recur.RA4])
apply basic_possibility
apply (tactic "DEPTH_SOLVE (swap_res_tac @{context} [refl, conjI, disjCI] 1)")
done

lemma respond_imp_not_used: "(PA,RB,KAB) \<in> respond evs ==> Key KAB \<notin> used evs"
by (erule respond.induct, simp_all)

lemma Key_in_parts_respond [rule_format]:
   "[| Key K \<in> parts {RB};  (PB,RB,K') \<in> respond evs |] ==> Key K \<notin> used evs"
apply (erule rev_mp, erule respond.induct)
apply (auto dest: Key_not_used respond_imp_not_used)
done

text\<open>Simple inductive reasoning about responses\<close>
lemma respond_imp_responses:
     "(PA,RB,KAB) \<in> respond evs ==> RB \<in> responses evs"
apply (erule respond.induct)
apply (blast intro!: respond_imp_not_used responses.intros)+
done

(** For reasoning about the encrypted portion of messages **)

lemmas RA2_analz_spies = Says_imp_spies [THEN analz.Inj]

lemma RA4_analz_spies:
     "Says C' B \<lbrace>Crypt K X, X', RA\<rbrace> \<in> set evs ==> RA \<in> analz (spies evs)"
by blast

(*RA2_analz... and RA4_analz... let us treat those cases using the same
  argument as for the Fake case.  This is possible for most, but not all,
  proofs: Fake does not invent new nonces (as in RA2), and of course Fake
  messages originate from the Spy. *)

lemmas RA2_parts_spies =  RA2_analz_spies [THEN analz_into_parts]
lemmas RA4_parts_spies =  RA4_analz_spies [THEN analz_into_parts]

(** Theorems of the form X \<notin> parts (spies evs) imply that NOBODY
    sends messages containing X! **)

(** Spy never sees another agent's shared key! (unless it's bad at start) **)

lemma Spy_see_shrK [simp]:
     "evs \<in> recur ==> (Key (shrK A) \<in> parts (spies evs)) = (A \<in> bad)"
apply (erule recur.induct, auto)
txt\<open>RA3.  It's ugly to call auto twice, but it seems necessary.\<close>
apply (auto dest: Key_in_parts_respond simp add: parts_insert_spies)
done

lemma Spy_analz_shrK [simp]:
     "evs \<in> recur ==> (Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> recur|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

(*** Proofs involving analz ***)

(** Session keys are not used to encrypt other session keys **)

(*Version for "responses" relation.  Handles case RA3 in the theorem below.
  Note that it holds for *any* set H (not just "spies evs")
  satisfying the inductive hypothesis.*)
lemma resp_analz_image_freshK_lemma:
     "[| RB \<in> responses evs;
         \<forall>K KK. KK \<subseteq> - (range shrK) -->
                   (Key K \<in> analz (Key`KK Un H)) =
                   (K \<in> KK | Key K \<in> analz H) |]
     ==> \<forall>K KK. KK \<subseteq> - (range shrK) -->
                   (Key K \<in> analz (insert RB (Key`KK Un H))) =
                   (K \<in> KK | Key K \<in> analz (insert RB H))"
apply (erule responses.induct)
apply (simp_all del: image_insert
                add: analz_image_freshK_simps, auto)
done

text\<open>Version for the protocol.  Proof is easy, thanks to the lemma.\<close>
lemma raw_analz_image_freshK:
 "evs \<in> recur ==>
   \<forall>K KK. KK \<subseteq> - (range shrK) -->
          (Key K \<in> analz (Key`KK Un (spies evs))) =
          (K \<in> KK | Key K \<in> analz (spies evs))"
apply (erule recur.induct)
apply (drule_tac [4] RA2_analz_spies,
       drule_tac [5] respond_imp_responses,
       drule_tac [6] RA4_analz_spies, analz_freshK, spy_analz)
txt\<open>RA3\<close>
apply (simp_all add: resp_analz_image_freshK_lemma)
done

(*Instance of the lemma with H replaced by (spies evs):
   [| RB \<in> responses evs;  evs \<in> recur; |]
   ==> KK \<subseteq> - (range shrK) -->
       Key K \<in> analz (insert RB (Key`KK Un spies evs)) =
       (K \<in> KK | Key K \<in> analz (insert RB (spies evs)))
*)
lemmas resp_analz_image_freshK =
       resp_analz_image_freshK_lemma [OF _ raw_analz_image_freshK]

lemma analz_insert_freshK:
     "[| evs \<in> recur;  KAB \<notin> range shrK |]
      ==> (Key K \<in> analz (insert (Key KAB) (spies evs))) =
          (K = KAB | Key K \<in> analz (spies evs))"
by (simp del: image_insert
         add: analz_image_freshK_simps raw_analz_image_freshK)

text\<open>Everything that's hashed is already in past traffic.\<close>
lemma Hash_imp_body:
     "[| Hash \<lbrace>Key(shrK A), X\<rbrace> \<in> parts (spies evs);
         evs \<in> recur;  A \<notin> bad |] ==> X \<in> parts (spies evs)"
apply (erule rev_mp)
apply (erule recur.induct,
       drule_tac [6] RA4_parts_spies,
       drule_tac [5] respond_imp_responses,
       drule_tac [4] RA2_parts_spies)
txt\<open>RA3 requires a further induction\<close>
apply (erule_tac [5] responses.induct, simp_all)
txt\<open>Fake\<close>
apply (blast intro: parts_insertI)
done

(** The Nonce NA uniquely identifies A's message.
    This theorem applies to steps RA1 and RA2!

  Unicity is not used in other proofs but is desirable in its own right.
**)

lemma unique_NA:
  "[| Hash \<lbrace>Key(shrK A), Agent A, B, NA, P\<rbrace> \<in> parts (spies evs);
      Hash \<lbrace>Key(shrK A), Agent A, B',NA, P'\<rbrace> \<in> parts (spies evs);
      evs \<in> recur;  A \<notin> bad |]
    ==> B=B' & P=P'"
apply (erule rev_mp, erule rev_mp)
apply (erule recur.induct,
       drule_tac [5] respond_imp_responses)
apply (force, simp_all)
txt\<open>Fake\<close>
apply blast
apply (erule_tac [3] responses.induct)
txt\<open>RA1,2: creation of new Nonce\<close>
apply simp_all
apply (blast dest!: Hash_imp_body)+
done

(*** Lemmas concerning the Server's response
      (relations "respond" and "responses")
***)

lemma shrK_in_analz_respond [simp]:
     "[| RB \<in> responses evs;  evs \<in> recur |]
  ==> (Key (shrK B) \<in> analz (insert RB (spies evs))) = (B:bad)"
apply (erule responses.induct)
apply (simp_all del: image_insert
                add: analz_image_freshK_simps resp_analz_image_freshK, auto)
done

lemma resp_analz_insert_lemma:
     "[| Key K \<in> analz (insert RB H);
         \<forall>K KK. KK \<subseteq> - (range shrK) -->
                   (Key K \<in> analz (Key`KK Un H)) =
                   (K \<in> KK | Key K \<in> analz H);
         RB \<in> responses evs |]
     ==> (Key K \<in> parts{RB} | Key K \<in> analz H)"
apply (erule rev_mp, erule responses.induct)
apply (simp_all del: image_insert parts_image
             add: analz_image_freshK_simps resp_analz_image_freshK_lemma)
txt\<open>Simplification using two distinct treatments of "image"\<close>
apply (simp add: parts_insert2, blast)
done

lemmas resp_analz_insert =
       resp_analz_insert_lemma [OF _ raw_analz_image_freshK]

text\<open>The last key returned by respond indeed appears in a certificate\<close>
lemma respond_certificate:
     "(Hash[Key(shrK A)] \<lbrace>Agent A, B, NA, P\<rbrace>, RA, K) \<in> respond evs
      ==> Crypt (shrK A) \<lbrace>Key K, B, NA\<rbrace> \<in> parts {RA}"
apply (ind_cases "(Hash[Key (shrK A)] \<lbrace>Agent A, B, NA, P\<rbrace>, RA, K) \<in> respond evs")
apply simp_all
done

(*This unicity proof differs from all the others in the HOL/Auth directory.
  The conclusion isn't quite unicity but duplicity, in that there are two
  possibilities.  Also, the presence of two different matching messages in
  the inductive step complicates the case analysis.  Unusually for such proofs,
  the quantifiers appear to be necessary.*)
lemma unique_lemma [rule_format]:
     "(PB,RB,KXY) \<in> respond evs ==>
      \<forall>A B N. Crypt (shrK A) \<lbrace>Key K, Agent B, N\<rbrace> \<in> parts {RB} -->
      (\<forall>A' B' N'. Crypt (shrK A') \<lbrace>Key K, Agent B', N'\<rbrace> \<in> parts {RB} -->
      (A'=A & B'=B) | (A'=B & B'=A))"
apply (erule respond.induct)
apply (simp_all add: all_conj_distrib)
apply (blast dest: respond_certificate)
done

lemma unique_session_keys:
     "[| Crypt (shrK A) \<lbrace>Key K, Agent B, N\<rbrace> \<in> parts {RB};
         Crypt (shrK A') \<lbrace>Key K, Agent B', N'\<rbrace> \<in> parts {RB};
         (PB,RB,KXY) \<in> respond evs |]
      ==> (A'=A & B'=B) | (A'=B & B'=A)"
by (rule unique_lemma, auto)

(** Crucial secrecy property: Spy does not see the keys sent in msg RA3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having A=Spy **)

lemma respond_Spy_not_see_session_key [rule_format]:
     "[| (PB,RB,KAB) \<in> respond evs;  evs \<in> recur |]
      ==> \<forall>A A' N. A \<notin> bad & A' \<notin> bad -->
          Crypt (shrK A) \<lbrace>Key K, Agent A', N\<rbrace> \<in> parts{RB} -->
          Key K \<notin> analz (insert RB (spies evs))"
apply (erule respond.induct)
apply (frule_tac [2] respond_imp_responses)
apply (frule_tac [2] respond_imp_not_used)
apply (simp_all del: image_insert parts_image
                add: analz_image_freshK_simps split_ifs shrK_in_analz_respond
                     resp_analz_image_freshK parts_insert2)
txt\<open>Base case of respond\<close>
apply blast
txt\<open>Inductive step of respond\<close>
apply (intro allI conjI impI, simp_all)
txt\<open>by unicity, either @{term "B=Aa"} or @{term "B=A'"}, a contradiction
     if @{term "B \<in> bad"}\<close>
apply (blast dest: unique_session_keys respond_certificate)
apply (blast dest!: respond_certificate)
apply (blast dest!: resp_analz_insert)
done

lemma Spy_not_see_session_key:
     "[| Crypt (shrK A) \<lbrace>Key K, Agent A', N\<rbrace> \<in> parts (spies evs);
         A \<notin> bad;  A' \<notin> bad;  evs \<in> recur |]
      ==> Key K \<notin> analz (spies evs)"
apply (erule rev_mp)
apply (erule recur.induct)
apply (drule_tac [4] RA2_analz_spies,
       frule_tac [5] respond_imp_responses,
       drule_tac [6] RA4_analz_spies,
       simp_all add: split_ifs analz_insert_eq analz_insert_freshK)
txt\<open>Fake\<close>
apply spy_analz
txt\<open>RA2\<close>
apply blast
txt\<open>RA3\<close>
apply (simp add: parts_insert_spies)
apply (metis Key_in_parts_respond parts.Body parts.Fst resp_analz_insert
             respond_Spy_not_see_session_key usedI)
txt\<open>RA4\<close>
apply blast
done

(**** Authenticity properties for Agents ****)

text\<open>The response never contains Hashes\<close>
lemma Hash_in_parts_respond:
     "[| Hash \<lbrace>Key (shrK B), M\<rbrace> \<in> parts (insert RB H);
         (PB,RB,K) \<in> respond evs |]
      ==> Hash \<lbrace>Key (shrK B), M\<rbrace> \<in> parts H"
apply (erule rev_mp)
apply (erule respond_imp_responses [THEN responses.induct], auto)
done

text\<open>Only RA1 or RA2 can have caused such a part of a message to appear.
  This result is of no use to B, who cannot verify the Hash.  Moreover,
  it can say nothing about how recent A's message is.  It might later be
  used to prove B's presence to A at the run's conclusion.\<close>
lemma Hash_auth_sender [rule_format]:
     "[| Hash \<lbrace>Key(shrK A), Agent A, Agent B, NA, P\<rbrace> \<in> parts(spies evs);
         A \<notin> bad;  evs \<in> recur |]
      ==> Says A B (Hash[Key(shrK A)] \<lbrace>Agent A, Agent B, NA, P\<rbrace>) \<in> set evs"
apply (unfold HPair_def)
apply (erule rev_mp)
apply (erule recur.induct,
       drule_tac [6] RA4_parts_spies,
       drule_tac [4] RA2_parts_spies,
       simp_all)
txt\<open>Fake, RA3\<close>
apply (blast dest: Hash_in_parts_respond)+
done

(** These two results subsume (for all agents) the guarantees proved
    separately for A and B in the Otway-Rees protocol.
**)

text\<open>Certificates can only originate with the Server.\<close>
lemma Cert_imp_Server_msg:
     "[| Crypt (shrK A) Y \<in> parts (spies evs);
         A \<notin> bad;  evs \<in> recur |]
      ==> \<exists>C RC. Says Server C RC \<in> set evs  &
                   Crypt (shrK A) Y \<in> parts {RC}"
apply (erule rev_mp, erule recur.induct, simp_all)
txt\<open>Fake\<close>
apply blast
txt\<open>RA1\<close>
apply blast
txt\<open>RA2: it cannot be a new Nonce, contradiction.\<close>
apply blast
txt\<open>RA3.  Pity that the proof is so brittle: this step requires the rewriting,
       which however would break all other steps.\<close>
apply (simp add: parts_insert_spies, blast)
txt\<open>RA4\<close>
apply blast
done

end


theory Proof_2_8
  imports Proofs_2
begin

abbreviation s where "s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value \<equiv>
(toEnv
             (setPstate (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) ERROR
               Ctrl'emergency))"

lemma VC8_R2_ind_proof: "toEnvP s0 \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'motionless \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'goUp \<or> getPstate s2 ERROR = Ctrl'goDown) \<and>
           ltime s2 ERROR = DELAY'TIMEOUT \<and> \<not> (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and> ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> \<not> getVarBool s2 moving') \<and>
          \<not> getVarBool s3 alarmButton' \<and>
          \<not> getVarBool s3 stuck' \<and>
          (\<forall>s4 s5.
              toEnvP s4 \<and>
              toEnvP s5 \<and>
              substate s3 s4 \<and>
              substate s4 s5 \<and>
              substate s5 s1 \<and>
              toEnvNum s4 s5 = ERROR \<longrightarrow>
              getPstate s4 ERROR = Ctrl'motionless \<and>
              \<not> getVarBool s5 alarmButton' \<and>
              \<not> getVarBool s5 stuck' \<and> \<not> (getVarBool s5 userAtTop' \<or> getVarBool s5 userAtBottom'))) \<or>
      (\<forall>s4 s5.
          toEnvP s4 \<and>
          toEnvP s5 \<and>
          substate s4 s5 \<and>
          substate s5 s1 \<and>
          toEnvNum s4 s5 = ERROR \<longrightarrow>
          getPstate s4 ERROR = Ctrl'motionless \<and>
          \<not> getVarBool s5 alarmButton' \<and> \<not> getVarBool s5 stuck' \<and> \<not> (getVarBool s5 userAtTop' \<or> getVarBool s5 userAtBottom'))) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'goUp \<longrightarrow> ltime s1 ERROR \<le> DELAY'TIMEOUT) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'goUp \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goUp) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = UP') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s0 \<and> getPstate s3 ERROR = Ctrl'goUp \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 ERROR \<longrightarrow> getPstate s1 ERROR = Ctrl'goUp) \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 < ltime s3 ERROR - ERROR \<longrightarrow>
            \<not> getVarBool s2 alarmButton' \<and> \<not> getVarBool s2 stuck' \<and> \<not> (getVarBool s2 userAtTop' \<or> getVarBool s2 userAtBottom'))) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'goDown \<longrightarrow> ltime s1 ERROR \<le> DELAY'TIMEOUT) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'goDown \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          ((getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'goDown) \<and>
           (getVarBool s3 userAtTop' \<or> getVarBool s3 userAtBottom') \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and>
           ltime s2 ERROR = SUSPENSION_TIME'TIMEOUT \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = DOWN') \<and>
          \<not> getVarBool s3 alarmButton' \<and> \<not> getVarBool s3 stuck')) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s0 \<and> getPstate s3 ERROR = Ctrl'goDown \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 ERROR \<longrightarrow> getPstate s1 ERROR = Ctrl'goDown) \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 < ltime s3 ERROR - ERROR \<longrightarrow>
            \<not> getVarBool s2 alarmButton' \<and> \<not> getVarBool s2 stuck' \<and> \<not> (getVarBool s2 userAtTop' \<or> getVarBool s2 userAtBottom'))) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'stuckState \<longrightarrow> ltime s1 ERROR \<le> SUSPENSION_TIME'TIMEOUT) \<and>
(\<forall>s1. toEnvP s1 \<and>
      substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'stuckState \<and> getVarBool s1 moving' \<and> getVarBool s1 direction' = UP' \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          (getPstate s2 ERROR = Ctrl'goUp \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = UP') \<and>
          \<not> getVarBool s3 alarmButton' \<and> getVarBool s3 stuck')) \<and>
(\<forall>s1. toEnvP s1 \<and>
      substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'stuckState \<and> getVarBool s1 moving' \<and> getVarBool s1 direction' = DOWN' \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          (getPstate s2 ERROR = Ctrl'goDown \<or>
           getPstate s2 ERROR = Ctrl'stuckState \<and> getVarBool s2 moving' \<and> getVarBool s2 direction' = DOWN') \<and>
          \<not> getVarBool s3 alarmButton' \<and> getVarBool s3 stuck')) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'stuckState \<and> \<not> getVarBool s1 moving' \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          toEnvNum s2 s1 = ltime s1 ERROR \<and>
          (getPstate s2 ERROR = Ctrl'motionless \<or> getPstate s2 ERROR = Ctrl'stuckState \<and> \<not> getVarBool s2 moving') \<and>
          \<not> getVarBool s3 alarmButton' \<and> getVarBool s3 stuck')) \<and>
(\<forall>s3. toEnvP s3 \<and> substate s3 s0 \<and> getPstate s3 ERROR = Ctrl'stuckState \<longrightarrow>
      (\<forall>s1. toEnvP s1 \<and> substate s1 s3 \<and> toEnvNum s1 s3 < ltime s3 ERROR \<longrightarrow>
            getPstate s1 ERROR = Ctrl'stuckState \<and>
            getVarBool s1 moving' = getVarBool s3 moving' \<and> getVarBool s1 direction' = getVarBool s3 direction') \<and>
      (\<forall>s2. toEnvP s2 \<and> substate s2 s3 \<and> toEnvNum s2 s3 < ltime s3 ERROR - ERROR \<longrightarrow>
            \<not> getVarBool s2 alarmButton' \<and> \<not> getVarBool s2 stuck' \<and> getVarBool s2 up' = DOWN' \<and> getVarBool s2 down' = DOWN')) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'emergency \<longrightarrow>
      (\<exists>s2 s3.
          toEnvP s2 \<and>
          toEnvP s3 \<and>
          substate s2 s3 \<and>
          substate s3 s1 \<and>
          toEnvNum s2 s3 = ERROR \<and>
          getPstate s2 ERROR \<noteq> Ctrl'emergency \<and>
          getVarBool s3 alarmButton' \<and>
          (\<forall>s4 s5.
              toEnvP s4 \<and> toEnvP s5 \<and> substate s3 s4 \<and> substate s4 s5 \<and> substate s5 s1 \<and> toEnvNum s4 s5 = ERROR \<longrightarrow>
              getPstate s4 ERROR = Ctrl'emergency \<and> getVarBool s5 up' = DOWN' \<and> getVarBool s5 down' = DOWN'))) \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'motionless \<longrightarrow>
      getVarBool s1 up' = DOWN' \<and> getVarBool s1 down' = DOWN' \<and> \<not> getVarBool s1 moving') \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'goUp \<longrightarrow>
      getVarBool s1 up' = UP' \<and> getVarBool s1 down' = DOWN' \<and> getVarBool s1 moving' \<and> getVarBool s1 direction' = UP') \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<and> getPstate s1 ERROR = Ctrl'goDown \<longrightarrow>
      getVarBool s1 up' = DOWN' \<and> getVarBool s1 down' = UP' \<and> getVarBool s1 moving' \<and> getVarBool s1 direction' = DOWN') \<and>
(\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<longrightarrow>
      getPstate s1 ERROR = Ctrl'motionless \<or>
      getPstate s1 ERROR = Ctrl'goUp \<or>
      getPstate s1 ERROR = Ctrl'goDown \<or> getPstate s1 ERROR = Ctrl'stuckState \<or> getPstate s1 ERROR = Ctrl'emergency) \<Longrightarrow>
toEnvP s2 \<Longrightarrow>
 getPstate (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) ERROR =
      Ctrl'goUp \<and>
     getVarBool (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value)
      alarmButton' \<and>
    \<not> DELAY'TIMEOUT
       \<le> ltime
           (setPstate (setVarAny s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) ERROR
             Ctrl'emergency)
           ERROR \<Longrightarrow>
toEnvP s5 \<and>
    substate s2 s5 \<and> substate s5 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) \<longrightarrow>
    pred2 s1 s2 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) s5"
  subgoal premises extraInvs0
    apply(induction rule: state_down_ind)
    using extraInvs0(1) extraInvs0(2) apply simp
     apply(simp only: pred2_def)
     apply(rule impI)
    apply(rule cut_rl[of "\<exists>s2. toEnvP s2 \<and>
     substate s2 s0 \<and>
     toEnvNum s2 s0 \<le> ltime s0 ERROR \<and>
     (getVarBool s2 up' = DOWN' \<and> getVarBool s2 down' = DOWN' \<or> getVarBool s2 userAtTop' \<or> getVarBool s2 userAtBottom')\<and>
(toEnvNum s2 s0 = ltime s0 Ctrl' \<longrightarrow> getVarBool s2 up' = False \<and> getVarBool s2 down' = False)
"])
      apply(drule exE)
       prefer 2
       apply assumption
    subgoal for s4
      apply((drule conjE)+)
                     prefer 16
      apply assumption
                    prefer 15
                    apply assumption
                   prefer 14
                   apply assumption
                  prefer 13
                  apply assumption
                 prefer 12
                 apply assumption
                prefer 11
                apply assumption
               prefer 10
               apply assumption
              prefer 9
              apply assumption
             prefer 8
             apply assumption
            prefer 7
            apply assumption
           prefer 6
           apply assumption
          prefer 5
          apply assumption
         prefer 4
         apply assumption
        prefer 3
        apply assumption
       prefer 2
       apply assumption
      apply(rule disjE[of "s4=s1" "substate s2 s4"])
        apply(cases "toEnvNum s4 s0 = DELAY'TIMEOUT")
         apply(rule disjI1)
         apply(simp split: if_splits)
         apply(rule cut_rl[of "toEnvNum emptyState s1 = toEnvNum emptyState s4"])
      using emptyState_substate toEnvNum3
          apply (metis gtimeE_inj substate_linear substate_trans)
         apply(rule cut_rl[of "toEnvNum s1 s0 = DELAY'TIMEOUT"])
          apply(rule cut_rl[of "substate s1 s0"])
      using emptyState_substate[of s1] emptyState_substate[of s4] toEnvNum3[of emptyState s1 s0] toEnvNum3[of emptyState s4 s0]
           apply simp
      using substate_trans apply blast
      using toEnvNum3 apply simp
        apply(rule disjI2)
        apply (simp split: if_splits)
        apply(rule disjE[of "substate s2 s4" "substate s4 s2 \<and> s2 \<noteq> s4"])
      using substate_linear substate_refl apply blast
         apply assumption
        apply(rule cut_rl[of "toEnvNum s4 s0 \<le> toEnvNum s2 s0"])
      using toEnvNum3[of s4 s2 s0] gtimeE_inj
         apply (metis add_diff_cancel_right' diff_is_0_eq' substate_toEnvNum_id)
      using extraInvs0(1) apply -[1]
         apply((drule conjE)+)
                          prefer 19
                          apply assumption
                         prefer 18
                         apply assumption
                        prefer 17
                        apply assumption
                       prefer 16
                       apply assumption
                      prefer 15
                      apply assumption
                     prefer 14
                     apply assumption
                    prefer 13
                    apply assumption
                   prefer 12
                   apply assumption
                  prefer 11
                  apply assumption
                 prefer 10
                 apply assumption
                prefer 9
                apply assumption
               prefer 8
               apply assumption
              prefer 7
              apply assumption
             prefer 6
             apply assumption
            prefer 5
            apply assumption
           prefer 4
           apply assumption
          prefer 3
          apply assumption
         prefer 2
         apply assumption
      subgoal premises prems
        using extraInvs0(3) prems(2) prems(9) prems(14) prems(24)
        by (metis One_nat_def antisym getPstate.simps(9) le_trans not_less_eq_eq numeral_plus_one one_plus_numeral_commute plus_1_eq_Suc prems(22) semiring_norm(5) semiring_norm(8) substate.simps(2) toEnvP.elims(2))
       apply(rule cut_rl[of "toEnvNum s1 s0 = DELAY'TIMEOUT"])
        apply(rule cut_rl[of "ltime s0 Ctrl' = DELAY'TIMEOUT"])
         apply simp
      using extraInvs0(3) apply -[1]
        apply (simp split: if_splits)
        apply(rule cut_rl[of "ltime s0 Ctrl' \<le> DELAY'TIMEOUT"])
      using le_antisym apply simp
      using extraInvs0(1) apply -[1]
        apply((drule conjE)+)
                         prefer 18
                         apply assumption
                        prefer 17
                        apply assumption
                       prefer 16
                       apply assumption
                      prefer 15
                      apply assumption
      prefer 14
                     apply assumption
                    prefer 13
                    apply assumption
                   prefer 12
                   apply assumption
                  prefer 11
                  apply assumption
                 prefer 10
                 apply assumption
                prefer 9
                apply assumption
               prefer 8
               apply assumption
              prefer 7
              apply assumption
             prefer 6
             apply assumption
            prefer 5
            apply assumption
           prefer 4
           apply assumption
          prefer 3
          apply assumption
         prefer 2
         apply assumption
      subgoal premises prems
        using prems(18) prems(22) prems(24) substate_refl by auto
       apply (simp split: if_splits)
      using toEnvNum3 apply simp
      apply(drule allE[of _ s4])
       prefer 2
       apply assumption
      apply(rule impE[of "toEnvP s4 \<and>
    substate s2 s4 \<and>
    substate s4 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) \<and>
    s4 \<noteq> s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value "
"(getVarBool s4 up' = UP' \<or> getVarBool s4 down' = UP') \<and> \<not> getVarBool s4 userAtTop' \<and> \<not> getVarBool s4 userAtBottom'"])
        apply assumption
       apply(rule cut_rl[of "\<not> substate (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value)  s0"])
        apply (simp split: if_splits)
 apply(rule cut_rl[of " s0 \<noteq> (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) "])
      apply(rule cut_rl[of "substate  s0  (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) "])
      using substate_antisym apply blast
      using substate_refl   by auto
     apply(rule goUp_notMoving[of _ s0])
     apply(rule conjI)
    using extraInvs0(1) apply fast
     apply(rule conjI)
    using substate_refl apply fast
     apply(rule conjI)
    using extraInvs0(3) apply simp
    using extraInvs0(1) apply fast

    subgoal for s5
      apply(simp only: pred2_def)
      apply(rule impI)
      apply(cases "(getVarBool (predEnv s5) up' = DOWN' \<and> getVarBool (predEnv s5) down' = DOWN' \<or>
 getVarBool (predEnv s5) userAtTop' \<or> getVarBool (predEnv s5) userAtBottom')")
       apply(rule exI[of _ "predEnv s5"])
       apply(rule conjI)
        apply(rule toEnvP_substate_pred_imp_toEnvP_pred[of s2])
        apply blast
       apply(rule conjI)
      using substate_refl apply simp
       apply(rule conjI)
      using predEnv_substate substate_trans apply blast
       apply(rule conjI)
      using toEnvNum3[of s2 "predEnv s5"
 "(s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) "]
      using le_add1 apply presburger
       apply(rule conjI)
      apply assumption
       apply (metis substate_antisym)
      apply(drule impE)
      apply(((rule conjI),blast)+)
        apply (metis substate_eq_or_predEnv)
       prefer 2
       apply assumption
      apply(drule exE)
       prefer 2
       apply assumption
      subgoal for s4
        apply(rule exI[of _ s4])
        apply(rule conjI)
         apply blast
        apply(rule conjI)
        using predEnv_substate substate_trans apply blast
        apply(((rule conjI),blast)+)
        by (metis predEnv_substate_imp_eq_or_substate)
      done
    done
  done

theorem proof_2_8: "VC8 inv2 env s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value"
  apply(simp only: VC8_def inv2_def R2_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
   apply((rule allI)+)
   apply(rule impI)
   apply((drule conjE)+)
                      prefer 32
                      apply assumption
 prefer 31
                      apply assumption
                       prefer 30
                      apply assumption
 prefer 29
                      apply assumption
 prefer 28
                      apply assumption
 prefer 27
                      apply assumption
 prefer 26
                      apply assumption
 prefer 25
                      apply assumption
 prefer 24
                      apply assumption
 prefer 23
                      apply assumption
 prefer 22
                      apply assumption
 prefer 21
                      apply assumption
 prefer 20
                      apply assumption
 prefer 19
                     apply assumption
 prefer 18
                    apply assumption
 prefer 17
                   apply assumption
 prefer 16
                  apply assumption
 prefer 15
                 apply assumption
                 prefer 14
                apply assumption
 prefer 13
               apply assumption
 prefer 12
              apply assumption
 prefer 11
             apply assumption
 prefer 10
            apply assumption
 prefer 9
           apply assumption
 prefer 8
          apply assumption
 prefer 7
         apply assumption
 prefer 6
        apply assumption
 prefer 5
       apply assumption
   prefer 4
      apply assumption
 prefer 3
     apply assumption
 prefer 2
    apply assumption
  subgoal premises prems for s1 s2
    apply(rule disjE[OF le_imp_less_or_eq[OF prems(13)]])
    apply(rule cut_rl[of "\<exists>s4. toEnvP s4 \<and>
         substate s2 s4 \<and>
         substate s4 s0 \<and>
         toEnvNum s2 s4 \<le> DELAY'TIMEOUT \<and>
         (getVarBool s4 up' = DOWN' \<and> getVarBool s4 down' = DOWN' \<or> getVarBool s4 userAtTop' \<or> getVarBool s4 userAtBottom') \<and>
         (\<forall>s3. toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s4 \<and> s3 \<noteq> s4 \<longrightarrow>
               (getVarBool s3 up' = UP' \<or> getVarBool s3 down' = UP') \<and> \<not> getVarBool s3 userAtTop' \<and> \<not> getVarBool s3 userAtBottom'
)"])
      apply(drule exE)
       prefer 2
       apply assumption
    subgoal for s4
      apply(rule exI[of _ s4])
      by simp
    using prems(2) prems(4) prems(6) prems(8) prems(9) prems(11) prems(15) prems(17) prems(18) apply -[1]
     apply(drule allE[of _ s1])
      prefer 2
    apply assumption
      apply(drule allE[of _ s2])
      prefer 2
      apply assumption
     apply (simp split: if_splits)
    apply(rule cut_rl[of
 "pred2 s1 s2 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value) s2"])
     apply(simp only: pred2_def)
     apply(drule impE)
    using prems(2) prems(4) prems(6) prems(8) prems(9) prems(15) prems(17) prems(18) substate_trans substate_refl
    using substate_antisym apply blast
      prefer 2
      apply assumption
     apply assumption
    apply(rule mp[of
 "toEnvP s2 \<and> substate s2 s2 \<and>
 substate s2 (s s0 userAtTop_value userAtBottom_value directionSwitch_value alarmButton_value stuck_value)"])
     apply(rule VC8_R2_ind_proof)
    using prems  apply fast
    using prems apply fast
    using prems apply fast
    apply(rule conjI)
    using prems apply fast
    apply(rule conjI)
    using substate_refl apply fast
    using prems by fast


(*  Title:      HOL/MicroJava/JVM/JVMDefensive.thy
    Author:     Gerwin Klein
*)

section \<open>A Defensive JVM\<close>

theory JVMDefensive
imports JVMExec
begin

text \<open>
  Extend the state space by one element indicating a type error (or
  other abnormal termination)\<close>
datatype 'a type_error = TypeError | Normal 'a

abbreviation
  fifth :: "'a \<times> 'b \<times> 'c \<times> 'd \<times> 'e \<times> 'f \<Rightarrow> 'e"
  where "fifth x == fst(snd(snd(snd(snd x))))"

fun isAddr :: "val \<Rightarrow> bool" where
  "isAddr (Addr loc) = True"
| "isAddr v          = False"

fun isIntg :: "val \<Rightarrow> bool" where
  "isIntg (Intg i) = True"
| "isIntg v        = False"

definition isRef :: "val \<Rightarrow> bool" where
  "isRef v \<equiv> v = Null \<or> isAddr v"

primrec check_instr :: "[instr, jvm_prog, aheap, opstack, locvars,
                  cname, sig, p_count, nat, frame list] \<Rightarrow> bool" where
  "check_instr (Load idx) G hp stk vars C sig pc mxs frs =
  (idx < length vars \<and> size stk < mxs)"

| "check_instr (Store idx) G hp stk vars Cl sig pc mxs frs =
  (0 < length stk \<and> idx < length vars)"

| "check_instr (LitPush v) G hp stk vars Cl sig pc mxs frs =
  (\<not>isAddr v \<and> size stk < mxs)"

| "check_instr (New C) G hp stk vars Cl sig pc mxs frs =
  (is_class G C \<and> size stk < mxs)"

| "check_instr (Getfield F C) G hp stk vars Cl sig pc mxs frs =
  (0 < length stk \<and> is_class G C \<and> field (G,C) F \<noteq> None \<and>
  (let (C', T) = the (field (G,C) F); ref = hd stk in
    C' = C \<and> isRef ref \<and> (ref \<noteq> Null \<longrightarrow>
      hp (the_Addr ref) \<noteq> None \<and>
      (let (D,vs) = the (hp (the_Addr ref)) in
        G \<turnstile> D \<preceq>C C \<and> vs (F,C) \<noteq> None \<and> G,hp \<turnstile> the (vs (F,C)) ::\<preceq> T))))"

| "check_instr (Putfield F C) G hp stk vars Cl sig pc mxs frs =
  (1 < length stk \<and> is_class G C \<and> field (G,C) F \<noteq> None \<and>
  (let (C', T) = the (field (G,C) F); v = hd stk; ref = hd (tl stk) in
    C' = C \<and> isRef ref \<and> (ref \<noteq> Null \<longrightarrow>
      hp (the_Addr ref) \<noteq> None \<and>
      (let (D,vs) = the (hp (the_Addr ref)) in
        G \<turnstile> D \<preceq>C C \<and> G,hp \<turnstile> v ::\<preceq> T))))"

| "check_instr (Checkcast C) G hp stk vars Cl sig pc mxs frs =
  (0 < length stk \<and> is_class G C \<and> isRef (hd stk))"

| "check_instr (Invoke C mn ps) G hp stk vars Cl sig pc mxs frs =
  (length ps < length stk \<and>
  (let n = length ps; v = stk!n in
  isRef v \<and> (v \<noteq> Null \<longrightarrow>
    hp (the_Addr v) \<noteq> None \<and>
    method (G,cname_of hp v) (mn,ps) \<noteq> None \<and>
    list_all2 (\<lambda>v T. G,hp \<turnstile> v ::\<preceq> T) (rev (take n stk)) ps)))"

| "check_instr Return G hp stk0 vars Cl sig0 pc mxs frs =
  (0 < length stk0 \<and> (0 < length frs \<longrightarrow>
    method (G,Cl) sig0 \<noteq> None \<and>
    (let v = hd stk0;  (C, rT, body) = the (method (G,Cl) sig0) in
    Cl = C \<and> G,hp \<turnstile> v ::\<preceq> rT)))"

| "check_instr Pop G hp stk vars Cl sig pc mxs frs =
  (0 < length stk)"

| "check_instr Dup G hp stk vars Cl sig pc mxs frs =
  (0 < length stk \<and> size stk < mxs)"

| "check_instr Dup_x1 G hp stk vars Cl sig pc mxs frs =
  (1 < length stk \<and> size stk < mxs)"

| "check_instr Dup_x2 G hp stk vars Cl sig pc mxs frs =
  (2 < length stk \<and> size stk < mxs)"

| "check_instr Swap G hp stk vars Cl sig pc mxs frs =
  (1 < length stk)"

| "check_instr IAdd G hp stk vars Cl sig pc mxs frs =
  (1 < length stk \<and> isIntg (hd stk) \<and> isIntg (hd (tl stk)))"

| "check_instr (Ifcmpeq b) G hp stk vars Cl sig pc mxs frs =
  (1 < length stk \<and> 0 \<le> int pc+b)"

| "check_instr (Goto b) G hp stk vars Cl sig pc mxs frs =
  (0 \<le> int pc+b)"

| "check_instr Throw G hp stk vars Cl sig pc mxs frs =
  (0 < length stk \<and> isRef (hd stk))"

definition check :: "jvm_prog \<Rightarrow> jvm_state \<Rightarrow> bool" where
  "check G s \<equiv> let (xcpt, hp, frs) = s in
               (case frs of [] \<Rightarrow> True | (stk,loc,C,sig,pc)#frs' \<Rightarrow>
                (let  (C',rt,mxs,mxl,ins,et) = the (method (G,C) sig); i = ins!pc in
                 pc < size ins \<and>
                 check_instr i G hp stk loc C sig pc mxs frs'))"

definition exec_d :: "jvm_prog \<Rightarrow> jvm_state type_error \<Rightarrow> jvm_state option type_error" where
  "exec_d G s \<equiv> case s of
      TypeError \<Rightarrow> TypeError
    | Normal s' \<Rightarrow> if check G s' then Normal (exec (G, s')) else TypeError"

definition
  exec_all_d :: "jvm_prog \<Rightarrow> jvm_state type_error \<Rightarrow> jvm_state type_error \<Rightarrow> bool"
                   ("_ \<turnstile> _ \<midarrow>jvmd\<rightarrow> _" [61,61,61]60) where
  "G \<turnstile> s \<midarrow>jvmd\<rightarrow> t \<longleftrightarrow>
         (s,t) \<in> ({(s,t). exec_d G s = TypeError \<and> t = TypeError} \<union>
                  {(s,t). \<exists>t'. exec_d G s = Normal (Some t') \<and> t = Normal t'})\<^sup>*"

declare split_paired_All [simp del]
declare split_paired_Ex [simp del]

lemma [dest!]:
  "(if P then A else B) \<noteq> B \<Longrightarrow> P"
  by (cases P, auto)

lemma exec_d_no_errorI [intro]:
  "check G s \<Longrightarrow> exec_d G (Normal s) \<noteq> TypeError"
  by (unfold exec_d_def) simp

theorem no_type_error_commutes:
  "exec_d G (Normal s) \<noteq> TypeError \<Longrightarrow>
  exec_d G (Normal s) = Normal (exec (G, s))"
  by (unfold exec_d_def, auto)

lemma defensive_imp_aggressive:
  "G \<turnstile> (Normal s) \<midarrow>jvmd\<rightarrow> (Normal t) \<Longrightarrow> G \<turnstile> s \<midarrow>jvm\<rightarrow> t"
proof -
  have "\<And>x y. G \<turnstile> x \<midarrow>jvmd\<rightarrow> y \<Longrightarrow> \<forall>s t. x = Normal s \<longrightarrow> y = Normal t \<longrightarrow>  G \<turnstile> s \<midarrow>jvm\<rightarrow> t"
    apply (unfold exec_all_d_def)
    apply (erule rtrancl_induct)
     apply (simp add: exec_all_def)
    apply (fold exec_all_d_def)
    apply simp
    apply (intro allI impI)
    apply (erule disjE, simp)
    apply (elim exE conjE)
    apply (erule allE, erule impE, assumption)
    apply (simp add: exec_all_def exec_d_def split: type_error.splits if_split_asm)
    apply (rule rtrancl_trans, assumption)
    apply blast
    done
  moreover
  assume "G \<turnstile> (Normal s) \<midarrow>jvmd\<rightarrow> (Normal t)"
  ultimately
  show "G \<turnstile> s \<midarrow>jvm\<rightarrow> t" by blast
qed

end


(*

Copyright (c) 2018, ETH Zurich
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

(*
 Contains definitions that are common to multiple controllers on the
 x86 platform, for instance the I/OAPIC and IOMMU have a the same
 destination mode/format fields.

 Based on intel programmers manual and
 "Intel \<registered> Virtualization Technology for Directed I/O", October 2014
*)

theory x86int
imports
  interrupt Main "HOL-Word.Word" "HOL-Word.WordBitwise"
begin

(* Delivery Mode *)
datatype DLM = DLMFIXED  | DLMLOWPRIO | DLMSMI | DLMNMI | DLMINIT | DLMEXTINT

(* Destination Mode *)
datatype DM = DMPHYS | DMLOGICAL

(* Trigger Mode *)
datatype TRIGGERM = TRIGGERMEDGE | TRIGGERMLEVEL

type_synonym word8 = "8 word"
type_synonym word4 = "4 word"

(* Encode Destination mode and the dest field (the dest field interpretation
   depends on the destination mode *)
datatype DMDEST = DMPHYS word4 | DMLOGICAL word8

(* IOAPIC Redirection table entry, see 82093AA Datasheet *)
record IOREDTBL_ENTRY =
  dest :: DMDEST
  mask :: bool
  trigger :: TRIGGERM
  delmode :: DLM
  remote_irr :: bool (* Read only *)
  intpol_high :: bool (* true=active high *)
  delivs :: bool (* Read only *)
  vector :: nat

(* This is for the original IOAPIC that has an 8 bit destination *)
definition ioredtbl_entry_well_formed :: "IOREDTBL_ENTRY \<Rightarrow> bool"
  where "ioredtbl_entry_well_formed iot \<longleftrightarrow> (vector iot) < 256"

definition tset :: "nat set"
  where "tset = {}"

definition to_indexset :: "word8 \<Rightarrow> nat set"
  where "to_indexset w = {x. (w !! x) }"

lemma "to_indexset 255 = {7,6,5,4,3,2,1,0}"
  using bin_nth_Bit0 bin_nth_Bit1 by (simp add:to_indexset_def, auto)

lemma bit_set_bound: "w !! n \<longrightarrow> n < 8"
  for w :: "8 word"
proof -
  have L1: "size w \<le> 8"
    by(simp only:word_size, auto)

  have L2: "w !! n \<longrightarrow> n < size w"
    by(simp add:test_bit_size)

  show ?thesis
    using L1 L2 less_trans by auto
qed

lemma to_indexset_bound: "\<forall> inp. to_indexset inp \<subseteq> {x. x < 8}"
  using bit_set_bound by (simp add: to_indexset_def, auto)

(* Turns a IOREDTBL_ENTRY at index i to a IRQ, Source: Intel 10.6.2.1 *)
definition ioredtbl_entry_to_irq_dest :: "IOREDTBL_ENTRY \<Rightarrow> IRQ set"
  where "ioredtbl_entry_to_irq_dest iot = (case (dest iot) of
    DMPHYS x \<Rightarrow> { \<lparr>format = FVECTOR (vector iot), port = unat x\<rparr> } |
    DMLOGICAL ldest \<Rightarrow> {x.\<exists>y \<in> (to_indexset ldest). x = \<lparr> format = FVECTOR (vector iot), port = y \<rparr>})"

(* In physical destination mode, the IOAPIC can address a 4 bit destination *)
lemma "\<forall>outi \<in> (ioredtbl_entry_to_irq_dest y). (port outi) < 16"
  apply(case_tac "dest y")
   apply(simp add:ioredtbl_entry_to_irq_dest_def, unat_arith, auto)
  apply(simp add:ioredtbl_entry_to_irq_dest_def)
  apply(auto)
  using bit_set_bound to_indexset_def by fastforce

end


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

header{*The n_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__54_on_rules imports n_g2kAbsAfter_lemma_on_inv__54
begin
section{*All lemmas on causal relation between inv__54*}
lemma lemma_inv__54_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__54  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_AStore_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__54) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__54) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      JinjaThreads/MM/SC.thy
    Author:     David von Oheimb, Andreas Lochbihler

    Based on the Jinja theories Common/Objects.thy and Common/Conform by David von Oheimb
*)

header {* \isaheader{Sequential consistency} *}

theory SC
imports
  "../Common/Conform"
  "MM"
begin

subsection{* Objects and Arrays *}

type_synonym
  fields = "vname \<times> cname \<rightharpoonup> addr val"       -- "field name, defining class, value"

type_synonym
  cells = "addr val list"

datatype heapobj
  = Obj cname fields
    -- "class instance with class name and fields"

  | Arr ty fields cells
    -- "element type, fields (from object), and list of each cell's content"

lemma rec_heapobj [simp]: "rec_heapobj = case_heapobj"
by(auto intro!: ext split: heapobj.split)

primrec obj_ty  :: "heapobj \<Rightarrow> htype"
where
  "obj_ty (Obj C f)     = Class_type C"
| "obj_ty (Arr T fs cs) = Array_type T (length cs)"

fun is_Arr :: "heapobj \<Rightarrow> bool" where
  "is_Arr (Obj C fs)   = False"
| "is_Arr (Arr T f el) = True"

lemma is_Arr_conv:
  "is_Arr arrobj = (\<exists>T f el. arrobj = Arr T f el)"
by(cases arrobj, auto)

lemma is_ArrE:
  "\<lbrakk> is_Arr arrobj; \<And>T f el. arrobj = Arr T f el \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
  "\<lbrakk> \<not> is_Arr arrobj; \<And>C fs. arrobj = Obj C fs \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
by(cases arrobj, auto)+

definition init_fields :: "('field_name \<times> (ty \<times> fmod)) list \<Rightarrow> 'field_name \<rightharpoonup> addr val"
where "init_fields \<equiv> map_of \<circ> map (\<lambda>(FD,(T, fm)). (FD,default_val T))"

primrec
  -- "a new, blank object with default values in all fields:"
  blank :: "'m prog \<Rightarrow> htype \<Rightarrow> heapobj"
where
  "blank P (Class_type C)   = Obj C (init_fields (fields P C))"
| "blank P (Array_type T n) = Arr T (init_fields (fields P Object)) (replicate n (default_val T))"

lemma obj_ty_blank [iff]:
  "obj_ty (blank P hT) = hT"
by(cases hT)(simp_all)

subsection{* Heap *}

type_synonym heap = "addr \<rightharpoonup> heapobj"

translations
  (type) "heap" <= (type) "nat \<Rightarrow> heapobj option"

abbreviation sc_empty :: heap
where "sc_empty \<equiv> empty"

fun the_obj :: "heapobj \<Rightarrow> cname \<times> fields" where
  "the_obj (Obj C fs) = (C, fs)"

fun the_arr :: "heapobj \<Rightarrow> ty \<times> fields \<times> cells" where
  "the_arr (Arr T f el) = (T, f, el)"

abbreviation
  cname_of :: "heap \<Rightarrow> addr \<Rightarrow> cname" where
  "cname_of hp a == fst (the_obj (the (hp a)))"

definition sc_allocate :: "'m prog \<Rightarrow> heap \<Rightarrow> htype \<Rightarrow> (heap \<times> addr) set"
where
  "sc_allocate P h hT =
   (case new_Addr h of None \<Rightarrow> {}
                   | Some a \<Rightarrow> {(h(a \<mapsto> blank P hT), a)})"

definition sc_typeof_addr :: "heap \<Rightarrow> addr \<Rightarrow> htype option"
where "sc_typeof_addr h a = map_option obj_ty (h a)"

inductive sc_heap_read :: "heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> bool"
for h :: heap and a :: addr
where
  Obj: "\<lbrakk> h a = \<lfloor>Obj C fs\<rfloor>; fs (F, D) = \<lfloor>v\<rfloor> \<rbrakk> \<Longrightarrow> sc_heap_read h a (CField D F) v"
| Arr: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; n < length el \<rbrakk> \<Longrightarrow> sc_heap_read h a (ACell n) (el ! n)"
| ArrObj: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; f (F, Object) = \<lfloor>v\<rfloor> \<rbrakk> \<Longrightarrow> sc_heap_read h a (CField Object F) v"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_read_cases [elim!]:
  "sc_heap_read h a (CField C F) v"
  "sc_heap_read h a (ACell n) v"

inductive sc_heap_write :: "heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> heap \<Rightarrow> bool"
for h :: heap and a :: addr
where
  Obj: "\<lbrakk> h a = \<lfloor>Obj C fs\<rfloor>; h' = h(a \<mapsto> Obj C (fs((F, D) \<mapsto> v))) \<rbrakk> \<Longrightarrow> sc_heap_write h a (CField D F) v h'"
| Arr: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; h' = h(a \<mapsto> Arr T f (el[n := v])) \<rbrakk> \<Longrightarrow> sc_heap_write h a (ACell n) v h'"
| ArrObj: "\<lbrakk> h a = \<lfloor>Arr T f el\<rfloor>; h' = h(a \<mapsto> Arr T (f((F, Object) \<mapsto> v)) el) \<rbrakk> \<Longrightarrow> sc_heap_write h a (CField Object F) v h'"

hide_fact (open) Obj Arr ArrObj

inductive_cases sc_heap_write_cases [elim!]:
  "sc_heap_write h a (CField C F) v h'"
  "sc_heap_write h a (ACell n) v h'"

consts sc_spurious_wakeups :: bool

interpretation sc!:
  heap_base
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P .

text {* Translate notation from @{text heap_base} *}

(* FIXME! Why does sc.preallocated need the type token?? *)
abbreviation sc_preallocated :: "'m prog \<Rightarrow> heap \<Rightarrow> bool"
where "sc_preallocated == sc.preallocated TYPE('m)"

abbreviation sc_start_tid :: "'md prog \<Rightarrow> thread_id"
where "sc_start_tid \<equiv> sc.start_tid TYPE('md)"

abbreviation sc_start_heap_ok :: "'m prog \<Rightarrow> bool"
where "sc_start_heap_ok \<equiv> sc.start_heap_ok TYPE('m)"

abbreviation sc_start_heap :: "'m prog \<Rightarrow> heap"
where "sc_start_heap \<equiv> sc.start_heap TYPE('m)"

abbreviation sc_start_state ::
  "(cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm \<Rightarrow> addr val list \<Rightarrow> 'x)
  \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> (addr, thread_id, 'x, heap, addr) state"
where
  "sc_start_state f P \<equiv> sc.start_state TYPE('m) P f P"

abbreviation sc_wf_start_state :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> bool"
where "sc_wf_start_state P \<equiv> sc.wf_start_state TYPE('m) P P"

notation sc.conf ("_,_ \<turnstile>sc _ :\<le> _"  [51,51,51,51] 50)
notation sc.confs ("_,_ \<turnstile>sc _ [:\<le>] _" [51,51,51,51] 50)
notation sc.hext ("_ \<unlhd>sc _" [51,51] 50)

lemma sc_start_heap_ok: "sc_start_heap_ok P"
apply(simp add: sc.start_heap_ok_def sc.start_heap_data_def initialization_list_def sc.create_initial_object_simps sc_allocate_def sys_xcpts_list_def case_option_conv_if new_Addr_SomeI del: blank.simps split del: option.split split_if)
done

lemma sc_wf_start_state_iff:
  "sc_wf_start_state P C M vs \<longleftrightarrow> (\<exists>Ts T meth D. P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>meth\<rfloor> in D \<and> P,sc_start_heap P \<turnstile>sc vs [:\<le>] Ts)"
by(simp add: sc.wf_start_state.simps sc_start_heap_ok)

lemma sc_heap:
  "heap addr2thread_id thread_id2addr (sc_allocate P) sc_typeof_addr sc_heap_write P"
proof
  fix h' a h hT
  assume "(h', a) \<in> sc_allocate P h hT"
  thus "sc_typeof_addr h' a = \<lfloor>hT\<rfloor>"
    by(auto simp add: sc_allocate_def sc_typeof_addr_def dest: new_Addr_SomeD split: split_if_asm)
next
  fix h' h hT a
  assume "(h', a) \<in> sc_allocate P h hT"
  from this[symmetric] show "h \<unlhd>sc h'"
    by(fastforce simp add: sc_allocate_def sc_typeof_addr_def sc.hext_def dest: new_Addr_SomeD intro!: map_leI)
next
  fix h a al v h'
  assume "sc_heap_write h a al v h'"
  thus "h \<unlhd>sc h'"
    by(cases al)(auto intro!: sc.hextI simp add: sc_typeof_addr_def)
qed simp

interpretation sc!:
  heap
    "addr2thread_id"
    "thread_id2addr"
    "sc_spurious_wakeups"
    "sc_empty"
    "sc_allocate P"
    "sc_typeof_addr"
    "sc_heap_read"
    "sc_heap_write"
  for P by(rule sc_heap)

lemma sc_hext_new:
  "h a = None \<Longrightarrow> h \<unlhd>sc h(a \<mapsto> arrobj)"
by(rule sc.hextI)(auto simp add: sc_typeof_addr_def dest!: new_Addr_SomeD)

lemma sc_hext_upd_obj: "h a = Some (Obj C fs) \<Longrightarrow> h \<unlhd>sc h(a\<mapsto>(Obj C fs'))"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def)

lemma sc_hext_upd_arr: "\<lbrakk> h a = Some (Arr T f e); length e = length e' \<rbrakk> \<Longrightarrow> h \<unlhd>sc h(a\<mapsto>(Arr T f' e'))"
by(rule sc.hextI)(auto simp:fun_upd_apply sc_typeof_addr_def)

subsection {* Conformance *}

definition sc_fconf :: "'m prog \<Rightarrow> cname \<Rightarrow> heap \<Rightarrow> fields \<Rightarrow> bool" ("_,_,_ \<turnstile>sc _ \<surd>" [51,51,51,51] 50)
where "P,C,h \<turnstile>sc fs \<surd> = (\<forall>F D T fm. P \<turnstile> C has F:T (fm) in D \<longrightarrow> (\<exists>v. fs(F,D) = Some v \<and> P,h \<turnstile>sc v :\<le> T))"

primrec sc_oconf :: "'m prog \<Rightarrow> heap \<Rightarrow> heapobj \<Rightarrow> bool"   ("_,_ \<turnstile>sc _ \<surd>" [51,51,51] 50)
where
  "P,h \<turnstile>sc Obj C fs \<surd> \<longleftrightarrow> is_class P C \<and> P,C,h \<turnstile>sc fs \<surd>"
| "P,h \<turnstile>sc Arr T fs el \<surd> \<longleftrightarrow> is_type P (T\<lfloor>\<rceil>) \<and> P,Object,h \<turnstile>sc fs \<surd> \<and> (\<forall>v \<in> set el. P,h \<turnstile>sc v :\<le> T)"

definition sc_hconf :: "'m prog \<Rightarrow> heap \<Rightarrow> bool"  ("_ \<turnstile>sc _ \<surd>" [51,51] 50)
where "P \<turnstile>sc h \<surd> \<longleftrightarrow> (\<forall>a obj. h a = Some obj \<longrightarrow> P,h \<turnstile>sc obj \<surd>)"

interpretation sc!: heap_conf_base
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P .

declare sc.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemma sc_conf_upd_obj: "h a = Some(Obj C fs) \<Longrightarrow> (P,h(a\<mapsto>(Obj C fs')) \<turnstile>sc x :\<le> T) = (P,h \<turnstile>sc x :\<le> T)"
apply (unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply (auto simp add: sc_typeof_addr_def split: split_if_asm)
done

lemma sc_conf_upd_arr: "h a = Some(Arr T f el) \<Longrightarrow> (P,h(a\<mapsto>(Arr T f' el')) \<turnstile>sc x :\<le> T') = (P,h \<turnstile>sc x :\<le> T')"
apply(unfold sc.conf_def)
apply (rule val.induct)
apply (auto simp:fun_upd_apply)
apply(auto simp add: sc_typeof_addr_def split: split_if_asm)
done

lemma sc_oconf_init:
 "is_htype P hT \<Longrightarrow> P,h \<turnstile>sc blank P hT \<surd>"
by(cases hT)(auto simp add: sc_fconf_def has_field_def init_fields_def split_def o_def map_of_map[simplified split_def, where f="\<lambda>p. default_val (fst p)"] dest: has_fields_fun)

lemma sc_oconf_fupd [intro?]:
  "\<lbrakk> P \<turnstile> C has F:T (fm) in D; P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Obj C fs) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Obj C (fs((F,D)\<mapsto>v))) \<surd>"
unfolding has_field_def
by(auto simp add: sc_fconf_def has_field_def dest: has_fields_fun)

lemma sc_oconf_fupd_arr [intro?]:
  "\<lbrakk> P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Arr T f el) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Arr T f (el[i := v])) \<surd>"
by(auto dest: subsetD[OF set_update_subset_insert])

lemma sc_oconf_fupd_arr_fields:
  "\<lbrakk> P \<turnstile> Object has F:T (fm) in Object; P,h \<turnstile>sc v :\<le> T; P,h \<turnstile>sc (Arr T' f el) \<surd> \<rbrakk>
  \<Longrightarrow> P,h \<turnstile>sc (Arr T' (f((F, Object) \<mapsto> v)) el) \<surd>"
by(auto dest: has_fields_fun simp add: sc_fconf_def has_field_def)

lemma sc_oconf_new: "\<lbrakk> P,h \<turnstile>sc obj \<surd>; h a = None \<rbrakk> \<Longrightarrow> P,h(a \<mapsto> arrobj) \<turnstile>sc obj \<surd>"
by(erule sc_oconf_hext)(rule sc_hext_new)

lemmas sc_oconf_upd_obj = sc_oconf_hext [OF _ sc_hext_upd_obj]

lemma sc_oconf_upd_arr:
  assumes "P,h \<turnstile>sc obj \<surd>"
  and ha: "h a = \<lfloor>Arr T f el\<rfloor>"
  shows "P,h(a \<mapsto> Arr T f' el') \<turnstile>sc obj \<surd>"
using assms
by(cases obj)(auto simp add: sc_conf_upd_arr[where h=h, OF ha] sc_fconf_def)

lemma sc_hconfD: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = Some obj \<rbrakk> \<Longrightarrow> P,h \<turnstile>sc obj \<surd>"
unfolding sc_hconf_def by blast

lemmas sc_preallocated_new = sc.preallocated_hext[OF _ sc_hext_new]
lemmas sc_preallocated_upd_obj = sc.preallocated_hext [OF _ sc_hext_upd_obj]
lemmas sc_preallocated_upd_arr = sc.preallocated_hext [OF _ sc_hext_upd_arr]

lemma sc_hconf_new: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = None; P,h \<turnstile>sc obj \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc h(a\<mapsto>obj) \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_new)

lemma sc_hconf_upd_obj: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = Some (Obj C fs); P,h \<turnstile>sc (Obj C fs') \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc h(a\<mapsto>(Obj C fs')) \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_obj simp del: sc_oconf.simps)

lemma sc_hconf_upd_arr: "\<lbrakk> P \<turnstile>sc h \<surd>; h a = Some(Arr T f el); P,h \<turnstile>sc (Arr T f' el') \<surd> \<rbrakk> \<Longrightarrow> P \<turnstile>sc h(a\<mapsto>(Arr T f' el')) \<surd>"
unfolding sc_hconf_def
by(auto intro: sc_oconf_upd_arr simp del: sc_oconf.simps)

lemma sc_heap_conf:
  "heap_conf addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_write (sc_hconf P) P"
proof
  show "P \<turnstile>sc sc_empty \<surd>" by(simp add: sc_hconf_def)
next
  fix h a hT
  assume "sc_typeof_addr h a = \<lfloor>hT\<rfloor>" "P \<turnstile>sc h \<surd>"
  thus "is_htype P hT"
    by(auto simp add: sc_typeof_addr_def sc_oconf_def dest!: sc_hconfD split: heapobj.split_asm)
next
  fix h h' hT a
  assume "P \<turnstile>sc h \<surd>" "(h', a) \<in> sc_allocate P h hT" "is_htype P hT"
  thus "P \<turnstile>sc h' \<surd>"
    by(auto simp add: sc_allocate_def dest!: new_Addr_SomeD intro: sc_hconf_new sc_oconf_init split: split_if_asm)
next
  fix h a al T v h'
  assume "P \<turnstile>sc h \<surd>"
    and "sc.addr_loc_type P h a al T"
    and "P,h \<turnstile>sc v :\<le> T"
    and "sc_heap_write h a al v h'"
  thus "P \<turnstile>sc h' \<surd>"
    by(cases al)(fastforce elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def intro: sc_hconf_upd_obj sc_oconf_fupd sc_hconfD sc_hconf_upd_arr sc_oconf_fupd_arr sc_oconf_fupd_arr_fields)+
qed

interpretation sc!: heap_conf
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_conf)

lemma sc_heap_progress:
  "heap_progress addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al T
  assume hconf: "P \<turnstile>sc h \<surd>"
    and alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "h a = \<lfloor>arrobj\<rfloor>"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  from alt show "\<exists>v. sc_heap_read h a al v \<and> P,h \<turnstile>sc v :\<le> T"
  proof(cases)
    case (addr_loc_type_field U F fm D)
    note [simp] = `al = CField D F`
    show ?thesis
    proof(cases "arrobj")
      case (Obj C' fs)
      with `sc_typeof_addr h a = \<lfloor>U\<rfloor>` arrobj
      have [simp]: "C' = class_type_of U" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Obj have "P,h \<turnstile>sc Obj (class_type_of U) fs \<surd>" by(auto dest: sc_hconfD)
      with `P \<turnstile> class_type_of U has F:T (fm) in D` obtain v
        where "fs (F, D) = \<lfloor>v\<rfloor>" "P,h \<turnstile>sc v :\<le> T" by(fastforce simp add: sc_fconf_def)
      thus ?thesis using Obj arrobj by(auto intro: sc_heap_read.intros)
    next
      case (Arr T' f el)
      with `sc_typeof_addr h a = \<lfloor>U\<rfloor>` arrobj
      have [simp]: "U = Array_type T' (length el)" by(auto simp add: sc_typeof_addr_def)
      from hconf arrobj Arr have "P,h \<turnstile>sc Arr T' f el \<surd>" by(auto dest: sc_hconfD)
      from `P \<turnstile> class_type_of U has F:T (fm) in D` have [simp]: "D = Object"
        by(auto dest: has_field_decl_above)
      with `P,h \<turnstile>sc Arr T' f el \<surd>` `P \<turnstile> class_type_of U has F:T (fm) in D`
      obtain v where "f (F, Object) = \<lfloor>v\<rfloor>" "P,h \<turnstile>sc v :\<le> T"
        by(fastforce simp add: sc_fconf_def)
      thus ?thesis using Arr arrobj by(auto intro: sc_heap_read.intros)
    qed
  next
    case (addr_loc_type_cell n' n)
    with arrobj obtain f el
      where [simp]: "arrobj = Arr T f el"
      by(cases arrobj)(auto simp add: sc_typeof_addr_def)
    from addr_loc_type_cell arrobj
    have [simp]: "al = ACell n" "n < length el" by(auto simp add: sc_typeof_addr_def)
    from hconf arrobj have "P,h \<turnstile>sc Arr T f el \<surd>" by(auto dest: sc_hconfD)
    hence "P,h \<turnstile>sc el ! n :\<le> T" by(fastforce)
    thus ?thesis using arrobj by(fastforce intro: sc_heap_read.intros)
  qed
next
  fix h a al T v
  assume alt: "sc.addr_loc_type P h a al T"
  from alt obtain arrobj where arrobj: "h a = \<lfloor>arrobj\<rfloor>"
    by(auto elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def)
  thus "\<exists>h'. sc_heap_write h a al v h'" using alt
    by(cases arrobj)(fastforce intro: sc_heap_write.intros elim!: sc.addr_loc_type.cases simp add: sc_typeof_addr_def dest: has_field_decl_above)+
qed

interpretation sc!: heap_progress
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_progress)

lemma sc_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr sc_empty (sc_allocate P) sc_typeof_addr sc_heap_read sc_heap_write (sc_hconf P) P"
proof
  fix h a al v T
  assume read: "sc_heap_read h a al v"
    and alt: "sc.addr_loc_type P h a al T"
    and hconf: "P \<turnstile>sc h \<surd>"
  thus "P,h \<turnstile>sc v :\<le> T"
    by(auto elim!: sc_heap_read.cases sc.addr_loc_type.cases simp add: sc_typeof_addr_def)(fastforce dest!: sc_hconfD simp add: sc_fconf_def)+
qed

interpretation sc!: heap_conf_read
  "addr2thread_id"
  "thread_id2addr"
  "sc_spurious_wakeups"
  "sc_empty"
  "sc_allocate P"
  "sc_typeof_addr"
  "sc_heap_read"
  "sc_heap_write"
  "sc_hconf P"
  "P"
for P
by(rule sc_heap_conf_read)

abbreviation sc_deterministic_heap_ops :: "'m prog \<Rightarrow> bool"
where "sc_deterministic_heap_ops \<equiv> sc.deterministic_heap_ops TYPE('m)"

lemma sc_deterministic_heap_ops: "\<not> sc_spurious_wakeups \<Longrightarrow> sc_deterministic_heap_ops P"
by(rule sc.deterministic_heap_opsI)(auto elim: sc_heap_read.cases sc_heap_write.cases simp add: sc_allocate_def)

subsection {* Code generation *}

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  sc_heap_read .

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  sc_heap_write .

lemma eval_sc_heap_read_i_i_i_o:
  "Predicate.eval (sc_heap_read_i_i_i_o h ad al) = sc_heap_read h ad al"
by(auto elim: sc_heap_read_i_i_i_oE intro: sc_heap_read_i_i_i_oI intro!: ext)

lemma eval_sc_heap_write_i_i_i_i_o:
  "Predicate.eval (sc_heap_write_i_i_i_i_o h ad al v) = sc_heap_write h ad al v"
by(auto elim: sc_heap_write_i_i_i_i_oE intro: sc_heap_write_i_i_i_i_oI intro!: ext)

end


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

header{*The n_mutualExOnI Protocol Case Study*}

theory n_mutualExOnI_lemma_on_inv__2 imports n_mutualExOnI_base
begin
section{*All lemmas on causal relation between inv__2 and some rule r*}
lemma n_TryVsinv__2:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)" and
a2: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__2  p__Inv0 p__Inv1)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_Try  i" apply fastforce done
from a2 obtain p__Inv0 p__Inv1 where a2:"p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__2  p__Inv0 p__Inv1" apply fastforce done
have "(i=p__Inv0)\<or>(i=p__Inv1)\<or>(i~=p__Inv0\<and>i~=p__Inv1)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv0)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Para (Ident ''n'') p__Inv1)) (Const C)) (eqn (IVar (Para (Ident ''n'') p__Inv0)) (Const I))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i=p__Inv1)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv0\<and>i~=p__Inv1)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

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

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

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