section "A simpler version with no clock parameter and factored-out matching"

theory Big_Step_Unclocked
imports
  Semantic_Extras
  Big_Step_Determ
begin

inductive

evaluate_list  :: " (v)sem_env \<Rightarrow> 'ffi state \<Rightarrow>(exp)list \<Rightarrow> 'ffi state*(((v)list),(v))result \<Rightarrow> bool "
      and
evaluate  :: " (v)sem_env \<Rightarrow> 'ffi state \<Rightarrow> exp \<Rightarrow> 'ffi state*((v),(v))result \<Rightarrow> bool "  where

"lit" : " \<And> env l s.

evaluate env s (Lit l) (s, Rval (Litv l))"

|

"raise1" : " \<And> env e s1 s2 v1.
evaluate s1 env e (s2, Rval v1)
==>
evaluate s1 env (Raise e) (s2, Rerr (Rraise v1))"

|

"raise2" : " \<And> env e s1 s2 err.
evaluate s1 env e (s2, Rerr err)
==>
evaluate s1 env (Raise e) (s2, Rerr err)"

|

"handle1" : " \<And> s1 s2 env e v1 pes.
evaluate s1 env e (s2, Rval v1)
==>
evaluate s1 env (Handle e pes) (s2, Rval v1)"

|

"handle2" : " \<And> s1 s2 env e pes v1 bv.
evaluate env s1 e (s2, Rerr (Rraise v1)) \<Longrightarrow>
match_result env s2 v1 pes v1 = Rval (e', env') \<Longrightarrow>
evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s2 e' bv
==>
evaluate env s1 (Handle e pes) bv "

|

"handle2b" : " \<And> s1 s2 env e pes v1.
evaluate env s1 e (s2, Rerr (Rraise v1)) \<Longrightarrow>
match_result env s2 v1 pes v1 = Rerr err
==>
evaluate env s1 (Handle e pes) (s2, Rerr err)"

|

"handle3" : " \<And> s1 s2 env e pes a.
evaluate env s1 e (s2, Rerr (Rabort a))
==>
evaluate env s1 (Handle e pes) (s2, Rerr (Rabort a))"

|

