theory HealthcareExample
imports Insider
begin

locale scenarioHealthcare =
fixes healthcare_actors :: "identity set"
defines healthcare_actors_def: "healthcare_actors \<equiv> {''Patient''}"

fixes hc_locations :: "location set"
defines hc_locations_def: "hc_locations \<equiv>
          {Location 0, Location 1, Location 2, Location 3}"

fixes sphone :: "location"
defines sphone_def: "sphone \<equiv> Location 0"
fixes room :: "location"
defines room_def: "room \<equiv> Location 1"
fixes bankapp :: "location"
defines bankapp_def: "bankapp \<equiv> Location 2"
fixes healthapp :: "location"
defines healthapp_def: "healthapp \<equiv> Location 3"

fixes global_policy :: "[infrastructure, identity] \<Rightarrow> bool"
defines global_policy_def: "global_policy I a \<equiv> a \<noteq> ''Patient''
                 \<longrightarrow> \<not>(enables I bankapp (Actor a) eval)"

fixes ex_creds :: "actor \<Rightarrow> (string set * string set)"
defines ex_creds_def: "ex_creds \<equiv> (\<lambda> x. if x = Actor ''Patient'' then
                         ({''PIN'',''skey''}, {}) else
                            (if x = Actor ''Carer'' then
                                ({''PIN''},{}) else ({},{})))"

fixes ex_creds' :: "actor \<Rightarrow> (string set * string set)"
defines ex_creds'_def: "ex_creds' \<equiv> (\<lambda> x. if x = Actor ''Patient'' then
                         ({''PIN'',''skey''}, {}) else
                            (if x = Actor ''Carer'' then
                                ({''PIN'',''skey''}, {}) else ({},{})))"

fixes ex_locs :: "location \<Rightarrow> string set"
defines "ex_locs \<equiv> (\<lambda> x.  {})"

fixes ex_graph :: "igraph"
defines ex_graph_def: "ex_graph \<equiv> Lgraph
     {(room, sphone), (sphone, healthapp), (sphone,bankapp)}
     (\<lambda> x. if x = room then {''Patient'', ''Carer''} else {})
     ex_creds ex_locs"

fixes ex_graph' :: "igraph"
defines ex_graph'_def: "ex_graph' \<equiv> Lgraph
     {(room, sphone), (sphone, healthapp), (sphone,bankapp)}
     (\<lambda> x. if x = room then {''Patient'', ''Carer''} else {})
     ex_creds' ex_locs"

fixes ex_graph'' :: "igraph"
defines ex_graph''_def: "ex_graph'' \<equiv> Lgraph
     {(room, sphone), (sphone, healthapp), (sphone,bankapp)}
     (\<lambda> x. if x = room then {''Patient''} else
           (if x = sphone then {''Carer''} else {}))
     ex_creds' ex_locs"

fixes ex_graph''' :: "igraph"
 defines ex_graph'''_def: "ex_graph''' \<equiv> Lgraph
     {(room, sphone), (sphone, healthapp), (sphone,bankapp)}
     (\<lambda> x. if x = room then {''Patient''} else
              (if x = bankapp then {''Carer''} else {}))
     ex_creds' ex_locs"

fixes local_policies :: "[igraph, location] \<Rightarrow> policy set"
defines local_policies_def: "local_policies G \<equiv>
    (\<lambda> x. if x = room then
        {(\<lambda> y. True, {put,get,move,eval})}
          else (if x = sphone then
             {((\<lambda> y. has G (y, ''PIN'')), {put,get,move,eval})}
                else (if x = healthapp then
                {((\<lambda> y. (\<exists> n. (n  @\<^bsub>G\<^esub> sphone) \<and> Actor n = y)), {put,get,move,eval})}
                       else (if x = bankapp then
                {((\<lambda> y. (\<exists> n. ((n  @\<^bsub>G\<^esub> sphone)\<or>(n  @\<^bsub>G\<^esub> bankapp )) \<and> Actor n = y \<and>
                           has G (y, ''skey''))), {put,get,move,eval})} else {}))))"

fixes hc_scenario :: "infrastructure"
defines hc_scenario_def:
"hc_scenario \<equiv> Infrastructure ex_graph local_policies"

fixes Ihc :: "infrastructure set"
defines Ihc_def:
  "Ihc \<equiv> {hc_scenario}"

(* other states of scenario *)

(* First step: Carer is in room with Patient and takes the skey *)
fixes hc_scenario' :: "infrastructure"
defines hc_scenario'_def:
"hc_scenario' \<equiv> Infrastructure ex_graph' local_policies"

fixes HC' :: "infrastructure set"
defines HC'_def:
  "HC' \<equiv> {hc_scenario'}"

(* Second step: Carer goes onto sphone and takes the money by eval on bankapp *)
fixes hc_scenario'' :: "infrastructure"
defines hc_scenario''_def:
"hc_scenario'' \<equiv> Infrastructure ex_graph'' local_policies"

fixes HC'' :: "infrastructure set"
defines HC''_def:
  "HC'' \<equiv> {hc_scenario''}"

(* Third step: Carer goes onto bankapp and can then get money *)
fixes hc_scenario''' :: "infrastructure"
defines hc_scenario'''_def:
"hc_scenario''' \<equiv> Infrastructure ex_graph''' local_policies"

fixes HC''' :: "infrastructure set"
defines HC'''_def:
  "HC''' \<equiv> {hc_scenario'''}"

fixes hc_states
defines hc_states_def: "hc_states \<equiv> { I. hc_scenario \<rightarrow>\<^sub>i* I }"

fixes hc_Kripke
defines "hc_Kripke \<equiv> Kripke hc_states {hc_scenario}"

fixes shc
defines "shc \<equiv> {x. \<not> (global_policy x ''Carer'')}"

begin

lemma step1: "hc_scenario  \<rightarrow>\<^sub>n hc_scenario'"
proof (rule_tac l = room and a' = "''Carer''" and a = "''Patient''" and z = "''skey''" in get, rule refl)
  show "''Patient'' @\<^bsub>graphI hc_scenario\<^esub> room"
    by (simp add: hc_scenario_def atI_def ex_graph_def)
next show "''Carer'' @\<^bsub>graphI hc_scenario\<^esub> room"
    by (simp add: hc_scenario_def atI_def ex_graph_def)
next show "has (graphI hc_scenario) (Actor ''Patient'', ''skey'')"
    by (simp add: ex_graph_def hc_scenario_def ex_creds_def has_def credentials_def)
next show "enables hc_scenario room (Actor ''Patient'') get"
    by (simp add: hc_scenario_def enables_def local_policies_def ex_creds_def)
next show "hc_scenario' =
        Infrastructure
                (Lgraph (gra (graphI hc_scenario)) (agra (graphI hc_scenario))
                ((cgra (graphI hc_scenario))
        (Actor ''Carer'' :=
           (insert ''skey'' (fst (cgra (graphI hc_scenario) (Actor ''Carer''))),
            snd (cgra (graphI hc_scenario) (Actor ''Carer'')))))
       (lgra (graphI hc_scenario)))
     (delta hc_scenario)"
    apply (simp add: hc_scenario'_def hc_scenario_def ex_creds'_def
         ex_graph'_def ex_graph_def ex_creds_def)
    apply (rule conjI)
    apply (rule impI)
    apply (rule ext)
    apply simp
    apply (rule impI)
    apply (rule equalityI)
    apply simp+
    apply (rule impI)
    apply (rule ext)
    apply simp
    apply (rule impI)+
    apply (rule equalityI)
    by simp+
qed

lemma step1r: "hc_scenario \<rightarrow>\<^sub>n*  hc_scenario'"
proof (simp add: state_transition_in_refl_def, insert step1, auto)
qed

lemma step2r: "hc_scenario'  \<rightarrow>\<^sub>n* hc_scenario''"
proof (simp add: state_transition_in_refl_def, insert step2, auto)
qed

lemma step3: "hc_scenario''  \<rightarrow>\<^sub>n hc_scenario'''"
proof (rule_tac l = sphone and a = "''Carer''" and l' = bankapp in move, rule refl)
  show "''Carer'' @\<^bsub>graphI hc_scenario''\<^esub> sphone"
    by (simp add: hc_scenario''_def atI_def nodes_def ex_graph'_def room_def sphone_def
               ex_graph''_def bankapp_def healthapp_def)
next show "sphone \<in> nodes (graphI hc_scenario'')"
    by (simp add: hc_scenario''_def atI_def nodes_def ex_graph'_def room_def sphone_def
               ex_graph''_def bankapp_def healthapp_def, blast)
next show "bankapp \<in> nodes (graphI hc_scenario'')"
    by (simp add: hc_scenario''_def actors_graph_def ex_graph'_def
                ex_graph''_def nodes_def sphone_def room_def healthapp_def bankapp_def)
next show "''Carer'' \<in> actors_graph (graphI hc_scenario'')"
    by (simp add: hc_scenario''_def actors_graph_def ex_graph'_def
                ex_graph''_def nodes_def sphone_def room_def healthapp_def bankapp_def, blast)
next show "enables hc_scenario'' bankapp (Actor ''Carer'') move"
    by (simp add: hc_scenario''_def enables_def local_policies_def ex_creds'_def
                  bankapp_def healthapp_def sphone_def room_def
                  atI_def ex_locs_def ex_graph'_def ex_graph''_def has_def
                  credentials_def)
next show "hc_scenario''' =
    Infrastructure (move_graph_a ''Carer'' sphone bankapp (graphI hc_scenario'')) (delta hc_scenario'')"
     apply (simp add: hc_scenario''_def hc_scenario'''_def ex_creds'_def ex_creds_def
                   ex_graph'_def move_graph_a_def ex_graph''_def sphone_def
                   room_def bankapp_def has_def credentials_def ex_graph'''_def
          )
     apply (rule ext)
     by (simp add: sphone_def bankapp_def)
qed

lemma step3r: "hc_scenario''  \<rightarrow>\<^sub>n* hc_scenario'''"
proof (simp add: state_transition_in_refl_def, insert step3, auto)
qed

lemma stepr: "hc_scenario   \<rightarrow>\<^sub>n* hc_scenario'''"
proof(insert step1r step2r step3r, simp add: state_transition_in_refl_def)
qed

(* The following attacks can be shown without using the
   strong impersonation property of Insider *)

lemma in_danger: "\<not> (global_policy hc_scenario''' ''Carer'')"
proof (unfold global_policy_def, simp)
  show "enables hc_scenario''' bankapp (Actor ''Carer'') eval"
    by (simp add: hc_scenario'''_def
                  ex_graph''_def ex_graph'''_def ex_locs_def ex_creds'_def
                  atI_def local_policies_def enables_def
                  bankapp_def healthapp_def sphone_def room_def has_def credentials_def)
qed

lemma att_hc: "\<turnstile>[\<N>\<^bsub>(Ihc,HC')\<^esub>, \<N>\<^bsub>(HC',HC'')\<^esub>, \<N>\<^bsub>(HC'',shc)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Ihc,shc)\<^esup>"
proof (subst att_and, simp, rule conjI)
  show "\<turnstile>\<N>\<^bsub>(Ihc, HC')\<^esub>"
    apply (simp add: Ihc_def HC'_def att_base)
    apply (subst state_transition_infra_def)
    by (rule step1)
next show " \<turnstile>[\<N>\<^bsub>(HC', HC'')\<^esub>, \<N>\<^bsub>(HC'', shc)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(HC', shc)\<^esup>"
   apply (subst att_and, simp)
  proof (rule conjI)
    show " \<turnstile>\<N>\<^bsub>(HC', HC'')\<^esub>"
     apply (simp add: Ihc_def HC'_def HC''_def att_base)
     apply (subst state_transition_infra_def)
     by (rule step2)
  next show " \<turnstile>[\<N>\<^bsub>(HC'', shc)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(HC'', shc)\<^esup>"
     apply (simp add: Ihc_def HC'_def HC''_def  att_base)
     apply (subst att_and, simp add: att_base)
     apply (rule_tac x = "hc_scenario'''" in bexI)
     apply (subst state_transition_infra_def)
     apply (rule step3)
     apply (simp add: shc_def)
     by (rule in_danger)
  qed
qed

theorem hc_EF: "hc_Kripke \<turnstile> EF shc"
proof -
  have a: "\<turnstile>[\<N>\<^bsub>(Ihc, HC')\<^esub>, \<N>\<^bsub>(HC', HC'')\<^esub>, \<N>\<^bsub>(HC'', shc)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Ihc, shc)\<^esup>" by (rule att_hc)
  have b: "(Ihc, shc) = attack ([\<N>\<^bsub>(Ihc,HC')\<^esub>, \<N>\<^bsub>(HC',HC'')\<^esub>, \<N>\<^bsub>(HC'',shc)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(Ihc,shc)\<^esup>)"
    by simp
  have "Kripke {s::infrastructure. \<exists>i::infrastructure\<in>Ihc. i \<rightarrow>\<^sub>i* s} Ihc \<turnstile> EF shc "
    apply (rule AT_EF)
     apply (rule a)
    by simp
  thus "hc_Kripke \<turnstile> EF shc"
    by  (simp add: hc_Kripke_def hc_states_def Ihc_def)
qed

end


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

header{*The n_g2kAbsAfter Protocol Case Study*}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


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

section {* A Defensive JVM *}

theory JVMDefensive
imports JVMExec
begin

text {*
  Extend the state space by one element indicating a type error (or
  other abnormal termination) *}
datatype 'a type_error = TypeError | Normal 'a

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


(*  Title:      HOL/Auth/n_german_lemma_inv__23_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__23_on_rules imports n_german_lemma_on_inv__23
begin
section{*All lemmas on causal relation between inv__23*}
lemma lemma_inv__23_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__23  p__Inv3 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) 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__23) done
    }

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

end


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

theory n_germanSimp_lemma_inv__16_on_rules imports n_germanSimp_lemma_on_inv__16
begin
section{*All lemmas on causal relation between inv__16*}
lemma lemma_inv__16_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv3 p__Inv4. p__Inv3\<le>N\<and>p__Inv4\<le>N\<and>p__Inv3~=p__Inv4\<and>f=inv__16  p__Inv3 p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  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)"
  apply (cut_tac b1, auto) 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__16) done
    }

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

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

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

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

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__16) 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__16) 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__16) 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__16) 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__16) 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__16) 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__16) done
    }

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

