(* *********************************************************************

    Theory LA.thy is part of a framework for modelling,
    verification and transformation of concurrent imperative
    programs. Copyright (c) 2021  M. Bortin

    The framework is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    For more details see the license agreement (LICENSE) you should have
    received along with the framework.

   ******************************************************************* *)

theory LA
imports Prelims
begin

text "highlighting the type of relations between (abstract) states"
type_synonym 'a staterel = "('a \<times> 'a) set"

text "an auxiliary annotation structure for the parallel components"
record 's annpar =
  ap_rely :: "'s staterel"
  ap_precond :: "'s set"
  ap_postcond :: "'s set"

section "A generic imperative language"

datatype 's LA =
    Skip
  | Basic "'s \<Rightarrow> 's"
  | Seq "'s LA" "'s LA"
  | Cond "'s set" "'s LA" "'s LA"
  | While "'s set" "'s set" "'s LA" "'s LA"
  | Parallel "('s LA \<times> 's annpar) list"
  | Await "'s set" "'s set" "'s LA"
  | CJump "'s set" nat "'s LA"

text "the unconditional jump instruction"
definition "Jump i = CJump UNIV i Skip"

fun jumpfree :: "'s LA \<Rightarrow> bool"
where "jumpfree Skip = True" |
      "jumpfree (Basic f) = True" |
      "jumpfree (Seq p1 p2) = (jumpfree p1 \<and> jumpfree p2)" |
      "jumpfree (Parallel ps) = (\<forall>p\<in>set ps. jumpfree (fst p))" |
      "jumpfree (Cond c p1 p2) = (jumpfree p1 \<and> jumpfree p2)" |
      "jumpfree (Await c a p) = jumpfree p" |
      "jumpfree (While c i p q) = (jumpfree p \<and> jumpfree q)" |
      "jumpfree _ = False"

lemma jumpfree_Jump[simp] :
"jumpfree (Jump i) = False"
  by(simp add: Jump_def)

text "locally sequential programs"
fun locally_seq :: "'s LA \<Rightarrow> bool"
where "locally_seq (Seq p1 p2) = (locally_seq p1 \<and> locally_seq p2)" |
      "locally_seq (Parallel ps) = False" |
      "locally_seq (Cond c p1 p2) = (locally_seq p1 \<and> locally_seq p2)" |
      "locally_seq (Await c a p) = locally_seq p" |
      "locally_seq (While c i p q) = (locally_seq p \<and> locally_seq q)" |
      "locally_seq (CJump C i p) = locally_seq p" |
      "locally_seq _ = True"

lemma locally_seq_Jump[simp] :
"locally_seq (Jump i) = True"
  by(simp add: Jump_def)

text "the set of local jumps"
fun ljumps :: "'s LA \<Rightarrow> nat set"
where "ljumps Skip = {}" |
      "ljumps (Basic f) = {}" |
      "ljumps (CJump C i p) = {i} \<union> ljumps p" |
      "ljumps (Seq p1 p2) = (ljumps p1 \<union> ljumps p2)" |
      "ljumps (Parallel ps) = (\<Union>((ljumps \<circ> fst) ` set ps))" |
      "ljumps (Cond c p1 p2) = (ljumps p1 \<union> ljumps p2)" |
      "ljumps (Await c a p) = ljumps p" |
      "ljumps (While c i p q) = (ljumps p \<union> ljumps q)"

lemma ljumps_Jump[simp] :
"ljumps (Jump i) = {i}"
  by(simp add: Jump_def)

section "Concrete syntax for the LA programs"

syntax
  "_quote"     :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)"                ("(\<guillemotleft>_\<guillemotright>)" [0] 1000)
  "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"                ("\<acute>_" [1000] 1000)
  "_Assert"    :: "'a \<Rightarrow> 'a set"                    ("(\<lbrace>_\<rbrace>)" [0] 1000)

translations
  "\<lbrace>b\<rbrace>" \<rightharpoonup> "CONST Collect \<guillemotleft>b\<guillemotright>"

parse_translation \<open>
  let
    fun quote_tr [t] = Syntax_Trans.quote_tr @{syntax_const "_antiquote"} t
      | quote_tr ts = raise TERM ("quote_tr", ts);
  in [(@{syntax_const "_quote"}, K quote_tr)] end
\<close>

lemma neg_Collect[simp] :
"- Collect P = Collect (\<lambda>x. \<not> P x)"
  by fast

syntax
  "_fst" :: "'a \<times> 'b \<Rightarrow> 'a"  ("_\<^sub>," [60] 61)
  "_snd" :: "'a \<times> 'b \<Rightarrow> 'b"  ("_\<^sub>." [60] 61)

parse_translation \<open>
  let
    fun fst_tr ((Const (@{const_syntax Pair}, _) $ p $ c)
          :: ts) = p;

    fun snd_tr ((Const (@{const_syntax Pair}, _) $ p $ c)
          :: ts) = c;
  in
   [(@{syntax_const "_fst"}, K fst_tr),
    (@{syntax_const "_snd"}, K snd_tr)]
  end
\<close>

syntax
  "_Assign"    :: "idt \<Rightarrow> 'b \<Rightarrow> 's LA"
                   ("(\<acute>_ :=/ _)" [70, 65] 61)

translations
  "\<acute>x := a" \<rightleftharpoons> "(CONST Basic \<guillemotleft>\<acute>(_update_name x (\<lambda>_. a))\<guillemotright>)"

syntax
  "_before" :: "id \<Rightarrow> 'a" ("\<ordmasculine>_")
  "_after"  :: "id \<Rightarrow> 'a" ("\<ordfeminine>_")

translations
  "\<ordmasculine>x" \<rightleftharpoons> "x \<acute> CONST fst"
  "\<ordfeminine>x" \<rightleftharpoons> "x \<acute> CONST snd"

syntax
  "_Seq"  :: "'s LA \<Rightarrow> 's LA \<Rightarrow> 's LA"
            ("(_;//_)" [56, 55] 55)

  "_Cond"        :: "'s set  \<Rightarrow> 's LA  \<Rightarrow> 's LA \<Rightarrow> 's LA"
                    ("(IF _//(2THEN/ (_))//(2ELSE/ (_))//FI)" [0, 0, 0] 61)
  "_Cond2"       :: "'s set  \<Rightarrow> 's LA  \<Rightarrow> 's LA"
                    ("(IF _//(2THEN/ (_))//FI)" [0,0] 56)

  "_While_inv"   :: "'s set  \<Rightarrow> 's set \<Rightarrow> 's LA  \<Rightarrow> 's LA  \<Rightarrow> 's LA"
  ("(WHILE _/ \<lbrakk> inv: _/\<rbrakk>//(2DO/ (_))//SUBSEQUENTLY _//OD)"  [0, 0, 0, 0] 61)

  "_While"       :: "'s set  \<Rightarrow> 's LA  \<Rightarrow> 's LA \<Rightarrow> 's LA"
                    ("(WHILE _//(2DO/ (_))//SUBSEQUENTLY _//OD)"  [0, 0, 0] 61)

  "_WhileS"      :: "'s set  \<Rightarrow> 's set \<Rightarrow> 's LA  \<Rightarrow> 's LA"
                    ("(WHILE _/ \<lbrakk> inv: _/\<rbrakk>//(2DO/ (_))//OD)"  [0, 0, 0] 61)
  "_WhileS5"     :: "'s set  \<Rightarrow> 's LA  \<Rightarrow> 's LA"
                    ("(WHILE _//(2DO/ (_))//OD)"  [0, 0] 61)

  "_AwaitA"       :: "'s set  \<Rightarrow> 's set \<Rightarrow> 's LA  \<Rightarrow> 's LA"
                    ("(AWAIT _/ \<lbrakk> ann: _/\<rbrakk>//(2THEN/ (_))/ END)"  [0,0,0] 61)
  "_AtomA"        :: "'s set  \<Rightarrow> 's LA  \<Rightarrow> 's LA"
                    ("(\<lbrakk> ann: _/\<rbrakk>\<langle>_\<rangle>)" [0,0] 61)
  "_WaitA"        :: "'s set  \<Rightarrow> 's set  \<Rightarrow> 's LA"
                    ("(WAIT _/ \<lbrakk> ann: _/\<rbrakk> END)" [0,0] 61)

  "_Await"       :: "'s set  \<Rightarrow> 's LA  \<Rightarrow> 's LA"
                    ("(AWAIT _/ (2THEN/ (_))/ END)"  [0,0] 61)
  "_Atom"        :: "'s set  \<Rightarrow> 's LA  \<Rightarrow> 's LA"
                    ("(\<langle>_\<rangle>)" [0] 61)
  "_Wait"        :: "'s set  \<Rightarrow> 's LA"
                    ("(WAIT _/ END)" [0] 61)

  "_Jump"        :: "nat \<Rightarrow> 's LA" ("JUMP _/" [0] 61)

  "_CJump"       :: "'s set \<Rightarrow> nat \<Rightarrow> 's LA \<Rightarrow> 's LA"
                    ("CJUMP _/ TO/ _//(2OTHERWISE/ (_))//END " [0,0,0] 61)

  "_Skip"        :: "'s LA" ("SKIP" 61)

