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

header{*The n_german Protocol Case Study*}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


theory RCU_S_steps
  imports RCU_model
begin

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

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

(*the following must be included in the proof:

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

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

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

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

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

lemmas con_assms_lemmas [simp] = reserved_bydef_def reservations_differ_def
                                 default_locs_def counters_limit_def

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

section \<open>Automation simpsets\<close>

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

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

lemmas finite_set_simps =
        insert_iff empty_iff
        Un_insert_left Un_empty_left
        Int_insert_left Int_empty_left
        insert_Diff_if empty_Diff

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

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

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

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

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

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

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

        object_slots_eval_simps
        cdl_obj_refs.simps

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

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

        (* evaluating irq integrity *)
        cdl_cap_irqs_controlled.simps

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

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

end
end