end


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

theory n_germanSymIndex_lemma_inv__20_on_rules imports n_germanSymIndex_lemma_on_inv__20
begin
section{*All lemmas on causal relation between inv__20*}
lemma lemma_inv__20_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__20  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  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)"
  apply (cut_tac b1, auto) 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__20) done
    }

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

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

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

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

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

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

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__20) 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__20) 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__20) 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__20) 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__20) 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__20) 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__20) done
    }

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

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Generator_CAMKES_CDL imports
  "../adl-spec/Types_CAMKES"
  "../adl-spec/Library_CAMKES"
  "../../spec/capDL/Syscall_D"
  Types_CAMKES_CDL
  "../../proof/access-control/Dpolicy"
begin

text {*
  This theory is a work in progress on specifying the CapDL-producing logic of the CAmkES code
  generator as an Isabelle function.
*}

text {*
  Merge two CapDL states to form a single one. Note that, in the case of conflicts, the second takes
  precedence.
*}
definition
  merge_cdl :: "cdl_state \<Rightarrow> cdl_state \<Rightarrow> cdl_state"
where
  "merge_cdl a b \<equiv> b\<lparr>
     cdl_objects := cdl_objects b ++ cdl_objects a,
     cdl_cdt := cdl_cdt b ++ cdl_cdt a,
     cdl_asid_table := cdl_asid_table b ++ cdl_asid_table a\<rparr>"

lemma map_add_id[simp]: "x ++ x = x"
  by (metis map_add_le_mapI map_le_antisym map_le_map_add map_le_refl)

lemma map_add_subsume: "dom x \<subseteq> dom y \<Longrightarrow> x ++ y = y"
  by (metis dom_map_add map_le_antisym map_le_def map_le_map_add sup.orderE)

lemma merge_id: "merge_cdl x x = x"
  by (clarsimp simp:merge_cdl_def)

definition merge_objs :: "cdl_state \<Rightarrow> cdl_heap \<Rightarrow> cdl_state"
  where "merge_objs a b \<equiv> merge_cdl a (a\<lparr>cdl_objects := b\<rparr>)"

(* convenience *)
definition sum :: "nat list \<Rightarrow> nat"
  where "sum xs \<equiv> fold (\<lambda>a b. a + b) xs 0"

(* convenience *)
definition enumerate' :: "word32 \<Rightarrow> 'a list \<Rightarrow> (word32 \<times> 'a) list"
  where "enumerate' start xs = map (\<lambda>(a, b). (of_nat a, b)) (enumerate (unat start) xs)"

definition
  lop :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "lop n xs \<equiv> take (length xs - n) xs"

abbreviation behead
  where "behead s pref \<equiv> drop (length pref) s"

abbreviation trunc
  where "trunc s suf \<equiv> lop (length suf) s"

(* Cap rights *)
abbreviation "G \<equiv> {AllowGrant}"
abbreviation "R \<equiv> {AllowRead}"
abbreviation "RG \<equiv> {AllowRead, AllowGrant}"
abbreviation "RW \<equiv> {AllowRead, AllowWrite}"
abbreviation "RWG \<equiv> {AllowRead, AllowWrite, AllowGrant}"
abbreviation "W \<equiv> {AllowWrite}"
abbreviation "WG \<equiv> {AllowWrite, AllowGrant}"

text {*
  A type for representing extra information relating to hardware interrupts that will be appended
  to a generated CapDL specification. We would prefer not to deal with interrupts, but CapDL
  represents each interrupt as a mapping to a single-slot CNode. We need to note the existence of
  these artificial CNodes for the final correspondence proof.
*}
record irqs =
  irqs_map :: "cdl_irq \<Rightarrow> cdl_object_id"
  irqs_objects :: cdl_heap

definition
  valid_irqs :: "cdl_state \<Rightarrow> cdl_heap \<Rightarrow> irqs \<Rightarrow> bool"
where
  "valid_irqs initial extra irqs \<equiv>
     range (irqs_map irqs) = dom (irqs_objects irqs) \<and>
     dom (cdl_objects initial) \<inter> dom (irqs_objects irqs) = {} \<and>
     dom extra \<inter> dom (irqs_objects irqs) = {} \<and>
     (\<forall>x \<in> ran (irqs_objects irqs). case x of
        Types_D.CNode c \<Rightarrow> c = \<lparr>cdl_cnode_caps = empty, cdl_cnode_size_bits = 0\<rparr>
      | _ \<Rightarrow> False)"

text {*
  Predicate that the extra capability distribution we provide to the @{text generate} function is a
  valid extension to the basic distribution we generate. Essentially the extension must only contain
  address space objects.
*}
definition
  valid_extra :: "cdl_state \<Rightarrow> cdl_heap \<Rightarrow> bool"
where
  "valid_extra initial extra \<equiv>
     (\<forall>obj \<in> range extra. case obj of
          None \<Rightarrow> True
        | Some (Types_D.PageDirectory _) \<Rightarrow> True
        | Some (Types_D.PageTable _) \<Rightarrow> True
        | Some (Types_D.Frame _) \<Rightarrow> True
        | _ \<Rightarrow> False) \<and>
     dom (cdl_objects initial) \<inter> dom extra = {}"

text {*
  Now, for each of the types of items present in a base CAmkES-derived CapDL specification (CNodes,
  TCBs, endpoints), we define two things:
   * count - How many of this type of object we have; and
   * objects - A list of these objects ordered by cdl_object_id.
  Note that a CAmkES-derived CapDL specification naturally groups objects of the same type in a
  single, contiguous block. The reason we need to define the count separately to the object list
  itself is that, in some cases, the count of a type of object is required before we are actually at
  the point where we can define the object list itself. This is basically to work around circular
  dependencies.
*}

definition cnode_count :: "camkes_state \<Rightarrow> nat"
  where "cnode_count spec \<equiv> length (components (composition spec))"

definition tcb_count :: "camkes_state \<Rightarrow> nat"
  where "tcb_count spec \<equiv>
    length (components (composition spec)) + sum (map
      (\<lambda>(_, c). length (provides c) + length (requires c) + length (emits c) +
                length (consumes c) + length (dataports c)) (components (composition spec)))"

lemma more_tcbs_than_cnodes: "tcb_count spec \<ge> cnode_count spec"
  by (clarsimp simp:tcb_count_def cnode_count_def)

definition
  ep_objs' :: "camkes_state \<Rightarrow> (string \<times> connection \<times> cdl_object) list"
where
  "ep_objs' spec \<equiv> concat (map (\<lambda>(n, c).
     if conn_type c = seL4RPC then
       [(n @ ''_ep'', c, Types_D.Endpoint)]
     else if conn_type c = seL4Asynch then
       [(n @ ''_ntfn'', c, Types_D.Notification)]
     else
       []) (connections (composition spec)))"