"con1" : " \<And> env cn es vs s s' v1.
do_con_check(c   env) cn (List.length es) \<Longrightarrow>
build_conv(c   env) cn (List.rev vs) = Some v1 \<Longrightarrow>
evaluate_list env s (List.rev es) (s', Rval vs)
==>
evaluate env s (Con cn es) (s', Rval v1)"

|

"con2" : " \<And> env cn es s.
\<not> (do_con_check(c   env) cn (List.length es))
==>
evaluate env s (Con cn es) (s, Rerr (Rabort Rtype_error))"

|

"con3" : " \<And> env cn es err s s'.
do_con_check(c   env) cn (List.length es) \<Longrightarrow>
evaluate_list env s (List.rev es) (s', Rerr err)
==>
evaluate env s (Con cn es) (s', Rerr err)"

|

"var1" : " \<And> env n v1 s.
nsLookup(sem_env.v   env) n = Some v1
==>
evaluate env s (Var n) (s, Rval v1)"

|

"var2" : " \<And> env n s.
nsLookup(sem_env.v   env) n = None
==>
evaluate env s (Var n) (s, Rerr (Rabort Rtype_error))"

|

"fn" : " \<And> env n e s.

evaluate env s (Fun n e) (s, Rval (Closure env n e))"

|

"app1" : " \<And> env es vs env' e bv s1 s2.
evaluate_list env s1 (List.rev es) (s2, Rval vs) \<Longrightarrow>
do_opapp (List.rev vs) = Some (env', e) \<Longrightarrow>
evaluate env' s2 e bv
==>
evaluate env s1 (App Opapp es) bv "

|

"app3" : " \<And> env es vs s1 s2.
evaluate_list env s1 (List.rev es) (s2, Rval vs) \<Longrightarrow>
(do_opapp (List.rev vs) = None)
==>
evaluate env s1 (App Opapp es) (s2, Rerr (Rabort Rtype_error))"

|

"app4" : " \<And> env op0 es vs res s1 s2 refs' ffi'.
evaluate_list env s1 (List.rev es) (s2, Rval vs) \<Longrightarrow>
do_app ((refs   s2),(ffi   s2)) op0 (List.rev vs) = Some ((refs',ffi'), res) \<Longrightarrow>
op0 \<noteq> Opapp
==>
evaluate env s1 (App op0 es) (( s2 (| refs := refs', ffi :=ffi' |)), res)"

|

"app5" : " \<And> env op0 es vs s1 s2.
evaluate_list env s1 (List.rev es) (s2, Rval vs) \<Longrightarrow>
do_app ((refs   s2),(ffi   s2)) op0 (List.rev vs) = None \<Longrightarrow>
op0 \<noteq> Opapp
==>
evaluate env s1 (App op0 es) (s2, Rerr (Rabort Rtype_error))"

|

"app6" : " \<And> env op0 es err s1 s2.
evaluate_list env s1 (List.rev es) (s2, Rerr err)
==>
evaluate env s1 (App op0 es) (s2, Rerr err)"

|

"log1" : " \<And> env op0 e1 e2 v1 e' bv s1 s2.
evaluate env s1 e1 (s2, Rval v1) \<Longrightarrow>
do_log op0 v1 e2 = Some (Exp e') \<Longrightarrow>
evaluate env s2 e' bv
==>
evaluate env s1 (Log op0 e1 e2) bv "

|

"log2" : " \<And> env op0 e1 e2 v1 bv s1 s2.
evaluate env s1 e1 (s2, Rval v1) \<Longrightarrow>
(do_log op0 v1 e2 = Some (Val bv))
==>
evaluate env s1 (Log op0 e1 e2) (s2, Rval bv)"

|

"log3" : " \<And> env op0 e1 e2 v1 s1 s2.
evaluate env s1 e1 (s2, Rval v1) \<Longrightarrow>
(do_log op0 v1 e2 = None)
==>
evaluate env s1 (Log op0 e1 e2) (s2, Rerr (Rabort Rtype_error))"

|

"log4" : " \<And> env op0 e1 e2 err s s'.
evaluate env s e1 (s', Rerr err)
==>
evaluate env s (Log op0 e1 e2) (s', Rerr err)"

|

"if1" : " \<And> env e1 e2 e3 v1 e' bv s1 s2.
evaluate env s1 e1 (s2, Rval v1) \<Longrightarrow>
do_if v1 e2 e3 = Some e' \<Longrightarrow>
evaluate env s2 e' bv
==>
evaluate env s1 (If e1 e2 e3) bv "

|

"if2" : " \<And> env e1 e2 e3 v1 s1 s2.
evaluate env s1 e1 (s2, Rval v1) \<Longrightarrow>
(do_if v1 e2 e3 = None)
==>
evaluate env s1 (If e1 e2 e3) (s2, Rerr (Rabort Rtype_error))"

|

"if3" : " \<And> env e1 e2 e3 err s s'.
evaluate env s e1 (s', Rerr err)
==>
evaluate env s (If e1 e2 e3) (s', Rerr err)"

|

"mat1" : " \<And> env e pes v1 bv s1 s2.
evaluate env s1 e (s2, Rval v1) \<Longrightarrow>
match_result env s2 v1 pes Bindv = Rval (e', env') \<Longrightarrow>
evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s2 e' bv
==>
evaluate env s1 (Mat e pes) bv "

|

"mat1b" : " \<And> env e pes v1 s1 s2.
evaluate env s1 e (s2, Rval v1) \<Longrightarrow>
match_result env s2 v1 pes Bindv = Rerr err
==>
evaluate env s1 (Mat e pes) (s2, Rerr err)"

|

"mat2" : " \<And> env e pes err s s'.
evaluate env s e (s', Rerr err)
==>
evaluate env s (Mat e pes) (s', Rerr err)"

|

"let1" : " \<And> env n e1 e2 v1 bv s1 s2.
evaluate env s1 e1 (s2, Rval v1) \<Longrightarrow>
evaluate ( env (| sem_env.v := (nsOptBind n v1(sem_env.v   env)) |)) s2 e2 bv
==>
evaluate env s1 (Let n e1 e2) bv "

|

"let2" : " \<And> env n e1 e2 err s s'.
evaluate env s e1 (s', Rerr err)
==>
evaluate env s (Let n e1 e2) (s', Rerr err)"

|

"letrec1" : " \<And> env funs e bv s.
distinct (List.map ( \<lambda>x .
  (case  x of (x,y,z) => x )) funs) \<Longrightarrow>
evaluate ( env (| sem_env.v := (build_rec_env funs env(sem_env.v   env)) |)) s e bv
==>
evaluate env s (Letrec funs e) bv "

|

"letrec2" : " \<And> env funs e s.
\<not> (distinct (List.map ( \<lambda>x .
  (case  x of (x,y,z) => x )) funs))
==>
evaluate env s (Letrec funs e) (s, Rerr (Rabort Rtype_error))"

|

"tannot" : " \<And> env e t0 s bv.
evaluate env s e bv
==>
evaluate env s (Tannot e t0) bv "

|

"locannot" : " \<And> env e l s bv.
evaluate env s e bv
==>
evaluate env s (Lannot e l) bv "

|

"empty" : " \<And> env s.

evaluate_list env s [] (s, Rval [])"

|

"cons1" : " \<And> env e es v1 vs s1 s2 s3.
evaluate env s1 e (s2, Rval v1) \<Longrightarrow>
evaluate_list env s2 es (s3, Rval vs)
==>
evaluate_list env s1 (e # es) (s3, Rval (v1 # vs))"

|

"cons2" : " \<And> env e es err s s'.
evaluate env s e (s', Rerr err)
==>
evaluate_list env s (e # es) (s', Rerr err)"

|

"cons3" : " \<And> env e es v1 err s1 s2 s3.
evaluate env s1 e (s2, Rval v1) \<Longrightarrow>
evaluate_list env s2 es (s3, Rerr err)
==>
evaluate_list env s1 (e # es) (s3, Rerr err)"

lemma unclocked_sound:
  "evaluate_list v s es bv \<Longrightarrow> BigStep.evaluate_list False v s es bv"
  "evaluate v s e bv' \<Longrightarrow> BigStep.evaluate False v s e bv'"
proof (induction rule: evaluate_list_evaluate.inducts)
  case (handle2 e' env' s1 s2 env e pes v1 bv)
  show ?case
    apply (rule BigStep.handle2, intro conjI)
    apply fact
    apply (rule match_result_sound_val)
    apply fact+
    done
next
  case (handle2b err s1 s2 env e pes v1)
  show ?case
    apply (rule BigStep.handle2, intro conjI)
    apply fact
    apply (rule match_result_sound_err)
    apply fact
    done
next
  case (mat1 e' env' env e pes v1 bv s1 s2)
  show ?case
    apply (rule BigStep.mat1, fold Bindv_def, intro conjI)
    apply fact
    apply (rule match_result_sound_val)
    apply fact+
    done
next
  case (mat1b err env e pes v1 s1 s2)
  show ?case
    apply (rule BigStep.mat1, fold Bindv_def, intro conjI)
    apply fact
    apply (rule match_result_sound_err)
    apply fact
    done
qed (fastforce simp: all_distinct_alt_def[symmetric] intro: evaluate_match_evaluate_list_evaluate.intros)+

context begin

private lemma unclocked_complete0:
  "BigStep.evaluate_match ck env s v0 pes err_v (s', bv) \<Longrightarrow> \<not> ck \<Longrightarrow> (
    case bv of
        Rval v \<Rightarrow>
          \<exists>e env'.
            match_result env s v0 pes err_v = Rval (e, env') \<and>
            evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s e (s', Rval v)
      | Rerr err \<Rightarrow>
          (match_result env s v0 pes err_v = Rerr err) \<or>
          (\<exists>e env'.
            match_result env s v0 pes err_v = Rval (e, env') \<and>
            evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s e (s', Rerr err)))"
  "BigStep.evaluate_list ck v s es (s', bv0) \<Longrightarrow> \<not> ck \<Longrightarrow> evaluate_list v s es (s', bv0)"
  "BigStep.evaluate ck v s e (s', bv) \<Longrightarrow> \<not> ck \<Longrightarrow> evaluate v s e (s', bv)"
proof (induction rule: evaluate_induct)
  case (handle2 ck s1 s2 env e pes v1 s3 bv)
  show ?case
    proof (cases bv)
      case (Rval v)
      with handle2 obtain e env' where
        "match_result env s2 v1 pes v1 = Rval (e, env')"
        "evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s2 e (s3, Rval v)"
        by auto

      show ?thesis
        unfolding \<open>bv = _\<close>
        apply (rule evaluate_list_evaluate.handle2)
        using handle2 apply blast
        by fact+
    next
      case (Rerr err)
      with handle2 consider
        (match_err) "match_result env s2 v1 pes v1 = Rerr err" |
        (eval_err) e env' where
          "match_result env s2 v1 pes v1 = Rval (e, env')"
          "evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s2 e (s3, Rerr err)"
        by auto
      then show ?thesis
        proof cases
          case match_err
          then have "evaluate_match ck env s2 v1 pes v1 (s2, Rerr err)"
            by (metis match_result_sound_err)
          moreover have "evaluate_match ck env s2 v1 pes v1 (s3, Rerr err)"
            using handle2 unfolding \<open>bv = _\<close> by blast
          ultimately have "s2 = s3"
            by (metis evaluate_determ fst_conv)

          show ?thesis
            unfolding \<open>bv = _\<close>
            apply (rule evaluate_list_evaluate.handle2b)
            using handle2 unfolding \<open>s2 = _\<close> apply blast
            using match_err unfolding \<open>s2 = _\<close> .
        next
          case eval_err
          show ?thesis
            unfolding \<open>bv = _\<close>
            apply (rule evaluate_list_evaluate.handle2)
            using handle2 apply blast
            by fact+
        qed
    qed
next
  case (mat1 ck env e pes v1 s3 v' s1 s2)
  then show ?case
    (* this is the same proof as above, but with less Isar and more apply *)
    apply (auto split: result.splits simp: Bindv_def[symmetric])
    subgoal by (rule evaluate_list_evaluate.mat1) auto
    subgoal
      apply (frule match_result_sound_err)
      apply (subgoal_tac "s2 = s3")
      apply (rule evaluate_list_evaluate.mat1b)
      apply force
      apply force
      apply (drule evaluate_determ)
      apply assumption
      by auto
    subgoal by (rule evaluate_list_evaluate.mat1) auto
    done
next
  case (mat_cons1 ck env env' v1 p pes e a b err_v s)
  then show ?case
    by (auto split: result.splits)
next
  case (mat_cons2 ck env v1 p e pes a b s err_v)
  then show ?case
    by (auto split: result.splits)
qed (fastforce simp: all_distinct_alt_def intro: evaluate_list_evaluate.intros)+

lemma unclocked_complete:
  "BigStep.evaluate_list False v s es bv' \<Longrightarrow> evaluate_list v s es bv'"
  "BigStep.evaluate False v s e bv \<Longrightarrow> evaluate v s e bv"
apply (cases bv'; metis unclocked_complete0)
apply (cases bv; metis unclocked_complete0)
done

end

lemma unclocked_eq:
  "evaluate_list = BigStep.evaluate_list False"
  "evaluate = BigStep.evaluate False"
by (auto intro: unclocked_sound unclocked_complete intro!: ext)

end


(*  Title:      HOL/Auth/Guard/P2.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2002  University of Cambridge

From G. Karjoth, N. Asokan and C. Gulcu
"Protecting the computation results of free-roaming agents"
Mobiles Agents 1998, LNCS 1477.
*)

section\<open>Protocol P2\<close>

theory P2 imports Guard_Public List_Msg begin

subsection\<open>Protocol Definition\<close>

text\<open>Like P1 except the definitions of \<open>chain\<close>, \<open>shop\<close>,
  \<open>next_shop\<close> and \<open>nonce\<close>\<close>

subsubsection\<open>offer chaining:
B chains his offer for A with the head offer of L for sending it to C\<close>

definition chain :: "agent => nat => agent => msg => agent => msg" where
"chain B ofr A L C ==
let m1= sign B (Nonce ofr) in
let m2= Hash \<lbrace>head L, Agent C\<rbrace> in
\<lbrace>Crypt (pubK A) m1, m2\<rbrace>"

declare Let_def [simp]

lemma chain_inj [iff]: "(chain B ofr A L C = chain B' ofr' A' L' C')
= (B=B' & ofr=ofr' & A=A' & head L = head L' & C=C')"
by (auto simp: chain_def Let_def)

lemma Nonce_in_chain [iff]: "Nonce ofr:parts {chain B ofr A L C}"
by (auto simp: chain_def sign_def)

subsubsection\<open>agent whose key is used to sign an offer\<close>

fun shop :: "msg => msg" where
"shop \<lbrace>Crypt K \<lbrace>B,ofr,Crypt K' H\<rbrace>,m2\<rbrace> = Agent (agt K')"

lemma shop_chain [simp]: "shop (chain B ofr A L C) = Agent B"
by (simp add: chain_def sign_def)

subsubsection\<open>nonce used in an offer\<close>

fun nonce :: "msg => msg" where
"nonce \<lbrace>Crypt K \<lbrace>B,ofr,CryptH\<rbrace>,m2\<rbrace> = ofr"

lemma nonce_chain [simp]: "nonce (chain B ofr A L C) = Nonce ofr"
by (simp add: chain_def sign_def)

subsubsection\<open>next shop\<close>

fun next_shop :: "msg => agent" where
"next_shop \<lbrace>m1,Hash \<lbrace>headL,Agent C\<rbrace>\<rbrace> = C"

lemma "next_shop (chain B ofr A L C) = C"
by (simp add: chain_def sign_def)

subsubsection\<open>anchor of the offer list\<close>

definition anchor :: "agent => nat => agent => msg" where
"anchor A n B == chain A n A (cons nil nil) B"

lemma anchor_inj [iff]:
     "(anchor A n B = anchor A' n' B') = (A=A' & n=n' & B=B')"
by (auto simp: anchor_def)

lemma Nonce_in_anchor [iff]: "Nonce n:parts {anchor A n B}"
by (auto simp: anchor_def)

lemma shop_anchor [simp]: "shop (anchor A n B) = Agent A"
by (simp add: anchor_def)

subsubsection\<open>request event\<close>

definition reqm :: "agent => nat => nat => msg => agent => msg" where
"reqm A r n I B == \<lbrace>Agent A, Number r, cons (Agent A) (cons (Agent B) I),
cons (anchor A n B) nil\<rbrace>"

lemma reqm_inj [iff]: "(reqm A r n I B = reqm A' r' n' I' B')
= (A=A' & r=r' & n=n' & I=I' & B=B')"
by (auto simp: reqm_def)

lemma Nonce_in_reqm [iff]: "Nonce n:parts {reqm A r n I B}"
by (auto simp: reqm_def)

definition req :: "agent => nat => nat => msg => agent => event" where
"req A r n I B == Says A B (reqm A r n I B)"

lemma req_inj [iff]: "(req A r n I B = req A' r' n' I' B')
= (A=A' & r=r' & n=n' & I=I' & B=B')"
by (auto simp: req_def)

subsubsection\<open>propose event\<close>

definition prom :: "agent => nat => agent => nat => msg => msg =>
msg => agent => msg" where
"prom B ofr A r I L J C == \<lbrace>Agent A, Number r,
app (J, del (Agent B, I)), cons (chain B ofr A L C) L\<rbrace>"

lemma prom_inj [dest]: "prom B ofr A r I L J C = prom B' ofr' A' r' I' L' J' C'
==> B=B' & ofr=ofr' & A=A' & r=r' & L=L' & C=C'"
by (auto simp: prom_def)

lemma Nonce_in_prom [iff]: "Nonce ofr:parts {prom B ofr A r I L J C}"
by (auto simp: prom_def)

definition pro :: "agent => nat => agent => nat => msg => msg =>
                  msg => agent => event" where
"pro B ofr A r I L J C == Says B C (prom B ofr A r I L J C)"

lemma pro_inj [dest]: "pro B ofr A r I L J C = pro B' ofr' A' r' I' L' J' C'
==> B=B' & ofr=ofr' & A=A' & r=r' & L=L' & C=C'"
by (auto simp: pro_def dest: prom_inj)

subsubsection\<open>protocol\<close>

inductive_set p2 :: "event list set"
where

  Nil: "[]:p2"

| Fake: "[| evsf:p2; X:synth (analz (spies evsf)) |] ==> Says Spy B X # evsf : p2"

| Request: "[| evsr:p2; Nonce n ~:used evsr; I:agl |] ==> req A r n I B # evsr : p2"

| Propose: "[| evsp:p2; Says A' B \<lbrace>Agent A,Number r,I,cons M L\<rbrace>:set evsp;
  I:agl; J:agl; isin (Agent C, app (J, del (Agent B, I)));
  Nonce ofr ~:used evsp |] ==> pro B ofr A r I (cons M L) J C # evsp : p2"

subsubsection\<open>valid offer lists\<close>

inductive_set
  valid :: "agent => nat => agent => msg set"
  for A :: agent and  n :: nat and B :: agent
where
  Request [intro]: "cons (anchor A n B) nil:valid A n B"

| Propose [intro]: "L:valid A n B
  ==> cons (chain (next_shop (head L)) ofr A L C) L:valid A n B"

subsubsection\<open>basic properties of valid\<close>

lemma valid_not_empty: "L:valid A n B ==> EX M L'. L = cons M L'"
by (erule valid.cases, auto)

lemma valid_pos_len: "L:valid A n B ==> 0 < len L"
by (erule valid.induct, auto)

subsubsection\<open>list of offers\<close>

fun offers :: "msg => msg"
where
  "offers (cons M L) = cons \<lbrace>shop M, nonce M\<rbrace> (offers L)"
| "offers other = nil"

subsection\<open>Properties of Protocol P2\<close>

text\<open>same as \<open>P1_Prop\<close> except that publicly verifiable forward
integrity is replaced by forward privacy\<close>

subsection\<open>strong forward integrity:
except the last one, no offer can be modified\<close>

lemma strong_forward_integrity: "ALL L. Suc i < len L
--> L:valid A n B --> repl (L,Suc i,M):valid A n B --> M = ith (L,Suc i)"
apply (induct i)
(* i = 0 *)
apply clarify
apply (frule len_not_empty, clarsimp)
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,xa,l'a\<rbrace>:valid A n B" for x xa l'a)
apply (ind_cases "\<lbrace>x,M,l'a\<rbrace>:valid A n B" for x l'a)
apply (simp add: chain_def)
(* i > 0 *)
apply clarify
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,repl(l',Suc na,M)\<rbrace>:valid A n B" for x l' na)
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,l'\<rbrace>:valid A n B" for x l')
by (drule_tac x=l' in spec, simp, blast)

subsection\<open>insertion resilience:
except at the beginning, no offer can be inserted\<close>

lemma chain_isnt_head [simp]: "L:valid A n B ==>
head L ~= chain (next_shop (head L)) ofr A L C"
by (erule valid.induct, auto simp: chain_def sign_def anchor_def)

lemma insertion_resilience: "ALL L. L:valid A n B --> Suc i < len L
--> ins (L,Suc i,M) ~:valid A n B"
apply (induct i)
(* i = 0 *)
apply clarify
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,l'\<rbrace>:valid A n B" for x l', simp)
apply (ind_cases "\<lbrace>x,M,l'\<rbrace>:valid A n B" for x l', clarsimp)
apply (ind_cases "\<lbrace>head l',l'\<rbrace>:valid A n B" for l', simp, simp)
(* i > 0 *)
apply clarify
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,l'\<rbrace>:valid A n B" for x l')
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,ins(l',Suc na,M)\<rbrace>:valid A n B" for x l' na)
apply (frule len_not_empty, clarsimp)
by (drule_tac x=l' in spec, clarsimp)

subsection\<open>truncation resilience:
only shop i can truncate at offer i\<close>

lemma truncation_resilience: "ALL L. L:valid A n B --> Suc i < len L
--> cons M (trunc (L,Suc i)):valid A n B --> shop M = shop (ith (L,i))"
apply (induct i)
(* i = 0 *)
apply clarify
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,l'\<rbrace>:valid A n B" for x l')
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>M,l'\<rbrace>:valid A n B" for l')
apply (frule len_not_empty, clarsimp, simp)
(* i > 0 *)
apply clarify
apply (frule len_not_empty, clarsimp)
apply (ind_cases "\<lbrace>x,l'\<rbrace>:valid A n B" for x l')
apply (frule len_not_empty, clarsimp)
by (drule_tac x=l' in spec, clarsimp)

subsection\<open>declarations for tactics\<close>

declare knows_Spy_partsEs [elim]
declare Fake_parts_insert [THEN subsetD, dest]
declare initState.simps [simp del]

subsection\<open>get components of a message\<close>

lemma get_ML [dest]: "Says A' B \<lbrace>A,R,I,M,L\<rbrace>:set evs ==>
M:parts (spies evs) & L:parts (spies evs)"
by blast

subsection\<open>general properties of p2\<close>

lemma reqm_neq_prom [iff]:
"reqm A r n I B ~= prom B' ofr A' r' I' (cons M L) J C"
by (auto simp: reqm_def prom_def)

lemma prom_neq_reqm [iff]:
"prom B' ofr A' r' I' (cons M L) J C ~= reqm A r n I B"
by (auto simp: reqm_def prom_def)

lemma req_neq_pro [iff]: "req A r n I B ~= pro B' ofr A' r' I' (cons M L) J C"
by (auto simp: req_def pro_def)

lemma pro_neq_req [iff]: "pro B' ofr A' r' I' (cons M L) J C ~= req A r n I B"
by (auto simp: req_def pro_def)

lemma p2_has_no_Gets: "evs:p2 ==> ALL A X. Gets A X ~:set evs"
by (erule p2.induct, auto simp: req_def pro_def)

lemma p2_is_Gets_correct [iff]: "Gets_correct p2"
by (auto simp: Gets_correct_def dest: p2_has_no_Gets)

lemma p2_is_one_step [iff]: "one_step p2"
by (unfold one_step_def, clarify, ind_cases "ev#evs:p2" for ev evs, auto)

lemma p2_has_only_Says' [rule_format]: "evs:p2 ==>
ev:set evs --> (EX A B X. ev=Says A B X)"
by (erule p2.induct, auto simp: req_def pro_def)

lemma p2_has_only_Says [iff]: "has_only_Says p2"
by (auto simp: has_only_Says_def dest: p2_has_only_Says')

lemma p2_is_regular [iff]: "regular p2"
apply (simp only: regular_def, clarify)
apply (erule_tac p2.induct)
apply (simp_all add: initState.simps knows.simps pro_def prom_def
req_def reqm_def anchor_def chain_def sign_def)
by (auto dest: no_Key_in_agl no_Key_in_appdel parts_trans)

subsection\<open>private keys are safe\<close>

lemma priK_parts_Friend_imp_bad [rule_format,dest]:
     "[| evs:p2; Friend B ~= A |]
      ==> (Key (priK A):parts (knows (Friend B) evs)) --> (A:bad)"
apply (erule p2.induct)
apply (simp_all add: initState.simps knows.simps pro_def prom_def
                req_def reqm_def anchor_def chain_def sign_def)
apply (blast dest: no_Key_in_agl)
apply (auto del: parts_invKey disjE  dest: parts_trans
            simp add: no_Key_in_appdel)
done

lemma priK_analz_Friend_imp_bad [rule_format,dest]:
     "[| evs:p2; Friend B ~= A |]
==> (Key (priK A):analz (knows (Friend B) evs)) --> (A:bad)"
by auto

lemma priK_notin_knows_max_Friend:
     "[| evs:p2; A ~:bad; A ~= Friend C |]
      ==> Key (priK A) ~:analz (knows_max (Friend C) evs)"
apply (rule not_parts_not_analz, simp add: knows_max_def, safe)
apply (drule_tac H="spies' evs" in parts_sub)
apply (rule_tac p=p2 in knows_max'_sub_spies', simp+)
apply (drule_tac H="spies evs" in parts_sub)
by (auto dest: knows'_sub_knows [THEN subsetD] priK_notin_initState_Friend)

subsection\<open>general guardedness properties\<close>

lemma agl_guard [intro]: "I:agl ==> I:guard n Ks"
by (erule agl.induct, auto)

lemma Says_to_knows_max'_guard: "[| Says A' C \<lbrace>A'',r,I,L\<rbrace>:set evs;
Guard n Ks (knows_max' C evs) |] ==> L:guard n Ks"
by (auto dest: Says_to_knows_max')

lemma Says_from_knows_max'_guard: "[| Says C A' \<lbrace>A'',r,I,L\<rbrace>:set evs;
Guard n Ks (knows_max' C evs) |] ==> L:guard n Ks"
by (auto dest: Says_from_knows_max')

lemma Says_Nonce_not_used_guard: "[| Says A' B \<lbrace>A'',r,I,L\<rbrace>:set evs;
Nonce n ~:used evs |] ==> L:guard n Ks"
by (drule not_used_not_parts, auto)

subsection\<open>guardedness of messages\<close>

lemma chain_guard [iff]: "chain B ofr A L C:guard n {priK A}"
by (case_tac "ofr=n", auto simp: chain_def sign_def)

lemma chain_guard_Nonce_neq [intro]: "n ~= ofr
==> chain B ofr A' L C:guard n {priK A}"
by (auto simp: chain_def sign_def)

lemma anchor_guard [iff]: "anchor A n' B:guard n {priK A}"
by (case_tac "n'=n", auto simp: anchor_def)

lemma anchor_guard_Nonce_neq [intro]: "n ~= n'
==> anchor A' n' B:guard n {priK A}"
by (auto simp: anchor_def)

lemma reqm_guard [intro]: "I:agl ==> reqm A r n' I B:guard n {priK A}"
by (case_tac "n'=n", auto simp: reqm_def)

lemma reqm_guard_Nonce_neq [intro]: "[| n ~= n'; I:agl |]
==> reqm A' r n' I B:guard n {priK A}"
by (auto simp: reqm_def)

lemma prom_guard [intro]: "[| I:agl; J:agl; L:guard n {priK A} |]
==> prom B ofr A r I L J C:guard n {priK A}"
by (auto simp: prom_def)

lemma prom_guard_Nonce_neq [intro]: "[| n ~= ofr; I:agl; J:agl;
L:guard n {priK A} |] ==> prom B ofr A' r I L J C:guard n {priK A}"
by (auto simp: prom_def)

subsection\<open>Nonce uniqueness\<close>

lemma uniq_Nonce_in_chain [dest]: "Nonce k:parts {chain B ofr A L C} ==> k=ofr"
by (auto simp: chain_def sign_def)

lemma uniq_Nonce_in_anchor [dest]: "Nonce k:parts {anchor A n B} ==> k=n"
by (auto simp: anchor_def chain_def sign_def)

lemma uniq_Nonce_in_reqm [dest]: "[| Nonce k:parts {reqm A r n I B};
I:agl |] ==> k=n"
by (auto simp: reqm_def dest: no_Nonce_in_agl)

lemma uniq_Nonce_in_prom [dest]: "[| Nonce k:parts {prom B ofr A r I L J C};
I:agl; J:agl; Nonce k ~:parts {L} |] ==> k=ofr"
by (auto simp: prom_def dest: no_Nonce_in_agl no_Nonce_in_appdel)

subsection\<open>requests are guarded\<close>

lemma req_imp_Guard [rule_format]: "[| evs:p2; A ~:bad |] ==>
req A r n I B:set evs --> Guard n {priK A} (spies evs)"
apply (erule p2.induct, simp)
apply (simp add: req_def knows.simps, safe)
apply (erule in_synth_Guard, erule Guard_analz, simp)
by (auto simp: req_def pro_def dest: Says_imp_knows_Spy)

lemma req_imp_Guard_Friend: "[| evs:p2; A ~:bad; req A r n I B:set evs |]
==> Guard n {priK A} (knows_max (Friend C) evs)"
apply (rule Guard_knows_max')
apply (rule_tac H="spies evs" in Guard_mono)
apply (rule req_imp_Guard, simp+)
apply (rule_tac B="spies' evs" in subset_trans)
apply (rule_tac p=p2 in knows_max'_sub_spies', simp+)
by (rule knows'_sub_knows)

subsection\<open>propositions are guarded\<close>

lemma pro_imp_Guard [rule_format]: "[| evs:p2; B ~:bad; A ~:bad |] ==>
pro B ofr A r I (cons M L) J C:set evs --> Guard ofr {priK A} (spies evs)"
apply (erule p2.induct) (* +3 subgoals *)
(* Nil *)
apply simp
(* Fake *)
apply (simp add: pro_def, safe) (* +4 subgoals *)
(* 1 *)
apply (erule in_synth_Guard, drule Guard_analz, simp, simp)
(* 2 *)
apply simp
(* 3 *)
apply (simp, simp add: req_def pro_def, blast)
(* 4 *)
apply (simp add: pro_def)
apply (blast dest: prom_inj Says_Nonce_not_used_guard Nonce_not_used_Guard)
(* 5 *)
apply simp
apply safe (* +1 subgoal *)
apply (simp add: pro_def)
apply (blast dest: prom_inj Says_Nonce_not_used_guard)
(* 6 *)
apply (simp add: pro_def)
apply (blast dest: Says_imp_knows_Spy)
(* Request *)
apply (simp add: pro_def)
apply (blast dest: prom_inj Says_Nonce_not_used_guard Nonce_not_used_Guard)
(* Propose *)
apply simp
apply safe (* +1 subgoal *)
(* 1 *)
apply (simp add: pro_def)
apply (blast dest: prom_inj Says_Nonce_not_used_guard)
(* 2 *)
apply (simp add: pro_def)
by (blast dest: Says_imp_knows_Spy)

lemma pro_imp_Guard_Friend: "[| evs:p2; B ~:bad; A ~:bad;
pro B ofr A r I (cons M L) J C:set evs |]
==> Guard ofr {priK A} (knows_max (Friend D) evs)"
apply (rule Guard_knows_max')
apply (rule_tac H="spies evs" in Guard_mono)
apply (rule pro_imp_Guard, simp+)
apply (rule_tac B="spies' evs" in subset_trans)
apply (rule_tac p=p2 in knows_max'_sub_spies', simp+)
by (rule knows'_sub_knows)

subsection\<open>data confidentiality:
no one other than the originator can decrypt the offers\<close>

lemma Nonce_req_notin_spies: "[| evs:p2; req A r n I B:set evs; A ~:bad |]
==> Nonce n ~:analz (spies evs)"
by (frule req_imp_Guard, simp+, erule Guard_Nonce_analz, simp+)

lemma Nonce_req_notin_knows_max_Friend: "[| evs:p2; req A r n I B:set evs;
A ~:bad; A ~= Friend C |] ==> Nonce n ~:analz (knows_max (Friend C) evs)"
apply (clarify, frule_tac C=C in req_imp_Guard_Friend, simp+)
apply (simp add: knows_max_def, drule Guard_invKey_keyset, simp+)
by (drule priK_notin_knows_max_Friend, auto simp: knows_max_def)

lemma Nonce_pro_notin_spies: "[| evs:p2; B ~:bad; A ~:bad;
pro B ofr A r I (cons M L) J C:set evs |] ==> Nonce ofr ~:analz (spies evs)"
by (frule pro_imp_Guard, simp+, erule Guard_Nonce_analz, simp+)

lemma Nonce_pro_notin_knows_max_Friend: "[| evs:p2; B ~:bad; A ~:bad;
A ~= Friend D; pro B ofr A r I (cons M L) J C:set evs |]
==> Nonce ofr ~:analz (knows_max (Friend D) evs)"
apply (clarify, frule_tac A=A in pro_imp_Guard_Friend, simp+)
apply (simp add: knows_max_def, drule Guard_invKey_keyset, simp+)
by (drule priK_notin_knows_max_Friend, auto simp: knows_max_def)

subsection\<open>forward privacy:
only the originator can know the identity of the shops\<close>

lemma forward_privacy_Spy: "[| evs:p2; B ~:bad; A ~:bad;
pro B ofr A r I (cons M L) J C:set evs |]
==> sign B (Nonce ofr) ~:analz (spies evs)"
by (auto simp:sign_def dest: Nonce_pro_notin_spies)

lemma forward_privacy_Friend: "[| evs:p2; B ~:bad; A ~:bad; A ~= Friend D;
pro B ofr A r I (cons M L) J C:set evs |]
==> sign B (Nonce ofr) ~:analz (knows_max (Friend D) evs)"
by (auto simp:sign_def dest:Nonce_pro_notin_knows_max_Friend )

subsection\<open>non repudiability: an offer signed by B has been sent by B\<close>

lemma Crypt_reqm: "[| Crypt (priK A) X:parts {reqm A' r n I B}; I:agl |] ==> A=A'"
by (auto simp: reqm_def anchor_def chain_def sign_def dest: no_Crypt_in_agl)

lemma Crypt_prom: "[| Crypt (priK A) X:parts {prom B ofr A' r I L J C};
I:agl; J:agl |] ==> A=B | Crypt (priK A) X:parts {L}"
apply (simp add: prom_def anchor_def chain_def sign_def)
by (blast dest: no_Crypt_in_agl no_Crypt_in_appdel)

lemma Crypt_safeness: "[| evs:p2; A ~:bad |] ==> Crypt (priK A) X:parts (spies evs)
--> (EX B Y. Says A B Y:set evs & Crypt (priK A) X:parts {Y})"
apply (erule p2.induct)
(* Nil *)
apply simp
(* Fake *)
apply clarsimp
apply (drule_tac P="%G. Crypt (priK A) X:G" in parts_insert_substD, simp)
apply (erule disjE)
apply (drule_tac K="priK A" in Crypt_synth, simp+, blast, blast)
(* Request *)
apply (simp add: req_def, clarify)
apply (drule_tac P="%G. Crypt (priK A) X:G" in parts_insert_substD, simp)
apply (erule disjE)
apply (frule Crypt_reqm, simp, clarify)
apply (rule_tac x=B in exI, rule_tac x="reqm A r n I B" in exI, simp, blast)
(* Propose *)
apply (simp add: pro_def, clarify)
apply (drule_tac P="%G. Crypt (priK A) X:G" in parts_insert_substD, simp)
apply (rotate_tac -1, erule disjE)
apply (frule Crypt_prom, simp, simp)
apply (rotate_tac -1, erule disjE)
apply (rule_tac x=C in exI)
apply (rule_tac x="prom B ofr Aa r I (cons M L) J C" in exI, blast)
apply (subgoal_tac "cons M L:parts (spies evsp)")
apply (drule_tac G="{cons M L}" and H="spies evsp" in parts_trans, blast, blast)
apply (drule Says_imp_spies, rotate_tac -1, drule parts.Inj)
apply (drule parts.Snd, drule parts.Snd, drule parts.Snd)
by auto

lemma Crypt_Hash_imp_sign: "[| evs:p2; A ~:bad |] ==>
Crypt (priK A) (Hash X):parts (spies evs)
--> (EX B Y. Says A B Y:set evs & sign A X:parts {Y})"
apply (erule p2.induct)
(* Nil *)
apply simp
(* Fake *)
apply clarsimp
apply (drule_tac P="%G. Crypt (priK A) (Hash X):G" in parts_insert_substD)
apply simp
apply (erule disjE)
apply (drule_tac K="priK A" in Crypt_synth, simp+, blast, blast)
(* Request *)
apply (simp add: req_def, clarify)
apply (drule_tac P="%G. Crypt (priK A) (Hash X):G" in parts_insert_substD)
apply simp
apply (erule disjE)
apply (frule Crypt_reqm, simp+)
apply (rule_tac x=B in exI, rule_tac x="reqm Aa r n I B" in exI)
apply (simp add: reqm_def sign_def anchor_def no_Crypt_in_agl)
apply (simp add: chain_def sign_def, blast)
(* Propose *)
apply (simp add: pro_def, clarify)
apply (drule_tac P="%G. Crypt (priK A) (Hash X):G" in parts_insert_substD)
apply simp
apply (rotate_tac -1, erule disjE)
apply (simp add: prom_def sign_def no_Crypt_in_agl no_Crypt_in_appdel)
apply (simp add: chain_def sign_def)
apply (rotate_tac -1, erule disjE)
apply (rule_tac x=C in exI)
apply (rule_tac x="prom B ofr Aa r I (cons M L) J C" in exI)
apply (simp add: prom_def chain_def sign_def)
apply (erule impE)
apply (blast dest: get_ML parts_sub)
apply (blast del: MPair_parts)+
done

lemma sign_safeness: "[| evs:p2; A ~:bad |] ==> sign A X:parts (spies evs)
--> (EX B Y. Says A B Y:set evs & sign A X:parts {Y})"
apply (clarify, simp add: sign_def, frule parts.Snd)
apply (blast dest: Crypt_Hash_imp_sign [unfolded sign_def])
done

end


(*
 * Copyright 2014, General Dynamics C4 Systems
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory KHeapPre_AI
imports "./$L4V_ARCH/Machine_AI"
begin

primrec
  same_caps :: "Structures_A.kernel_object \<Rightarrow> Structures_A.kernel_object \<Rightarrow> bool"
where
  "same_caps val (CNode sz cs)       = (val = CNode sz cs)"
| "same_caps val (TCB tcb)           = (\<exists>tcb'. val = TCB tcb'
                                         \<and> (\<forall>(getF, t) \<in> ran tcb_cap_cases. getF tcb' = getF tcb))"
| "same_caps val (Endpoint ep)       = is_ep val"
| "same_caps val (Notification ntfn) = is_ntfn val"
| "same_caps val (ArchObj ao)        = (\<exists>ao'. val = ArchObj ao')"

lemma same_caps_more_simps[simp]:
 "same_caps (CNode sz cs) val       = (val = CNode sz cs)"
 "same_caps (TCB tcb)     val       = (\<exists>tcb'. val = TCB tcb'
                                         \<and> (\<forall>(getF, t) \<in> ran tcb_cap_cases. getF tcb' = getF tcb))"
 "same_caps (Endpoint ep) val       = is_ep val"
 "same_caps (Notification ntfn) val = is_ntfn val"
 "same_caps (ArchObj ao) val        = (\<exists>ao'. val = ArchObj ao')"
 by (cases val, (fastforce simp: is_obj_defs)+)+

lemma dmo_return [simp]:
  "do_machine_op (return x) = return x"
  by (simp add: do_machine_op_def select_f_def return_def gets_def get_def
                bind_def modify_def put_def)

lemma get_object_sp:
  "\<lbrace>P\<rbrace> get_object p \<lbrace>\<lambda>r. P and ko_at r p\<rbrace>"
  apply (simp add: get_object_def)
  apply wp
  apply (auto simp add: obj_at_def)
  done

definition non_arch_obj :: "kernel_object \<Rightarrow> bool" where
  "non_arch_obj \<equiv> \<lambda>ko. \<forall>ako. ko \<noteq> ArchObj ako"

lemma non_arch_objs[intro]:
  "non_arch_obj (Endpoint ep)"
  "non_arch_obj (CNode sz cnode_contents)"
  "non_arch_obj (TCB tcb)"
  "non_arch_obj (Notification notification)"
  by (auto simp add: non_arch_obj_def)

definition arch_obj_pred :: "(kernel_object \<Rightarrow> bool) \<Rightarrow> bool" where
  "arch_obj_pred P \<equiv>
    \<forall>ko ko'. non_arch_obj ko \<longrightarrow> non_arch_obj ko' \<longrightarrow>
      P ko = P ko'"

lemma arch_obj_predE:
  "\<lbrakk>arch_obj_pred P; non_arch_obj ko; non_arch_obj ko'\<rbrakk> \<Longrightarrow> P ko = P ko'"
  apply (unfold arch_obj_pred_def)
  apply (erule allE[where ?x="ko"])
  apply (erule allE[where ?x="ko'"])
  by blast

lemmas arch_obj_pred_defs = non_arch_obj_def arch_obj_pred_def

lemma arch_obj_pred_a_type[intro, simp]: "arch_obj_pred (\<lambda>ko. a_type ko = AArch T)"
  by (auto simp add: arch_obj_pred_defs a_type_def split: kernel_object.splits)

lemma
  arch_obj_pred_arch_obj_l[intro, simp]: "arch_obj_pred (\<lambda>ko. ArchObj ako = ko)" and
  arch_obj_pred_arch_obj_r[intro, simp]: "arch_obj_pred (\<lambda>ko. ko = ArchObj ako)"
  by (auto simp add: arch_obj_pred_defs)

lemma arch_obj_pred_fun_lift: "arch_obj_pred (\<lambda>ko. F (arch_obj_fun_lift P N ko))"
  by (simp add: arch_obj_pred_defs)

lemmas arch_obj_pred_fun_lift_id[simp]
  = arch_obj_pred_fun_lift[where F=id, simplified]

lemmas arch_obj_pred_fun_lift_k[intro]
  = arch_obj_pred_fun_lift[where F="K R" for R, simplified]

lemmas arch_obj_pred_fun_lift_el[simp]
  = arch_obj_pred_fun_lift[where F="\<lambda> S. x \<in> S" for x, simplified]

lemma arch_obj_pred_const_conjI[intro]:
  "arch_obj_pred P \<Longrightarrow>
    arch_obj_pred P' \<Longrightarrow>
    arch_obj_pred (\<lambda>ko. P ko \<and> P' ko)"
  apply (simp only: arch_obj_pred_def)
  apply blast
  done

lemma arch_obj_pred_fI:
  "(\<And>x. arch_obj_pred (P x)) \<Longrightarrow> arch_obj_pred (\<lambda>ko. f (\<lambda>x :: 'a :: type. P x ko))"
  apply (simp only: arch_obj_pred_def)
  apply (intro allI impI)
  apply (rule arg_cong[where f=f])
  by blast

declare
  arch_obj_pred_fI[where f=All, intro]
  arch_obj_pred_fI[where f=Ex, intro]

locale arch_only_obj_pred =
  fixes P :: "kernel_object \<Rightarrow> bool"
  assumes arch_only: "arch_obj_pred P"

lemma set_object_typ_at [wp]:
  "\<lbrace>\<lambda>s. P (typ_at T p' s)\<rbrace>
  set_object p ko \<lbrace>\<lambda>rv s. P (typ_at T p' s)\<rbrace>"
  apply (simp add: set_object_def get_object_def)
  apply wp
  apply clarsimp
  apply (erule rsubst [where P=P])
  apply (clarsimp simp: obj_at_def)
  done

lemma set_object_neg_ko:
  "\<lbrace>not ko_at ko' p' and K (p = p' \<longrightarrow> ko \<noteq> ko')\<rbrace>
  set_object p ko
  \<lbrace>\<lambda>_ s. \<not> ko_at ko' p' s\<rbrace>"
  apply (simp add: set_object_def get_object_def)
  apply wp
  apply (simp add: pred_neg_def obj_at_def)
  done

lemma get_tcb_SomeD: "get_tcb t s = Some v \<Longrightarrow> kheap s t = Some (TCB v)"
  apply (case_tac "kheap s t", simp_all add: get_tcb_def)
  apply (case_tac a, simp_all)
  done

lemma get_tcb_at: "tcb_at t s \<Longrightarrow> (\<exists>tcb. get_tcb t s = Some tcb)"
  by (simp add: tcb_at_def)

lemma typ_at_same_type:
  assumes "typ_at T p s" "a_type k = a_type ko" "kheap s p' = Some ko"
  shows "typ_at T p (s\<lparr>kheap := kheap s(p' \<mapsto> k)\<rparr>)"
  using assms
  by (clarsimp simp: obj_at_def)

lemma hoare_to_pure_kheap_upd:
  assumes hoare[rule_format]:
    "\<And>f. (\<And>P p T. \<lbrace>\<lambda>s. P (typ_at (AArch T) p s)\<rbrace>
      f \<lbrace>\<lambda>r s. P (typ_at (AArch T) p s)\<rbrace>) \<Longrightarrow> \<lbrace>P\<rbrace> f \<lbrace>\<lambda>_. P\<rbrace>"
  assumes typ_eq: "a_type k = a_type ko"
  assumes valid: "P (s :: ('z :: state_ext) state)"
  assumes at: "ko_at ko p s"
  shows "P (s\<lparr>kheap := kheap s(p \<mapsto> k)\<rparr>)"
  apply (rule use_valid[where f="
      do
        s' <- get;
        assert (s' = s);
        (modify (\<lambda>s. s\<lparr>kheap := kheap s(p \<mapsto> k)\<rparr>));
        return undefined
      od", OF _ hoare valid])
  apply (fastforce simp add: simpler_modify_def get_def bind_def
                             assert_def return_def[abs_def] fail_def)[1]
  apply wp
  apply (insert typ_eq at)
  apply clarsimp
  apply (erule_tac P=P in rsubst)
  by (auto simp add: obj_at_def a_type_def split: kernel_object.splits if_splits)

lemma set_object_wp:
  "\<lbrace>\<lambda>s. Q (s\<lparr> kheap := kheap s (p \<mapsto> v)\<rparr>) \<rbrace> set_object p v \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (simp add: set_object_def get_object_def)
  apply wp
  apply blast
  done

lemma get_object_wp:
  "\<lbrace>\<lambda>s. \<forall>ko. ko_at ko p s \<longrightarrow> Q ko s\<rbrace> get_object p \<lbrace>Q\<rbrace>"
  apply (clarsimp simp: get_object_def)
  apply wp
  apply (clarsimp simp: obj_at_def)
  done

(* FIXME: move *)
lemma hoare_strengthen_pre_via_assert_forward:
  assumes pos: "\<lbrace> P \<rbrace> f \<lbrace> Q \<rbrace>"
  assumes rel: "\<And>s. S s \<Longrightarrow> P s \<or> N s"
  assumes neg: "\<lbrace> N \<rbrace> f \<lbrace> \<bottom>\<bottom> \<rbrace>"
  shows "\<lbrace> S \<rbrace> f \<lbrace> Q \<rbrace>"
  apply (rule hoare_weaken_pre)
   apply (rule hoare_strengthen_post)
    apply (rule hoare_vcg_disj_lift[OF pos neg])
   apply simp
  apply (erule rel)
  done

lemma hoare_set_object_weaken_pre:
  assumes "\<lbrace>P\<rbrace> set_object p v \<lbrace>\<lambda>_. Q\<rbrace>"
  shows "\<lbrace>\<lambda>s. \<forall>ko. ko_at ko p s \<longrightarrow> (a_type v = a_type ko) \<longrightarrow> P s\<rbrace>
         set_object p v
         \<lbrace>\<lambda>_. Q\<rbrace>"
  apply (rule hoare_strengthen_pre_via_assert_forward
                [OF assms, where N="\<lambda>s. \<forall>ko. ko_at ko p s \<longrightarrow> a_type ko \<noteq> a_type v"])
  apply fastforce
  apply (simp add: set_object_def)
  apply (rule hoare_seq_ext[OF _ get_object_sp])
  apply (rule hoare_seq_ext[OF _ assert_sp])
  apply (fastforce intro: hoare_weaken_pre[OF hoare_pre_cont])
  done

lemmas set_object_wp_strong = hoare_set_object_weaken_pre[OF set_object_wp]

end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>  and
                 Nicole Rauch <rauch at informatik.uni-kl.de>, 2005
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

section \<open>The Direct Subtype Relation of Java Types\<close>

theory DirectSubtypes
imports "../Isabelle/JavaType"
begin

text \<open>
In this theory, we formalize the direct subtype relations of the Java types (as defined
in Sec. \ref{java_typeid_definitions}) that appear in the program to be verified. Thus, this
theory has to be generated for each program.
\label{direct_subtype_relations}
\<close>

text \<open>We have the following type hierarchy:
\begin{center}
\includegraphics[width=13cm]{TypeHierarchy}
\end{center}
We need to describe all direct subtype relations of this  type hierarchy.
As you can see in the picture, all unnecessary direct subtype relations can be
ignored, e.g. the subclass relation between CounterImpl and Object, because it is
added
transitively by the widening relation of types (see Sec. \ref{widening_subtypes}).
\<close>

text \<open>
We have to specify the direct subtype relation between
\begin{itemize}
\item each ``leaf'' class or interface and its subtype \texttt{NullT}
\item each ``root'' class or interface and its supertype \texttt{Object}
\item each two types that are direct subtypes as specified in the code by
\texttt{extends} or \texttt{implements}
\item each array type of a primitive type and its subtype \texttt{NullT}
\item each array type of a primitive type and its supertype \texttt{Object}
\item each array type of a ``leaf'' class or interface and its subtype \texttt{NullT}
\item the array type \texttt{Object[]} and its supertype \texttt{Object}
\item two array types if their element types are in a subtype hierarchy
\end{itemize}
\<close>

definition direct_subtype :: "(Javatype * Javatype) set" where
"direct_subtype =
{ (NullT, AClassT Dummy),
  (NullT, CClassT UndoCounter),
  (NullT, CClassT NullPointerException),
  (NullT, CClassT ClassCastException),

  (AClassT Dummy, CClassT Object),
  (InterfaceT Counter, CClassT Object),
  (CClassT Exception, CClassT Object),

  (CClassT UndoCounter, CClassT CounterImpl),
  (CClassT CounterImpl, InterfaceT Counter),
  (CClassT NullPointerException, CClassT Exception),
  (CClassT ClassCastException, CClassT Exception),

  (NullT, ArrT BoolAT),
  (NullT, ArrT IntgAT),
  (NullT, ArrT ShortAT),
  (NullT, ArrT ByteAT),
  (ArrT BoolAT,  CClassT Object),
  (ArrT IntgAT,  CClassT Object),
  (ArrT ShortAT, CClassT Object),
  (ArrT ByteAT,  CClassT Object),

  (NullT, ArrT (AClassAT Dummy)),
  (NullT, ArrT (CClassAT UndoCounter)),
  (NullT, ArrT (CClassAT NullPointerException)),
  (NullT, ArrT (CClassAT ClassCastException)),

  (ArrT (CClassAT Object),      CClassT Object),

  (ArrT (AClassAT Dummy),       ArrT (CClassAT Object)),
  (ArrT (CClassAT CounterImpl), ArrT (InterfaceAT Counter)),
  (ArrT (InterfaceAT Counter),  ArrT (CClassAT Object)),
  (ArrT (CClassAT Exception),   ArrT (CClassAT Object)),
  (ArrT (CClassAT UndoCounter), ArrT (CClassAT CounterImpl)),
  (ArrT (CClassAT NullPointerException), ArrT (CClassAT Exception)),
  (ArrT (CClassAT ClassCastException),   ArrT (CClassAT Exception))
}"

text \<open>This lemma is used later in the Simplifier.\<close>

lemma direct_subtype:
  "(NullT, AClassT Dummy) \<in> direct_subtype"
  "(NullT, CClassT UndoCounter) \<in> direct_subtype"
  "(NullT, CClassT NullPointerException) \<in> direct_subtype"
  "(NullT, CClassT ClassCastException) \<in> direct_subtype"

  "(AClassT Dummy, CClassT Object) \<in> direct_subtype"
  "(InterfaceT Counter, CClassT Object) \<in> direct_subtype"
  "(CClassT Exception, CClassT Object) \<in> direct_subtype"

  "(CClassT UndoCounter, CClassT CounterImpl) \<in> direct_subtype"
  "(CClassT CounterImpl, InterfaceT Counter) \<in> direct_subtype"
  "(CClassT NullPointerException, CClassT Exception) \<in> direct_subtype"
  "(CClassT ClassCastException, CClassT Exception) \<in> direct_subtype"

  "(NullT, ArrT BoolAT) \<in> direct_subtype"
  "(NullT, ArrT IntgAT) \<in> direct_subtype"
  "(NullT, ArrT ShortAT) \<in> direct_subtype"
  "(NullT, ArrT ByteAT) \<in> direct_subtype"
  "(ArrT BoolAT,  CClassT Object) \<in> direct_subtype"
  "(ArrT IntgAT,  CClassT Object) \<in> direct_subtype"
  "(ArrT ShortAT, CClassT Object) \<in> direct_subtype"
  "(ArrT ByteAT,  CClassT Object) \<in> direct_subtype"

  "(NullT, ArrT (AClassAT Dummy)) \<in> direct_subtype"
  "(NullT, ArrT (CClassAT UndoCounter)) \<in> direct_subtype"
  "(NullT, ArrT (CClassAT NullPointerException)) \<in> direct_subtype"
  "(NullT, ArrT (CClassAT ClassCastException)) \<in> direct_subtype"

  "(ArrT (CClassAT Object),      CClassT Object) \<in> direct_subtype"

  "(ArrT (AClassAT Dummy),       ArrT (CClassAT Object)) \<in> direct_subtype"
  "(ArrT (CClassAT CounterImpl), ArrT (InterfaceAT Counter)) \<in> direct_subtype"
  "(ArrT (InterfaceAT Counter),  ArrT (CClassAT Object)) \<in> direct_subtype"
  "(ArrT (CClassAT Exception),   ArrT (CClassAT Object)) \<in> direct_subtype"
  "(ArrT (CClassAT UndoCounter), ArrT (CClassAT CounterImpl)) \<in> direct_subtype"
  "(ArrT (CClassAT NullPointerException), ArrT (CClassAT Exception)) \<in> direct_subtype"
  "(ArrT (CClassAT ClassCastException),   ArrT (CClassAT Exception)) \<in> direct_subtype"
  by (simp_all add: direct_subtype_def)

end


theory MMU_Instants_TLB
imports
  TLBJ.Simp_Lemmas
  TLBJ.ARM_Monadic

begin

record non_det_tlb_state = state +
           non_det_tlb :: "unit tlb"

record det_tlb_state = state +
           det_tlb :: "unit tlb"

record sat_tlb_state = state +
           sat_tlb :: "unit tlb"

record set_tlb_state = state +
           set_tlb :: "vaddr set"

definition
  typ_non_det_tlb :: "'a non_det_tlb_state_scheme \<Rightarrow> unit tlb state_scheme"
where
  "typ_non_det_tlb s =  state.extend (state.truncate s) (non_det_tlb s)"

definition
  typ_det_tlb :: "'a det_tlb_state_scheme \<Rightarrow> unit tlb state_scheme"
where
  "typ_det_tlb s =  state.extend (state.truncate s) (det_tlb s)"

definition
  typ_sat_tlb :: "'a sat_tlb_state_scheme \<Rightarrow> unit tlb state_scheme"
where
  "typ_sat_tlb s =  state.extend (state.truncate s) (sat_tlb s)"

definition
  typ_set_tlb :: "'a set_tlb_state_scheme \<Rightarrow> vaddr set state_scheme"
where
  "typ_set_tlb s =  state.extend (state.truncate s) (set_tlb s)"

lemma non_det_tlb_more [simp]:
  "state.more (typ_non_det_tlb s) = non_det_tlb s"
  by (clarsimp simp: typ_non_det_tlb_def state.defs)

lemma det_tlb_more [simp]:
  "state.more (typ_det_tlb s) = det_tlb s"
  by (clarsimp simp: typ_det_tlb_def state.defs)

lemma sat_tlb_more [simp]:
  "state.more (typ_sat_tlb s) = sat_tlb s"
  by (clarsimp simp: typ_sat_tlb_def state.defs)

lemma set_tlb_more [simp]:
  "state.more (typ_set_tlb s) = set_tlb s"
  by (clarsimp simp: typ_set_tlb_def state.defs)

lemma non_det_tlb_truncate [simp]:
  "state.truncate (typ_non_det_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_non_det_tlb_def state.defs)

lemma det_tlb_truncate [simp]:
  "state.truncate (typ_det_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_det_tlb_def state.defs)

lemma sat_tlb_truncate [simp]:
  "state.truncate (typ_sat_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_sat_tlb_def state.defs)

lemma set_tlb_truncate [simp]:
  "state.truncate (typ_set_tlb s') = state.truncate s'"
  by (clarsimp simp: typ_set_tlb_def state.defs)

lemma typ_non_det_prim_parameter [simp]:
  "TTBR0 (typ_non_det_tlb s) =  TTBR0 s \<and> MEM (typ_non_det_tlb s) = MEM s \<and> exception (typ_non_det_tlb s) = exception s"
  by (clarsimp simp: typ_non_det_tlb_def  state.defs)

lemma typ_det_prim_parameter [simp]:
  "TTBR0 (typ_det_tlb s) =  TTBR0 s \<and> MEM (typ_det_tlb s) = MEM s \<and> exception (typ_det_tlb s) = exception s"
  by (clarsimp simp: typ_det_tlb_def  state.defs)

lemma typ_sat_prim_parameter [simp]:
  "TTBR0 (typ_sat_tlb s) =  TTBR0 s \<and> MEM (typ_sat_tlb s) = MEM s \<and> exception (typ_sat_tlb s) = exception s"
  by (clarsimp simp: typ_sat_tlb_def  state.defs)

lemma typ_set_prim_parameter [simp]:
  "TTBR0 (typ_set_tlb s) =  TTBR0 s \<and> MEM (typ_set_tlb s) = MEM s \<and> exception (typ_set_tlb s) = exception s"
  by (clarsimp simp: typ_set_tlb_def  state.defs)

abbreviation
  "consistent (s:: unit tlb_entry set state_scheme) \<equiv>
               consistent0  (lookup' (state.more s)) (pt_walk () (MEM s) (TTBR0 s))"

definition
  saturated :: "unit tlb_entry set state_scheme \<Rightarrow> bool"
where
  "saturated s  \<equiv> the ` {e\<in>pt_walk () (MEM s) (TTBR0 s) ` UNIV. \<not>is_fault e} \<subseteq> state.more s"

definition
  tlb_rel_det :: "unit tlb_entry set state_scheme \<Rightarrow> unit tlb_entry set state_scheme \<Rightarrow> bool"
where
  "tlb_rel_det s t \<equiv> state.truncate s = state.truncate t \<and>  state.more s \<subseteq> state.more t"

definition
  tlb_rel_sat :: "unit tlb_entry set state_scheme \<Rightarrow> unit tlb_entry set state_scheme \<Rightarrow> bool"
where
  "tlb_rel_sat s t \<equiv> state.truncate s = state.truncate t \<and>  state.more s \<subseteq> state.more t  \<and>  saturated t"

definition
   inconsistent_vaddrs :: "unit tlb_entry set state_scheme \<Rightarrow>  vaddr set"
where
  "inconsistent_vaddrs s  \<equiv>  {va. lookup' (state.more s) va = Incon}"

definition
   incoherrent_vaddrs :: "unit tlb_entry set state_scheme \<Rightarrow>  vaddr set"
where
  "incoherrent_vaddrs s  \<equiv> {va. \<exists>x. lookup' (state.more s) va = Hit x \<and> is_fault (pt_walk () (MEM s) (TTBR0 s) va)} "

definition
   incon_addrs :: "unit tlb_entry set state_scheme \<Rightarrow>  vaddr set"
where
  "incon_addrs s  \<equiv>  inconsistent_vaddrs s \<union> incoherrent_vaddrs s"

definition
  tlb_rel_abs :: "unit tlb_entry set state_scheme  \<Rightarrow> vaddr set state_scheme \<Rightarrow> bool"
where
"tlb_rel_abs s t \<equiv>  state.truncate s = state.truncate t \<and> incon_addrs s \<subseteq> state.more t \<and> saturated s"

declare return_def [simp add]
declare bind_def [simp add]
declare read_state_def [simp add]
declare update_state_def [simp add]
declare extend_state_def [simp add]
declare trim_state_def [simp add]

lemma tlb_rel_detD:
  "tlb_rel_det s t \<Longrightarrow>  MEM t = MEM s \<and> TTBR0 t = TTBR0 s \<and> state.more s \<subseteq> state.more t  \<and>  exception t = exception s"
  by (clarsimp simp: tlb_rel_det_def state.defs)

lemma tlb_rel_satD:
  "tlb_rel_sat s t \<Longrightarrow> MEM t = MEM s \<and> TTBR0 t = TTBR0 s \<and> state.more s \<subseteq> state.more t \<and> exception t = exception s  \<and> saturated t"
  by (clarsimp simp: tlb_rel_sat_def state.defs)

lemma tlb_rel_det_consistent:
  "\<lbrakk> tlb_rel_det s t; consistent t va \<rbrakk> \<Longrightarrow> consistent s va"
   by (insert tlb_rel_detD [of s t] , clarsimp ,drule tlb_mono [of _ _ "va"] ,auto simp: consistent0_def less_eq_lookup_type)

lemma tlb_rel_sat_consistent:
  "\<lbrakk> tlb_rel_sat s t; consistent t va \<rbrakk> \<Longrightarrow> consistent s va"
   by (insert tlb_rel_satD [of s t] , clarsimp ,drule tlb_mono [of _ _ "va"] ,auto simp: consistent0_def less_eq_lookup_type)

lemma sat_state_tlb:
  "saturated s  \<Longrightarrow> state.more s = state.more s \<union> the ` {e \<in> range (pt_walk () (MEM s) (TTBR0 s)). \<not> is_fault e}"
  by (fastforce simp: saturated_def)

lemma saturated_tlb_pde:
  "saturated (typ_sat_tlb s) \<Longrightarrow> (sat_tlb s) = sat_tlb s \<union> the ` {e\<in>pt_walk ()  (MEM s) (TTBR0 s) ` UNIV. \<not>is_fault e}"
 apply (clarsimp simp:  saturated_def fst_def) apply (cases s ; clarsimp)  by blast

lemma sat_miss_fault:
  "\<lbrakk> saturated (typ_sat_tlb s); lookup' (sat_tlb s)   va = Miss \<rbrakk> \<Longrightarrow>
           is_fault (pt_walk () (MEM s) (TTBR0 s) va)"
  apply (subgoal_tac " lookup' ((sat_tlb s)  \<union> the ` {e \<in> range (pt_walk ()   (MEM s) (TTBR0 s)). \<not> is_fault e})   va = Miss")
   apply (thin_tac "lookup' ((sat_tlb s))   va = Miss")
   apply (drule lookup_miss_union)
   apply clarsimp
   apply (drule lookup_miss_is_fault)
   apply clarsimp
  using  sat_state_tlb by force

lemma saturatd_lookup_hit_no_fault:
  "\<lbrakk>saturated (typ_sat_tlb s);
    lookup' (sat_tlb s)   b = Hit x; \<not> is_fault (pt_walk ()  (MEM s) (TTBR0 s) b)\<rbrakk> \<Longrightarrow>
                       x = the (pt_walk ()   (MEM s) (TTBR0 s) b)"
  apply (subgoal_tac "lookup'(sat_tlb s \<union>
                              the ` {e \<in> range (pt_walk ()   (MEM s) (TTBR0 s)). \<not> is_fault e})   (  b) = Hit x")
   prefer 2
   apply (drule sat_state_tlb, clarsimp simp: state.defs)
  apply (drule lookup_hit_miss_or_hit')
  apply (erule disjE)
   apply (clarsimp simp: lookup_range_pt_walk_hit)
  apply (frule lookup_range_fault_pt_walk)
  apply (drule_tac x = b in bspec; clarsimp simp: lookup_hit_entry_range)
  done

lemma saturated_tlb:
  "saturated (typ_sat_tlb s) \<Longrightarrow> sat_tlb s = sat_tlb s \<union> the ` {e\<in>pt_walk ()   (MEM s) (TTBR0 s) ` UNIV. \<not>is_fault e} "
 apply (clarsimp simp:  saturated_def fst_def) apply (cases s ; clarsimp)  by blast

lemma write_mem_eq_TLB:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') \<rbrakk>  \<Longrightarrow> state.more s' = state.more s"
   by (clarsimp simp: write'mem1_def raise'exception_def split: if_split_asm)

lemma write_same_mem:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') ; write'mem1 (val, va, sz) t = ((), t') ;
      MEM s = MEM t\<rbrakk>  \<Longrightarrow>  MEM s' = MEM t'"
  by (clarsimp simp: write'mem1_def raise'exception_def split:if_split_asm)

lemma write_same_mem_excep:
  "\<lbrakk> write'mem1 (val, pa, sz) s = ((), s') ; write'mem1 (val, pa, sz) t = ((), t') ;
      MEM s = MEM t ; exception s = exception t \<rbrakk>  \<Longrightarrow> exception s' = exception t'"
   by (clarsimp simp: write'mem1_def raise'exception_def split:if_split_asm)

lemma write_mem_rel:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') \<rbrakk>  \<Longrightarrow> s' = s \<lparr> MEM:= MEM s' , exception:= exception s' \<rparr>"
   by (clarsimp simp: write'mem1_def raise'exception_def split: if_split_asm)

lemma not_member_incon_consistent:
  "\<lbrakk>va \<notin>  incon_addrs (typ_sat_tlb s) ; saturated (typ_sat_tlb s) \<rbrakk> \<Longrightarrow>
                                       consistent (typ_sat_tlb s) va"
  apply (clarsimp simp: incon_addrs_def inconsistent_vaddrs_def incoherrent_vaddrs_def consistent0_def)
  apply (erule disjE)
   apply (rule conjI)
    apply (meson lookup_type.exhaust )
   apply (meson lookup_type.exhaust)
  using not_miss_incon_hit saturatd_lookup_hit_no_fault by blast

lemma tlb_rel_abs_consistent [simp]:
  "\<lbrakk>va \<notin> set_tlb t ;   tlb_rel_abs  (typ_sat_tlb s) (typ_set_tlb t)  \<rbrakk>  \<Longrightarrow>
           consistent (typ_sat_tlb s) va "
  apply (rule not_member_incon_consistent ; clarsimp simp: tlb_rel_abs_def)
  by blast

lemma tlb_rel_absD:
  "tlb_rel_abs s t \<Longrightarrow> MEM t = MEM s \<and> TTBR0 t = TTBR0 s  \<and>  saturated s \<and>
                        incon_addrs s  \<subseteq> state.more t \<and> exception t = exception s"
  by (clarsimp simp: tlb_rel_abs_def state.defs)

(*      ARM Monadic Simplification Lemmas     *)

lemma mem1_exception:
  "mem1 p s = (val, t) \<Longrightarrow>  t = s\<lparr>exception := exception t\<rparr>"
  apply (clarsimp simp: mem1_def)
  apply (cases "MEM s p")
   apply (clarsimp simp: raise'exception_def split: if_split_asm)
  apply clarsimp
done

lemma mem1_read_exception:
  "mem_read1 (a, sz) b = (val, r) \<Longrightarrow> r = b \<lparr>exception := exception r\<rparr>"
  apply (clarsimp simp: mem_read1_def)
  apply (clarsimp split: if_split_asm)
      apply (case_tac "mem1 (a r+ 0) b" , clarsimp)
      apply (clarsimp simp: mem1_exception)
     apply (case_tac "mem1 (a r+ 1) b" , clarsimp)
     apply (case_tac "mem1 (a r+ 0) ba", clarsimp)
     apply (drule mem1_exception)
     apply (drule mem1_exception)
     apply (cases b, case_tac ba, cases r ,clarsimp)
    apply (case_tac "mem1 (a r+ 3) b" , clarsimp)
    apply (case_tac "mem1 (a r+ 2) ba", clarsimp)
    apply (case_tac "mem1 (a r+ 1) baa", clarsimp)
    apply (case_tac "mem1 (a r+ 0) bb", clarsimp)
    apply (drule mem1_exception)
    apply (drule mem1_exception)
    apply (drule mem1_exception)
    apply (drule mem1_exception)
    apply (cases b, case_tac ba, case_tac baa, case_tac bb , cases r ,clarsimp)
   apply (case_tac "mem1 (a r+ 7) b" , clarsimp)
   apply (case_tac "mem1 (a r+ 6) ba", clarsimp)
   apply (case_tac "mem1 (a r+ 5) baa", clarsimp)
   apply (case_tac "mem1 (a r+ 4) bb", clarsimp)
   apply (case_tac "mem1 (a r+ 3) bc", clarsimp)
   apply (case_tac "mem1 (a r+ 2) bd", clarsimp)
   apply (case_tac "mem1 (a r+ 1) be", clarsimp)
   apply (case_tac "mem1 (a r+ 0) bf", clarsimp)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (drule mem1_exception)
   apply (cases b, case_tac ba, case_tac baa, case_tac bb ,case_tac bc ,
                   case_tac bd ,  case_tac be ,  case_tac bf , cases r ,clarsimp)
  apply (clarsimp simp: raise'exception_def split:if_split_asm)
done

lemma write_mem_state_trun_equal:
  "\<lbrakk>  write'mem1 (val, pa, sz) s = ((), s'); write'mem1 (val, pa, sz) t = ((), t');
     state.truncate s = state.truncate t \<rbrakk>  \<Longrightarrow> state.truncate s' = state.truncate t'"
  apply (frule write_mem_rel)
  apply rotate_tac
  apply (frule write_mem_rel)
  apply (subgoal_tac "MEM s' = MEM t' \<and> exception s' = exception t'")
   apply clarsimp
   apply (cases s, cases t, cases s', cases t', clarsimp simp: state.defs)
  apply (cases s, cases t, cases s', cases t', clarsimp simp: state.defs)
  apply (clarsimp simp: write'mem1_def Let_def state.defs raise'exception_def split:if_split_asm)
  done

lemma write_mem1_eq_ASID_TTBR0:
  "\<lbrakk> write'mem1 (val, va, sz) s = ((), s') \<rbrakk>  \<Longrightarrow> TTBR0 s' = TTBR0 s"
   by (clarsimp simp: write'mem1_def raise'exception_def split: if_split_asm)

lemma tlb_sat_set_mem1 [simp]:
  "sat_tlb (snd (mem1 ps s)) = sat_tlb s"
  by (simp add: mem1_def raise'exception_def split: option.splits)

consts tlb_evict :: "'a state_scheme \<Rightarrow> 'a"

instantiation non_det_tlb_state_ext :: (type) mmu
begin
  definition
  "(mmu_translate va :: ('a non_det_tlb_state_scheme \<Rightarrow> _))
 = do {
     update_state (\<lambda>s. s\<lparr> non_det_tlb := non_det_tlb s - tlb_evict (typ_non_det_tlb s) \<rparr>);
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     tlb   <- read_state non_det_tlb;
          case lookup' tlb va of
               Hit entry \<Rightarrow> return (va_to_pa va entry)
          |    Miss \<Rightarrow>
                   do {
                       let entry = pt_walk () mem ttbr0 va;
                       if is_fault entry
                       then raise'exception (PAGE_FAULT ''more info'')
                       else do {
                                   update_state (\<lambda>s. s\<lparr> non_det_tlb := non_det_tlb s \<union>  {the entry} \<rparr>);
                                   return (va_to_pa va (the entry)) } }
          |    Incon \<Rightarrow> raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
   }"

thm mmu_translate_non_det_tlb_state_ext_def

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a non_det_tlb_state_scheme \<Rightarrow> bool list \<times>  'a non_det_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a non_det_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a non_det_tlb_state_scheme \<Rightarrow> unit \<times> 'a non_det_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
     pa <- mmu_translate va :: ('a non_det_tlb_state_scheme \<Rightarrow> _);
     exception <- read_state exception;
     if exception = NoException
       then  write'mem1 (value, pa, size)
       else return ()
  }"
(* print_context *)

definition
  "(update_TTBR0 r :: ('a non_det_tlb_state_scheme \<Rightarrow> _))  =
do {
    update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>)
  } "

definition
  "(flush f :: ('a non_det_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushTLB \<Rightarrow> update_state (\<lambda>s. s\<lparr> non_det_tlb := {} \<rparr>)
                  | Flushvarange vset \<Rightarrow> do {
                                         update_state (\<lambda>s. s\<lparr> non_det_tlb := flush_tlb_vset (non_det_tlb s) vset \<rparr>)}"

  instance ..
end

instantiation det_tlb_state_ext :: (_) mmu
begin
  definition
  "(mmu_translate va :: ('a det_tlb_state_scheme \<Rightarrow> _))
 = do {
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     tlb   <- read_state det_tlb;
          case lookup' tlb va of
               Hit entry \<Rightarrow> return (va_to_pa va entry)
          |    Miss \<Rightarrow>
                   do {
                       let entry = pt_walk () mem ttbr0 va;
                       if is_fault entry
                       then raise'exception (PAGE_FAULT ''more info'')
                       else do {
                                   update_state (\<lambda>s. s\<lparr> det_tlb := det_tlb s \<union>  {the entry} \<rparr>);
                                   return (va_to_pa va (the entry)) } }
          |    Incon \<Rightarrow> raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
   }"

thm mmu_translate_non_det_tlb_state_ext_def

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a det_tlb_state_scheme \<Rightarrow> bool list \<times>  'a det_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a det_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a det_tlb_state_scheme \<Rightarrow> unit \<times> 'a det_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
     pa <- mmu_translate va :: ('a det_tlb_state_scheme \<Rightarrow> _);
     exception <- read_state exception;
     if exception = NoException
       then  write'mem1 (value, pa, size)
       else return ()
  }"
(* print_context *)

definition
  "(update_TTBR0 r :: ('a det_tlb_state_scheme \<Rightarrow> _))  =
do {
    update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>)
  } "

definition
  "(flush f :: ('a det_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushTLB \<Rightarrow> update_state (\<lambda>s. s\<lparr> det_tlb := {} \<rparr>)
                  | Flushvarange vset \<Rightarrow> do {
                                         update_state (\<lambda>s. s\<lparr> det_tlb := flush_tlb_vset (det_tlb s) vset \<rparr>)}"

  instance ..
end

instantiation sat_tlb_state_ext :: (_) mmu
begin
  definition
  "(mmu_translate va :: ('a sat_tlb_state_scheme \<Rightarrow> _))
 = do {
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     let tlb_new = the ` {e\<in>pt_walk () mem ttbr0 ` UNIV. \<not>is_fault e};
     tlb   <- read_state sat_tlb;
     let sat_tlb' = tlb \<union> tlb_new;
     update_state (\<lambda>s. s\<lparr> sat_tlb := sat_tlb' \<rparr>);
          case lookup' sat_tlb' va of
               Hit entry \<Rightarrow> return (va_to_pa va entry)
          |    Miss \<Rightarrow> raise'exception (PAGE_FAULT ''more info'')
          |    Incon \<Rightarrow> raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
   }"

thm mmu_translate_non_det_tlb_state_ext_def

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a sat_tlb_state_scheme \<Rightarrow> bool list \<times>  'a sat_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a sat_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a sat_tlb_state_scheme \<Rightarrow> unit \<times> 'a sat_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
      ttbr0 <- read_state TTBR0;
      pa <- mmu_translate va :: ('a sat_tlb_state_scheme \<Rightarrow> _);
      tlb   <- read_state sat_tlb;
      exception <- read_state exception;
      if exception = NoException
       then  do {
                 write'mem1 (value, pa, size);
                 mem'  <- read_state MEM;
                 let tlb_new = the ` {e\<in>pt_walk () mem' ttbr0 ` UNIV. \<not>is_fault e};
                 update_state (\<lambda>s. s\<lparr> sat_tlb := tlb \<union> tlb_new \<rparr>) }
       else return ()
  }"
(* print_context *)

definition
  "(update_TTBR0 r :: ('a sat_tlb_state_scheme \<Rightarrow> _))  =
do {
      update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>);
      mem   <- read_state MEM;
      let all_entries = the ` {e\<in>pt_walk () mem r ` UNIV. \<not>is_fault e};
      tlb   <- read_state sat_tlb;
      update_state (\<lambda>s. s\<lparr> sat_tlb := tlb \<union> all_entries \<rparr>)}"

definition
  "(flush f :: ('a sat_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushTLB \<Rightarrow> do {update_state (\<lambda>s. s\<lparr> sat_tlb := {} \<rparr>);
                                     mem   <- read_state MEM;
                                     ttbr0 <- read_state TTBR0;
                                     let tlb_new = the ` {e\<in>pt_walk () mem ttbr0 ` UNIV. \<not>is_fault e};
                                     update_state (\<lambda>s. s\<lparr> sat_tlb := tlb_new \<rparr>)}
                  | Flushvarange vset \<Rightarrow>  do {
                                     mem   <- read_state MEM;
                                     ttbr0 <- read_state TTBR0;
                                     let tlb_new = the ` {e\<in>pt_walk () mem ttbr0 ` UNIV. \<not>is_fault e};
                                     tlb_pde     <- read_state sat_tlb;
                                     update_state (\<lambda>s. s\<lparr> sat_tlb := flush_tlb_vset tlb_pde vset \<union> tlb_new \<rparr>)}"

  instance ..
end

(*definition
  ptable_comp :: "(vaddr \<Rightarrow> pt_walk_typ) \<Rightarrow> (vaddr \<Rightarrow> pt_walk_typ) \<Rightarrow> vaddr set"
where
  "ptable_comp walk walk'  \<equiv> {va. \<not>(walk va \<preceq> walk' va)}"
*)

definition
  ptable_comp :: "(vaddr \<Rightarrow> unit tlb_entry option) \<Rightarrow> (vaddr \<Rightarrow> unit tlb_entry option) \<Rightarrow> vaddr set"
where
  "ptable_comp wlk wlk'  \<equiv> {va. \<not> is_fault (wlk va) \<and> \<not> is_fault (wlk' va) \<and> wlk va \<noteq> wlk' va \<or>
                                 \<not> is_fault (wlk va) \<and> is_fault (wlk' va)}"

definition
  incon_comp :: " heap \<Rightarrow> heap \<Rightarrow> paddr \<Rightarrow> paddr \<Rightarrow> vaddr set"
where
  "incon_comp  hp hp' rt rt' \<equiv> ptable_comp (pt_walk () hp rt) (pt_walk () hp' rt')"

instantiation set_tlb_state_ext :: (_) mmu
begin
  definition
  "(mmu_translate va :: ('a set_tlb_state_scheme \<Rightarrow> _))
 = do {
     mem   <- read_state MEM;
     ttbr0 <- read_state TTBR0;
     incon_vaddrs <- read_state set_tlb;
     if  va \<in> incon_vaddrs
       then raise'exception (IMPLEMENTATION_DEFINED ''set on fire'')
       else let entry = pt_walk () mem ttbr0 va in
             if is_fault entry
              then raise'exception (PAGE_FAULT ''more info'')
              else return (va_to_pa va (the entry))
    }"

definition
 "(mmu_read_size  :: (vaddr \<times> nat \<Rightarrow>  'a set_tlb_state_scheme \<Rightarrow> bool list \<times>  'a set_tlb_state_scheme))
  \<equiv> \<lambda>(va,size). do {
                     pa  \<leftarrow> mmu_translate va :: ('a set_tlb_state_scheme \<Rightarrow> _);
                     mem_read1 (pa , size)
  }"

definition
  "(mmu_write_size  :: (bool list \<times> vaddr \<times> nat \<Rightarrow> 'a set_tlb_state_scheme \<Rightarrow> unit \<times> 'a set_tlb_state_scheme))
   \<equiv> \<lambda>(value, va, size). do {
      ttbr0 <- read_state TTBR0;
      mem   <- read_state MEM;
      paddr <- mmu_translate va :: ('a set_tlb_state_scheme \<Rightarrow> _);
      incon_vaddrs <- read_state set_tlb;
      exception <- read_state exception;
      if exception = NoException
        then  do {
                   write'mem1 (value, paddr, size);
                   mem' <- read_state MEM;
                   let ptable_comp = incon_comp mem mem' ttbr0 ttbr0;
                   let incon_vaddrs_new    = incon_vaddrs \<union>  ptable_comp;
                   update_state (\<lambda>s. s\<lparr> set_tlb :=  incon_vaddrs_new \<rparr>)
            }
        else return ()
   }"

definition
  "(update_TTBR0 r :: ('a set_tlb_state_scheme \<Rightarrow> _))  =
do {
      ttbr0   <- read_state TTBR0;
      update_state (\<lambda>s. s\<lparr> TTBR0 := r \<rparr>);
      incon_vaddrs   <- read_state set_tlb;
      mem    <- read_state MEM;
       let ptable_comp = incon_comp mem mem ttbr0 r;
       let incon_vaddrs_new = incon_vaddrs \<union>  ptable_comp;
      update_state (\<lambda>s. s\<lparr> set_tlb := incon_vaddrs_new \<rparr>)
}"

definition
  "(flush f :: ('a set_tlb_state_scheme \<Rightarrow> _))  \<equiv>
           case f of FlushTLB \<Rightarrow> update_state (\<lambda>s. s\<lparr> set_tlb := {} \<rparr>)
                  | Flushvarange vset \<Rightarrow> do {
                       incon_vaddrs   <- read_state set_tlb;
                        update_state (\<lambda>s. s\<lparr> set_tlb := incon_vaddrs -vset\<rparr>)}"

  instance ..
end

end


theory IICF_MS_Array_List
imports
  "../Intf/IICF_List"
  Separation_Logic_Imperative_HOL.Array_Blit
  "../../../Separation_Logic_Imperative_HOL/Examples/Default_Insts"
begin

  type_synonym 'a ms_array_list = "'a Heap.array \<times> nat"

  definition "is_ms_array_list ms l \<equiv> \<lambda>(a,n). \<exists>\<^sub>Al'. a \<mapsto>\<^sub>a l' * \<up>(n \<le> length l' \<and> l = take n l' \<and> ms=length l')"

  lemma is_ms_array_list_prec[safe_constraint_rules]: "precise (is_ms_array_list ms)"
    unfolding is_ms_array_list_def[abs_def]
    apply(rule preciseI)
    apply(simp split: prod.splits)
  	using preciseD snga_prec by fastforce

  definition "marl_empty_sz maxsize \<equiv> do {
    a \<leftarrow> Array.new maxsize default;
    return (a,0)
  }"

  definition "marl_append \<equiv> \<lambda>(a,n) x. do {
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
  }"

  definition marl_length :: "'a::heap ms_array_list \<Rightarrow> nat Heap" where
    "marl_length \<equiv> \<lambda>(a,n). return (n)"

  definition marl_is_empty :: "'a::heap ms_array_list \<Rightarrow> bool Heap" where
    "marl_is_empty \<equiv> \<lambda>(a,n). return (n=0)"

  definition marl_last :: "'a::heap ms_array_list \<Rightarrow> 'a Heap" where
    "marl_last \<equiv> \<lambda>(a,n). do {
      Array.nth a (n - 1)
    }"

  definition marl_butlast :: "'a::heap ms_array_list \<Rightarrow> 'a ms_array_list Heap" where
    "marl_butlast \<equiv> \<lambda>(a,n). do {
      return (a,n - 1)
    }"

  definition marl_get :: "'a::heap ms_array_list \<Rightarrow> nat \<Rightarrow> 'a Heap" where
    "marl_get \<equiv> \<lambda>(a,n) i. Array.nth a i"

  definition marl_set :: "'a::heap ms_array_list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a ms_array_list Heap" where
    "marl_set \<equiv> \<lambda>(a,n) i x. do { a \<leftarrow> Array.upd i x a; return (a,n)}"

  lemma marl_empty_sz_rule[sep_heap_rules]: "< emp > marl_empty_sz N <is_ms_array_list N []>"
    by (sep_auto simp: marl_empty_sz_def is_ms_array_list_def)

  lemma marl_append_rule[sep_heap_rules]: "length l < N \<Longrightarrow>
    < is_ms_array_list N l a >
      marl_append a x
    <\<lambda>a. is_ms_array_list N (l@[x]) a >\<^sub>t"
    by (sep_auto
      simp: marl_append_def is_ms_array_list_def take_update_last
      split: prod.splits)

  lemma marl_length_rule[sep_heap_rules]: "
    <is_ms_array_list N l a>
      marl_length a
    <\<lambda>r. is_ms_array_list N l a * \<up>(r=length l)>"
    by (sep_auto simp: marl_length_def is_ms_array_list_def)

  lemma marl_is_empty_rule[sep_heap_rules]: "
    <is_ms_array_list N l a>
      marl_is_empty a
    <\<lambda>r. is_ms_array_list N l a * \<up>(r\<longleftrightarrow>(l=[]))>"
    by (sep_auto simp: marl_is_empty_def is_ms_array_list_def)

  lemma marl_last_rule[sep_heap_rules]: "
    l\<noteq>[] \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_last a
    <\<lambda>r. is_ms_array_list N l a * \<up>(r=last l)>"
    by (sep_auto simp: marl_last_def is_ms_array_list_def last_take_nth_conv)

  lemma marl_butlast_rule[sep_heap_rules]: "
    l\<noteq>[] \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_butlast a
    <is_ms_array_list N (butlast l)>\<^sub>t"
    by (sep_auto
      split: prod.splits
      simp: marl_butlast_def is_ms_array_list_def butlast_take)

  lemma marl_get_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_get a i
    <\<lambda>r. is_ms_array_list N l a * \<up>(r=l!i)>"
    by (sep_auto simp: marl_get_def is_ms_array_list_def split: prod.split)

  lemma marl_set_rule[sep_heap_rules]: "
    i<length l \<Longrightarrow>
    <is_ms_array_list N l a>
      marl_set a i x
    <is_ms_array_list N (l[i:=x])>"
    by (sep_auto simp: marl_set_def is_ms_array_list_def split: prod.split)

  definition "marl_assn N A \<equiv> hr_comp (is_ms_array_list N) (\<langle>the_pure A\<rangle>list_rel)"
  lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "marl_assn N A" for N A]

context
  notes [fcomp_norm_unfold] = marl_assn_def[symmetric]
  notes [intro!] = hfrefI hn_refineI[THEN hn_refine_preI]
  notes [simp] = pure_def hn_ctxt_def invalid_assn_def
begin

  definition [simp]: "op_marl_empty_sz (N::nat) \<equiv> op_list_empty"
  context fixes N :: nat begin
    sepref_register "PR_CONST (op_marl_empty_sz N)"
  end

  lemma marl_fold_custom_empty_sz:
    "op_list_empty = op_marl_empty_sz N"
    "mop_list_empty = RETURN (op_marl_empty_sz N)"
    "[] = op_marl_empty_sz N"
    by auto

  lemma marl_empty_hnr_aux: "(uncurry0 (marl_empty_sz N), uncurry0 (RETURN op_list_empty)) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a is_ms_array_list N"
    by sep_auto
  lemmas marl_empty_hnr = marl_empty_hnr_aux[FCOMP op_list_empty.fref[of "the_pure A" for A]]
  lemmas marl_empty_hnr_mop = marl_empty_hnr[FCOMP mk_mop_rl0_np[OF mop_list_empty_alt]]

  lemma marl_empty_sz_hnr[sepref_fr_rules]:
    "(uncurry0 (marl_empty_sz N), uncurry0 (RETURN (PR_CONST (op_marl_empty_sz N)))) \<in> unit_assn\<^sup>k \<rightarrow>\<^sub>a marl_assn N A"
    using marl_empty_hnr
    by simp

  lemma marl_append_hnr_aux: "(uncurry marl_append,uncurry (RETURN oo op_list_append)) \<in> [\<lambda>(l,_). length l<N]\<^sub>a ((is_ms_array_list N)\<^sup>d *\<^sub>a id_assn\<^sup>k) \<rightarrow> is_ms_array_list N"
    by sep_auto
  lemmas marl_append_hnr[sepref_fr_rules] = marl_append_hnr_aux[FCOMP op_list_append.fref]
  lemmas marl_append_hnr_mop[sepref_fr_rules] = marl_append_hnr[FCOMP mk_mop_rl2_np[OF mop_list_append_alt]]

  lemma marl_length_hnr_aux: "(marl_length,RETURN o op_list_length) \<in> (is_ms_array_list N)\<^sup>k \<rightarrow>\<^sub>a nat_assn"
    by sep_auto
  lemmas marl_length_hnr[sepref_fr_rules] = marl_length_hnr_aux[FCOMP op_list_length.fref[of "the_pure A" for A]]
  lemmas marl_length_hnr_mop[sepref_fr_rules] = marl_length_hnr[FCOMP mk_mop_rl1_np[OF mop_list_length_alt]]

  lemma marl_is_empty_hnr_aux: "(marl_is_empty,RETURN o op_list_is_empty) \<in> (is_ms_array_list N)\<^sup>k \<rightarrow>\<^sub>a bool_assn"
    by sep_auto
  lemmas marl_is_empty_hnr[sepref_fr_rules] = marl_is_empty_hnr_aux[FCOMP op_list_is_empty.fref[of "the_pure A" for A]]
  lemmas marl_is_empty_hnr_mop[sepref_fr_rules] = marl_is_empty_hnr[FCOMP mk_mop_rl1_np[OF mop_list_is_empty_alt]]

  lemma marl_last_hnr_aux: "(marl_last,RETURN o op_list_last) \<in> [\<lambda>x. x\<noteq>[]]\<^sub>a (is_ms_array_list N)\<^sup>k \<rightarrow> id_assn"
    by sep_auto
  lemmas marl_last_hnr[sepref_fr_rules] = marl_last_hnr_aux[FCOMP op_list_last.fref]
  lemmas marl_last_hnr_mop[sepref_fr_rules] = marl_last_hnr[FCOMP mk_mop_rl1[OF mop_list_last_alt]]

  lemma marl_butlast_hnr_aux: "(marl_butlast,RETURN o op_list_butlast) \<in> [\<lambda>x. x\<noteq>[]]\<^sub>a (is_ms_array_list N)\<^sup>d \<rightarrow> (is_ms_array_list N)"
    by sep_auto
  lemmas marl_butlast_hnr[sepref_fr_rules] = marl_butlast_hnr_aux[FCOMP op_list_butlast.fref[of "the_pure A" for A]]
  lemmas marl_butlast_hnr_mop[sepref_fr_rules] = marl_butlast_hnr[FCOMP mk_mop_rl1[OF mop_list_butlast_alt]]

  lemma marl_get_hnr_aux: "(uncurry marl_get,uncurry (RETURN oo op_list_get)) \<in> [\<lambda>(l,i). i<length l]\<^sub>a ((is_ms_array_list N)\<^sup>k *\<^sub>a nat_assn\<^sup>k) \<rightarrow> id_assn"
    by sep_auto
  lemmas marl_get_hnr[sepref_fr_rules] = marl_get_hnr_aux[FCOMP op_list_get.fref]
  lemmas marl_get_hnr_mop[sepref_fr_rules] = marl_get_hnr[FCOMP mk_mop_rl2[OF mop_list_get_alt]]

  lemma marl_set_hnr_aux: "(uncurry2 marl_set,uncurry2 (RETURN ooo op_list_set)) \<in> [\<lambda>((l,i),_). i<length l]\<^sub>a ((is_ms_array_list N)\<^sup>d *\<^sub>a nat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k) \<rightarrow> (is_ms_array_list N)"
    by sep_auto
  lemmas marl_set_hnr[sepref_fr_rules] = marl_set_hnr_aux[FCOMP op_list_set.fref]
  lemmas marl_set_hnr_mop[sepref_fr_rules] = marl_set_hnr[FCOMP mk_mop_rl3[OF mop_list_set_alt]]

end

context
  fixes N :: nat
  assumes N_sz: "N>10"
begin

schematic_goal "hn_refine (emp) (?c::?'c Heap) ?\<Gamma>' ?R (do {
  let x = op_marl_empty_sz N;
  RETURN (x@[1::nat])
})"
  using N_sz
  by sepref

end

schematic_goal "hn_refine (emp) (?c::?'c Heap) ?\<Gamma>' ?R (do {
  let x = op_list_empty;
  RETURN (x@[1::nat])
})"
  apply (subst marl_fold_custom_empty_sz[where N=10])
  apply sepref
  done

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Weak_Early_Bisim_Pres
  imports Strong_Early_Bisim_Pres Weak_Early_Sim_Pres Weak_Early_Bisim_SC Weak_Early_Bisim
begin

(************ Preservation rules ************)

lemma tauPres:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<approx> Q"

  shows "\<tau>.(P) \<approx> \<tau>.(Q)"
proof -
  let ?X = "{(\<tau>.(P), \<tau>.(Q)) | P Q. P \<approx> Q}"
  from `P \<approx> Q` have "(\<tau>.(P), \<tau>.(Q)) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    thus ?case
      by(force intro: Weak_Early_Sim_Pres.tauPres)
  next
    case(cSym P Q)
    thus ?case by(force dest: Weak_Early_Bisim.symetric simp add: pi.inject)
  qed
qed

lemma outputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<approx> Q"

  shows "a{b}.P \<approx> a{b}.Q"
proof -
  let ?X = "{(a{b}.(P), a{b}.(Q)) | P Q a b. P \<approx> Q}"
  from `P \<approx> Q` have "(a{b}.(P), a{b}.(Q)) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    thus ?case
      by(force intro: Weak_Early_Sim_Pres.outputPres)
  next
    case(cSym P Q)
    thus ?case by(force dest: Weak_Early_Bisim.symetric simp add: pi.inject)
  qed
qed

lemma inputPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   x :: name

  assumes PSimQ: "\<forall>y. P[x::=y] \<approx> Q[x::=y]"

  shows "a<x>.P \<approx> a<x>.Q"
proof -
  let ?X = "{(a<x>.P, a<x>.Q) | a x P Q. \<forall>y. P[x::=y] \<approx> Q[x::=y]}"
  {
    fix axP axQ p
    assume "(axP, axQ) \<in> ?X"
    then obtain a x P Q where A: "\<forall>y. P[x::=y] \<approx> Q[x::=y]" and B: "axP = a<x>.P" and C: "axQ = a<x>.Q"
      by auto
    have "\<And>y. ((p::name prm) \<bullet> P)[(p \<bullet> x)::=y] \<approx> (p \<bullet> Q)[(p \<bullet> x)::=y]"
    proof -
      fix y
      from A have "P[x::=(rev p \<bullet> y)] \<approx> Q[x::=(rev p \<bullet> y)]"
        by blast
      hence "(p \<bullet> (P[x::=(rev p \<bullet> y)])) \<approx> p \<bullet> (Q[x::=(rev p \<bullet> y)])"
        by(rule eqvts)
      thus "(p \<bullet> P)[(p \<bullet> x)::=y] \<approx> (p \<bullet> Q)[(p \<bullet> x)::=y]"
        by(simp add: eqvts pt_pi_rev[OF pt_name_inst, OF at_name_inst])
    qed
    hence "((p::name prm) \<bullet> axP, p \<bullet> axQ) \<in> ?X" using B C
      by auto
  }
  hence "eqvt ?X" by(simp add: eqvt_def)

  from PSimQ have "(a<x>.P, a<x>.Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim P Q)
    thus ?case using `eqvt ?X`
      by(force intro: Weak_Early_Sim_Pres.inputPres)
  next
    case(cSym P Q)
    thus ?case
      by(blast dest: weakBisimE)
  qed
qed

  shows "<\<nu>x>P \<approx> <\<nu>x>Q"
proof -
  let ?X = "{(<\<nu>x>P, <\<nu>x>Q) | x P Q. P \<approx> Q}"
  from `P \<approx> Q` have "(<\<nu>x>P, <\<nu>x>Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim xP xQ)
    {
      fix P Q x
      assume "P \<approx> Q"
      hence "P \<leadsto><weakBisim> Q" by(rule weakBisimE)
      moreover have "\<And>P Q x. P \<approx> Q \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?X \<union> weakBisim" by blast
      moreover have "weakBisim \<subseteq> ?X \<union> weakBisim" by blast
      moreover have "eqvt weakBisim" by simp
      moreover have "eqvt (?X \<union> weakBisim)"
        by(auto simp add: eqvt_def dest: Weak_Early_Bisim.eqvtI)+
      ultimately have "<\<nu>x>P \<leadsto><(?X \<union> weakBisim)> <\<nu>x>Q"
        by(rule Weak_Early_Sim_Pres.resPres)
    }
    with `(xP, xQ) \<in> ?X` show ?case by blast
  next
    case(cSym xP xQ)
    thus ?case by(blast dest: Weak_Early_Bisim.symetric)
  qed
qed

  assumes "P \<approx> Q"

  shows "[a\<frown>b]P \<approx> [a\<frown>b]Q"
proof -
  let ?X = "{([a\<frown>b]P, [a\<frown>b]Q) | a b P Q. P \<approx> Q}"
  from `P \<approx> Q` have "([a\<frown>b]P, [a\<frown>b]Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim abP abQ)
    {
      fix P Q a b
      assume "P \<approx> Q"
      hence "P \<leadsto><weakBisim> Q" by(rule weakBisimE)
      moreover have "weakBisim \<subseteq> (?X \<union> weakBisim)" by blast
      moreover have "\<And>P Q a. P \<approx> Q \<Longrightarrow> [a\<frown>a]P \<approx> Q"
        by (metis (full_types) strongBisimWeakBisim Strong_Early_Bisim_SC.matchId Weak_Early_Bisim.transitive)
      ultimately have"[a\<frown>b]P \<leadsto><(?X \<union> weakBisim)> [a\<frown>b]Q"
        by(rule Weak_Early_Sim_Pres.matchPres)
    }
    with `(abP, abQ) \<in> ?X` show ?case by blast
  next
    case(cSym abP abQ)
    thus ?case by(blast dest: Weak_Early_Bisim.symetric)
  qed
qed

lemma mismatchPres:
  fixes P :: pi
  and   Q :: pi
  and   a :: name
  and   b :: name

  assumes "P \<approx> Q"

  shows "[a\<noteq>b]P \<approx> [a\<noteq>b]Q"
proof -
  let ?X = "{([a\<noteq>b]P, [a\<noteq>b]Q)| a b P Q. P \<approx> Q}"
  from `P \<approx> Q` have "([a\<noteq>b]P, [a\<noteq>b]Q) \<in> ?X" by blast
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSim abP abQ)
    {
      fix P Q a b
      assume "P \<approx> Q"
      hence "P \<leadsto><weakBisim> Q" by(rule weakBisimE)
      moreover have "weakBisim \<subseteq> (?X \<union> weakBisim)" by blast
      moreover have "\<And>P Q a b. \<lbrakk>P \<approx> Q; a \<noteq> b\<rbrakk> \<Longrightarrow> [a\<noteq>b]P \<approx> Q"
        by (metis (full_types) strongBisimWeakBisim Strong_Early_Bisim_SC.mismatchId Weak_Early_Bisim.transitive)
      ultimately have "[a\<noteq>b]P \<leadsto><(?X \<union> weakBisim)> [a\<noteq>b]Q"
        by(rule Weak_Early_Sim_Pres.mismatchPres)
    }
    with `(abP, abQ) \<in> ?X` show ?case by blast
  next
    case(cSym abP abQ)
    thus ?case by(blast dest: Weak_Early_Bisim.symetric)
  qed
qed

lemma parPres:
  fixes P :: pi
  and   Q :: pi
  and   R :: pi

  assumes "P \<approx> Q"

  shows "P \<parallel> R \<approx> Q \<parallel> R"
proof -
  let ?X = "{(resChain lst (P \<parallel> R), resChain lst (Q \<parallel> R)) | lst P R Q. P \<approx> Q}"
  have BC: "\<And>P Q. P \<parallel> Q = resChain [] (P \<parallel> Q)" by auto
  from `P \<approx> Q` have "(P \<parallel> R, Q \<parallel> R) \<in> ?X" by(blast intro: BC)
  thus ?thesis
  proof(coinduct rule: weakBisimCoinduct)
    case(cSym PR QR)
    {
      fix P Q R lst
      assume "P \<approx> Q"
      moreover hence "P \<leadsto><weakBisim> Q" by(rule weakBisimE)
      moreover have "\<And>P Q R. P \<approx> Q \<Longrightarrow> (P \<parallel> R, Q \<parallel> R) \<in> ?X" using BC
        by blast
      moreover {
        fix PR QR x
        assume "(PR, QR) \<in> ?X"
        then obtain lst P Q R where "P \<approx> Q" and A: "PR = resChain lst (P \<parallel> R)" and B: "QR = resChain lst (Q \<parallel> R)"
          by auto
        from A have "<\<nu>x>PR = resChain (x#lst) (P \<parallel> R)" by auto
        moreover from B have "<\<nu>x>QR = resChain (x#lst) (Q \<parallel> R)" by auto
        ultimately have "(<\<nu>x>PR, <\<nu>x>QR) \<in> ?X" using `P \<approx> Q`
          by blast
      }
      note Res = this
      ultimately have "P \<parallel> R \<leadsto><?X> Q \<parallel> R"
        by(rule_tac Weak_Early_Sim_Pres.parPres)
      moreover have "eqvt ?X"
        by(auto simp add: eqvt_def) (blast intro: eqvts)
      ultimately have "resChain lst (P \<parallel> R) \<leadsto><?X> resChain lst (Q \<parallel> R)" using Res
        by(rule_tac Weak_Early_Sim_Pres.resChainI)
      hence "resChain lst (P \<parallel> R) \<leadsto><(?X \<union> weakBisim)> resChain lst (Q \<parallel> R)"
        by(force intro: Weak_Early_Sim.monotonic)
    }
    with `(PR, QR) \<in> ?X` show "PR \<leadsto><(?X \<union> weakBisim)> QR"
      by blast
  next
    case(cSym PR QR)
    thus ?case by(blast dest: Weak_Early_Bisim.symetric)
  qed
qed

  assumes PBisimQ: "P \<approx> Q"

  shows "!P \<approx> !Q"
proof -
  let ?X = "(bangRel weakBisim)"
  let ?Y = "Strong_Early_Bisim.bisim O (bangRel weakBisim) O Strong_Early_Bisim.bisim"

  from Weak_Early_Bisim.eqvt Strong_Early_Bisim.eqvt have eqvtY: "eqvt ?Y" by(blast intro: eqvtBangRel)
  have XsubY: "?X \<subseteq> ?Y" by(auto intro: Strong_Early_Bisim.reflexive)

  have RelStay: "\<And>P Q. (P \<parallel> !P, Q) \<in> ?Y \<Longrightarrow> (!P, Q) \<in> ?Y"
  proof(auto)
    fix P Q R T
    assume PBisimQ: "P \<parallel> !P \<sim>\<^sub>e Q"
       and QBRR: "(Q, R) \<in> bangRel weakBisim"
       and RBisimT: "R \<sim>\<^sub>e T"
    have "!P \<sim>\<^sub>e Q"
    proof -
      have "!P \<sim>\<^sub>e P \<parallel> !P" by(rule Strong_Early_Bisim_SC.bangSC)
      thus ?thesis using PBisimQ by(rule Strong_Early_Bisim.transitive)
    qed
    with QBRR RBisimT show "(!P, T) \<in> ?Y" by blast
  qed

  have ParCompose: "\<And>P Q R T. \<lbrakk>P \<approx> Q; (R, T) \<in> ?Y\<rbrakk> \<Longrightarrow> (P \<parallel> R, Q \<parallel> T) \<in> ?Y"
  proof -
    fix P Q R T
    assume PBisimQ: "P \<approx> Q"
       and RYT:     "(R, T) \<in> ?Y"
    thus "(P \<parallel> R, Q \<parallel> T) \<in> ?Y"
    proof(auto)
      fix T' R'
      assume T'BisimT: "T' \<sim>\<^sub>e T" and RBisimR': "R \<sim>\<^sub>e R'"
         and R'BRT': "(R', T') \<in> bangRel weakBisim"
      have "P \<parallel> R \<sim>\<^sub>e P \<parallel> R'"
      proof -
        from RBisimR' have "R \<parallel> P \<sim>\<^sub>e R' \<parallel> P" by(rule Strong_Early_Bisim_Pres.parPres)
        moreover have "P \<parallel> R \<sim>\<^sub>e R \<parallel> P" and "R' \<parallel> P \<sim>\<^sub>e P \<parallel> R'" by(rule Strong_Early_Bisim_SC.parSym)+
        ultimately show ?thesis by(blast intro: Strong_Early_Bisim.transitive)
      qed
      moreover from PBisimQ R'BRT' have "(P \<parallel> R', Q \<parallel> T') \<in> bangRel weakBisim" by(rule BRPar)
      moreover have "Q \<parallel> T' \<sim>\<^sub>e Q \<parallel> T"
      proof -
        from T'BisimT have "T' \<parallel> Q \<sim>\<^sub>e T \<parallel> Q" by(rule Strong_Early_Bisim_Pres.parPres)
        moreover have "Q \<parallel> T' \<sim>\<^sub>e T' \<parallel> Q" and "T \<parallel> Q \<sim>\<^sub>e Q \<parallel> T" by(rule Strong_Early_Bisim_SC.parSym)+
        ultimately show ?thesis by(blast intro: Strong_Early_Bisim.transitive)
      qed
      ultimately show ?thesis by blast
    qed
  qed

  have ResCong: "\<And>P Q x. (P, Q) \<in> ?Y \<Longrightarrow> (<\<nu>x>P, <\<nu>x>Q) \<in> ?Y"
    by(auto intro: BRRes Strong_Early_Bisim_Pres.resPres transitive)

  have Sim: "\<And>P Q. (P, Q) \<in> ?X \<Longrightarrow> P \<leadsto><?Y> Q"
  proof -
    fix P Q
    assume "(P, Q) \<in> ?X"
    thus "P \<leadsto><?Y> Q"
    proof(induct)
      case(BRBang P Q)
      have "P \<approx> Q" by fact
      moreover hence "P \<leadsto><weakBisim> Q" by(blast dest: weakBisimE)
      moreover have "\<And>P Q. P \<approx> Q \<Longrightarrow> P \<leadsto><weakBisim> Q" by(blast dest: weakBisimE)
      moreover from Strong_Early_Bisim.eqvt Weak_Early_Bisim.eqvt have "eqvt ?Y" by(blast intro: eqvtBangRel)

      ultimately show "!P \<leadsto><?Y> !Q" using ParCompose ResCong RelStay XsubY
        by(rule_tac Weak_Early_Sim_Pres.bangPres, simp_all)
    next
      case(BRPar P Q R T)
      have PBiSimQ: "P \<approx> Q" by fact
      moreover have RBangRelT: "(R, T) \<in> ?X" by fact
      have RSimT: "R \<leadsto><?Y> T" by fact
      moreover from PBiSimQ  have "P \<leadsto><weakBisim> Q" by(blast dest: weakBisimE)
      moreover from RBangRelT have "(R, T) \<in> ?Y" by(blast intro: Strong_Early_Bisim.reflexive)
      ultimately show "P \<parallel> R \<leadsto><?Y> Q \<parallel> T" using ParCompose ResCong eqvt eqvtY
        by(rule_tac Weak_Early_Sim_Pres.parCompose)
    next
      case(BRRes P Q x)
      have "P \<leadsto><?Y> Q" by fact
      thus "<\<nu>x>P \<leadsto><?Y> <\<nu>x>Q" using ResCong eqvtY XsubY
        by(rule_tac Weak_Early_Sim_Pres.resPres, simp_all)
    qed
  qed

  from PBisimQ have "(!P, !Q) \<in> ?X" by(rule BRBang)
  moreover from Weak_Early_Bisim.eqvt have "eqvt (bangRel weakBisim)" by(rule eqvtBangRel)
  ultimately show ?thesis
    apply(coinduct rule: Weak_Early_Bisim.transitive_coinduct_weak)
    apply(blast intro: Sim)
    by(blast dest: bangRelSymetric Weak_Early_Bisim.symetric intro: Strong_Early_Bisim.reflexive)
qed

end