(*  Title:      HOL/Bali/AxExample.thy
    Author:     David von Oheimb
*)

subsection \<open>Example of a proof based on the Bali axiomatic semantics\<close>

theory AxExample
imports AxSem Example
begin

definition
  arr_inv :: "st \<Rightarrow> bool" where
 "arr_inv = (\<lambda>s. \<exists>obj a T el. globs s (Stat Base) = Some obj \<and>
                              values obj (Inl (arr, Base)) = Some (Addr a) \<and>
                              heap s a = Some \<lparr>tag=Arr T 2,values=el\<rparr>)"

lemma arr_inv_new_obj:
"\<And>a. \<lbrakk>arr_inv s; new_Addr (heap s)=Some a\<rbrakk> \<Longrightarrow> arr_inv (gupd(Inl a\<mapsto>x) s)"
apply (unfold arr_inv_def)
apply (force dest!: new_AddrD2)
done

lemma arr_inv_set_locals [simp]: "arr_inv (set_locals l s) = arr_inv s"
apply (unfold arr_inv_def)
apply (simp (no_asm))
done

lemma arr_inv_gupd_Stat [simp]:
  "Base \<noteq> C \<Longrightarrow> arr_inv (gupd(Stat C\<mapsto>obj) s) = arr_inv s"
apply (unfold arr_inv_def)
apply (simp (no_asm_simp))
done

lemma ax_inv_lupd [simp]: "arr_inv (lupd(x\<mapsto>y) s) = arr_inv s"
apply (unfold arr_inv_def)
apply (simp (no_asm))
done

declare if_split_asm [split del]
declare lvar_def [simp]

ML \<open>
fun inst1_tac ctxt s t xs st =
  (case AList.lookup (op =) (rev (Term.add_var_names (Thm.prop_of st) [])) s of
    SOME i => PRIMITIVE (Rule_Insts.read_instantiate ctxt [(((s, i), Position.none), t)] xs) st
  | NONE => Seq.empty);

fun ax_tac ctxt =
  REPEAT o resolve_tac ctxt [allI] THEN'
  resolve_tac ctxt
    @{thms ax_Skip ax_StatRef ax_MethdN ax_Alloc ax_Alloc_Arr ax_SXAlloc_Normal ax_derivs.intros(8-)};
\<close>