definition ep_objs :: "camkes_state \<Rightarrow> (string \<times> cdl_object) list"
  where "ep_objs spec \<equiv> map (\<lambda>(n, c, e). (n, e)) (ep_objs' spec)"

definition ep_count :: "camkes_state \<Rightarrow> nat"
  where "ep_count spec \<equiv> length (ep_objs spec)"

text {*
  When debugging a system (or when you would like your threads to terminate smoothly), we install
  TCB caps for all a component instance's threads in the first few CNode slots. When producing a
  verified system, we do not install these TCB caps, but we still need to account for the slots
  they would occupy as an offset into the CNode at which the following caps begin. Note, that we
  intentionally leave these slots empty so that any code expecting to invoke a TCB cap causes a cap
  fault, rather than incorrectly invoking an endpoint.
*}
definition cap_offset :: "camkes_state \<Rightarrow> string \<Rightarrow> nat"
  where "cap_offset spec instance \<equiv> 2 +
    (\<lambda>(_, c). length (requires c) + length (provides c) + length (dataports c) +
              length (emits c) + length (consumes c))
      (hd (filter (\<lambda>(n, _). n = instance) (components (composition spec))))"

lemma helper1: "map (length \<circ> (\<lambda>(a, b). P a b # map (f a b) (Q a b))) xs =
                  map (\<lambda>(a, b). 1 + length (Q a b)) xs"
  by clarsimp

lemma helper2: "(\<Sum>x \<leftarrow> xs. Suc (f x)) = length xs + (\<Sum>x \<leftarrow> xs. f x)"
  apply (induct xs)
   by clarsimp+

lemma helper3: "(\<Sum>(a, b) \<leftarrow> xs. Suc (f a b)) = length xs + (\<Sum>(a, b) \<leftarrow> xs. f a b)"
  apply (induct xs)
   by clarsimp+

lemma helper4: "fold op + ((map (\<lambda>(a, b). f a b) xs)::nat list) 0 = (\<Sum>(a, b) \<leftarrow> xs. f a b)"
  apply (subst fold_plus_sum_list_rev)
  apply (subst sum_list_rev)
  by clarsimp

lemma set_of_enumerate:"card (set (enumerate n xs)) = length xs"
  by (metis distinct_card distinct_enumerate length_enumerate)

lemma collapse_fst:"fst ` (\<lambda>x. (f x, g x)) ` s = f ` s"
  by force

lemma collapse_fst2:"fst ` (\<lambda>(x, y). (f x, g y)) ` s = (\<lambda>x. f (fst x)) ` s"
  by force

lemma collapse_fst3:"(\<lambda>x. f (fst x)) ` set (enumerate n xs) = f ` set [n..<n + length xs]"
  by (metis image_image list.set_map map_fst_enumerate)

lemma card_of_dom_bounded:
  fixes f :: "'a \<Rightarrow> 'b option"
  assumes "finite (UNIV::'a set)"
  shows "card (dom f) \<le> CARD('a)"
  by (metis assms card_seteq linear top_greatest)

lemma helper8: "x \<in> f ` S = (\<exists>y \<in> S. f y = x)"
  by blast

