(*  Title:      HOL/Bali/Evaln.thy
    Author:     David von Oheimb and Norbert Schirmer
*)
subsection \<open>Operational evaluation (big-step) semantics of Java expressions and
          statements
\<close>

theory Evaln imports TypeSafe begin

text \<open>
Variant of @{term eval} relation with counter for bounded recursive depth.
In principal @{term evaln} could replace @{term eval}.

Validity of the axiomatic semantics builds on @{term evaln}.
For recursive method calls the axiomatic semantics rule assumes the method ok
to derive a proof for the body. To prove the method rule sound we need to
perform induction on the recursion depth.
For the completeness proof of the axiomatic semantics the notion of the most
general formula is used. The most general formula right now builds on the
ordinary evaluation relation @{term eval}.
So sometimes we have to switch between @{term evaln} and @{term eval} and vice
versa. To make
this switch easy @{term evaln} also does all the technical accessibility tests
@{term check_field_access} and @{term check_method_access} like @{term eval}.
If it would omit them @{term evaln} and @{term eval} would only be equivalent
for welltyped, and definitely assigned terms.
\<close>

inductive
  evaln :: "[prog, state, term, nat, vals, state] \<Rightarrow> bool"
    ("_\<turnstile>_ \<midarrow>_\<succ>\<midarrow>_\<rightarrow> '(_, _')" [61,61,80,61,0,0] 60)
  and evarn :: "[prog, state, var, vvar, nat, state] \<Rightarrow> bool"
    ("_\<turnstile>_ \<midarrow>_=\<succ>_\<midarrow>_\<rightarrow> _" [61,61,90,61,61,61] 60)
  and eval_n:: "[prog, state, expr, val, nat, state] \<Rightarrow> bool"
    ("_\<turnstile>_ \<midarrow>_-\<succ>_\<midarrow>_\<rightarrow> _" [61,61,80,61,61,61] 60)
  and evalsn :: "[prog, state, expr list, val  list, nat, state] \<Rightarrow> bool"
    ("_\<turnstile>_ \<midarrow>_\<doteq>\<succ>_\<midarrow>_\<rightarrow> _" [61,61,61,61,61,61] 60)
  and execn     :: "[prog, state, stmt, nat, state] \<Rightarrow> bool"
    ("_\<turnstile>_ \<midarrow>_\<midarrow>_\<rightarrow> _"     [61,61,65,   61,61] 60)
  for G :: prog
where

  "G\<turnstile>s \<midarrow>c     \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In1r  c\<succ>\<midarrow>n\<rightarrow> (\<diamondsuit>    ,  s')"
| "G\<turnstile>s \<midarrow>e-\<succ>v  \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In1l e\<succ>\<midarrow>n\<rightarrow> (In1 v ,  s')"
| "G\<turnstile>s \<midarrow>e=\<succ>vf \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In2  e\<succ>\<midarrow>n\<rightarrow> (In2 vf,  s')"
| "G\<turnstile>s \<midarrow>e\<doteq>\<succ>v  \<midarrow>n\<rightarrow>    s' \<equiv> G\<turnstile>s \<midarrow>In3  e\<succ>\<midarrow>n\<rightarrow> (In3 v ,  s')"

\<comment>\<open>propagation of abrupt completion\<close>

| Abrupt:   "G\<turnstile>(Some xc,s) \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (undefined3 t,(Some xc,s))"

\<comment>\<open>evaluation of variables\<close>

| LVar: "G\<turnstile>Norm s \<midarrow>LVar vn=\<succ>lvar vn s\<midarrow>n\<rightarrow> Norm s"