theorem ax_test: "tprg,({}::'a triple set)\<turnstile>
  {Normal (\<lambda>Y s Z::'a. heap_free four s \<and> \<not>initd Base s \<and> \<not> initd Ext s)}
  .test [Class Base].
  {\<lambda>Y s Z. abrupt s = Some (Xcpt (Std IndOutBound))}"
apply (unfold test_def arr_viewed_from_def)
apply (tactic "ax_tac \<^context> 1" (*;;*))
defer (* We begin with the last assertion, to synthesise the intermediate
         assertions, like in the fashion of the weakest
         precondition. *)
apply  (tactic "ax_tac \<^context> 1" (* Try *))
defer
apply    (tactic \<open>inst1_tac \<^context> "Q"
                 "\<lambda>Y s Z. arr_inv (snd s) \<and> tprg,s\<turnstile>catch SXcpt NullPointer" []\<close>)
prefer 2
apply    simp
apply   (rule_tac P' = "Normal (\<lambda>Y s Z. arr_inv (snd s))" in conseq1)
prefer 2
apply    clarsimp
apply   (rule_tac Q' = "(\<lambda>Y s Z. Q Y s Z)\<leftarrow>=False\<down>=\<diamondsuit>" and Q = Q for Q in conseq2)
prefer 2
apply    simp
apply   (tactic "ax_tac \<^context> 1" (* While *))
prefer 2
apply    (rule ax_impossible [THEN conseq1], clarsimp)
apply   (rule_tac P' = "Normal P" and P = P for P in conseq1)
prefer 2
apply    clarsimp
apply   (tactic "ax_tac \<^context> 1")
apply   (tactic "ax_tac \<^context> 1" (* AVar *))
prefer 2
apply    (rule ax_subst_Val_allI)
apply    (tactic \<open>inst1_tac \<^context> "P'" "\<lambda>a. Normal (PP a\<leftarrow>x)" ["PP", "x"]\<close>)
apply    (simp del: avar_def2 peek_and_def2)
apply    (tactic "ax_tac \<^context> 1")
apply   (tactic "ax_tac \<^context> 1")
      (* just for clarification: *)
apply   (rule_tac Q' = "Normal (\<lambda>Var:(v, f) u ua. fst (snd (avar tprg (Intg 2) v u)) = Some (Xcpt (Std IndOutBound)))" in conseq2)
prefer 2
apply    (clarsimp simp add: split_beta)
apply   (tactic "ax_tac \<^context> 1" (* FVar *))
apply    (tactic "ax_tac \<^context> 2" (* StatRef *))
apply   (rule ax_derivs.Done [THEN conseq1])
apply   (clarsimp simp add: arr_inv_def inited_def in_bounds_def)
defer
apply  (rule ax_SXAlloc_catch_SXcpt)
apply  (rule_tac Q' = "(\<lambda>Y (x, s) Z. x = Some (Xcpt (Std NullPointer)) \<and> arr_inv s) \<and>. heap_free two" in conseq2)
prefer 2
apply   (simp add: arr_inv_new_obj)
apply  (tactic "ax_tac \<^context> 1")
apply  (rule_tac C = "Ext" in ax_Call_known_DynT)
apply     (unfold DynT_prop_def)
apply     (simp (no_asm))
apply    (intro strip)
apply    (rule_tac P' = "Normal P" and P = P for P in conseq1)
apply     (tactic "ax_tac \<^context> 1" (* Methd *))
apply     (rule ax_thin [OF _ empty_subsetI])
apply     (simp (no_asm) add: body_def2)
apply     (tactic "ax_tac \<^context> 1" (* Body *))
(* apply       (rule_tac [2] ax_derivs.Abrupt) *)
defer
apply      (simp (no_asm))
apply      (tactic "ax_tac \<^context> 1") (* Comp *)
            (* The first statement in the  composition
                 ((Ext)z).vee = 1; Return Null
                will throw an exception (since z is null). So we can handle
                Return Null with the Abrupt rule *)
apply       (rule_tac [2] ax_derivs.Abrupt)

apply      (rule ax_derivs.Expr) (* Expr *)
apply      (tactic "ax_tac \<^context> 1") (* Ass *)
prefer 2
apply       (rule ax_subst_Var_allI)
apply       (tactic \<open>inst1_tac \<^context> "P'" "\<lambda>a vs l vf. PP a vs l vf\<leftarrow>x \<and>. p" ["PP", "x", "p"]\<close>)
apply       (rule allI)
apply       (tactic \<open>simp_tac (\<^context> delloop "split_all_tac" delsimps [@{thm peek_and_def2}, @{thm heap_def2}, @{thm subst_res_def2}, @{thm normal_def2}]) 1\<close>)
apply       (rule ax_derivs.Abrupt)
apply      (simp (no_asm))
apply      (tactic "ax_tac \<^context> 1" (* FVar *))
apply       (tactic "ax_tac \<^context> 2", tactic "ax_tac \<^context> 2", tactic "ax_tac \<^context> 2")
apply      (tactic "ax_tac \<^context> 1")
apply     (tactic \<open>inst1_tac \<^context> "R" "\<lambda>a'. Normal ((\<lambda>Vals:vs (x, s) Z. arr_inv s \<and> inited Ext (globs s) \<and> a' \<noteq> Null \<and> vs = [Null]) \<and>. heap_free two)" []\<close>)
apply     fastforce
prefer 4
apply    (rule ax_derivs.Done [THEN conseq1],force)
apply   (rule ax_subst_Val_allI)
apply   (tactic \<open>inst1_tac \<^context> "P'" "\<lambda>a. Normal (PP a\<leftarrow>x)" ["PP", "x"]\<close>)
apply   (simp (no_asm) del: peek_and_def2 heap_free_def2 normal_def2 o_apply)
apply   (tactic "ax_tac \<^context> 1")
prefer 2
apply   (rule ax_subst_Val_allI)
apply    (tactic \<open>inst1_tac \<^context> "P'" "\<lambda>aa v. Normal (QQ aa v\<leftarrow>y)" ["QQ", "y"]\<close>)
apply    (simp del: peek_and_def2 heap_free_def2 normal_def2)
apply    (tactic "ax_tac \<^context> 1")
apply   (tactic "ax_tac \<^context> 1")
apply  (tactic "ax_tac \<^context> 1")
apply  (tactic "ax_tac \<^context> 1")
(* end method call *)
apply (simp (no_asm))
    (* just for clarification: *)
apply (rule_tac Q' = "Normal ((\<lambda>Y (x, s) Z. arr_inv s \<and> (\<exists>a. the (locals s (VName e)) = Addr a \<and> obj_class (the (globs s (Inl a))) = Ext \<and>
 invocation_declclass tprg IntVir s (the (locals s (VName e))) (ClassT Base)
     \<lparr>name = foo, parTs = [Class Base]\<rparr> = Ext)) \<and>. initd Ext \<and>. heap_free two)"
  in conseq2)
prefer 2
apply  clarsimp
apply (tactic "ax_tac \<^context> 1")
apply (tactic "ax_tac \<^context> 1")
defer
apply  (rule ax_subst_Var_allI)
apply  (tactic \<open>inst1_tac \<^context> "P'" "\<lambda>vf. Normal (PP vf \<and>. p)" ["PP", "p"]\<close>)
apply  (simp (no_asm) del: split_paired_All peek_and_def2 initd_def2 heap_free_def2 normal_def2)
apply  (tactic "ax_tac \<^context> 1" (* NewC *))
apply  (tactic "ax_tac \<^context> 1" (* ax_Alloc *))
     (* just for clarification: *)
apply  (rule_tac Q' = "Normal ((\<lambda>Y s Z. arr_inv (store s) \<and> vf=lvar (VName e) (store s)) \<and>. heap_free three \<and>. initd Ext)" in conseq2)
prefer 2
apply   (simp add: invocation_declclass_def dynmethd_def)
apply   (unfold dynlookup_def)
apply   (simp add: dynmethd_Ext_foo)
apply   (force elim!: arr_inv_new_obj atleast_free_SucD atleast_free_weaken)
     (* begin init *)
apply  (rule ax_InitS)
apply     force
apply    (simp (no_asm))
apply   (tactic \<open>simp_tac (\<^context> delloop "split_all_tac") 1\<close>)
apply   (rule ax_Init_Skip_lemma)
apply  (tactic \<open>simp_tac (\<^context> delloop "split_all_tac") 1\<close>)
apply  (rule ax_InitS [THEN conseq1] (* init Base *))
apply      force
apply     (simp (no_asm))
apply    (unfold arr_viewed_from_def)
apply    (rule allI)
apply    (rule_tac P' = "Normal P" and P = P for P in conseq1)
apply     (tactic \<open>simp_tac (\<^context> delloop "split_all_tac") 1\<close>)
apply     (tactic "ax_tac \<^context> 1")
apply     (tactic "ax_tac \<^context> 1")
apply     (rule_tac [2] ax_subst_Var_allI)
apply      (tactic \<open>inst1_tac \<^context> "P'" "\<lambda>vf l vfa. Normal (P vf l vfa)" ["P"]\<close>)
apply     (tactic \<open>simp_tac (\<^context> delloop "split_all_tac" delsimps [@{thm split_paired_All}, @{thm peek_and_def2}, @{thm heap_free_def2}, @{thm initd_def2}, @{thm normal_def2}, @{thm supd_lupd}]) 2\<close>)
apply      (tactic "ax_tac \<^context> 2" (* NewA *))
apply       (tactic "ax_tac \<^context> 3" (* ax_Alloc_Arr *))
apply       (tactic "ax_tac \<^context> 3")
apply      (tactic \<open>inst1_tac \<^context> "P" "\<lambda>vf l vfa. Normal (P vf l vfa\<leftarrow>\<diamondsuit>)" ["P"]\<close>)
apply      (tactic \<open>simp_tac (\<^context> delloop "split_all_tac") 2\<close>)
apply      (tactic "ax_tac \<^context> 2")
apply     (tactic "ax_tac \<^context> 1" (* FVar *))
apply      (tactic "ax_tac \<^context> 2" (* StatRef *))
apply     (rule ax_derivs.Done [THEN conseq1])
apply     (tactic \<open>inst1_tac \<^context> "Q" "\<lambda>vf. Normal ((\<lambda>Y s Z. vf=lvar (VName e) (snd s)) \<and>. heap_free four \<and>. initd Base \<and>. initd Ext)" []\<close>)
apply     (clarsimp split del: if_split)
apply     (frule atleast_free_weaken [THEN atleast_free_weaken])
apply     (drule initedD)
apply     (clarsimp elim!: atleast_free_SucD simp add: arr_inv_def)
apply    force
apply   (tactic \<open>simp_tac (\<^context> delloop "split_all_tac") 1\<close>)
apply   (rule ax_triv_Init_Object [THEN peek_and_forget2, THEN conseq1])
apply     (rule wf_tprg)
apply    clarsimp
apply   (tactic \<open>inst1_tac \<^context> "P" "\<lambda>vf. Normal ((\<lambda>Y s Z. vf = lvar (VName e) (snd s)) \<and>. heap_free four \<and>. initd Ext)" []\<close>)
apply   clarsimp
apply  (tactic \<open>inst1_tac \<^context> "PP" "\<lambda>vf. Normal ((\<lambda>Y s Z. vf = lvar (VName e) (snd s)) \<and>. heap_free four \<and>. Not \<circ> initd Base)" []\<close>)
apply  clarsimp
     (* end init *)
apply (rule conseq1)
apply (tactic "ax_tac \<^context> 1")
apply clarsimp
done

(*
while (true) {
  if (i) {throw xcpt;}
  else i=j
}
*)
lemma Loop_Xcpt_benchmark:
 "Q = (\<lambda>Y (x,s) Z. x \<noteq> None \<longrightarrow> the_Bool (the (locals s i))) \<Longrightarrow>
  G,({}::'a triple set)\<turnstile>{Normal (\<lambda>Y s Z::'a. True)}
  .lab1\<bullet> While(Lit (Bool True)) (If(Acc (LVar i)) (Throw (Acc (LVar xcpt))) Else
        (Expr (Ass (LVar i) (Acc (LVar j))))). {Q}"
apply (rule_tac P' = "Q" and Q' = "Q\<leftarrow>=False\<down>=\<diamondsuit>" in conseq12)
apply  safe
apply  (tactic "ax_tac \<^context> 1" (* Loop *))
apply   (rule ax_Normal_cases)
prefer 2
apply    (rule ax_derivs.Abrupt [THEN conseq1], clarsimp simp add: Let_def)
apply   (rule conseq1)
apply    (tactic "ax_tac \<^context> 1")
apply   clarsimp
prefer 2
apply  clarsimp
apply (tactic "ax_tac \<^context> 1" (* If *))
apply  (tactic
  \<open>inst1_tac \<^context> "P'" "Normal (\<lambda>s.. (\<lambda>Y s Z. True)\<down>=Val (the (locals s i)))" []\<close>)
apply  (tactic "ax_tac \<^context> 1")
apply  (rule conseq1)
apply   (tactic "ax_tac \<^context> 1")
apply  clarsimp
apply (rule allI)
apply (rule ax_escape)
apply auto
apply  (rule conseq1)
apply   (tactic "ax_tac \<^context> 1" (* Throw *))
apply   (tactic "ax_tac \<^context> 1")
apply   (tactic "ax_tac \<^context> 1")
apply  clarsimp
apply (rule_tac Q' = "Normal (\<lambda>Y s Z. True)" in conseq2)
prefer 2
apply  clarsimp
apply (rule conseq1)
apply  (tactic "ax_tac \<^context> 1")
apply  (tactic "ax_tac \<^context> 1")
prefer 2
apply   (rule ax_subst_Var_allI)
apply   (tactic \<open>inst1_tac \<^context> "P'" "\<lambda>b Y ba Z vf. \<lambda>Y (x,s) Z. x=None \<and> snd vf = snd (lvar i s)" []\<close>)
apply   (rule allI)
apply   (rule_tac P' = "Normal P" and P = P for P in conseq1)
prefer 2
apply    clarsimp
apply   (tactic "ax_tac \<^context> 1")
apply   (rule conseq1)
apply    (tactic "ax_tac \<^context> 1")
apply   clarsimp
apply  (tactic "ax_tac \<^context> 1")
apply clarsimp
done

end


theory Callproc
imports RHL_Typed
begin

lemma callproc_split_args:
  assumes footQ1: "assertion_footprint_left (-{mk_variable_untyped x1}) Q"
  assumes footQ2: "assertion_footprint_right (-{mk_variable_untyped x2}) Q"
  assumes x1f1: "mk_variable_untyped x1 \<notin> set (vars_proc_global f1)"
  assumes x1e1: "mk_variable_untyped x1 \<notin> set (e_vars e1)"
  assumes x2f2: "mk_variable_untyped x2 \<notin> set (vars_proc_global f2)"
  assumes x2e2: "mk_variable_untyped x2 \<notin> set (e_vars e2)"
  assumes rh: "rhoare P (seq (seq c1 (assign (variable_pattern x1) e1)) (callproc p1 f1 (var_expression x1)))
                        (seq (seq c2 (assign (variable_pattern x2) e2)) (callproc p2 f2 (var_expression x2))) Q"
  shows "rhoare P (seq c1 (callproc p1 f1 e1)) (seq c2 (callproc p2 f2 e2)) Q"
proof -
  let ?x1 = "mk_variable_untyped x1"
  let ?x2 = "mk_variable_untyped x2"
  define eq where "eq \<equiv> \<lambda>X m1 m2. \<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  have aux: "(\<lambda>mem1 mem2. eq X mem2 mem1) = (eq X)" for X unfolding eq_def by force

  have "rhoare (eq (-{?x1})) (callproc p1 f1 e1) (seq (assign (variable_pattern x1) e1) (callproc p1 f1 (var_expression x1))) (eq (-{?x1}))"
    unfolding eq_def obs_eq_def[symmetric]
    by (rule callproc_split_args_equiv, auto simp: x1f1 x1e1)
  hence left: "rhoare (eq UNIV)
            (seq c1 (callproc p1 f1 e1))
            (seq c1 (seq (assign (variable_pattern x1) e1) (callproc p1 f1 (var_expression x1))))
         (eq (-{?x1}))"
    apply (rule rseq_rule[rotated])
    unfolding eq_def obs_eq_def[symmetric]
    by (rule self_obseq_vars, auto)

  have "rhoare (eq (-{?x2})) (callproc p2 f2 e2) (seq (assign (variable_pattern x2) e2) (callproc p2 f2 (var_expression x2))) (eq (-{?x2}))"
    unfolding eq_def obs_eq_def[symmetric]
    by (rule callproc_split_args_equiv, auto simp: x2f2 x2e2)
  hence "rhoare (eq (-{?x2})) (seq (assign (variable_pattern x2) e2) (callproc p2 f2 (var_expression x2))) (callproc p2 f2 e2) (eq (-{?x2}))"
    apply (rule_tac rsymmetric_rule)
    unfolding aux by simp
  hence right: "rhoare (eq UNIV) (seq c2 (seq (assign (variable_pattern x2) e2) (callproc p2 f2 (var_expression x2))))
                                 (seq c2 (callproc p2 f2 e2))     (eq (-{?x2}))"
    apply (rule rseq_rule[rotated])
    unfolding eq_def obs_eq_def[symmetric]
    by (rule self_obseq_vars, auto)

  have mid: "rhoare P (seq c1 (seq (assign (variable_pattern x1) e1) (callproc p1 f1 (var_expression x1))))
                      (seq c2 (seq (assign (variable_pattern x2) e2) (callproc p2 f2 (var_expression x2)))) Q"
    using rh by (simp add: seq_assoc_left_rule seq_assoc_right_rule)

  show ?thesis
    apply (rule rtrans3_rule[rotated 2])
        close (fact left) close (fact mid) close (fact right)
     unfolding eq_def close blast
    using footQ1[THEN assertion_footprint_leftE] footQ2[THEN assertion_footprint_rightE]
    by metis
qed

lemma callproc_split_result:
  assumes footQ1: "assertion_footprint_left (-{mk_variable_untyped x1}) Q"
  assumes footQ2: "assertion_footprint_right (-{mk_variable_untyped x2}) Q"
  assumes rh: "rhoare P (seq (seq c1 (callproc (variable_pattern x1) f1 e1)) (assign p1 (var_expression x1)))
                        (seq (seq c2 (callproc (variable_pattern x2) f2 e2)) (assign p2 (var_expression x2))) Q"
  shows "rhoare P (seq c1 (callproc p1 f1 e1)) (seq c2 (callproc p2 f2 e2)) Q"
proof -
  let ?x1 = "mk_variable_untyped x1"
  let ?x2 = "mk_variable_untyped x2"
  define eq where "eq \<equiv> \<lambda>X m1 m2. \<forall>x\<in>X. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  have aux: "(\<lambda>mem1 mem2. eq X mem2 mem1) = (eq X)" for X unfolding eq_def by force

  have "rhoare (eq UNIV) (callproc p1 f1 e1) (seq (callproc (variable_pattern x1) f1 e1) (assign p1 (var_expression x1))) (eq (-{?x1}))"
    unfolding eq_def obs_eq_def[symmetric]
    by (rule callproc_split_result_equiv, auto)
  hence left: "rhoare (eq UNIV)
            (seq c1 (callproc p1 f1 e1))
            (seq c1 ((seq (callproc (variable_pattern x1) f1 e1) (assign p1 (var_expression x1)))))
         (eq (-{?x1}))"
    apply (rule rseq_rule[rotated])
    unfolding eq_def obs_eq_def[symmetric]
    by (rule self_obseq_vars, auto)

  have "rhoare (eq UNIV) (callproc p2 f2 e2) (seq (callproc (variable_pattern x2) f2 e2) (assign p2 (var_expression x2))) (eq (-{?x2}))"
    unfolding eq_def obs_eq_def[symmetric]
    by (rule callproc_split_result_equiv, auto)
  hence "rhoare (eq UNIV) (seq (callproc (variable_pattern x2) f2 e2) (assign p2 (var_expression x2))) (callproc p2 f2 e2) (eq (-{?x2}))"
    apply (rule_tac rsymmetric_rule)
    unfolding aux by simp
  hence right: "rhoare (eq UNIV) (seq c2 (seq (callproc (variable_pattern x2) f2 e2) (assign p2 (var_expression x2))))
                                 (seq c2 (callproc p2 f2 e2))     (eq (-{?x2}))"
    apply (rule rseq_rule[rotated])
    unfolding eq_def obs_eq_def[symmetric]
    by (rule self_obseq_vars, auto)

  have mid: "rhoare P (seq c1 (seq (callproc (variable_pattern x1) f1 e1) (assign p1 (var_expression x1))))
                      (seq c2 (seq (callproc (variable_pattern x2) f2 e2) (assign p2 (var_expression x2)))) Q"
    using rh by (simp add: seq_assoc_left_rule seq_assoc_right_rule)

  show ?thesis
    apply (rule rtrans3_rule[rotated 2])
        close (fact left) close (fact mid) close (fact right)
     unfolding eq_def close blast
    using footQ1[THEN assertion_footprint_leftE] footQ2[THEN assertion_footprint_rightE]
    by metis
qed

lemma call_rule_abstract:
  fixes globals_f and res x1 x2::"'x::prog_type variable"
    and args y1 y2::"'y::prog_type variable"
    and A B
  assumes distinct: "distinct globals_f"
  assumes globals_f: "set(write_vars_proc_global f) \<subseteq> set globals_f"
  assumes globals_f': "set(vars_proc_global f) \<supseteq> set globals_f"
  assumes x1_globals: "mk_variable_untyped x1 \<notin> set globals_f"
  assumes x2_globals: "mk_variable_untyped x2 \<notin> set globals_f"
  assumes res_nin_f: "mk_variable_untyped res \<notin> set (vars_proc_global f)"
  assumes args_nin_f: "mk_variable_untyped args \<notin> set (vars_proc_global f)"
  assumes args_not_res: "mk_variable_untyped args \<noteq> mk_variable_untyped res"
  defines "QB' == (\<lambda>m1 m2. (\<forall>g x.
                B (memory_update (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f) g) x1 x)
                  (memory_update (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f) g) x2 x)))"
  defines "C' == (\<lambda>m1 m2.
      (\<forall>x\<in>set (vars_proc_global f). memory_lookup_untyped m1 x = memory_lookup_untyped m2 x)
    \<and> memory_lookup m1 y1 = memory_lookup m2 y2
    \<and> QB' m1 m2)"
  assumes p1p2': "rhoare A p1 p2 C'"
  shows "rhoare A (seq p1 (callproc (variable_pattern x1) f (var_expression y1)))
                  (seq p2 (callproc (variable_pattern x2) f (var_expression y2))) B"
proof -
  define Q where "Q \<equiv> \<lambda>m1 m2. \<forall>x\<in>set (vars_proc_global f) \<union> {mk_variable_untyped res}. memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  define QB where "QB \<equiv> \<lambda>m1 m2. (\<forall>gL gR xL xR x'L x'R. gL \<in> t_domain (pu_type (list_pattern_untyped globals_f)) \<longrightarrow>
                 gR \<in> t_domain (pu_type (list_pattern_untyped globals_f)) \<longrightarrow>
                     Q (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f) gL) (list_pattern_untyped (p_vars (variable_pattern x1))) x'L) res xL)
                       (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f) gR) (list_pattern_untyped (p_vars (variable_pattern x2))) x'R) res xR)
                \<longrightarrow> B (memory_update_pattern
                     (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f) gL) (variable_pattern x1) xL)
                  (memory_update_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f) gR)
                    (variable_pattern x2) xR))"
  define P where "P \<equiv> \<lambda>m1 m2. \<forall>x\<in>set (vars_proc_global f) \<union> {mk_variable_untyped args}.
                    memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
  define C where "C \<equiv> \<lambda>m1 m2. P (memory_update m1 args (e_fun (var_expression y1) m1))
              (memory_update m2 args (e_fun (var_expression y2) m2)) \<and> QB m1 m2"

  have Q': "gL = gR \<and> xL = xR"
    if gL_type: "gL \<in> t_domain (pu_type (list_pattern_untyped globals_f))"
    and gR_type: "gR \<in> t_domain (pu_type (list_pattern_untyped globals_f))"
    and Q: "Q (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f) gL) (list_pattern_untyped (p_vars (variable_pattern x1))) x'L) res xL)
           (memory_update (memory_update_untyped_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f) gR) (list_pattern_untyped (p_vars (variable_pattern x2))) x'R) res xR)"
            (is "Q ?ml ?mr")
    for m1 m2 gL gR x'L x'R xL xR
  proof -
    define ml where "ml \<equiv> ?ml"
    define mr where "mr \<equiv> ?mr"
    note Q_rule = Q[unfolded Q_def, rule_format]
    note Q_rule' = Q[folded ml_def mr_def, unfolded Q_def, rule_format]

    have xLxR: "xL = xR"
      using Q_rule[of "mk_variable_untyped res"] by auto

    have kill_x1: "kill_vars_pattern_untyped (list_pattern_untyped globals_f) {mk_variable_untyped x1} = list_pattern_untyped globals_f"
      apply (rule kill_vars_pattern_untyped_disjoint) using x1_globals by simp
    have kill_x2: "kill_vars_pattern_untyped (list_pattern_untyped globals_f) {mk_variable_untyped x2} = list_pattern_untyped globals_f"
      apply (rule kill_vars_pattern_untyped_disjoint) using x2_globals by simp
    have kill_res: "kill_vars_pattern_untyped (list_pattern_untyped globals_f) {mk_variable_untyped res} = list_pattern_untyped globals_f"
      apply (rule kill_vars_pattern_untyped_disjoint) using globals_f' res_nin_f by auto

    have swapL: "memory_update (memory_update_untyped_pattern m (list_pattern_untyped globals_f) gL) res xL
               = memory_update_untyped_pattern (memory_update m res xL) (list_pattern_untyped globals_f) gL" for m
      unfolding memory_update_def
      apply (subst memory_update_untyped_pattern_1var[symmetric]) close simp
      unfolding memory_update_pattern_untyped_swap[where a="list_pattern_untyped globals_f"]
      by (auto simp: kill_res)
    have swapR: "memory_update (memory_update_untyped_pattern m (list_pattern_untyped globals_f) gR) res xR
               = memory_update_untyped_pattern (memory_update m res xR) (list_pattern_untyped globals_f) gR" for m
      unfolding memory_update_def
      apply (subst memory_update_untyped_pattern_1var[symmetric]) close simp
      unfolding memory_update_pattern_untyped_swap[where a="list_pattern_untyped globals_f"]
      by (auto simp: kill_res)

    have "eu_fun (list_expression_untyped globals_f) ml = eu_fun (list_expression_untyped globals_f) mr"
      apply (rule eu_fun_footprint)
      using Q_rule' globals_f' by auto
    hence gLgR: "gL = gR"
      unfolding mr_def ml_def apply simp
      unfolding memory_update_pattern_untyped_swap[where a="list_pattern_untyped globals_f"]
      apply (simp add: kill_x1 kill_x2)
      unfolding swapL swapR
      apply (subst (asm) list_expression_list_pattern_untyped)
        using distinct gL_type close 2
      apply (subst (asm) list_expression_list_pattern_untyped)
        using distinct gR_type close 2
      by simp
    show ?thesis using xLxR gLgR by simp
  qed

  have B': "B (memory_update_pattern (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f) gL) (variable_pattern x1) xL)
        (memory_update_pattern (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f) gR) (variable_pattern x2) xR)"
        if "B (memory_update (memory_update_untyped_pattern m1 (list_pattern_untyped globals_f) gL) x1 xL)
              (memory_update (memory_update_untyped_pattern m2 (list_pattern_untyped globals_f) gR) x2 xR)" for gL gR m1 m2 xL xR
    by (simp add: that)

  have QB'QB: "QB' m1 m2 \<Longrightarrow> QB m1 m2" for m1 m2
    unfolding QB'_def QB_def
    apply rule+
    apply (drule_tac Q')
      close 2 simp_all
    apply (rule B')
    by simp

  have P'P: "P (memory_update m1 args (memory_lookup m2 y2)) (memory_update m2 args (memory_lookup m2 y2))"
        if "\<forall>x\<in>set (vars_proc_global f). memory_lookup_untyped m1 x = memory_lookup_untyped m2 x"
        and "memory_lookup m1 y1 = memory_lookup m2 y2"
        (* and "memory_lookup m1 res = memory_lookup m2 res" *) for m1 m2
    unfolding P_def using that by auto

  from QB'QB P'P have "C' m1 m2 \<Longrightarrow> C m1 m2" for m1 m2 unfolding C'_def C_def by simp
  hence p1p2: "rhoare A p1 p2 C"
    apply (rule_tac rconseq_rule[OF _ _ p1p2'])
    by auto

  have "obs_eq (set(vars_proc_global f) \<union> {mk_variable_untyped args})
               (set(vars_proc_global f) \<union> {mk_variable_untyped res})
               (callproc (variable_pattern res) f (var_expression args))
               (callproc (variable_pattern res) f (var_expression args))"
    apply (rule self_obs_eq_callproc)
        unfolding vars_proc_global_def by auto
  hence PfQ: "rhoare P (callproc (variable_pattern res) f (var_expression args))
                       (callproc (variable_pattern res) f (var_expression args)) Q"
    unfolding obs_eq_def P_def Q_def by simp

  have footQ1: "assertion_footprint_left (- {mk_variable_untyped args}) Q"
    unfolding Q_def
    apply (rule assertion_footprint_leftI)
    apply simp by (metis args_nin_f args_not_res memory_lookup_def)

  have footQ2: "assertion_footprint_right (- {mk_variable_untyped args}) Q"
    apply (subst assertion_footprint_right_left)
    apply (rewrite at "assertion_footprint_left _ \<hole>" eq_reflection[of _ Q])
     close (unfold Q_def, metis)
    by (rule footQ1)

  show ?thesis
    apply (rule call_rule[where P=P and Q=Q])
    close 2 (rule globals_f)+
    close 2 (rule args_nin_f)+
    close (rule footQ1) close (rule footQ2)
    close (rule PfQ)
    using p1p2[unfolded C_def QB_def] by blast
qed

end


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

header{*The n_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_on_inv__43 imports n_germanSimp_base
begin
section{*All lemmas on causal relation between inv__43 and some rule r*}
lemma n_RecvReqSVsinv__43:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__43  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqS N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__43  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

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

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

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

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

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

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

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

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

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

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

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

end


theory Compiler imports Compiler1 Compiler2 begin

definition J2JVM :: "'addr J_prog \<Rightarrow> 'addr jvm_prog"
where [code del]: "J2JVM \<equiv> compP2 \<circ> compP1"

lemma J2JVM_code [code]:
  "J2JVM = compP (\<lambda>C M Ts T (pns, body). compMb2 (compE1 (this#pns) body))"
by(simp add: J2JVM_def compP2_def o_def compP_compP split_def)

end


(*  Title:      HOL/Auth/n_german_lemma_inv__5_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__5_on_rules imports n_german_lemma_on_inv__5
begin
section{*All lemmas on causal relation between inv__5*}
lemma lemma_inv__5_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__5  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__5) 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__5) 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__5) 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__5) 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__5) 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__5) 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__5) 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__5) 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__5) 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__5) 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__5) 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__5) 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__5) done
    }

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