translations
  "p1;p2" \<rightleftharpoons> "CONST Seq p1 p2"

  "IF b THEN c1 ELSE c2 FI" \<rightleftharpoons> "CONST Cond b c1 c2"
  "IF b THEN c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"

  "WHILE b \<lbrakk>inv: i\<rbrakk> DO p SUBSEQUENTLY q OD" \<rightleftharpoons> "CONST While b i p q"
  "WHILE b DO p SUBSEQUENTLY q OD" \<rightleftharpoons> "WHILE b \<lbrakk>inv: CONST UNIV\<rbrakk> DO p SUBSEQUENTLY q OD"

  "WHILE b \<lbrakk>inv: i\<rbrakk> DO p OD" \<rightleftharpoons> "WHILE b \<lbrakk>inv: i\<rbrakk> DO p SUBSEQUENTLY SKIP OD"
  "WHILE b DO p OD" \<rightleftharpoons> "WHILE b DO p SUBSEQUENTLY SKIP OD"

  "AWAIT b \<lbrakk>ann: a\<rbrakk> THEN c END" \<rightleftharpoons> "CONST Await b a c"
  "\<lbrakk>ann: a\<rbrakk>\<langle>c\<rangle>" \<rightleftharpoons> "AWAIT CONST UNIV \<lbrakk>ann: a\<rbrakk> THEN c END"
  "WAIT b \<lbrakk>ann: a\<rbrakk> END" \<rightleftharpoons> "AWAIT b \<lbrakk>ann: a\<rbrakk> THEN SKIP END"

  "AWAIT b THEN c END" \<rightleftharpoons> "CONST Await b (CONST UNIV) c"
  "\<langle>c\<rangle>" \<rightleftharpoons> "AWAIT CONST UNIV THEN c END"
  "WAIT b END" \<rightleftharpoons> "AWAIT b THEN SKIP END"
  "JUMP j"  \<rightleftharpoons> "CONST Jump j"
  "CJUMP b TO j OTHERWISE p END" \<rightleftharpoons> "CONST CJump b j p"
  "SKIP" \<rightleftharpoons> "CONST Skip"

nonterminal prgs
syntax
  "_PAR" :: "prgs \<Rightarrow> 'a"
            ("(INTERLEAVING-BEGIN//_//INTERLEAVING-END)" [57] 56)
  "_AnnPrg" :: "['a, 'a, 'a, 'a] \<Rightarrow> prgs"
               ("(2 \<lbrakk> rely: _,/ pre: _,/ post: _ \<rbrakk>//_)" [90, 90, 90, 60] 57)
  "_AnnPrgs" :: "['a, 'a, 'a, 'a, prgs] \<Rightarrow> prgs"
                ("(2 \<lbrakk> rely: _,/ pre: _,/ post: _ \<rbrakk>//_)//\<parallel>//_" [90, 90, 90, 60, 57] 57)
  "_AnnPrgScheme" :: "['a, 'a, 'a, 'a, 'a, 'a, 'a] \<Rightarrow> prgs"
  ("  (2SCHEME-BEGIN [_ \<le> _ < _]//\<lbrakk> rely: _,/ pre: _,/ post: _ \<rbrakk>//_//SCHEME-END)" [0,0,0,90,90,90,0] 57)

  "_Prg" :: "['a] \<Rightarrow> prgs"
            ("(2  _)" [60] 57)
  "_Prgs" :: "['a, prgs] \<Rightarrow> prgs"
             ("(2  _)//\<parallel>//_" [60,57] 57)
  "_PrgScheme" :: "['a, 'a, 'a, 'a] \<Rightarrow> prgs"
                  ("  (2SCHEME-BEGIN [_ \<le> _ < _]//_//SCHEME-END)" [0,0,0,60] 57)

translations
  "_PAR ps" \<rightharpoonup> "CONST Parallel ps"
  "_AnnPrg r p q c" \<rightharpoonup> "([(c, \<lparr>ap_rely=r, ap_precond=p, ap_postcond=q\<rparr>)])"
  "_AnnPrgs r p q c ps" \<rightharpoonup> "((c, \<lparr>ap_rely=r, ap_precond=p, ap_postcond=q\<rparr>) # ps)"
  "_AnnPrgScheme j i k r p q c" \<rightharpoonup>
    "(CONST map (\<lambda>i. (c, \<lparr>ap_rely=r, ap_precond=p, ap_postcond=q\<rparr>)) [j..<k])"

  "_Prg c" \<rightharpoonup>
    "([(c, \<lparr>ap_rely=CONST UNIV, ap_precond=CONST UNIV, ap_postcond=CONST UNIV\<rparr>)])"
  "_Prgs c ps" \<rightharpoonup>
    "((c, \<lparr>ap_rely=CONST UNIV, ap_precond=CONST UNIV, ap_postcond=CONST UNIV\<rparr>) # ps)"
  "_PrgScheme j i k c" \<rightharpoonup>
    "(CONST map (\<lambda>i. (c, \<lparr>ap_rely=CONST UNIV, ap_precond=CONST UNIV, ap_postcond=CONST UNIV\<rparr> )) [j..<k])"

ML \<open>