| FVar: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init statDeclC\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>e-\<succ>a\<midarrow>n\<rightarrow> s2;
          (v,s2') = fvar statDeclC stat fn a s2;
          s3 = check_field_access G accC statDeclC fn stat a s2'\<rbrakk> \<Longrightarrow>
          G\<turnstile>Norm s0 \<midarrow>{accC,statDeclC,stat}e..fn=\<succ>v\<midarrow>n\<rightarrow> s3"

| AVar: "\<lbrakk>G\<turnstile> Norm s0 \<midarrow>e1-\<succ>a\<midarrow>n\<rightarrow> s1 ; G\<turnstile>s1 \<midarrow>e2-\<succ>i\<midarrow>n\<rightarrow> s2;
          (v,s2') = avar G i a s2\<rbrakk> \<Longrightarrow>
                      G\<turnstile>Norm s0 \<midarrow>e1.[e2]=\<succ>v\<midarrow>n\<rightarrow> s2'"

\<comment>\<open>evaluation of expressions\<close>

| NewC: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s1;
          G\<turnstile>     s1 \<midarrow>halloc (CInst C)\<succ>a\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                  G\<turnstile>Norm s0 \<midarrow>NewC C-\<succ>Addr a\<midarrow>n\<rightarrow> s2"

| NewA: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>init_comp_ty T\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>e-\<succ>i'\<midarrow>n\<rightarrow> s2;
          G\<turnstile>abupd (check_neg i') s2 \<midarrow>halloc (Arr T (the_Intg i'))\<succ>a\<rightarrow> s3\<rbrakk> \<Longrightarrow>
                                G\<turnstile>Norm s0 \<midarrow>New T[e]-\<succ>Addr a\<midarrow>n\<rightarrow> s3"

| Cast: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1;
          s2 = abupd (raise_if (\<not>G,snd s1\<turnstile>v fits T) ClassCast) s1\<rbrakk> \<Longrightarrow>
                                G\<turnstile>Norm s0 \<midarrow>Cast T e-\<succ>v\<midarrow>n\<rightarrow> s2"

| Inst: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1;
          b = (v\<noteq>Null \<and> G,store s1\<turnstile>v fits RefT T)\<rbrakk> \<Longrightarrow>
                              G\<turnstile>Norm s0 \<midarrow>e InstOf T-\<succ>Bool b\<midarrow>n\<rightarrow> s1"

| Lit:                     "G\<turnstile>Norm s \<midarrow>Lit v-\<succ>v\<midarrow>n\<rightarrow> Norm s"

| UnOp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1\<rbrakk>
         \<Longrightarrow> G\<turnstile>Norm s0 \<midarrow>UnOp unop e-\<succ>(eval_unop unop v)\<midarrow>n\<rightarrow> s1"

| BinOp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e1-\<succ>v1\<midarrow>n\<rightarrow> s1;
           G\<turnstile>s1 \<midarrow>(if need_second_arg binop v1 then (In1l e2) else (In1r Skip))
            \<succ>\<midarrow>n\<rightarrow> (In1 v2,s2)\<rbrakk>
         \<Longrightarrow> G\<turnstile>Norm s0 \<midarrow>BinOp binop e1 e2-\<succ>(eval_binop binop v1 v2)\<midarrow>n\<rightarrow> s2"

| Super:                   "G\<turnstile>Norm s \<midarrow>Super-\<succ>val_this s\<midarrow>n\<rightarrow> Norm s"

| Acc:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>va=\<succ>(v,f)\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                  G\<turnstile>Norm s0 \<midarrow>Acc va-\<succ>v\<midarrow>n\<rightarrow> s1"

| Ass:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>va=\<succ>(w,f)\<midarrow>n\<rightarrow> s1;
          G\<turnstile>     s1 \<midarrow>e-\<succ>v     \<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                   G\<turnstile>Norm s0 \<midarrow>va:=e-\<succ>v\<midarrow>n\<rightarrow> assign f v s2"

| Cond: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e0-\<succ>b\<midarrow>n\<rightarrow> s1;
          G\<turnstile>     s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                            G\<turnstile>Norm s0 \<midarrow>e0 ? e1 : e2-\<succ>v\<midarrow>n\<rightarrow> s2"

| Call:
  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>args\<doteq>\<succ>vs\<midarrow>n\<rightarrow> s2;
    D = invocation_declclass G mode (store s2) a' statT \<lparr>name=mn,parTs=pTs\<rparr>;
    s3=init_lvars G D \<lparr>name=mn,parTs=pTs\<rparr> mode a' vs s2;
    s3' = check_method_access G accC statT mode \<lparr>name=mn,parTs=pTs\<rparr> a' s3;
    G\<turnstile>s3'\<midarrow>Methd D \<lparr>name=mn,parTs=pTs\<rparr>-\<succ>v\<midarrow>n\<rightarrow> s4
   \<rbrakk>
   \<Longrightarrow>
    G\<turnstile>Norm s0 \<midarrow>{accC,statT,mode}e\<cdot>mn({pTs}args)-\<succ>v\<midarrow>n\<rightarrow> (restore_lvars s2 s4)"

| Methd:"\<lbrakk>G\<turnstile>Norm s0 \<midarrow>body G D sig-\<succ>v\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                G\<turnstile>Norm s0 \<midarrow>Methd D sig-\<succ>v\<midarrow>Suc n\<rightarrow> s1"

| Body: "\<lbrakk>G\<turnstile>Norm s0\<midarrow>Init D\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>c\<midarrow>n\<rightarrow> s2;
          s3 = (if (\<exists> l. abrupt s2 = Some (Jump (Break l)) \<or>
                         abrupt s2 = Some (Jump (Cont l)))
                  then abupd (\<lambda> x. Some (Error CrossMethodJump)) s2
                  else s2)\<rbrakk>\<Longrightarrow>
         G\<turnstile>Norm s0 \<midarrow>Body D c
          -\<succ>the (locals (store s2) Result)\<midarrow>n\<rightarrow>abupd (absorb Ret) s3"

\<comment>\<open>evaluation of expression lists\<close>

| Nil:
                                "G\<turnstile>Norm s0 \<midarrow>[]\<doteq>\<succ>[]\<midarrow>n\<rightarrow> Norm s0"

| Cons: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e -\<succ> v \<midarrow>n\<rightarrow> s1;
          G\<turnstile>     s1 \<midarrow>es\<doteq>\<succ>vs\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                             G\<turnstile>Norm s0 \<midarrow>e#es\<doteq>\<succ>v#vs\<midarrow>n\<rightarrow> s2"

\<comment>\<open>execution of statements\<close>

| Skip:                             "G\<turnstile>Norm s \<midarrow>Skip\<midarrow>n\<rightarrow> Norm s"

| Expr: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                  G\<turnstile>Norm s0 \<midarrow>Expr e\<midarrow>n\<rightarrow> s1"

| Lab:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c \<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                             G\<turnstile>Norm s0 \<midarrow>l\<bullet> c\<midarrow>n\<rightarrow> abupd (absorb l) s1"

| Comp: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1 \<midarrow>n\<rightarrow> s1;
          G\<turnstile>     s1 \<midarrow>c2 \<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>c1;; c2\<midarrow>n\<rightarrow> s2"

| If:   "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n\<rightarrow> s1;
          G\<turnstile>     s1\<midarrow>(if the_Bool b then c1 else c2)\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
                       G\<turnstile>Norm s0 \<midarrow>If(e) c1 Else c2 \<midarrow>n\<rightarrow> s2"

| Loop: "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n\<rightarrow> s1;
          if the_Bool b
             then (G\<turnstile>s1 \<midarrow>c\<midarrow>n\<rightarrow> s2 \<and>
                   G\<turnstile>(abupd (absorb (Cont l)) s2) \<midarrow>l\<bullet> While(e) c\<midarrow>n\<rightarrow> s3)
             else s3 = s1\<rbrakk> \<Longrightarrow>
                              G\<turnstile>Norm s0 \<midarrow>l\<bullet> While(e) c\<midarrow>n\<rightarrow> s3"

| Jmp: "G\<turnstile>Norm s \<midarrow>Jmp j\<midarrow>n\<rightarrow> (Some (Jump j), s)"

| Throw:"\<lbrakk>G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<midarrow>n\<rightarrow> s1\<rbrakk> \<Longrightarrow>
                                 G\<turnstile>Norm s0 \<midarrow>Throw e\<midarrow>n\<rightarrow> abupd (throw a') s1"

| Try:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>sxalloc\<rightarrow> s2;
          if G,s2\<turnstile>catch tn then G\<turnstile>new_xcpt_var vn s2 \<midarrow>c2\<midarrow>n\<rightarrow> s3 else s3 = s2\<rbrakk>
          \<Longrightarrow>
                  G\<turnstile>Norm s0 \<midarrow>Try c1 Catch(tn vn) c2\<midarrow>n\<rightarrow> s3"

| Fin:  "\<lbrakk>G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n\<rightarrow> (x1,s1);
          G\<turnstile>Norm s1 \<midarrow>c2\<midarrow>n\<rightarrow> s2;
          s3=(if (\<exists> err. x1=Some (Error err))
              then (x1,s1)
              else abupd (abrupt_if (x1\<noteq>None) x1) s2)\<rbrakk> \<Longrightarrow>
              G\<turnstile>Norm s0 \<midarrow>c1 Finally c2\<midarrow>n\<rightarrow> s3"

| Init: "\<lbrakk>the (class G C) = c;
          if inited C (globs s0) then s3 = Norm s0
          else (G\<turnstile>Norm (init_class_obj G C s0)
                  \<midarrow>(if C = Object then Skip else Init (super c))\<midarrow>n\<rightarrow> s1 \<and>
                G\<turnstile>set_lvars empty s1 \<midarrow>init c\<midarrow>n\<rightarrow> s2 \<and>
                s3 = restore_lvars s1 s2)\<rbrakk>
          \<Longrightarrow>
                 G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s3"
monos
  if_bool_eq_conj

declare if_split     [split del] if_split_asm     [split del]
        option.split [split del] option.split_asm [split del]
        not_None_eq [simp del]
        split_paired_All [simp del] split_paired_Ex [simp del]
setup \<open>map_theory_simpset (fn ctxt => ctxt delloop "split_all_tac")\<close>

inductive_cases evaln_cases: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v, s')"

inductive_cases evaln_elim_cases:
        "G\<turnstile>(Some xc, s) \<midarrow>t                        \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1r Skip                      \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (Jmp j)                   \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (l\<bullet> c)                    \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In3  ([])                      \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In3  (e#es)                    \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (Lit w)                   \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (UnOp unop e)             \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (BinOp binop e1 e2)       \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In2  (LVar vn)                 \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (Cast T e)                \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (e InstOf T)              \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (Super)                   \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (Acc va)                  \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (Expr e)                  \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (c1;; c2)                 \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (Methd C sig)             \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (Body D c)                \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (e0 ? e1 : e2)            \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (If(e) c1 Else c2)        \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (l\<bullet> While(e) c)           \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (c1 Finally c2)           \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (Throw e)                 \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (NewC C)                  \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (New T[e])                \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l (Ass va e)                \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (Try c1 Catch(tn vn) c2)  \<succ>\<midarrow>n\<rightarrow> (x, s')"
        "G\<turnstile>Norm s \<midarrow>In2  ({accC,statDeclC,stat}e..fn) \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In2  (e1.[e2])                 \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1l ({accC,statT,mode}e\<cdot>mn({pT}p)) \<succ>\<midarrow>n\<rightarrow> (v, s')"
        "G\<turnstile>Norm s \<midarrow>In1r (Init C)                  \<succ>\<midarrow>n\<rightarrow> (x, s')"

declare if_split     [split] if_split_asm     [split]
        option.split [split] option.split_asm [split]
        not_None_eq [simp]
        split_paired_All [simp] split_paired_Ex [simp]
declaration \<open>K (Simplifier.map_ss (fn ss => ss addloop ("split_all_tac", split_all_tac)))\<close>

lemma evaln_Inj_elim: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (w,s') \<Longrightarrow> case t of In1 ec \<Rightarrow>
  (case ec of Inl e \<Rightarrow> (\<exists>v. w = In1 v) | Inr c \<Rightarrow> w = \<diamondsuit>)
  | In2 e \<Rightarrow> (\<exists>v. w = In2 v) | In3 e \<Rightarrow> (\<exists>v. w = In3 v)"
apply (erule evaln_cases , auto)
apply (induct_tac "t")
apply   (rename_tac a, induct_tac "a")
apply auto
done

text \<open>The following simplification procedures set up the proper injections of
 terms and their corresponding values in the evaluation relation:
 E.g. an expression
 (injection @{term In1l} into terms) always evaluates to ordinary values
 (injection @{term In1} into generalised values @{term vals}).
\<close>

lemma evaln_expr_eq: "G\<turnstile>s \<midarrow>In1l t\<succ>\<midarrow>n\<rightarrow> (w, s') = (\<exists>v. w=In1 v \<and> G\<turnstile>s \<midarrow>t-\<succ>v \<midarrow>n\<rightarrow> s')"
  by (auto, frule evaln_Inj_elim, auto)

lemma evaln_var_eq: "G\<turnstile>s \<midarrow>In2 t\<succ>\<midarrow>n\<rightarrow> (w, s') = (\<exists>vf. w=In2 vf \<and> G\<turnstile>s \<midarrow>t=\<succ>vf\<midarrow>n\<rightarrow> s')"
  by (auto, frule evaln_Inj_elim, auto)

lemma evaln_exprs_eq: "G\<turnstile>s \<midarrow>In3 t\<succ>\<midarrow>n\<rightarrow> (w, s') = (\<exists>vs. w=In3 vs \<and> G\<turnstile>s \<midarrow>t\<doteq>\<succ>vs\<midarrow>n\<rightarrow> s')"
  by (auto, frule evaln_Inj_elim, auto)

lemma evaln_stmt_eq: "G\<turnstile>s \<midarrow>In1r t\<succ>\<midarrow>n\<rightarrow> (w, s') = (w=\<diamondsuit> \<and> G\<turnstile>s \<midarrow>t \<midarrow>n\<rightarrow> s')"
  by (auto, frule evaln_Inj_elim, auto, frule evaln_Inj_elim, auto)

simproc_setup evaln_expr ("G\<turnstile>s \<midarrow>In1l t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
  fn _ => fn _ => fn ct =>
    (case Thm.term_of ct of
      (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
    | _ => SOME (mk_meta_eq @{thm evaln_expr_eq}))\<close>

simproc_setup evaln_var ("G\<turnstile>s \<midarrow>In2 t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
  fn _ => fn _ => fn ct =>
    (case Thm.term_of ct of
      (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
    | _ => SOME (mk_meta_eq @{thm evaln_var_eq}))\<close>

simproc_setup evaln_exprs ("G\<turnstile>s \<midarrow>In3 t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
  fn _ => fn _ => fn ct =>
    (case Thm.term_of ct of
      (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
    | _ => SOME (mk_meta_eq @{thm evaln_exprs_eq}))\<close>

simproc_setup evaln_stmt ("G\<turnstile>s \<midarrow>In1r t\<succ>\<midarrow>n\<rightarrow> (w, s')") = \<open>
  fn _ => fn _ => fn ct =>
    (case Thm.term_of ct of
      (_ $ _ $ _ $ _ $ _ $ (Const _ $ _) $ _) => NONE
    | _ => SOME (mk_meta_eq @{thm evaln_stmt_eq}))\<close>

ML \<open>ML_Thms.bind_thms ("evaln_AbruptIs", sum3_instantiate @{context} @{thm evaln.Abrupt})\<close>
declare evaln_AbruptIs [intro!]

lemma evaln_Callee: "G\<turnstile>Norm s\<midarrow>In1l (Callee l e)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
proof -
  { fix s t v s'
    assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
         normal: "normal s" and
         callee: "t=In1l (Callee l e)"
    then have "False" by induct auto
  }
  then show ?thesis
    by (cases s') fastforce
qed

lemma evaln_InsInitE: "G\<turnstile>Norm s\<midarrow>In1l (InsInitE c e)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
proof -
  { fix s t v s'
    assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
         normal: "normal s" and
         callee: "t=In1l (InsInitE c e)"
    then have "False" by induct auto
  }
  then show ?thesis
    by (cases s') fastforce
qed

lemma evaln_InsInitV: "G\<turnstile>Norm s\<midarrow>In2 (InsInitV c w)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
proof -
  { fix s t v s'
    assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
         normal: "normal s" and
         callee: "t=In2 (InsInitV c w)"
    then have "False" by induct auto
  }
  then show ?thesis
    by (cases s') fastforce
qed

lemma evaln_FinA: "G\<turnstile>Norm s\<midarrow>In1r (FinA a c)\<succ>\<midarrow>n\<rightarrow> (v,s') = False"
proof -
  { fix s t v s'
    assume eval: "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s')" and
         normal: "normal s" and
         callee: "t=In1r (FinA a c)"
    then have "False" by induct auto
  }
  then show ?thesis
    by (cases s') fastforce
qed

lemma evaln_abrupt_lemma: "G\<turnstile>s \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (v,s') \<Longrightarrow>
 fst s = Some xc \<longrightarrow> s' = s \<and> v = undefined3 e"
apply (erule evaln_cases , auto)
done

lemma evaln_abrupt:
 "\<And>s'. G\<turnstile>(Some xc,s) \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (w,s') = (s' = (Some xc,s) \<and>
  w=undefined3 e \<and> G\<turnstile>(Some xc,s) \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (undefined3 e,(Some xc,s)))"
apply auto
apply (frule evaln_abrupt_lemma, auto)+
done

simproc_setup evaln_abrupt ("G\<turnstile>(Some xc,s) \<midarrow>e\<succ>\<midarrow>n\<rightarrow> (w,s')") = \<open>
  fn _ => fn _ => fn ct =>
    (case Thm.term_of ct of
      (_ $ _ $ _ $ _ $ _ $ _ $ (Const (@{const_name Pair}, _) $ (Const (@{const_name Some},_) $ _)$ _))
        => NONE
    | _ => SOME (mk_meta_eq @{thm evaln_abrupt}))
\<close>

lemma evaln_LitI: "G\<turnstile>s \<midarrow>Lit v-\<succ>(if normal s then v else undefined)\<midarrow>n\<rightarrow> s"
apply (case_tac "s", case_tac "a = None")
by (auto intro!: evaln.Lit)

lemma CondI:
 "\<And>s1. \<lbrakk>G\<turnstile>s \<midarrow>e-\<succ>b\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
  G\<turnstile>s \<midarrow>e ? e1 : e2-\<succ>(if normal s1 then v else undefined)\<midarrow>n\<rightarrow> s2"
apply (case_tac "s", case_tac "a = None")
by (auto intro!: evaln.Cond)

lemma evaln_SkipI [intro!]: "G\<turnstile>s \<midarrow>Skip\<midarrow>n\<rightarrow> s"
apply (case_tac "s", case_tac "a = None")
by (auto intro!: evaln.Skip)

lemma evaln_ExprI: "G\<turnstile>s \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s' \<Longrightarrow> G\<turnstile>s \<midarrow>Expr e\<midarrow>n\<rightarrow> s'"
apply (case_tac "s", case_tac "a = None")
by (auto intro!: evaln.Expr)

lemma evaln_CompI: "\<lbrakk>G\<turnstile>s \<midarrow>c1\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>c2\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow> G\<turnstile>s \<midarrow>c1;; c2\<midarrow>n\<rightarrow> s2"
apply (case_tac "s", case_tac "a = None")
by (auto intro!: evaln.Comp)

lemma evaln_IfI:
 "\<lbrakk>G\<turnstile>s \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1; G\<turnstile>s1 \<midarrow>(if the_Bool v then c1 else c2)\<midarrow>n\<rightarrow> s2\<rbrakk> \<Longrightarrow>
  G\<turnstile>s \<midarrow>If(e) c1 Else c2\<midarrow>n\<rightarrow> s2"
apply (case_tac "s", case_tac "a = None")
by (auto intro!: evaln.If)

lemma evaln_SkipD [dest!]: "G\<turnstile>s \<midarrow>Skip\<midarrow>n\<rightarrow> s' \<Longrightarrow> s' = s"
by (erule evaln_cases, auto)

lemma evaln_Skip_eq [simp]: "G\<turnstile>s \<midarrow>Skip\<midarrow>n\<rightarrow> s' = (s = s')"
apply auto
done

subsubsection \<open>evaln implies eval\<close>

lemma evaln_eval:
  assumes evaln: "G\<turnstile>s0 \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s1)"
  shows "G\<turnstile>s0 \<midarrow>t\<succ>\<rightarrow> (v,s1)"
using evaln
proof (induct)
  case (Loop s0 e b n s1 c s2 l s3)
  note \<open>G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<rightarrow> s1\<close>
  moreover
  have "if the_Bool b
        then (G\<turnstile>s1 \<midarrow>c\<rightarrow> s2) \<and>
             G\<turnstile>abupd (absorb (Cont l)) s2 \<midarrow>l\<bullet> While(e) c\<rightarrow> s3
        else s3 = s1"
    using Loop.hyps by simp
  ultimately show ?case by (rule eval.Loop)
next
  case (Try s0 c1 n s1 s2 C vn c2 s3)
  note \<open>G\<turnstile>Norm s0 \<midarrow>c1\<rightarrow> s1\<close>
  moreover
  note \<open>G\<turnstile>s1 \<midarrow>sxalloc\<rightarrow> s2\<close>
  moreover
  have "if G,s2\<turnstile>catch C then G\<turnstile>new_xcpt_var vn s2 \<midarrow>c2\<rightarrow> s3 else s3 = s2"
    using Try.hyps by simp
  ultimately show ?case by (rule eval.Try)
next
  case (Init C c s0 s3 n s1 s2)
  note \<open>the (class G C) = c\<close>
  moreover
  have "if inited C (globs s0)
           then s3 = Norm s0
           else G\<turnstile>Norm ((init_class_obj G C) s0)
                  \<midarrow>(if C = Object then Skip else Init (super c))\<rightarrow> s1 \<and>
                G\<turnstile>(set_lvars empty) s1 \<midarrow>init c\<rightarrow> s2 \<and>
                s3 = (set_lvars (locals (store s1))) s2"
    using Init.hyps by simp
  ultimately show ?case by (rule eval.Init)
qed (rule eval.intros,(assumption+ | assumption?))+

lemma Suc_le_D_lemma: "\<lbrakk>Suc n <= m'; (\<And>m. n <= m \<Longrightarrow> P (Suc m)) \<rbrakk> \<Longrightarrow> P m'"
apply (frule Suc_le_D)
apply fast
done

lemma evaln_nonstrict [rule_format (no_asm), elim]:
  "G\<turnstile>s \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (w, s') \<Longrightarrow> \<forall>m. n\<le>m \<longrightarrow> G\<turnstile>s \<midarrow>t\<succ>\<midarrow>m\<rightarrow> (w, s')"
apply (erule evaln.induct)
apply (tactic \<open>ALLGOALS (EVERY' [strip_tac @{context},
  TRY o eresolve_tac @{context} @{thms Suc_le_D_lemma},
  REPEAT o smp_tac @{context} 1,
  resolve_tac @{context} @{thms evaln.intros} THEN_ALL_NEW TRY o assume_tac @{context}])\<close>)
(* 3 subgoals *)
apply (auto split del: if_split)
done

lemmas evaln_nonstrict_Suc = evaln_nonstrict [OF _ le_refl [THEN le_SucI]]

lemma evaln_max2: "\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2')\<rbrakk> \<Longrightarrow>
             G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max n1 n2\<rightarrow> (w1, s1') \<and> G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max n1 n2\<rightarrow> (w2, s2')"
by (fast intro: max.cobounded1 max.cobounded2)

corollary evaln_max2E [consumes 2]:
  "\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2');
    \<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max n1 n2\<rightarrow> (w1, s1');G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max n1 n2\<rightarrow> (w2, s2') \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (drule (1) evaln_max2) simp

lemma evaln_max3:
"\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2'); G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>n3\<rightarrow> (w3, s3')\<rbrakk> \<Longrightarrow>
 G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w1, s1') \<and>
 G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w2, s2') \<and>
 G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w3, s3')"
apply (drule (1) evaln_max2, erule thin_rl)
apply (fast intro!: max.cobounded1 max.cobounded2)
done

corollary evaln_max3E:
"\<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>n1\<rightarrow> (w1, s1'); G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>n2\<rightarrow> (w2, s2'); G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>n3\<rightarrow> (w3, s3');
   \<lbrakk>G\<turnstile>s1 \<midarrow>t1\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w1, s1');
    G\<turnstile>s2 \<midarrow>t2\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w2, s2');
    G\<turnstile>s3 \<midarrow>t3\<succ>\<midarrow>max (max n1 n2) n3\<rightarrow> (w3, s3')
   \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
by (drule (2) evaln_max3) simp

lemma le_max3I1: "(n2::nat) \<le> max n1 (max n2 n3)"
proof -
  have "n2 \<le> max n2 n3"
    by (rule max.cobounded1)
  also
  have "max n2 n3 \<le> max n1 (max n2 n3)"
    by (rule max.cobounded2)
  finally
  show ?thesis .
qed

lemma le_max3I2: "(n3::nat) \<le> max n1 (max n2 n3)"
proof -
  have "n3 \<le> max n2 n3"
    by (rule max.cobounded2)
  also
  have "max n2 n3 \<le> max n1 (max n2 n3)"
    by (rule max.cobounded2)
  finally
  show ?thesis .
qed

declare [[simproc del: wt_expr wt_var wt_exprs wt_stmt]]

subsubsection \<open>eval implies evaln\<close>
lemma eval_evaln:
  assumes eval: "G\<turnstile>s0 \<midarrow>t\<succ>\<rightarrow> (v,s1)"
  shows  "\<exists>n. G\<turnstile>s0 \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (v,s1)"
using eval
proof (induct)
  case (Abrupt xc s t)
  obtain n where
    "G\<turnstile>(Some xc, s) \<midarrow>t\<succ>\<midarrow>n\<rightarrow> (undefined3 t, (Some xc, s))"
    by (iprover intro: evaln.Abrupt)
  then show ?case ..
next
  case Skip
  show ?case by (blast intro: evaln.Skip)
next
  case (Expr s0 e v s1)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
    by (iprover)
  then have "G\<turnstile>Norm s0 \<midarrow>Expr e\<midarrow>n\<rightarrow> s1"
    by (rule evaln.Expr)
  then show ?case ..
next
  case (Lab s0 c s1 l)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>c\<midarrow>n\<rightarrow> s1"
    by (iprover)
  then have "G\<turnstile>Norm s0 \<midarrow>l\<bullet> c\<midarrow>n\<rightarrow> abupd (absorb l) s1"
    by (rule evaln.Lab)
  then show ?case ..
next
  case (Comp s0 c1 s1 c2 s2)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>c2\<midarrow>n2\<rightarrow> s2"
    by (iprover)
  then have "G\<turnstile>Norm s0 \<midarrow>c1;; c2\<midarrow>max n1 n2\<rightarrow> s2"
    by (blast intro: evaln.Comp dest: evaln_max2 )
  then show ?case ..
next
  case (If s0 e b s1 c1 c2 s2)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>(if the_Bool b then c1 else c2)\<midarrow>n2\<rightarrow> s2"
    by (iprover)
  then have "G\<turnstile>Norm s0 \<midarrow>If(e) c1 Else c2\<midarrow>max n1 n2\<rightarrow> s2"
    by (blast intro: evaln.If dest: evaln_max2)
  then show ?case ..
next
  case (Loop s0 e b s1 c s2 l s3)
  from Loop.hyps obtain n1 where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>b\<midarrow>n1\<rightarrow> s1"
    by (iprover)
  moreover from Loop.hyps obtain n2 where
    "if the_Bool b
        then (G\<turnstile>s1 \<midarrow>c\<midarrow>n2\<rightarrow> s2 \<and>
              G\<turnstile>(abupd (absorb (Cont l)) s2)\<midarrow>l\<bullet> While(e) c\<midarrow>n2\<rightarrow> s3)
        else s3 = s1"
    by simp (iprover intro: evaln_nonstrict max.cobounded1 max.cobounded2)
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>l\<bullet> While(e) c\<midarrow>max n1 n2\<rightarrow> s3"
    apply -
    apply (rule evaln.Loop)
    apply   (iprover intro: evaln_nonstrict intro: max.cobounded1)
    apply   (auto intro: evaln_nonstrict intro: max.cobounded2)
    done
  then show ?case ..
next
  case (Jmp s j)
  fix n have "G\<turnstile>Norm s \<midarrow>Jmp j\<midarrow>n\<rightarrow> (Some (Jump j), s)"
    by (rule evaln.Jmp)
  then show ?case ..
next
  case (Throw s0 e a s1)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>a\<midarrow>n\<rightarrow> s1"
    by (iprover)
  then have "G\<turnstile>Norm s0 \<midarrow>Throw e\<midarrow>n\<rightarrow> abupd (throw a) s1"
    by (rule evaln.Throw)
  then show ?case ..
next
  case (Try s0 c1 s1 s2 catchC vn c2 s3)
  from Try.hyps obtain n1 where
    "G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n1\<rightarrow> s1"
    by (iprover)
  moreover
  note sxalloc = \<open>G\<turnstile>s1 \<midarrow>sxalloc\<rightarrow> s2\<close>
  moreover
  from Try.hyps obtain n2 where
    "if G,s2\<turnstile>catch catchC then G\<turnstile>new_xcpt_var vn s2 \<midarrow>c2\<midarrow>n2\<rightarrow> s3 else s3 = s2"
    by fastforce
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>Try c1 Catch(catchC vn) c2\<midarrow>max n1 n2\<rightarrow> s3"
    by (auto intro!: evaln.Try max.cobounded1 max.cobounded2)
  then show ?case ..
next
  case (Fin s0 c1 x1 s1 c2 s2 s3)
  from Fin obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>c1\<midarrow>n1\<rightarrow> (x1, s1)"
    "G\<turnstile>Norm s1 \<midarrow>c2\<midarrow>n2\<rightarrow> s2"
    by iprover
  moreover
  note s3 = \<open>s3 = (if \<exists>err. x1 = Some (Error err)
                   then (x1, s1)
                   else abupd (abrupt_if (x1 \<noteq> None) x1) s2)\<close>
  ultimately
  have
    "G\<turnstile>Norm s0 \<midarrow>c1 Finally c2\<midarrow>max n1 n2\<rightarrow> s3"
    by (blast intro: evaln.Fin dest: evaln_max2)
  then show ?case ..
next
  case (Init C c s0 s3 s1 s2)
  note cls = \<open>the (class G C) = c\<close>
  moreover from Init.hyps obtain n where
      "if inited C (globs s0) then s3 = Norm s0
       else (G\<turnstile>Norm (init_class_obj G C s0)
              \<midarrow>(if C = Object then Skip else Init (super c))\<midarrow>n\<rightarrow> s1 \<and>
                   G\<turnstile>set_lvars empty s1 \<midarrow>init c\<midarrow>n\<rightarrow> s2 \<and>
                   s3 = restore_lvars s1 s2)"
    by (auto intro: evaln_nonstrict max.cobounded1 max.cobounded2)
  ultimately have "G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s3"
    by (rule evaln.Init)
  then show ?case ..
next
  case (NewC s0 C s1 a s2)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>Init C\<midarrow>n\<rightarrow> s1"
    by (iprover)
  with NewC
  have "G\<turnstile>Norm s0 \<midarrow>NewC C-\<succ>Addr a\<midarrow>n\<rightarrow> s2"
    by (iprover intro: evaln.NewC)
  then show ?case ..
next
  case (NewA s0 T s1 e i s2 a s3)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>init_comp_ty T\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>e-\<succ>i\<midarrow>n2\<rightarrow> s2"
    by (iprover)
  moreover
  note \<open>G\<turnstile>abupd (check_neg i) s2 \<midarrow>halloc Arr T (the_Intg i)\<succ>a\<rightarrow> s3\<close>
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>New T[e]-\<succ>Addr a\<midarrow>max n1 n2\<rightarrow> s3"
    by (blast intro: evaln.NewA dest: evaln_max2)
  then show ?case ..
next
  case (Cast s0 e v s1 s2 castT)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
    by (iprover)
  moreover
  note \<open>s2 = abupd (raise_if (\<not> G,snd s1\<turnstile>v fits castT) ClassCast) s1\<close>
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>Cast castT e-\<succ>v\<midarrow>n\<rightarrow> s2"
    by (rule evaln.Cast)
  then show ?case ..
next
  case (Inst s0 e v s1 b T)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
    by (iprover)
  moreover
  note \<open>b = (v \<noteq> Null \<and> G,snd s1\<turnstile>v fits RefT T)\<close>
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>e InstOf T-\<succ>Bool b\<midarrow>n\<rightarrow> s1"
    by (rule evaln.Inst)
  then show ?case ..
next
  case (Lit s v)
  fix n have "G\<turnstile>Norm s \<midarrow>Lit v-\<succ>v\<midarrow>n\<rightarrow> Norm s"
    by (rule evaln.Lit)
  then show ?case ..
next
  case (UnOp s0 e v s1 unop)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n\<rightarrow> s1"
    by (iprover)
  hence "G\<turnstile>Norm s0 \<midarrow>UnOp unop e-\<succ>eval_unop unop v\<midarrow>n\<rightarrow> s1"
    by (rule evaln.UnOp)
  then show ?case ..
next
  case (BinOp s0 e1 v1 s1 binop e2 v2 s2)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>e1-\<succ>v1\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>(if need_second_arg binop v1 then In1l e2
               else In1r Skip)\<succ>\<midarrow>n2\<rightarrow> (In1 v2, s2)"
    by (iprover)
  hence "G\<turnstile>Norm s0 \<midarrow>BinOp binop e1 e2-\<succ>(eval_binop binop v1 v2)\<midarrow>max n1 n2
          \<rightarrow> s2"
    by (blast intro!: evaln.BinOp dest: evaln_max2)
  then show ?case ..
next
  case (Super s )
  fix n have "G\<turnstile>Norm s \<midarrow>Super-\<succ>val_this s\<midarrow>n\<rightarrow> Norm s"
    by (rule evaln.Super)
  then show ?case ..
next
  case (Acc s0 va v f s1)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>va=\<succ>(v, f)\<midarrow>n\<rightarrow> s1"
    by (iprover)
  then
  have "G\<turnstile>Norm s0 \<midarrow>Acc va-\<succ>v\<midarrow>n\<rightarrow> s1"
    by (rule evaln.Acc)
  then show ?case ..
next
  case (Ass s0 var w f s1 e v s2)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>var=\<succ>(w, f)\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>e-\<succ>v\<midarrow>n2\<rightarrow> s2"
    by (iprover)
  then
  have "G\<turnstile>Norm s0 \<midarrow>var:=e-\<succ>v\<midarrow>max n1 n2\<rightarrow> assign f v s2"
    by (blast intro: evaln.Ass dest: evaln_max2)
  then show ?case ..
next
  case (Cond s0 e0 b s1 e1 e2 v s2)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>e0-\<succ>b\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>(if the_Bool b then e1 else e2)-\<succ>v\<midarrow>n2\<rightarrow> s2"
    by (iprover)
  then
  have "G\<turnstile>Norm s0 \<midarrow>e0 ? e1 : e2-\<succ>v\<midarrow>max n1 n2\<rightarrow> s2"
    by (blast intro: evaln.Cond dest: evaln_max2)
  then show ?case ..
next
  case (Call s0 e a' s1 args vs s2 invDeclC mode statT mn pTs' s3 s3' accC' v s4)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>a'\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>args\<doteq>\<succ>vs\<midarrow>n2\<rightarrow> s2"
    by iprover
  moreover
  note \<open>invDeclC = invocation_declclass G mode (store s2) a' statT
                       \<lparr>name=mn,parTs=pTs'\<rparr>\<close>
  moreover
  note \<open>s3 = init_lvars G invDeclC \<lparr>name=mn,parTs=pTs'\<rparr> mode a' vs s2\<close>
  moreover
  note \<open>s3'=check_method_access G accC' statT mode \<lparr>name=mn,parTs=pTs'\<rparr> a' s3\<close>
  moreover
  from Call.hyps
  obtain m where
    "G\<turnstile>s3' \<midarrow>Methd invDeclC \<lparr>name=mn, parTs=pTs'\<rparr>-\<succ>v\<midarrow>m\<rightarrow> s4"
    by iprover
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>{accC',statT,mode}e\<cdot>mn( {pTs'}args)-\<succ>v\<midarrow>max n1 (max n2 m)\<rightarrow>
            (set_lvars (locals (store s2))) s4"
    by (auto intro!: evaln.Call max.cobounded1 le_max3I1 le_max3I2)
  thus ?case ..
next
  case (Methd s0 D sig v s1)
  then obtain n where
    "G\<turnstile>Norm s0 \<midarrow>body G D sig-\<succ>v\<midarrow>n\<rightarrow> s1"
    by iprover
  then have "G\<turnstile>Norm s0 \<midarrow>Methd D sig-\<succ>v\<midarrow>Suc n\<rightarrow> s1"
    by (rule evaln.Methd)
  then show ?case ..
next
  case (Body s0 D s1 c s2 s3)
  from Body.hyps obtain n1 n2 where
    evaln_init: "G\<turnstile>Norm s0 \<midarrow>Init D\<midarrow>n1\<rightarrow> s1" and
    evaln_c: "G\<turnstile>s1 \<midarrow>c\<midarrow>n2\<rightarrow> s2"
    by (iprover)
  moreover
  note \<open>s3 = (if \<exists>l. fst s2 = Some (Jump (Break l)) \<or>
                     fst s2 = Some (Jump (Cont l))
              then abupd (\<lambda>x. Some (Error CrossMethodJump)) s2
              else s2)\<close>
  ultimately
  have
     "G\<turnstile>Norm s0 \<midarrow>Body D c-\<succ>the (locals (store s2) Result)\<midarrow>max n1 n2
       \<rightarrow> abupd (absorb Ret) s3"
    by (iprover intro: evaln.Body dest: evaln_max2)
  then show ?case ..
next
  case (LVar s vn )
  obtain n where
    "G\<turnstile>Norm s \<midarrow>LVar vn=\<succ>lvar vn s\<midarrow>n\<rightarrow> Norm s"
    by (iprover intro: evaln.LVar)
  then show ?case ..
next
  case (FVar s0 statDeclC s1 e a s2 v s2' stat fn s3 accC)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>Init statDeclC\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>e-\<succ>a\<midarrow>n2\<rightarrow> s2"
    by iprover
  moreover
  note \<open>s3 = check_field_access G accC statDeclC fn stat a s2'\<close>
    and \<open>(v, s2') = fvar statDeclC stat fn a s2\<close>
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>{accC,statDeclC,stat}e..fn=\<succ>v\<midarrow>max n1 n2\<rightarrow> s3"
    by (iprover intro: evaln.FVar dest: evaln_max2)
  then show ?case ..
next
  case (AVar s0 e1 a s1 e2 i s2 v s2')
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>e1-\<succ>a\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>e2-\<succ>i\<midarrow>n2\<rightarrow> s2"
    by iprover
  moreover
  note \<open>(v, s2') = avar G i a s2\<close>
  ultimately
  have "G\<turnstile>Norm s0 \<midarrow>e1.[e2]=\<succ>v\<midarrow>max n1 n2\<rightarrow> s2'"
    by (blast intro!: evaln.AVar dest: evaln_max2)
  then show ?case ..
next
  case (Nil s0)
  show ?case by (iprover intro: evaln.Nil)
next
  case (Cons s0 e v s1 es vs s2)
  then obtain n1 n2 where
    "G\<turnstile>Norm s0 \<midarrow>e-\<succ>v\<midarrow>n1\<rightarrow> s1"
    "G\<turnstile>s1 \<midarrow>es\<doteq>\<succ>vs\<midarrow>n2\<rightarrow> s2"
    by iprover
  then
  have "G\<turnstile>Norm s0 \<midarrow>e # es\<doteq>\<succ>v # vs\<midarrow>max n1 n2\<rightarrow> s2"
    by (blast intro!: evaln.Cons dest: evaln_max2)
  then show ?case ..
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

(*
    Properties of machine operations.
*)

theory Machine_R
imports Bits_R
begin

definition "irq_state_independent_H (P :: kernel_state \<Rightarrow> bool)\<equiv>
              \<forall>(f :: nat \<Rightarrow> nat) (s :: kernel_state). P s \<longrightarrow> P (s\<lparr>ksMachineState := ksMachineState s
                                \<lparr>irq_state := f (irq_state (ksMachineState s))\<rparr>\<rparr>)"

lemma irq_state_independent_HI[intro!, simp]:
  "\<lbrakk>\<And>s f. P (s\<lparr>ksMachineState := ksMachineState s
              \<lparr>irq_state := f (irq_state (ksMachineState s))\<rparr>\<rparr>) = P s\<rbrakk>
   \<Longrightarrow> irq_state_independent_H P"
  by (simp add: irq_state_independent_H_def)

context begin interpretation Arch . (*FIXME: arch_split*)

lemma dmo_getirq_inv[wp]:
  "irq_state_independent_H P \<Longrightarrow> \<lbrace>P\<rbrace> doMachineOp (getActiveIRQ in_kernel) \<lbrace>\<lambda>rv. P\<rbrace>"
  apply (simp add: getActiveIRQ_def doMachineOp_def split_def exec_gets
                   select_f_select[simplified liftM_def]
                   select_modify_comm gets_machine_state_modify)
  apply wp
  apply (clarsimp simp: irq_state_independent_H_def in_monad return_def split: if_splits)
  done

lemma getActiveIRQ_masked:
  "\<lbrace>\<lambda>s. valid_irq_masks' table (irq_masks s)\<rbrace> getActiveIRQ in_kernel
  \<lbrace>\<lambda>rv s. \<forall>irq. rv = Some irq \<longrightarrow> table irq \<noteq> IRQInactive\<rbrace>"
  apply (simp add: getActiveIRQ_def)
  apply wp
  apply (clarsimp simp: valid_irq_masks'_def)
  done

lemma dmo_maskInterrupt:
  "\<lbrace>\<lambda>s. P (ksMachineState_update (irq_masks_update (\<lambda>t. t (irq := m))) s)\<rbrace>
  doMachineOp (maskInterrupt m irq) \<lbrace>\<lambda>_. P\<rbrace>"
  apply (simp add: doMachineOp_def split_def)
  apply wp
  apply (clarsimp simp: maskInterrupt_def in_monad)
  apply (erule rsubst [where P=P])
  apply simp
  done

lemma dmo_maskInterrupt_True:
  "\<lbrace>invs'\<rbrace> doMachineOp (maskInterrupt True irq) \<lbrace>\<lambda>_. invs'\<rbrace>"
  apply (wp dmo_maskInterrupt)
  apply (clarsimp simp: invs'_def valid_state'_def)
  apply (simp add: valid_irq_masks'_def valid_machine_state'_def
                   ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def)
  done

lemma setIRQState_irq_states':
  "\<lbrace>valid_irq_states'\<rbrace>
      setIRQState state irq
   \<lbrace>\<lambda>rv. valid_irq_states'\<rbrace>"
  apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def)
  apply (wp dmo_maskInterrupt)
  apply (simp add: valid_irq_masks'_def)
  done

lemma getActiveIRQ_le_maxIRQ:
  "\<lbrace>irqs_masked' and valid_irq_states'\<rbrace> doMachineOp (getActiveIRQ in_kernel) \<lbrace>\<lambda>rv s. \<forall>x. rv = Some x \<longrightarrow> x \<le> maxIRQ\<rbrace>"
  apply (simp add: doMachineOp_def split_def)
  apply wp
  apply clarsimp
  apply (drule use_valid, rule getActiveIRQ_le_maxIRQ')
   prefer 2
   apply simp
  apply (simp add: irqs_masked'_def valid_irq_states'_def)
  done

end
end


(*  Title:      HOL/Auth/n_german_lemma_inv__13_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_german Protocol Case Study*}

theory n_german_lemma_inv__13_on_rules imports n_german_lemma_on_inv__13
begin
section{*All lemmas on causal relation between inv__13*}
lemma lemma_inv__13_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__13  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqEI  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqES  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReq N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvE  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)\<or>
    (\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> j. j\<le>N\<and>r=n_SendReqS  j)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__13) done
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

end


theory RCU_S_steps
  imports RCU_model
begin

(*datatype PC = I1 | I2 | I3 | I4 | I5 | I6 | I7 | I8 | I9 | I10 | I11 | I12 | I13 | I14 |  cas_res | finished
            | R1 | R2 | R3 | R4 | R5
            | S1 | S2 | S3 | S4 | S5 | S6 | S7 *)

(*
(\<forall> x. lastWr \<sigma> x \<notin> covered \<sigma>)"
*)

(*the following must be included in the proof:

con_assms ps                            assumed         --- concerns allocation/bounds of C and rcu_0+i for all i

main_inv ms                             *done*          --- main invariant has 3 parts
psem_rules ps                           *done*          --- how allocation works on the inside
allocated_addresses ms ps               *done*          --- allocation for above are defined here
simple - observation_inv_ms ms          *done*          --- how own\<^sub>W affects loc status (own\<^sub>W loc = t \<longrightarrow> loc\<in>{s,n,det} t)
hard   - observation_inv_sig ms ps \<sigma>    **          --- limits which values can be WM_read from C
simple - own\<^sub>W_n_by_t_imp ms             **          --- related own\<^sub>W of n to n_dec and n (value)
tedious - general_structure ms          **          --- says how n \<noteq> s \<noteq> detaddrs
local - preCond ms ps \<sigma> (pc ms t) t     **          --- defines preconditions for t to proceed with stepping
global - preCond ms ps \<sigma> (pc ms ta) ta  **          --- defines preconditions for t to proceed with stepping

local  - weak_mem (pre/in/post block) (t ta)
global - weak_mem (pre/in/post block) (ta t)

*)
definition  "S_steps \<equiv> {i. i=S1 \<or> i=S2 \<or> i=S3 \<or> i=S4 \<or> i=S5 \<or> i=S6 \<or> i=S7}"
lemmas step_breakdown [simp] = S_steps_def

definition "default_locs \<equiv> {i | i a. i=C \<or> i = rcu_0+a \<and> a<T_max }"
definition "reserved_bydef ps \<equiv> \<forall>i. i\<in>default_locs \<longrightarrow> \<not>isfree_addr i ps"
definition "reservations_differ \<equiv> \<forall>i. i<T_max \<longrightarrow> C\<noteq>rcu_0+i"
definition "counters_limit ms \<equiv> \<forall>t. t<T_max \<longrightarrow> CTRsync\<^sub>1 ms t \<le>T_max \<and> CTRsync\<^sub>2 ms t \<le>T_max"
definition "con_assms ms ps \<equiv> reserved_bydef ps \<and> reservations_differ \<and> counters_limit ms "

lemmas con_assms_lemmas [simp] = reserved_bydef_def reservations_differ_def
                                 default_locs_def counters_limit_def

lemma showing_observation_inv_sig_for_S:
 "main_inv ms ps \<Longrightarrow>
  con_assms ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  allocated_addresses ms ps \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_ms ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  observation_inv_sig ms' ps' \<sigma>'"
  apply (simp, safe; clarsimp)
  apply(simp add:observation_inv_sig_def step_def abbr)
  apply(simp add:observation_inv_sig_def step_def abbr)
  apply clarify
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max") prefer 2 apply simp
  apply(simp add:observation_inv_sig_def step_def abbr)
  apply blast
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr)
  apply blast
  apply blast
  apply(simp add:observation_inv_sig_def step_def abbr)
  apply auto[1]
  apply(subgoal_tac "loc \<noteq> l") prefer 2
  apply blast
  apply(simp add:OpSem.step_def wfs_2_def) apply auto[1]
  using OpSem.step_def not_cvd_RdX_pres apply blast
  apply(simp add:OpSem.step_def wfs_2_def) apply auto[1]
  using OpSem.step_def not_cvd_RdX_pres apply blast
  apply(simp add:observation_inv_sig_def step_def abbr)
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply(simp add:step_def)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0") prefer 2 apply simp
  apply(simp add:observation_inv_sig_def step_def abbr)
  apply(simp add:abbr)
  unfolding observation_inv_sig_def apply simp
  prefer 2
  unfolding step_def
  apply(case_tac "reg ms t = 1", simp_all add:abbr) (*last 1, S6, load(rcu)*)
  apply(simp add:step_def abbr OpSem.step_def wfs_2_def)
  apply auto[1]
  using OpSem.step_def not_cvd_RdX_pres apply blast
  apply(simp add:RdX_def) apply(simp add:con_assms_def)
  apply(subgoal_tac "loc \<noteq> l") prefer 2
  apply blast
  apply(subgoal_tac "isfree_addr loc ps") prefer 2
  apply (meson isfree_addr_def)
  apply(subgoal_tac "isfree_addr loc ps'") prefer 2
  apply blast
  apply(simp add:preCond_def)
  sorry

lemma showing_main_inv_1_for_S:
 "main_inv ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  main_inv_1 ms'"
  apply (simp, safe; clarsimp)
  apply(simp_all add:main_inv_1_def step_def setup_r_def)
  apply (metis main_inv_1_def main_inv_def option.distinct(1))
  apply(simp add:preCond_def)
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr)
  apply (simp add: main_inv_1_def main_inv_def)
  apply (simp add: main_inv_1_def main_inv_def)
  apply (simp add: main_inv_1_def main_inv_def)
  apply (simp add: main_inv_1_def main_inv_def)
  apply(simp add:preCond_def OpSem.step_def general_structure_def)
  apply clarify apply auto
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply (metis main_inv_1_def main_inv_def option.discI option.sel singletonD)
  apply (metis main_inv_1_def main_inv_def option.distinct(1) option.sel singleton_iff)
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply (metis main_inv_1_def main_inv_def option.discI option.sel singletonI)
  apply (metis main_inv_1_def main_inv_def option.discI option.sel singletonI)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr)
  apply (metis main_inv_1_def main_inv_def option.distinct(1) option.sel singleton_iff)
  apply (metis empty_iff insert_iff main_inv_1_def main_inv_def option.distinct(1) option.sel)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr)
  apply (metis main_inv_1_def main_inv_def option.distinct(1) option.sel singleton_iff)
  apply (metis insert_iff main_inv_1_def main_inv_def option.distinct(1) option.sel)
  apply (metis main_inv_1_def main_inv_def option.distinct(1) option.sel singletonD)
  apply (metis main_inv_1_def main_inv_def option.discI option.sel singletonI)
  apply(case_tac "reg ms t = Suc 0", simp_all add:abbr)
  apply (metis main_inv_1_def main_inv_def option.distinct(1) option.sel singleton_iff)
  apply (smt (verit) Collect_conv_if2 main_inv_1_def main_inv_def mem_Collect_eq option.distinct(1) option.sel)
  apply(case_tac "reg ms t = Suc 0", simp_all add:abbr)
  apply (metis main_inv_1_def main_inv_def option.distinct(1) option.sel singletonI)
  by (meson main_inv_3_def main_inv_def own\<^sub>W_n_by_t_imp_def)

lemma showing_main_inv_2_for_S:
 "main_inv ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_ms ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  main_inv_2 ms' ps'"
  apply(simp, safe; simp_all)
  apply(simp_all add:step_def)
  apply(simp_all add:main_inv_2_def abbr main_inv_def)
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr) defer
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr) defer
  apply(case_tac "reg ms t = Suc 0", simp_all add:abbr)
  by auto

lemma showing_main_inv_3_for_S:
 "main_inv ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_ms ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  main_inv_3 ms' ps'"
  apply(simp, safe; simp_all)
  apply(simp_all add:step_def)
  apply(simp_all add:main_inv_3_def abbr main_inv_def)
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr) defer
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr) defer
  apply(case_tac "reg ms t = Suc 0", simp_all add:abbr)
  by auto

lemma showing_main_inv_for_S:
 "main_inv ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_ms ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  main_inv ms' ps'"
  apply(subgoal_tac "main_inv_1 ms' \<and> main_inv_2 ms' ps' \<and> main_inv_3 ms' ps'")
  apply(simp add:main_inv_def)
  apply(intro conjI impI)
  using showing_main_inv_1_for_S apply blast
  using showing_main_inv_2_for_S apply blast
  using showing_main_inv_3_for_S by blast

lemma showing_psem_rules_for_S:
 "main_inv ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  allocated_addresses ms ps \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_ms ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  psem_rules ps'"
  apply(simp, safe; simp_all)
  apply(simp_all add: step_def abbr)
  apply (metis domI fst_conv option.sel)
  apply blast+
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all add:abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr)
  apply (metis domI fst_eqD option.sel)
  apply (metis domI fst_conv option.sel)
  apply (metis domI fst_conv option.sel)
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all add:abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all add:abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr)
  apply blast
  apply blast
  apply blast apply auto[1]
  apply (metis domI fst_conv option.sel)
  apply blast
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr) apply auto[1]
  apply (metis domI fst_conv option.sel)
  apply (metis domI fst_conv option.sel)
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply blast
  apply blast
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr)
  apply (metis domI fst_eqD option.sel)
  apply (metis domI fst_eqD option.sel)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr)
  apply blast
  apply blast
  apply auto[1]
  apply (metis domI eq_fst_iff option.sel)
  apply blast
  apply(case_tac "reg ms t = Suc 0", simp_all add:abbr)
  apply (metis domI fst_eqD option.sel)
  apply (metis domI fst_eqD option.sel)
  apply(case_tac "reg ms t = Suc 0", simp_all add:abbr)
  apply(case_tac "reg ms t = Suc 0", simp_all add:abbr)
  apply blast
  by blast

lemma showing_allocated_addresses_for_S:
 "main_inv ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  allocated_addresses ms ps \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_ms ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  allocated_addresses ms' ps'"
  apply(simp, safe; simp_all)
  apply(simp add:allocated_addresses_lemmas step_def abbr)
  apply(simp add:allocated_addresses_lemmas step_def abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all add:abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr)
  apply(simp add:allocated_addresses_lemmas step_def abbr)
  apply auto[1] apply blast
  apply(simp add:allocated_addresses_lemmas step_def abbr)
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply(simp add:allocated_addresses_lemmas step_def abbr)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr)
  apply(simp add:allocated_addresses_lemmas step_def abbr)
  apply auto[1] apply blast
  apply(simp add:allocated_addresses_lemmas step_def abbr)
  by(case_tac "reg ms t = Suc 0", simp_all add:abbr)