end


theory ResourcedAdequacy
imports ResourcedDenotational Launchbury "AList-Utils" CorrectnessResourced
begin

lemma demand_not_0: "demand (\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<rho>\<^esub>) \<noteq> \<bottom>"
proof
  assume "demand (\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<rho>\<^esub>) = \<bottom>"
  with demand_suffices'[where n = 0, simplified, OF this]
  have "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>\<bottom> \<noteq> \<bottom>" by simp
  thus False by simp
qed

text \<open>
The semantics of an expression, given only @{term r} resources, will only use values from the
environment with less resources.
\<close>

lemma restr_can_restrict_env: "(\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)|\<^bsub>C\<cdot>r\<^esub> = (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)|\<^bsub>C\<cdot>r\<^esub>"
proof(induction e arbitrary: \<rho> r rule: exp_induct)
  case (Var x)
  show ?case
  proof (rule C_restr_C_cong)
    fix r'
    assume "r' \<sqsubseteq> r"
    have "(\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(C\<cdot>r') = \<rho> x\<cdot>r'" by simp
    also have "\<dots> = ((\<rho> x)|\<^bsub>r\<^esub>)\<cdot>r'" using \<open>r' \<sqsubseteq> r\<close> by simp
    also have "\<dots> =  (\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r')" by simp
    finally show "(\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(C\<cdot>r') = (\<N>\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r')".
  qed simp
