(*  Title:      HOL/Auth/n_germanSimp_lemma_inv__22_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__22_on_rules imports n_germanSimp_lemma_on_inv__22
begin
section{*All lemmas on causal relation between inv__22*}
lemma lemma_inv__22_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__22  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__22) 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__22) 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__22) 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__22) 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__22) 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__22) 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__22) 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__22) 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__22) 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__22) 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__22) 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__22) done
    }

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

end


(*
   Title: Psi-calculi
   Based on the AFP entry by Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Stat_Imp
  imports Tau_Chain
begin

context env begin

definition
  "weak_stat_imp" :: "'b \<Rightarrow> ('a, 'b, 'c) psi \<Rightarrow>
                     ('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set \<Rightarrow>
                     ('a, 'b, 'c) psi \<Rightarrow> bool" ("_ \<rhd> _ \<lessapprox><_> _" [80, 80, 80, 80] 80)
where "\<Psi> \<rhd> P \<lessapprox><Rel> Q \<equiv> \<forall>\<Psi>'. \<exists>Q' Q''. \<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q' \<and> insert_assertion(extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame Q') \<Psi> \<and> \<Psi> \<otimes> \<Psi>' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'' \<and> (\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel"

lemma weak_stat_impMonotonic:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   A :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q :: "('a, 'b, 'c) psi"
  and   B :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes "\<Psi> \<rhd> P \<lessapprox><A> Q"
  and     "A \<subseteq> B"

  shows "\<Psi> \<rhd> P \<lessapprox><B> Q"
using assms
by(auto simp add: weak_stat_imp_def) blast

lemma weak_stat_impI[case_names cStatImp]:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   \<Psi>' :: 'b

  assumes "\<And>\<Psi>'. \<exists>Q' Q''. \<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q' \<and> insert_assertion(extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame Q') \<Psi> \<and> \<Psi> \<otimes> \<Psi>' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'' \<and> (\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel"

  shows "\<Psi> \<rhd> P \<lessapprox><Rel> Q"
using assms
by(auto simp add: weak_stat_imp_def)

lemma weak_stat_impE:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   \<Psi>' :: 'b

  assumes "\<Psi> \<rhd> P \<lessapprox><Rel> Q"

  obtains Q' Q'' where "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'" and "insert_assertion(extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame Q') \<Psi> " and "\<Psi> \<otimes> \<Psi>' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" and "(\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel"

using assms
by(auto simp add: weak_stat_imp_def) blast

lemma weak_stat_impClosed:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   p   :: "name prm"

  assumes EqvtRel: "eqvt Rel"
  and     PStatImpQ: "\<Psi> \<rhd> P \<lessapprox><Rel> Q"

  shows "(p \<bullet> \<Psi>) \<rhd> (p \<bullet> P) \<lessapprox><Rel> (p \<bullet> Q)"
proof(induct rule: weak_stat_impI)
  case(cStatImp \<Psi>')
  from PStatImpQ obtain Q' Q'' where QChain: "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'"
                                 and PimpQ': "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q') \<Psi>"
                                 and Q'Chain: "\<Psi> \<otimes> (rev(p::name prm) \<bullet> \<Psi>') \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" and "(\<Psi> \<otimes> (rev p \<bullet> \<Psi>'), P,  Q'') \<in> Rel"
    by(rule weak_stat_impE)
  from QChain have "(p \<bullet> \<Psi>) \<rhd> (p \<bullet> Q) \<Longrightarrow>\<^sup>^\<^sub>\<tau> (p \<bullet> Q')" by(rule tau_chain_eqvt)
  moreover from PimpQ' have "insert_assertion (extract_frame (p \<bullet> P)) (p \<bullet> \<Psi>) \<hookrightarrow>\<^sub>F insert_assertion (extract_frame(p \<bullet> Q')) (p \<bullet> \<Psi>)"
    by(drule_tac p=p in Frame_stat_imp_closed) (simp add: eqvts)
  moreover from Q'Chain have "(p \<bullet> \<Psi>) \<otimes> \<Psi>' \<rhd> (p \<bullet> Q') \<Longrightarrow>\<^sup>^\<^sub>\<tau> (p \<bullet> Q'')" by(drule_tac p=p in tau_chain_eqvt) (simp add: eqvts)
  moreover from `(\<Psi> \<otimes> (rev p \<bullet> \<Psi>'), P, Q'') \<in> Rel` EqvtRel have "((p \<bullet> \<Psi>) \<otimes> \<Psi>', (p \<bullet> P), (p \<bullet> Q'')) \<in> Rel"
    by(drule_tac p=p in eqvtI) (auto simp add: eqvts)
  ultimately show ?case
    by blast
qed

lemma weak_stat_impReflexive:
  fixes Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"

  assumes "{(\<Psi>, P, P) | \<Psi> P. True} \<subseteq> Rel"

  shows "\<Psi> \<rhd> P \<lessapprox><Rel> P"
using assms
by(auto simp add: weak_stat_imp_def weak_transition_def dest: rtrancl_into_rtrancl) force+

lemma weak_stat_impTransitive:
  fixes \<Psi>     :: 'b
  and   P     :: "('a, 'b, 'c) psi"
  and   Rel   :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q     :: "('a, 'b, 'c) psi"
  and   Rel'  :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   R     :: "('a, 'b, 'c) psi"
  and   Rel'' :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes PStatImpQ: "\<Psi> \<rhd> P \<lessapprox><Rel> Q"
  and     QRelR: "(\<Psi>, Q, R) \<in> Rel'"
  and     Set: "{(\<Psi>', S, U) | \<Psi>' S U. \<exists>T. (\<Psi>', S, T) \<in> Rel \<and> (\<Psi>', T, U) \<in> Rel'} \<subseteq> Rel''"
  and     C1: "\<And>\<Psi>' S T. (\<Psi>', S, T) \<in> Rel' \<Longrightarrow> \<Psi>' \<rhd> S \<lessapprox><Rel'> T"
  and     C2: "\<And>\<Psi>' S T S'. \<lbrakk>(\<Psi>', S, T) \<in> Rel'; \<Psi>' \<rhd> S \<Longrightarrow>\<^sup>^\<^sub>\<tau> S'\<rbrakk> \<Longrightarrow> \<exists>T'. \<Psi>' \<rhd> T \<Longrightarrow>\<^sup>^\<^sub>\<tau> T' \<and> (\<Psi>', S', T') \<in> Rel'"

  shows "\<Psi> \<rhd> P \<lessapprox><Rel''> R"
proof(induct rule: weak_stat_impI)
  case(cStatImp \<Psi>')
  from `\<Psi> \<rhd> P \<lessapprox><Rel> Q` obtain Q' Q'' where QChain: "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'"
                                         and PimpQ': "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q') \<Psi>"
                                         and Q'Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" and "(\<Psi> \<otimes> \<Psi>', P, Q'') \<in> Rel"
    by(rule weak_stat_impE)
  from QChain `(\<Psi>, Q, R) \<in> Rel'` obtain R' where RChain: "\<Psi> \<rhd> R \<Longrightarrow>\<^sup>^\<^sub>\<tau> R'" and "(\<Psi>, Q', R') \<in> Rel'"
    by(metis C2)
  from `(\<Psi>, Q', R') \<in> Rel'` obtain R'' R''' where R'Chain: "\<Psi> \<rhd> R' \<Longrightarrow>\<^sup>^\<^sub>\<tau> R''"
                                              and Q'impR'': "insert_assertion (extract_frame Q') \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame R'') \<Psi>"
                                              and R''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> R'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> R'''" and "(\<Psi> \<otimes> \<Psi>', Q', R''') \<in> Rel'"
    by(blast dest: C1 weak_stat_impE)
  from RChain R'Chain have "\<Psi> \<rhd> R \<Longrightarrow>\<^sup>^\<^sub>\<tau> R''" by auto
  moreover from PimpQ' Q'impR'' have "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame R'') \<Psi>"
    by(rule Frame_stat_imp_trans)
  moreover from Q'Chain `(\<Psi> \<otimes> \<Psi>', Q',  R''') \<in> Rel'` obtain R'''' where R'''Chain: "\<Psi> \<otimes> \<Psi>' \<rhd> R''' \<Longrightarrow>\<^sup>^\<^sub>\<tau> R''''" and "(\<Psi> \<otimes> \<Psi>', Q'', R'''') \<in> Rel'"
    by(metis C2)
  from R''Chain R'''Chain have "\<Psi> \<otimes> \<Psi>' \<rhd> R'' \<Longrightarrow>\<^sup>^\<^sub>\<tau> R''''" by auto
  moreover from `(\<Psi> \<otimes> \<Psi>', P,  Q'') \<in> Rel` `(\<Psi> \<otimes> \<Psi>', Q'', R'''') \<in> Rel'` Set have "(\<Psi> \<otimes> \<Psi>', P, R'''') \<in> Rel''" by blast
  ultimately show ?case
    by blast
qed

lemma weak_stat_impStatEq:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"
  and   Q   :: "('a, 'b, 'c) psi"
  and   \<Psi>'  :: 'b

  assumes PSimQ: "\<Psi> \<rhd> P \<lessapprox><Rel> Q"
  and     "\<Psi> \<simeq> \<Psi>'"
  and     C1: "\<And>\<Psi>' R S \<Psi>''. \<lbrakk>(\<Psi>', R, S) \<in> Rel; \<Psi>' \<simeq> \<Psi>''\<rbrakk> \<Longrightarrow> (\<Psi>'', R, S) \<in> Rel'"

  shows "\<Psi>' \<rhd> P \<lessapprox><Rel'> Q"
proof(induct rule: weak_stat_impI)
  case(cStatImp \<Psi>'')
  from `\<Psi> \<rhd> P \<lessapprox><Rel> Q` obtain Q' Q'' where QChain: "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'"
                                         and PimpQ: "insert_assertion (extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q') \<Psi>"
                                         and Q'Chain: "\<Psi> \<otimes> \<Psi>'' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" and "(\<Psi> \<otimes> \<Psi>'', P, Q'') \<in> Rel"
    by(rule weak_stat_impE)
  from QChain `\<Psi> \<simeq> \<Psi>'` have "\<Psi>' \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q'" by(rule tau_chain_stat_eq)
  moreover from PimpQ `\<Psi> \<simeq> \<Psi>'` have "insert_assertion (extract_frame P) \<Psi>' \<hookrightarrow>\<^sub>F insert_assertion (extract_frame Q') \<Psi>'"
    by(rule insert_assertionStatImp)
  moreover from Q'Chain `\<Psi> \<simeq> \<Psi>'` have "\<Psi>' \<otimes> \<Psi>'' \<rhd> Q' \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q''" by(metis tau_chain_stat_eq Composition)
  moreover from `(\<Psi> \<otimes> \<Psi>'', P, Q'') \<in> Rel` `\<Psi> \<simeq> \<Psi>'`  have "(\<Psi>' \<otimes> \<Psi>'', P, Q'') \<in> Rel'" by(blast intro: Composition C1)
  ultimately show ?case
    by blast
qed

lemma statImpWeakStatImp:
  fixes \<Psi>   :: 'b
  and   P   :: "('a, 'b, 'c) psi"
  and   Q   :: "('a, 'b, 'c) psi"
  and   Rel :: "('b \<times> ('a, 'b, 'c) psi \<times> ('a, 'b, 'c) psi) set"

  assumes PImpQ: "insert_assertion(extract_frame P) \<Psi> \<hookrightarrow>\<^sub>F insert_assertion(extract_frame Q) \<Psi>"
  and     C1: "\<And>\<Psi>'. (\<Psi> \<otimes> \<Psi>', P, Q) \<in> Rel"

  shows "\<Psi> \<rhd> P \<lessapprox><Rel> Q"
proof(induct rule: weak_stat_impI)
  case(cStatImp \<Psi>')
  have "\<Psi> \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q" by simp
  moreover note PImpQ
  moreover have "\<Psi> \<otimes> \<Psi>' \<rhd> Q \<Longrightarrow>\<^sup>^\<^sub>\<tau> Q" by simp
  moreover have "(\<Psi> \<otimes> \<Psi>', P, Q) \<in> Rel" by(rule C1)
  ultimately show ?case
    by blast
qed

end

end


theory ARMv7A_Mem_Write_Read_Ref

imports  ARMv7A_Address_Translate_Ref

begin

lemma  mmu_write_rel:
  "\<lbrakk>mmu_write_size (val,va, sz) s = ((), s')\<rbrakk>   \<Longrightarrow>  s' = s \<lparr> non_det_tlb := non_det_tlb s' , MEM:= MEM s' , exception:= exception s' \<rparr>"
  apply (clarsimp simp:  mmu_write_size_non_det_tlb_state_ext_def Let_def, cases "mmu_translate va s", clarsimp split: if_split_asm)
   apply (drule write_mem_rel, cases "mmu_translate va s" , clarsimp)
   apply (drule mmu_rel, cases s, cases s', case_tac b, clarsimp)
  apply (clarsimp simp: mmu_translate_non_det_tlb_state_ext_def Let_def split: lookup_type.splits)
      by (clarsimp simp: Let_def raise'exception_def split:if_split_asm)+

lemma mmu_write_sat_tlb_disj:
  "\<lbrakk> mmu_write_size (val,va, sz) s = ((), s') \<rbrakk> \<Longrightarrow>
     fst(non_det_tlb s') = fst(pairsub (non_det_tlb s)  (tlb_evict (typ_non_det_tlb s))) \<or>  fst(non_det_tlb s') = fst(pairsub (non_det_tlb s)  (tlb_evict (typ_non_det_tlb s))) \<union> {the (pt_walk (ASID s) (MEM s) (TTBR0 s) va)} \<or>
     fst(non_det_tlb s') = fst(pairsub (non_det_tlb s)  (tlb_evict (typ_non_det_tlb s))) \<union>  the ` (\<lambda>x. pde_tlb_entry x (MEM s) va) ` {x. lookup_pdc  (snd (pairsub (non_det_tlb s) (tlb_evict (typ_non_det_tlb s)))) (ASID s) va = Hit x }"
  apply (clarsimp simp:  mmu_write_size_non_det_tlb_state_ext_def mmu_translate_non_det_tlb_state_ext_def split_def Let_def write_mem_eq_TLB raise'exception_def
      split: lookup_type.splits split: if_split_asm)
    apply (drule write_mem_eq_TLB state.defs)
    apply (cases s , cases s' ; clarsimp)
   apply (drule write_mem_eq_TLB state.defs)
   apply (cases s , cases s' ; clarsimp)
  apply (drule write_mem_eq_TLB state.defs)
  by (cases s , cases s' ; clarsimp)

lemma mmu_write_sat_pdc_disj:
  "\<lbrakk> mmu_write_size (val,va, sz) s = ((), s') \<rbrakk> \<Longrightarrow>
     snd(non_det_tlb s') =  snd (pairsub (non_det_tlb s)  (tlb_evict (typ_non_det_tlb s))) \<or>
         snd(non_det_tlb s') =  snd(pairsub (non_det_tlb s)  (tlb_evict (typ_non_det_tlb s))) \<union> {the (pdc_walk (ASID s) (MEM s) (TTBR0 s) va)}"
  apply (clarsimp simp:  mmu_write_size_non_det_tlb_state_ext_def mmu_translate_non_det_tlb_state_ext_def split_def Let_def write_mem_eq_TLB raise'exception_def
      split: lookup_type.splits split: if_split_asm)
    apply (drule write_mem_eq_TLB state.defs)
    apply (cases s , cases s' ; clarsimp)
   apply (drule write_mem_eq_TLB state.defs)
   apply (cases s , cases s' ; clarsimp)
  apply (drule write_mem_eq_TLB state.defs)
  by (cases s , cases s' ; clarsimp)

(**************************************************************)

lemma mmu_write_saturated_state:
  "\<lbrakk>mmu_write_size (val,va,sz) s = ((), t)  \<rbrakk>  \<Longrightarrow> saturated (typ_sat_tlb t)"
  apply (clarsimp simp: mmu_write_size_sat_tlb_state_ext_def Let_def)
  apply (case_tac "mmu_translate va s" , clarsimp)
  apply (clarsimp split: if_split_asm)
   apply (case_tac "write'mem1 (val, a, sz) b" , clarsimp)
   apply (subgoal_tac "ASID s = ASID ba \<and> TTBR0 s = TTBR0 ba ")
    apply (clarsimp simp: saturated_def)
   apply (subgoal_tac "ASID s = ASID b \<and> TTBR0 s = TTBR0 b")
    apply clarsimp
    apply (clarsimp simp:  write'mem1_def Let_def)
    apply (clarsimp split: if_split_asm)
    apply (clarsimp simp:  raise'exception_def)
   apply (clarsimp simp: mmu_translate_sat_tlb_state_ext_def Let_def raise'exception_def split:lookup_type.splits if_split_asm)
  using mmu_translate_saturated_state surjective_pairing by blast

lemma mmu_wrtie_sat_rel:
  "\<lbrakk>mmu_write_size (val,va, sz) s = ((), s')\<rbrakk>   \<Longrightarrow>
      s' = s \<lparr> sat_tlb := sat_tlb s' , MEM:= MEM s' , exception:= exception s' \<rparr>"
  apply (clarsimp simp: mmu_write_size_sat_tlb_state_ext_def Let_def)
  apply (cases "mmu_translate va s" , clarsimp)
  apply (clarsimp split: if_split_asm)
   apply (case_tac " write'mem1 (val, a, sz) b", clarsimp)
   apply (drule write_mem_rel)
   apply (drule mmu_sat_rel)
   apply (cases s, cases s', case_tac a, case_tac b, case_tac ba)
   apply clarsimp
  apply (clarsimp simp: mmu_translate_sat_tlb_state_ext_def Let_def split: lookup_type.splits)
   apply (clarsimp simp: raise'exception_def  split:if_split_asm)
  by (clarsimp simp: raise'exception_def split:if_split_asm)

lemma mmu_write_tlb_subset:
  "\<lbrakk> mmu_write_size (val,va, sz) s = ((), s'); tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t) ; consistent (typ_sat_tlb t) va ;
        mmu_write_size (val,va, sz) t = ((), t') \<rbrakk> \<Longrightarrow>
          fst (non_det_tlb s') \<subseteq> fst(sat_tlb t') \<and> snd (non_det_tlb s') \<subseteq> snd (sat_tlb t')"
  apply (frule tlb_rel_satD)
  apply (clarsimp simp:  mmu_write_size_non_det_tlb_state_ext_def , cases "mmu_translate va s" , clarsimp)
  apply (clarsimp simp:  mmu_write_size_sat_tlb_state_ext_def , cases "mmu_translate va t" , clarsimp)
  apply (frule_tac t' = ba and s' = b and t = t and s = s and pa' = aa in mmu_translate_non_det_sat_subset_rel; simp?)
  apply (subgoal_tac "non_det_tlb b = non_det_tlb s'", clarsimp split: if_split_asm)
    apply (case_tac "write'mem1 (val, aa, sz) ba", clarsimp simp:)
    apply (subgoal_tac "state.more bb = state.more ba")
     apply force
    apply (drule write_mem_eq_TLB)
    apply (drule write_mem_eq_TLB)
    apply (clarsimp simp: typ_sat_tlb_def)
   apply (case_tac "write'mem1 (val, aa, sz) ba", simp)
   apply (subgoal_tac "state.more ba = state.more b")
    apply force
   apply (drule write_mem_eq_TLB)
   apply (clarsimp simp: typ_sat_tlb_def)
  apply (clarsimp split: if_split_asm)
   apply (drule write_mem_eq_TLB)
   apply (cases s' , case_tac b, clarsimp simp:)
  apply (drule write_mem_eq_TLB)
  by (cases s' , case_tac b, clarsimp simp:)

lemma mmu_write_non_det_sat_mem:
  "\<lbrakk> mmu_write_size (val,va, sz) s = ((), s');  tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t) ; consistent (typ_sat_tlb t) va;
                   mmu_write_size (val,va, sz) t = ((), t') \<rbrakk> \<Longrightarrow> MEM s' = MEM t'"
  apply (frule tlb_rel_satD)
  apply (clarsimp simp:  mmu_write_size_non_det_tlb_state_ext_def , cases "mmu_translate va s" , clarsimp)
  apply (clarsimp simp:  mmu_write_size_sat_tlb_state_ext_def , cases "mmu_translate va t" , clarsimp)
  apply (subgoal_tac "MEM ba = MEM b \<and>  exception ba = exception b")
   prefer 2
   apply (frule_tac t = t and t' = ba in mmu_translate_non_det_sat_mem_excp; simp)
  apply (subgoal_tac "a = aa")
   prefer 2
   apply (frule  mmu_translate_non_det_sat_pa; simp)
  apply simp
  apply (clarsimp split: if_split_asm)
  apply (case_tac "write'mem1 (val, aa, sz) ba", simp)
  apply (frule_tac t = ba and t' = bb in  write_same_mem, simp, simp)
  by (case_tac bb, cases t', simp)

lemma mmu_write_size_non_det_sat_state_trunc:
  "\<lbrakk>mmu_write_size (val,va, sz) s = ((), s'); tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t)  ; consistent (typ_sat_tlb t) va;
     mmu_write_size (val,va, sz) t = ((), t')\<rbrakk> \<Longrightarrow> state.truncate t' = state.truncate s'"
  apply (frule (3)  mmu_write_non_det_sat_mem)
  apply (frule tlb_rel_satD, clarsimp)
  apply (frule mmu_write_rel)
  apply (rotate_tac)
  apply (frule mmu_wrtie_sat_rel)
  apply (clarsimp simp: tlb_rel_sat_def)
  apply (subgoal_tac "exception s' = exception t'")
   apply (cases s, cases t, cases s' , cases t')
   apply (clarsimp simp: state.defs)
  apply (clarsimp simp: mmu_write_size_sat_tlb_state_ext_def mmu_write_size_non_det_tlb_state_ext_def Let_def)
  apply (case_tac "mmu_translate va t" , case_tac "write'mem1 (val, a, sz) b" , clarsimp)
  apply (case_tac "mmu_translate va s" , clarsimp)
  apply (subgoal_tac "exception b = exception bb \<and> a = aa")
   apply (clarsimp split: if_split_asm)
   apply (subgoal_tac "MEM b = MEM bb ")
    apply (frule_tac s="bb" and s'="s'" and t = b and t' = ba in write_same_mem_excep ; clarsimp)
   apply (frule_tac s="s" and s'="bb" and t = t and t' = b and p' = aa in mmu_translate_non_det_sat_mem_excp ; clarsimp simp: consistent0_def tlb_rel_sat_def)
  apply (rule conjI)
   apply (frule_tac s = "s" and s' = "bb" and t = "t" and t' = "b" in   mmu_translate_non_det_sat_excp ; clarsimp simp: tlb_rel_sat_def)
  by (frule_tac t= t and pa' = a and t' = b in mmu_translate_non_det_sat_pa ; clarsimp simp: tlb_rel_sat_def) +

lemma mmu_write_non_det_sat_refine:
  "\<lbrakk> mmu_write_size (val,va, sz) s = ((), s'); tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t)  ; consistent (typ_sat_tlb t) va;
        mmu_write_size (val,va, sz) t = ((), t') \<rbrakk> \<Longrightarrow>  tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t') "
  apply (clarsimp simp: tlb_rel_sat_def)
  apply (clarsimp simp: mmu_write_saturated_state)
  apply (rule conjI)
    prefer 2
    apply (frule_tac s = s and s' = s' and t = t and t' = t' in mmu_write_tlb_subset; clarsimp simp: tlb_rel_sat_def)
  by (frule_tac s="s" and s'="s'" and t="t" and t'="t'" in mmu_write_size_non_det_sat_state_trunc; clarsimp simp: tlb_rel_sat_def)

(* refinement between saturated and second abstracted model *)

lemma mmu_write_incon_set_rel:
  "\<lbrakk> saturated (typ_sat_tlb s) ;
       inconsistent_vaddrs (typ_sat_tlb s) \<subseteq> iset(set_tlb t) ;  incoherrent_vaddrs (typ_sat_tlb s) \<subseteq> iset(set_tlb t) ; ASID s = ASID r ; TTBR0 s = TTBR0 r\<rbrakk> \<Longrightarrow>
     inconsistent_vaddrs (typ_sat_tlb (r\<lparr>sat_tlb := pairunion (sat_tlb s) (the ` {e \<in> range (pt_walk (ASID r) (MEM q) (TTBR0 r)). \<not> is_fault e},
           the ` {e \<in> range (pdc_walk (ASID r) (MEM q) (TTBR0 r)). \<not> is_fault e})\<rparr>))
           \<subseteq> iset (set_tlb t) \<union> incon_comp (ASID r) (ASID r) (MEM s) (MEM q) (TTBR0 r) (TTBR0 r)"
  apply (clarsimp)
  apply (clarsimp simp: inconsistent_vaddrs_def incon_comp_def ptable_comp_def  incoherrent_vaddrs_def)
  apply (erule disjE)
   apply (drule union_asid_tlb_incon_cases)
   apply (erule disjE, clarsimp simp: asid_tlb_lookup_range_pt_walk_not_incon)
   apply (erule disjE, clarsimp simp: entry_leq_def)
    apply (erule disjE)
     apply (subgoal_tac "is_fault (pt_walk (ASID r) (MEM s) (TTBR0 r) x)")
      apply blast
     apply (clarsimp simp: pt_walk_new_fault_pt_walk_fault)
    apply (erule disjE)
     apply (subgoal_tac "the (pt_walk (ASID r) (MEM q) (TTBR0 r) xc) = the (pt_walk (ASID r) (MEM s) (TTBR0 r) x)")
      apply (case_tac "\<not> is_fault (pt_walk (ASID r) (MEM s) (TTBR0 r) x)")
  using saturatd_lookup_hit_no_fault apply fastforce
      apply blast
     apply (subgoal_tac "the (pt_walk (ASID r) (MEM q) (TTBR0 r) xc) = the (pt_walk (ASID r) (MEM q) (TTBR0 r) x)")
      apply (drule pt_walk_new_equal_pt_walk, simp add: is_fault_def)
     apply (frule  asid_tlb_lookup_range_fault_pt_walk)
     apply (drule_tac x = x in bspec; clarsimp simp: lookup_asid_tlb_hit_entry_range)
    apply (subgoal_tac "is_fault (pt_walk (ASID r) (MEM s) (TTBR0 r) x)")
     apply blast
    apply clarsimp
    apply (simp add: pt_walk_new_par_fault_pt_walk_fault)
  using  asid_tlb_lookup_range_pt_walk_not_incon apply blast
  apply (drule union_asid_pdc_incon_cases)
  apply (erule disjE, clarsimp simp: lookup_pdc_walk_not_incon)
  apply (erule disjE)
   apply clarsimp
   apply (simp add: entry_leq_def)
   apply (erule disjE)
    apply (subgoal_tac "is_fault (pdc_walk (ASID r) (MEM s) (TTBR0 r) x)")
     apply blast
    apply (clarsimp simp: pt_walk_new_fault_pde_walk_fault)
   apply (erule disjE)
    apply (subgoal_tac "the (pdc_walk (ASID r) (MEM q) (TTBR0 r) xc) = the (pdc_walk (ASID r) (MEM s) (TTBR0 r) x)")
     prefer 2
     apply (subgoal_tac "the (pdc_walk (ASID r) (MEM q) (TTBR0 r) xc) = the (pdc_walk (ASID r) (MEM q) (TTBR0 r) x)")
      apply clarsimp
      apply (drule pt_walk_new_equal_pdc_walk, simp add: is_fault_def)
     apply (frule lookup_pdc_range_fault_pt_walk)
     apply (drule_tac x = x in bspec; clarsimp simp: lookup_asid_pdc_hit_entry_range)
     apply (case_tac "\<not> is_fault (pdc_walk (ASID r) (MEM s) (TTBR0 r) x)")
      apply clarsimp
  using saturatd_lookup_pdc_hit_no_fault apply fastforce
  apply blast
  apply (subgoal_tac "the(pdc_walk (ASID r) (MEM q) (TTBR0 r) xc) = the(pdc_walk (ASID r) (MEM s) (TTBR0 r) x)" )
  apply (case_tac "is_fault (pdc_walk (ASID r) (MEM s) (TTBR0 r) x)")
  apply blast
  using saturatd_lookup_pdc_hit_no_fault apply fastforce
  apply (subgoal_tac " the (pdc_walk (ASID r) (MEM q) (TTBR0 r) xc) =  the(pdc_walk (ASID r) (MEM q) (TTBR0 r) x)")
    apply clarsimp
    apply (simp add: pt_walk_partial_full_pdc_walk_eq)
   apply (meson lookup_asid_pdc_hit_entry_range lookup_pdc_range_fault_pt_walk
               lookup_pdc_range_pt_walk_hit)
  using lookup_pdc_walk_not_incon by blast

lemma  mmu_write_asid_ptcomp_rel:
  "\<lbrakk>saturated (typ_sat_tlb s) ; ASID t = ASID s; MEM t = MEM r; TTBR0 t = TTBR0 s ;
       inconsistent_vaddrs (typ_sat_tlb s) \<subseteq> iset (set_tlb q) ;  incoherrent_vaddrs (typ_sat_tlb s) \<subseteq> iset(set_tlb q)\<rbrakk> \<Longrightarrow>
      incoherrent_vaddrs  (typ_sat_tlb (t\<lparr>sat_tlb := pairunion (sat_tlb s) (the ` {e \<in> range (pt_walk (ASID t) (MEM r) (TTBR0 t)). \<not> is_fault e},
          the ` {e \<in> range (pdc_walk (ASID t) (MEM r) (TTBR0 t)). \<not> is_fault e})\<rparr>)) \<subseteq> iset (set_tlb q) \<union> incon_comp (ASID t) (ASID t) (MEM s) (MEM r) (TTBR0 t) (TTBR0 t)"
  apply rule
  apply (clarsimp simp: incoherrent_vaddrs_def  inconsistent_vaddrs_def )
  apply (erule disjE; clarsimp)
   apply (drule lookup_asid_tlb_hit_union_cases')
   apply (erule disjE)
    apply (clarsimp simp: incon_comp_def ptable_comp_def entry_leq_def Let_def)
    apply (subgoal_tac "is_fault (pt_walk (ASID s) (MEM s) (TTBR0 s) x)")
     apply blast
    apply (metis (mono_tags, hide_lams) pt_walk_new_equal_pt_walk pt_walk_new_fault_pt_walk_fault pt_walk_new_par_fault_pt_walk_fault)
   apply  (clarsimp simp: asid_tlb_lookup_miss_is_fault_intro)
  apply (drule lookup_asid_pdc_hit_union_cases')
  apply (erule disjE)
   apply (clarsimp simp: incon_comp_def ptable_comp_def entry_leq_def Let_def)
   apply (subgoal_tac "is_fault (pdc_walk (ASID s) (MEM s) (TTBR0 s) x)")
    apply blast
   apply (metis (mono_tags, hide_lams) pt_walk_new_equal_pdc_walk pt_walk_new_fault_pde_walk_fault pt_walk_partial_full_pdc_walk_eq)
  by  (clarsimp simp: lookup_pdc_miss_is_fault_intro)

lemma mmu_write_sat_incon_refine:
  "\<lbrakk> mmu_write_size (val,va, sz) s = ((), s');  mmu_write_size (val,va, sz) t = ((), t'); va \<notin> iset (set_tlb t);
            tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t)  \<rbrakk> \<Longrightarrow>
                                  tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  apply (frule_tac s = s in tlb_rel_abs_consistent; clarsimp )
  apply (frule tlb_rel_absD, clarsimp)
  apply (clarsimp simp: mmu_write_size_sat_tlb_state_ext_def  mmu_write_size_set_tlb_state_ext_def)
  apply (cases "mmu_translate va s", cases "mmu_translate va t", clarsimp)
  apply (frule_tac t=t and pa'= aa and t' = ba in mmu_translate_sat_incon_refine; clarsimp)
  apply (clarsimp simp: tlb_rel_abs_def)
  apply (subgoal_tac "exception b = exception ba")
   prefer 2 apply (case_tac b , case_tac ba , clarsimp simp: state.defs)
  apply (clarsimp split: if_split_asm)
  apply (case_tac "write'mem1 (val, aa, sz) b " , case_tac "write'mem1 (val, aa, sz) ba" , clarsimp simp: Let_def)
  apply (subgoal_tac "state.truncate bb = state.truncate bc")
   prefer 2
  using write_mem_state_trun_equal apply blast
  apply (rule conjI , clarsimp simp: state.defs)
  apply (subgoal_tac "MEM bb = MEM bc  \<and> MEM s = MEM b" , simp)
   apply (subgoal_tac "ASID s = ASID b \<and> TTBR0 s = TTBR0 b" , simp)
    apply (subgoal_tac "saturated (typ_sat_tlb b)")
     prefer 2 apply blast
    prefer 2 using mmu_sat_eq_asid_root_mem apply blast
   prefer 2
   apply (rule conjI)
    apply (clarsimp simp: state.defs)
  using mmu_sat_eq_asid_root_mem
   apply blast
  apply (subgoal_tac "ASID b = ASID bb \<and> TTBR0 b = TTBR0 bb")
   apply (rule conjI)
    apply (clarsimp simp: saturated_def)
   apply (simp only: incon_addrs_def)
   apply simp
   apply (rule conjI)
    apply (drule_tac s = b and t = ba and q = bc and r = bb in mmu_write_incon_set_rel; clarsimp)
   apply (rule conjI)
    apply (frule_tac t = bb and r = bc and q = ba and s = b in  mmu_write_asid_ptcomp_rel ; clarsimp simp: )
   prefer 2
   apply (clarsimp simp: write'mem1_def raise'exception_def split: if_split_asm)
  apply (rule conjI)
   apply (clarsimp simp: global_range_def)
   apply (rule conjI)
    apply (simp only: global_entries_union)
    apply clarsimp
    apply fastforce
   apply (simp only: global_entries_union_pdc)
   apply clarsimp
   apply (rule conjI)
    apply force
  using global_entr_pdc_subset_global_entries apply fastforce
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp: non_global_to_global [symmetric])
   apply (subgoal_tac "lookup'' (non_global_entries (fst (sat_tlb b) \<union> the ` {e \<in> range (pt_walk (ASID t) (MEM bc) (TTBR0 bb)). \<not> is_fault e})) a v =
                       lookup'' (non_global_entries (fst (sat_tlb b))) a v")
    apply force
   apply (rule lookup_non_global_union_asid_unequal, simp)
  apply (clarsimp simp: non_global_to_global_pdc [symmetric])
  apply (subgoal_tac "lookup_pdc (non_global_entries_pdc (snd (sat_tlb b) \<union> the ` {e \<in> range (pdc_walk (ASID t) (MEM bc) (TTBR0 bb)). \<not> is_fault e})) a v =
                         lookup_pdc (non_global_entries_pdc (snd (sat_tlb b))) a v")
   apply force
  by (rule lookup_non_global_union_asid_unequal_pdc, simp)

(* refinement for read theroems *)

lemma  mem_read1_consistent_tlb_rel_non_det:
  " \<lbrakk>mem_read1 (a, sz) s = (val, s');   mem_read1 (a, sz) t = (val', t');
               consistent0' (MEM t) (ASID t) (TTBR0 t) (fst (sat_tlb t)) (snd (sat_tlb t)) va; tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t)\<rbrakk>
              \<Longrightarrow> consistent0' (MEM t') (ASID t') (TTBR0 t') (fst (sat_tlb t')) (snd (sat_tlb t')) va \<and> tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t')"
   apply (rule conjI)
   apply (subgoal_tac "MEM t = MEM t' \<and> ASID t = ASID t' \<and> TTBR0 t = TTBR0 t' \<and> sat_tlb t = sat_tlb t'")
    apply (clarsimp simp: consistent0_def)
   prefer 2
   apply (subgoal_tac " exception s' =  exception t'")
    apply (drule mem1_read_exception)
    apply (drule mem1_read_exception)
    apply (clarsimp simp: tlb_rel_sat_def)
    apply (clarsimp simp: saturated_def  state.truncate_def)
    apply (cases s', cases t')
    apply clarsimp
   apply (subgoal_tac "MEM s = MEM t \<and> exception s = exception t")
    apply (thin_tac "consistent0' (MEM t) (ASID t) (TTBR0 t) (fst (sat_tlb t)) (snd (sat_tlb t)) va")
    apply (thin_tac "tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t)")
    apply (clarsimp simp: mem_read1_def)
    apply (clarsimp split: if_split_asm)
        apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
       apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
      apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
     subgoal
     by (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
    apply (clarsimp simp: raise'exception_def split: option.splits if_split_asm)
   apply (clarsimp simp: tlb_rel_sat_def state.defs)
  apply (drule mem1_read_exception)
  apply (drule mem1_read_exception)
  apply (cases t, cases t' , clarsimp)
   done

lemma mmu_read_non_det_sat_rel_cons:
  "\<lbrakk> mmu_read_size (va, sz) s = (val, s'); tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t);
         consistent (typ_sat_tlb t) va; mmu_read_size (va, sz) t = (val', t') \<rbrakk> \<Longrightarrow>
                     consistent (typ_sat_tlb t') va \<and>  tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t') "
  apply (clarsimp simp: mmu_read_size_sat_tlb_state_ext_def   mmu_read_size_non_det_tlb_state_ext_def Let_def)
  apply (cases "mmu_translate va s", cases "mmu_translate va t", clarsimp)
  apply (drule_tac t = t in mmu_translate_non_det_sat_refine ; clarsimp simp: Let_def mem_read1_consistent_tlb_rel_non_det)
  done

lemma same_mem_read_equal:
  "\<lbrakk>MEM s = MEM t; mem_read1 (pa, sz) s = (val, s'); mem_read1 (pa, sz) t = (val', t')  \<rbrakk> \<Longrightarrow> val = val'"
  apply (clarsimp simp: mem_read1_def)
  apply (clarsimp split: if_split_asm)
      apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
     apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
    apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
  subgoal
    by (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
  apply (clarsimp simp: raise'exception_def split: option.splits if_split_asm)
    done

lemma mmu_read_non_det_sat_refine:
  "\<lbrakk>mmu_read_size (va, sz) s = (val, s');  mmu_read_size (va, sz) t = (val', t');
              tlb_rel_sat (typ_non_det_tlb s) (typ_sat_tlb t); consistent (typ_sat_tlb t) va\<rbrakk> \<Longrightarrow>
                     val = val' \<and> tlb_rel_sat (typ_non_det_tlb s') (typ_sat_tlb t') \<and> consistent (typ_sat_tlb t') va  "
  apply (rule conjI)
   apply (clarsimp simp: mmu_read_size_sat_tlb_state_ext_def   mmu_read_size_non_det_tlb_state_ext_def Let_def)
   apply (cases "mmu_translate va s", cases "mmu_translate va t", clarsimp)
   apply (rename_tac pa s'' pa' t'')
   apply (subgoal_tac "pa = pa'", clarsimp)
    apply (subgoal_tac "MEM s'' = MEM t''")
     apply (clarsimp simp: same_mem_read_equal)
  using mmu_translate_non_det_sat_mem_excp apply force
  using mmu_translate_non_det_sat_pa apply force
  apply (frule_tac t = t and t' =t' in  mmu_read_non_det_sat_rel_cons; simp)
  done

lemma mmu_read_sat_const_inter [simp]:
  "saturated (typ_sat_tlb s) \<Longrightarrow> fst(sat_tlb (snd (mmu_read_size v s))) = fst(sat_tlb s) \<and>
       snd(sat_tlb (snd (mmu_read_size v s))) = snd(sat_tlb s)"
   by (clarsimp simp: mmu_read_size_sat_tlb_state_ext_def split_def Let_def
                      mem_read1_def raise'exception_def  split: if_split_asm)

lemma  mem_read1_consistent_tlb_rel_incon:
  "\<lbrakk>mem_read1 (a, sz) s = (val, s'); mem_read1 (a, sz) t = (val', t');
             va \<notin> iset (set_tlb t); tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t)\<rbrakk>
              \<Longrightarrow>  va \<notin> iset (set_tlb t') \<and>  tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t')"
  apply (rule conjI)
   apply (subgoal_tac "ASID t = ASID t' \<and> iset (set_tlb t) = iset (set_tlb t')")
    apply clarsimp
   apply (drule mem1_read_exception)
   apply (drule mem1_read_exception)
   apply (cases t, cases t')
   apply clarsimp
  apply (subgoal_tac "exception s' =  exception t'")
   apply (drule mem1_read_exception)
   apply (drule mem1_read_exception)
   apply (clarsimp simp: tlb_rel_abs_def)
   apply (rule conjI)
    apply (clarsimp simp: state.defs)
    apply (cases s', cases t')
    apply clarsimp
   apply (rule conjI)
    apply (clarsimp simp:  saturated_def)
   apply (rule conjI)
    apply (clarsimp simp: incon_addrs_def inconsistent_vaddrs_def incoherrent_vaddrs_def)
    apply (cases s', cases t')
    apply clarsimp
   apply (rule conjI)
    apply (clarsimp simp: global_range_def)
    apply (cases s', cases t')
    apply clarsimp
   apply (cases s', cases t')
   apply clarsimp
  apply (subgoal_tac "MEM s = MEM t \<and> exception s = exception t")
   apply (thin_tac " va \<notin> iset (set_tlb t)")
   apply (thin_tac " tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t)")
   apply (clarsimp simp: mem_read1_def)
   apply (clarsimp split: if_split_asm)
       apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
      apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
     apply (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
    subgoal
    by (clarsimp simp: mem1_def raise'exception_def split: option.splits if_split_asm)
   apply (clarsimp simp: raise'exception_def split: option.splits if_split_asm)
  apply (clarsimp simp: tlb_rel_abs_def state.defs)
  done

find_consts "'a option set \<Rightarrow> 'a option"

lemma mmu_read_sat_incon_rel_con:
  "\<lbrakk> mmu_read_size (va, sz) s = (val, s'); tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t);
         va \<notin> iset (set_tlb t); mmu_read_size (va, sz) t = (val', t') \<rbrakk> \<Longrightarrow>
                     va \<notin> iset (set_tlb t') \<and>  tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t') "
  apply (clarsimp simp: mmu_read_size_sat_tlb_state_ext_def  mmu_read_size_set_tlb_state_ext_def Let_def)
  apply (cases "mmu_translate va s", cases "mmu_translate va t", clarsimp)
  apply (drule_tac t = t and pa' = aa  and t' = ba in mmu_translate_sat_incon_refine ; clarsimp simp: Let_def mem_read1_consistent_tlb_rel_incon)
  done

lemma mmu_read_sat_incon_refine:
  "\<lbrakk> mmu_read_size (va, sz) s = (val, s'); mmu_read_size (va, sz) t = (val', t');
        tlb_rel_abs (typ_sat_tlb s) (typ_set_tlb t); va \<notin> iset (set_tlb t)  \<rbrakk> \<Longrightarrow>
                    val = val' \<and> tlb_rel_abs (typ_sat_tlb s') (typ_set_tlb t') \<and> va \<notin> iset (set_tlb t')"
  apply (rule conjI)
   apply (clarsimp simp: mmu_read_size_sat_tlb_state_ext_def  mmu_read_size_set_tlb_state_ext_def Let_def)
   apply (cases "mmu_translate va s", cases "mmu_translate va t", clarsimp)
   apply (rename_tac pa s'' pa' t'')
   apply (subgoal_tac "pa = pa'", clarsimp)
    apply (subgoal_tac "MEM s'' = MEM t''")
     apply (clarsimp simp: same_mem_read_equal)
    using mmu_translate_sat_incon_mem_excp apply force
   using mmu_translate_sat_incon_refine apply force
   by (frule_tac t = t and t' =t' in  mmu_read_sat_incon_rel_con; simp)

end


theory "Env-Set-Cpo"
imports Launchbury.Env "Set-Cpo"
begin

lemma cont_edom[THEN cont_compose, simp, cont2cont]:
  "cont (\<lambda> f. edom f)"
  apply (rule set_contI)
  apply (auto simp add: edom_def)
  apply (metis ch2ch_fun lub_eq_bottom_iff lub_fun)
  apply (metis ch2ch_fun lub_eq_bottom_iff lub_fun)
  done

end


(*  Title:      JinjaThreads/Common/WellForm.thy
    Author:     Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/WellForm.thy by Tobias Nipkow
*)

section \<open>Generic Well-formedness of programs\<close>

theory WellForm
imports
  SystemClasses
  ExternalCall
begin

text \<open>\noindent This theory defines global well-formedness conditions
for programs but does not look inside method bodies.  Hence it works
for both Jinja and JVM programs. Well-typing of expressions is defined
elsewhere (in theory \<open>WellType\<close>).

Because JinjaThreads does not have method overloading, its policy for method
overriding is the classical one: \emph{covariant in the result type
but contravariant in the argument types.} This means the result type
of the overriding method becomes more specific, the argument types
become more general.
\<close>

type_synonym 'm wf_mdecl_test = "'m prog \<Rightarrow> cname \<Rightarrow> 'm mdecl \<Rightarrow> bool"

definition wf_fdecl :: "'m prog \<Rightarrow> fdecl \<Rightarrow> bool"
where "wf_fdecl P \<equiv> \<lambda>(F,T,fm). is_type P T"

definition wf_mdecl :: "'m wf_mdecl_test \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> 'm mdecl' \<Rightarrow> bool" where
  "wf_mdecl wf_md P C \<equiv>
  \<lambda>(M,Ts,T,m). (\<forall>T\<in>set Ts. is_type P T) \<and> is_type P T \<and>
    (case m of Native \<Rightarrow> C\<bullet>M(Ts) :: T | \<lfloor>mb\<rfloor> \<Rightarrow> wf_md P C (M,Ts,T,mb))"

fun wf_overriding :: "'m prog \<Rightarrow> cname \<Rightarrow> 'm mdecl' \<Rightarrow> bool"
where
  "wf_overriding P D (M,Ts,T,m) =
  (\<forall>D' Ts' T' m'. P \<turnstile> D sees M:Ts' \<rightarrow> T' = m' in D' \<longrightarrow> P \<turnstile> Ts' [\<le>] Ts \<and> P \<turnstile> T \<le> T')"

definition wf_cdecl :: "'m wf_mdecl_test \<Rightarrow> 'm prog \<Rightarrow> 'm cdecl \<Rightarrow> bool"
where
  "wf_cdecl wf_md P  \<equiv>  \<lambda>(C,(D,fs,ms)).
  (\<forall>f\<in>set fs. wf_fdecl P f) \<and> distinct_fst fs \<and>
  (\<forall>m\<in>set ms. wf_mdecl wf_md P C m) \<and>
  distinct_fst ms \<and>
  (C \<noteq> Object \<longrightarrow>
   is_class P D \<and> \<not> P \<turnstile> D \<preceq>\<^sup>* C \<and>
   (\<forall>m\<in>set ms. wf_overriding P D m)) \<and>
  (C = Thread \<longrightarrow> (\<exists>m. (run, [], Void, m) \<in> set ms))"

definition wf_prog :: "'m wf_mdecl_test \<Rightarrow> 'm prog \<Rightarrow> bool"
where
  "wf_prog wf_md P \<longleftrightarrow> wf_syscls P \<and> distinct_fst (classes P) \<and> (\<forall>c \<in> set (classes P). wf_cdecl wf_md P c)"

lemma wf_prog_def2:
  "wf_prog wf_md P \<longleftrightarrow> wf_syscls P \<and> (\<forall>C rest. class P C = \<lfloor>rest\<rfloor> \<longrightarrow> wf_cdecl wf_md P (C, rest)) \<and> distinct_fst (classes P)"
by(cases P)(auto simp add: wf_prog_def dest: map_of_SomeD map_of_SomeI)

subsection\<open>Well-formedness lemmas\<close>

lemma wf_prog_wf_syscls: "wf_prog wf_md P \<Longrightarrow> wf_syscls P"
by(simp add: wf_prog_def)

lemma class_wf:
  "\<lbrakk>class P C = Some c; wf_prog wf_md P\<rbrakk> \<Longrightarrow> wf_cdecl wf_md P (C,c)"
by (cases P) (fastforce dest: map_of_SomeD simp add: wf_prog_def)

lemma [simp]:
  assumes "wf_prog wf_md P"
  shows is_class_Object: "is_class P Object"
  and is_class_Thread: "is_class P Thread"
using wf_prog_wf_syscls[OF assms] by simp_all

lemma xcpt_subcls_Throwable:
  "\<lbrakk> C \<in> sys_xcpts; wf_prog wf_md P \<rbrakk> \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* Throwable"
by(simp add: wf_prog_wf_syscls wf_syscls_xcpt_subcls_Throwable)

lemma is_class_Throwable:
  "wf_prog wf_md P \<Longrightarrow> is_class P Throwable"
by(rule wf_prog_wf_syscls wf_syscls_is_class_Throwable)+

lemma is_class_sub_Throwable:
  "\<lbrakk> wf_prog wf_md P; P \<turnstile> C \<preceq>\<^sup>* Throwable \<rbrakk> \<Longrightarrow> is_class P C"
by(rule wf_syscls_is_class_sub_Throwable[OF wf_prog_wf_syscls])

lemma is_class_xcpt:
  "\<lbrakk> C \<in> sys_xcpts; wf_prog wf_md P \<rbrakk> \<Longrightarrow> is_class P C"
by(rule wf_syscls_is_class_xcpt[OF _ wf_prog_wf_syscls])

context heap_base begin
lemma wf_preallocatedE:
  assumes "wf_prog wf_md P"
  and "preallocated h"
  and "C \<in> sys_xcpts"
  obtains "typeof_addr h (addr_of_sys_xcpt C) = \<lfloor>Class_type C\<rfloor>" "P \<turnstile> C \<preceq>\<^sup>* Throwable"
proof -
  from \<open>preallocated h\<close> \<open>C \<in> sys_xcpts\<close> have "typeof_addr h (addr_of_sys_xcpt C) = \<lfloor>Class_type C\<rfloor>"
    by(rule typeof_addr_sys_xcp)
  moreover from \<open>C \<in> sys_xcpts\<close> \<open>wf_prog wf_md P\<close> have "P \<turnstile> C \<preceq>\<^sup>* Throwable" by(rule xcpt_subcls_Throwable)
  ultimately show thesis by(rule that)
qed

lemma wf_preallocatedD:
  assumes "wf_prog wf_md P"
  and "preallocated h"
  and "C \<in> sys_xcpts"
  shows "typeof_addr h (addr_of_sys_xcpt C) = \<lfloor>Class_type C\<rfloor> \<and> P \<turnstile> C \<preceq>\<^sup>* Throwable"
using assms
by(rule wf_preallocatedE) blast

end

lemma (in heap_conf) hconf_start_heap:
  "wf_prog wf_md P \<Longrightarrow> hconf start_heap"
unfolding start_heap_def start_heap_data_def initialization_list_def sys_xcpts_list_def
using hconf_empty
by -(simp add: create_initial_object_simps del: hconf_empty, clarsimp split: prod.split elim!: not_empty_pairE simp del: hconf_empty, drule (1) allocate_Eps, drule (1) hconf_allocate_mono, simp add: is_class_xcpt)+

lemma subcls1_wfD:
  "\<lbrakk> P \<turnstile> C \<prec>\<^sup>1 D; wf_prog wf_md P \<rbrakk> \<Longrightarrow> D \<noteq> C \<and> \<not> (subcls1 P)\<^sup>+\<^sup>+ D C"
apply( frule tranclp.r_into_trancl[where r="subcls1 P"])
apply( drule subcls1D)
apply(clarify)
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def)
apply(rule conjI)
 apply(force)
apply(unfold reflclp_tranclp[symmetric, where r="subcls1 P"])
apply(blast)
done

lemma wf_cdecl_supD:
  "\<lbrakk>wf_cdecl wf_md P (C,D,r); C \<noteq> Object\<rbrakk> \<Longrightarrow> is_class P D"
(*<*)by (auto simp: wf_cdecl_def)(*>*)

lemma subcls_asym:
  "\<lbrakk> wf_prog wf_md P; (subcls1 P)\<^sup>+\<^sup>+ C D \<rbrakk> \<Longrightarrow> \<not> (subcls1 P)\<^sup>+\<^sup>+ D C"
(*<*)
apply(erule tranclp.cases)
apply(fast dest!: subcls1_wfD )
apply(fast dest!: subcls1_wfD intro: tranclp_trans)
done
(*>*)

lemma subcls_irrefl:
  "\<lbrakk> wf_prog wf_md P; (subcls1 P)\<^sup>+\<^sup>+ C D\<rbrakk> \<Longrightarrow> C \<noteq> D"
(*<*)
apply (erule tranclp_trans_induct)
apply  (auto dest: subcls1_wfD subcls_asym)
done
(*>*)

lemma acyclicP_def:
  "acyclicP r \<longleftrightarrow> (\<forall>x. \<not> r^++ x x)"
  unfolding acyclic_def trancl_def
by(auto)

lemma acyclic_subcls1:
  "wf_prog wf_md P \<Longrightarrow> acyclicP (subcls1 P)"
by(unfold acyclicP_def)(fast dest: subcls_irrefl)

lemma finite_conversep: "finite {(x, y). r\<inverse>\<inverse> x y} = finite {(x, y). r x y}"
by(subst finite_converse[unfolded converse_unfold, symmetric]) simp

lemma acyclicP_wf_subcls1:
  "acyclicP (subcls1 P) \<Longrightarrow> wfP ((subcls1 P)\<inverse>\<inverse>)"
unfolding wfP_def
by(rule finite_acyclic_wf)(simp_all only: finite_conversep finite_subcls1 acyclicP_converse)

lemma wf_subcls1:
  "wf_prog wf_md P \<Longrightarrow> wfP ((subcls1 P)\<inverse>\<inverse>)"
by(rule acyclicP_wf_subcls1)(rule acyclic_subcls1)

lemma single_valued_subcls1:
  "wf_prog wf_md G \<Longrightarrow> single_valuedp (subcls1 G)"
(*<*)
by(auto simp:wf_prog_def distinct_fst_def single_valuedp_def dest!:subcls1D)
(*>*)

lemma subcls_induct:
  "\<lbrakk> wf_prog wf_md P; \<And>C. \<forall>D. (subcls1 P)\<^sup>+\<^sup>+ C D \<longrightarrow> Q D \<Longrightarrow> Q C \<rbrakk> \<Longrightarrow> Q C"
(*<*)
  (is "?A \<Longrightarrow> PROP ?P \<Longrightarrow> _")
proof -
  assume p: "PROP ?P"
  assume ?A thus ?thesis apply -
apply(drule wf_subcls1)
apply(drule wfP_trancl)
apply(simp only: tranclp_converse)
apply(erule_tac a = C in wfP_induct)
apply(rule p)
apply(auto)
done
qed
(*>*)

lemma subcls1_induct_aux:
  "\<lbrakk> is_class P C; wf_prog wf_md P; Q Object;
    \<And>C D fs ms.
    \<lbrakk> C \<noteq> Object; is_class P C; class P C = Some (D,fs,ms) \<and>
      wf_cdecl wf_md P (C,D,fs,ms) \<and> P \<turnstile> C \<prec>\<^sup>1 D \<and> is_class P D \<and> Q D\<rbrakk> \<Longrightarrow> Q C \<rbrakk>
  \<Longrightarrow> Q C"
(*<*)
  (is "?A \<Longrightarrow> ?B \<Longrightarrow> ?C \<Longrightarrow> PROP ?P \<Longrightarrow> _")
proof -
  assume p: "PROP ?P"
  assume ?A ?B ?C thus ?thesis apply -
apply(unfold is_class_def)
apply( rule impE)
prefer 2
apply(   assumption)
prefer 2
apply(  assumption)
apply( erule thin_rl)
apply( rule subcls_induct)
apply(  assumption)
apply( rule impI)
apply( case_tac "C = Object")
apply(  fast)
apply safe
apply( frule (1) class_wf)
apply( frule (1) wf_cdecl_supD)

apply( subgoal_tac "P \<turnstile> C \<prec>\<^sup>1 a")
apply( erule_tac [2] subcls1I)
apply(  rule p)
apply (unfold is_class_def)
apply auto
done
qed
(*>*)

lemma subcls1_induct [consumes 2, case_names Object Subcls]:
  "\<lbrakk> wf_prog wf_md P; is_class P C; Q Object;
    \<And>C D. \<lbrakk>C \<noteq> Object; P \<turnstile> C \<prec>\<^sup>1 D; is_class P D; Q D\<rbrakk> \<Longrightarrow> Q C \<rbrakk>
  \<Longrightarrow> Q C"
(*<*)
  apply (erule subcls1_induct_aux, assumption, assumption)
  apply blast
  done
(*>*)

lemma subcls_C_Object:
  "\<lbrakk> is_class P C; wf_prog wf_md P \<rbrakk> \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* Object"
(*<*)
apply(erule (1) subcls1_induct)
 apply( fast)
apply(erule (1) converse_rtranclp_into_rtranclp)
done
(*>*)

lemma converse_subcls_is_class:
  assumes wf: "wf_prog wf_md P"
  shows "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* D; is_class P C \<rbrakk> \<Longrightarrow> is_class P D"
proof(induct rule: rtranclp_induct)
  assume "is_class P C"
  thus "is_class P C" .
next
  fix D E
  assume PDE: "P \<turnstile> D \<prec>\<^sup>1 E"
    and IH: "is_class P C \<Longrightarrow> is_class P D"
    and iPC: "is_class P C"
  have "is_class P D" by (rule IH[OF iPC])
  with PDE obtain fsD MsD where classD: "class P D = \<lfloor>(E, fsD, MsD)\<rfloor>"
    by(auto simp add: is_class_def elim!: subcls1.cases)
  thus "is_class P E" using wf PDE
    by(auto elim!: subcls1.cases dest: class_wf simp: wf_cdecl_def)
qed

lemma is_class_is_subcls:
  "wf_prog m P \<Longrightarrow> is_class P C = P \<turnstile> C \<preceq>\<^sup>* Object"
(*<*)by (fastforce simp:is_class_def
                  elim: subcls_C_Object converse_rtranclpE subcls1I
                  dest: subcls1D)
(*>*)

lemma subcls_antisym:
  "\<lbrakk>wf_prog m P; P \<turnstile> C \<preceq>\<^sup>* D; P \<turnstile> D \<preceq>\<^sup>* C\<rbrakk> \<Longrightarrow> C = D"
apply(drule acyclic_subcls1)
apply(drule acyclic_impl_antisym_rtrancl)
apply(drule antisymD)
apply(unfold Transitive_Closure.rtrancl_def)
apply(auto)
done

lemma is_type_pTs:
  "\<lbrakk> wf_prog wf_md P; class P C = \<lfloor>(S,fs,ms)\<rfloor>; (M,Ts,T,m) \<in> set ms \<rbrakk> \<Longrightarrow> set Ts \<subseteq> types P"
by(fastforce dest: class_wf simp add: wf_cdecl_def wf_mdecl_def)

lemma widen_asym_1:
  assumes wfP: "wf_prog wf_md P"
  shows "P \<turnstile> C \<le> D \<Longrightarrow> C = D \<or> \<not> (P \<turnstile> D \<le> C)"
proof (erule widen.induct)
  fix T
  show "T = T \<or> \<not> (P \<turnstile> T \<le> T)" by simp
next
  fix C D
  assume CscD: "P \<turnstile> C \<preceq>\<^sup>* D"
  then have CpscD: "C = D \<or> (C \<noteq> D \<and> (subcls1 P)\<^sup>+\<^sup>+ C D)" by (simp add: rtranclpD)
  { assume "P \<turnstile> D \<preceq>\<^sup>* C"
    then have DpscC: "D = C \<or> (D \<noteq> C \<and> (subcls1 P)\<^sup>+\<^sup>+ D C)" by (simp add: rtranclpD)
    { assume "(subcls1 P)\<^sup>+\<^sup>+ D C"
      with wfP have CnscD: "\<not> (subcls1 P)\<^sup>+\<^sup>+ C D" by (rule subcls_asym)
      with CpscD have "C = D" by simp
    }
    with DpscC have "C = D" by blast
  }
  hence "Class C = Class D \<or> \<not> (P \<turnstile> D \<preceq>\<^sup>* C)" by blast
  thus "Class C = Class D \<or> \<not> P \<turnstile> Class D \<le> Class C" by simp
next
  fix C
  show "NT = Class C \<or> \<not> P \<turnstile> Class C \<le> NT" by simp
next
  fix A
  { assume "P \<turnstile> A\<lfloor>\<rceil> \<le> NT"
    hence "A\<lfloor>\<rceil> = NT" by fastforce
    hence "False" by simp }
  hence "\<not> (P \<turnstile> A\<lfloor>\<rceil> \<le> NT)" by blast
  thus "NT = A\<lfloor>\<rceil> \<or> \<not> P \<turnstile> A\<lfloor>\<rceil> \<le> NT" by simp
next
  fix A
  show "A\<lfloor>\<rceil> = Class Object \<or> \<not> P \<turnstile> Class Object \<le> A\<lfloor>\<rceil>"
    by(auto dest: Object_widen)
next
  fix A B
  assume AsU: "P \<turnstile> A \<le> B" and BnpscA: "A = B \<or> \<not> P \<turnstile> B \<le> A"
  { assume "P \<turnstile> B\<lfloor>\<rceil> \<le> A\<lfloor>\<rceil>"
    hence "P \<turnstile> B \<le> A" by (auto dest: Array_Array_widen)
    with BnpscA have "A = B" by blast
    hence "A\<lfloor>\<rceil> = B\<lfloor>\<rceil>" by simp }
  thus "A\<lfloor>\<rceil> = B\<lfloor>\<rceil> \<or> \<not> P \<turnstile> B\<lfloor>\<rceil> \<le> A\<lfloor>\<rceil>" by blast
qed

lemma widen_asym: "\<lbrakk> wf_prog wf_md P; P \<turnstile> C \<le> D; C \<noteq> D \<rbrakk> \<Longrightarrow> \<not> (P \<turnstile> D \<le> C)"
proof -
  assume wfP: "wf_prog wf_md P" and CsD: "P \<turnstile> C \<le> D" and CneqD: "C \<noteq> D"
  from wfP CsD have "C = D \<or> \<not> (P \<turnstile> D \<le> C)" by (rule widen_asym_1)
  with CneqD show ?thesis by simp
qed

lemma widen_antisym:
  "\<lbrakk> wf_prog m P; P \<turnstile> T \<le> U; P \<turnstile> U \<le> T \<rbrakk> \<Longrightarrow> T = U"
by(auto dest: widen_asym)

lemma widen_C_Object: "\<lbrakk> wf_prog wf_md P; is_class P C \<rbrakk> \<Longrightarrow> P \<turnstile> Class C \<le> Class Object"
by(simp add: subcls_C_Object)

lemma is_refType_widen_Object:
  assumes wfP: "wf_prog wfmc P"
  shows "\<lbrakk> is_type P A; is_refT A \<rbrakk> \<Longrightarrow> P \<turnstile> A \<le> Class Object"
by(induct A)(auto elim: refTE intro: subcls_C_Object[OF _ wfP] widen_array_object)

lemma is_lub_unique:
  assumes wf: "wf_prog wf_md P"
  shows "\<lbrakk> P \<turnstile> lub(U, V) = T; P \<turnstile> lub(U, V) = T' \<rbrakk> \<Longrightarrow> T = T'"
by(auto elim!: is_lub.cases intro: widen_antisym[OF wf])

subsection\<open>Well-formedness and method lookup\<close>

lemma sees_wf_mdecl:
  "\<lbrakk> wf_prog wf_md P; P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<rbrakk> \<Longrightarrow> wf_mdecl wf_md P D (M,Ts,T,m)"
(*<*)
apply(drule visible_method_exists)
apply(clarify)
apply(drule class_wf, assumption)
apply(drule map_of_SomeD)
apply(auto simp add: wf_cdecl_def)
done
(*>*)

lemma sees_method_mono [rule_format (no_asm)]:
  "\<lbrakk> P \<turnstile> C' \<preceq>\<^sup>* C; wf_prog wf_md P \<rbrakk> \<Longrightarrow>
  \<forall>D Ts T m. P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<longrightarrow>
     (\<exists>D' Ts' T' m'. P \<turnstile> C' sees M:Ts'\<rightarrow>T' = m' in D' \<and> P \<turnstile> Ts [\<le>] Ts' \<and> P \<turnstile> T' \<le> T)"
apply( drule rtranclpD)
apply( erule disjE)
apply(  fastforce intro: widen_refl widens_refl)
apply( erule conjE)
apply( erule tranclp_trans_induct)
prefer 2
apply(  clarify)
apply(  drule spec, drule spec, drule spec, drule spec, erule (1) impE)
apply clarify
apply(  fast elim: widen_trans widens_trans)
apply( clarify)
apply( drule subcls1D)
apply( clarify)
apply(clarsimp simp:Method_def)
apply(frule (2) sees_methods_rec)
apply(rule refl)
apply(case_tac "map_of ms M")
apply(rule_tac x = D in exI)
apply(rule_tac x = Ts in exI)
apply(rule_tac x = T in exI)
apply(clarsimp simp add: widens_refl)
apply(rule_tac x = m in exI)
apply(fastforce simp add:map_add_def split:option.split)
apply clarsimp
apply(rename_tac Ts' T' m')
apply( drule (1) class_wf)
apply( unfold wf_cdecl_def Method_def)
apply( frule map_of_SomeD)
apply(clarsimp)
apply(drule (1) bspec)+
apply clarsimp
apply(erule_tac x=D in allE)
apply(erule_tac x=Ts in allE)
apply(rotate_tac -1)
apply(erule_tac x=T in allE)
apply(fastforce simp:map_add_def Method_def split:option.split)
done
(*>*)

lemma sees_method_mono2:
  "\<lbrakk> P \<turnstile> C' \<preceq>\<^sup>* C; wf_prog wf_md P;
     P \<turnstile> C sees M:Ts\<rightarrow>T = m in D; P \<turnstile> C' sees M:Ts'\<rightarrow>T' = m' in D' \<rbrakk>
  \<Longrightarrow> P \<turnstile> Ts [\<le>] Ts' \<and> P \<turnstile> T' \<le> T"
(*<*)by(blast dest:sees_method_mono sees_method_fun)(*>*)

lemma mdecls_visible:
  assumes wf: "wf_prog wf_md P" and "class": "is_class P C"
  shows "\<And>D fs ms. class P C = Some(D,fs,ms)
         \<Longrightarrow> \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> (\<forall>(M,Ts,T,m) \<in> set ms. Mm M = Some((Ts,T,m),C))"
using wf "class"
proof (induct rule:subcls1_induct)
  case Object
  with wf have "distinct_fst ms"
    by(auto dest: class_wf simp add: wf_cdecl_def)
  with Object show ?case by(fastforce intro!: sees_methods_Object map_of_SomeI)
next
  case Subcls
  with wf have "distinct_fst ms"
    by(auto dest: class_wf simp add: wf_cdecl_def)
  with Subcls show ?case
    by(fastforce elim:sees_methods_rec dest:subcls1D map_of_SomeI
                simp:is_class_def)
qed

lemma mdecl_visible:
  assumes wf: "wf_prog wf_md P" and C: "class P C = \<lfloor>(S,fs,ms)\<rfloor>" and  m: "(M,Ts,T,m) \<in> set ms"
  shows "P \<turnstile> C sees M:Ts\<rightarrow>T = m in C"
proof -
  from C have "is_class P C" by(auto simp:is_class_def)
  with assms show ?thesis
    by(bestsimp simp:Method_def dest:mdecls_visible)
qed

lemma sees_wf_native:
  "\<lbrakk> wf_prog wf_md P; P \<turnstile> C sees M:Ts\<rightarrow>T=Native in D \<rbrakk> \<Longrightarrow> D\<bullet>M(Ts) :: T"
apply(drule (1) sees_wf_mdecl)
apply(simp add: wf_mdecl_def)
done

lemma Call_lemma:
  "\<lbrakk> P \<turnstile> C sees M:Ts\<rightarrow>T = m in D; P \<turnstile> C' \<preceq>\<^sup>* C; wf_prog wf_md P \<rbrakk>
  \<Longrightarrow> \<exists>D' Ts' T' m'.
       P \<turnstile> C' sees M:Ts'\<rightarrow>T' = m' in D' \<and> P \<turnstile> Ts [\<le>] Ts' \<and> P \<turnstile> T' \<le> T \<and> P \<turnstile> C' \<preceq>\<^sup>* D'
       \<and> is_type P T' \<and> (\<forall>T\<in>set Ts'. is_type P T) \<and> (m' \<noteq> Native \<longrightarrow> wf_md P D' (M,Ts',T',the m'))"
apply(frule (2) sees_method_mono)
apply(fastforce intro:sees_method_decl_above dest:sees_wf_mdecl
               simp: wf_mdecl_def)
done

lemma sub_Thread_sees_run:
  assumes wf: "wf_prog wf_md P"
  and PCThread: "P \<turnstile> C \<preceq>\<^sup>* Thread"
  shows "\<exists>D mthd. P \<turnstile> C sees run: []\<rightarrow>Void = \<lfloor>mthd\<rfloor> in D"
proof -
  from class_Thread[OF wf] obtain T' fsT MsT
    where classT: "class P Thread = \<lfloor>(T', fsT, MsT)\<rfloor>" by blast
  hence wfcThread: "wf_cdecl wf_md P (Thread, T', fsT, MsT)" using wf by(rule class_wf)
  then obtain mrunT where runThread: "(run, [], Void, mrunT) \<in> set MsT"
    by(auto simp add: wf_cdecl_def)
  moreover have "\<exists>MmT. P \<turnstile> Thread sees_methods MmT \<and>
                       (\<forall>(M,Ts,T,m) \<in> set MsT. MmT M = Some((Ts,T,m),Thread))"
    by(rule mdecls_visible[OF wf is_class_Thread[OF wf] classT])
  then obtain MmT where ThreadMmT: "P \<turnstile> Thread sees_methods MmT"
    and MmT: "\<forall>(M,Ts,T,m) \<in> set MsT. MmT M = Some((Ts,T,m),Thread)"
    by blast
  ultimately obtain mthd
    where "MmT run = \<lfloor>(([], Void, mthd), Thread)\<rfloor>"
    by(fastforce)
  with ThreadMmT have Tseesrun: "P \<turnstile> Thread sees run: []\<rightarrow>Void = mthd in Thread"
    by(auto simp add: Method_def)
  from sees_method_mono[OF PCThread wf Tseesrun]
  obtain D' m' where "P \<turnstile> C sees run: []\<rightarrow>Void = m' in D'" by auto
  moreover have "m' \<noteq> None"
  proof
    assume "m' = None"
    with wf \<open>P \<turnstile> C sees run: []\<rightarrow>Void = m' in D'\<close> have "D'\<bullet>run([]) :: Void"
      by(auto intro: sees_wf_native)
    thus False by cases auto
  qed
  ultimately show ?thesis by auto
qed

lemma wf_prog_lift:
  assumes wf: "wf_prog (\<lambda>P C bd. A P C bd) P"
  and rule:
  "\<And>wf_md C M Ts C T m.
   \<lbrakk> wf_prog wf_md P; P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>m\<rfloor> in C; is_class P C; set Ts \<subseteq> types P; A P C (M,Ts,T,m) \<rbrakk>
   \<Longrightarrow> B P C (M,Ts,T,m)"
  shows "wf_prog (\<lambda>P C bd. B P C bd) P"
proof(cases P)
  case (Program P')
  thus ?thesis using wf
    apply(clarsimp simp add: wf_prog_def wf_cdecl_def)
    apply(drule (1) bspec)
    apply(rename_tac C D fs ms)
    apply(subgoal_tac "is_class P C")
     prefer 2
     apply(simp add: is_class_def)
     apply(drule weak_map_of_SomeI)
     apply(simp add: Program)
    apply(clarsimp simp add: Program wf_mdecl_def split del: option.split)
    apply(drule (1) bspec)
    apply clarsimp
    apply(rule conjI)
     apply clarsimp
    apply clarsimp
    apply(frule (1) map_of_SomeI)
    apply(rule rule[OF wf, unfolded Program])
    apply(clarsimp simp add: is_class_def)
    apply(rule mdecl_visible[OF wf[unfolded Program]])
    apply(fastforce intro: is_type_pTs [OF wf, unfolded Program])+
    done
qed

subsection\<open>Well-formedness and field lookup\<close>

lemma wf_Fields_Ex:
  "\<lbrakk> wf_prog wf_md P; is_class P C \<rbrakk> \<Longrightarrow> \<exists>FDTs. P \<turnstile> C has_fields FDTs"
(*<*)
apply(frule class_Object)
apply(erule (1) subcls1_induct)
 apply(blast intro:has_fields_Object)
apply(blast intro:has_fields_rec dest:subcls1D)
done
(*>*)

lemma has_fields_types:
  "\<lbrakk> P \<turnstile> C has_fields FDTs; (FD, T, fm) \<in> set FDTs; wf_prog wf_md P \<rbrakk> \<Longrightarrow> is_type P T"
(*<*)
apply(induct rule:Fields.induct)
 apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
apply(fastforce dest!: class_wf simp: wf_cdecl_def wf_fdecl_def)
done
(*>*)

lemma sees_field_is_type:
  "\<lbrakk> P \<turnstile> C sees F:T (fm) in D; wf_prog wf_md P \<rbrakk> \<Longrightarrow> is_type P T"
by(fastforce simp: sees_field_def
            elim: has_fields_types map_of_SomeD[OF map_of_remap_SomeD])

lemma wf_has_field_mono2:
  assumes wf: "wf_prog wf_md P"
  and has: "P \<turnstile> C has F:T (fm) in E"
  shows "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* D; P \<turnstile> D \<preceq>\<^sup>* E \<rbrakk> \<Longrightarrow> P \<turnstile> D has F:T (fm) in E"
proof(induct rule: rtranclp_induct)
  case base show ?case using has .
next
  case (step D D')
  note DsubD' = \<open>P \<turnstile> D \<prec>\<^sup>1 D'\<close>
  from DsubD' obtain rest where classD: "class P D = \<lfloor>(D', rest)\<rfloor>"
    and DObj: "D \<noteq> Object" by(auto elim!: subcls1.cases)
  from DsubD' \<open>P \<turnstile> D' \<preceq>\<^sup>* E\<close> have DsubE: "P \<turnstile> D \<preceq>\<^sup>* E" and DsubE2: "(subcls1 P)^++ D E"
    by(rule converse_rtranclp_into_rtranclp rtranclp_into_tranclp2)+
  from wf DsubE2 have DnE: "D \<noteq> E" by(rule subcls_irrefl)
  from DsubE have hasD: "P \<turnstile> D has F:T (fm) in E" by(rule \<open>P \<turnstile> D \<preceq>\<^sup>* E \<Longrightarrow> P \<turnstile> D has F:T (fm) in E\<close>)
  then obtain FDTs where hasf: "P \<turnstile> D has_fields FDTs" and FE: "map_of FDTs (F, E) = \<lfloor>(T, fm)\<rfloor>"
    unfolding has_field_def by blast
  from hasf show ?case
  proof cases
    case has_fields_Object with DObj show ?thesis by simp
  next
    case (has_fields_rec DD' fs ms FDTs')
    with classD have [simp]: "DD' = D'" "rest = (fs, ms)"
      and hasf': "P \<turnstile> D' has_fields FDTs'"
      and FDTs: "FDTs = map (\<lambda>(F, Tm). ((F, D), Tm)) fs @ FDTs'" by auto
    from FDTs FE DnE hasf' show ?thesis by(auto dest: map_of_SomeD simp add: has_field_def)
  qed
qed

lemma wf_has_field_idemp:
  "\<lbrakk> wf_prog wf_md P; P \<turnstile> C has F:T (fm) in D \<rbrakk> \<Longrightarrow> P \<turnstile> D has F:T (fm) in D"
apply(frule has_field_decl_above)
apply(erule (2) wf_has_field_mono2)
apply(rule rtranclp.rtrancl_refl)
done

lemma map_of_remap_conv:
  "\<lbrakk> distinct_fst fs; map_of (map (\<lambda>(F, y). ((F, D), y)) fs) (F, D) = \<lfloor>T\<rfloor> \<rbrakk>
  \<Longrightarrow> map_of (map (\<lambda>((F, D), T). (F, D, T)) (map (\<lambda>(F, y). ((F, D), y)) fs)) F = \<lfloor>(D, T)\<rfloor>"
apply(induct fs)
apply auto
done

lemma has_field_idemp_sees_field:
  assumes wf: "wf_prog wf_md P"
  and has: "P \<turnstile> D has F:T (fm) in D"
  shows "P \<turnstile> D sees F:T (fm) in D"
proof -
  from has obtain FDTs where hasf: "P \<turnstile> D has_fields FDTs"
    and FD: "map_of FDTs (F, D) = \<lfloor>(T, fm)\<rfloor>" unfolding has_field_def by blast
  from hasf have "map_of (map (\<lambda>((F, D), T). (F, D, T)) FDTs) F = \<lfloor>(D, T, fm)\<rfloor>"
  proof cases
    case (has_fields_Object D' fs ms)
    from \<open>class P Object = \<lfloor>(D', fs, ms)\<rfloor>\<close> wf
    have "wf_cdecl wf_md P (Object, D', fs, ms)" by(rule class_wf)
    hence "distinct_fst fs" by(simp add: wf_cdecl_def)
    with FD has_fields_Object show ?thesis by(auto intro: map_of_remap_conv simp del: map_map)
  next
    case (has_fields_rec D' fs ms FDTs')
    hence [simp]: "FDTs = map (\<lambda>(F, Tm). ((F, D), Tm)) fs @ FDTs'"
      and classD: "class P D = \<lfloor>(D', fs, ms)\<rfloor>" and DnObj: "D \<noteq> Object"
      and hasf': "P \<turnstile> D' has_fields FDTs'" by auto
    from \<open>class P D = \<lfloor>(D', fs, ms)\<rfloor>\<close> wf
    have "wf_cdecl wf_md P (D, D', fs, ms)" by(rule class_wf)
    hence "distinct_fst fs" by(simp add: wf_cdecl_def)
    moreover have "map_of FDTs' (F, D) = None"
    proof(rule ccontr)
      assume "map_of FDTs' (F, D) \<noteq> None"
      then obtain T' fm' where "map_of FDTs' (F, D) = \<lfloor>(T', fm')\<rfloor>" by(auto)
      with hasf' have "P \<turnstile> D' \<preceq>\<^sup>* D" by(auto dest!: map_of_SomeD intro: has_fields_decl_above)
      with classD DnObj have "(subcls1 P)^++ D D"
        by(auto intro: subcls1.intros rtranclp_into_tranclp2)
      with wf show False by(auto dest: subcls_irrefl)
    qed
    ultimately show ?thesis using FD hasf'
      by(auto simp add: map_add_Some_iff intro: map_of_remap_conv simp del: map_map)
  qed
  with hasf show ?thesis unfolding sees_field_def by blast
qed

lemma has_fields_distinct:
  assumes wf: "wf_prog wf_md P"
  and "P \<turnstile> C has_fields FDTs"
  shows "distinct (map fst FDTs)"
using \<open>P \<turnstile> C has_fields FDTs\<close>
proof(induct)
  case (has_fields_Object D fs ms FDTs)
  have eq: "map (fst \<circ> (\<lambda>(F, y). ((F, Object), y))) fs = map ((\<lambda>F. (F, Object)) \<circ> fst) fs" by(auto)
  from \<open>class P Object = \<lfloor>(D, fs, ms)\<rfloor>\<close> wf
  have "wf_cdecl wf_md P (Object, D, fs, ms)" by(rule class_wf)
  hence "distinct (map fst fs)" by(simp add: wf_cdecl_def distinct_fst_def)
  hence "distinct (map (fst \<circ> (\<lambda>(F, y). ((F, Object), y))) fs)"
    unfolding eq distinct_map by(auto intro: comp_inj_on inj_onI)
  thus ?case using \<open>FDTs = map (\<lambda>(F, T). ((F, Object), T)) fs\<close> by(simp)
next
  case (has_fields_rec C D fs ms FDTs FDTs')
  have eq: "map (fst \<circ> (\<lambda>(F, y). ((F, C), y))) fs = map ((\<lambda>F. (F, C)) \<circ> fst) fs" by(auto)
  from \<open>class P C = \<lfloor>(D, fs, ms)\<rfloor>\<close> wf
  have "wf_cdecl wf_md P (C, D, fs, ms)" by(rule class_wf)
  hence "distinct (map fst fs)" by(simp add: wf_cdecl_def distinct_fst_def)
  hence "distinct (map (fst \<circ> (\<lambda>(F, y). ((F, C), y))) fs)"
    unfolding eq distinct_map by(auto intro: comp_inj_on inj_onI)
  moreover from \<open>class P C = \<lfloor>(D, fs, ms)\<rfloor>\<close> \<open>C \<noteq> Object\<close>
  have "P \<turnstile> C \<prec>\<^sup>1 D" by(rule subcls1.intros)
  with \<open>P \<turnstile> D has_fields FDTs\<close>
  have "(fst \<circ> (\<lambda>(F, y). ((F, C), y))) ` set fs \<inter> fst ` set FDTs = {}"
    by(auto dest: subcls_notin_has_fields)
  ultimately show ?case using \<open>FDTs' = map (\<lambda>(F, T). ((F, C), T)) fs @ FDTs\<close> \<open>distinct (map fst FDTs)\<close> by simp
qed

subsection \<open>Code generation\<close>

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  [inductify]
  wf_overriding
.

text \<open>
  Separate subclass acycilicity from class declaration check.
  Otherwise, cyclic class hierarchies might lead to non-termination
  as @{term "Methods"} recurses over the class hierarchy.
\<close>

definition acyclic_class_hierarchy :: "'m prog \<Rightarrow> bool"
where
  "acyclic_class_hierarchy P \<longleftrightarrow>
  (\<forall>(C, D, fs, ml) \<in> set (classes P). C \<noteq> Object \<longrightarrow> \<not> P \<turnstile> D \<preceq>\<^sup>* C)"

definition wf_cdecl' :: "'m wf_mdecl_test \<Rightarrow> 'm prog \<Rightarrow> 'm cdecl \<Rightarrow> bool"
where
  "wf_cdecl' wf_md P = (\<lambda>(C,(D,fs,ms)).
  (\<forall>f\<in>set fs. wf_fdecl P f) \<and> distinct_fst fs \<and>
  (\<forall>m\<in>set ms. wf_mdecl wf_md P C m) \<and>
  distinct_fst ms \<and>
  (C \<noteq> Object \<longrightarrow> is_class P D \<and> (\<forall>m\<in>set ms. wf_overriding P D m)) \<and>
  (C = Thread \<longrightarrow> (\<exists>m. (run, [], Void, m) \<in> set ms)))"

lemma acyclic_class_hierarchy_code [code]:
  "acyclic_class_hierarchy P \<longleftrightarrow> (\<forall>(C, D, fs, ml) \<in> set (classes P). C \<noteq> Object \<longrightarrow> \<not> subcls' P D C)"
by(simp add: acyclic_class_hierarchy_def subcls'_def)

lemma wf_cdecl'_code [code]:
  "wf_cdecl' wf_md P = (\<lambda>(C,(D,fs,ms)).
  (\<forall>f\<in>set fs. wf_fdecl P f) \<and>  distinct_fst fs \<and>
  (\<forall>m\<in>set ms. wf_mdecl wf_md P C m) \<and>
  distinct_fst ms \<and>
  (C \<noteq> Object \<longrightarrow> is_class P D \<and> (\<forall>m\<in>set ms. wf_overriding P D m)) \<and>
  (C = Thread \<longrightarrow> ((run, [], Void) \<in> set (map (\<lambda>(M, Ts, T, b). (M, Ts, T)) ms))))"
by(auto simp add: wf_cdecl'_def intro!: ext intro: rev_image_eqI)

declare set_append [symmetric, code_unfold]

lemma wf_prog_code [code]:
  "wf_prog wf_md P \<longleftrightarrow>
   acyclic_class_hierarchy P \<and>
   wf_syscls P \<and> distinct_fst (classes P) \<and>
   (\<forall>c \<in> set (classes P). wf_cdecl' wf_md P c)"
unfolding wf_prog_def wf_cdecl_def wf_cdecl'_def acyclic_class_hierarchy_def split_def
by blast

end


(******************************************************************************)
(* Project: The Isabelle/UTP Proof System                                     *)
(* File: utp_circus_prefix.thy                                                *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)
(* LAST REVIEWED: 28 June 2017 *)

section {* {\Circus} Prefixes (OLD) *}

theory utp_circus_prefix
imports "UTP-Theories-Deep.utp_theories_deep"
begin (* recall_syntax *)

text \<open>TODO: Allow simplification theorems to be passed to @{method rel_simp}.\<close>

subsection {* Simplification of @{const do\<^sub>I} *}

text \<open>Original @{const "do\<^sub>I"} function from theory @{theory utp_csp}.\<close>

text {*
\<open>definition do\<^sub>I :: "
  ('a, '\<theta>) chan \<Rightarrow>
  ('a \<Longrightarrow> ('\<sigma>, '\<theta>) st_csp) \<Rightarrow>
  ('a \<Rightarrow> ('\<sigma>, '\<theta>) action) \<Rightarrow>
  ('\<sigma>, '\<theta>) action" where
"do\<^sub>I c x P = (
  ($tr\<acute> =\<^sub>u $tr \<and> {e : \<guillemotleft>\<delta>\<^sub>u(c)\<guillemotright> | P(e) \<bullet> (c\<cdot>\<guillemotleft>e\<guillemotright>)\<^sub>u}\<^sub>u \<inter>\<^sub>u $ref\<acute> =\<^sub>u {}\<^sub>u)
    \<triangleleft> $wait\<acute> \<triangleright>
  (($tr\<acute> - $tr) \<in>\<^sub>u {e : \<guillemotleft>\<delta>\<^sub>u(c)\<guillemotright> | P(e) \<bullet> \<langle>(c\<cdot>\<guillemotleft>e\<guillemotright>)\<^sub>u\<rangle>}\<^sub>u \<and> (c\<cdot>$x\<acute>)\<^sub>u =\<^sub>u last\<^sub>u($tr\<acute>)))"\<close>
*}

text \<open>Simplifications that are parametrised by a value rather than a lens.\<close>

definition new_do\<^sub>I :: "
  ('a, '\<epsilon>) chan \<Rightarrow> 'a \<Rightarrow>
  ('a \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
  ('\<sigma>, '\<epsilon>) action" where
"new_do\<^sub>I c x P =
  ($tr\<acute> =\<^sub>u $tr \<and> {e : \<guillemotleft>\<delta>\<^sub>u(c)\<guillemotright> | P(e) \<bullet> (c\<cdot>\<guillemotleft>e\<guillemotright>)\<^sub>u}\<^sub>u \<inter>\<^sub>u $ref\<acute> =\<^sub>u {}\<^sub>u)
    \<triangleleft> $wait\<acute> \<triangleright>
  ($tr\<acute> - $tr \<in>\<^sub>u {e : \<guillemotleft>\<delta>\<^sub>u(c)\<guillemotright> | P(e) \<bullet> \<langle>(c\<cdot>\<guillemotleft>e\<guillemotright>)\<^sub>u\<rangle>}\<^sub>u \<and> (c\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u =\<^sub>u last\<^sub>u($tr\<acute>))"

definition new_do\<^sub>I' :: "
  ('a, '\<epsilon>) chan \<Rightarrow> 'a \<Rightarrow>
  ('a \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
  ('\<sigma>, '\<epsilon>) action" where
"new_do\<^sub>I' c x P =
  ($tr\<acute> =\<^sub>u $tr \<and> (\<^bold>\<forall>x | P(x) \<bullet> (c\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u \<notin>\<^sub>u $ref\<acute>))
    \<triangleleft> $wait\<acute> \<triangleright>
  ($tr\<acute> - $tr =\<^sub>u \<langle>(c\<cdot>\<guillemotleft>x\<guillemotright>)\<^sub>u\<rangle> \<and> P(x))"

declare new_do\<^sub>I_def  [urel_defs]
declare new_do\<^sub>I'_def [urel_defs]

text \<open>For @{const inj}ective channels, the two definitions are equivalent.\<close>

-- \<open>Perhaps all channels should be injective by construction.\<close>

lemma diff_eq_singletonD:
"t - s = [x] \<Longrightarrow> s \<le> t \<Longrightarrow> last t = x"
apply (metis last_snoc less_eq_list_def prefix_concat_minus)
done

lemma new_do\<^sub>I_iff_new_do\<^sub>I':
"inj c \<Longrightarrow> `$tr \<le>\<^sub>u $tr\<acute> \<Rightarrow> (new_do\<^sub>I c x P \<Leftrightarrow> new_do\<^sub>I' c x P)`"
apply (rel_simp)
apply (safe; clarsimp?)
-- {* Subgoal 1 *}
apply (blast)
-- {* Subgoal 2 *}
apply (simp add: diff_eq_singletonD)
-- {* Subgoal 3 *}
apply (drule_tac diff_eq_singletonD)
apply (assumption)
using injD apply (fastforce)
-- {* Subgoal 4 *}
apply (blast)
-- {* Subgoal 5 *}
apply (simp add: diff_eq_singletonD)
done

subsection {* Input Prefix *}

text \<open>The below is obsolete as we can use @{const InputCSP} for actions too.\<close>

-- \<open>Is the use of @{const RDES} correct anyway here?\<close>

definition InputCircus ::
  "('a::{continuum, two}, '\<epsilon>) chan \<Rightarrow>
    ('a, ('\<sigma>, '\<epsilon>) st_csp) lvar \<Rightarrow>
    ('a \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
    (('a \<Longrightarrow> ('\<sigma>, '\<epsilon>) st_csp) \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
    ('\<sigma>, '\<epsilon>) action" where
"InputCircus c x P A =
  (var\<^bsub>RDES\<^esub> x \<bullet> \<^bold>R\<^sub>s(true \<turnstile> (do\<^sub>I c x P) \<and> (\<exists> $x\<acute> \<bullet> II)) ;; A(x))"

declare InputCircus_def [urel_defs]

text \<open>Simplifications based on the original definition of Marcel Oliveira.\<close>

definition NewInputCircus ::
  "('a, '\<epsilon>) chan \<Rightarrow>
    ('a \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
    ('a \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
    ('\<sigma>, '\<epsilon>) action" where
"NewInputCircus c P A = (\<^bold>\<exists> x \<bullet> \<^bold>R\<^sub>s(true \<turnstile> (new_do\<^sub>I c x P) \<and> II) ;; A(x))"

declare NewInputCircus_def [urel_defs]

definition NewInputCircus' ::
  "('a, '\<epsilon>) chan \<Rightarrow>
    ('a \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
    ('a \<Rightarrow> ('\<sigma>, '\<epsilon>) action) \<Rightarrow>
    ('\<sigma>, '\<epsilon>) action" where
"NewInputCircus' c P A = (\<^bold>\<exists> x \<bullet> \<^bold>R\<^sub>s(true \<turnstile> (new_do\<^sub>I' c x P) \<and> II) ;; A(x))"

declare NewInputCircus'_def [urel_defs]

lemma "inj c \<Longrightarrow> NewInputCircus c P A = NewInputCircus' c P A"
apply (rel_simp)
apply (safe; clarsimp?)
apply (metis)+
done

text \<open>Locale variables appear not to be support yet for CSP/{\Circus}.\<close>

lemma
"vwb_lens x \<Longrightarrow>
 InputCircus c x P A = NewInputCircus' c P (\<lambda>v. (var\<^bsub>RDES\<^esub> x \<bullet> (x := \<guillemotleft>v\<guillemotright>) ;; A x))"
apply (rel_simp)
apply (unfold comp_def)
apply (safe; clarsimp?)
oops

(************************)
(* REVIEWED UNNTIL HERE *)
(************************)

subsection {* Mixed Prefixes *}

text {* In this section, we provide support for mixed prefixes. *}

text {* A few syntactic adjustments, remove them and adapt @{text "fmi.thy"}. *}

no_notation utp_rel_opsem.trel (infix "\<rightarrow>\<^sub>u" 85)

syntax
  "_circus_sync" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<rightarrow>\<^sub>u" 80)
  "_circus_input" :: "logic \<Rightarrow> id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"
    ("_?\<^sub>u'(_ :/ _') \<rightarrow> _" [81, 0, 0, 80] 80)
  "_circus_output" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"
    ("_!\<^sub>u'(_') \<rightarrow> _" [81, 0, 80] 80)

translations
  "c \<rightarrow>\<^sub>u A" \<rightleftharpoons> "(CONST OutputCSP) c ()\<^sub>u A"
  "c!\<^sub>u(v) \<rightarrow> A" \<rightleftharpoons> "(CONST OutputCSP) c v A"
  "c?\<^sub>u(x : P) \<rightarrow> A" \<rightharpoonup> "(CONST InputCircus) c
    (*(CONST top_var \<dots>*) (CONST MkDVar IDSTR(x)) (\<lambda>x. P) (\<lambda>x. A)"
  "c?\<^sub>u(x : P) \<rightarrow> A" \<leftharpoondown> "(CONST InputCircus) c x (\<lambda>v. P) (\<lambda>w. A)"

(*
syntax
  "_circus_sync" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("_ \<rightarrow> _" [81, 80] 80)
  "_circus_output" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"
    ("_!\<^sub>u'(_') \<rightarrow> _" [81, 0, 80] 80)
  "_circus_input"  :: "logic \<Rightarrow> id \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"
    ("_?\<^sub>u'(_ :/ _') \<rightarrow> _" [81, 0, 0, 80] 80)
*)
(*
no_translations
  "c \<^bold>\<rightarrow> A"      \<leftharpoondown> "(CONST OutputCSP) c ()\<^sub>u A"
  "c!\<^sub>u(v) \<rightarrow> A" \<leftharpoondown> "(CONST OutputCSP) c v A"
*)

subsubsection {* Prefix Semantics *}

text {*
  We first define a new and simplified version of the @{const InputCircus}
  operator. Simplification is due to its action argument being parametrised
  by the a (HOL) value rather than a variable lens. This makes a subsequent
  definition of syntax and translations for mixed prefixes much easier. We
  note that all different kinds of prefixes will be expressed in terms of
  input communications with appropriate constraints on variables that are
  introduced by the prefix construct.
*}

subsubsection {* Syntax and Translations *}

text {* We next configure a syntax for mixed prefixes. *}

nonterminal prefix_elem and mixed_prefix

syntax "" :: "prefix_elem \<Rightarrow> mixed_prefix" ("_")

text {* Input Prefix: @{text "\<dots>?(x)"} *}

syntax "_simple_input_prefix" :: "id \<Rightarrow> prefix_elem"  ("?'(_')")

text {* Input Prefix with Constraint: @{text "\<dots>?(x : P)"} *}

syntax "_input_prefix" :: "id \<Rightarrow> ('\<sigma>, '\<epsilon>) action \<Rightarrow> prefix_elem" ("?'(_ :/ _')")

text {* Output Prefix: @{text "\<dots>![v]e"} *}

text {* A variable name must currently be provided for outputs, too. Fix?! *}

syntax "_output_prefix" :: "id \<Rightarrow> ('a, '\<sigma>) uexpr \<Rightarrow> prefix_elem" ("![_]_")
syntax "_output_prefix" :: "id \<Rightarrow> ('a, '\<sigma>) uexpr \<Rightarrow> prefix_elem" (".[_]_")

syntax (output) "_output_prefix_pp" :: "('a, '\<sigma>) uexpr \<Rightarrow> prefix_elem" ("!_")

text {* Synchronisation Action: @{text "c \<rightarrow>\<^sub>\<C> A"} *}

syntax "_sync_action" ::
  "('a, '\<epsilon>) chan \<Rightarrow> ('\<sigma>, '\<epsilon>) action \<Rightarrow> ('\<sigma>, '\<epsilon>) action" (infixr "\<rightarrow>\<^sub>\<C>" 80)

text {* Mixed-Prefix Action: @{text "c\<dots>(prefix) \<rightarrow>\<^sub>\<C> A"} *}

syntax "_mixed_prefix" :: "prefix_elem \<Rightarrow> mixed_prefix \<Rightarrow> mixed_prefix" ("__")

syntax "_prefix_action" ::
  "('a, '\<epsilon>) chan \<Rightarrow> mixed_prefix \<Rightarrow> ('\<sigma>, '\<epsilon>) action \<Rightarrow> ('\<sigma>, '\<epsilon>) action"
  ("(__ \<rightarrow>\<^sub>\<C>/ _)" [81, 81, 80] 80)

text {* Syntax translations *}

translations
  "_simple_input_prefix x" \<rightleftharpoons> "_input_prefix x true"
  "_output_prefix x e" \<rightharpoonup> "_input_prefix x (\<guillemotleft>x\<guillemotright> =\<^sub>u e)"
  "_output_prefix_pp e" \<leftharpoondown> "_input_prefix v (\<guillemotleft>x\<guillemotright> =\<^sub>u e)" (* Better do in ML! *)

translations
  "_mixed_prefix (_input_prefix x P) (_input_prefix y Q)" \<rightleftharpoons>
  "_input_prefix (_pattern x y) (P \<and> Q)"

translations
  "_sync_action c A" \<rightleftharpoons> "(CONST OutputCSP) c ()\<^sub>u A"
  "_prefix_action c (_input_prefix x P) A"  \<rightharpoonup>
  "(CONST NewInputCircus) c (\<lambda>x. P) (\<lambda>x. A)"
(* "_prefix_action c (_input_prefix x P) A"  \<leftharpoondown>
  "(CONST NewInputCircus) c (\<lambda>x. P) (\<lambda>v. A)" *)

text {*
  The ML print translation for @{const NewInputCircus} below is a little more
  robust than using Isabelle in-built @{command translations} in dealing with
  unwanted eta-contraction.
*}

ML {*
signature CIRCUS_PREFIX =
sig
  val mk_pattern: term list -> term
  val strip_abs_tr': term list -> term -> term list * term
  val mk_input_prefix: term -> term -> term
  val mk_prefix_action: term -> term -> term -> term -> term
  val InputCircus_tr': term list -> term
end;

structure Circus_Prefix : CIRCUS_PREFIX =
struct
  fun mk_pattern [] = Const (@{syntax_const "_unit"}, dummyT)
  | mk_pattern [x] = x
  | mk_pattern (h :: t) =
    Const (@{syntax_const "_pattern"}, dummyT) $ h $ (mk_pattern t);

  fun strip_abs_tr' vs (Abs abs) =
    let val (v, body) = Syntax_Trans.atomic_abs_tr' abs in
      strip_abs_tr' (vs @ [v]) body
    end
  | strip_abs_tr' vs
      (Const (@{const_syntax case_prod}, _) $ (Abs abs)) =
    let val (v, body) = Syntax_Trans.atomic_abs_tr' abs in
      strip_abs_tr' (vs @ [v]) body
    end
  | strip_abs_tr' vs term = (vs, term);

  fun mk_input_prefix x P =
    Const (@{syntax_const "_input_prefix"}, dummyT) $ x $ P;

  fun mk_prefix_action c x P A =
    Const (@{syntax_const "_prefix_action"}, dummyT) $ c $
      (mk_input_prefix x P) $ A;

  fun InputCircus_tr' [c, P, A] = let
    val (vs, P') = strip_abs_tr' [] P;
    val (vs', A') = strip_abs_tr' [] A in
      if (vs = vs') then
        (mk_prefix_action c (mk_pattern vs) P' A')
      else raise Match
    end
  | InputCircus_tr' _ = raise Match;
end;
*}

print_translation {*
  [(@{const_syntax NewInputCircus}, K Circus_Prefix.InputCircus_tr')]
*}

text {* Testing *}

text {* All of the below seem to work! *}

term "c?(x : true) \<rightarrow>\<^sub>\<C> A x"
term "c?(x : true)?(y : true) \<rightarrow>\<^sub>\<C> A x y"
term "c?(x : true)?(y : true)?(z : true) \<rightarrow>\<^sub>\<C> A x y z"
term "c?(x : \<guillemotleft>x\<guillemotright> <\<^sub>u \<guillemotleft>10::nat\<guillemotright>) \<rightarrow>\<^sub>\<C> A x"
term "c?(x)?(y : true) \<rightarrow>\<^sub>\<C> A x y"
term "c?(x : true)![st]\<guillemotleft>1::nat\<guillemotright> \<rightarrow>\<^sub>\<C> A x"
term "c![st]\<guillemotleft>1::nat\<guillemotright>?(x : true) \<rightarrow>\<^sub>\<C> A x"
term "c![st]\<guillemotleft>1::nat\<guillemotright> \<rightarrow>\<^sub>\<C> A"
term "c![x]\<guillemotleft>1::nat\<guillemotright>![y]\<guillemotleft>2::nat\<guillemotright> \<rightarrow>\<^sub>\<C> A"
term "c \<rightarrow>\<^sub>\<C> A"
end


(* @LICENSE(NICTA_CORE) *)

(*  Author:     Rafal Kolanski, NICTA & UNSW

    Instantiation of pointers and heaps to a 32-bit system, along with
    typed pointer manipulation.
*)

theory TypedHeap
imports Heaps Misc
begin

(* XXX: Gerwin points out that calling things "value" will cause problems
  later on, as valid_value already exists in seL4. "entity" is not much
  better. Best to leave it for now, then rename if it's really necessary.
*)

section \<open>Types\<close>

text \<open>A pointer type is a mem_type if its address type is a mem_type\<close>

text \<open>Can I be more specific than mem_type for addrs here?\<close>
instantiation ptr_t :: (mem_type, type, type) mem_type
begin
definition
  "to_bytes_ptr_t \<equiv> to_bytes o ptr_addr"
definition
  "from_bytes_ptr_t \<equiv> Ptr o Addr o from_bytes"
definition
  align_of_ptr_t :: "('a,'p,'t) ptr_t itself \<Rightarrow> nat" where
  "align_of_ptr_t x \<equiv> align_of TYPE ('a)"
definition
  size_of_ptr_t :: "('a,'p,'t) ptr_t itself \<Rightarrow> nat" where
  "size_of_ptr_t x \<equiv> size_of TYPE ('a)"
definition
  type_tag_ptr_t :: "('a,'p,'t) ptr_t itself \<Rightarrow> type_tag" where
  "type_tag_ptr_t x \<equiv> ''ptr_t'' @ type_tag TYPE ('a)"
instance
  by (intro_classes)
     (simp_all add: to_bytes_ptr_t_def from_bytes_ptr_t_def
                    size_of_ptr_t_def align_of_ptr_t_def max_size[simplified]
                    storable restorable size_length some_size max_size
                    sane_alignment ptr_addr_def)
end

declare size_of_ptr_t_def[simp]
declare align_of_ptr_t_def[simp]

text \<open>Instantiations of typed pointers based on instantiated address types\<close>

type_synonym 't pptr = "(paddr_word,physical,'t) ptr_t"
type_synonym 't vptr = "(vaddr_word,virtual,'t) ptr_t"

translations
  (type) "'t vptr" <= (type) "(32 word,virtual,'t) ptr_t"
  (type) "'t pptr" <= (type) "(32 word,physical,'t) ptr_t"

text \<open>
  For virtual/physical agnostic operations, such as loading an value from
  an address space or heap.\<close>
type_synonym ('a,'p) value_space = "('a,'p) addr_t \<rightharpoonup> byte"

text \<open>
  Pointers can be valid with respect to specific criteria enforced by guards,
  e.g. disallowing null pointers.
\<close>
type_synonym ('a,'p,'t) ptr_guard = "('a,'p,'t) ptr_t \<Rightarrow> bool"
type_synonym 't pptr_guard = "(paddr_word,physical,'t) ptr_t \<Rightarrow> bool"
type_synonym 't vptr_guard = "(vaddr_word,virtual,'t) ptr_t \<Rightarrow> bool"

section \<open>Typed Pointer Manipulation\<close>

text \<open>
  Incrementing an address in a typed pointer by a specific number of bytes\<close>
definition
  ptr_raw_add :: "('a::semiring_1,'p,'t::mem_type) ptr_t \<Rightarrow> 'a
              \<Rightarrow> ('a,'p,'t) ptr_t" where
  "ptr_raw_add p x \<equiv> Ptr (ptr_val p r+ x)"

text \<open>
   Incrementing an address in a typed pointer by multiples of the size of what
   it points to (in bytes). E.g. adding an int to a pointer in C.\<close>
definition
  ptr_add :: "('a::semiring_1,'p,'t::mem_type) ptr_t \<Rightarrow> 'a
              \<Rightarrow> ('a,'p,'t) ptr_t"
    (infixl "p+" 65) where
  "p p+ x \<equiv> ptr_raw_add p (x * of_nat (size_of TYPE('t)))"

notation (latex output)
  ptr_add (infixl "+" 65)

lemma ptr_add_zero [simp]:
  "p p+ 0 = p"
  unfolding ptr_add_def ptr_raw_add_def addr_add_def
  by simp

lemma ptr_add_add:
  "p p+ x p+ y = p p+ (x + y)"
  unfolding ptr_add_def ptr_raw_add_def
  by (clarsimp simp: addr_add_add field_simps)

text \<open>
  Decrementing an address in a typed pointer by a specific number of bytes\<close>
definition
  ptr_raw_sub :: "('a::{minus},'p,'t::mem_type) ptr_t \<Rightarrow> 'a
              \<Rightarrow> ('a,'p,'t) ptr_t" where
  "ptr_raw_sub p x \<equiv> Ptr (ptr_val p r- x)"

text \<open>
   Decrementing an address in a typed pointer by multiples of the size of what
   it points to (in bytes). E.g. subtracting an int from a pointer in C.\<close>
definition
  ptr_sub :: "('a::{minus,semiring_1},'p,'t::mem_type) ptr_t \<Rightarrow> 'a
              \<Rightarrow> ('a,'p,'t) ptr_t"
    (infixl "p-" 65) where
  "p p- x \<equiv> ptr_raw_sub p (x * of_nat (size_of TYPE('t)))"

notation (latex output)
  ptr_sub (infixl "-" 65)

text \<open>Pointer to type 't aligned as required by type 't.\<close>
definition
  ptr_aligned :: "('a::len word,'p,'t::mem_type) ptr_t \<Rightarrow> bool" where
  "ptr_aligned p \<equiv> align_of TYPE('t) dvd unat (ptr_addr p)"

text \<open>
  A sequence of typed pointers of length n starting at a specific offset.
  Wrapping permitted.\<close>
fun
  ptr_seq :: "('a::semiring_1, 'p, 't::mem_type) ptr_t \<Rightarrow> nat \<Rightarrow> ('a, 'p, 't) ptr_t list" where
  "ptr_seq p 0 = []" |
  "ptr_seq p (Suc n) = p # (ptr_seq (p p+ 1) n)"

lemma map_range_Suc_manipulation: (*FIXME move to misc*)
  assumes gf: "\<And>n. g (Suc n) = f n"
  shows "(g 0) # map f [0..<n] = map g [0..<Suc n]"
proof -
  have ss: "[Suc 0..<Suc n] = map Suc [0..<n]"
    by (subst map_Suc_upt[symmetric], rule refl)
  show ?thesis
  apply (subst upt_conv_Cons, simp)
  apply (subst ss)
  apply (simp add: gf)
  done
qed

lemma ptr_seq_as_map:
  fixes base :: "('a::semiring_1, 'p, 't::mem_type) ptr_t"
  shows "ptr_seq base sz = map (\<lambda>i. base p+ (of_nat i)) [0..<sz]"
proof (induct sz arbitrary: base)
  case 0 thus ?case by simp
next
  case (Suc n)
  hence IH: "\<And>(base::('a::semiring_1, 'p, 't::mem_type) ptr_t). ptr_seq base n = map (\<lambda>i. base p+ of_nat i) [0..<n]"
    by - assumption
  show ?case
    apply (clarsimp simp only: ptr_seq.simps IH)
    apply (subst map_range_Suc_manipulation[symmetric])
     apply (auto simp: ptr_add_add field_simps)
    done
qed

end