lemma helper7:
  "n \<le> CARD(cdl_object_id) \<Longrightarrow> card ((of_nat::nat \<Rightarrow> cdl_object_id) ` {0..<n}) = card {0..<n}"
  apply clarsimp
  apply (induct n)
   apply clarsimp+
  apply (subgoal_tac "{0..<Suc n} = {0..<n} \<union> {n}")
   prefer 2
   apply clarsimp
   apply fastforce
  apply clarsimp
  apply (subst card_insert_disjoint)
    apply clarsimp
   apply (subst atLeast0LessThan)
   apply (subgoal_tac "(of_nat::nat \<Rightarrow> cdl_object_id) ` {..<n} = {..<of_nat n}")
    prefer 2
    apply (rule equalityI)
     apply clarsimp
     apply (subst (asm) card_word)
     apply clarsimp
     apply (rule of_nat_mono_maybe)
      apply clarsimp+
      apply (subst helper8)
      apply (rule bexI) (* sorry for schematics *)
       apply (rule word_unat.Rep_inverse')
       apply force
      apply clarsimp
      apply (subst (asm) card_word)
      apply clarsimp
      apply (metis (erased, hide_lams) Divides.mod_less_eq_dividend order_less_le_trans unat_of_nat word_less_nat_alt)
     by clarsimp+

lemma helper6: "n \<le> CARD(cdl_object_id) \<Longrightarrow> card ((of_nat::nat \<Rightarrow> cdl_object_id) ` {0..<n}) = n"
  apply (subst helper7)
   by clarsimp+

lemma third_in: "(a, b, c) \<in> S \<Longrightarrow> c \<in> (snd \<circ> snd) ` S"
  by (metis (erased, hide_lams) helper8 image_comp snd_conv)

lemma helper9: "(a \<in> (snd \<circ> snd) ` (set (enumerate i xs))) = (a \<in> snd ` (set xs))"
  by (metis map_map map_snd_enumerate set_map)

abbreviation "is_some s \<equiv> \<not> Option.is_none s"

lemma helper11: "is_some (map_of (enumerate' n xs) x) \<Longrightarrow> \<exists>y. map_of (enumerate' n xs) x = Some y"
  by (metis (full_types) is_none_code(1) not_Some_eq)

lemma helper10: "map_of (enumerate' n xs) x = Some y \<Longrightarrow> y \<in> set xs"
  apply (clarsimp simp:enumerate'_def)
  by (metis enumerate_eq_zip in_set_zipE map_of_SomeD zip_map1)

lemma helper14:
  "(map_of xs ++ map_of ys) x = (case map_of ys x of None \<Rightarrow> map_of xs x | Some x' \<Rightarrow> Some x')"
  apply (case_tac "(map_of xs ++ map_of ys) x")
   apply clarsimp+
  apply (case_tac "map_of ys x")
   by clarsimp+

lemma helper15:
  "(map_of xs ++ map_of ys ++ map_of zs) x =
     (case map_of zs x of None \<Rightarrow> (case map_of ys x of None \<Rightarrow> map_of xs x
                                                     | Some x' \<Rightarrow> Some x')
                        | Some x' \<Rightarrow> Some x')"
  apply (case_tac "(map_of xs ++ map_of ys ++ map_of zs) x")
   apply clarsimp+
  apply (case_tac "map_of zs x")
   apply clarsimp
   apply (case_tac "map_of ys x")
    by clarsimp+

lemma helper13: "map_of (map (\<lambda>(n, y). (the_id_of n, y)) xs) x = Some z \<Longrightarrow> z \<in> snd ` set xs"
  proof -
    assume "map_of (map (\<lambda>(n, y). (the_id_of n, y)) xs) x = Some z"
    hence "(x, z) \<in> (\<lambda>(uu, y). (the_id_of uu, y)) ` set xs" using map_of_SomeD by fastforce
    thus "z \<in> snd ` set xs" using helper8 by fastforce
  qed

lemma helper12: "valid_extra a b \<Longrightarrow> dom (cdl_objects a) \<inter> dom b = {}"
  by (clarsimp simp:valid_extra_def)

lemma helper16: "(a, b) \<in> set (enumerate x ys) \<Longrightarrow> b \<in> set ys"
  by (metis enumerate_eq_zip in_set_zip2)

lemma helper17: "distinct (map fst xs) \<Longrightarrow> ran (map_of xs) = set (map snd xs)"
  apply (cut_tac xs="map fst xs" and ys="map snd xs" in ran_map_of_zip[symmetric])
    apply clarsimp+
  by (simp add: ran_distinct)

lemma helper18: "x \<in> ran (map_of xs) \<Longrightarrow> x \<in> set (map snd xs)"
  by (metis (mono_tags, hide_lams) helper8 map_of_SomeD ranE set_map snd_conv)

lemma helper19: "x \<in> ran (xs ++ ys ++ zs) \<Longrightarrow> x \<in> ran xs \<or> x \<in> ran ys \<or> x \<in> ran zs"
  by (smt map_add_Some_iff ranE ranI)

lemma helper21: "None \<notin> S \<Longrightarrow> Some x \<in> S = (x \<in> the ` S)"
  apply (rule iffI)
   apply force
  apply (subst in_these_eq[symmetric])
  apply (clarsimp simp:Option.these_def)
  apply (case_tac "\<exists>y. xa = Some y")
   by clarsimp+

lemma helper20: "the ` Set.filter (\<lambda>s. \<not> Option.is_none s) (range f) = ran f"
  apply (rule subset_antisym)
   apply clarsimp
   apply (case_tac "f x", simp_all)
   apply (simp add: ranI)
  apply clarsimp
  apply (subst helper21[symmetric])
   apply clarsimp+
  apply (erule ranE)
  by (metis range_eqI)

lemma helper23:
  "x \<in> ran (cdl_objects (merge_objs a b)) \<Longrightarrow> x \<in> ran (cdl_objects a) \<or> x \<in> ran b"
  apply (clarsimp simp:merge_objs_def merge_cdl_def)
  by (metis helper19 map_add_id)

type_synonym label = string

text {*
  We assume that the user, when instantiating the following locale to use the contained lemmas, will
  provide us with a function to find the object IDs of the IPC buffers. We need to assume this
  because the IPC buffer frames (and caps to them) are inferred late in the CapDL generation
  process, while deriving the rest of the backing frames for the address space.
*}
locale cdl_translation =
  fixes ipc_buffer :: "string \<Rightarrow> nat \<Rightarrow> cdl_object_id option"
  assumes buffers_distinct: "\<And>n i m j. \<exists>f. ipc_buffer n i = Some f \<and> ipc_buffer m j = Some f
                               \<Longrightarrow> n = m \<and> i = j"
  fixes id_of :: "string \<Rightarrow> cdl_object_id option"
  assumes ids_distinct: "\<And>n m. \<exists>i. id_of n = Some i \<and> id_of m = Some i \<Longrightarrow> n = m"

  fixes garbage :: label
  fixes irq_label :: label
begin

abbreviation the_ipc_buffer :: "string \<Rightarrow> nat \<Rightarrow> cdl_object_id"
  where "the_ipc_buffer name index \<equiv> the (ipc_buffer name index)"

abbreviation the_id_of :: "string \<Rightarrow> cdl_object_id"
  where "the_id_of name \<equiv> the (id_of name)"

abbreviation the_cnode_of :: "string \<Rightarrow> cdl_object_id"
  where "the_cnode_of instance \<equiv> the_id_of (''cnode_'' @ instance)"

(* XXX: Assumes no shared address space components. *)
abbreviation the_pd_of :: "string \<Rightarrow> cdl_object_id"
  where "the_pd_of instance \<equiv> the_id_of (''pd_'' @ instance @ ''_group_bin'')"

text {*
  The contents of a CNode of a given component instance. It is easier to define this out-of-line
  here.
*}
definition
  cap_map :: "camkes_state \<Rightarrow> string \<Rightarrow> nat \<Rightarrow> cdl_cap option"
where
  "cap_map spec instance \<equiv> map_of (enumerate (cap_offset spec instance) (concat (
     map (\<lambda>(n, c, _). if conn_type c = seL4RPC then (
                        if fst (conn_from c) = instance then
                          [Types_D.EndpointCap (the_id_of n) 0 RW]
                        else if fst (conn_to c) = instance then
                          [Types_D.EndpointCap (the_id_of n) 0 RW]
                        else
                          [])
                      else if conn_type c = seL4Asynch then (
                        if fst (conn_from c) = instance then
                          [Types_D.NotificationCap (the_id_of n) 0 W]
                        else if fst (conn_to c) = instance then
                          [Types_D.NotificationCap (the_id_of n) 0 R]
                        else
                          [])
                      else
                        []) (ep_objs' spec))))"

text {*
  Various minutiae related to CNode sizes. Ordinarily, in a hand-written system, this would not be a
  big deal. However, in CAmkES we automatically infer the CNode size based on the number of
  capabilities it needs to contain. The definition below is intended to replicate the calculation in
  the python-capdl module.
*}
definition cnode_size_bits :: "camkes_state \<Rightarrow> string \<Rightarrow> nat"
  where "cnode_size_bits spec name \<equiv>
    LEAST bits. 2 ^ bits > Max (dom (cap_map spec name) \<union> {2})"

definition cnode_size :: "camkes_state \<Rightarrow> string \<Rightarrow> nat"
  where "cnode_size spec instance \<equiv> 2 ^ (cnode_size_bits spec instance)"

definition cnode_guard_size :: "camkes_state \<Rightarrow> string \<Rightarrow> nat"
  where "cnode_guard_size spec instance \<equiv> 32 - cnode_size_bits spec instance"

text {* All CNodes have a guard of 0. *}
definition cnode_guard :: "camkes_state \<Rightarrow> string \<Rightarrow> 32 word"
  where "cnode_guard _ _ \<equiv> 0"

definition
  cnode_objs :: "camkes_state \<Rightarrow> (string \<times> cdl_object) list"
where
  "cnode_objs spec \<equiv>
     map (\<lambda>n. (''cnode_'' @ n,
               Types_D.CNode \<lparr>cdl_cnode_caps = cap_map spec n,
                              cdl_cnode_size_bits = cnode_size_bits spec n\<rparr>))
       (instance_names spec)"

lemma cnode_count_correct: "cnode_count spec = length (cnode_objs spec)"
  by (clarsimp simp:cnode_count_def cnode_objs_def instance_names_def)

definition
  tcb_objs :: "camkes_state \<Rightarrow> (string \<times> cdl_object) list"
where
  "tcb_objs spec \<equiv> concat (
     (* The 'control' TCB *)
     map (\<lambda>(n, c). (n @ ''_tcb_0_control'', Types_D.Tcb \<lparr>cdl_tcb_caps = [
       cspace \<mapsto> Types_D.CNodeCap (the_cnode_of n) (cnode_guard spec n) (cnode_guard_size spec n)
                   (cnode_size_bits spec n),
       vspace \<mapsto> Types_D.PageDirectoryCap (the_pd_of n) Real None,
       ipc_buffer_slot \<mapsto> Types_D.FrameCap False (the_ipc_buffer n 0) RW 12 Real None],
                        cdl_tcb_fault_endpoint = 0,
                        cdl_tcb_intent = undefined,
                        cdl_tcb_has_fault = False,
                        cdl_tcb_domain = 0\<rparr>) #

     (* The interface TCBs *)
     map (\<lambda>(i, inf). (n @ ''_tcb_'' @ inf, Types_D.Tcb \<lparr>cdl_tcb_caps = [
       cspace \<mapsto> Types_D.CNodeCap (the_cnode_of n) (cnode_guard spec n) (cnode_guard_size spec n)
                   (cnode_size_bits spec n),
       vspace \<mapsto> Types_D.PageDirectoryCap (the_pd_of n) Real None,
       ipc_buffer_slot \<mapsto> Types_D.FrameCap False (the_ipc_buffer n (i + 1)) RW 12 Real None],
                   cdl_tcb_fault_endpoint = 0,
                   cdl_tcb_intent = undefined,
                   cdl_tcb_has_fault = False,
                   cdl_tcb_domain = 0\<rparr>))
         (enumerate 0 (map fst (provides c) @ map fst (requires c) @ map fst (emits c) @
                       map fst (consumes c) @ map fst (dataports c))))

     (components (composition spec)))"

lemma tcb_count_correct: "tcb_count spec = length (tcb_objs spec)"
  apply (clarsimp simp:tcb_count_def tcb_objs_def sum_def)
  apply (subst length_concat)
  apply clarsimp
  apply (subst helper1)
  apply clarsimp
  apply (subst helper3)
  apply (subst helper4)
  apply clarsimp
  by (metis (no_types, hide_lams) add.commute add.left_commute)

text {* The CapDL heap; that is, all the objects in the system. *}
definition
  obj_heap :: "camkes_state \<Rightarrow> cdl_object_id \<Rightarrow> cdl_object option"
where
  "obj_heap spec \<equiv> map_of (map (\<lambda>(n, i). (the_id_of n, i)) (
     cnode_objs spec @ tcb_objs spec @ ep_objs spec))"

definition obj_heap_size :: "camkes_state \<Rightarrow> nat"
  where "obj_heap_size spec \<equiv> cnode_count spec + tcb_count spec + ep_count spec"

lemma obj_heap_dom_bounded:"card (dom (obj_heap spec)) \<le> CARD(cdl_object_id)"
  apply (rule card_mono[where B=UNIV])
   by clarsimp+

text {* Low-level generator. This describes the actual logic of the CAmkES code generator. *}
definition
  generate' :: "camkes_state \<Rightarrow> cdl_state"
where
  "generate' spec \<equiv> \<lparr>
     cdl_arch = ARM11,
     cdl_objects = obj_heap spec,
     cdl_cdt = empty,
     cdl_current_thread = undefined,
     cdl_irq_node = undefined,
     cdl_asid_table = empty,
     cdl_current_domain = undefined\<rparr>"

text {*
  An object abstraction (that is, a mapping from object IDs to labels) for a CAmkES-generated
  specification. WIP.
*}
definition
  poa_of :: "camkes_state \<Rightarrow> cdl_heap \<Rightarrow> irqs \<Rightarrow> label agent_map"
where
  "poa_of spec extra irqs \<equiv> (\<lambda>id. case (

     (* Labelling of the output of the low-level generator: *)
     fold (op ++)
       (map (\<lambda>(name, _). [the_id_of name \<mapsto> behead name ''cnode_'']) (cnode_objs spec))
         Map.empty

     ++
     fold (op ++)
       (map (\<lambda>(name, _). [the_id_of name \<mapsto> trunc name ''_ep'']) (ep_objs spec)) Map.empty
     ++
     fold (op ++)
       (map (\<lambda>(name, _). [the_id_of name \<mapsto> behead name ''tcb_'']) (tcb_objs spec)) Map.empty

     (* Labelling of address space objects: *)
     ++
     (\<lambda>id. case extra id of
             Some _ \<Rightarrow> if \<exists>name. id_of name = Some id
                          then Some (trunc
                                      (behead (SOME name. id_of name = Some id) ''frame_'')
                                        ''_group_bin_0000'')
                          else None
           | None \<Rightarrow> None)

     (* Labelling of IRQ objects: *)
     ++
     (\<lambda>id. if id \<in> dom (irqs_objects irqs)
              then Some irq_label
              else None)

     ) id of Some l \<Rightarrow> l | None \<Rightarrow> garbage)"

abbreviation "edge_subject \<equiv> fst"
abbreviation "edge_auth \<equiv> fst o snd"
abbreviation "edge_object \<equiv> snd o snd"

text {*
  A policy describing the authority between labels in a CapDL system. Note that the only meaningful
  relationships here are the authority implied by endpoints. TODO: shared memory.
*}
definition
  policy_of :: "camkes_state \<Rightarrow> cdl_heap \<Rightarrow> irqs \<Rightarrow> label auth_graph"