fun dest_absL (x, T, body) =
  let
    fun name_clash (Free (y, _)) = (x = y)
      | name_clash (t $ u) = name_clash t orelse name_clash u
      | name_clash (Abs (_, _, t)) = name_clash t
      | name_clash _ = false;
  in
    if name_clash body then
      dest_absL (singleton (Name.variant_list [x]) x, T, body)    (*potentially slow*)
    else (x, subst_bound (Free (x, T), body))
  end;

  fun quote_tr' f (t :: ts) =
        Term.list_comb (f $ Syntax_Trans.quote_tr' @{syntax_const "_antiquote"} t, ts)
    | quote_tr' _ _ = raise Match;

  fun annquote_tr' f (r :: t :: ts) =
        Term.list_comb (f $ r $ Syntax_Trans.quote_tr' @{syntax_const "_antiquote"} t, ts)
    | annquote_tr' _ _ = raise Match;

  val assert_tr' = quote_tr' (Syntax.const @{syntax_const "_Assert"});

  fun annbexp_tr' name (r :: (Const (@{const_syntax Collect}, _) $ t) :: ts) =
        annquote_tr' (Syntax.const name) (r :: t :: ts)
    | annbexp_tr' name (r :: Const (@{const_syntax UNIV}, _) :: ts) =
        annquote_tr' (Syntax.const name)
                     (r :: Abs ("s", dummyT, Const (@{const_syntax True}, dummyT)) :: ts)
    | annbexp_tr' name (r :: Const (@{const_syntax Set.empty}, _) :: ts) =
        annquote_tr' (Syntax.const name)
                     (r :: Abs ("s", dummyT, Const (@{const_syntax False}, dummyT)) :: ts)
    | annbexp_tr' _ _ = raise Match;

  fun annassign_tr' (r :: Abs (x, _, f $ k $ Bound 0) :: ts) =
        quote_tr' (Syntax.const @{syntax_const "_Assign"} $ r $ Syntax_Trans.update_name_tr' f)
          (Abs (x, dummyT, Syntax_Trans.const_abs_tr' k) :: ts)
    | annassign_tr' _ = raise Match;

  fun dest_list (Const (@{const_syntax Nil}, _)) = []
    | dest_list (Const (@{const_syntax Cons}, _) $ x $ xs) = x :: dest_list xs
    | dest_list xs = [xs];

  fun new_Pair a b =
    (Const (@{const_syntax Pair}, dummyT) $ a $ b)

  fun dest_prod (Const (@{const_syntax Pair}, _) $ a $ b) = (a, b)
    | dest_prod _ = raise Match;

  fun dest_upt (Const (@{const_syntax upt},_) $ m $ n) = (m, n)
    | dest_upt _ = raise Match;

  fun dest_apar (Const (@{const_syntax annpar_ext}, _) $ r $ p $ q $ _) = (r, p, q)
    | dest_apar _ = raise Match;

  fun prg_tr' const aconst xs pqa =
        let val (c, apr) = dest_prod pqa
            val (R, P, Q) = dest_apar apr
            fun fake (Const (@{const_syntax UNIV},_)) = true
              | fake _ = false
            val const' = if fake R then const else aconst
            val ys = if fake R then [] else [R, P, Q]
        in list_comb (Syntax.const const', xs @ ys @ [c])
        end

  fun prgs_lst_tr'
            [Const (@{const_syntax map}, _) $ Abs (i, T, p) $ upt] =
        let val (j, k) = dest_upt upt
        in prg_tr' @{syntax_const "_PrgScheme"} @{syntax_const "_AnnPrgScheme"}
                 [j, Free (i, T), k] (snd(dest_absL (i, T, p)))
        end
    | prgs_lst_tr' [p] =
        prg_tr' @{syntax_const "_Prg"} @{syntax_const "_AnnPrg"} [] p
    | prgs_lst_tr' (p :: ps)  =
        prg_tr' @{syntax_const "_Prgs"} @{syntax_const "_AnnPrgs"} [] p $
          prgs_lst_tr' ps
    | prgs_lst_tr' _ = raise Match

  fun Parallel_tr (cs :: _) =
        let val cs' = dest_list cs
        in Syntax.const @{syntax_const "_PAR"} $
             prgs_lst_tr' cs' end
    | Parallel_tr _ = raise Match;

  fun Basic_tr (Abs (x, _, f $ k $ Bound 0) :: ts) =
      quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax_Trans.update_name_tr' f)
          (Abs (x, dummyT, Syntax_Trans.const_abs_tr' k) :: ts)
    | Basic_tr ((f $ k) :: ts) = quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax_Trans.update_name_tr' f)
          (k :: ts)
    | Basic_tr _ = raise Match;

\<close>

print_translation \<open>
  [(@{const_syntax Collect}, K assert_tr'),
   (@{const_syntax Basic}, K Basic_tr),
   (@{const_syntax Parallel}, K Parallel_tr)]
\<close>

end


(*  Title:      JinjaThreads/J/WellType.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

header {* \isaheader{Well-typedness of Jinja expressions} *}

theory WellType
imports
  Expr
  State
  "../Common/ExternalCallWF"
  "../Common/WellForm"
  "../Common/SemiType"
begin

declare Listn.lesub_list_impl_same_size[simp del]
declare listE_length [simp del]

type_synonym
  env  = "vname \<rightharpoonup> ty"

inductive
  WT :: "(ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool) \<Rightarrow> 'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> ty \<Rightarrow> bool" ("_,_,_ \<turnstile> _ :: _"   [51,51,51,51]50)
  and WTs :: "(ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool) \<Rightarrow> 'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> ty list \<Rightarrow> bool"
    ("_,_,_ \<turnstile> _ [::] _"   [51,51,51,51]50)
  for is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile> lub'((_,/ _)') = _" [51,51,51] 50)
  and P :: "'addr J_prog"
where

  WTNew:
  "is_class P C  \<Longrightarrow>
  is_lub,P,E \<turnstile> new C :: Class C"

| WTNewArray:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Integer; is_type P (T\<lfloor>\<rceil>) \<rbrakk> \<Longrightarrow>
  is_lub,P,E \<turnstile> newA T\<lfloor>e\<rceil> :: T\<lfloor>\<rceil>"

| WTCast:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: T; P \<turnstile> U \<le> T \<or> P \<turnstile> T \<le> U; is_type P U \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> Cast U e :: U"

| WTInstanceOf:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: T; P \<turnstile> U \<le> T \<or> P \<turnstile> T \<le> U; is_type P U; is_refT U \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e instanceof U :: Boolean"

| WTVal:
  "typeof v = Some T \<Longrightarrow>
  is_lub,P,E \<turnstile> Val v :: T"

| WTVar:
  "E V = Some T \<Longrightarrow>
  is_lub,P,E \<turnstile> Var V :: T"

| WTBinOp:
  "\<lbrakk> is_lub,P,E \<turnstile> e1 :: T1; is_lub,P,E \<turnstile> e2 :: T2; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e1\<guillemotleft>bop\<guillemotright>e2 :: T"

| WTLAss:
  "\<lbrakk> E V = Some T;  is_lub,P,E \<turnstile> e :: T';  P \<turnstile> T' \<le> T;  V \<noteq> this \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> V:=e :: Void"

| WTAAcc:
  "\<lbrakk> is_lub,P,E \<turnstile> a :: T\<lfloor>\<rceil>; is_lub,P,E \<turnstile> i :: Integer \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> a\<lfloor>i\<rceil> :: T"

| WTAAss:
  "\<lbrakk> is_lub,P,E \<turnstile> a :: T\<lfloor>\<rceil>; is_lub,P,E \<turnstile> i :: Integer; is_lub,P,E \<turnstile> e :: T'; P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> a\<lfloor>i\<rceil> := e :: Void"

| WTALength:
  "is_lub,P,E \<turnstile> a :: T\<lfloor>\<rceil> \<Longrightarrow> is_lub,P,E \<turnstile> a\<bullet>length :: Integer"

| WTFAcc:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees F:T (fm) in D \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e\<bullet>F{D} :: T"

| WTFAss:
  "\<lbrakk> is_lub,P,E \<turnstile> e\<^sub>1 :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees F:T (fm) in D; is_lub,P,E \<turnstile> e\<^sub>2 :: T'; P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e\<^sub>1\<bullet>F{D}:=e\<^sub>2 :: Void"

| WTCall:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: U; class_type_of' U = \<lfloor>C\<rfloor>; P \<turnstile> C sees M:Ts \<rightarrow> T = meth in D;
     is_lub,P,E \<turnstile> es [::] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> e\<bullet>M(es) :: T"

| WTBlock:
  "\<lbrakk> is_type P T;  is_lub,P,E(V \<mapsto> T) \<turnstile> e :: T'; case vo of None \<Rightarrow> True | \<lfloor>v\<rfloor> \<Rightarrow> \<exists>T'. typeof v = \<lfloor>T'\<rfloor> \<and> P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> {V:T=vo; e} :: T'"

| WTSynchronized:
  "\<lbrakk> is_lub,P,E \<turnstile> o' :: T; is_refT T; T \<noteq> NT; is_lub,P,E \<turnstile> e :: T' \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> sync(o') e :: T'"

-- "Note that insync is not statically typable."

| WTSeq:
  "\<lbrakk> is_lub,P,E \<turnstile> e\<^sub>1::T\<^sub>1;  is_lub,P,E \<turnstile> e\<^sub>2::T\<^sub>2 \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"
| WTCond:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Boolean;  is_lub,P,E \<turnstile> e\<^sub>1::T\<^sub>1;  is_lub,P,E \<turnstile> e\<^sub>2::T\<^sub>2; \<turnstile> lub(T\<^sub>1, T\<^sub>2) = T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T"

| WTWhile:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Boolean;  is_lub,P,E \<turnstile> c::T \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> while (e) c :: Void"

| WTThrow:
  "\<lbrakk> is_lub,P,E \<turnstile> e :: Class C; P \<turnstile> C \<preceq>\<^sup>* Throwable \<rbrakk> \<Longrightarrow>
  is_lub,P,E \<turnstile> throw e :: Void"

| WTTry:
  "\<lbrakk> is_lub,P,E \<turnstile> e\<^sub>1 :: T;  is_lub,P,E(V \<mapsto> Class C) \<turnstile> e\<^sub>2 :: T; P \<turnstile> C \<preceq>\<^sup>* Throwable \<rbrakk>
  \<Longrightarrow> is_lub,P,E \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :: T"

| WTNil: "is_lub,P,E \<turnstile> [] [::] []"

| WTCons: "\<lbrakk> is_lub,P,E \<turnstile> e :: T; is_lub,P,E \<turnstile> es [::] Ts \<rbrakk> \<Longrightarrow> is_lub,P,E \<turnstile> e#es [::] T#Ts"

abbreviation WT' :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> ty \<Rightarrow> bool" ("_,_ \<turnstile> _ :: _" [51,51,51] 50)
where "WT' P \<equiv> WT (TypeRel.is_lub P) P"

abbreviation WTs' :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> ty list \<Rightarrow> bool" ("_,_ \<turnstile> _ [::] _" [51,51,51] 50)
where "WTs' P \<equiv> WTs (TypeRel.is_lub P) P"

declare WT_WTs.intros[intro!]

inductive_simps WTs_iffs [iff]:
  "is_lub',P,E \<turnstile> [] [::] Ts"
  "is_lub',P,E \<turnstile> e#es [::] T#Ts"
  "is_lub',P,E \<turnstile> e#es [::] Ts"

lemma WTs_conv_list_all2:
  fixes is_lub
  shows "is_lub,P,E \<turnstile> es [::] Ts = list_all2 (WT is_lub P E) es Ts"
by(induct es arbitrary: Ts)(auto simp add: list_all2_Cons1 elim: WTs.cases)

lemma WTs_append [iff]: "\<And>is_lub Ts. (is_lub,P,E \<turnstile> es\<^sub>1 @ es\<^sub>2 [::] Ts) =
  (\<exists>Ts\<^sub>1 Ts\<^sub>2. Ts = Ts\<^sub>1 @ Ts\<^sub>2 \<and> is_lub,P,E \<turnstile> es\<^sub>1 [::] Ts\<^sub>1 \<and> is_lub,P,E \<turnstile> es\<^sub>2[::]Ts\<^sub>2)"
by(auto simp add: WTs_conv_list_all2 list_all2_append1 dest: list_all2_lengthD[symmetric])

inductive_simps WT_iffs [iff]:
  "is_lub',P,E \<turnstile> Val v :: T"
  "is_lub',P,E \<turnstile> Var V :: T"
  "is_lub',P,E \<turnstile> e\<^sub>1;;e\<^sub>2 :: T\<^sub>2"
  "is_lub',P,E \<turnstile> {V:T=vo; e} :: T'"

inductive_cases WT_elim_cases[elim!]:
  "is_lub',P,E \<turnstile> V :=e :: T"
  "is_lub',P,E \<turnstile> sync(o') e :: T"
  "is_lub',P,E \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 :: T"
  "is_lub',P,E \<turnstile> while (e) c :: T"
  "is_lub',P,E \<turnstile> throw e :: T"
  "is_lub',P,E \<turnstile> try e\<^sub>1 catch(C V) e\<^sub>2 :: T"
  "is_lub',P,E \<turnstile> Cast D e :: T"
  "is_lub',P,E \<turnstile> e instanceof U :: T"
  "is_lub',P,E \<turnstile> a\<bullet>F{D} :: T"
  "is_lub',P,E \<turnstile> a\<bullet>F{D} := v :: T"
  "is_lub',P,E \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 :: T"
  "is_lub',P,E \<turnstile> new C :: T"
  "is_lub',P,E \<turnstile> newA T\<lfloor>e\<rceil> :: T'"
  "is_lub',P,E \<turnstile> a\<lfloor>i\<rceil> := e :: T"
  "is_lub',P,E \<turnstile> a\<lfloor>i\<rceil> :: T"
  "is_lub',P,E \<turnstile> a\<bullet>length :: T"
  "is_lub',P,E \<turnstile> e\<bullet>M(ps) :: T"
  "is_lub',P,E \<turnstile> sync(o') e :: T"
  "is_lub',P,E \<turnstile> insync(a) e :: T"

lemma fixes is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile> lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_unique: "\<And>T1 T2 T3 T4. \<lbrakk> \<turnstile> lub(T1, T2) = T3; \<turnstile> lub(T1, T2) = T4 \<rbrakk> \<Longrightarrow> T3 = T4"
  shows WT_unique: "\<lbrakk> is_lub,P,E \<turnstile> e :: T; is_lub,P,E \<turnstile> e :: T' \<rbrakk> \<Longrightarrow> T = T'"
  and WTs_unique: "\<lbrakk> is_lub,P,E \<turnstile> es [::] Ts; is_lub,P,E \<turnstile> es [::] Ts' \<rbrakk> \<Longrightarrow> Ts = Ts'"
apply(induct arbitrary: T' and Ts' rule: WT_WTs.inducts)
apply blast
apply blast
apply blast
apply blast
apply fastforce
apply fastforce
apply(fastforce dest: WT_binop_fun)
apply fastforce
apply fastforce
apply fastforce
apply fastforce
apply(fastforce dest: sees_field_fun)
apply(fastforce dest: sees_field_fun)
apply(fastforce dest: sees_method_fun)
apply fastforce
apply fastforce
apply fastforce
apply(blast dest: is_lub_unique)
apply fastforce
apply fastforce
apply blast
apply fastforce
apply fastforce
done

lemma fixes is_lub
  shows wt_env_mono: "is_lub,P,E \<turnstile> e :: T \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> is_lub,P,E' \<turnstile> e :: T)"
  and wts_env_mono: "is_lub,P,E \<turnstile> es [::] Ts \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> is_lub,P,E' \<turnstile> es [::] Ts)"
apply(induct rule: WT_WTs.inducts)
apply(simp add: WTNew)
apply(simp add: WTNewArray)
apply(fastforce simp: WTCast)
apply(fastforce simp: WTInstanceOf)
apply(fastforce simp: WTVal)
apply(simp add: WTVar map_le_def dom_def)
apply(fastforce simp: WTBinOp)
apply(force simp:map_le_def)
apply(simp add: WTAAcc)
apply(simp add: WTAAss, fastforce)
apply(simp add: WTALength, fastforce)
apply(fastforce simp: WTFAcc)
apply(fastforce simp: WTFAss del:WT_WTs.intros WT_elim_cases)
apply(fastforce)
apply(fastforce simp: map_le_def WTBlock)
apply(fastforce simp: WTSynchronized)
apply(fastforce simp: WTSeq)
apply(fastforce simp: WTCond)
apply(fastforce simp: WTWhile)
apply(fastforce simp: WTThrow)
apply(fastforce simp: WTTry map_le_def dom_def)
apply(fastforce)+
done

lemma fixes is_lub
  shows WT_fv: "is_lub,P,E \<turnstile> e :: T \<Longrightarrow> fv e \<subseteq> dom E"
  and WT_fvs: "is_lub,P,E \<turnstile> es [::] Ts \<Longrightarrow> fvs es \<subseteq> dom E"
apply(induct rule:WT_WTs.inducts)
apply(simp_all del: fun_upd_apply)
apply fast+
done

lemma fixes is_lub
  shows WT_expr_locks: "is_lub,P,E \<turnstile> e :: T \<Longrightarrow> expr_locks e = (\<lambda>ad. 0)"
  and WTs_expr_lockss: "is_lub,P,E \<turnstile> es [::] Ts \<Longrightarrow> expr_lockss es = (\<lambda>ad. 0)"
by(induct rule: WT_WTs.inducts)(auto)

lemma
  fixes is_lub :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile> lub'((_,/ _)') = _" [51,51,51] 50)
  assumes is_lub_is_type: "\<And>T1 T2 T3. \<lbrakk> \<turnstile> lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T3"
  and wf: "wf_prog wf_md P"
  shows WT_is_type: "\<lbrakk> is_lub,P,E \<turnstile> e :: T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> is_type P T"
  and WTs_is_type: "\<lbrakk> is_lub,P,E \<turnstile> es [::] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> set Ts \<subseteq> types P"
apply(induct rule: WT_WTs.inducts)
apply simp
apply simp
apply simp
apply simp
apply (simp add:typeof_lit_is_type)
apply (fastforce intro:nth_mem simp add: ran_def)
apply(simp add: WT_binop_is_type)
apply(simp)
apply(simp del: is_type_array add: is_type_ArrayD)
apply(simp)
apply(simp)
apply(simp add:sees_field_is_type[OF _ wf])
apply(simp)
apply(fastforce dest: sees_wf_mdecl[OF wf] simp:wf_mdecl_def)
apply(fastforce simp add: ran_def split: split_if_asm)
apply(simp add: is_class_Object[OF wf])
apply(simp)
apply(simp)
apply(fastforce intro: is_lub_is_type)
apply(simp)
apply(simp)
apply simp
apply simp
apply simp
done

lemma
  fixes is_lub1 :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile>1 lub'((_,/ _)') = _" [51,51,51] 50)
  and is_lub2 :: "ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("\<turnstile>2 lub'((_,/ _)') = _" [51,51,51] 50)
  assumes wf: "wf_prog wf_md P"
  and is_lub1_into_is_lub2: "\<And>T1 T2 T3. \<lbrakk> \<turnstile>1 lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> \<turnstile>2 lub(T1, T2) = T3"
  and is_lub2_is_type: "\<And>T1 T2 T3. \<lbrakk> \<turnstile>2 lub(T1, T2) = T3; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T3"
  shows WT_change_is_lub: "\<lbrakk> is_lub1,P,E \<turnstile> e :: T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> is_lub2,P,E \<turnstile> e :: T"
  and WTs_change_is_lub: "\<lbrakk> is_lub1,P,E \<turnstile> es [::] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> is_lub2,P,E \<turnstile> es [::] Ts"
proof(induct rule: WT_WTs.inducts)
  case (WTBlock U E V e' T vo)
  from `is_type P U` `ran E \<subseteq> types P`
  have "ran (E(V \<mapsto> U)) \<subseteq> types P" by(auto simp add: ran_def)
  hence "is_lub2,P,E(V \<mapsto> U) \<turnstile> e' :: T" by(rule WTBlock)
  with `is_type P U` show ?case
    using `case vo of None \<Rightarrow> True | \<lfloor>v\<rfloor> \<Rightarrow> \<exists>T'. typeof v = \<lfloor>T'\<rfloor> \<and> P \<turnstile> T' \<le> U` by auto
next
  case (WTCond E e e1 T1 e2 T2 T)
  from `ran E \<subseteq> types P` have "is_lub2,P,E \<turnstile> e :: Boolean" "is_lub2,P,E \<turnstile> e1 :: T1" "is_lub2,P,E \<turnstile> e2 :: T2"
    by(rule WTCond)+
  moreover from is_lub2_is_type wf `is_lub2,P,E \<turnstile> e1 :: T1` `ran E \<subseteq> types P`
  have "is_type P T1" by(rule WT_is_type)
  from is_lub2_is_type wf `is_lub2,P,E \<turnstile> e2 :: T2` `ran E \<subseteq> types P`
  have "is_type P T2" by(rule WT_is_type)
  with `\<turnstile>1 lub(T1, T2) = T` `is_type P T1`
  have "\<turnstile>2 lub(T1, T2) = T" by(rule is_lub1_into_is_lub2)
  ultimately show ?case ..
next
  case (WTTry E e1 T V C e2)
  from `ran E \<subseteq> types P` have "is_lub2,P,E \<turnstile> e1 :: T" by(rule WTTry)
  moreover from `P \<turnstile> C \<preceq>\<^sup>* Throwable` have "is_class P C"
    by(rule is_class_sub_Throwable[OF wf])
  with `ran E \<subseteq> types P` have "ran (E(V \<mapsto> Class C)) \<subseteq> types P"
    by(auto simp add: ran_def)
  hence "is_lub2,P,E(V \<mapsto> Class C) \<turnstile> e2 :: T" by(rule WTTry)
  ultimately show ?case using `P \<turnstile> C \<preceq>\<^sup>* Throwable` ..
qed auto

subsection {* Code generator setup *}

lemma WTBlock_code:
  "\<And>is_lub. \<lbrakk> is_type P T; is_lub,P,E(V \<mapsto> T) \<turnstile> e :: T';
     case vo of None \<Rightarrow> True | \<lfloor>v\<rfloor> \<Rightarrow> case typeof v of None \<Rightarrow> False | Some T' \<Rightarrow> P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow>  is_lub,P,E \<turnstile> {V:T=vo; e} :: T'"
by(auto)

lemmas [code_pred_intro] =
  WTNew WTNewArray WTCast WTInstanceOf WTVal WTVar WTBinOp WTLAss WTAAcc WTAAss WTALength WTFAcc WTFAss WTCall
declare
  WTBlock_code [code_pred_intro WTBlock']
lemmas [code_pred_intro] =
  WTSynchronized WTSeq WTCond WTWhile WTThrow WTTry
  WTNil WTCons

code_pred
  (modes:
    (i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
    (i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  [detect_switches, skip_proof]
  WT
proof -
  case WT
  from WT.prems show thesis
  proof cases
    case (WTBlock T V e vo)
    thus thesis using WTBlock'[OF refl refl refl, of V T vo e] by(auto)
  qed(assumption|erule that[OF refl refl refl]|rule refl)+
next
  case WTs
  from WTs.prems that show thesis by cases blast+
qed

inductive is_lub_sup :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool"
for P T1 T2 T3
where
  "sup P T1 T2 = OK T3 \<Longrightarrow> is_lub_sup P T1 T2 T3"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  is_lub_sup
.

definition WT_code :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr \<Rightarrow> ty \<Rightarrow> bool" ("_,_ \<turnstile> _ ::' _" [51,51,51] 50)
where "WT_code P \<equiv> WT (is_lub_sup P) P"

definition WTs_code :: "'addr J_prog \<Rightarrow> env \<Rightarrow> 'addr expr list \<Rightarrow> ty list \<Rightarrow> bool" ("_,_ \<turnstile> _ [::''] _" [51,51,51] 50)
where "WTs_code P \<equiv> WTs (is_lub_sup P) P"

lemma assumes wf: "wf_prog wf_md P"
  shows WT_code_into_WT:
  "\<lbrakk> P,E \<turnstile> e ::' T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> e :: T"

  and WTs_code_into_WTs:
  "\<lbrakk> P,E \<turnstile> es [::'] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> es [::] Ts"
proof -
  assume ran: "ran E \<subseteq> types P"
  { assume wt: "P,E \<turnstile> e ::' T"
    show "P,E \<turnstile> e :: T"
      by(rule WT_change_is_lub[OF wf _ _ wt[unfolded WT_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
  { assume wts: "P,E \<turnstile> es [::'] Ts"
    show "P,E \<turnstile> es [::] Ts"
      by(rule WTs_change_is_lub[OF wf _ _ wts[unfolded WTs_code_def] ran])(blast elim!: is_lub_sup.cases intro: sup_is_lubI[OF wf] is_lub_is_type[OF wf])+ }
qed

lemma assumes wf: "wf_prog wf_md P"
  shows WT_into_WT_code:
  "\<lbrakk> P,E \<turnstile> e :: T; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> e ::' T"

  and WT_into_WTs_code_OK:
  "\<lbrakk> P,E \<turnstile> es [::] Ts; ran E \<subseteq> types P \<rbrakk> \<Longrightarrow> P,E \<turnstile> es [::'] Ts"
proof -
  assume ran: "ran E \<subseteq> types P"
  { assume wt: "P,E \<turnstile> e :: T"
    show "P,E \<turnstile> e ::' T" unfolding WT_code_def
      by(rule WT_change_is_lub[OF wf _ _ wt ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
  { assume wts: "P,E \<turnstile> es [::] Ts"
    show "P,E \<turnstile> es [::'] Ts" unfolding WTs_code_def
      by(rule WTs_change_is_lub[OF wf _ _ wts ran])(blast intro!: is_lub_sup.intros intro: is_lub_subD[OF wf] sup_is_type[OF wf] elim!: is_lub_sup.cases)+ }
qed

theorem WT_eq_WT_code:
  assumes "wf_prog wf_md P"
  and "ran E \<subseteq> types P"
  shows "P,E \<turnstile> e :: T \<longleftrightarrow> P,E \<turnstile> e ::' T"
using assms by(blast intro: WT_code_into_WT WT_into_WT_code)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  WT_code
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  WTs_code
.

end


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

(* Author: Andrew Boyton, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

chapter "Instantiating capDL as a separation algebra."

theory Abstract_Separation_D
imports
  "../../Sep_Tactics"
  Types_D
  "../../Map_Extra"
begin

(**************************************
 * Start of lemmas to move elsewhere. *
 **************************************)

lemma inter_empty_not_both:
"\<lbrakk>x \<in> A; A \<inter> B = {}\<rbrakk> \<Longrightarrow> x \<notin> B"
  by fastforce

lemma union_intersection:
  "A \<inter> (A \<union> B) = A"
  "B \<inter> (A \<union> B) = B"
  "(A \<union> B) \<inter> A = A"
  "(A \<union> B) \<inter> B = B"
  by fastforce+

lemma union_intersection1: "A \<inter> (A \<union> B) = A"
  by (rule inf_sup_absorb)
lemma union_intersection2: "B \<inter> (A \<union> B) = B"
  by fastforce

(* This lemma is strictly weaker than restrict_map_disj. *)
lemma restrict_map_disj':
  "S \<inter> T = {} \<Longrightarrow> h |` S \<bottom> h' |` T"
  by (auto simp: map_disj_def restrict_map_def dom_def)

lemma map_add_restrict_comm:
  "S \<inter> T = {} \<Longrightarrow> h |` S ++ h' |` T = h' |` T ++ h |` S"
  apply (drule restrict_map_disj')
  apply (erule map_add_com)
  done

(************************************
 * End of lemmas to move elsewhere. *
 ************************************)

(* The state for separation logic has:
   * The memory heap.
   * A function for which objects own which fields.
     In capDL, we say that an object either owns all of its fields, or none of them.
   These are both taken from the cdl_state.
 *)

datatype sep_state = SepState cdl_heap cdl_ghost_state

(* Functions to get the heap and the ghost_state from the sep_state. *)
primrec sep_heap :: "sep_state \<Rightarrow> cdl_heap"
where  "sep_heap (SepState h gs) = h"

primrec sep_ghost_state :: "sep_state \<Rightarrow> cdl_ghost_state"
where  "sep_ghost_state (SepState h gs) = gs"

definition
  the_set :: "'a option set \<Rightarrow> 'a set"
where
  "the_set xs = {x. Some x \<in> xs}"

lemma the_set_union [simp]:
  "the_set (A \<union> B) = the_set A \<union> the_set B"
  by (fastforce simp: the_set_def)

lemma the_set_inter [simp]:
  "the_set (A \<inter> B) = the_set A \<inter> the_set B"
  by (fastforce simp: the_set_def)

lemma the_set_inter_empty:
  "A \<inter> B = {} \<Longrightarrow> the_set A \<inter> the_set B = {}"
  by (fastforce simp: the_set_def)

(* As the capDL operations mostly take the state (rather than the heap)
 * we need to redefine some of them again to take just the heap.
 *)
definition
  slots_of_heap :: "cdl_heap \<Rightarrow> cdl_object_id \<Rightarrow> cdl_cap_map"
where
  "slots_of_heap h \<equiv> \<lambda>obj_id.
  case h obj_id of
    None \<Rightarrow> Map.empty
  | Some obj \<Rightarrow> object_slots obj"

(* Adds new caps to an object. It won't overwrite on a collision. *)
definition
  add_to_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "add_to_slots new_val obj \<equiv> update_slots (new_val ++ (object_slots obj)) obj"

lemma add_to_slots_assoc:
  "add_to_slots x (add_to_slots (y ++ z) obj) =
   add_to_slots (x ++ y) (add_to_slots z obj)"
  apply (clarsimp simp: add_to_slots_def update_slots_def object_slots_def)
  apply (fastforce simp: cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)
  done

(* Lemmas about add_to_slots, update_slots and object_slots. *)
lemma add_to_slots_twice [simp]:
  "add_to_slots x (add_to_slots y a) = add_to_slots (x ++ y) a"
  by (fastforce simp: add_to_slots_def update_slots_def object_slots_def
              split: cdl_object.splits)

lemma slots_of_heap_empty [simp]: "slots_of_heap Map.empty object_id = Map.empty"
  by (simp add: slots_of_heap_def)

lemma slots_of_heap_empty2 [simp]:
  "h obj_id = None \<Longrightarrow> slots_of_heap h obj_id = Map.empty"
  by (simp add: slots_of_heap_def)

lemma update_slots_add_to_slots_empty [simp]:
  "update_slots Map.empty (add_to_slots new obj) = update_slots Map.empty obj"
  by (clarsimp simp: update_slots_def add_to_slots_def split:cdl_object.splits)

lemma update_object_slots_id [simp]: "update_slots (object_slots a) a = a"
  by (clarsimp simp: update_slots_def object_slots_def
              split: cdl_object.splits)

lemma update_slots_of_heap_id [simp]:
  "h obj_id = Some obj \<Longrightarrow> update_slots (slots_of_heap h obj_id) obj = obj"
  by (clarsimp simp: update_slots_def slots_of_heap_def object_slots_def
              split: cdl_object.splits)

lemma add_to_slots_empty [simp]: "add_to_slots Map.empty h = h"
  by (simp add: add_to_slots_def)

lemma update_slots_eq:
  "update_slots a o1 = update_slots a o2 \<Longrightarrow> update_slots b o1 = update_slots b o2"
  by (fastforce simp: update_slots_def cdl_tcb.splits cdl_cnode.splits
              split: cdl_object.splits)

(* If there are not two conflicting objects at a position in two states.
 * Objects conflict if their types are different or their ghost_states collide.
 *)
definition
  not_conflicting_objects :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_object_id \<Rightarrow> bool"
where
  "not_conflicting_objects state_a state_b = (\<lambda>obj_id.
 let heap_a = sep_heap state_a;
     heap_b = sep_heap state_b;
     gs_a = sep_ghost_state state_a;
     gs_b = sep_ghost_state state_b
 in case (heap_a obj_id, heap_b obj_id) of
    (Some o1, Some o2) \<Rightarrow> object_type o1 = object_type o2 \<and> gs_a obj_id \<inter> gs_b obj_id = {}
   | _ \<Rightarrow> True)"

(* "Cleans" slots to conform with the components. *)
definition
  clean_slots :: "cdl_cap_map \<Rightarrow> cdl_components \<Rightarrow> cdl_cap_map"
where
  "clean_slots slots cmp \<equiv> slots |` the_set cmp"

(* Sets the fields of an object to a "clean" state.
   Because a frame's size is part of it's type, we don't reset it. *)
definition
  object_clean_fields :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean_fields obj cmp \<equiv> if None \<in> cmp then obj else case obj of
    Tcb x \<Rightarrow> Tcb (x\<lparr>cdl_tcb_fault_endpoint := undefined\<rparr>)
  | CNode x \<Rightarrow> CNode (x\<lparr>cdl_cnode_size_bits := undefined \<rparr>)
  | _ \<Rightarrow> obj"

(* Sets the slots of an object to a "clean" state. *)
definition
  object_clean_slots :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean_slots obj cmp \<equiv> update_slots (clean_slots (object_slots obj) cmp) obj"

(* Sets an object to a "clean" state. *)
definition
  object_clean :: "cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_clean obj gs \<equiv> object_clean_slots (object_clean_fields obj gs) gs"

(* Overrides the left object with the attributes of the right, as specified by the ghost state.
   If the components for an object are empty, then this object is treated as empty, and thus ignored.
 *)
definition
  object_add :: "cdl_object \<Rightarrow> cdl_object \<Rightarrow> cdl_components \<Rightarrow> cdl_components \<Rightarrow> cdl_object"
where
  "object_add obj_a obj_b cmps_a cmps_b \<equiv>
  let clean_obj_a = object_clean obj_a cmps_a;
      clean_obj_b = object_clean obj_b cmps_b
  in if (cmps_a = {})
     then clean_obj_b
     else if (cmps_b = {})
     then clean_obj_a
     else if (None \<in> cmps_b)
     then (update_slots (object_slots clean_obj_a ++ object_slots clean_obj_b) clean_obj_b)
     else (update_slots (object_slots clean_obj_a ++ object_slots clean_obj_b) clean_obj_a)"

(* Heaps are added by adding their respective objects.
 * The ghost state tells us which object's fields should be taken.
 * Adding objects of the same type adds their caps
 *   (overwrites the left with the right).
 *)
definition
  cdl_heap_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_heap"
where
  "cdl_heap_add state_a state_b \<equiv> \<lambda>obj_id.
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    case heap_b obj_id of
      None \<Rightarrow> heap_a obj_id
    | Some obj_b \<Rightarrow>
        (case heap_a obj_id of
           None \<Rightarrow> heap_b obj_id
         | Some obj_a \<Rightarrow> Some (object_add obj_a obj_b (gs_a obj_id) (gs_b obj_id)))"

(* Heaps are added by adding their repsective objects.
 * The ghost state tells us which object's fields should be taken.
 * Adding objects of the same type adds their caps
 *   (overwrites the left with the right).
 *)
definition
  cdl_ghost_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> cdl_ghost_state"
where
  "cdl_ghost_state_add state_a state_b \<equiv> \<lambda>obj_id.
 let heap_a = sep_heap state_a;
     heap_b = sep_heap state_b;
     gs_a = sep_ghost_state state_a;
     gs_b = sep_ghost_state state_b
 in      if heap_a obj_id = None \<and> heap_b obj_id \<noteq> None then gs_b obj_id
    else if heap_b obj_id = None \<and> heap_a obj_id \<noteq> None then gs_a obj_id
    else gs_a obj_id \<union> gs_b obj_id"

(* Adding states adds their heaps,
 *  and each objects owns whichever fields it owned in either heap.
 *)
definition
  sep_state_add :: "sep_state \<Rightarrow> sep_state \<Rightarrow> sep_state"
where
  "sep_state_add state_a state_b \<equiv>
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    SepState (cdl_heap_add state_a state_b) (cdl_ghost_state_add state_a state_b)"

(* Heaps are disjoint if for all of their objects:
   * the caps of their respective objects are disjoint,
   * their respective objects don't conflict,
   * they don't both own any of the same fields.
*)
definition
  sep_state_disj :: "sep_state \<Rightarrow> sep_state \<Rightarrow> bool"
where
  "sep_state_disj state_a state_b \<equiv>
  let
    heap_a = sep_heap state_a;
    heap_b = sep_heap state_b;
    gs_a = sep_ghost_state state_a;
    gs_b = sep_ghost_state state_b
  in
    \<forall>obj_id. not_conflicting_objects state_a state_b obj_id"

lemma not_conflicting_objects_comm:
  "not_conflicting_objects h1 h2 obj = not_conflicting_objects h2 h1 obj"
  apply (clarsimp simp: not_conflicting_objects_def split:option.splits)
  apply (fastforce simp: update_slots_def cdl_tcb.splits cdl_cnode.splits
              split: cdl_object.splits)
  done

lemma object_clean_comm:
  "\<lbrakk>object_type obj_a = object_type obj_b;
    object_slots obj_a ++ object_slots obj_b = object_slots obj_b ++ object_slots obj_a; None \<notin> cmp\<rbrakk>
  \<Longrightarrow> object_clean (add_to_slots (object_slots obj_a) obj_b) cmp =
      object_clean (add_to_slots (object_slots obj_b) obj_a) cmp"
  apply (clarsimp simp: object_type_def split: cdl_object.splits)
  apply (clarsimp simp: object_clean_def object_clean_slots_def object_clean_fields_def
                        add_to_slots_def object_slots_def update_slots_def
                        cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)+
  done

lemma add_to_slots_object_slots:
  "object_type y = object_type z
 \<Longrightarrow> add_to_slots (object_slots (add_to_slots (x) y)) z =
     add_to_slots (x ++ object_slots y) z"
  apply (clarsimp simp: add_to_slots_def update_slots_def object_slots_def)
  apply (fastforce simp: object_type_def cdl_tcb.splits cdl_cnode.splits
                 split: cdl_object.splits)
  done

lemma not_conflicting_objects_empty [simp]:
  "not_conflicting_objects s (SepState Map.empty (\<lambda>obj_id. {})) obj_id"
  by (clarsimp simp: not_conflicting_objects_def split:option.splits)

lemma empty_not_conflicting_objects [simp]:
  "not_conflicting_objects (SepState Map.empty (\<lambda>obj_id. {})) s obj_id"
  by (clarsimp simp: not_conflicting_objects_def split:option.splits)

lemma not_conflicting_objects_empty_object [elim!]:
  "(sep_heap x) obj_id = None \<Longrightarrow> not_conflicting_objects x y obj_id"
  by (clarsimp simp: not_conflicting_objects_def)

lemma empty_object_not_conflicting_objects [elim!]:
  "(sep_heap y) obj_id = None \<Longrightarrow> not_conflicting_objects x y obj_id"
  apply (drule not_conflicting_objects_empty_object [where y=x])
  apply (clarsimp simp: not_conflicting_objects_comm)
  done

lemma cdl_heap_add_empty [simp]:
 "cdl_heap_add (SepState h gs) (SepState Map.empty (\<lambda>obj_id. {})) = h"
  by (simp add: cdl_heap_add_def)

lemma empty_cdl_heap_add [simp]:
  "cdl_heap_add (SepState Map.empty (\<lambda>obj_id. {})) (SepState h gs)= h"
  apply (simp add: cdl_heap_add_def)
  apply (rule ext)
  apply (clarsimp split: option.splits)
  done

lemma map_add_result_empty1: "a ++ b = Map.empty \<Longrightarrow> a = Map.empty"
  apply (subgoal_tac "dom (a++b) = {}")
   apply (subgoal_tac "dom (a) = {}")
    apply clarsimp
   apply (unfold dom_map_add)[1]
   apply clarsimp
  apply clarsimp
  done

lemma map_add_result_empty2: "a ++ b = Map.empty \<Longrightarrow> b = Map.empty"
  apply (subgoal_tac "dom (a++b) = {}")
   apply (subgoal_tac "dom (a) = {}")
    apply clarsimp
   apply (unfold dom_map_add)[1]
   apply clarsimp
  apply clarsimp
  done

lemma map_add_emptyE [elim!]: "\<lbrakk>a ++ b = Map.empty; \<lbrakk>a = Map.empty; b = Map.empty\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  apply (frule map_add_result_empty1)
  apply (frule map_add_result_empty2)
  apply clarsimp
  done

lemma clean_slots_empty [simp]:
  "clean_slots Map.empty cmp = Map.empty"
  by (clarsimp simp: clean_slots_def)

lemma object_type_update_slots [simp]:
  "object_type (update_slots slots x) = object_type x"
  by (clarsimp simp: object_type_def update_slots_def split: cdl_object.splits)

lemma object_type_object_clean_slots [simp]:
  "object_type (object_clean_slots x cmp) = object_type x"
  by (clarsimp simp: object_clean_slots_def)

lemma object_type_object_clean_fields [simp]:
  "object_type (object_clean_fields x cmp) = object_type x"
  by (clarsimp simp: object_clean_fields_def object_type_def split: cdl_object.splits)

lemma object_type_object_clean [simp]:
  "object_type (object_clean x cmp) = object_type x"
  by (clarsimp simp: object_clean_def)

lemma object_type_add_to_slots [simp]:
  "object_type (add_to_slots slots x) = object_type x"
  by (clarsimp simp: object_type_def add_to_slots_def update_slots_def split: cdl_object.splits)

lemma object_slots_update_slots [simp]:
  "has_slots obj \<Longrightarrow> object_slots (update_slots slots obj) = slots"
  by (clarsimp simp: object_slots_def update_slots_def has_slots_def
              split: cdl_object.splits)

lemma object_slots_update_slots_empty [simp]:
  "\<not>has_slots obj \<Longrightarrow> object_slots (update_slots slots obj) = Map.empty"
  by (clarsimp simp: object_slots_def update_slots_def has_slots_def
                 split: cdl_object.splits)

lemma update_slots_no_slots [simp]:
  "\<not>has_slots obj \<Longrightarrow> update_slots slots obj = obj"
  by (clarsimp simp: update_slots_def has_slots_def split: cdl_object.splits)

lemma update_slots_update_slots [simp]:
  "update_slots slots (update_slots slots' obj) = update_slots slots obj"
  by (clarsimp simp: update_slots_def split: cdl_object.splits)

lemma update_slots_same_object:
  "a = b \<Longrightarrow> update_slots a obj = update_slots b obj"
  by (erule arg_cong)

lemma object_type_has_slots:
  "\<lbrakk>has_slots x; object_type x = object_type y\<rbrakk> \<Longrightarrow> has_slots y"
  by (clarsimp simp: object_type_def has_slots_def split: cdl_object.splits)

lemma object_slots_object_clean_fields [simp]:
  "object_slots (object_clean_fields obj cmp) = object_slots obj"
  by (clarsimp simp: object_slots_def object_clean_fields_def split: cdl_object.splits)

lemma object_slots_object_clean_slots [simp]:
  "object_slots (object_clean_slots obj cmp) = clean_slots (object_slots obj) cmp"
  by (clarsimp simp: object_clean_slots_def object_slots_def update_slots_def split: cdl_object.splits)

lemma object_slots_object_clean [simp]:
  "object_slots (object_clean obj cmp) = clean_slots (object_slots obj) cmp"
  by (clarsimp simp: object_clean_def)

lemma object_slots_add_to_slots [simp]:
  "object_type y = object_type z \<Longrightarrow> object_slots (add_to_slots (object_slots y) z) = object_slots y ++ object_slots z"
  by (clarsimp simp: object_slots_def add_to_slots_def update_slots_def object_type_def split: cdl_object.splits)

lemma update_slots_object_clean_slots [simp]:
  "update_slots slots (object_clean_slots obj cmp) = update_slots slots obj"
  by (clarsimp simp: object_clean_slots_def)

lemma object_clean_fields_idem [simp]:
  "object_clean_fields (object_clean_fields obj cmp) cmp = object_clean_fields obj cmp"
  by (clarsimp simp: object_clean_fields_def split: cdl_object.splits)

lemma object_clean_slots_idem [simp]:
  "object_clean_slots (object_clean_slots obj cmp) cmp = object_clean_slots obj cmp"
  apply (case_tac  "has_slots obj")
  apply (clarsimp simp: object_clean_slots_def clean_slots_def)+
  done

lemma object_clean_fields_object_clean_slots [simp]:
  "object_clean_fields (object_clean_slots obj gs) gs = object_clean_slots (object_clean_fields obj gs) gs"
  by (clarsimp simp: object_clean_fields_def object_clean_slots_def
                     clean_slots_def object_slots_def update_slots_def
              split: cdl_object.splits)

lemma object_clean_idem [simp]:
  "object_clean (object_clean obj cmp) cmp = object_clean obj cmp"
  by (clarsimp simp: object_clean_def)

lemma has_slots_object_clean_slots:
 "has_slots (object_clean_slots obj cmp) = has_slots obj"
  by (clarsimp simp: has_slots_def object_clean_slots_def update_slots_def split: cdl_object.splits)

lemma has_slots_object_clean_fields:
 "has_slots (object_clean_fields obj cmp) = has_slots obj"
  by (clarsimp simp: has_slots_def object_clean_fields_def split: cdl_object.splits)

lemma has_slots_object_clean:
 "has_slots (object_clean obj cmp) = has_slots obj"
  by (clarsimp simp: object_clean_def has_slots_object_clean_slots has_slots_object_clean_fields)

lemma object_slots_update_slots_object_clean_fields [simp]:
  "object_slots (update_slots slots (object_clean_fields obj cmp)) = object_slots (update_slots slots obj)"
  apply (case_tac "has_slots obj")
   apply (clarsimp simp: has_slots_object_clean_fields)+
  done

lemma object_clean_fields_update_slots [simp]:
 "object_clean_fields (update_slots slots obj) cmp = update_slots slots (object_clean_fields obj cmp)"
  by (clarsimp simp: object_clean_fields_def update_slots_def split: cdl_object.splits)

lemma object_clean_fields_twice [simp]:
  "(object_clean_fields (object_clean_fields obj cmp') cmp) = object_clean_fields obj (cmp \<inter> cmp')"
  by (clarsimp simp: object_clean_fields_def split: cdl_object.splits)

lemma update_slots_object_clean_fields:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'\<rbrakk>
    \<Longrightarrow> update_slots slots (object_clean_fields obj cmps) =
        update_slots slots (object_clean_fields obj' cmps')"
  by (fastforce simp: update_slots_def object_clean_fields_def object_type_def split: cdl_object.splits)

lemma object_clean_fields_no_slots:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'; \<not> has_slots obj; \<not> has_slots obj'\<rbrakk>
    \<Longrightarrow> object_clean_fields obj cmps = object_clean_fields obj' cmps'"
  by (fastforce simp: object_clean_fields_def object_type_def has_slots_def split: cdl_object.splits)

lemma update_slots_object_clean:
  "\<lbrakk>None \<notin> cmps; None \<notin> cmps'; object_type obj = object_type obj'\<rbrakk>
   \<Longrightarrow> update_slots slots (object_clean obj cmps) = update_slots slots (object_clean obj' cmps')"
  apply (clarsimp simp: object_clean_def object_clean_slots_def)
  apply (erule (2) update_slots_object_clean_fields)
  done

lemma cdl_heap_add_assoc':
  "\<forall>obj_id. not_conflicting_objects x z obj_id \<and>
            not_conflicting_objects y z obj_id \<and>
            not_conflicting_objects x z obj_id \<Longrightarrow>
   cdl_heap_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
   cdl_heap_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (rule ext)
  apply (rename_tac obj_id)
  apply (erule_tac x=obj_id in allE)
  apply (clarsimp simp: cdl_heap_add_def cdl_ghost_state_add_def not_conflicting_objects_def)
  apply (simp add: Let_unfold split: option.splits)
  apply (rename_tac obj_y obj_x obj_z)
  apply (clarsimp simp: object_add_def clean_slots_def object_clean_def object_clean_slots_def Let_unfold)
  apply (case_tac "has_slots obj_z")
   apply (subgoal_tac "has_slots obj_y")
    apply (subgoal_tac "has_slots obj_x")
     apply ((clarsimp simp: has_slots_object_clean_fields has_slots_object_clean_slots has_slots_object_clean
                           map_add_restrict union_intersection |
            drule inter_empty_not_both |
            erule update_slots_object_clean_fields |
            erule object_type_has_slots, simp |
            simp | safe)+)[3]
   apply (subgoal_tac "\<not> has_slots obj_y")
    apply (subgoal_tac "\<not> has_slots obj_x")
     apply ((clarsimp simp: has_slots_object_clean_fields has_slots_object_clean_slots has_slots_object_clean
                           map_add_restrict union_intersection |
            drule inter_empty_not_both |
            erule object_clean_fields_no_slots |
            erule object_type_has_slots, simp |
            simp | safe)+)
   apply (fastforce simp: object_type_has_slots)+
  done

lemma cdl_heap_add_assoc:
  "\<lbrakk>sep_state_disj x y; sep_state_disj y z; sep_state_disj x z\<rbrakk>
  \<Longrightarrow> cdl_heap_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
      cdl_heap_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (clarsimp simp: sep_state_disj_def)
  apply (cut_tac cdl_heap_add_assoc')
   apply fast
  apply fastforce
  done

lemma cdl_ghost_state_add_assoc:
  "cdl_ghost_state_add (SepState (cdl_heap_add x y) (cdl_ghost_state_add x y)) z =
   cdl_ghost_state_add x (SepState (cdl_heap_add y z) (cdl_ghost_state_add y z))"
  apply (rule ext)
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def Let_unfold)
  done

lemma clean_slots_map_add_comm:
  "cmps_a \<inter> cmps_b = {}
  \<Longrightarrow> clean_slots slots_a cmps_a ++ clean_slots slots_b cmps_b =
      clean_slots slots_b cmps_b ++ clean_slots slots_a cmps_a"
  apply (clarsimp simp: clean_slots_def)
  apply (drule the_set_inter_empty)
  apply (erule map_add_restrict_comm)
  done

lemma object_clean_all:
  "object_type obj_a = object_type obj_b \<Longrightarrow> object_clean obj_b {} = object_clean obj_a {}"
  apply (clarsimp simp: object_clean_def object_clean_slots_def clean_slots_def the_set_def)
  apply (rule_tac cmps'1="{}" and obj'1="obj_a" in trans [OF update_slots_object_clean_fields], fastforce+)
  done

lemma object_add_comm:
  "\<lbrakk>object_type obj_a = object_type obj_b; cmps_a \<inter> cmps_b = {}\<rbrakk>
  \<Longrightarrow> object_add obj_a obj_b cmps_a cmps_b = object_add obj_b obj_a cmps_b cmps_a"
  apply (clarsimp simp: object_add_def Let_unfold)
  apply (rule conjI | clarsimp)+
    apply fastforce
  apply (rule conjI | clarsimp)+
   apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
   apply fastforce
  apply (rule conjI | clarsimp)+
   apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
   apply fastforce
  apply (rule conjI | clarsimp)+
   apply (erule object_clean_all)
  apply (clarsimp)
  apply (rule_tac cmps'1=cmps_b and obj'1=obj_b in trans [OF update_slots_object_clean], assumption+)
  apply (drule_tac slots_a = "object_slots obj_a" and slots_b = "object_slots obj_b" in clean_slots_map_add_comm)
  apply fastforce
  done

lemma sep_state_add_comm:
  "sep_state_disj x y \<Longrightarrow> sep_state_add x y = sep_state_add y x"
  apply (clarsimp simp: sep_state_add_def sep_state_disj_def)
  apply (rule conjI)
   apply (case_tac x, case_tac y, clarsimp)
   apply (rename_tac heap_a gs_a heap_b gs_b)
   apply (clarsimp simp: cdl_heap_add_def Let_unfold)
   apply (rule ext)
   apply (case_tac "heap_a obj_id")
    apply (case_tac "heap_b obj_id", simp_all add: slots_of_heap_def)
   apply (case_tac "heap_b obj_id", simp_all add: slots_of_heap_def)
   apply (rename_tac obj_a obj_b)
   apply (erule_tac x=obj_id in allE)
   apply (rule object_add_comm)
    apply (clarsimp simp: not_conflicting_objects_def)
   apply (clarsimp simp: not_conflicting_objects_def)
  apply (rule ext, fastforce simp: cdl_ghost_state_add_def Let_unfold Un_commute)
  done

lemma add_to_slots_comm:
  "\<lbrakk>object_slots y_obj \<bottom> object_slots z_obj; update_slots Map.empty y_obj = update_slots Map.empty z_obj \<rbrakk>
  \<Longrightarrow> add_to_slots (object_slots z_obj) y_obj = add_to_slots (object_slots y_obj) z_obj"
  by (fastforce simp: add_to_slots_def update_slots_def object_slots_def
                     cdl_tcb.splits cdl_cnode.splits
              dest!: map_add_com
              split: cdl_object.splits)

lemma cdl_heap_add_none1:
  "cdl_heap_add x y obj_id = None \<Longrightarrow> (sep_heap x) obj_id = None"
  by (clarsimp simp: cdl_heap_add_def Let_unfold split:option.splits if_split_asm)

lemma cdl_heap_add_none2:
  "cdl_heap_add x y obj_id = None \<Longrightarrow> (sep_heap y) obj_id = None"
  by (clarsimp simp: cdl_heap_add_def Let_unfold split:option.splits if_split_asm)

lemma object_type_object_addL:
  "object_type obj = object_type obj'
  \<Longrightarrow> object_type (object_add obj obj' cmp cmp') = object_type obj"
  by (clarsimp simp: object_add_def Let_unfold)

lemma object_type_object_addR:
  "object_type obj = object_type obj'
  \<Longrightarrow> object_type (object_add obj obj' cmp cmp') = object_type obj'"
  by (clarsimp simp: object_add_def Let_unfold)

lemma sep_state_add_disjL:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x (sep_state_add y z)\<rbrakk> \<Longrightarrow> sep_state_disj x y"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

lemma sep_state_add_disjR:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x (sep_state_add y z)\<rbrakk> \<Longrightarrow> sep_state_disj x z"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

lemma sep_state_add_disj:
  "\<lbrakk>sep_state_disj y z; sep_state_disj x y; sep_state_disj x z\<rbrakk> \<Longrightarrow> sep_state_disj x (sep_state_add y z)"
  apply (clarsimp simp: sep_state_disj_def sep_state_add_def)
  apply (rename_tac obj_id)
  apply (clarsimp simp: not_conflicting_objects_def)
  apply (erule_tac x=obj_id in allE)+
  apply (fastforce simp: cdl_heap_add_def cdl_ghost_state_add_def object_type_object_addR
                 split: option.splits)
  done

(*********************************************)
(* Definition of separation logic for capDL. *)
(*********************************************)

instantiation "sep_state" :: zero
begin
  definition "0 \<equiv> SepState Map.empty (\<lambda>obj_id. {})"
  instance ..
end

instantiation "sep_state" :: stronger_sep_algebra
begin

definition "(##) \<equiv> sep_state_disj"
definition "(+) \<equiv> sep_state_add"

(**********************************************
 * The proof that this is a separation logic. *
 **********************************************)

instance
  apply intro_classes
(* x ## 0 *)
       apply (simp add: sep_disj_sep_state_def sep_state_disj_def zero_sep_state_def)
(* x ## y \<Longrightarrow> y ## x *)
      apply (clarsimp simp: not_conflicting_objects_comm sep_disj_sep_state_def sep_state_disj_def Let_unfold
                            map_disj_com Int_commute)
(* x + 0 = x *)
     apply (simp add: plus_sep_state_def sep_state_add_def zero_sep_state_def)
     apply (case_tac x)
     apply (clarsimp simp: cdl_heap_add_def)
     apply (rule ext)
     apply (clarsimp simp: cdl_ghost_state_add_def split:if_split_asm)
(* x ## y \<Longrightarrow> x + y = y + x *)
    apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
    apply (erule sep_state_add_comm)
(* (x + y) + z = x + (y + z) *)
   apply (simp add: plus_sep_state_def sep_state_add_def)
   apply (rule conjI)
   apply (clarsimp simp: sep_disj_sep_state_def)
    apply (erule (2) cdl_heap_add_assoc)
   apply (rule cdl_ghost_state_add_assoc)
(* x ## y + z = (x ## y \<and> x ## z) *)
  apply (clarsimp simp: plus_sep_state_def sep_disj_sep_state_def)
  apply (rule iffI)
   (* x ## y + z \<Longrightarrow> (x ## y \<and> x ## z) *)
   apply (rule conjI)
    (* x ## y + z \<Longrightarrow> (x ## y) *)
    apply (erule (1) sep_state_add_disjL)
   (* x ## y + z \<Longrightarrow> (x ## z) *)
   apply (erule (1) sep_state_add_disjR)
  (* x ## y + z \<Longleftarrow> (x ## y \<and> x ## z) *)
  apply clarsimp
  apply (erule (2) sep_state_add_disj)
  done

end

end


theory Calls
  imports "reassembly_setup.Leviathan_Setup"
          "Det_Step"
begin

context execution_context
begin
text "To call a concrete function on a concrete state."
definition call\<^sub>c :: "(state \<Rightarrow> state) \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool"
  where "call\<^sub>c f s s' \<equiv> s' = (let s'' = f s in s''\<lparr>regs := (regs s'')(rip := get_rip s + 5)\<rparr>)"

text "To call an abstract function on an abstract state"
definition abstract\<^sub>0 :: "(state \<Rightarrow> '\<sigma>\<^sub>C \<times> '\<sigma>\<^sub>C\<^sub>C) \<Rightarrow> _ \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> bool"
  where "abstract\<^sub>0 S f \<sigma> \<sigma>' \<equiv> \<exists> s s' . call\<^sub>c f s s' \<and> ((), \<L> S s') = \<sigma>' \<and> ((), \<L> S s) = \<sigma>"

lemma abstract_call\<^sub>0:
  shows "call\<^sub>c f s s' \<Longrightarrow> abstract\<^sub>0 S f ((), \<L> S s) ((), \<L> S s')"
  by (auto simp add: call\<^sub>c_def Let_def abstract\<^sub>0_def)

definition abstract\<^sub>1\<^sub>_\<^sub>3\<^sub>2 :: "(state \<Rightarrow> '\<sigma>\<^sub>C \<times> '\<sigma>\<^sub>C\<^sub>C) \<Rightarrow> _ \<Rightarrow> 32 word \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> bool"
  where "abstract\<^sub>1\<^sub>_\<^sub>3\<^sub>2 S f p\<^sub>0 \<sigma> \<sigma>' \<equiv> \<exists> s s' . EDI s = p\<^sub>0 \<and> call\<^sub>c f s s' \<and> ((), \<L> S s') = \<sigma>' \<and> ((), \<L> S s) = \<sigma>"

lemma abstract_call\<^sub>1\<^sub>_\<^sub>3\<^sub>2:
  shows "EDI s = p\<^sub>0 \<Longrightarrow> call\<^sub>c f s s' \<Longrightarrow> abstract\<^sub>1\<^sub>_\<^sub>3\<^sub>2 S f p\<^sub>0 ((), \<L> S s) ((), \<L> S s')"
  by (auto simp add: call\<^sub>c_def Let_def abstract\<^sub>1\<^sub>_\<^sub>3\<^sub>2_def)

definition abstract\<^sub>1\<^sub>_\<^sub>6\<^sub>4 :: "(state \<Rightarrow> '\<sigma>\<^sub>C \<times> '\<sigma>\<^sub>C\<^sub>C) \<Rightarrow> _ \<Rightarrow> 64 word \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> bool"
  where "abstract\<^sub>1\<^sub>_\<^sub>6\<^sub>4 S f p\<^sub>0 \<sigma> \<sigma>' \<equiv> \<exists> s s' . RDI s = p\<^sub>0 \<and> call\<^sub>c f s s' \<and> ((), \<L> S s') = \<sigma>' \<and> ((), \<L> S s) = \<sigma>"

lemma abstract_call\<^sub>1\<^sub>_\<^sub>6\<^sub>4:
  shows "RDI s = p\<^sub>0 \<Longrightarrow> call\<^sub>c f s s' \<Longrightarrow> abstract\<^sub>1\<^sub>_\<^sub>6\<^sub>4 S f p\<^sub>0 ((), \<L> S s) ((), \<L> S s')"
  by (auto simp add: call\<^sub>c_def Let_def abstract\<^sub>1\<^sub>_\<^sub>6\<^sub>4_def)

definition abstract\<^sub>2\<^sub>_\<^sub>6\<^sub>4\<^sub>_\<^sub>3\<^sub>2 :: "(state \<Rightarrow> '\<sigma>\<^sub>C \<times> '\<sigma>\<^sub>C\<^sub>C) \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> bool"
  where "abstract\<^sub>2\<^sub>_\<^sub>6\<^sub>4\<^sub>_\<^sub>3\<^sub>2 S f p\<^sub>0 p\<^sub>1 \<sigma> \<sigma>' \<equiv> \<exists> s s' . RDI s = p\<^sub>0 \<and> ESI s = p\<^sub>1 \<and> call\<^sub>c f s s' \<and> ((), \<L> S s') = \<sigma>' \<and> ((), \<L> S s) = \<sigma>"

lemma abstract_call\<^sub>2\<^sub>_\<^sub>6\<^sub>4\<^sub>_\<^sub>3\<^sub>2:
  shows "RDI s = p\<^sub>0 \<Longrightarrow> ESI s = p\<^sub>1 \<Longrightarrow> call\<^sub>c f s s' \<Longrightarrow> abstract\<^sub>2\<^sub>_\<^sub>6\<^sub>4\<^sub>_\<^sub>3\<^sub>2 S f p\<^sub>0 p\<^sub>1 ((), \<L> S s) ((), \<L> S s')"
  by (auto simp add: call\<^sub>c_def Let_def abstract\<^sub>2\<^sub>_\<^sub>6\<^sub>4\<^sub>_\<^sub>3\<^sub>2_def)

definition abstract\<^sub>2\<^sub>_\<^sub>3\<^sub>2_\<^sub>3\<^sub>2 :: "(state \<Rightarrow> '\<sigma>\<^sub>C \<times> '\<sigma>\<^sub>C\<^sub>C) \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> unit \<times> '\<sigma>\<^sub>C \<Rightarrow> bool"
  where "abstract\<^sub>2\<^sub>_\<^sub>3\<^sub>2_\<^sub>3\<^sub>2 S f p\<^sub>0 p\<^sub>1 \<sigma> \<sigma>' \<equiv> \<exists> s s' . EDI s = p\<^sub>0 \<and> ESI s = p\<^sub>1 \<and> call\<^sub>c f s s' \<and> ((), \<L> S s') = \<sigma>' \<and> ((), \<L> S s) = \<sigma>"

lemma abstract_call\<^sub>2\<^sub>_\<^sub>3\<^sub>2\<^sub>_\<^sub>3\<^sub>2:
  shows "EDI s = p\<^sub>0 \<Longrightarrow> ESI s = p\<^sub>1 \<Longrightarrow> call\<^sub>c f s s' \<Longrightarrow> abstract\<^sub>2\<^sub>_\<^sub>3\<^sub>2_\<^sub>3\<^sub>2 S f p\<^sub>0 p\<^sub>1 ((), \<L> S s) ((), \<L> S s')"
  by (auto simp add: call\<^sub>c_def Let_def abstract\<^sub>2\<^sub>_\<^sub>3\<^sub>2_\<^sub>3\<^sub>2_def)

end
end