(* Copyright 2021 (C) Mihails Milehins *)

section\<open>\<open>IHOL_IDE\<close>\<close>
theory IHOL_IDE
  imports "IDE_Tools/IDE_Tools"
  keywords "mk_ide" :: thy_defn
    and "rf"
    and "|intro" "|dest" "|elim"
begin

subsection\<open>Miscellaneous results\<close>

lemma PQ_P_Q: "P \<equiv> Q \<Longrightarrow> P \<Longrightarrow> Q" by auto

subsection\<open>Import\<close>

ML_file\<open>IDE.ML\<close>

end


theory "WideMouthFrog_cert_auto"
imports
  "../ESPLogic"
begin

(* section:  Wide Mouthed Frog  *)

(* text:
  The protocol is modeled after the description in the SPORE library:

    http://www.lsv.ens-cachan.fr/Software/spore/wideMouthedFrog.html

  Note that we cannot reason about the timestamps in our current model.
  Furthermore, our current calculus for backwards reasoning is too weak
  to reason about the original protocol

    1: I -> S: I, {TimeI, R, kIR}k(I,S)
    2: R <- S:    {TimeS, I, kIR}k(R,S)

  because the server S could receive the message {TimeI, R, kIR}k(I,S)
  arbitrarily many times from himself. Therefore, we added global constants
  identifying the different steps.
 *)

role I
where "I =
  [ Send ''1'' <| sAV ''I'', sAV ''R'',
                  PEnc <| sC ''step1'', sN ''TimeI'', sAV ''R'', sN ''kIR'' |>
                       ( sK ''I'' ''S'' )
               |>
  ]"

role R
where "R =
  [ Recv ''2'' <| sMV ''S'', sMV ''I'',
                  PEnc <| sC ''step2'', sMV ''TimeS'', sMV ''I'', sMV ''kIR'' |>
                       ( PSymK ( sAV ''R'' ) ( sMV ''S'' ) )
               |>
  ]"

role S
where "S =
  [ Recv ''1'' <| sMV ''I'', sMV ''R'',
                  PEnc <| sC ''step1'', sMV ''TimeI'', sMV ''R'', sMV ''kIR'' |>
                       ( PSymK ( sMV ''I'' ) ( sAV ''S'' ) )
               |>
  , Send ''2'' <| sAV ''S'', sMV ''I'',
                  PEnc <| sC ''step2'', sN ''TimeS'', sMV ''I'', sMV ''kIR'' |>
                       ( PSymK ( sMV ''R'' ) ( sAV ''S'' ) )
               |>
  ]"

protocol WMF
where "WMF = { I, R, S }"

locale restricted_WMF_state = WMF_state

type_invariant WMF_msc_typing for WMF
where "WMF_msc_typing = mk_typing
  [ ((R, ''I''), (KnownT R_2))
  , ((S, ''I''), (KnownT S_1))
  , ((S, ''R''), (KnownT S_1))
  , ((R, ''S''), (KnownT R_2))
  , ((S, ''TimeI''), (SumT (KnownT S_1) (NonceT I ''TimeI'')))
  , ((R, ''TimeS''), (SumT (KnownT R_2) (NonceT S ''TimeS'')))
  , ((R, ''kIR''), (SumT (KnownT R_2) (NonceT I ''kIR'')))
  , ((S, ''kIR''), (SumT (KnownT S_1) (NonceT I ''kIR'')))
  ]"