where
  "policy_of spec extra irqs \<equiv>
     (* Every label has every authority over itself. *)
     {edge. edge_subject edge = edge_object edge} \<union>

     (* Senders on seL4RPC connections. *)
     {edge. \<exists>from. from \<in> fst ` set (components (composition spec)) \<and>
                   (\<exists>conn \<in> set (connections (composition spec)).
                      fst (conn_from (snd conn)) = from \<and>
                      conn_type (snd conn) = seL4RPC \<and>
                      edge_object edge = fst conn) \<and>
                    edge_subject edge = from \<and>
                    edge_auth edge \<in> {Receive, Reset, SyncSend}} \<union>

     (* Receivers on seL4RPC connections. *)
     {edge. \<exists>to. to \<in> fst ` set (components (composition spec)) \<and>
                 (\<exists>conn \<in> set (connections (composition spec)).
                    fst (conn_to (snd conn)) = to \<and>
                    conn_type (snd conn) = seL4RPC \<and>
                    edge_object edge = fst conn) \<and>
                  edge_subject edge = to \<and>
                  edge_auth edge \<in> {Receive, Reset, SyncSend}} \<union>

     (* Senders on seL4Asynch connections. *)
     {edge. \<exists>from. from \<in> fst ` set (components (composition spec)) \<and>
                   (\<exists>conn \<in> set (connections (composition spec)).
                      fst (conn_from (snd conn)) = from \<and>
                      conn_type (snd conn) = seL4Asynch \<and>
                      edge_object edge = fst conn) \<and>
                    edge_subject edge = from \<and>
                    edge_auth edge \<in> {Notify, Reset}} \<union>

     (* Receivers on seL4Asynch connections. *)
     {edge. \<exists>to. to \<in> fst ` set (components (composition spec)) \<and>
                 (\<exists>conn \<in> set (connections (composition spec)).
                    fst (conn_to (snd conn)) = to \<and>
                    conn_type (snd conn) = seL4Asynch \<and>
                    edge_object edge = fst conn) \<and>
                  edge_subject edge = to \<and>
                  edge_auth edge \<in> {Receive, Reset}}"

lemma pw_decompose:
  "\<lbrakk>\<forall>agent. (\<forall>agent'. (agent, Control, agent') \<in> aag \<longrightarrow> agent = agent')
         \<and> (\<forall>a. (agent, a, agent) \<in> aag);
    \<exists>agent. policy_wellformed aag mirqs irqs agent\<rbrakk>
    \<Longrightarrow> \<forall>agent. policy_wellformed aag False irqs agent"
  by (clarsimp simp:policy_wellformed_def)

lemma no_trans_grant: "subj = obj \<or> (subj, Grant, obj) \<notin> policy_of spec extras irqs"
  by (clarsimp simp:policy_of_def)

lemma pw_control:
  "\<lbrakk>policy_wellformed policy mirqs irqs l; (s, Receive, l) \<in> policy\<rbrakk> \<Longrightarrow> (l, Control, s) \<in> policy"
  apply (rule_tac ep=l and mirqs=mirqs and irqs=irqs and l=l in aag_wellformed_grant_Control_to_recv)
    apply (rule_tac mirqs=mirqs and irqs=irqs in aag_wellformed_refl)
    by assumption+

lemma pw_control':
  "\<lbrakk>policy_wellformed policy mirqs irqs l; (s, Receive, l) \<in> policy\<rbrakk> \<Longrightarrow> (s, Control, l) \<in> policy"
  apply (rule_tac ep=l and mirqs=mirqs and irqs=irqs and l=l in aag_wellformed_grant_Control_to_send)
    apply (rule_tac mirqs=mirqs and irqs=irqs in aag_wellformed_refl)
    by assumption+