next
  case (Lam x e)
  show ?case
  proof(rule C_restr_C_cong)
    fix r'
    assume "r' \<sqsubseteq> r"
    hence "r' \<sqsubseteq> C\<cdot>r" by (metis below_C below_trans)
    {
      fix v
      have "\<rho>(x := v)|\<^sup>\<circ>\<^bsub>r\<^esub> = (\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>)(x := v)|\<^sup>\<circ>\<^bsub>r\<^esub>"
        by simp
      hence "(\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>)|\<^bsub>r'\<^esub> = (\<N>\<lbrakk> e \<rbrakk>\<^bsub>(\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>)(x := v)\<^esub>)|\<^bsub>r'\<^esub>"
        by  (subst (1 2) C_restr_eq_lower[OF Lam \<open>r' \<sqsubseteq> C\<cdot>r\<close> ]) simp
    }
    thus "(\<N>\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(C\<cdot>r') = (\<N>\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r')"
      by simp
  qed simp
next
  case (App e x)
  show ?case
  proof (rule C_restr_C_cong)
    fix r'
    assume "r' \<sqsubseteq> r"
    hence "r' \<sqsubseteq> C\<cdot>r" by (metis below_C below_trans)
    hence "(\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r' = (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>r'"
        by (rule C_restr_eqD[OF App])
    thus "(\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(C\<cdot>r') = (\<N>\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r')"
      using \<open>r' \<sqsubseteq> r\<close> by simp
  qed simp
next
  case (Bool b)
  show ?case by simp
next
  case (IfThenElse scrut e\<^sub>1 e\<^sub>2)
  show ?case
  proof (rule C_restr_C_cong)
    fix r'
    assume "r' \<sqsubseteq> r"
    hence "r' \<sqsubseteq> C\<cdot>r" by (metis below_C below_trans)

    have "(\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r' = (\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>r'"
      using \<open>r' \<sqsubseteq> C\<cdot>r\<close> by (rule C_restr_eqD[OF IfThenElse(1)])
    moreover
    have "(\<N>\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r' = (\<N>\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>r'"
      using \<open>r' \<sqsubseteq> C\<cdot>r\<close> by (rule C_restr_eqD[OF IfThenElse(2)])
    moreover
    have "(\<N>\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>r' = (\<N>\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>r'"
      using \<open>r' \<sqsubseteq> C\<cdot>r\<close> by (rule C_restr_eqD[OF IfThenElse(3)])
    ultimately
    show "(\<N>\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(C\<cdot>r') = (\<N>\<lbrakk> (scrut ? e\<^sub>1 : e\<^sub>2) \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r')"
      using \<open>r' \<sqsubseteq> r\<close> by simp
  qed simp
next
  case (Let \<Gamma> e)

  txt \<open>The lemma, lifted to heaps\<close>
  have restr_can_restrict_env_heap : "\<And> r. (\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>)|\<^sup>\<circ>\<^bsub>r\<^esub> = (\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>)|\<^sup>\<circ>\<^bsub>r\<^esub>"
  proof(rule has_ESem.parallel_HSem_ind)
    fix \<rho>\<^sub>1 \<rho>\<^sub>2 :: CEnv and r :: C
    assume "\<rho>\<^sub>1|\<^sup>\<circ>\<^bsub>r\<^esub> = \<rho>\<^sub>2|\<^sup>\<circ>\<^bsub>r\<^esub>"

    show " (\<rho> ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^sub>1\<^esub>)|\<^sup>\<circ>\<^bsub>r\<^esub> = (\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub> ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^sub>2\<^esub>)|\<^sup>\<circ>\<^bsub>r\<^esub>"
    proof(rule env_C_restr_cong)
      fix x and r'
      assume "r' \<sqsubseteq> r"
      hence "r' \<sqsubseteq> C\<cdot>r" by (metis below_C below_trans)

      show "(\<rho> ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^sub>1\<^esub>) x\<cdot>r' = (\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub> ++\<^bsub>domA \<Gamma>\<^esub> \<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^sub>2\<^esub>) x\<cdot>r'"
      proof(cases "x \<in> domA \<Gamma>")
        case True
        have "(\<N>\<lbrakk> the (map_of \<Gamma> x) \<rbrakk>\<^bsub>\<rho>\<^sub>1\<^esub>)\<cdot>r' = (\<N>\<lbrakk> the (map_of \<Gamma> x) \<rbrakk>\<^bsub>\<rho>\<^sub>1|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>r'"
         by (rule C_restr_eqD[OF Let(1)[OF True] \<open>r' \<sqsubseteq> C\<cdot>r\<close>])
        also have "\<dots> = (\<N>\<lbrakk> the (map_of \<Gamma> x) \<rbrakk>\<^bsub>\<rho>\<^sub>2|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>r'"
          unfolding \<open>\<rho>\<^sub>1|\<^sup>\<circ>\<^bsub>r\<^esub> = \<rho>\<^sub>2|\<^sup>\<circ>\<^bsub>r\<^esub>\<close>..
        also have "\<dots>   = (\<N>\<lbrakk> the (map_of \<Gamma> x) \<rbrakk>\<^bsub>\<rho>\<^sub>2\<^esub>)\<cdot>r'"
          by (rule C_restr_eqD[OF Let(1)[OF True] \<open>r' \<sqsubseteq> C\<cdot>r\<close>, symmetric])
        finally
        show ?thesis using True by (simp add: lookupEvalHeap)
      next
        case False
        with \<open>r' \<sqsubseteq> r\<close>
        show ?thesis by simp
      qed
    qed
  qed simp_all

  show ?case
  proof (rule C_restr_C_cong)
    fix r'
    assume "r' \<sqsubseteq> r"
    hence "r' \<sqsubseteq> C\<cdot>r" by (metis below_C below_trans)

    have "(\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>)|\<^sup>\<circ>\<^bsub>r\<^esub> = (\<N>\<lbrace>\<Gamma>\<rbrace>(\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>))|\<^sup>\<circ>\<^bsub>r\<^esub>"
      by (rule restr_can_restrict_env_heap)
    hence "(\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>\<^esub>)\<cdot>r' = (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>r'"
      by (subst (1 2) C_restr_eqD[OF Let(2) \<open>r' \<sqsubseteq> C\<cdot>r\<close>]) simp

    thus "(\<N>\<lbrakk> Let \<Gamma> e \<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(C\<cdot>r') = (\<N>\<lbrakk> Let \<Gamma> e \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r')"
      using \<open>r' \<sqsubseteq> r\<close> by simp
  qed simp
qed

lemma can_restrict_env:
  "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<rho>\<^esub>)\<cdot>(C\<cdot>r) = (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r)"
  by (rule C_restr_eqD[OF restr_can_restrict_env below_refl])

text \<open>
When an expression @{term e} terminates, then we can remove such an expression from the heap and it
still terminates. This is the crucial trick to handle black-holing in the resourced semantics.
\<close>

lemma add_BH:
  assumes "map_of \<Gamma> x = Some e"
  assumes  "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r' \<noteq> \<bottom>"
  shows "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<^esub>)\<cdot>r' \<noteq> \<bottom>"
proof-
  obtain r where r: "C\<cdot>r = demand (\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)"
    using demand_not_0 by (cases "demand (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)") auto

  from  assms(2)
  have "C\<cdot>r \<sqsubseteq> r'" unfolding r not_bot_demand by simp

  from assms(1)
  have [simp]: "the (map_of \<Gamma> x) = e" by (metis option.sel)

  from assms(1)
  have [simp]: "x \<in> domA \<Gamma>" by (metis domIff dom_map_of_conv_domA not_Some_eq)

  define ub where "ub = \<N>\<lbrace>\<Gamma>\<rbrace>" \<comment> \<open>An upper bound for the induction\<close>

  have heaps: "(\<N>\<lbrace>\<Gamma>\<rbrace>)|\<^sup>\<circ>\<^bsub>r\<^esub> \<sqsubseteq> \<N>\<lbrace>delete x \<Gamma>\<rbrace>" and "\<N>\<lbrace>\<Gamma>\<rbrace> \<sqsubseteq> ub"
  proof (induction rule: HSem_bot_ind)
    fix \<rho>
    assume "\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub> \<sqsubseteq> \<N>\<lbrace>delete x \<Gamma>\<rbrace>"
    assume "\<rho> \<sqsubseteq> ub"

    show "(\<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>)|\<^sup>\<circ>\<^bsub>r\<^esub> \<sqsubseteq> \<N>\<lbrace>delete x \<Gamma>\<rbrace>"
    proof (rule fun_belowI)
      fix y
      show "((\<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>)|\<^sup>\<circ>\<^bsub>r\<^esub>) y \<sqsubseteq> (\<N>\<lbrace>delete x \<Gamma>\<rbrace>) y"
      proof (cases "y = x")
        case True
        have "((\<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>)|\<^sup>\<circ>\<^bsub>r\<^esub>) x = (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub>)|\<^bsub>r\<^esub>"
          by (simp add: lookupEvalHeap)
        also have "\<dots> \<sqsubseteq> (\<N>\<lbrakk> e \<rbrakk>\<^bsub>ub\<^esub>)|\<^bsub>r\<^esub>"
          using \<open>\<rho> \<sqsubseteq> ub\<close> by (intro monofun_cfun_arg)
        also have "\<dots> = (\<N>\<lbrakk> e \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)|\<^bsub>r\<^esub>"
          unfolding ub_def..
        also have "\<dots> = \<bottom>"
          using r by (rule  C_restr_bot_demand[OF eq_imp_below])
        also have "\<dots> = (\<N>\<lbrace>delete x \<Gamma>\<rbrace>) x"
          by (simp add: lookup_HSem_other)
        finally
        show ?thesis unfolding True.
      next
        case False
        show ?thesis
        proof (cases "y \<in> domA \<Gamma>")
          case True
          have "(\<N>\<lbrakk> the (map_of \<Gamma> y) \<rbrakk>\<^bsub>\<rho>\<^esub>)|\<^bsub>r\<^esub> = (\<N>\<lbrakk> the (map_of \<Gamma> y) \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)|\<^bsub>r\<^esub>"
            by (rule C_restr_eq_lower[OF restr_can_restrict_env below_C])
          also have "\<dots> \<sqsubseteq> \<N>\<lbrakk> the (map_of \<Gamma> y) \<rbrakk>\<^bsub>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>"
            by (rule C_restr_below)
          also note \<open>\<rho>|\<^sup>\<circ>\<^bsub>r\<^esub> \<sqsubseteq> \<N>\<lbrace>delete x \<Gamma>\<rbrace>\<close>
          finally
          show ?thesis
            using \<open>y \<in> domA \<Gamma>\<close> \<open>y \<noteq> x\<close>
            by (simp add: lookupEvalHeap lookup_HSem_heap)
        next
          case False
          thus ?thesis by simp
        qed
      qed
    qed

    from \<open>\<rho> \<sqsubseteq> ub\<close>
    have "(\<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>) \<sqsubseteq> (\<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>ub\<^esub>)"
      by (rule cont2monofunE[rotated]) simp
    also have "\<dots> = ub"
      unfolding ub_def HSem_bot_eq[symmetric]..
    finally
    show "(\<^bold>\<N>\<lbrakk> \<Gamma> \<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub>) \<sqsubseteq> ub".
  qed simp_all

  from assms(2)
  have "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>(C\<cdot>r) \<noteq> \<bottom>"
    unfolding r
    by (rule demand_suffices[OF infinite_resources_suffice])
  also
  have "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>(C\<cdot>r) = (\<N>\<lbrakk>e\<rbrakk>\<^bsub>(\<N>\<lbrace>\<Gamma>\<rbrace>)|\<^sup>\<circ>\<^bsub>r\<^esub>\<^esub>)\<cdot>(C\<cdot>r)"
    by (rule can_restrict_env)
  also
  have "\<dots> \<sqsubseteq> (\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<^esub>)\<cdot>(C\<cdot>r)"
    by (intro monofun_cfun_arg monofun_cfun_fun heaps )
  also
  have "\<dots> \<sqsubseteq> (\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<^esub>)\<cdot>r'"
    using \<open>C\<cdot>r \<sqsubseteq> r'\<close> by (rule monofun_cfun_arg)
  finally
  show ?thesis by this (intro cont2cont)+
qed

text \<open>
The semantics is continuous, so we can apply induction here:
\<close>

lemma resourced_adequacy:
  assumes "(\<N>\<lbrakk>e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>"
  shows "\<exists> \<Delta> v. \<Gamma> : e \<Down>\<^bsub>S\<^esub> \<Delta> : v"
using assms
proof(induction r arbitrary: \<Gamma> e S rule: C.induct[case_names adm bot step])
  case adm show ?case by simp
next
  case bot
  hence False by auto
  thus ?case..
next
  case (step r)
  show ?case
  proof(cases e rule:exp_strong_exhaust(1)[where c = "(\<Gamma>,S)", case_names Var App Let Lam Bool IfThenElse])
  case (Var x)
    let ?e = "the (map_of \<Gamma> x)"
    from step.prems[unfolded Var]
    have "x \<in> domA \<Gamma>"
      by (auto intro: ccontr simp add: lookup_HSem_other)
    hence "map_of \<Gamma> x = Some ?e" by (rule domA_map_of_Some_the)
    moreover
    from step.prems[unfolded Var] \<open>map_of \<Gamma> x = Some ?e\<close> \<open>x \<in> domA \<Gamma>\<close>
    have "(\<N>\<lbrakk>?e\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>" by (auto simp add: lookup_HSem_heap  simp del: app_strict)
    hence "(\<N>\<lbrakk>?e\<rbrakk>\<^bsub>\<N>\<lbrace>delete x \<Gamma>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>" by (rule add_BH[OF \<open>map_of \<Gamma> x = Some ?e\<close>])
    from step.IH[OF this]
    obtain \<Delta> v where "delete x \<Gamma> : ?e \<Down>\<^bsub>x # S\<^esub> \<Delta> : v" by blast
    ultimately
    have "\<Gamma> : (Var x) \<Down>\<^bsub>S\<^esub> (x,v) #  \<Delta> : v" by (rule Variable)
    thus ?thesis using Var by auto
  next
  case (App e' x)
    have "finite (set S \<union> fv (\<Gamma>, e'))" by simp
    from finite_list[OF this]
    obtain S' where S': "set S' = set S \<union> fv (\<Gamma>, e')"..

    from step.prems[unfolded App]
    have prem: "((\<N>\<lbrakk> e' \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r \<down>CFn (\<N>\<lbrace>\<Gamma>\<rbrace>) x|\<^bsub>r\<^esub>)\<cdot>r \<noteq> \<bottom>" by (auto simp del: app_strict)
    hence "(\<N>\<lbrakk>e'\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>" by auto
    from step.IH[OF this]
    obtain \<Delta> v where lhs': "\<Gamma> : e' \<Down>\<^bsub>S'\<^esub> \<Delta> : v" by blast

    have "fv (\<Gamma>, e') \<subseteq> set S'" using S' by auto
    from correctness_empty_env[OF lhs' this]
    have correct1: "\<N>\<lbrakk>e'\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<sqsubseteq> \<N>\<lbrakk>v\<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>" and "\<N>\<lbrace>\<Gamma>\<rbrace> \<sqsubseteq> \<N>\<lbrace>\<Delta>\<rbrace>" by auto

    from prem
    have "((\<N>\<lbrakk> v \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>)\<cdot>r \<down>CFn (\<N>\<lbrace>\<Gamma>\<rbrace>) x|\<^bsub>r\<^esub>)\<cdot>r \<noteq> \<bottom>"
      by (rule not_bot_below_trans)(intro correct1 monofun_cfun_fun  monofun_cfun_arg)
    with result_evaluated[OF lhs']
    have "isLam v" by (cases r, auto, cases v rule: isVal.cases, auto)
    then obtain y e'' where n': "v = (Lam [y]. e'')" by (rule isLam_obtain_fresh)
    with lhs'
    have lhs: "\<Gamma> : e' \<Down>\<^bsub>S'\<^esub> \<Delta> : Lam [y]. e''" by simp

    have "((\<N>\<lbrakk> v \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>)\<cdot>r \<down>CFn (\<N>\<lbrace>\<Gamma>\<rbrace>) x|\<^bsub>r\<^esub>)\<cdot>r \<noteq> \<bottom>" by fact
    also have "(\<N>\<lbrace>\<Gamma>\<rbrace>) x|\<^bsub>r\<^esub> \<sqsubseteq> (\<N>\<lbrace>\<Gamma>\<rbrace>) x" by (rule C_restr_below)
    also note \<open>v = _\<close>
    also note \<open>(\<N>\<lbrace>\<Gamma>\<rbrace>) \<sqsubseteq> (\<N>\<lbrace>\<Delta>\<rbrace>)\<close>
    also have "(\<N>\<lbrakk> Lam [y]. e'' \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>)\<cdot>r \<sqsubseteq> CFn\<cdot>(\<Lambda> v. \<N>\<lbrakk>e''\<rbrakk>\<^bsub>(\<N>\<lbrace>\<Delta>\<rbrace>)(y := v)\<^esub>)"
      by (rule CELam_no_restr)
    also have "(\<dots> \<down>CFn (\<N>\<lbrace>\<Delta>\<rbrace>) x)\<cdot>r = (\<N>\<lbrakk>e''\<rbrakk>\<^bsub>(\<N>\<lbrace>\<Delta>\<rbrace>)(y := ((\<N>\<lbrace>\<Delta>\<rbrace>) x))\<^esub>)\<cdot>r" by simp
    also have "\<dots> = (\<N>\<lbrakk>e''[y::=x]\<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>)\<cdot>r"
      unfolding ESem_subst..
    finally
    have "\<dots> \<noteq> \<bottom>" by this (intro cont2cont cont_fun)+
    then
    obtain \<Theta> v' where rhs: "\<Delta> : e''[y::=x] \<Down>\<^bsub>S'\<^esub> \<Theta> : v'" using step.IH by blast

    have "\<Gamma> : App e' x \<Down>\<^bsub>S'\<^esub> \<Theta> : v'"
      by (rule reds_ApplicationI[OF lhs rhs])
    hence "\<Gamma> : App e' x \<Down>\<^bsub>S\<^esub> \<Theta> : v'"
      apply (rule reds_smaller_L) using S' by auto
    thus ?thesis using App by auto
  next
  case (Lam v e')
    have "\<Gamma> : Lam [v]. e' \<Down>\<^bsub>S\<^esub> \<Gamma> : Lam [v]. e'" ..
    thus ?thesis using Lam by blast
  next
  case (Bool b)
    have "\<Gamma> : Bool b \<Down>\<^bsub>S\<^esub> \<Gamma> : Bool b" by rule
    thus ?thesis using Bool by blast
  next
  case (IfThenElse scrut e\<^sub>1 e\<^sub>2)

    from step.prems[unfolded IfThenElse]
    have prem: "CB_project\<cdot>((\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>1 \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r)\<cdot>((\<N>\<lbrakk> e\<^sub>2 \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r) \<noteq> \<bottom>" by (auto simp del: app_strict)
    then obtain b where
      is_CB: "(\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r = CB\<cdot>(Discr b)"
      and not_bot2: "((\<N>\<lbrakk> (if b then e\<^sub>1 else e\<^sub>2) \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r) \<noteq> \<bottom>"
    unfolding CB_project_not_bot by (auto split: if_splits)

    have "finite (set S \<union> fv (\<Gamma>, scrut))" by simp
    from finite_list[OF this]
    obtain S' where S': "set S' = set S \<union> fv (\<Gamma>, scrut)"..

    from is_CB have "(\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>" by simp
    from step.IH[OF this]
    obtain \<Delta> v where lhs': "\<Gamma> : scrut \<Down>\<^bsub>S'\<^esub> \<Delta> : v" by blast
    then have "isVal v" by (rule result_evaluated)

    have "fv (\<Gamma>, scrut) \<subseteq> set S'" using S' by simp
    from correctness_empty_env[OF lhs' this]
    have correct1: "\<N>\<lbrakk>scrut\<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub> \<sqsubseteq> \<N>\<lbrakk>v\<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>" and correct2: "\<N>\<lbrace>\<Gamma>\<rbrace> \<sqsubseteq> \<N>\<lbrace>\<Delta>\<rbrace>" by auto

    from correct1
    have "(\<N>\<lbrakk> scrut \<rbrakk>\<^bsub>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r \<sqsubseteq> (\<N>\<lbrakk> v \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>)\<cdot>r" by (rule monofun_cfun_fun)
    with is_CB
    have "(\<N>\<lbrakk> v \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>)\<cdot>r = CB\<cdot>(Discr b)" by simp
    with \<open>isVal v\<close>
    have "v = Bool b" by (cases v rule: isVal.cases) (case_tac r, auto)+

    from not_bot2 \<open>\<N>\<lbrace>\<Gamma>\<rbrace> \<sqsubseteq> \<N>\<lbrace>\<Delta>\<rbrace>\<close>
    have "(\<N>\<lbrakk> (if b then e\<^sub>1 else e\<^sub>2) \<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>"
      by (rule not_bot_below_trans[OF _ monofun_cfun_fun[OF monofun_cfun_arg]])
    from step.IH[OF this]
    obtain \<Theta> v' where rhs: "\<Delta> : (if b then e\<^sub>1 else e\<^sub>2) \<Down>\<^bsub>S'\<^esub> \<Theta> : v'" by blast

    from lhs'[unfolded \<open>v = _\<close>] rhs
    have "\<Gamma> : (scrut ? e\<^sub>1 : e\<^sub>2) \<Down>\<^bsub>S'\<^esub> \<Theta> : v'" by rule
    hence "\<Gamma> : (scrut ? e\<^sub>1 : e\<^sub>2) \<Down>\<^bsub>S\<^esub> \<Theta> : v'"
      apply (rule reds_smaller_L) using S' by auto
    thus ?thesis unfolding IfThenElse by blast
  next
  case (Let \<Delta> e')
    from step.prems[unfolded Let(2)]
    have prem: "(\<N>\<lbrakk>e'\<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta>\<rbrace>\<N>\<lbrace>\<Gamma>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>"
      by (simp  del: app_strict)
    also
      have "atom ` domA \<Delta> \<sharp>* \<Gamma>" using Let(1) by (simp add: fresh_star_Pair)
      hence "\<N>\<lbrace>\<Delta>\<rbrace>\<N>\<lbrace>\<Gamma>\<rbrace> = \<N>\<lbrace>\<Delta> @ \<Gamma>\<rbrace>" by (rule HSem_merge)
    finally
    have "(\<N>\<lbrakk>e'\<rbrakk>\<^bsub>\<N>\<lbrace>\<Delta> @ \<Gamma>\<rbrace>\<^esub>)\<cdot>r \<noteq> \<bottom>".
    then
    obtain \<Theta> v where "\<Delta> @ \<Gamma> : e' \<Down>\<^bsub>S\<^esub> \<Theta> : v" using step.IH by blast
    hence "\<Gamma> : Let \<Delta> e' \<Down>\<^bsub>S\<^esub> \<Theta> : v"
      by (rule reds.Let[OF Let(1)])
    thus ?thesis using Let by auto
  qed
qed

end


(*****************************************************************************
 * Copyright (c) 2005-2010 ETH Zurich, Switzerland
 *               2008-2015 Achim D. Brucker, Germany
 *               2009-2016 Université Paris-Sud, France
 *               2015-2016 The University of Sheffield, UK
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *****************************************************************************)

subsection \<open>Elementary Firewall Policy Transformation Rules\<close>
theory
  ElementaryRules
  imports
    FWNormalisationCore
begin

text\<open>
  This theory contains those elementary transformation rules which are presented in the ICST
  2010 paper~\cite{brucker.ea:firewall:2010}. They are not used elsewhere.
\<close>

lemma elem1:
  "C (AllowPortFromTo x y p \<oplus> DenyAllFromTo x y) = C (DenyAllFromTo x y)"
  by (rule ext, auto simp: PLemmas)

lemma elem2:
  "C ((a \<oplus> b) \<oplus> c) = C (a \<oplus> (b \<oplus> c))"
  by (simp add: C.simps)

lemma elem3:
  "C (AllowPortFromTo x y a \<oplus> AllowPortFromTo x y b) =
  C (AllowPortFromTo x y b \<oplus> AllowPortFromTo x y a)"
  by (rule ext, auto simp: PLemmas)

lemma elem4:
  "C (a \<oplus> DenyAll) = C DenyAll"
  by (rule ext, auto simp: PLemmas)

lemma elem5:
  "C (DenyAllFromTo x y \<oplus> DenyAllFromTo u v) = C (DenyAllFromTo u v \<oplus> DenyAllFromTo x y)"
  by (rule ext, auto simp: PLemmas)

lemma elem6:
  "dom (C a) \<inter> dom (C b) = {} \<Longrightarrow> C (a \<oplus> b) = C (b \<oplus> a)"
  by (rule ext, metis C.simps(4) map_add_comm)

end


(*  Title:      JinjaThreads/Execute/JVMExec_Execute.thy
    Author:     Andreas Lochbihler
*)

theory JVMExec_Execute
imports
  "../JVM/JVMExec"
  ExternalCall_Execute
begin

subsection {* Manual translation of the JVM to use sets instead of predicates *}

locale JVM_heap_execute = heap_execute +
  constrains addr2thread_id :: "('addr :: addr) \<Rightarrow> 'thread_id"
  and thread_id2addr :: "'thread_id \<Rightarrow> 'addr"
  and spurious_wakeups :: bool
  and empty_heap :: "'heap"
  and allocate :: "'heap \<Rightarrow> htype \<Rightarrow> ('heap \<times> 'addr) set"
  and typeof_addr :: "'heap \<Rightarrow> 'addr \<Rightarrow> htype option"
  and heap_read :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val set"
  and heap_write :: "'heap \<Rightarrow> 'addr \<Rightarrow> addr_loc \<Rightarrow> 'addr val \<Rightarrow> 'heap set"

sublocale JVM_heap_execute < execute!: JVM_heap_base
  addr2thread_id thread_id2addr
  spurious_wakeups
  empty_heap allocate typeof_addr
  "\<lambda>h a ad v. v \<in> heap_read h a ad" "\<lambda>h a ad v h'. h' \<in> heap_write h a ad v"
.

context JVM_heap_execute begin

definition exec_instr ::
  "'addr instr \<Rightarrow> 'addr jvm_prog \<Rightarrow> 'thread_id \<Rightarrow> 'heap \<Rightarrow> 'addr val list \<Rightarrow> 'addr val list
  \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> pc \<Rightarrow> 'addr frame list
  \<Rightarrow> (('addr, 'thread_id, 'heap) jvm_thread_action \<times> ('addr, 'heap) jvm_state) set"
where [simp]: "exec_instr = execute.exec_instr"

lemma exec_instr_code [code]:
  "exec_instr (Load n) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   {(\<epsilon>, (None, h, ((loc ! n) # stk, loc, C\<^sub>0, M\<^sub>0, pc+1)#frs))}"
  "exec_instr (Store n) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   {(\<epsilon>, (None, h, (tl stk, loc[n:=hd stk], C\<^sub>0, M\<^sub>0, pc+1)#frs))}"
  "exec_instr (Push v) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   {(\<epsilon>, (None, h, (v # stk, loc, C\<^sub>0, M\<^sub>0, pc+1)#frs))}"
  "exec_instr (New C) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   (let HA = allocate h (Class_type C) in
    if HA = {} then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt OutOfMemory\<rfloor>, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc) # frs)}
    else do { (h', a) \<leftarrow> HA; {(\<lbrace>NewHeapElem a (Class_type C)\<rbrace>, None, h', (Addr a # stk, loc, C\<^sub>0, M\<^sub>0, pc + 1)#frs)} })"
  "exec_instr (NewArray T) P t h stk loc C0 M0 pc frs =
   (let si = the_Intg (hd stk);
        i = nat (sint si)
    in if si <s 0
       then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NegativeArraySize\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)}
       else let HA = allocate h (Array_type T i) in
         if HA = {} then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt OutOfMemory\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)}
         else do { (h', a) \<leftarrow> HA; {(\<lbrace>NewHeapElem a (Array_type T i)\<rbrace>, None, h', (Addr a # tl stk, loc, C0, M0, pc + 1) # frs)}})"
  "exec_instr ALoad P t h stk loc C0 M0 pc frs =
   (let va = hd (tl stk)
    in (if va = Null then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)}
        else
          let i = the_Intg (hd stk);
              a = the_Addr va;
              len = alen_of_htype (the (typeof_addr h a))
          in if i <s 0 \<or> int len \<le> sint i then
               {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt ArrayIndexOutOfBounds\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)}
             else do {
                 v \<leftarrow> heap_read h a (ACell (nat (sint i)));
                 {(\<lbrace>ReadMem a (ACell (nat (sint i))) v\<rbrace>, None, h, (v # tl (tl stk), loc, C0, M0, pc + 1) # frs)}
               }))"
  "exec_instr AStore P t h stk loc C0 M0 pc frs =
  (let ve = hd stk;
       vi = hd (tl stk);
       va = hd (tl (tl stk))
   in (if va = Null then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)}
       else (let i = the_Intg vi;
                 idx = nat (sint i);
                 a = the_Addr va;
                 hT = the (typeof_addr h a);
                 T = ty_of_htype hT;
                 len = alen_of_htype hT;
                 U = the (execute.typeof_h h ve)
             in (if i <s 0 \<or> int len \<le> sint i then
                      {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt ArrayIndexOutOfBounds\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)}
                 else if P \<turnstile> U \<le> the_Array T then
                      do {
                         h' \<leftarrow> heap_write h a (ACell idx) ve;
                         {(\<lbrace>WriteMem a (ACell idx) ve\<rbrace>, None, h', (tl (tl (tl stk)), loc, C0, M0, pc+1) # frs)}
                      }
                 else {(\<epsilon>, (\<lfloor>execute.addr_of_sys_xcpt ArrayStore\<rfloor>, h, (stk, loc, C0, M0, pc) # frs))}))))"
  "exec_instr ALength P t h stk loc C0 M0 pc frs =
   {(\<epsilon>, (let va = hd stk
         in if va = Null
            then (\<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)
            else (None, h, (Intg (word_of_int (int (alen_of_htype (the (typeof_addr h (the_Addr va)))))) # tl stk, loc, C0, M0, pc+1) # frs)))}"
  "exec_instr (Getfield F C) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   (let v = hd stk
    in if v = Null then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc) # frs)}
       else let a = the_Addr v
            in do {
               v' \<leftarrow> heap_read h a (CField C F);
               {(\<lbrace>ReadMem a (CField C F) v'\<rbrace>, None, h, (v' # (tl stk), loc, C\<^sub>0, M\<^sub>0, pc + 1) # frs)}
            })"
  "exec_instr (Putfield F C) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
  (let v = hd stk;
       r = hd (tl stk)
   in if r = Null then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc) # frs)}
      else let a = the_Addr r
           in do {
                h' \<leftarrow> heap_write h a (CField C F) v;
                {(\<lbrace>WriteMem a (CField C F) v\<rbrace>, None, h', (tl (tl stk), loc, C\<^sub>0, M\<^sub>0, pc + 1) # frs)}
              })"
 "exec_instr (Checkcast T) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
  {(\<epsilon>, let U = the (typeof\<^bsub>h\<^esub> (hd stk))
       in if P \<turnstile> U \<le> T then (None, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc + 1) # frs)
          else (\<lfloor>execute.addr_of_sys_xcpt ClassCast\<rfloor>, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc) # frs))}"
  "exec_instr (Instanceof T) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   {(\<epsilon>, None, h, (Bool (hd stk \<noteq> Null \<and> P \<turnstile> the (typeof\<^bsub>h\<^esub> (hd stk)) \<le> T) # tl stk, loc, C\<^sub>0, M\<^sub>0, pc + 1) # frs)}"
  "exec_instr (Invoke M n) P t h stk loc C0 M0 pc frs =
   (let r = stk ! n
    in (if r = Null then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C0, M0, pc) # frs)}
        else (let ps = rev (take n stk);
                  a = the_Addr r;
                  T = the (typeof_addr h a);
                  (D,M',Ts,meth)= method P (class_type_of T) M
         in case meth of
               Native \<Rightarrow>
                      do {
                        (ta, va, h') \<leftarrow> red_external_aggr P t a M ps h;
                        {(extTA2JVM P ta, extRet2JVM n h' stk loc C0 M0 pc frs va)}
                      }
            | \<lfloor>(mxs,mxl\<^sub>0,ins,xt)\<rfloor> \<Rightarrow>
              let f' = ([],[r]@ps@(replicate mxl\<^sub>0 undefined_value),D,M,0)
              in {(\<epsilon>, None, h, f' # (stk, loc, C0, M0, pc) # frs)})))"
  "exec_instr Return P t h stk\<^sub>0 loc\<^sub>0 C\<^sub>0 M\<^sub>0 pc frs =
   {(\<epsilon>, (if frs=[] then (None, h, [])
         else
           let v = hd stk\<^sub>0;
               (stk,loc,C,m,pc) = hd frs;
                n = length (fst (snd (method P C\<^sub>0 M\<^sub>0)))
           in (None, h, (v#(drop (n+1) stk),loc,C,m,pc+1)#tl frs)))}"
  "exec_instr Pop P t h stk loc C\<^sub>0 M\<^sub>0 pc frs = {(\<epsilon>, (None, h, (tl stk, loc, C\<^sub>0, M\<^sub>0, pc+1)#frs))}"
  "exec_instr Dup P t h stk loc C\<^sub>0 M\<^sub>0 pc frs = {(\<epsilon>, (None, h, (hd stk # stk, loc, C\<^sub>0, M\<^sub>0, pc+1)#frs))}"
  "exec_instr Swap P t h stk loc C\<^sub>0 M\<^sub>0 pc frs = {(\<epsilon>, (None, h, (hd (tl stk) # hd stk # tl (tl stk), loc, C\<^sub>0, M\<^sub>0, pc+1)#frs))}"
  "exec_instr (BinOpInstr bop) P t h stk loc C0 M0 pc frs =
   {(\<epsilon>,
     case the (execute.binop bop (hd (tl stk)) (hd stk)) of
       Inl v \<Rightarrow> (None, h, (v # tl (tl stk), loc, C0, M0, pc + 1) # frs)
     | Inr a \<Rightarrow> (Some a, h, (stk, loc, C0, M0, pc) # frs))}"
  "exec_instr (IfFalse i) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   {(\<epsilon>, (let pc' = if hd stk = Bool False then nat(int pc+i) else pc+1
         in (None, h, (tl stk, loc, C\<^sub>0, M\<^sub>0, pc')#frs)))}"
  "exec_instr (Goto i) P t h stk loc C\<^sub>0 M\<^sub>0 pc frs = {(\<epsilon>, (None, h, (stk, loc, C\<^sub>0, M\<^sub>0, nat(int pc+i))#frs))}"
  "exec_instr ThrowExc P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   {(\<epsilon>, (let xp' = if hd stk = Null then \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor> else \<lfloor>the_Addr(hd stk)\<rfloor>
         in (xp', h, (stk, loc, C\<^sub>0, M\<^sub>0, pc)#frs)))}"
  "exec_instr MEnter P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   {(let v = hd stk
     in if v = Null
        then (\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc) # frs)
        else (\<lbrace>Lock\<rightarrow>the_Addr v, SyncLock (the_Addr v)\<rbrace>, None, h, (tl stk, loc, C\<^sub>0, M\<^sub>0, pc + 1) # frs))}"
  "exec_instr MExit P t h stk loc C\<^sub>0 M\<^sub>0 pc frs =
   (let v = hd stk
    in if v = Null
       then {(\<epsilon>, \<lfloor>execute.addr_of_sys_xcpt NullPointer\<rfloor>, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc) # frs)}
       else {(\<lbrace>Unlock\<rightarrow>the_Addr v, SyncUnlock (the_Addr v)\<rbrace>, None, h, (tl stk, loc, C\<^sub>0, M\<^sub>0, pc + 1) # frs),
             (\<lbrace>UnlockFail\<rightarrow>the_Addr v\<rbrace>, \<lfloor>execute.addr_of_sys_xcpt IllegalMonitorState\<rfloor>, h, (stk, loc, C\<^sub>0, M\<^sub>0, pc) # frs)})"
by(auto 4 4 intro: rev_bexI)

definition exec :: "'addr jvm_prog \<Rightarrow> 'thread_id \<Rightarrow> ('addr, 'heap) jvm_state \<Rightarrow> ('addr, 'thread_id, 'heap) jvm_ta_state set"
where "exec = execute.exec"

lemma exec_code:
  "exec P t (xcp, h, []) = {}"
  "exec P t (None, h, (stk, loc, C, M, pc) # frs) = exec_instr (instrs_of P C M ! pc) P t h stk loc C M pc frs"
  "exec P t (\<lfloor>a\<rfloor>, h, fr # frs) = {(\<epsilon>, execute.exception_step P a h fr frs)}"
by(simp_all add: exec_def)

definition exec_1 ::
  "'addr jvm_prog \<Rightarrow> 'thread_id \<Rightarrow> ('addr, 'heap) jvm_state
   \<Rightarrow> (('addr, 'thread_id, 'heap) jvm_thread_action \<times> ('addr, 'heap) jvm_state) Predicate.pred"
where "exec_1 P t \<sigma> = pred_of_set (exec P t \<sigma>)"

lemma exec_1I: "execute.exec_1 P t \<sigma> ta \<sigma>' \<Longrightarrow> Predicate.eval (exec_1 P t \<sigma>) (ta, \<sigma>')"
by(erule execute.exec_1.cases)(simp add: exec_1_def exec_def)

lemma exec_1E:
  assumes "Predicate.eval (exec_1 P t \<sigma>) (ta, \<sigma>')"
  obtains "execute.exec_1 P t \<sigma> ta \<sigma>'"
using assms
by(auto simp add: exec_1_def exec_def intro: execute.exec_1.intros)

lemma exec_1_eq [simp]:
  "Predicate.eval (exec_1 P t \<sigma>) (ta, \<sigma>') \<longleftrightarrow> execute.exec_1 P t \<sigma> ta \<sigma>'"
by(auto intro: exec_1I elim: exec_1E)

lemma exec_1_eq':
  "Predicate.eval (exec_1 P t \<sigma>) = (\<lambda>(ta, \<sigma>'). execute.exec_1 P t \<sigma> ta \<sigma>')"
by(rule ext)(simp split: prod.split)

end

lemmas [code] =
  JVM_heap_execute.exec_instr_code
  JVM_heap_base.exception_step.simps
  JVM_heap_execute.exec_code
  JVM_heap_execute.exec_1_def

end