lemma showing_observation_inv_ms_for_S:
 "main_inv ms ps \<Longrightarrow>
  wfs_2 \<sigma> \<Longrightarrow>
  cvd[C,l] \<sigma> \<Longrightarrow>
  t<T_max \<Longrightarrow>
  pc ms t \<in> S_steps \<Longrightarrow>
  step ms ps \<sigma> (pc ms t) t ms' ps' \<sigma>' \<Longrightarrow>
  preCond ms ps \<sigma> (pc ms t) t \<Longrightarrow>
  general_structure ms \<Longrightarrow>
  allocated_addresses ms ps \<Longrightarrow>
  psem_rules ps \<Longrightarrow>
  own\<^sub>W_n_by_t_imp ms \<Longrightarrow>
  observation_inv_ms ms \<Longrightarrow>
  observation_inv_sig ms ps \<sigma> \<Longrightarrow>
  observation_inv_ms ms'"
  apply(simp, safe; simp_all)
  apply(simp add:observation_inv_ms_def step_def abbr)
  apply(simp add:observation_inv_ms_def step_def abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t < T_max", simp_all add:abbr)
  apply(case_tac "CTRsync\<^sub>1 ms t = t", simp_all add:abbr)
  apply(simp add:observation_inv_ms_def step_def abbr)
  apply auto[1]
  apply blast
  apply blast
  apply(simp add:observation_inv_ms_def step_def abbr)
  apply(case_tac "CTRsync\<^sub>2 ms t < T_max", simp_all add:abbr)
  apply(simp add:observation_inv_ms_def step_def abbr)
  apply(case_tac "r ms t (CTRsync\<^sub>2 ms t) = 0", simp_all add:abbr)
  apply(simp add:observation_inv_ms_def step_def abbr)
  apply auto[1]
  apply blast
  apply blast
  apply(simp add:observation_inv_ms_def step_def abbr)
  by(case_tac "reg ms t = Suc 0", simp_all add:abbr)


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory Eval_CAMKES_CDL
imports
  "Policy_CAMKES_CDL"
  "DPolicy.Dpolicy"
  "Lib.FastMap"
  "Lib.RangeMap"
  "Lib.FP_Eval"
  "Lib.GenericTag"
begin

text \<open>
  Various helpers for the generated CAmkES-capDL integrity proofs that are
  produced from camkes-tool.

  The main integrity proofs proceed by more-or-less direct evaluation
  of the proof obligations in cdl_state_asids_to_policy__eval, etc.

  These proof obligations are nested @{const Ball} predicates that iterate
  over each object, cap, etc. in the generated capDL state.
\<close>

context begin interpretation Arch . (* FIXME: need this only to talk about ARM ASIDs *)

type_synonym asid_high = "7 word" (* FIXME: MOVE *)

section \<open>Generic policy labelling helpers\<close>

text \<open>Retrieve page tables mapped into a page directory. (AARCH32 only)\<close>
definition mapped_pts_of :: "cdl_heap \<Rightarrow> cdl_cap_map \<Rightarrow> cdl_object_id set"
  where
  "mapped_pts_of object_map pd_caps \<equiv>
      {pt_id. \<exists>pt \<in> ran pd_caps.
        case pt of FrameCap _ _ _ _ _ _ \<Rightarrow> False \<comment> \<open>ignore ARM section pages\<close>
                 | _ \<Rightarrow> pt_id \<in> cap_objects pt}"

text \<open>Retrieve frames mapped into a page directory. (AARCH32 only)\<close>
definition mapped_frames_of :: "cdl_heap \<Rightarrow> cdl_cap_map \<Rightarrow> cdl_object_id set"
  where
  "mapped_frames_of object_map pd_caps \<equiv>
      {frame_id.
         \<exists>pt_id \<in> mapped_pts_of object_map pd_caps.
           \<exists>frame \<in> ran (object_slots (the (object_map pt_id))).
             frame_id \<in> cap_objects frame}
    \<union> {section_id.
         \<exists>section \<in> ran pd_caps.
            case section of FrameCap _ _ _ _ _ _ \<Rightarrow> section_id \<in> cap_objects section
               | _ \<Rightarrow> False}"

text \<open>
  Resolve a schematic equality "{a, b, c, ...} = ?val", while checking
  that the LHS is a concrete set builder expression
\<close>
method assign_schematic_set =
  (((rule arg_cong[where f="insert _"])+)?, rule refl[where t="{}"])

text \<open>
  Resolve a schematic equality "(a = x \<and> b = y \<and> c = z \<and> \<dots>) = ?val",
  while checking that the LHS is a conjunction of equations
\<close>
method assign_schematic_eq_conjs =
  (((rule conj_cong[where P="_ = _", OF refl])+)?, rule refl[where t="_ = _"])

text \<open>
  Resolve a schematic equality of the form
  "((a1 = x1 \<and> a2 = x2 \<and> \<dots>) \<or> (b1 = y1 \<and> b2 = y2 \<and> \<dots>) \<or> \<dots>) = ?val",
  while ensuring that the LHS consists of equations in disjunctive normal form.
\<close>
method assign_schematic_dnf =
  (((rule disj_cong, assign_schematic_eq_conjs)+)?, assign_schematic_eq_conjs)

text \<open>Policy graph manipulation utils\<close>
lemma split_Collect_graph_edge:
  "Collect P = Collect (\<lambda>(from, auth, to). P (from, auth, to))"
  by simp

lemma Collect_graph_cong_helper:
  "(\<And>x y z. P x y z = P' x y z) \<Longrightarrow>
   Collect (\<lambda>(x, y, z). P x y z) = Collect (\<lambda>(x, y, z). P' x y z)"
  by simp

text \<open>
  VER-1030 forces us to create a huge number of (mostly spurious)
  DeleteDerived rights in @{const policy_of}. In fact, it forms a
  complete graph. We use that fact to help prove transitivity more
  efficiently.
\<close>
lemma proj_Collect_prod:
  "fst ` {(a, b). f a b} = {a. \<exists>b. f a b}"
  "snd ` {(a, b). f a b} = {b. \<exists>a. f a b}"
  by force+

lemma complete_graph_is_transitive[rotated 1, consumes 2]:
  "\<lbrakk> let edges = {(v, u). G v e u};
         verts = fst ` edges \<union> snd ` edges
     in \<forall>u \<in> verts. \<forall>v \<in> verts. G v e u;
     G u e v; G v e w \<rbrakk>
   \<Longrightarrow> G u e w"
  apply (simp (no_asm_use) add: proj_Collect_prod flip: Collect_disj_eq)
  by blast

(* version without self edges *)
lemma complete_graph_is_transitive'[rotated 1, consumes 2]:
  "\<lbrakk> let edges = {(v, u). G v e u};
         verts = fst ` edges \<union> snd ` edges
     in \<forall>u \<in> verts. \<forall>v \<in> verts. u \<noteq> v \<longrightarrow> G v e u;
     G u e v; G v e w; u \<noteq> v; v \<noteq> w; u \<noteq> w \<rbrakk>
   \<Longrightarrow> G u e w"
  apply (simp (no_asm_use) add: proj_Collect_prod flip: Collect_disj_eq)
  by blast

lemma Collect_case_prod_dnf:
  "{(a, b). a = x \<and> b = y} = {(x, y)}"
  "{(a, b). a = x \<and> b = y \<or> P a b} = insert (x, y) {(a, b). P a b}"
  "{(a, b). b = y \<and> a = x} = set [(x, y)]"
  "{(a, b). b = y \<and> a = x \<or> P a b} = insert (x, y) {(a, b). P a b}"
  by auto

text \<open>
  Simplified, automation-friendl(ier) intro for policy_wellformed, assuming that
  CAmkES never provides Grant auth across components, and we ignore components
  indirectly triggering interrupts.
\<close>

lemma camkes_policy_wellformedI:
  assumes "\<not>maySendIrqs"
      and "\<And>a. (agent, a, agent) \<in> aag"
      and "\<And>s auth r. (s, auth, r) \<in> aag \<Longrightarrow> (s, Control, s) \<in> aag"
      and "\<And>s r. (s, auth.Grant, r) \<in> aag \<Longrightarrow> s = r"
      and "\<And>s r. (s, Control, r) \<in> aag \<Longrightarrow> s = r"
      and "\<And>s auth. (s, Control, s) \<in> aag \<Longrightarrow> (s, auth, s) \<in> aag"
      and "\<And>s r. (s, Receive, r) \<in> aag \<Longrightarrow> s \<noteq> r \<Longrightarrow> (r, Control, r) \<in> aag \<Longrightarrow> False"
      and "\<And>s r. (s, Call, r) \<in> aag \<Longrightarrow> s \<noteq> r \<Longrightarrow> (r, Control, r) \<in> aag \<Longrightarrow> False"
      and "\<And>s ep. (s, Call, ep) \<in> aag \<Longrightarrow> (s, SyncSend, ep) \<in> aag"
      and "\<And>s r. (s, Reply, r) \<in> aag \<Longrightarrow> (r, DeleteDerived, s) \<in> aag"
      and "\<And>s r ep. (s, Call, ep) \<in> aag \<Longrightarrow> s \<noteq> ep \<Longrightarrow> (r, Receive, ep) \<in> aag
                     \<Longrightarrow> (r, Reply, s) \<in> aag"
      and "\<And>l1 l2 l3. (l1, DeleteDerived, l2) \<in> aag \<Longrightarrow> l1 \<noteq> l2 \<Longrightarrow>
                       (l2, DeleteDerived, l3) \<in> aag \<Longrightarrow> l1 \<noteq> l3 \<Longrightarrow> l2 \<noteq> l3 \<Longrightarrow>
                       (l1, DeleteDerived, l3) \<in> aag"
  shows "policy_wellformed aag maySendIrqs irqSet agent"
  unfolding policy_wellformed_def
  apply (insert assms)
  apply (safe; metis)
  done

section \<open>Word and pointer arithmetic helpers\<close>
lemma ptr_range_in_range:
  "0 < (p :: 'a::len word) + 2^sz \<Longrightarrow>
   (x \<in> ptr_range p sz) = (RangeMap.in_range (p, p + 2^sz) x)"
  apply (simp add: ptr_range_def RangeMap.in_range.simps)
  apply uint_arith
  done

lemma Collect_asid_high__eval_helper:
  "asid_high_bits_of ` {asid. fst (transform_asid asid) = asid_high \<and> asid \<noteq> 0} =
   (if asid_high < 2^asid_high_bits then {of_nat asid_high} else {})"
  (* cleanup... *)
  apply (case_tac "asid_high < 2^asid_high_bits")
   prefer 2
   apply (clarsimp simp: transform_asid_def asid_high_bits_of_def[abs_def])
   apply (erule contrapos_np)
   apply (subst arg_cong[where f="(<) _"])
    prefer 2
    apply (rule unat_lt2p)
   apply (simp add: asid_high_bits_def)
  apply (simp add: transform_asid_def asid_high_bits_of_def[abs_def])
  apply (rule set_eqI)
  apply (rule iffI)
   apply clarsimp
  apply (clarsimp simp: Collect_conj_eq image_iff)
  apply (rule_tac x="(of_nat asid_high << asid_low_bits) + 1" in bexI)
   apply (subst add.commute, subst shiftr_irrelevant)
     apply (clarsimp simp: asid_low_bits_def asid_high_bits_def)
    apply (clarsimp simp: is_aligned_shift)
   apply (subst shiftl_shiftr_id)
     apply (clarsimp simp: asid_low_bits_def asid_high_bits_def)
    apply (clarsimp simp: asid_low_bits_def asid_high_bits_def word_of_nat_less)
   apply (subst ucast_of_nat_small)
    apply (clarsimp simp: asid_high_bits_def)
   apply simp
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp: unat_ucast_eq_unat_and_mask)
   apply (subst add.commute, subst shiftr_irrelevant)
     apply (clarsimp simp: asid_low_bits_def asid_high_bits_def)
    apply (clarsimp simp: is_aligned_shift)
   apply (subst shiftl_shiftr_id)
     apply (clarsimp simp: asid_low_bits_def asid_high_bits_def)
    apply (clarsimp simp: asid_low_bits_def asid_high_bits_def word_of_nat_less)
   apply (fold asid_high_bits_def)
   apply (subst less_mask_eq)
    apply (clarsimp simp: asid_high_bits_def word_of_nat_less)
   apply (rule unat_of_nat_eq)
   apply (clarsimp simp: asid_high_bits_def)
  apply (rule less_is_non_zero_p1[where k="2^asid_high_bits << asid_low_bits"])
  apply (simp only: shiftl_t2n)
  apply (subst mult.commute, subst mult.commute, rule word_mult_less_mono1)
    apply (clarsimp simp: asid_high_bits_def word_of_nat_less)
   apply (clarsimp simp: asid_low_bits_def)
  apply (clarsimp simp: asid_low_bits_def asid_high_bits_def)
  done

section \<open>Assorted helpers\<close>
lemma fun_upds_to_map_of[THEN eq_reflection]:
  "Map.empty = map_of []"
  "(map_of xs(k \<mapsto> v)) = map_of ((k, v) # xs)"
  by auto

lemma subst_eqn_helper:
  "(\<And>s. s = t \<longrightarrow> P s) \<Longrightarrow> P t"
  by simp

text \<open>Helper to lift FastMap lookups to "admissible labelling" predicates.\<close>
lemma iterate_labelling_helper:
  "\<lbrakk> m = map_of binds;
     distinct (map fst binds)
   \<rbrakk> \<Longrightarrow>
   (\<forall>obj label. m obj = Some label \<longrightarrow> label_of obj = label)
    = list_all (\<lambda>(k, v). label_of k = v) binds"
  apply (rule iffI)
   apply (blast intro: list_allI FastMap.map_of_lookups)
  apply (fastforce simp: list_all_iff)
  done

section \<open>Integrity proof automation\<close>

text \<open>Helpers to put the policy subgoals into a consistent form for our automation\<close>
lemma helper_pcs_refined_policyI:
  assumes cdt_policy: "\<And>p slot p' slot'.
                          cdl_cdt s (p, slot) = Some (p', slot') \<Longrightarrow>
                          (pasObjectAbs aag p', Control, pasObjectAbs aag p) \<in> pasPolicy aag"
      and delete_derived_policy: "\<And>p slot p' slot'.
                          cdl_cdt s (p, slot) = Some (p', slot') \<Longrightarrow>
                          (pasObjectAbs aag p', DeleteDerived, pasObjectAbs aag p) \<in> pasPolicy aag"
      and obj_policy: "\<And>p p_obj p_idx cap auth oref.
                          \<lbrakk> cdl_objects s p = Some p_obj;
                            object_slots p_obj p_idx = Some cap;
                            auth \<in> cdl_cap_auth_conferred cap;
                            oref \<in> cdl_obj_refs cap
                          \<rbrakk> \<Longrightarrow> (pasObjectAbs aag p, auth, pasObjectAbs aag oref) \<in> pasPolicy aag"
  shows "auth_graph_map (pasObjectAbs aag) (cdl_state_objs_to_policy s) \<subseteq> (pasPolicy aag)"
  apply (clarsimp simp: cdl_state_objs_to_policy_def auth_graph_map_def)
  by (fastforce elim: cdl_state_bits_to_policy.cases
                intro: obj_policy cdt_policy delete_derived_policy
                simp: opt_cap_def slots_of_def
                split: option.splits)

text \<open>More executable form of obj_policy\<close>
lemma helper_pcs_refined_policy__eval:
      (* policy specification, to be generated *)
  assumes policy_spec: "policy_spec \<subseteq> pasPolicy aag"
      and label_spec: "\<And>p l. label_spec p = Some l \<Longrightarrow> pasObjectAbs aag p = l"
      (* we don't handle the CDT for now, so these are unchanged *)
      and cdt_policy:
            "\<And>p slot p' slot'.
                 cdl_cdt s (p, slot) = Some (p', slot') \<Longrightarrow>
                 (pasObjectAbs aag p', Control, pasObjectAbs aag p) \<in> pasPolicy aag"
      and delete_derived_policy:
            "\<And>p slot p' slot'.
                 cdl_cdt s (p, slot) = Some (p', slot') \<Longrightarrow>
                 (pasObjectAbs aag p', DeleteDerived, pasObjectAbs aag p) \<in> pasPolicy aag"
      (* main specification, as nested set traversals *)
      and obj_policy:
            "\<forall>(p, p_obj) \<in> graph_of (cdl_objects s).
               (case label_spec p of
                  Some pl \<Rightarrow>
                     \<forall>(p_idx, cap) \<in> graph_of (object_slots p_obj).
                       \<forall>auth \<in> cdl_cap_auth_conferred cap.
                         \<forall>oref \<in> cdl_obj_refs cap.
                            (case label_spec oref of
                               Some orefl \<Rightarrow> generic_tag ''obj policy'' (p, cap, cdl_obj_refs cap)
                                                 ((pl, auth, orefl) \<in> policy_spec)
                             | _ \<Rightarrow> False)
                | _ \<Rightarrow> False)"
  shows "auth_graph_map (pasObjectAbs aag) (cdl_state_objs_to_policy s) \<subseteq> (pasPolicy aag)"
  apply (rule helper_pcs_refined_policyI)
    apply (blast intro: cdt_policy)
   apply (blast intro: delete_derived_policy)
  apply (fastforce simp: remove_generic_tag
                   intro: subsetD[OF policy_spec]
                   dest: label_spec obj_policy[simplified graph_of_def, simplified, rule_format]
                   split: option.splits)
  done

(* Efficient check for key distinctness *)
fun sorted_distinct :: "'a::linorder list \<Rightarrow> bool" where
    "sorted_distinct (x # y # xs) = (x < y \<and> sorted_distinct (y # xs))"
  | "sorted_distinct _ = True"

lemma sorted_distinct:
  "sorted_distinct xs \<Longrightarrow> sorted xs \<and> distinct xs"
  by (induct xs rule: sorted_distinct.induct; fastforce)

lemma sorted_distinct_conv:
  "sorted_distinct xs = (sorted xs \<and> distinct xs)"
  apply (induct xs)
   apply simp
  apply (rename_tac x xs, case_tac xs)
   apply simp
  apply fastforce
  done

(* This is a conditional rule and FP_Eval can't evaluate it.
   Below, we construct a workaround for this *)
lemma graph_of_map_of:
  "distinct (map fst binds) \<Longrightarrow> graph_of (map_of binds) = set binds"
  by (simp add: graph_of_def)

lemma graph_of_map_of_simp:
  "sorted_distinct (map fst binds) \<Longrightarrow> graph_of (map_of binds) = set binds"
  by (simp add: graph_of_def sorted_distinct_conv)

(* prevent looping if sorted_distinct fails for any reason *)
definition "graph_of_map_of__eval_FAIL binds \<equiv> graph_of (map_of binds)"

(* @{const rev} is because @{thm fun_upds_to_map_of} produces list in reverse order
   compared to the [_ \<mapsto> _...] syntax *)
lemma graph_of_map_of__sorted_eval:
  "graph_of (map_of binds) =
     (if sorted_distinct (rev (map fst binds)) then set binds else graph_of_map_of__eval_FAIL binds)"
  by (simp add: graph_of_map_of sorted_distinct_conv graph_of_map_of__eval_FAIL_def)

(* useful if we already have a distinctness theorem from somewhere *)
lemma graph_of_map_of__distinct_eval:
  "graph_of (map_of binds) =
     (if distinct (map fst binds) then set binds else graph_of_map_of__eval_FAIL binds)"
  by (simp add: graph_of_map_of graph_of_map_of__eval_FAIL_def)

lemma range_map_of_ptr_range:
  "\<lbrakk> RangeMap.range_map_of binds (p :: cdl_object_id) = Some ((p, p + 2^sz), l) \<rbrakk> \<Longrightarrow>
   (x \<in> ptr_range p sz) = (p \<le> x \<and> x < p + 2^sz)"
  apply (drule RangeMap.range_map_of_SomeD)
  apply (subst ptr_range_in_range)
   apply unat_arith
  apply (simp add: RangeMap.in_range.simps)
  done

lemma range_tree_ptr_range:
  "\<lbrakk> RangeMap.lookup_range_tree tree = RangeMap.range_map_of binds;
     RangeMap.monotonic_key_ranges binds;
     RangeMap.range_map_of binds (p :: cdl_object_id) = Some ((p, p + 2^sz), l);
     x \<in> ptr_range p sz \<rbrakk> \<Longrightarrow>
   RangeMap.lookup_range_tree tree x = Some ((p, p + 2^sz), l)"
  apply (subst (asm) range_map_of_ptr_range)
   apply fastforce
  apply (simp only:)
  apply (drule RangeMap.range_map_of_SomeD)
  apply (blast intro: RangeMap.range_map_of_single RangeMap.monotonic_key_ranges_disjoint)
  done

(*
   This matches exactly the expression for checking object accesses
   over a ptr_range (see cdl_obj_refs.simps).

   "map_option snd" comes from the expansion of the generated
   <app>_labelling predicate.

   The LHS expects the RangeMap to be defined in the form
   "((foo_id, foo_id + 2^sz), foo_label)", and only does anything
   useful in this branch.

   If this rewrite no longer works in the main proof, it may need adjustment.
 *)
lemma label_over_ptr_range:
  assumes "RangeMap.monotonic_key_ranges binds"
      and "\<And>x. label_spec x = map_option snd (RangeMap.range_map_of binds x)"
  shows
   "RangeMap.range_map_of binds obj_id = Some ((obj_id, obj_id + 2^sz), l) \<Longrightarrow>
    (\<forall>oref \<in> ptr_range (obj_id :: cdl_object_id) sz.
       case label_spec oref of
          Some l \<Rightarrow> P l | None \<Rightarrow> False)
     = P l"
  apply (rule iffI)
   apply (fastforce simp: range_map_of_ptr_range assms
                    dest: RangeMap.range_map_of_SomeD bspec)
  apply (clarsimp simp: assms)
  apply (subst (asm) range_map_of_ptr_range, assumption)
  apply (subst RangeMap.range_map_of_single;
         fastforce simp: RangeMap.range_map_of_single RangeMap.in_range.simps
                   intro: RangeMap.monotonic_key_ranges_disjoint assms
                   dest: RangeMap.range_map_of_SomeD)
  done

(* prevent looping if label_over_ptr_range fails for any reason *)
definition label_over_ptr_range_FAILED
  where "label_over_ptr_range_FAILED = Ball"

(* again, lift the conditional rule to a pure equation for fp_eval *)
lemma label_over_ptr_range_fp_eval:
  assumes "RangeMap.monotonic_key_ranges binds"
      and "\<And>x. label_spec x = map_option snd (RangeMap.range_map_of binds x)"
  shows
   "(\<forall>oref \<in> ptr_range (obj_id :: cdl_object_id) sz.
       case label_spec oref of Some l \<Rightarrow> P l | None \<Rightarrow> False)
     = (case RangeMap.range_map_of binds obj_id of
          Some ((obj_id', obj_end), l) \<Rightarrow>
             if obj_id' = obj_id \<and> obj_end = obj_id + 2^sz \<comment> \<open> = ptr_range\<close>
             then P l \<comment> \<open>this is the case we care about, the rest is just fluff\<close>
             else (label_over_ptr_range_FAILED (ptr_range obj_id sz)
                     (\<lambda>oref. case label_spec oref of Some l \<Rightarrow> P l | None \<Rightarrow> False))
        | None \<Rightarrow> (label_over_ptr_range_FAILED (ptr_range obj_id sz)
                     (\<lambda>oref. case label_spec oref of Some l \<Rightarrow> P l | None \<Rightarrow> False)))"
  apply (simp only: label_over_ptr_range_FAILED_def)
  (* rewrite "P l" in RHS *)
  apply (subst option.case_cong[where ?f2.0="case_prod _", OF refl refl])
   apply (clarsimp simp only:)
   apply wpfix
   apply (subst if_cong[OF refl _ refl])
    apply (clarsimp simp only:)
    apply (erule label_over_ptr_range[OF assms, symmetric])
   apply (rule refl)
  (* now both sides are identical in all cases *)
  apply (fastforce simp only: split: option.splits if_splits)
  done

lemma cdl_state_irqs_to_policy__eval:
  assumes policy_spec: "policy_spec \<subseteq> pasPolicy aag"
      and obj_label_spec: "\<And>p l. obj_label_spec p = Some l \<Longrightarrow> pasObjectAbs aag p = l"
      and irq_label_spec: "\<And>irq l. irq_label_spec irq = Some l \<Longrightarrow> pasIRQAbs aag irq = l"
  shows "\<forall>(p, p_obj) \<in> graph_of (cdl_objects s).
           (case obj_label_spec p of
              Some pl \<Rightarrow>
                 \<forall>(p_idx, cap) \<in> graph_of (object_slots p_obj).
                   \<forall>irq \<in> cdl_cap_irqs_controlled cap.
                      (case irq_label_spec irq of
                           Some irql \<Rightarrow> generic_tag ''irq policy'' (p, cap, irq)
                                            ((pl, Control, irql) \<in> policy_spec)
                         | _ \<Rightarrow> False)
            | _ \<Rightarrow> False)
         \<Longrightarrow> cdl_state_irqs_to_policy aag s \<subseteq> pasPolicy aag"
  apply clarsimp
  apply (erule cdl_state_irqs_to_policy_aux.cases)
  apply (fastforce simp: opt_cap_def slots_of_def graph_of_def remove_generic_tag
                   split: option.splits
                   dest: obj_label_spec irq_label_spec
                   intro: subsetD[OF policy_spec])
  done

lemma cdl_state_asids_to_policy__eval:
  assumes policy_spec: "policy_spec \<subseteq> pasPolicy aag"
      and obj_label_spec: "\<And>p l. obj_label_spec p = Some l \<Longrightarrow> pasObjectAbs aag p = l"
      and asid_label_spec: "\<And>asid l. asid_label_spec (asid_high_bits_of asid) = Some l \<Longrightarrow>
                                      pasASIDAbs aag asid = l"
      and cap_asids:
            "\<forall>(p, p_obj) \<in> graph_of (cdl_objects s).
               (case obj_label_spec p of
                  Some pl \<Rightarrow>
                     \<forall>(p_idx, cap) \<in> graph_of (object_slots p_obj).
                       \<forall>asid \<in> asid_high_bits_of ` cdl_cap_asid' cap.
                          (case asid_label_spec asid of
                               Some asidl \<Rightarrow> generic_tag ''asid policy'' (p, cap, asid)
                                                 ((pl, Control, asidl) \<in> policy_spec)
                             | _ \<Rightarrow> False)
                | _ \<Rightarrow> False)"
      and asid_table_lookups:
            "\<forall>(asid_high, asid_pool_cap) \<in> graph_of (cdl_asid_table s).
               \<not>is_null_cap asid_pool_cap \<longrightarrow>
               (case asid_label_spec (of_nat asid_high) of
                  Some asidl \<Rightarrow>
                     (case cdl_objects s (cap_object asid_pool_cap) of
                        Some asid_pool \<Rightarrow>
                           \<forall>(asid_low, pd_cap) \<in> graph_of (object_slots asid_pool).
                             if is_null_cap pd_cap then True else
                                (case obj_label_spec (cap_object pd_cap) of
                                     Some pdl \<Rightarrow> generic_tag ''asid PD policy'' (asid_high, pd_cap)
                                                     ((asidl, Control, pdl) \<in> policy_spec)
                                   | _ \<Rightarrow> False)
                      | _ \<Rightarrow> False)
                     \<and> (case obj_label_spec (cap_object asid_pool_cap) of
                           Some asid_pool_l \<Rightarrow>
                             generic_tag ''asid pool policy'' (asid_high, asid_pool_cap)
                                 ((asid_pool_l, AAuth ASIDPoolMapsASID, asidl) \<in> policy_spec)
                         | _ \<Rightarrow> False)
                | _ \<Rightarrow> False)"

  shows "cdl_state_asids_to_policy aag s \<subseteq> pasPolicy aag"
  apply clarsimp
  apply (erule cdl_state_asids_to_policy_aux.cases)
    using cap_asids[unfolded remove_generic_tag]
    apply (fastforce simp: opt_cap_def slots_of_def graph_of_def
                     dest: obj_label_spec asid_label_spec
                     intro: subsetD[OF policy_spec]
                     split: option.splits)
   using asid_table_lookups[unfolded remove_generic_tag]
   apply (fastforce simp: opt_cap_def slots_of_def graph_of_def transform_asid_def
                    dest: obj_label_spec asid_label_spec
                    intro: subsetD[OF policy_spec]
                    split: option.splits)
  using asid_table_lookups[unfolded remove_generic_tag]
  apply (fastforce simp: opt_cap_def slots_of_def graph_of_def transform_asid_def
                   dest: obj_label_spec asid_label_spec
                   intro: subsetD[OF policy_spec]
                   split: option.splits)
  done

section \<open>Automation simpsets\<close>

lemma Ball_eval:
  "Ball (insert x s) P = (P x \<and> Ball s P)"
  "Ball Set.empty P = True"
  by auto

lemma ball_cong_weak:
  "\<And>s s' P. s = s' \<Longrightarrow> Ball s P = Ball s' P"
  by simp

lemmas finite_set_simps =
        insert_iff empty_iff
        Un_insert_left Un_empty_left
        Int_insert_left Int_empty_left
        insert_Diff_if empty_Diff

(* missing from HOL-Word... *)
lemma bintrunc_1_1:
  "bintrunc 1 1 = 1"
  by auto

(* simpset for comparisons between word literals *)
lemmas word_rel_simps_small =
  order_refl (* shortcut *)
  rel_simps simp_thms
  word_less_alt word_le_def word_uint_eq_iff uint_0_eq uint_1
  (* need bintrunc to reduce numerals mod word size *)
  uint_bintrunc bintrunc_numeral_simps bintrunc_1_1
  numeral_One
  (* evaluating word size for bintrunc -- yuck *)
  len_num0 len_num1 len_bit0 len_bit1
  arith_simps mult_1_right pred_numeral_simps numeral_plus_one
  arith_special

(* test for simpset *)
ML \<open>
let
  val eval = Raw_Simplifier.rewrite @{context} false
               (map_filter FP_Eval.maybe_convert_eqn @{thms word_rel_simps_small});
  fun check word_typ cmp cmp_term x y = let
    val xt = HOLogic.mk_number word_typ x;
    val yt = HOLogic.mk_number word_typ y;
    val prop = Const (cmp_term, word_typ --> word_typ --> @{typ bool}) $ xt $ yt;
    val prop = (if cmp (x, y) then prop else @{term "HOL.Not"} $ prop)
               |> Thm.cterm_of @{context};
    val result = eval prop |> Thm.rhs_of;
  in if Thm.term_of result = @{term True} then () else
       error ("word_rel_simps_small test failed for: " ^ @{make_string} prop ^
              "\n  Result: " ^ @{make_string} result) end
in
  [@{typ word32}, @{typ word64}, @{typ "3 word"}]
  |> app (fn word_typ =>
      [(op<, @{const_name less}), (op<=, @{const_name less_eq}), (op=, @{const_name HOL.eq})]
      |> app (fn (cmp, cmp_term) =>
          List.tabulate (8, I)
          |> app (fn x =>
              List.tabulate (8, I)
              |> app (fn y =>
                  check word_typ cmp cmp_term x y
              )
          )
      )
  )
end
\<close>

lemma pow_2_numeral:
  "(2::'a::{numeral,semiring_1,power})^0 = 1"
  "(2::'a)^1 = 2"
  "(2::'a)^numeral n = 2 * 2^(numeral n - 1)"
  apply simp
  apply simp
  apply (metis numeral_eq_Suc pred_numeral_def power_Suc)
  done

(* needed to evaluate "ptr + 2^sz" expressions *)
lemmas word_pow_arith_simps =
  pow_2_numeral uint_word_arith_bintrs
  uint_0_eq uint_1 uint_bintrunc bintrunc_Suc_numeral numeral_One
  arith_simps arith_special
  nat_0 nat_one_as_int[symmetric] nat_numeral nat_numeral_diff_1 mult_1_right

lemmas object_slots_eval_simps
         [simplified fun_upds_to_map_of] = (* NB: convert Map.empty for FP_Eval compatibility *)
    object_slots_def cdl_object.case
    cdl_asid_pool.simps
    cdl_cnode.simps
    cdl_irq_node.simps
    cdl_page_table.simps
    cdl_page_directory.simps
    cdl_tcb.simps

(* Main simpset and congs *)
lemmas obj_policy_eval_simps =
        (* basics *)
        simp_thms if_True if_False
        Ball_eval option.case cdl_cap.case prod.case
        list.set prod.sel option.map option.set

        object_slots_eval_simps
        cdl_obj_refs.simps

        (* converting graph_of (map_of <caps...>) *)
        graph_of_map_of__sorted_eval rev.simps append.simps
        sorted_distinct.simps rel_simps list.map

        (* evaluating asid integrity *)
        cdl_cap_asid'.simps
        is_null_cap_def cap_object_simps
        image_empty
        semiring_1_class.of_nat_0 semiring_1_class.of_nat_1 semiring_1_class.of_nat_numeral

        (* evaluating irq integrity *)
        cdl_cap_irqs_controlled.simps

        (* evaluating cdl_cap_auth_conferred for obj integrity *)
        cdl_cap_auth_conferred_def
        cap_rights_to_auth_def vspace_cap_rights_to_auth_def
        rights.distinct finite_set_simps

lemmas obj_policy_eval_congs =
        if_weak_cong FP_Eval.let_weak_cong'
        ball_cong_weak option.case_cong_weak prod.case_cong_weak
        cdl_object.case_cong_weak cdl_cap.case_cong_weak

end
end