lemma pw_same_label:
  "\<lbrakk>policy_wellformed policy mirqs irqs l; (s, Receive, l) \<in> policy\<rbrakk> \<Longrightarrow> s = l"
  apply (frule_tac s=s in pw_control, assumption)
  apply (frule_tac s=s in pw_control', assumption)
  apply (rule sym)
  apply (rule_tac aag=policy and mirqs=mirqs and irqs=irqs in aag_wellformed_Control)
   by assumption+

lemma policy_wf: "wellformed_assembly spec \<Longrightarrow>
    \<forall>agent. policy_wellformed (policy_of spec extras irqs) False {irq_label} agent"
  apply (clarsimp simp:policy_wellformed_def)
  apply (rule conjI)
   apply (clarsimp simp:policy_of_def)
  apply (rule conjI)
   apply (clarsimp simp:policy_of_def)
  apply clarsimp
  apply (rename_tac subj subj' obj)
  apply (cut_tac subj=subj and obj=obj and spec=spec and extras=extras and irqs=irqs in no_trans_grant)
  apply clarsimp
  oops

(* TODO *)
definition
  pas_of :: "camkes_state \<Rightarrow> cdl_heap \<Rightarrow> irqs \<Rightarrow> label PAS set"
where
  "pas_of spec extra irqs \<equiv> {pas.
     pasObjectAbs pas = poa_of spec extra irqs \<and>
     (\<forall>asid. pasASIDAbs pas asid = garbage) \<and>
     (\<forall>irq. pasIRQAbs pas irq = irq_label) \<and>
     pasPolicy pas = policy_of spec extra irqs \<and>
     pasSubject pas \<notin> {garbage, irq_label} \<and>
     \<not> pasMayActivate pas \<and>
     \<not> pasMayEditReadyQueues pas \<and>
     \<not> pasMaySendIrqs pas \<and>
     (\<forall>domain. (domain = 0 \<and> pasDomainAbs pas domain \<noteq> garbage) \<or>
               (domain \<noteq> 0 \<and> pasDomainAbs pas domain = garbage))
   }"

text {*
  Top-level state generator. We validate the capability extension and then use the low-level
  generator above.
*}
definition
  state_of :: "camkes_state \<Rightarrow> cdl_heap \<Rightarrow> irqs \<Rightarrow> cdl_state option"
where
  "state_of spec extra irqs \<equiv>
     if valid_extra (generate' spec) extra \<and> valid_irqs (generate' spec) extra irqs then
       Some ((merge_objs
               (merge_objs (generate' spec) extra) (irqs_objects irqs))
                 \<lparr>cdl_irq_node := irqs_map irqs\<rparr>)
     else
       None"

lemma state_of_implies_valid:
  "state_of spec extra irqs = Some cdl \<Longrightarrow> valid_extra (generate' spec) extra"
  by (metis state_of_def option.distinct(1))

lemma state_of_implies_valid2:
  "state_of spec extra irqs = Some cdl \<Longrightarrow> valid_irqs (generate' spec) extra irqs"
  by (metis state_of_def option.distinct(1))

lemma merge_contained:
  "\<lbrakk>z = merge_cdl x y; cdl_objects z u = Some v\<rbrakk>
     \<Longrightarrow> cdl_objects x u = Some v \<or> cdl_objects y u = Some v"
  by (clarsimp simp:merge_cdl_def)

abbreviation "obj_ids cdl \<equiv> dom (cdl_objects cdl)"
abbreviation "obj_ids' extra \<equiv> dom extra"
abbreviation "obj_count cdl \<equiv> card (obj_ids cdl)"
abbreviation "obj_count' extra \<equiv> card (obj_ids' extra)"
abbreviation "objs cdl \<equiv> the ` (Set.filter is_some (range (cdl_objects cdl)))"
abbreviation "objs' extra \<equiv> the ` (Set.filter is_some (range extra))"

lemma valid_only_pds_pts_frames:
  "valid_extra initial cdl \<Longrightarrow> \<forall>i \<in> objs' cdl. case i of Types_D.PageDirectory _ \<Rightarrow> True
                                                       | Types_D.PageTable _ \<Rightarrow> True
                                                       | Types_D.Frame _ \<Rightarrow> True
                                                       | _ \<Rightarrow> False"
  apply (clarsimp simp:valid_extra_def)
  apply (erule_tac x=xa in allE)
  by (metis case_option_If2 Option.is_none_def)

lemma cnode_objs_only_cnodes:
  "\<forall>(_, i) \<in> set (cnode_objs spec). case i of Types_D.CNode _ \<Rightarrow> True | _ \<Rightarrow> False"
  by (clarsimp simp:cnode_objs_def)

lemma tcb_objs_only_tcbs: "\<forall>(_, i) \<in> set (tcb_objs spec). case i of Types_D.Tcb _ \<Rightarrow> True | _ \<Rightarrow> False"
  apply (clarsimp simp:tcb_objs_def)
  apply (erule disjE)
   by clarsimp+

lemma ep_objs_only_eps:
  "\<forall>(_, i) \<in> set (ep_objs spec). case i of Types_D.Endpoint \<Rightarrow> True | Types_D.Notification \<Rightarrow> True | _ \<Rightarrow> False"
  apply (clarsimp simp:ep_objs_def ep_objs'_def)
  by (metis cdl_object.simps(98) cdl_object.simps(99))

lemma generated_no_pds_pts_frames:
  "generate' spec = cdl \<Longrightarrow>
     \<not>(\<exists>x \<in> objs cdl. case x of Types_D.PageDirectory _ \<Rightarrow> True
                               | Types_D.PageTable _ \<Rightarrow> True
                               | Types_D.Frame _ \<Rightarrow> True
                               | _ \<Rightarrow> False)"
  apply (clarsimp simp:generate'_def obj_heap_def)
  apply (subst (asm) helper15)+
  apply (case_tac "map_of (map (\<lambda>(n, y). (the_id_of n, y)) (cnode_objs spec)) xa")
   apply clarsimp
   apply (case_tac "map_of (map (\<lambda>(n, y). (the_id_of n, y)) (tcb_objs spec)) xa")
    apply clarsimp
    apply (case_tac "map_of (map (\<lambda>(n, y). (the_id_of n, y)) (ep_objs spec)) xa")
     apply (clarsimp; fail)
    apply clarsimp
    apply (insert ep_objs_only_eps[where spec=spec], clarsimp)
    apply (drule helper13)
    apply clarsimp
    apply (rename_tac a' b')
    apply (erule_tac x="(a', b')" in ballE)
     apply clarsimp
     apply (case_tac b', simp_all)
   apply (insert tcb_objs_only_tcbs[where spec=spec], clarsimp)
   apply (drule helper13)
   apply clarsimp
   apply (rename_tac a' b')
   apply (erule_tac x="(a', b')" and A="set (tcb_objs spec)" in ballE)
    apply clarsimp
    apply (case_tac b', simp_all)
  apply (insert cnode_objs_only_cnodes[where spec=spec], clarsimp)
  apply (drule helper13)
  apply clarsimp
  apply (rename_tac a' b')
  apply (erule_tac x="(a', b')" and A="set (cnode_objs spec)" in ballE)
   apply clarsimp
   by (case_tac b', simp_all)

lemma generated_objects_disjoint:
  "state_of spec extra irqs = Some cdl \<Longrightarrow>
     obj_count (generate' spec) + obj_count' extra + obj_count' (irqs_objects irqs) = obj_count cdl"
  apply (frule state_of_implies_valid, frule state_of_implies_valid2)
  apply (subst card_Un_disjoint[symmetric], simp_all)
   apply (clarsimp simp:helper12)
  apply (subst card_Un_disjoint[symmetric], simp_all)
   apply (subgoal_tac "dom extra \<inter> dom (irqs_objects irqs) = {}")
    prefer 2
    apply (rule ccontr)
    apply (subst (asm) not_empty_eq)
    apply clarsimp
    apply (rename_tac obj1 obj2)
    apply (clarsimp simp:valid_irqs_def)
    apply blast
   apply (clarsimp simp:valid_irqs_def)
   apply blast
  apply (clarsimp simp:state_of_def merge_cdl_def merge_objs_def)
  by (simp add: Un_assoc)

lemma only_endpoint_caps:
  "\<forall>cap \<in> ran (cap_map a xs). case cap of Types_D.EndpointCap _ _ _ \<Rightarrow> True
                                        | Types_D.NotificationCap _ _ _ \<Rightarrow> True
                                        | _ \<Rightarrow> False"
  apply (clarsimp simp:cap_map_def)
  apply (subst (asm) ran_distinct)
   apply clarsimp+
  apply (drule helper16)
  apply clarsimp
  apply (rename_tac connection irrelevant)
  apply (case_tac "conn_type connection = seL4RPC", simp_all)
   by (case_tac "from_component connection = xs", simp_all)+

lemma valid_only_empty_cnodes:
  "valid_irqs spec extra irqs \<Longrightarrow> \<forall>obj \<in> ran (irqs_objects irqs). case obj of
     Types_D.CNode c \<Rightarrow> c = \<lparr>cdl_cnode_caps = empty, cdl_cnode_size_bits = 0\<rparr>
   | _ \<Rightarrow> False"
  by (clarsimp simp:valid_irqs_def)

lemma only_endpoint_caps2:
  "\<forall>(name, cnode) \<in> set (cnode_objs spec). case cnode of
     Types_D.CNode c \<Rightarrow> (\<forall>cap \<in> ran (cdl_cnode_caps c). case cap of
       Types_D.EndpointCap _ _ _ \<Rightarrow> True
     | Types_D.NotificationCap _ _ _ \<Rightarrow> True
     | _ \<Rightarrow> False)
   | _ \<Rightarrow> False"
  apply (clarsimp simp:cnode_objs_def)
  apply (rename_tac name cap)
  apply (cut_tac a=spec and xs=name in only_endpoint_caps)
  apply (erule_tac x=cap in ballE)
   apply assumption
  by clarsimp

text {* All the caps in a generated spec are only to endpoints. *}
lemma generated_caps_limited:
  "state_of spec extra irqs = Some cdl \<Longrightarrow>
     \<forall>cnode \<in> ((\<lambda>c. case c of Types_D.CNode c' \<Rightarrow> c') `
                 (Set.filter (\<lambda>c. case c of Types_D.CNode _ \<Rightarrow> True | _ \<Rightarrow> False)
                   (Map.ran (cdl_objects cdl)))).
       \<forall>cap \<in> (Map.ran (cdl_cnode_caps cnode)).
         case cap of Types_D.EndpointCap _ _ _ \<Rightarrow> True
                   | Types_D.NotificationCap _ _ _ \<Rightarrow> True
                   | _ \<Rightarrow> False"
  apply (clarsimp simp:state_of_def)
  apply (rename_tac cap)
  apply (subgoal_tac "valid_extra (generate' spec) extra")
   prefer 2
   apply (rule ccontr)
   apply clarsimp+
  apply (subgoal_tac "valid_irqs (generate' spec) extra irqs")
   prefer 2
   apply (rule ccontr)
   apply clarsimp+
  apply (drule helper23)
  apply (erule disjE)
   apply (drule helper23)
   apply (erule disjE)
    apply (clarsimp simp:generate'_def obj_heap_def)
    apply (drule helper19)
    apply (case_tac "cnode \<in> ran (map_of (map (\<lambda>(n, y). (the_id_of n, y)) (ep_objs spec)))")
     apply (drule helper18)
     apply clarsimp
     apply (rename_tac name cnode)
     apply (cut_tac spec=spec in ep_objs_only_eps)
     apply (erule_tac x="(name, cnode)" in ballE)
      apply clarsimp
      apply (case_tac cnode; simp_all)
     apply clarsimp
    apply (case_tac "cnode \<in> ran (map_of (map (\<lambda>(n, y). (the_id_of n, y)) (tcb_objs spec)))")
     apply (drule helper18)
     apply clarsimp
     apply (rename_tac name cnode)
     apply (cut_tac spec=spec in tcb_objs_only_tcbs)
     apply (erule_tac x="(name, cnode)" in ballE)
      apply clarsimp
      apply (case_tac cnode; simp_all)
     apply clarsimp
    apply clarsimp
    apply (drule helper18)
    apply clarsimp
    apply (rename_tac name cnode)
    apply (cut_tac spec=spec in only_endpoint_caps2)
    apply (erule_tac x="(name, cnode)" in ballE)
     apply clarsimp
     apply (case_tac cnode; simp_all)
    apply clarsimp
   apply (drule valid_only_pds_pts_frames)
   apply (erule_tac x=cnode in ballE)
    apply (case_tac cnode; simp_all)
   apply (simp add: helper20)
  apply (drule valid_only_empty_cnodes)
  apply (erule_tac x=cnode in ballE)
   apply (case_tac cnode; simp_all)
  by clarsimp

text {* Compose the functions for producing a state and PAS into a single top-level generator. *}
definition
  generate :: "camkes_state \<Rightarrow> cdl_heap \<Rightarrow> irqs \<Rightarrow> (cdl_state \<times> label PAS set) option"
where
  "generate spec extra irqs \<equiv>
     case state_of spec extra irqs of Some state \<Rightarrow> Some (state, pas_of spec extra irqs)
                                    | None \<Rightarrow> None"

lemma "\<lbrakk>generate spec extra irqs = Some (state, pases); pas \<in> pases;
        (subject, Control, object) \<in> pasPolicy pas\<rbrakk>
         \<Longrightarrow> subject = object"
  apply (clarsimp simp:generate_def pas_of_def policy_of_def)
  apply (case_tac "state_of spec extra irqs"; clarsimp)+
  done

end

end


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

(* Kernel init refinement. Currently axiomatised.
*)

theory ArchKernelInit_AI
imports
  "../ADT_AI"
  "../Tcb_AI"
  "../Arch_AI"
begin

context Arch begin global_naming ARM (*FIXME: arch_split*)

text {*
  Showing that there is a state that satisfies the abstract invariants.
*}

lemmas ptr_defs = init_tcb_ptr_def idle_thread_ptr_def init_irq_node_ptr_def
                  init_globals_frame_def init_global_pd_def
lemmas state_defs = init_A_st_def init_kheap_def init_arch_state_def ptr_defs

lemma [simp]: "is_tcb (TCB t)" by (simp add: is_tcb_def)

lemma [simp]: "ran (empty_cnode n) = {Structures_A.NullCap}"
  apply (auto simp: ran_def empty_cnode_def)
  apply (rule_tac x="replicate n False" in exI)
  apply simp
  done

lemma empty_cnode_apply[simp]:
  "(empty_cnode n xs = Some cap) = (length xs = n \<and> cap = Structures_A.NullCap)"
  by (auto simp add: empty_cnode_def)

lemma valid_cs_size_empty[simp]:
  "valid_cs_size n (empty_cnode n) = (n < word_bits - cte_level_bits)"
  apply (simp add: valid_cs_size_def)
  apply (insert wf_empty_bits [of n])
  apply fastforce
  done

lemma init_cdt [simp]:
  "cdt init_A_st = init_cdt"
  by (simp add: state_defs)

lemma mdp_parent_empty [simp]:
  "\<not>empty \<Turnstile> x \<rightarrow> y"
  apply clarsimp
  apply (drule tranclD)
  apply (clarsimp simp: cdt_parent_of_def)
  done

lemma descendants_empty [simp]:
  "descendants_of x empty = {}"
  by (clarsimp simp: descendants_of_def)

lemma [simp]: "\<not>is_reply_cap Structures_A.NullCap"
  by (simp add: is_reply_cap_def)

lemma [simp]: "cap_range Structures_A.NullCap = {}"
  by (simp add: cap_range_def)

lemma pde_mapping_bits_shift:
  fixes x :: "12 word"
  shows "x \<noteq> 0 \<Longrightarrow> 2 ^ pde_mapping_bits - 1 < (ucast x << pde_mapping_bits :: word32)"
  apply (simp only:shiftl_t2n pde_mapping_bits_def)
  apply (unfold word_less_alt)
  apply simp
  apply (unfold word_mult_def)
  apply simp
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply simp
   apply (subst uint_up_ucast)
    apply (simp add: is_up_def source_size_def target_size_def word_size)
   apply (cut_tac 'a = "12" and x = x in uint_lt2p)
   apply simp
  apply (rule order_less_le_trans)
   prefer 2
   apply (rule pos_mult_pos_ge)
    apply (subst uint_up_ucast)
     apply (simp add: is_up_def source_size_def target_size_def word_size)
    apply (simp add: word_neq_0_conv word_less_alt)
   apply simp
  apply simp
  done

lemma mask_pde_mapping_bits:
  "mask 20 = 2^pde_mapping_bits - 1"
  by (simp add: mask_def pde_mapping_bits_def)

lemma init_irq_ptrs_ineqs:
  "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) \<ge> init_irq_node_ptr"
  "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) + 2 ^ cte_level_bits - 1
                \<le> init_irq_node_ptr + 2 ^ 14 - 1"
  "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits)
                \<le> init_irq_node_ptr + 2 ^ 14 - 1"
proof -
  have P: "ucast irq < (2 ^ (14 - cte_level_bits) :: word32)"
    apply (rule order_le_less_trans[OF
        ucast_le_ucast[where 'a=10 and 'b=32,simplified,THEN iffD2, OF word_n1_ge]])
    apply (simp add: cte_level_bits_def minus_one_norm)
    done
  show "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) \<ge> init_irq_node_ptr"
    apply (rule is_aligned_no_wrap'[where sz=14])
     apply (simp add: is_aligned_def init_irq_node_ptr_def kernel_base_def)
    apply (rule shiftl_less_t2n[OF P])
    apply simp
    done
  show Q: "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits) + 2 ^ cte_level_bits - 1
                \<le> init_irq_node_ptr + 2 ^ 14 - 1"
    apply (simp only: add_diff_eq[symmetric] add.assoc)
    apply (rule word_add_le_mono2)
     apply (simp only: trans [OF shiftl_t2n mult.commute])
     apply (rule nasty_split_lt[OF P])
      apply (simp_all add: cte_level_bits_def
        word_bits_def kernel_base_def init_irq_node_ptr_def)
    done
  show "init_irq_node_ptr + (ucast (irq :: irq) << cte_level_bits)
                \<le> init_irq_node_ptr + 2 ^ 14 - 1"
    apply (simp only: add_diff_eq[symmetric])
    apply (rule word_add_le_mono2)
     apply (rule minus_one_helper3, rule shiftl_less_t2n[OF P])
     apply simp
    apply (simp add: kernel_base_def
      cte_level_bits_def word_bits_def init_irq_node_ptr_def)
    done
qed

lemmas init_irq_ptrs_less_ineqs
   = init_irq_ptrs_ineqs(1)[THEN order_less_le_trans[rotated]]
     init_irq_ptrs_ineqs(2-3)[THEN order_le_less_trans]

lemmas init_irq_ptrs_all_ineqs[unfolded init_irq_node_ptr_def cte_level_bits_def]
   = init_irq_ptrs_ineqs(1)[THEN order_trans[rotated]]
     init_irq_ptrs_ineqs(2-3)[THEN order_trans]
     init_irq_ptrs_less_ineqs
     init_irq_ptrs_less_ineqs[THEN less_imp_neq]
     init_irq_ptrs_less_ineqs[THEN less_imp_neq, THEN not_sym]

lemmas ucast_le_ucast_10_32 = ucast_le_ucast[where 'a=10 and 'b=32,simplified]
lemma init_irq_ptrs_eq:
  "((ucast (irq :: irq) << cte_level_bits)
        = (ucast (irq' :: irq) << cte_level_bits :: word32))
      = (irq = irq')"
  apply safe
  apply (rule ccontr)
  apply (erule_tac bnd="ucast (max_word :: irq) + 1"
              in shift_distinct_helper[rotated 3],
         safe intro!: plus_one_helper2,
         simp_all add: ucast_le_ucast_10_32 up_ucast_inj_eq,
         simp_all add: cte_level_bits_def word_bits_def up_ucast_inj_eq
                       max_word_def)
  done

lemma in_kernel_base:
"\<lbrakk>m < 0xFFFFF; n \<le> 0xFFFFF\<rbrakk> \<Longrightarrow> (\<forall>y\<in>{kernel_base + m .. n + kernel_base}.
              kernel_base \<le> y \<and> y \<le> kernel_base + 0xFFFFF)"
  apply (clarsimp simp:)
  apply (intro conjI)
   apply (rule ccontr,simp add:not_le)
   apply (drule(1) le_less_trans)
   apply (cut_tac is_aligned_no_wrap'[where ptr = kernel_base and off = m
     and sz = 28,simplified])
     apply (drule(1) less_le_trans)
     apply simp
    apply (simp add:kernel_base_def is_aligned_def)
   apply (rule ccontr,simp add:not_less)
   apply (drule less_le_trans[where z = "0x10000000"])
    apply simp
   apply simp
  apply (erule order_trans)
  apply (simp add:field_simps)
  apply (rule word_plus_mono_right)
   apply simp
  apply (simp add:kernel_base_def)
  done

lemma pspace_aligned_init_A:
  "pspace_aligned init_A_st"
  apply (clarsimp simp: pspace_aligned_def state_defs wf_obj_bits [OF wf_empty_bits]
                          dom_if_Some cte_level_bits_def)
  apply (safe intro!: aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl],
           simp_all add: is_aligned_def word_bits_def kernel_base_def)[1]
  done

lemma pspace_distinct_init_A:
  "pspace_distinct init_A_st"
  apply (clarsimp simp: pspace_distinct_def state_defs pageBits_def
                        empty_cnode_bits kernel_base_def
                        cte_level_bits_def linorder_not_le cong: if_cong)
  apply (safe,
         simp_all add: init_irq_ptrs_all_ineqs
                       [simplified kernel_base_def, simplified])[1]
  apply (cut_tac x="init_irq_node_ptr + (ucast irq << cte_level_bits)"
             and y="init_irq_node_ptr + (ucast irqa << cte_level_bits)"
             and sz=cte_level_bits in aligned_neq_into_no_overlap)
     apply (simp add: init_irq_node_ptr_def kernel_base_def cte_level_bits_def)
    apply (rule aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl])
    apply (simp add: is_aligned_def cte_level_bits_def init_irq_node_ptr_def
                     kernel_base_def)
   apply (rule aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl])
   apply (simp add: is_aligned_def cte_level_bits_def init_irq_node_ptr_def
                    kernel_base_def)
  apply (simp add: init_irq_node_ptr_def kernel_base_def cte_level_bits_def
                   linorder_not_le)
  done

lemma caps_of_state_init_A_st_Null:
  "caps_of_state (init_A_st::'z::state_ext state) x
     = (if cte_at x (init_A_st::'z::state_ext state) then Some cap.NullCap else None)"
  apply (subgoal_tac "\<not> cte_wp_at (op \<noteq> cap.NullCap) x init_A_st")
   apply (auto simp add: cte_wp_at_caps_of_state)[1]
  apply (clarsimp, erule cte_wp_atE)
   apply (auto simp add: state_defs tcb_cap_cases_def split: if_split_asm)
  done

lemmas cte_wp_at_caps_of_state_eq
    = cte_wp_at_caps_of_state[where P="op = cap" for cap]

declare ptrFormPAddr_addFromPPtr[simp]

lemma pspace_respects_device_region_init[simp]:
  "pspace_respects_device_region init_A_st"
   apply (clarsimp simp: pspace_respects_device_region_def init_A_st_def init_machine_state_def device_mem_def
                         in_device_frame_def obj_at_def init_kheap_def a_type_def)
   apply (rule ext)
   apply clarsimp
   done

lemma cap_refs_respects_device_region_init[simp]:
  "cap_refs_respects_device_region init_A_st"
   apply (clarsimp simp: cap_refs_respects_device_region_def)
   apply (frule cte_wp_at_caps_of_state[THEN iffD1])
   apply clarsimp
   apply (subst(asm) caps_of_state_init_A_st_Null)
   apply (clarsimp simp: cte_wp_at_caps_of_state cap_range_respects_device_region_def)
   done

lemma invs_A:
  "invs init_A_st"

  apply (simp add: invs_def)
  apply (rule conjI)
   prefer 2
   apply (simp add: cur_tcb_def state_defs obj_at_def)
  apply (simp add: valid_state_def)
  apply (rule conjI)
   apply (simp add: valid_pspace_def)
   apply (rule conjI)
    apply (clarsimp simp: kernel_base_def valid_objs_def state_defs
                          valid_obj_def valid_vm_rights_def vm_kernel_only_def
                          dom_if_Some cte_level_bits_def)
    apply (rule conjI)
     apply (clarsimp simp: valid_tcb_def tcb_cap_cases_def is_master_reply_cap_def
                           valid_cap_def obj_at_def valid_tcb_state_def
                           cap_aligned_def word_bits_def valid_ipc_buffer_cap_simps)+
    apply (clarsimp simp: valid_cs_def word_bits_def cte_level_bits_def
                          init_irq_ptrs_all_ineqs valid_tcb_def
                   split: if_split_asm)
   apply (rule conjI)
    apply (clarsimp simp: pspace_aligned_def state_defs wf_obj_bits [OF wf_empty_bits]
                          dom_if_Some cte_level_bits_def)
    apply (safe intro!: aligned_add_aligned[OF _ is_aligned_shiftl_self order_refl],
           simp_all add: is_aligned_def word_bits_def kernel_base_def)[1]
   apply (rule conjI)
    apply (simp add:pspace_distinct_init_A)
   apply (rule conjI)
    apply (clarsimp simp: if_live_then_nonz_cap_def obj_at_def state_defs)
   apply (rule conjI)
    apply (clarsimp simp: zombies_final_def cte_wp_at_cases state_defs
                          tcb_cap_cases_def is_zombie_def)
   apply (clarsimp simp: sym_refs_def state_refs_of_def state_defs)
  apply (rule conjI)
   apply (clarsimp simp: valid_mdb_def init_cdt_def no_mloop_def
                         mdb_cte_at_def)
   apply (clarsimp simp: untyped_mdb_def caps_of_state_init_A_st_Null
                         untyped_inc_def ut_revocable_def
                         irq_revocable_def reply_master_revocable_def
                         reply_mdb_def reply_caps_mdb_def
                         reply_masters_mdb_def)
   apply (simp add:descendants_inc_def)
  apply (rule conjI)
   apply (simp add: valid_ioc_def init_A_st_def init_ioc_def cte_wp_at_cases2)
   apply (intro allI impI, elim exE conjE)
   apply (case_tac obj, simp_all add: cap_of_def)
   apply (clarsimp simp: init_kheap_def split: if_split_asm)
  apply (rule conjI)
   apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def state_defs)
  apply (rule conjI)
   apply (clarsimp simp: only_idle_def pred_tcb_at_def obj_at_def state_defs)
  apply (rule conjI)
   apply (clarsimp simp: if_unsafe_then_cap_def caps_of_state_init_A_st_Null)
  apply (clarsimp simp: valid_reply_caps_def unique_reply_caps_def
                        has_reply_cap_def pred_tcb_at_def obj_at_def
                        caps_of_state_init_A_st_Null
                        cte_wp_at_caps_of_state_eq
                        valid_reply_masters_def valid_global_refs_def
                        valid_refs_def[unfolded cte_wp_at_caps_of_state])
  apply (rule conjI)
   apply (clarsimp simp: valid_arch_state_def)
   apply (rule conjI)
    apply (clarsimp simp: valid_asid_table_def state_defs)
   apply (rule conjI)
    apply (clarsimp simp: valid_arch_state_def obj_at_def state_defs
                          a_type_def)
   apply (rule conjI)
    apply (simp add: valid_global_pts_def state_defs)
   apply (simp add: state_defs is_inv_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_irq_node_def obj_at_def state_defs
                         is_cap_table_def wf_empty_bits
                         init_irq_ptrs_all_ineqs cte_level_bits_def
                         init_irq_ptrs_eq[unfolded cte_level_bits_def])
   apply (intro conjI)
    apply (rule inj_onI)
    apply (simp add: init_irq_ptrs_eq[unfolded cte_level_bits_def])
   apply clarsimp
   defer
  apply (simp add: valid_irq_handlers_def caps_of_state_init_A_st_Null
                   ran_def cong: rev_conj_cong)
  apply (rule conjI)
   apply (clarsimp simp: valid_irq_states_def init_A_st_def init_machine_state_def valid_irq_masks_def init_irq_masks_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_machine_state_def init_A_st_def
                         init_machine_state_def init_underlying_memory_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_arch_objs_def obj_at_def state_defs)
   apply (clarsimp simp: vs_lookup_def vs_asid_refs_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_arch_caps_def)
   apply (rule conjI)
    apply (clarsimp simp: valid_vs_lookup_def)
    apply (clarsimp simp: vs_lookup_pages_def state_defs vs_asid_refs_def)
   apply (clarsimp simp: valid_table_caps_def caps_of_state_init_A_st_Null
                         unique_table_caps_def unique_table_refs_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_global_objs_def state_defs)
   apply (clarsimp simp: valid_ao_at_def obj_at_def empty_table_def pde_ref_def
                         valid_pde_mappings_def)
   apply (simp add: kernel_base_def kernel_mapping_slots_def
                    Platform.ARM.addrFromPPtr_def physMappingOffset_def
                    kernelBase_addr_def physBase_def pageBits_def is_aligned_def)
  apply (rule conjI)
   apply (simp add: valid_kernel_mappings_def state_defs
                         valid_kernel_mappings_if_pd_def pde_ref_def
                         ran_def)
   apply (auto simp: pde_ref_def split: if_split_asm)[1]
  apply (rule conjI)
   apply (clarsimp simp: equal_kernel_mappings_def state_defs obj_at_def)
  apply (rule conjI)
   apply (clarsimp simp: valid_asid_map_def state_defs)
  apply (rule conjI)
   apply (clarsimp simp: valid_global_vspace_mappings_def obj_at_def state_defs
                         valid_pd_kernel_mappings_def mask_pde_mapping_bits)
   apply (simp add: valid_pde_kernel_mappings_def kernel_base_def)
   apply (rule conjI)
    apply (fastforce simp:pde_mapping_bits_def)
   apply (intro ballI impI)
   apply (clarsimp simp:pde_mapping_bits_def)
   apply word_bitwise
   apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp: pspace_in_kernel_window_def state_defs mask_def)
   apply (intro conjI impI)
            apply (rule in_kernel_base|simp)+
         apply (erule exE,drule sym,simp add:field_simps)
         apply (rule in_kernel_base[simplified add.commute])
          apply (rule word_less_add_right,simp add:cte_level_bits_def)
           apply (rule less_le_trans[OF shiftl_less_t2n'[OF ucast_less]],simp+)[1]
          apply simp
         apply (simp add:cte_level_bits_def field_simps)
         apply (subst add.commute)
         apply (rule le_plus')
          apply simp+
          apply (rule less_imp_le)
          apply (rule less_le_trans[OF shiftl_less_t2n'[OF ucast_less]],simp+)[1]
     apply (rule in_kernel_base|simp)+
  apply (simp add: cap_refs_in_kernel_window_def caps_of_state_init_A_st_Null
                  valid_refs_def[unfolded cte_wp_at_caps_of_state])
  apply word_bitwise
  done

end

end


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

theory DetWP
imports "Lib.DetWPLib" "CBaseRefine.Include_C"
begin

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

lemma det_wp_doMachineOp [wp]:
  "det_wp (\<lambda>_. P) f \<Longrightarrow> det_wp (\<lambda>_. P) (doMachineOp f)"
  apply (simp add: doMachineOp_def split_def)
  apply (rule det_wp_pre, wp)
      apply (erule det_wp_select_f)
     apply wp+
  apply simp
  done

lemma det_wp_loadWordUser [wp]:
  "det_wp (pointerInUserData x and K (is_aligned x 3)) (loadWordUser x)"
  apply (simp add: loadWordUser_def loadWord_def)
  apply (rule det_wp_pre, wp)
    apply (rule det_wp_pre, wp)
    apply clarsimp
    apply assumption
   apply wp
  apply (clarsimp simp: is_aligned_mask)
  done

declare det_wp_liftM[wp]

declare det_wp_assert_opt[wp]

declare det_wp_when[wp]

declare det_wp_unless[wp]

declare word_neq_0_conv [simp del]

lemma det_wp_loadObject_default [wp]:
  "det_wp (\<lambda>s. \<exists>obj. projectKO_opt ko = Some (obj::'a) \<and>
                      is_aligned p (objBits obj) \<and> q = p
                      \<and> case_option True (\<lambda>x. 2 ^ (objBits obj) \<le> x - p) n)
           (loadObject_default p q n ko :: ('a::pre_storable) kernel)"
  apply (simp add: loadObject_default_def split_def projectKO_def
                   alignCheck_def alignError_def magnitudeCheck_def
                   unless_def)
  apply (rule det_wp_pre)
   apply (wp case_option_wp)
  apply (clarsimp simp: is_aligned_mask[symmetric])
  apply simp
  done

lemma det_wp_getTCB [wp]:
  "det_wp (tcb_at' t) (getObject t :: tcb kernel)"
  supply option.case_cong[cong]
  apply (simp add: getObject_def split_def)
  apply (rule det_wp_pre)
   apply (wp|wpc)+
  apply (clarsimp simp: obj_at'_def objBits_simps cong: conj_cong)
  apply (simp add: lookupAround2_known1)
  apply (rule ps_clear_lookupAround2, assumption+)
    apply simp
   apply (erule is_aligned_no_overflow)
  apply (simp add: word_bits_def)
  done

lemma det_wp_setObject_other [wp]:
  fixes ob :: "'a :: pspace_storable"
  assumes x: "updateObject ob = updateObject_default ob"
  shows "det_wp (obj_at' (\<lambda>k::'a. objBits k = objBits ob) ptr)
                  (setObject ptr ob)"
  apply (simp add: setObject_def x split_def updateObject_default_def
                   magnitudeCheck_def
                   projectKO_def2 alignCheck_def alignError_def)
  apply (rule det_wp_pre)
   apply (wp )
  apply (clarsimp simp: is_aligned_mask[symmetric] obj_at'_def objBits_def[symmetric]
                        project_inject lookupAround2_known1)
  apply (erule(1) ps_clear_lookupAround2)
    apply simp
   apply (erule is_aligned_get_word_bits)
    apply (subst add_diff_eq[symmetric])
    apply (erule is_aligned_no_wrap')
    apply simp
   apply simp
  apply fastforce
  done

lemma det_wp_setTCB [wp]:
  "det_wp (tcb_at' t) (setObject t (v::tcb))"
  apply (rule det_wp_pre)
   apply (wp|wpc|simp)+
  apply (clarsimp simp: objBits_simps)
  done

lemma det_wp_threadGet [wp]:
  "det_wp (tcb_at' t) (threadGet f t)"
  apply (simp add: threadGet_def)
  apply (rule det_wp_pre, wp)
  apply simp
  done

lemma det_wp_threadSet [wp]:
  "det_wp (tcb_at' t) (threadSet f t)"
  apply (simp add: threadSet_def)
  apply (rule det_wp_pre, wp)
  apply simp
  done

lemma det_wp_asUser [wp]:
  "det f \<Longrightarrow> det_wp (tcb_at' t) (asUser t f)"
  apply (simp add: asUser_def split_def)
  apply (rule det_wp_pre)
   apply wp
      apply (drule det_wp_det)
      apply (erule det_wp_select_f)
     apply wp+
   apply (rule_tac Q="\<lambda>_. tcb_at' t" in hoare_post_imp)
    apply simp
   apply wp
  apply simp
  done

(* FIXME move into Refine somewhere *)
lemma wordSize_def':
  "wordSize = 8"
  unfolding wordSize_def wordBits_def
  by (simp add: word_size)

lemma det_wp_getMRs:
  "det_wp (tcb_at' thread and case_option \<top> valid_ipc_buffer_ptr' buffer) (getMRs thread buffer mi)"
  apply (clarsimp simp: getMRs_def)
  apply (rule det_wp_pre)
   apply (wp det_mapM det_getRegister order_refl det_wp_mapM)
   apply (simp add: word_size)
   apply (wp asUser_inv mapM_wp' getRegister_inv)
  apply clarsimp
  apply (rule conjI)
   apply (simp add: pointerInUserData_def wordSize_def' word_size)
   apply (erule valid_ipc_buffer_ptr'D2[unfolded word_size_def, simplified])
    apply (rule word_mult_less_mono1)
      apply (erule order_le_less_trans)
      apply (simp add: msgMaxLength_def max_ipc_words)
     apply simp
    apply (simp add: max_ipc_words)
   apply (simp add: is_aligned_mult_triv2 [where n = 3, simplified] word_bits_conv word_size_bits_def)
  apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits[simplified word_size_bits_def])
  apply (simp add: wordSize_def' is_aligned_mult_triv2 [where n = 3, simplified] word_bits_conv)
  done

end

end