sublocale WMF_state < WMF_msc_typing_state
proof -
  have "(t,r,s) : approx WMF_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF WMF_msc_typing.monoTyp, completeness_cases_rule])
    case (R_2_I t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    by (fastsimp intro: event_predOrdI split: if_splits)
  next
    case (R_2_S t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    by (fastsimp intro: event_predOrdI split: if_splits)
  next
    case (R_2_TimeS t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    proof(sources! "
        Enc {| LC ''step2'', s(MV ''TimeS'' tid0), s(MV ''I'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(AV ''R'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
  next
    case (R_2_kIR t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    proof(sources! "
        Enc {| LC ''step2'', s(MV ''TimeS'' tid0), s(MV ''I'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(AV ''R'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
      case (S_2_enc tid1) note_unified facts = this facts
      thus ?thesis proof(sources! "
                       Enc {| LC ''step1'', s(MV ''TimeI'' tid1), s(AV ''R'' tid0),
                              s(MV ''kIR'' tid0)
                           |}
                           ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid1) ) ) ")
      qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
    qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
  next
    case (S_1_I t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    by (fastsimp intro: event_predOrdI split: if_splits)
  next
    case (S_1_R t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    by (fastsimp intro: event_predOrdI split: if_splits)
  next
    case (S_1_TimeI t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    proof(sources! "
        Enc {| LC ''step1'', s(MV ''TimeI'' tid0), s(MV ''R'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
  next
    case (S_1_kIR t r s tid0) note facts = this
    then interpret state: WMF_msc_typing_state t r s
      by unfold_locales auto
    show ?case using facts
    proof(sources! "
        Enc {| LC ''step1'', s(MV ''TimeI'' tid0), s(MV ''R'' tid0),
               s(MV ''kIR'' tid0)
            |}
            ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    qed (insert facts, ((fastsimp intro: event_predOrdI split: if_splits))+)?
  qed
  thus "WMF_msc_typing_state t r s" by unfold_locales auto
qed

text{* Prove secrecy of long-term keys. *}
context WMF_state begin

  (* This rule is unsafe in general, but OK here,
     as we are only reasoning about static compromise.
  *)
  lemma static_longterm_key_reveal[dest!]:
    "predOrd t (LKR a) e ==> RLKR a : reveals t"
    by (auto intro: compr_predOrdI)

  lemma longterm_private_key_secrecy:
    assumes facts:
      "SK m : knows t"
      "RLKR m ~: reveals t"
    shows "False"
  using facts by (sources "SK m")

  lemma longterm_sym_ud_key_secrecy:
    assumes facts:
      "K m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
    shows "False"
  using facts by (sources "K m1 m2")

  lemma longterm_sym_bd_key_secrecy:
    assumes facts:
      "Kbd m1 m2 : knows t"
      "RLKR m1 ~: reveals t"
      "RLKR m2 ~: reveals t"
      "m1 : Agent"
      "m2 : Agent"
    shows "False"
  proof -
    from facts
    have "KShr (agents {m1, m2}) : knows t"
      by (auto simp: Kbd_def)
    thus ?thesis using facts
    proof (sources "KShr (agents {m1, m2})")
    qed (auto simp: agents_def Agent_def)
  qed

  lemmas ltk_secrecy =
    longterm_sym_ud_key_secrecy
    longterm_sym_ud_key_secrecy[OF in_knows_predOrd1]
    longterm_sym_bd_key_secrecy
    longterm_sym_bd_key_secrecy[OF in_knows_predOrd1]
    longterm_private_key_secrecy
    longterm_private_key_secrecy[OF in_knows_predOrd1]

end

(* subsection:  Secrecy Properties  *)

lemma (in restricted_WMF_state) I_kIR_sec:
  assumes facts:
    "roleMap r tid0 = Some I"
    "RLKR(s(AV ''I'' tid0)) ~: reveals t"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "LN ''kIR'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''kIR'' tid0 ")
  case I_1_kIR note_unified facts = this facts
  thus ?thesis by (fastsimp dest!: ltk_secrecy)
next
  case (S_2_kIR tid1) note_unified facts = this facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''step1'', s(MV ''TimeI'' tid1), s(MV ''R'' tid1),
                          LN ''kIR'' tid0
                       |}
                       ( K ( s(MV ''I'' tid1) ) ( s(AV ''S'' tid1) ) ) ")
    case (I_1_enc tid2) note_unified facts = this facts
    thus ?thesis by (fastsimp dest!: ltk_secrecy)
  qed (insert facts, (((clarsimp, order?) | order))+)?
qed (insert facts, fastsimp+)?

lemma (in restricted_WMF_state) S_kIR_sec:
  assumes facts:
    "roleMap r tid0 = Some S"
    "RLKR(s(AV ''S'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "RLKR(s(MV ''R'' tid0)) ~: reveals t"
    "( tid0, S_1 ) : steps t"
    "s(MV ''kIR'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''step1'', s(MV ''TimeI'' tid0), s(MV ''R'' tid0),
                          s(MV ''kIR'' tid0)
                       |}
                       ( K ( s(MV ''I'' tid0) ) ( s(AV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastsimp dest!: ltk_secrecy)
  next
    case (I_1_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastsimp dest: I_kIR_sec intro: event_predOrdI)
  qed (insert facts, fastsimp+)?
qed

lemma (in restricted_WMF_state) R_kIR_sec:
  assumes facts:
    "roleMap r tid0 = Some R"
    "RLKR(s(AV ''R'' tid0)) ~: reveals t"
    "RLKR(s(MV ''I'' tid0)) ~: reveals t"
    "RLKR(s(MV ''S'' tid0)) ~: reveals t"
    "( tid0, R_2 ) : steps t"
    "s(MV ''kIR'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''step2'', s(MV ''TimeS'' tid0), s(MV ''I'' tid0),
                          s(MV ''kIR'' tid0)
                       |}
                       ( K ( s(AV ''R'' tid0) ) ( s(MV ''S'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastsimp dest!: ltk_secrecy)
  next
    case (S_2_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastsimp dest: S_kIR_sec intro: event_predOrdI)
  qed (insert facts, fastsimp+)?
qed

(* subsection:  Authentication Properties  *)

(* text:
  The authentication guarantee for the initiator is trivial because it does not
  receive any confirmation that the responder received the new session-key.
 *)

lemma (in restricted_WMF_state) S_ni_synch:
  assumes facts:
    "roleMap r tid3 = Some S"
    "RLKR(s(AV ''S'' tid3)) ~: reveals t"
    "RLKR(s(MV ''I'' tid3)) ~: reveals t"
    "( tid3, S_1 ) : steps t"
  shows
    "(?  tid1.
        roleMap r tid1 = Some I &
        s(AV ''I'' tid1) = s(MV ''I'' tid3) &
        s(AV ''R'' tid1) = s(MV ''R'' tid3) &
        s(AV ''S'' tid1) = s(AV ''S'' tid3) &
        LN ''TimeI'' tid1 = s(MV ''TimeI'' tid3) &
        LN ''kIR'' tid1 = s(MV ''kIR'' tid3) &
        predOrd t (St( tid1, I_1 )) (St( tid3, S_1 )))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''step1'', s(MV ''TimeI'' tid3), s(MV ''R'' tid3),
                          s(MV ''kIR'' tid3)
                       |}
                       ( K ( s(MV ''I'' tid3) ) ( s(AV ''S'' tid3) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastsimp dest!: ltk_secrecy)
  next
    case (I_1_enc tid4) note_unified facts = this facts
    thus ?thesis by (fastsimp intro: event_predOrdI split: if_splits)
  qed (insert facts, fastsimp+)?
qed

lemma (in restricted_WMF_state) R_ni_synch:
  assumes facts:
    "roleMap r tid2 = Some R"
    "RLKR(s(AV ''R'' tid2)) ~: reveals t"
    "RLKR(s(MV ''I'' tid2)) ~: reveals t"
    "RLKR(s(MV ''S'' tid2)) ~: reveals t"
    "( tid2, R_2 ) : steps t"
  shows
    "(?  tid1.
        (?  tid3.
           roleMap r tid1 = Some I &
           roleMap r tid3 = Some S &
           s(AV ''I'' tid1) = s(MV ''I'' tid2) &
           s(MV ''I'' tid2) = s(MV ''I'' tid3) &
           s(AV ''R'' tid1) = s(AV ''R'' tid2) &
           s(AV ''R'' tid2) = s(MV ''R'' tid3) &
           s(AV ''S'' tid1) = s(MV ''S'' tid2) &
           s(MV ''S'' tid2) = s(AV ''S'' tid3) &
           LN ''TimeI'' tid1 = s(MV ''TimeI'' tid3) &
           s(MV ''TimeS'' tid2) = LN ''TimeS'' tid3 &
           LN ''kIR'' tid1 = s(MV ''kIR'' tid2) &
           s(MV ''kIR'' tid2) = s(MV ''kIR'' tid3) &
           predOrd t (St( tid1, I_1 )) (St( tid3, S_1 )) &
           predOrd t (St( tid3, S_1 )) (St( tid3, S_2 )) &
           predOrd t (St( tid3, S_2 )) (St( tid2, R_2 ))))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''step2'', s(MV ''TimeS'' tid2), s(MV ''I'' tid2),
                          s(MV ''kIR'' tid2)
                       |}
                       ( K ( s(AV ''R'' tid2) ) ( s(MV ''S'' tid2) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastsimp dest!: ltk_secrecy)
  next
    case (S_2_enc tid3) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''step1'', s(MV ''TimeI'' tid3), s(AV ''R'' tid2),
                            s(MV ''kIR'' tid2)
                         |}
                         ( K ( s(MV ''I'' tid2) ) ( s(AV ''S'' tid3) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastsimp dest!: ltk_secrecy)
    next
      case (I_1_enc tid4) note_unified facts = this facts
      thus ?thesis by (fastsimp intro: event_predOrdI split: if_splits)
    qed (insert facts, fastsimp+)?
  qed (insert facts, fastsimp+)?
qed

end


(*
Title: SIFUM-Type-Systems
Authors: Sylvia Grewe, Heiko Mantel, Daniel Schoepe
*)
section \<open>Type System for Ensuring Locally Sound Use of Modes\<close>

theory LocallySoundModeUse
imports Main Security Language
begin

subsection \<open>Typing Rules\<close>

locale sifum_modes = sifum_lang ev\<^sub>A ev\<^sub>B  +
  sifum_security dma Stop eval\<^sub>w
  for ev\<^sub>A :: "('Var, 'Val) Mem \<Rightarrow> 'AExp \<Rightarrow> 'Val"
  and ev\<^sub>B :: "('Var, 'Val) Mem \<Rightarrow> 'BExp \<Rightarrow> bool"

context sifum_modes
begin

abbreviation eval_abv_modes :: "(_, 'Var, 'Val) LocalConf \<Rightarrow> (_, _, _) LocalConf \<Rightarrow> bool"
  (infixl "\<leadsto>" 70)
  where
  "x \<leadsto> y \<equiv> (x, y) \<in> eval\<^sub>w"

fun update_annos :: "'Var Mds \<Rightarrow> 'Var ModeUpd list \<Rightarrow> 'Var Mds"
(infix "\<oplus>" 140)
  where
  "update_annos mds [] = mds" |
  "update_annos mds (a # as) = update_annos (update_modes a mds) as"

fun annotate :: "('Var, 'AExp, 'BExp) Stmt \<Rightarrow> 'Var ModeUpd list \<Rightarrow> ('Var, 'AExp, 'BExp) Stmt"
(infix "\<otimes>" 140)
  where
  "annotate c [] = c" |
  "annotate c (a # as) = (annotate c as)@[a]"

inductive mode_type :: "'Var Mds \<Rightarrow>
  ('Var, 'AExp, 'BExp) Stmt \<Rightarrow>
  'Var Mds \<Rightarrow> bool" ("\<turnstile> _ { _ } _")
  where
  skip: "\<turnstile> mds { Skip \<otimes> annos } (mds \<oplus> annos)" |
  assign: "\<lbrakk> x \<notin> mds GuarNoWrite ; aexp_vars e \<inter> mds GuarNoRead = {} \<rbrakk> \<Longrightarrow>
  \<turnstile> mds { (x \<leftarrow> e) \<otimes> annos } (mds \<oplus> annos)" |
  if_: "\<lbrakk> \<turnstile> (mds \<oplus> annos) { c\<^sub>1 } mds'' ;
          \<turnstile> (mds \<oplus> annos) { c\<^sub>2 } mds'' ;
          bexp_vars e \<inter> mds GuarNoRead = {} \<rbrakk> \<Longrightarrow>
        \<turnstile> mds { If e c\<^sub>1 c\<^sub>2 \<otimes> annos } mds''" |
  while: "\<lbrakk> mds' = mds \<oplus> annos ; \<turnstile> mds' { c } mds' ; bexp_vars e \<inter> mds' GuarNoRead = {} \<rbrakk> \<Longrightarrow>
  \<turnstile> mds { While e c \<otimes> annos } mds'" |
  seq: "\<lbrakk> \<turnstile> mds { c\<^sub>1 } mds' ; \<turnstile> mds' { c\<^sub>2 } mds'' \<rbrakk> \<Longrightarrow> \<turnstile> mds { c\<^sub>1 ;; c\<^sub>2 } mds''" |
  sub: "\<lbrakk> \<turnstile> mds\<^sub>2 { c } mds\<^sub>2' ; mds\<^sub>1 \<le> mds\<^sub>2 ; mds\<^sub>2' \<le> mds\<^sub>1' \<rbrakk> \<Longrightarrow>
  \<turnstile> mds\<^sub>1 { c } mds\<^sub>1'"

subsection \<open>Soundness of the Type System\<close>

(* Special case for evaluation with an empty context *)

lemma update_preserves_le:
  "mds\<^sub>1 \<le> mds\<^sub>2 \<Longrightarrow> (mds\<^sub>1 \<oplus> annos) \<le> (mds\<^sub>2 \<oplus> annos)"
proof (induct annos arbitrary: mds\<^sub>1 mds\<^sub>2)
  case Nil
  thus ?case by simp
next
  case (Cons a annos mds\<^sub>1 mds\<^sub>2)
  hence "update_modes a mds\<^sub>1 \<le> update_modes a mds\<^sub>2"
    by (case_tac a, auto simp: le_fun_def)
  with Cons show ?case
    by auto
qed

(* Annotations do not affect doesnt_read and doesnt_modify: *)
lemma doesnt_read_annos:
  "doesnt_read c x \<Longrightarrow> doesnt_read (c \<otimes> annos) x"
  unfolding doesnt_read_def
  apply clarify
  apply (induct annos)
   apply simp
   apply (metis (lifting))
  apply auto
  apply (rule cxt_eval)
  apply (rule eval\<^sub>w.decl)
  by (metis cxt_eval eval\<^sub>w.decl upd_elim)

lemma doesnt_modify_annos:
  "doesnt_modify c x \<Longrightarrow> doesnt_modify (c \<otimes> annos) x"
  unfolding doesnt_modify_def
  apply auto
  apply (induct annos)
   apply simp
  apply auto
  by (metis (lifting) upd_elim)

(* The following part contains some lemmas about evaluation of
   commands annotated using \<otimes> and characterisations of loc_reach for
   commands. *)

lemma stop_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>Stop, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  c' = Stop \<and> mds' = mds"
  apply (induct rule: loc_reach.induct)
  by (auto simp: stop_no_eval)

lemma stop_doesnt_access:
  "doesnt_modify Stop x \<and> doesnt_read Stop x"
  unfolding doesnt_modify_def and doesnt_read_def
  using stop_no_eval
  by auto

lemma skip_eval_step:
  "\<langle>Skip \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>Stop, mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (metis cxt_to_stmt.simps(1) eval\<^sub>w.unannotated eval\<^sub>w_simple.skip)
  apply simp
  apply (insert eval\<^sub>w.decl)
  apply (rule cxt_eval)
  apply (rule eval\<^sub>w.decl)
  by auto

lemma skip_eval_elim:
  "\<lbrakk> \<langle>Skip \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow> c' = Stop \<and> mds' = mds \<oplus> annos \<and> mem' = mem"
  apply (rule ccontr)
  apply (insert skip_eval_step deterministic)
  apply clarify
  apply auto
    by metis+

lemma skip_doesnt_read:
  "doesnt_read (Skip \<otimes> annos) x"
  apply (rule doesnt_read_annos)
  apply (auto simp: doesnt_read_def)
  by (metis annotate.simps(1) skip_elim skip_eval_step)

lemma skip_doesnt_write:
  "doesnt_modify (Skip \<otimes> annos) x"
  apply (rule doesnt_modify_annos)
  apply (auto simp: doesnt_modify_def)
  by (metis skip_elim)

lemma skip_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>Skip \<otimes> annos, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = Stop \<and> mds' = (mds \<oplus> annos)) \<or> (c' = Skip \<otimes> annos \<and> mds' = mds)"
  apply (induct rule: loc_reach.induct)
    apply (metis fst_conv snd_conv)
   apply (metis skip_eval_elim stop_no_eval)
  by metis

lemma skip_doesnt_access:
  "\<lbrakk> lc \<in> loc_reach \<langle>Skip \<otimes> annos, mds, mem\<rangle> ; lc = \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow> doesnt_read c' x \<and> doesnt_modify c' x"
  apply (subgoal_tac "(c' = Stop \<and> mds' = (mds \<oplus> annos)) \<or> (c' = Skip \<otimes> annos \<and> mds' = mds)")
   apply (rule conjI, erule disjE)
     apply (simp add: doesnt_read_def stop_no_eval)
    apply (metis (lifting) annotate.simps skip_doesnt_read)
   apply (erule disjE)
    apply (simp add: doesnt_modify_def stop_no_eval)
   apply (metis (lifting) annotate.simps skip_doesnt_write)
  by (metis skip_loc_reach)

lemma assign_doesnt_modify:
  "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> doesnt_modify ((x \<leftarrow> e) \<otimes> annos) y"
  apply (rule doesnt_modify_annos)
  apply (simp add: doesnt_modify_def)
  by (metis assign_elim fun_upd_apply)

lemma assign_annos_eval:
  "\<langle>(x \<leftarrow> e) \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>Stop, mds \<oplus> annos, mem (x := ev\<^sub>A mem e)\<rangle>"
  apply (induct annos arbitrary: mds)
   apply (simp only: annotate.simps update_annos.simps)
   apply (rule cxt_eval)
   apply (rule eval\<^sub>w.unannotated)
   apply (rule eval\<^sub>w_simple.assign)
  apply (rule cxt_eval)
  apply (simp del: cxt_to_stmt.simps)
  apply (rule eval\<^sub>w.decl)
  by auto

lemma assign_annos_eval_elim:
  "\<lbrakk> \<langle>(x \<leftarrow> e) \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
  c' = Stop \<and> mds' = mds \<oplus> annos"
  apply (rule ccontr)
  apply (insert deterministic assign_annos_eval)
  apply auto
   apply (metis (lifting))
  by metis

lemma mem_upd_commute:
  "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> mem (x := v\<^sub>1, y := v\<^sub>2) = mem (y := v\<^sub>2, x := v\<^sub>1)"
  by (metis fun_upd_twist)

lemma assign_doesnt_read:
  "\<lbrakk> y \<notin> aexp_vars e \<rbrakk> \<Longrightarrow> doesnt_read ((x \<leftarrow> e) \<otimes> annos) y"
  apply (rule doesnt_read_annos)
proof (cases "x = y")
  assume "y \<notin> aexp_vars e"
    and [simp]: "x = y"
  show "doesnt_read (x \<leftarrow> e) y"
    unfolding doesnt_read_def
    apply (rule allI)+
    apply (rename_tac mds mem c' mds' mem')
    apply (rule impI)
    apply (subgoal_tac "c' = Stop \<and> mds' = mds \<and> mem' = mem (x := ev\<^sub>A mem e)")
     apply simp
     apply (rule disjI2)
     apply clarify
     apply (rule cxt_eval)
     apply (rule eval\<^sub>w.unannotated)
     apply simp
     apply (metis (hide_lams, no_types) \<open>x = y\<close> \<open>y \<notin> aexp_vars e\<close> eval\<^sub>w_simple.assign eval_vars_det\<^sub>A fun_upd_apply fun_upd_upd)
    by (metis assign_elim)
next
  assume asms: "y \<notin> aexp_vars e" "x \<noteq> y"
  show "doesnt_read (x \<leftarrow> e) y"
    unfolding doesnt_read_def
    apply (rule allI)+
    apply (rename_tac mds mem c' mds' mem')
    apply (rule impI)
    apply (subgoal_tac "c' = Stop \<and> mds' = mds \<and> mem' = mem (x := ev\<^sub>A mem e)")
     apply simp
     apply (rule disjI1)
     apply (insert asms)
     apply clarify
     apply (subgoal_tac "mem (x := ev\<^sub>A mem e, y := v) = mem (y := v, x := ev\<^sub>A mem e)")
      apply simp
      apply (rule cxt_eval)
      apply (rule eval\<^sub>w.unannotated)
      apply (metis eval\<^sub>w_simple.assign eval_vars_det\<^sub>A fun_upd_apply)
     apply (metis mem_upd_commute)
    by (metis assign_elim)
qed

lemma assign_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>(x \<leftarrow> e) \<otimes> annos, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = Stop \<and> mds' = (mds \<oplus> annos)) \<or> (c' = (x \<leftarrow> e) \<otimes> annos \<and> mds' = mds)"
  apply (induct rule: loc_reach.induct)
    apply simp_all
  by (metis assign_annos_eval_elim stop_no_eval)

lemma if_doesnt_modify:
  "doesnt_modify (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
  apply (rule doesnt_modify_annos)
  by (auto simp: doesnt_modify_def)

lemma vars_eval\<^sub>B:
  "x \<notin> bexp_vars e \<Longrightarrow> ev\<^sub>B mem e = ev\<^sub>B (mem (x := v)) e"
  by (metis (lifting) eval_vars_det\<^sub>B fun_upd_other)

lemma if_doesnt_read:
  "x \<notin> bexp_vars e \<Longrightarrow> doesnt_read (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
  apply (rule doesnt_read_annos)
  apply (auto simp: doesnt_read_def)
  apply (rename_tac mds mem c' mds' mem' v va)
  apply (case_tac "ev\<^sub>B mem e")
   apply (subgoal_tac "c' = c\<^sub>1 \<and> mds' = mds \<and> mem' = mem")
    apply auto
   apply (rule cxt_eval)
   apply (rule eval\<^sub>w.unannotated)
   apply (rule eval\<^sub>w_simple.if_true)
   apply (metis (lifting) vars_eval\<^sub>B)
  apply (subgoal_tac "c' = c\<^sub>2 \<and> mds' = mds \<and> mem' = mem")
   apply auto
  apply (rule cxt_eval)
  apply (rule eval\<^sub>w.unannotated)
  apply (rule eval\<^sub>w_simple.if_false)
  by (metis (lifting) vars_eval\<^sub>B)

lemma if_eval_true:
  "\<lbrakk> ev\<^sub>B mem e \<rbrakk> \<Longrightarrow>
  \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c\<^sub>1, mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (metis cxt_eval eval\<^sub>w.unannotated eval\<^sub>w_simple.if_true)
  by (metis annotate.simps(2) cxt_eval eval\<^sub>w.decl update_annos.simps(2))

lemma if_eval_false:
  "\<lbrakk> \<not> ev\<^sub>B mem e \<rbrakk> \<Longrightarrow>
  \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c\<^sub>2, mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (metis cxt_eval eval\<^sub>w.unannotated eval\<^sub>w_simple.if_false)
  by (metis annotate.simps(2) cxt_eval eval\<^sub>w.decl update_annos.simps(2))

lemma if_eval_elim:
  "\<lbrakk> \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
  ((c' = c\<^sub>1 \<and> ev\<^sub>B mem e) \<or> (c' = c\<^sub>2 \<and> \<not> ev\<^sub>B mem e)) \<and> mds' = mds \<oplus> annos \<and> mem' = mem"
  apply (rule ccontr)
  apply (cases "ev\<^sub>B mem e")
   apply (insert if_eval_true deterministic)
   apply (metis prod.inject)
  by (metis prod.inject if_eval_false deterministic)

lemma if_eval_elim':
  "\<lbrakk> \<langle>If e c\<^sub>1 c\<^sub>2, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
  ((c' = c\<^sub>1 \<and> ev\<^sub>B mem e) \<or> (c' = c\<^sub>2 \<and> \<not> ev\<^sub>B mem e)) \<and> mds' = mds \<and> mem' = mem"
  using if_eval_elim [where annos = "[]"]
  by auto

lemma loc_reach_refl':
  "\<langle>c, mds, mem\<rangle> \<in> loc_reach \<langle>c, mds, mem\<rangle>"
  apply (subgoal_tac "\<exists> lc. lc \<in> loc_reach lc \<and> lc = \<langle>c, mds, mem\<rangle>")
   apply blast
  by (metis loc_reach.refl fst_conv snd_conv)

lemma if_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = If e c\<^sub>1 c\<^sub>2 \<otimes> annos \<and> mds' = mds) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds \<oplus> annos, mem''\<rangle>) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds \<oplus> annos, mem''\<rangle>)"
  apply (induct rule: loc_reach.induct)
    apply (metis fst_conv snd_conv)
   apply (erule disjE)
    apply (erule conjE)
    apply simp
    apply (drule if_eval_elim)
    apply (erule conjE)+
    apply (erule disjE)
     apply (erule conjE)
     apply simp
     apply (metis loc_reach_refl')
    apply (metis loc_reach_refl')
   apply (metis loc_reach.step)
  by (metis loc_reach.mem_diff)

lemma if_loc_reach':
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (c' = If e c\<^sub>1 c\<^sub>2 \<and> mds' = mds) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem''\<rangle>) \<or>
  (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds, mem''\<rangle>)"
  using if_loc_reach [where annos = "[]"]
  by simp

lemma seq_loc_reach:
  "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1 ;; c\<^sub>2, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  (\<exists> c''. c' = c'' ;; c\<^sub>2 \<and> \<langle>c'', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem\<rangle>) \<or>
  (\<exists> c'' mds'' mem''. \<langle>Stop, mds'', mem''\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem\<rangle> \<and>
                      \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds'', mem''\<rangle>)"
  apply (induct rule: loc_reach.induct)
    apply simp
    apply (metis  loc_reach_refl')
   apply simp
   apply (metis (no_types) loc_reach.step loc_reach_refl' seq_elim seq_stop_elim)
  by (metis (lifting) loc_reach.mem_diff)

lemma seq_doesnt_read:
  "\<lbrakk> doesnt_read c x \<rbrakk> \<Longrightarrow> doesnt_read (c ;; c') x"
  apply (auto simp: doesnt_read_def)
  apply (rename_tac mds mem c'a mds' mem' v va)
  apply (case_tac "c = Stop")
   apply auto
   apply (subgoal_tac "c'a = c' \<and> mds' = mds \<and> mem' = mem")
    apply simp
    apply (metis cxt_eval eval\<^sub>w.unannotated eval\<^sub>w_simple.seq_stop)
   apply (metis (lifting) seq_stop_elim)
  by (metis (lifting, no_types) eval\<^sub>w.seq seq_elim)

inductive_cases seq_stop_elim': "\<langle>Stop ;; c, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle>"

lemma seq_split:
  "\<lbrakk> \<langle>Stop, mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1 ;; c\<^sub>2, mds, mem\<rangle> \<rbrakk> \<Longrightarrow>
  \<exists> mds'' mem''. \<langle>Stop, mds'', mem''\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds, mem\<rangle> \<and>
                 \<langle>Stop, mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds'', mem''\<rangle>"
  apply (drule seq_loc_reach)
  by (metis Stmt.simps(41))

lemma while_eval:
  "\<langle>While e c \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>(If e (c ;; While e c) Stop), mds \<oplus> annos, mem\<rangle>"
  apply (induct annos arbitrary: mds)
   apply simp
   apply (rule cxt_eval)
   apply (rule eval\<^sub>w.unannotated)
   apply (metis (lifting) eval\<^sub>w_simple.while)
  apply simp
  by (metis cxt_eval eval\<^sub>w.decl)

lemma while_eval':
  "\<langle>While e c, mds, mem\<rangle> \<leadsto> \<langle>If e (c ;; While e c) Stop, mds, mem\<rangle>"
  using while_eval [where annos = "[]"]
  by auto

lemma while_eval_elim:
  "\<lbrakk> \<langle>While e c \<otimes> annos, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
   (c' = If e (c ;; While e c) Stop \<and> mds' = mds \<oplus> annos \<and> mem' = mem)"
  apply (rule ccontr)
  apply (insert while_eval deterministic)
  by blast

lemma while_eval_elim':
  "\<lbrakk> \<langle>While e c, mds, mem\<rangle> \<leadsto> \<langle>c', mds', mem'\<rangle> \<rbrakk> \<Longrightarrow>
   (c' = If e (c ;; While e c) Stop \<and> mds' = mds \<and> mem' = mem)"
  using while_eval_elim [where annos = "[]"]
  by auto

lemma while_doesnt_read:
  "\<lbrakk> x \<notin> bexp_vars e \<rbrakk> \<Longrightarrow> doesnt_read (While e c \<otimes> annos) x"
  unfolding doesnt_read_def
  using while_eval while_eval_elim
  by metis

lemma while_doesnt_modify:
  "doesnt_modify (While e c \<otimes> annos) x"
  unfolding doesnt_modify_def
  using while_eval_elim
  by metis

(* TODO: try to find a better solution to this: *)
lemma disjE3:
  "\<lbrakk> A \<or> B \<or> C ; A \<Longrightarrow> P ; B \<Longrightarrow> P ; C \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma disjE5:
  "\<lbrakk> A \<or> B \<or> C \<or> D \<or> E ; A \<Longrightarrow> P ; B \<Longrightarrow> P ; C \<Longrightarrow> P ; D \<Longrightarrow> P ; E \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by auto

lemma if_doesnt_read':
  "x \<notin> bexp_vars e \<Longrightarrow> doesnt_read (If e c\<^sub>1 c\<^sub>2) x"
  using if_doesnt_read [where annos = "[]"]
  by auto

theorem mode_type_sound:
  assumes typeable: "\<turnstile> mds\<^sub>1 { c } mds\<^sub>1'"
  assumes mode_le: "mds\<^sub>2 \<le> mds\<^sub>1"
  shows "\<forall> mem. (\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>c, mds\<^sub>2, mem\<rangle> \<longrightarrow> mds\<^sub>2' \<le> mds\<^sub>1') \<and>
                locally_sound_mode_use \<langle>c, mds\<^sub>2, mem\<rangle>"
  using typeable mode_le
proof (induct arbitrary: mds\<^sub>2 mds\<^sub>2' mem' mem rule: mode_type.induct)
  case (skip mds annos)
  thus ?case
    apply auto
     apply (metis (lifting) skip_eval_step skip_loc_reach stop_no_eval update_preserves_le)
    apply (simp add: locally_sound_mode_use_def)
    by (metis annotate.simps skip_doesnt_access)
next
  case (assign x mds e annos)
  hence "\<forall> mem. locally_sound_mode_use \<langle>(x \<leftarrow> e) \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    unfolding locally_sound_mode_use_def
  proof (clarify)
    fix mem c' mds' mem' y
    assume asm: "\<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>(x \<leftarrow> e) \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    hence "c' = (x \<leftarrow> e) \<otimes> annos \<and> mds' = mds\<^sub>2 \<or> c' = Stop \<and> mds' = mds\<^sub>2 \<oplus> annos"
      using assign_loc_reach by blast
    thus "(y \<in> mds' GuarNoRead \<longrightarrow> doesnt_read c' y) \<and>
          (y \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' y)"
    proof
      assume "c' = (x \<leftarrow> e) \<otimes> annos \<and> mds' = mds\<^sub>2"
      thus ?thesis
      proof (auto)
        assume "y \<in> mds\<^sub>2 GuarNoRead"
        hence "y \<notin> aexp_vars e"
          by (metis IntD2 IntI assign.hyps(2) assign.prems empty_iff inf_apply le_iff_inf)
        with assign_doesnt_read show "doesnt_read ((x \<leftarrow> e) \<otimes> annos) y"
          by blast
      next
        assume "y \<in> mds\<^sub>2 GuarNoWrite"
        hence "x \<noteq> y"
          by (metis assign.hyps(1) assign.prems in_mono le_fun_def)
        with assign_doesnt_modify show "doesnt_modify ((x \<leftarrow> e) \<otimes> annos) y"
          by blast
      qed
    next
      assume "c' = Stop \<and> mds' = mds\<^sub>2 \<oplus> annos"
      with stop_doesnt_access show ?thesis by blast
    qed
  qed
  thus ?case
    apply auto
    by (metis assign.prems assign_annos_eval assign_loc_reach stop_no_eval update_preserves_le)
next
  case (if_ mds annos c\<^sub>1 mds'' c\<^sub>2 e)
    let ?c = "(If e c\<^sub>1 c\<^sub>2) \<otimes> annos"
  from if_ have modes_le': "mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos"
    by (metis (lifting) update_preserves_le)
  from if_ show ?case
    apply (simp add: locally_sound_mode_use_def)
    apply clarify
    apply (rule conjI)
     apply clarify
     prefer 2
     apply clarify
  proof -
    fix mem
    assume "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    with modes_le' and if_ show "mds\<^sub>2' \<le> mds''"
      by (metis if_eval_false if_eval_true if_loc_reach stop_no_eval)
  next
    fix mem c' mds' mem' x
    assume "\<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>If e c\<^sub>1 c\<^sub>2 \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    hence "(c' = If e c\<^sub>1 c\<^sub>2 \<otimes> annos \<and> mds' = mds\<^sub>2) \<or>
           (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds\<^sub>2 \<oplus> annos, mem''\<rangle>) \<or>
           (\<exists> mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds\<^sub>2 \<oplus> annos, mem''\<rangle>)"
      using if_loc_reach by blast
    thus "(x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read c' x) \<and>
          (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
    proof
      assume "c' = If e c\<^sub>1 c\<^sub>2 \<otimes> annos \<and> mds' = mds\<^sub>2"
      thus ?thesis
      proof (auto)
        assume "x \<in> mds\<^sub>2 GuarNoRead"
        with \<open>bexp_vars e \<inter> mds GuarNoRead = {}\<close> and \<open>mds\<^sub>2 \<le> mds\<close> have "x \<notin> bexp_vars e"
          by (metis IntD2 disjoint_iff_not_equal inf_fun_def le_iff_inf)
        thus "doesnt_read (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
          using if_doesnt_read by blast
      next
        assume "x \<in> mds\<^sub>2 GuarNoWrite"
        thus "doesnt_modify (If e c\<^sub>1 c\<^sub>2 \<otimes> annos) x"
          using if_doesnt_modify by blast
      qed
    next
      assume "(\<exists>mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds\<^sub>2 \<oplus> annos, mem''\<rangle>) \<or>
              (\<exists>mem''. \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds\<^sub>2 \<oplus> annos, mem''\<rangle>)"
      with if_ show ?thesis
        by (metis locally_sound_mode_use_def modes_le')
    qed
  qed
next
  case (while mdsa mds annos c e)
  hence "mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos"
    by (metis (lifting) update_preserves_le)
  have while_loc_reach: "\<And> c' mds' mem' mem.
  \<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle> \<Longrightarrow>
  c' = While e c \<otimes> annos \<and> mds' = mds\<^sub>2 \<or>
  c' = While e c \<and> mds' \<le> mdsa \<or>
  c' = Stmt.If e (c ;; While e c) Stop \<and> mds' \<le> mdsa \<or>
  c' = Stop \<and> mds' \<le> mdsa \<or>
  (\<exists>c'' mem'' mds\<^sub>3.
      c' = c'' ;; While e c \<and>
      mds\<^sub>3 \<le> mdsa \<and> \<langle>c'', mds', mem'\<rangle> \<in> loc_reach \<langle>c, mds\<^sub>3, mem''\<rangle>)"
  proof -
    fix mem c' mds' mem'
    assume "\<langle>c', mds', mem'\<rangle> \<in> loc_reach \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    thus "?thesis c' mds' mem' mem"
      apply (induct rule: loc_reach.induct)
        apply simp_all
       apply (erule disjE)
        apply simp
        apply (metis \<open>mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos\<close> while.hyps(1) while_eval_elim)
       apply (erule disjE)
        apply (metis while_eval_elim')
       apply (erule disjE)
        apply simp
        apply (metis if_eval_elim' loc_reach_refl')
       apply (erule disjE)
        apply (metis stop_no_eval)
       apply (erule exE)
       apply (rename_tac c' mds' mem' c'' mds'' mem'' c''a)
       apply (case_tac "c''a = Stop")
        apply (insert while.hyps(3))
        apply (metis seq_stop_elim while.hyps(3))
       apply (metis loc_reach.step seq_elim)
      by (metis (full_types) loc_reach.mem_diff)
  qed
  from while show ?case
  proof (auto)
    fix mem
    assume "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
    thus "mds\<^sub>2' \<le> mds \<oplus> annos"
      by (metis Stmt.distinct(35) stop_no_eval while.hyps(1) while_eval while_loc_reach)
  next
    fix mem
    from while have "bexp_vars e \<inter> (mds\<^sub>2 \<oplus> annos) GuarNoRead = {}"
      by (metis (lifting, no_types) Int_empty_right Int_left_commute \<open>mds\<^sub>2 \<oplus> annos \<le> mds \<oplus> annos\<close> inf_fun_def le_iff_inf)
    show "locally_sound_mode_use \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
      unfolding locally_sound_mode_use_def
      apply (rule allI)+
      apply (rule impI)
    proof -
      fix c' mds' mem'
      define lc where "lc = \<langle>While e c \<otimes> annos, mds\<^sub>2, mem\<rangle>"
      assume "\<langle>c', mds', mem'\<rangle> \<in> loc_reach lc"
      thus "\<forall> x. (x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read c' x) \<and>
                 (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)"
        apply (simp add: lc_def)
        apply (drule while_loc_reach)
        apply (erule disjE5)
      proof (auto del: conjI)
        fix x
        show "(x \<in> mds\<^sub>2 GuarNoRead \<longrightarrow> doesnt_read (While e c \<otimes> annos) x) \<and>
              (x \<in> mds\<^sub>2 GuarNoWrite \<longrightarrow> doesnt_modify (While e c \<otimes> annos) x)"
          unfolding doesnt_read_def and doesnt_modify_def
          using while_eval and while_eval_elim
          by blast
      next
        fix x
        assume "mds' \<le> mdsa"
        let ?c' = "If e (c ;; While e c) Stop"
        have "x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read ?c' x"
          apply clarify
          apply (rule if_doesnt_read')
          by (metis IntI \<open>mds' \<le> mdsa\<close> empty_iff le_fun_def rev_subsetD while.hyps(1) while.hyps(4))
        moreover
        have "x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify ?c' x"
          by (metis annotate.simps(1) if_doesnt_modify)
        ultimately show "(x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read ?c' x) \<and>
                         (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify ?c' x)" ..
      next
        fix x
        assume "mds' \<le> mdsa"
        show "(x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read Stop x) \<and>
              (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify Stop x)"
          by (metis stop_doesnt_access)
      next
        fix c'' x mem'' mds\<^sub>3
        assume "mds\<^sub>3 \<le> mdsa"
        assume "\<langle>c'', mds', mem'\<rangle> \<in> loc_reach \<langle>c, mds\<^sub>3, mem''\<rangle>"
        thus "(x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read (c'' ;; While e c) x) \<and>
              (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify (c'' ;; While e c) x)"
          apply auto
           apply (rule seq_doesnt_read)
           apply (insert while(3))
           apply (metis \<open>mds\<^sub>3 \<le> mdsa\<close> locally_sound_mode_use_def while.hyps(1))
          apply (rule seq_doesnt_modify)
          by (metis \<open>mds\<^sub>3 \<le> mdsa\<close> locally_sound_mode_use_def while.hyps(1))
      next
        fix x
        assume "mds' \<le> mdsa"
        show "(x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read (While e c) x) \<and>
              (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify (While e c) x)"
          unfolding doesnt_read_def and doesnt_modify_def
          using while_eval' and while_eval_elim'
          by blast
      qed
    qed
  qed
next
  case (seq mds c\<^sub>1 mds' c\<^sub>2 mds'')
  thus ?case
  proof (auto)
    fix mem
    assume "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>1 ;; c\<^sub>2, mds\<^sub>2, mem\<rangle>"
    then obtain mds\<^sub>2'' mem'' where "\<langle>Stop, mds\<^sub>2'', mem''\<rangle> \<in> loc_reach \<langle>c\<^sub>1, mds\<^sub>2, mem\<rangle>" and
      "\<langle>Stop, mds\<^sub>2', mem'\<rangle> \<in> loc_reach \<langle>c\<^sub>2, mds\<^sub>2'', mem''\<rangle>"
      using seq_split by blast
    thus "mds\<^sub>2' \<le> mds''"
      using seq by blast
  next
    fix mem
    from seq show "locally_sound_mode_use \<langle>c\<^sub>1 ;; c\<^sub>2, mds\<^sub>2, mem\<rangle>"
      apply (simp add: locally_sound_mode_use_def)
      apply clarify
      apply (drule seq_loc_reach)
      apply (erule disjE)
       apply (metis seq_doesnt_modify seq_doesnt_read)
      by metis
  qed
next
  case (sub mds\<^sub>2'' c mds\<^sub>2' mds\<^sub>1 mds\<^sub>1' c\<^sub>1)
  thus ?case
    apply auto
    by (metis (hide_lams, no_types) inf_absorb2 le_infI1)
qed

end

end


(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>

    Based on the Jinja theory J/WellTypeRT.thy by Tobias Nipkow
*)

header {* \isaheader{Runtime Well-typedness} *}

theory WellTypeRT imports WellType begin

section {* Run time types *}

primrec typeof_h :: "prog \<Rightarrow> heap \<Rightarrow> val \<Rightarrow> ty option" ("_ \<turnstile> typeof\<^bsub>_\<^esub>") where
  "P \<turnstile> typeof\<^bsub>h\<^esub> Unit     = Some Void"
| "P \<turnstile> typeof\<^bsub>h\<^esub> Null     = Some NT"
| "P \<turnstile> typeof\<^bsub>h\<^esub> (Bool b) = Some Boolean"
| "P \<turnstile> typeof\<^bsub>h\<^esub> (Intg i) = Some Integer"
| "P \<turnstile> typeof\<^bsub>h\<^esub> (Ref r)  = (case h (the_addr (Ref r)) of None \<Rightarrow> None
                            | Some(C,S) \<Rightarrow> (if Subobjs P C (the_path(Ref r)) then
                                   Some(Class(last(the_path(Ref r))))
                                            else None))"

lemma type_eq_type: "typeof v = Some T \<Longrightarrow> P \<turnstile> typeof\<^bsub>h\<^esub> v = Some T"
by(induct v)auto

lemma typeof_Void [simp]: "P \<turnstile> typeof\<^bsub>h\<^esub> v = Some Void \<Longrightarrow> v = Unit"
by(induct v,auto split:split_if_asm)

lemma typeof_NT [simp]: "P \<turnstile> typeof\<^bsub>h\<^esub> v = Some NT \<Longrightarrow> v = Null"
by(induct v,auto split:split_if_asm)

lemma typeof_Boolean [simp]: "P \<turnstile> typeof\<^bsub>h\<^esub> v = Some Boolean \<Longrightarrow> \<exists>b. v = Bool b"
by(induct v,auto split:split_if_asm)

lemma typeof_Integer [simp]: "P \<turnstile> typeof\<^bsub>h\<^esub> v = Some Integer \<Longrightarrow> \<exists>i. v = Intg i"
by(induct v,auto split:split_if_asm)

lemma typeof_Class_Subo:
"P \<turnstile> typeof\<^bsub>h\<^esub> v = Some (Class C) \<Longrightarrow>
\<exists>a Cs D S. v = Ref(a,Cs) \<and> h a = Some(D,S) \<and> Subobjs P D Cs \<and> last Cs = C"
by(induct v,auto split:split_if_asm)

section {* The rules *}

inductive
  WTrt :: "[prog,env,heap,expr,     ty     ] \<Rightarrow> bool"
        ("_,_,_ \<turnstile> _ : _"   [51,51,51]50)
  and WTrts :: "[prog,env,heap,expr list,ty list] \<Rightarrow> bool"
        ("_,_,_ \<turnstile> _ [:] _" [51,51,51]50)
  for P :: prog
where

  WTrtNew:
  "is_class P C  \<Longrightarrow>
  P,E,h \<turnstile> new C : Class C"

| WTrtDynCast:
  "\<lbrakk> P,E,h \<turnstile> e : T; is_refT T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> Cast C e : Class C"

| WTrtStaticCast:
  "\<lbrakk> P,E,h \<turnstile> e : T; is_refT T; is_class P C \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> \<lparr>C\<rparr>e : Class C"

| WTrtVal:
  "P \<turnstile> typeof\<^bsub>h\<^esub> v = Some T \<Longrightarrow>
  P,E,h \<turnstile> Val v : T"

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

| WTrtBinOp:
  "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 : T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2 : T\<^sub>2;
     case bop of Eq \<Rightarrow> T = Boolean
               | Add \<Rightarrow> T\<^sub>1 = Integer \<and> T\<^sub>2 = Integer \<and> T = Integer \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 : T"

| WTrtLAss:
  "\<lbrakk> E V = Some T;  P,E,h \<turnstile> e : T'; P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> V:=e : T"

| WTrtFAcc:
"\<lbrakk>P,E,h \<turnstile> e : Class C; Cs \<noteq> []; P \<turnstile> C has least F:T via Cs \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<bullet>F{Cs} : T"

| WTrtFAccNT:
  "P,E,h \<turnstile> e : NT \<Longrightarrow> P,E,h \<turnstile> e\<bullet>F{Cs} : T"

| WTrtFAss:
"\<lbrakk>P,E,h \<turnstile> e\<^sub>1 : Class C; Cs \<noteq> [];
  P \<turnstile> C has least F:T via Cs; P,E,h \<turnstile> e\<^sub>2 : T'; P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1\<bullet>F{Cs}:=e\<^sub>2 : T"

| WTrtFAssNT:
  "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 : NT; P,E,h \<turnstile> e\<^sub>2 : T'; P \<turnstile> T' \<le> T \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<^sub>1\<bullet>F{Cs}:=e\<^sub>2 : T"

| WTrtCall:
  "\<lbrakk> P,E,h \<turnstile> e : Class C;  P \<turnstile> C has least M = (Ts,T,m) via Cs;
     P,E,h \<turnstile> es [:] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<bullet>M(es) : T"

| WTrtStaticCall:
  "\<lbrakk> P,E,h \<turnstile> e : Class C'; P \<turnstile> Path C' to C unique;
     P \<turnstile> C has least M = (Ts,T,m) via Cs;
     P,E,h \<turnstile> es [:] Ts'; P \<turnstile> Ts' [\<le>] Ts \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> e\<bullet>(C::)M(es) : T"

| WTrtCallNT:
  "\<lbrakk>P,E,h \<turnstile> e : NT; P,E,h \<turnstile> es [:] Ts\<rbrakk> \<Longrightarrow> P,E,h \<turnstile> Call e Copt M es : T"

| WTrtBlock:
  "\<lbrakk>P,E(V\<mapsto>T),h \<turnstile> e : T'; is_type P T\<rbrakk> \<Longrightarrow>
  P,E,h \<turnstile> {V:T; e} : T'"

| WTrtSeq:
  "\<lbrakk> P,E,h \<turnstile> e\<^sub>1 : T\<^sub>1;  P,E,h \<turnstile> e\<^sub>2 : T\<^sub>2 \<rbrakk>  \<Longrightarrow>  P,E,h \<turnstile> e\<^sub>1;;e\<^sub>2 : T\<^sub>2"

| WTrtCond:
  "\<lbrakk> P,E,h \<turnstile> e : Boolean;  P,E,h \<turnstile> e\<^sub>1 : T;  P,E,h \<turnstile> e\<^sub>2 : T \<rbrakk>
  \<Longrightarrow> P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 : T"

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

| WTrtThrow:
  "\<lbrakk>P,E,h \<turnstile> e : T'; is_refT T'\<rbrakk>
 \<Longrightarrow>  P,E,h \<turnstile> throw e : T"

| WTrtNil:
"P,E,h \<turnstile> [] [:] []"

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

declare
  WTrt_WTrts.intros[intro!]
  WTrtNil[iff]
declare
  WTrtFAcc[rule del] WTrtFAccNT[rule del]
  WTrtFAss[rule del] WTrtFAssNT[rule del]
  WTrtCall[rule del] WTrtCallNT[rule del]

lemmas WTrt_induct = WTrt_WTrts.induct [split_format (complete)]
  and WTrt_inducts = WTrt_WTrts.inducts [split_format (complete)]

section{*Easy consequences*}

inductive_simps [iff]:
  "P,E,h \<turnstile> [] [:] Ts"
  "P,E,h \<turnstile> e#es [:] T#Ts"
  "P,E,h \<turnstile> (e#es) [:] Ts"
  "P,E,h \<turnstile> Val v : T"
  "P,E,h \<turnstile> Var V : T"
  "P,E,h \<turnstile> e\<^sub>1;;e\<^sub>2 : T\<^sub>2"
  "P,E,h \<turnstile> {V:T; e} : T'"

apply(induct_tac es\<^sub>1)
 apply simp
apply clarsimp
apply(erule thin_rl)
apply (rule iffI)
 apply clarsimp
 apply(rule exI)+
 apply(rule conjI)
  prefer 2 apply blast
 apply simp
apply fastforce
done

inductive_cases WTrt_elim_cases[elim!]:
  "P,E,h \<turnstile> new C : T"
  "P,E,h \<turnstile> Cast C e : T"
  "P,E,h \<turnstile> \<lparr>C\<rparr>e : T"
  "P,E,h \<turnstile> e\<^sub>1 \<guillemotleft>bop\<guillemotright> e\<^sub>2 : T"
  "P,E,h \<turnstile> V:=e : T"
  "P,E,h \<turnstile> e\<bullet>F{Cs} : T"
  "P,E,h \<turnstile> e\<bullet>F{Cs} := v : T"
  "P,E,h \<turnstile> e\<bullet>M(es) : T"
  "P,E,h \<turnstile> e\<bullet>(C::)M(es) : T"
  "P,E,h \<turnstile> if (e) e\<^sub>1 else e\<^sub>2 : T"
  "P,E,h \<turnstile> while(e) c : T"
  "P,E,h \<turnstile> throw e : T"

section{*Some interesting lemmas*}

lemma WTrts_Val[simp]:
 "\<And>Ts. (P,E,h \<turnstile> map Val vs [:] Ts) = (map (\<lambda>v. (P \<turnstile> typeof\<^bsub>h\<^esub>) v) vs = map Some Ts)"

apply(induct vs)
 apply fastforce
apply(case_tac Ts)
 apply simp
apply simp
done

lemma WTrt_env_mono:
  "P,E,h \<turnstile> e : T \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> P,E',h \<turnstile> e : T)" and
  "P,E,h \<turnstile> es [:] Ts \<Longrightarrow> (\<And>E'. E \<subseteq>\<^sub>m E' \<Longrightarrow> P,E',h \<turnstile> es [:] Ts)"

apply(induct rule: WTrt_inducts)
apply(simp add: WTrtNew)
apply(fastforce simp: WTrtDynCast)
apply(fastforce simp: WTrtStaticCast)
apply(fastforce simp: WTrtVal)
apply(simp add: WTrtVar map_le_def dom_def)
apply(fastforce simp add: WTrtBinOp)
apply (force simp:map_le_def)
apply(fastforce simp: WTrtFAcc)
apply(simp add: WTrtFAccNT)
apply(fastforce simp: WTrtFAss)
apply(fastforce simp: WTrtFAssNT)
apply(fastforce simp: WTrtCall)
apply(fastforce simp: WTrtStaticCall)
apply(fastforce simp: WTrtCallNT)
apply(fastforce simp: map_le_def)
apply(fastforce)
apply(fastforce simp: WTrtCond)
apply(fastforce simp: WTrtWhile)
apply(fastforce simp: WTrtThrow)
apply(simp add: WTrtNil)
apply(simp add: WTrtCons)
done

lemma WT_implies_WTrt: "P,E \<turnstile> e :: T \<Longrightarrow> P,E,h \<turnstile> e : T"
and WTs_implies_WTrts: "P,E \<turnstile> es [::] Ts \<Longrightarrow> P,E,h \<turnstile> es [:] Ts"

proof(induct rule: WT_WTs_inducts)
  case WTVal thus ?case by (fastforce dest:type_eq_type)
next
  case WTBinOp thus ?case by (fastforce split:bop.splits)
next
  case WTFAcc thus ?case
    by(fastforce intro!:WTrtFAcc dest:Subobjs_nonempty
                  simp:LeastFieldDecl_def FieldDecls_def)
next
  case WTFAss thus ?case
    by(fastforce intro!:WTrtFAss dest:Subobjs_nonempty
                  simp:LeastFieldDecl_def FieldDecls_def)
next
  case WTCall thus ?case by (fastforce intro:WTrtCall)
qed (auto simp del:fun_upd_apply)

end