theory Proofs_2
  imports Requirements ExtraInv VCTheoryLemmas
begin

definition inv2 where "inv2 s \<equiv> R2 s \<and> extraInv s"

theorem proof_2_1: "VC1 inv2 s0"
  apply(simp only: VC1_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_2: "VC2 R2 env s0 user_value pressure_value"
  apply(simp only: VC2_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_3: "VC3 R2 env s0 user_value pressure_value"
  apply(simp only: VC3_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_4: "VC4 R2 env s0 user_value pressure_value"
  apply(simp only: VC4_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_5: "VC5 inv2 env s0 user_value pressure_value"
  apply(simp only: VC5_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_6: "VC6 R2 env s0 user_value pressure_value"
  apply(simp only: VC6_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_7: "VC7 inv2 env s0 user_value pressure_value"
  apply(simp only: VC7_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_8: "VC8 R2 env s0 user_value pressure_value"
  apply(simp only: VC8_def inv2_def R2_def extraInv_def)
  apply auto
   apply(drule allE[of _ "(toEnv (reset (setVarAny s0 True False) user))"])
    prefer 2
    apply assumption
   apply auto
  using substate_toEnvNum_id by blast

theorem proof_2_9: "VC9 R2 env s0 user_value pressure_value"
  apply(simp only: VC9_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_10: "VC10 R2 env s0 user_value pressure_value"
  apply(simp only: VC10_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_11: "VC11 inv2 env s0 user_value pressure_value"
  apply(simp only: VC11_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_12: "VC12 R2 env s0 user_value pressure_value"
  apply(simp only: VC12_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_13: "VC13 R2 env s0 user_value pressure_value"
  apply(simp only: VC13_def inv2_def R2_def extraInv_def)
  by auto

theorem proof_2_14: "VC14 R2 env s0 user_value pressure_value"
  apply(simp only: VC14_def inv2_def R2_def extraInv_def)
  apply auto
   apply(drule allE[of _ "(toEnv (setVarAny s0 user_value False))"])
    prefer 2
    apply assumption
   apply auto
  using substate_toEnvNum_id by blast

end


(*  Adapted from implementation by:
    Title:      Sequents/Modal0.thy
    Author:     Martin Coen
    Copyright   1991  University of Cambridge
*)

theory DModal0
imports DLK0
uses "Dmodal.ML"
begin

(*Think future which of "consts" and $datatype$ is better. *)
consts
  box           :: "fform => fform"       ("[]_" [50] 50)
  dia           :: "fform => fform"       ("<>_" [50] 50)
  strimp        :: "[fform, fform] => fform"   (infixr "--<" 25)
  streqv        :: "[fform, fform] => fform"   (infixr ">-<" 25)
  Lstar         :: "two_seqi"
  Rstar         :: "two_seqi"

syntax
  "_Lstar"      :: "two_seqe"   ("(_)|L>(_)" [6,6] 5)
  "_Rstar"      :: "two_seqe"   ("(_)|R>(_)" [6,6] 5)

ML {*
  fun star_tr c [s1, s2] = Const(c, dummyT) $ seq_tr s1 $ seq_tr s2;
  fun star_tr' c [s1, s2] = Const(c, dummyT) $ seq_tr' s1 $ seq_tr' s2;
*}

parse_translation {*
 [(@{syntax_const "_Lstar"}, star_tr @{const_syntax Lstar}),
  (@{syntax_const "_Rstar"}, star_tr @{const_syntax Rstar})]
*}

print_translation {*
 [(@{const_syntax Lstar}, star_tr' @{syntax_const "_Lstar"}),
  (@{const_syntax Rstar}, star_tr' @{syntax_const "_Rstar"})]
*}

defs
  strimp_def:    "P --< Q == [](P [-->] Q)"
  streqv_def:    "P >-< Q == (P --< Q) [&] (Q --< P)"

lemmas rewrite_rls = strimp_def streqv_def

lemma iffR:
    "[| $H,P |- $E,Q,$F;  $H,Q |- $E,P,$F |] ==> $H |- $E, P [<->] Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL:
    "[| $H,$G |- $E,P,Q;  $H,Q,P,$G |- $E |] ==> $H, P [<->] Q, $G |- $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemmas safe_rls = basic conjL conjR disjL disjR impL impR notL notR iffL iffR
  and unsafe_rls = allR exL
  and bound_rls = allL exR

end


section \<open>Properties of Sets of IO Sequences\<close>

text \<open>This theory contains various definitions for properties of sets of IO-traces.\<close>

theory IO_Sequence_Set
imports FSM
begin

fun output_completion :: "('a \<times> 'b) list set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) list set" where
  "output_completion P Out = P \<union> {io@[(fst xy, y)] | io xy y . y \<in> Out \<and> io@[xy] \<in> P \<and> io@[(fst xy, y)] \<notin> P}"

fun output_complete_sequences :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "output_complete_sequences M P = (\<forall> io \<in> P . io = [] \<or> (\<forall> y \<in> (outputs M) . (butlast io)@[(fst (last io), y)] \<in> P))"

fun acyclic_sequences :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "acyclic_sequences M q P = (\<forall> p . (path M q p \<and> p_io p \<in> P) \<longrightarrow> distinct (visited_states q p))"

fun acyclic_sequences' :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "acyclic_sequences' M q P = (\<forall> io \<in> P . \<forall> p \<in> (paths_for_io M q io) .  distinct (visited_states q p))"

lemma acyclic_sequences_alt_def[code] : "acyclic_sequences M P = acyclic_sequences' M P"
  unfolding acyclic_sequences'.simps acyclic_sequences.simps paths_for_io_def
  by blast

fun single_input_sequences :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "single_input_sequences M P = (\<forall> xys1 xys2 xy1 xy2 . (xys1@[xy1] \<in> P \<and> xys2@[xy2] \<in> P \<and> io_targets M xys1 (initial M) = io_targets M xys2 (initial M)) \<longrightarrow> fst xy1 = fst xy2)"

fun single_input_sequences' :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "single_input_sequences' M P = (\<forall> io1 \<in> P . \<forall> io2 \<in> P . io1 = [] \<or> io2 = [] \<or> ((io_targets M (butlast io1) (initial M) = io_targets M (butlast io2) (initial M)) \<longrightarrow> fst (last io1) = fst (last io2)))"

lemma single_input_sequences_alt_def[code] : "single_input_sequences M P = single_input_sequences' M P"
  unfolding single_input_sequences.simps single_input_sequences'.simps
  by (metis append_butlast_last_id append_is_Nil_conv butlast_snoc last_snoc not_Cons_self)

fun output_complete_for_FSM_sequences_from_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "output_complete_for_FSM_sequences_from_state M q P = (\<forall> io xy t . io@[xy] \<in> P \<and> t \<in> transitions M \<and> t_source t \<in> io_targets M io q \<and> t_input t = fst xy \<longrightarrow> io@[(fst xy, t_output t)] \<in> P)"

lemma output_complete_for_FSM_sequences_from_state_alt_def :
  shows "output_complete_for_FSM_sequences_from_state M q P = (\<forall> xys xy y . (xys@[xy] \<in> P \<and> (\<exists> q' \<in> (io_targets M xys q) . [(fst xy,y)] \<in> LS M q')) \<longrightarrow> xys@[(fst xy,y)] \<in> P)"
proof -
  have "\<And> xys xy y q' . q' \<in> (io_targets M xys q) \<Longrightarrow> [(fst xy,y)] \<in> LS M q' \<Longrightarrow> \<exists> t . t \<in> transitions M \<and> t_source t \<in> io_targets M xys q \<and> t_input t = fst xy \<and> t_output t = y"
    unfolding io_targets.simps LS.simps
    using path_append path_append_transition_elim(2) by fastforce

  moreover have "\<And> xys xy y t . t \<in> transitions M \<Longrightarrow> t_source t \<in> io_targets M xys q \<Longrightarrow> t_input t = fst xy \<Longrightarrow> t_output t = y \<Longrightarrow> \<exists> q' \<in> (io_targets M xys q) . [(fst xy,y)] \<in> LS M q'"
    unfolding io_targets.simps LS.simps
  proof -
    fix xys :: "('b \<times> 'c) list" and xy :: "'b \<times> 'd" and y :: 'c and t :: "'a \<times> 'b \<times> 'c \<times> 'a"
    assume a1: "t_input t = fst xy"
    assume a2: "t_output t = y"
    assume a3: "t_source t \<in> {target q p |p. path M q p \<and> p_io p = xys}"
    assume a4: "t \<in> FSM.transitions M"
    have "\<forall>p f. [f (p::'a \<times> 'b \<times> 'c \<times> 'a)::'b \<times> 'c] = map f [p]"
      by simp
    then have "\<exists>a. (\<exists>ps. [(t_input t, t_output t)] = p_io ps \<and> path M a ps) \<and> a \<in> {target q ps |ps. path M q ps \<and> p_io ps = xys}"
      using a4 a3 by (meson single_transition_path)
    then have "\<exists>a. [(t_input t, t_output t)] \<in> {p_io ps |ps. path M a ps} \<and> a \<in> {target q ps |ps. path M q ps \<and> p_io ps = xys}"
      by auto
    then show "\<exists>a\<in>{target q ps |ps. path M q ps \<and> p_io ps = xys}. [(fst xy, y)] \<in> {p_io ps |ps. path M a ps}"
      using a2 a1 by (metis (no_types, lifting))
  qed

  ultimately show ?thesis
    unfolding output_complete_for_FSM_sequences_from_state.simps by blast
qed

fun output_complete_for_FSM_sequences_from_state' :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "output_complete_for_FSM_sequences_from_state' M q P = (\<forall> io\<in>P . \<forall> t \<in> transitions M . io = [] \<or> (t_source t \<in> io_targets M (butlast io) q \<and> t_input t = fst (last io) \<longrightarrow> (butlast io)@[(fst (last io), t_output t)] \<in> P))"

lemma output_complete_for_FSM_sequences_alt_def'[code] : "output_complete_for_FSM_sequences_from_state M q P = output_complete_for_FSM_sequences_from_state' M q P"
  unfolding output_complete_for_FSM_sequences_from_state.simps output_complete_for_FSM_sequences_from_state'.simps
  by (metis last_snoc snoc_eq_iff_butlast)

fun deadlock_states_sequences :: "('a,'b,'c) fsm \<Rightarrow> 'a set \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "deadlock_states_sequences M Q P = (\<forall> xys \<in> P .
                                        ((io_targets M xys (initial M) \<subseteq> Q
                                          \<and> \<not> (\<exists> xys' \<in> P . length xys < length xys' \<and> take (length xys) xys' = xys)))
                                      \<or> (\<not> io_targets M xys (initial M) \<inter> Q = {}
                                          \<and> (\<exists> xys' \<in> P . length xys < length xys' \<and> take (length xys) xys' = xys)))"

fun reachable_states_sequences :: "('a,'b,'c) fsm \<Rightarrow> 'a set \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
  "reachable_states_sequences M Q P = (\<forall> q \<in> Q . \<exists> xys \<in> P . q \<in> io_targets M xys (initial M))"

fun prefix_closed_sequences :: "('b \<times> 'c) list set \<Rightarrow> bool" where
  "prefix_closed_sequences P = (\<forall> xys1 xys2 . xys1@xys2 \<in> P \<longrightarrow> xys1 \<in> P)"

fun prefix_closed_sequences' :: "('b \<times> 'c) list set \<Rightarrow> bool" where
  "prefix_closed_sequences' P = (\<forall> io \<in> P . io = [] \<or> (butlast io) \<in> P)"

lemma prefix_closed_sequences_alt_def[code] : "prefix_closed_sequences P = prefix_closed_sequences' P"
proof
  show "prefix_closed_sequences P \<Longrightarrow> prefix_closed_sequences' P"
    unfolding prefix_closed_sequences.simps prefix_closed_sequences'.simps
    by (metis append_butlast_last_id)

  have "\<And>xys1 xys2. \<forall>io\<in>P. io = [] \<or> butlast io \<in> P \<Longrightarrow> xys1 @ xys2 \<in> P \<Longrightarrow> xys1 \<in> P"
  proof -
    fix xys1 xys2 assume "\<forall>io\<in>P. io = [] \<or> butlast io \<in> P" and "xys1 @ xys2 \<in> P"
    then show "xys1 \<in> P"
    proof (induction xys2 rule: rev_induct)
      case Nil
      then show ?case by auto
    next
      case (snoc a xys2)
      then show ?case
        by (metis append.assoc snoc_eq_iff_butlast)
    qed
  qed

  then show "prefix_closed_sequences' P \<Longrightarrow> prefix_closed_sequences P"
    unfolding prefix_closed_sequences.simps prefix_closed_sequences'.simps by blast
qed

subsection \<open>Completions\<close>

definition prefix_completion :: "'a list set \<Rightarrow> 'a list set" where
  "prefix_completion P = {xs . \<exists> ys . xs@ys \<in> P}"

lemma prefix_completion_closed :
  "prefix_closed_sequences (prefix_completion P)"
  unfolding prefix_closed_sequences.simps prefix_completion_def
  by auto

lemma prefix_completion_source_subset :
  "P \<subseteq> prefix_completion P"
  unfolding prefix_completion_def
  by (metis (no_types, lifting) append_Nil2 mem_Collect_eq subsetI)

definition output_completion_for_FSM :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> ('b \<times> 'c) list set" where
  "output_completion_for_FSM M P = P \<union> { io@[(x,y')] | io x y' . (y' \<in> (outputs M)) \<and> (\<exists> y . io@[(x,y)] \<in> P)}"

lemma output_completion_for_FSM_complete :
  shows "output_complete_sequences M (output_completion_for_FSM M P)"
  unfolding output_completion_for_FSM_def output_complete_sequences.simps
proof
  fix io assume *: "io \<in> P \<union> {io @ [(x, y')] |io x y'. y' \<in> (outputs M) \<and> (\<exists>y. io @ [(x, y)] \<in> P)}"
  show   "io = [] \<or>
          (\<forall>y\<in>(outputs M).
              butlast io @ [(fst (last io), y)]
              \<in> P \<union> {io @ [(x, y')] |io x y'. y' \<in> (outputs M) \<and> (\<exists>y. io @ [(x, y)] \<in> P)})"
  proof (cases io rule: rev_cases)
    case Nil
    then show ?thesis by blast
  next
    case (snoc ys y)
    then show ?thesis proof (cases "io \<in> P")
      case True
      then have "butlast io @ [(fst (last io), (snd (last io)))] \<in> P" using snoc by auto
      then show ?thesis using snoc by blast
    next
      case False
      then show ?thesis
        using "*" by auto
    qed
  qed
qed

lemma output_completion_for_FSM_length :
  assumes "\<forall> io \<in> P . length io \<le> k"
  shows   "\<forall> io \<in> output_completion_for_FSM M P. length io \<le> k"
  using assms unfolding output_completion_for_FSM_def
  by auto

lemma output_completion_for_FSM_code[code] :
  "output_completion_for_FSM M P = P \<union> (\<Union>(image (\<lambda>(y,io) . if length io = 0 then {} else {((butlast io)@[(fst (last io),y)])})  ((outputs M) \<times> P)))"
proof -
  let ?OC = "{io @ [(x, y')] |io x y'. y' \<in> FSM.outputs M \<and> (\<exists>y. io @ [(x, y)] \<in> P)}"
  let ?OC' = "(\<Union>(y, io)\<in>FSM.outputs M \<times> P. if length io = 0 then {} else {butlast io @ [(fst (last io), y)]})"

  have "?OC = ?OC'"
  proof -
    have "?OC \<subseteq> ?OC'"
    proof
      fix io' assume "io' \<in> ?OC"
      then obtain io x y y' where "io' = io @ [(x, y')]"
                            and   "y' \<in> FSM.outputs M"
                            and   "io @ [(x, y)] \<in> P"
        by blast
      then have "(y',io @ [(x, y)]) \<in> FSM.outputs M \<times> P" by blast
      moreover have "length (io @ [(x, y)]) \<noteq> 0" by auto
      ultimately show "io' \<in> ?OC'"
        unfolding \<open>io' = io @ [(x, y')]\<close> by force
    qed
    moreover have "?OC' \<subseteq> ?OC"
    proof
      fix io' assume "io' \<in> ?OC'"
      then obtain y io where "y \<in> outputs M" and "io \<in> P"
                       and "io' \<in> (if length io = 0 then {} else {butlast io @ [(fst (last io), y)]})"
        by auto
      then have "io' = butlast io @ [(fst (last io), y)]"
        by (meson empty_iff singletonD)
      have "io \<noteq> []"
        using \<open>io' \<in> (if length io = 0 then {} else {butlast io @ [(fst (last io), y)]})\<close>
        by auto

      then have "butlast io @ [(fst (last io), snd (last io))] \<in> P"
        by (simp add: \<open>io \<in> P\<close>)

      then show "io' \<in> ?OC"
        using \<open>y \<in> outputs M\<close> \<open>io \<in> P\<close>
        unfolding \<open>io' = butlast io @ [(fst (last io), y)]\<close> by blast
    qed
    ultimately show ?thesis by blast
  qed

  then show ?thesis
    unfolding output_completion_for_FSM_def
    by simp
qed

end


(*
    File:        SndLAlpha.thy
    Time-stamp:  <2016-01-06T16:55:28Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory SndLAlpha imports LAlpha begin

consts
  LAlpha2 :: i

inductive
  domains "LAlpha2" <= "LTerm * LTerm"
  intros
    LVarI: "x: LVariable ==> <LVar(x), LVar(x)>: LAlpha2"
    LAppI: "[| <A, C>: LAlpha2; <B, D>: LAlpha2 |]
                ==> <LApp(A, B), LApp(C, D)>: LAlpha2"
    LLamI: "[| x: LVariable; y: LVariable; <M, N>: LAlpha2;
               y ~: LFV(N) - {x}; LFreeForIn(LVar(y), x, N) |]
             ==> <LLam(x, M), LLam(y, Lsubst(N, x, LVar(y)))>: LAlpha2"

    transI: "[| <A, B>: LAlpha2; <B, C>: LAlpha2 |] ==> <A, C>: LAlpha2"

  type_intros LTerm.intros SigmaI Lsubst_type
  type_elims SigmaE2

lemma LAlpha2_induct:
  assumes major: "<M, N>: LAlpha2"
  and
   "!!x. x : LVariable ==> P(LVar(x), LVar(x))"
  and
   "!!A B C D. [| <A, C> : LAlpha2; P(A, C); <B, D> : LAlpha2; P(B, D) |]
       ==> P(LApp(A, B), LApp(C, D))"
  and
   "!!M N x y.
       [| x : LVariable; y : LVariable; <M, N> : LAlpha2; P(M, N);
          y ~: LFV(N) - {x}; LFreeForIn(LVar(y), x, N) |] ==>
       P(LLam(x, M), LLam(y, Lsubst(N, x, LVar(y))))"
  and
   "!!A B C.
       [| <A, B> : LAlpha2; P(A, B); <B, C> : LAlpha2; P(B, C) |] ==>
          P(A, C)"
  shows "P(M, N)"
apply (rule_tac P="%x. P(x, N)" and b1="N" in fst_conv [THEN subst])
apply (rule_tac P="%x. P(fst(<M,N>),x)" and a1="M" in snd_conv [THEN subst])
apply (rule major [THEN LAlpha2.induct])
apply simp_all
apply (blast intro: assms)+
done

lemma LAlpha2_refl:
  "M: LTerm ==> <M, M>: LAlpha2"
apply (erule LTerm.induct)
apply (erule LAlpha2.LVarI)
apply (erule_tac [2] LAlpha2.LAppI)
prefer 2 apply assumption
apply (rule_tac P="%z. <LLam(x, M), z>: LAlpha2" in ssubst)
apply (rule_tac [2] y="x" in LAlpha2.LLamI)
apply (erule_tac [2] asm_rl)+
prefer 2 apply simp
apply (erule_tac [2] LFreeForIn_left_LVarI)
prefer 2 apply assumption
apply (simp only: Lsubst_self)
done

lemma LAlpha2_sym:
  "<M, N>: LAlpha2 ==> <N, M>: LAlpha2"
apply (erule LAlpha2_induct)
apply (erule LAlpha2.LVarI)
apply (erule LAlpha2.LAppI)
apply assumption
apply (erule_tac [2] LAlpha2.transI)
prefer 2 apply assumption
apply (frule LAlpha2.dom_subset [THEN subsetD])
apply (erule SigmaE2)
apply simp
apply (erule disjE)
prefer 2
apply hypsubst
apply (simp add: Lsubst_self)
apply (rule_tac P="%z. <LLam(x, N), z>: LAlpha2" in subst)
apply (rule_tac [2] N="M" and y="x" in LAlpha2.LLamI)
apply (simp add: Lsubst_self)
prefer 4 apply blast
apply (assumption | rule LFreeForIn_left_LVarI)+
apply (rule_tac B="LLam(x, Lsubst(Lsubst(N,x, LVar(y)), y, LVar(x)))"
        in LAlpha2.transI)
prefer 2
apply (simp add: Lsubst_self Lsubst_lemma2)
apply (rule_tac P="%z. <LLam(x, N), z>: LAlpha2" in subst)
apply (rule_tac [2] N="M" and y="x" in LAlpha2.LLamI)
apply (simp add: Lsubst_self)
prefer 4 apply blast
apply (assumption | rule LFreeForIn_left_LVarI)+
apply (rule LAlpha2.LLamI)
apply (assumption | rule LAlpha2_refl Lsubst_type LTerm.intros)+
prefer 2
apply (assumption | rule LFreeForIn_left_LVarI LFreeForIn_name_change)+
apply (safe elim!: LFV_E LFreeIn_LsubstE LTag.free_elims
         LFreeIn_LTermEs)
done

lemma LAlpha2_LFV_lemma:
  assumes major: "<M, N>: LAlpha2"
  and prem: "x: LFV(M)"
  shows "x: LFV(N)"
apply (rule prem [THEN rev_mp])
apply (rule major [THEN LAlpha2_induct])
apply (subgoal_tac [2] "A: LTerm" "B: LTerm" "C: LTerm" "D: LTerm")
apply (erule_tac [3] LAlpha2.dom_subset [THEN subsetD, THEN SigmaD1]
         LAlpha2.dom_subset [THEN subsetD, THEN SigmaD2])+
apply simp_all
apply blast
apply (frule LAlpha2.dom_subset [THEN subsetD])
apply safe
prefer 2 apply (simp add: Lsubst_self)
apply (erule LFV_E)+
apply (rule LFV_I)
apply (erule LFreeIn_LsubstI1)
apply assumption
apply blast
done

lemma LAlpha2_LAlpha:
  "<M, N>: LAlpha2 ==> LAlpha(M, N)"
apply (erule LAlpha2_induct)
apply (rule_tac [4] LAlpha_trans)
apply (erule_tac [4] asm_rl)+
apply (assumption | rule LAlpha_LVarI LAlpha_LAppI)+
apply (case_tac "y = x")
prefer 2
apply simp
apply safe
apply (erule_tac [3] swap, rule_tac [3] LAlpha_LLamI1)
apply (erule_tac [2] swap, rule_tac [2] LAlpha_LLamI1)
prefer 2 apply (simp add: Lsubst_self LFreeForInD3)
prefer 3 apply (simp add: Lsubst_self LFreeForInD3)
apply (erule_tac [2] asm_rl)+
apply (rule LAlpha_LLamI2)
apply (simp add: Lsubst_lemma2 Lsubst_self LFreeForInD3)
apply (rule LFreeForIn_name_change)
apply (rule_tac [4] LFV_Lsubst_notI)
apply (assumption | rule LFreeForIn_left_LVarI
       | erule LFreeForInD3)+
done

lemmas LTerm_def_Terms_depth_induct = def_Terms_depth_induct [OF
  LTerm_Occ_cons_cond LTerm_Occ_ind_cond LOccinv_def]

lemma LAlpha_LAlpha2:
  assumes infv: "Infinite(LVariable)"
  and prem: "LAlpha(M, N)"
  shows "<M, N>: LAlpha2"
apply (insert prem [THEN LAlphaD1, THEN LSkeltonEqD1])
apply (rule prem [THEN rev_mp])
apply (rule_tac x="N" in spec)
apply (erule_tac M="M" in LTerm_def_Terms_depth_induct)
apply (erule_tac LTerm.cases)
apply (safe elim!: LAlpha_LTermEs)
apply (frule_tac [3] depth_ind_LApp1)
apply (frule_tac [5] depth_ind_LApp2)
apply (rule_tac [7] LAlpha2.LAppI)
apply (erule_tac [8] bspec [THEN mp, THEN spec, THEN mp],
       erule_tac [8] asm_rl)
apply (erule_tac [7] bspec [THEN mp, THEN spec, THEN mp],
       erule_tac [7] asm_rl)
apply (erule_tac [3] asm_rl)+
apply (assumption | rule LAlpha2.LVarI)+
apply (erule infv [THEN LAlpha_LLamE])
prefer 2 apply hypsubst
prefer 2 apply hypsubst

apply (frule_tac LAlphaD1 [THEN LSkeltonEqD2])
apply (rule_tac P="%z. <LLam(x, Ma), z>: LAlpha2" in ssubst)
apply (rule_tac [2] y="x" and N="N'" in LAlpha2.LLamI)
apply (simp add: Lsubst_self)
prefer 4 apply simp
apply (frule_tac [3] depth_ind_LLam)
apply (erule_tac [5] bspec [THEN mp, THEN spec, THEN mp],
       erule_tac [5] asm_rl)
apply (assumption | rule LFreeForIn_left_LVarI)+
apply (subgoal_tac "M': LTerm" "N': LTerm" "y: LVariable"
                   "LOcc(Ma) <= domain(Z) * LTag"
                   "LOcc(M') <= domain(Z) * LTag"
                   "LOcc(N') <= domain(Z) * LTag")
apply (erule_tac [7] LAlphaD1 [THEN LSkeltonEqD2])
apply (erule_tac [6] LAlphaD1 [THEN LSkeltonEqD1])
apply (erule_tac [5] LFreeForInE)
apply (erule_tac [5] LTerm_typeEs)
apply (erule_tac [4] depth_ind_LLam)
apply (rule_tac [3] depth_ind_LSkeltonEq)
apply (erule_tac [3] LAlphaD1)
apply (rule_tac [2] depth_ind_LSkeltonEq)
apply (rule_tac [2] LSkeltonEq_trans)
apply (erule_tac [3] LAlphaD1 [THEN LSkeltonEq_sym])
apply (rule_tac [2] LSkeltonEq_Lsubst_LVar)
apply (erule_tac [2] asm_rl)+
apply (rule_tac P="%z. <LLam(x, Ma), z>: LAlpha2" in ssubst)
apply (rule_tac [2] LAlpha2.transI)
apply (rule_tac [3] y="y" and N="N'" in LAlpha2.LLamI)
apply (rule_tac [2] y="y" and N="M'" in LAlpha2.LLamI)
apply (rule_tac [9] LAlpha2_sym)
prefer 2
prefer 3
prefer 6
prefer 7
prefer 8
apply assumption+
apply (erule_tac [4] bspec [THEN mp, THEN spec, THEN mp],
       erule_tac [4] asm_rl)
apply (erule_tac [2] bspec [THEN mp, THEN spec, THEN mp],
       erule_tac [2] asm_rl)
apply (simp only: Lsubst_self)
prefer 3 apply blast
prefer 5 apply blast
apply (assumption | rule LFreeForIn_left_LVarI)+
done

lemma LAlpha2_iff_LAlpha:
  assumes prem: "Infinite(LVariable)"
  shows "<M,N>:LAlpha2 <-> LAlpha(M,N)"
apply (rule iffI)
apply (erule LAlpha2_LAlpha)
apply (erule prem [THEN LAlpha_LAlpha2])
done

lemmas LAlpha2_LSkeltonEq = LAlpha2_LAlpha [THEN LAlphaD1, rule_format]

lemma LAlpha2_LVarE_lemma:
  "<M, N>: LAlpha2 ==> M = LVar(x) --> N = LVar(x)"
apply (erule LAlpha2_induct)
apply (safe elim!: LTerm.free_elims)
done

lemma LAlpha2_LVarD:
  "<LVar(x), N>: LAlpha2 ==>  N = LVar(x)"
apply (erule LAlpha2_LVarE_lemma [THEN mp])
apply (rule refl)
done

lemma LAlpha2_LAppE_lemma:
  "<M, N>: LAlpha2 ==>
    (ALL A B. (M = LApp(A, B) -->
        (EX C D. N = LApp(C, D) & <A, C>: LAlpha2 & <B, D>: LAlpha2)))"
apply (erule LAlpha2_induct)
apply (blast elim!: LTerm.free_elims)
apply (blast elim!: LTerm.free_elims)
apply (blast elim!: LTerm.free_elims)
apply (safe elim!: LTerm.free_elims)
apply (drule spec [THEN spec, THEN mp], rule refl)
apply (elim exE conjE)
apply (drule spec [THEN spec, THEN mp], assumption)
apply (safe elim!: LTerm.free_elims)
apply (blast intro: LAlpha2.transI)
done

lemma LAlpha2_LAppE:
  assumes major: "<LApp(A, B), N>: LAlpha2"
  and prem1:
     "!! C D. [| N = LApp(C, D); <A, C>: LAlpha2; <B, D>: LAlpha2 |] ==> R"
  shows "R"
apply (insert major [THEN LAlpha2_LAppE_lemma])
apply (drule spec [THEN spec, THEN mp])
apply (rule refl)
apply (elim exE conjE)
apply (rule prem1)
apply assumption+
done

lemma Lsubst_eq_LVar_lemma:
  assumes major: "Lsubst(N, x, LVar(y)) = LVar(z)"
  and sub: "N: LTerm"
  and prem1: "y: LVariable"
  and prem2: "z: LVariable"
  shows "N = LVar(x) & y = z  | N = LVar(x) & y = z
                         | N = LVar(z) & x ~= z"
apply (insert assms)
apply (rule sub [THEN LTerm.cases])
apply (case_tac [2] "x = xa")
apply (case_tac [1] "x = xa")
apply simp_all
done

lemma Lsubst_eq_LLam_lemma:
  assumes major: "Lsubst(N, x, LVar(y)) = LLam(x, M)"
  and sub: "N: LTerm"
  and prem1: "M: LTerm"
  and prem2: "y: LVariable"
  shows "N = LLam(x, M)"
apply (insert assms)
apply (rule sub [THEN LTerm.cases])
apply (case_tac [2] "x = xa")
apply (case_tac "x = xa")
apply simp_all
done

lemma LAlpha2_LLam_LVar_lemma1:
  "[| <M, N>: LAlpha2; LVariable = {x, y}; y ~= x |]
       ==> M = LLam(y, LVar(x)) --> N = LLam(y, LVar(x))"
apply (erule LAlpha2_induct)
prefer 3 apply simp
prefer 3
prefer 3
prefer 4 apply (blast elim!: LTerm.free_elims)
prefer 1 apply (blast elim!: LTerm.free_elims)
prefer 1 apply (blast elim!: LTerm.free_elims)
apply (frule LAlpha2.dom_subset [THEN subsetD])
apply (erule SigmaE2)
apply (erule disjE)
prefer 2 apply hypsubst
apply (rule impI)
apply (erule conjE)
apply hypsubst
apply (rule conjI)
apply (rule refl)
apply (drule LAlpha2_LVarD)
apply (simp only: Lsubst_self)

apply (rule impI)
apply (erule conjE)
apply hypsubst
apply (drule LAlpha2_LVarD)
apply hypsubst
apply (erule LFreeForIn_LVarE)
apply simp
apply (subgoal_tac "ya : {x, y}")
apply blast
apply (erule subst)
apply assumption
done

lemma LAlpha2_LLam_LLam_LVar_lemma1:
  assumes major: "<M, N>: LAlpha2"
  and prem1: "LVariable = {x, y}"
  and prem2: "y ~= x"
  shows "M = LLam(x, LLam(y, LVar(x)))
          --> N = LLam(x, LLam(y, LVar(x)))"
apply (insert prem1 prem2)
apply (rule major [THEN LAlpha2_induct])
prefer 3 apply simp
defer 1
apply (blast elim!: LTerm.free_elims)
apply (blast elim!: LTerm.free_elims)
apply (blast elim!: LTerm.free_elims)
apply (frule LAlpha2.dom_subset [THEN subsetD])
apply (erule SigmaE2)
apply (erule disjE)
prefer 2 apply hypsubst
apply (rule impI)
apply (erule conjE)
apply hypsubst
prefer 2
apply (rule impI)
apply (erule conjE)
apply hypsubst
apply (frule LAlpha2_LLam_LVar_lemma1 [THEN mp])
apply (assumption | rule refl)+
apply hypsubst
apply (erule LFreeForIn_LLamE)
apply blast
apply (erule LFreeForIn_LVarE)
apply simp
apply (subgoal_tac "ya: {x, y}")
apply blast
apply (erule subst)
apply assumption
apply simp
apply (simp add: Lsubst_self)
apply (frule LAlpha2_LLam_LVar_lemma1 [THEN mp])
apply (assumption | rule refl)+
done

lemma LAlpha2_LLam_LLam_LVar_lemma:
  "[| LVariable = {x, y}; y ~= x |] ==>
      <LLam(x, LLam(y, LVar(x))), LLam(y, LLam(x, LVar(y)))> ~: LAlpha2"
apply (rule notI)
apply (drule LAlpha2_LLam_LLam_LVar_lemma1)
apply (drule_tac [3] mp)
apply (assumption | rule refl)+
apply (safe elim!: LTerm.free_elims)
done

lemma LAlpha_LLam_LLam_LVar_lemma:
  "[| LVariable = {x, y}; y ~= x |] ==>
      LAlpha(LLam(x, LLam(y, LVar(x))), LLam(y, LLam(x, LVar(y))))"
apply (subgoal_tac "x: LVariable" "y: LVariable")
defer 1
apply (erule ssubst)
apply blast
apply (erule ssubst)
apply blast
apply (rule LAlphaI)
apply (assumption | rule LSkeltonEq_LTermIs)+
apply (safe elim!: LFreeIn_LTermEs LBoundBy_LTermEs LTag.free_elims)
apply (assumption | rule exI LBoundBy_LTermIs LFreeIn_LTermIs)+
done

end


(*  Title:      HOL/Auth/Event.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1996  University of Cambridge

Datatype of events; function "spies"; freshness

"bad" agents have been broken by the Spy; their private keys and internal
    stores are visible to him
*)

section\<open>Theory of Events for Security Protocols\<close>

theory Event imports Message begin

consts  (*Initial states of agents -- parameter of the construction*)
  initState :: "agent \<Rightarrow> msg set"

datatype
  event = Says  agent agent msg
        | Gets  agent       msg
        | Notes agent       msg

consts
  bad    :: "agent set"                         \<comment> \<open>compromised agents\<close>

text\<open>Spy has access to his own key for spoof messages, but Server is secure\<close>
specification (bad)
  Spy_in_bad     [iff]: "Spy \<in> bad"
  Server_not_bad [iff]: "Server \<notin> bad"
    by (rule exI [of _ "{Spy}"], simp)

primrec knows :: "agent \<Rightarrow> event list \<Rightarrow> msg set"
where
  knows_Nil:   "knows A [] = initState A"
| knows_Cons:
    "knows A (ev # evs) =
       (if A = Spy then
        (case ev of
           Says A' B X \<Rightarrow> insert X (knows Spy evs)
         | Gets A' X \<Rightarrow> knows Spy evs
         | Notes A' X  \<Rightarrow>
             if A' \<in> bad then insert X (knows Spy evs) else knows Spy evs)
        else
        (case ev of
           Says A' B X \<Rightarrow>
             if A'=A then insert X (knows A evs) else knows A evs
         | Gets A' X    \<Rightarrow>
             if A'=A then insert X (knows A evs) else knows A evs
         | Notes A' X    \<Rightarrow>
             if A'=A then insert X (knows A evs) else knows A evs))"
(*
  Case A=Spy on the Gets event
  enforces the fact that if a message is received then it must have been sent,
  therefore the oops case must use Notes
*)

text\<open>The constant "spies" is retained for compatibility's sake\<close>

abbreviation (input)
  spies  :: "event list \<Rightarrow> msg set" where
  "spies == knows Spy"

(*Set of items that might be visible to somebody:
    complement of the set of fresh items*)

primrec used :: "event list \<Rightarrow> msg set"
where
  used_Nil:   "used []         = (UN B. parts (initState B))"
| used_Cons:  "used (ev # evs) =
                     (case ev of
                        Says A B X \<Rightarrow> parts {X} \<union> used evs
                      | Gets A X   \<Rightarrow> used evs
                      | Notes A X  \<Rightarrow> parts {X} \<union> used evs)"
    \<comment> \<open>The case for \<^term>\<open>Gets\<close> seems anomalous, but \<^term>\<open>Gets\<close> always
        follows \<^term>\<open>Says\<close> in real protocols.  Seems difficult to change.
        See \<open>Gets_correct\<close> in theory \<open>Guard/Extensions.thy\<close>.\<close>

lemma Notes_imp_used [rule_format]: "Notes A X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

lemma Says_imp_used [rule_format]: "Says A B X \<in> set evs \<longrightarrow> X \<in> used evs"
apply (induct_tac evs)
apply (auto split: event.split)
done

subsection\<open>Function \<^term>\<open>knows\<close>\<close>

(*Simplifying
 parts(insert X (knows Spy evs)) = parts{X} \<union> parts(knows Spy evs).
  This version won't loop with the simplifier.*)
lemmas parts_insert_knows_A = parts_insert [of _ "knows A evs"] for A evs

text\<open>Letting the Spy see "bad" agents' notes avoids redundant case-splits
      on whether \<^term>\<open>A=Spy\<close> and whether \<^term>\<open>A\<in>bad\<close>\<close>
lemma knows_Spy_Notes [simp]:
     "knows Spy (Notes A X # evs) =
          (if A\<in>bad then insert X (knows Spy evs) else knows Spy evs)"
by simp

lemma knows_Spy_Gets [simp]: "knows Spy (Gets A X # evs) = knows Spy evs"
by simp

lemma knows_Spy_subset_knows_Spy_Says:
     "knows Spy evs \<subseteq> knows Spy (Says A B X # evs)"
by (simp add: subset_insertI)

lemma knows_Spy_subset_knows_Spy_Notes:
     "knows Spy evs \<subseteq> knows Spy (Notes A X # evs)"
by force

lemma knows_Spy_subset_knows_Spy_Gets:
     "knows Spy evs \<subseteq> knows Spy (Gets A X # evs)"
by (simp add: subset_insertI)

text\<open>Spy sees what is sent on the traffic\<close>
lemma Says_imp_knows_Spy [rule_format]:
     "Says A B X \<in> set evs \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

lemma Notes_imp_knows_Spy [rule_format]:
     "Notes A X \<in> set evs \<longrightarrow> A \<in> bad \<longrightarrow> X \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

text\<open>Elimination rules: derive contradictions from old Says events containing
  items known to be fresh\<close>
lemmas Says_imp_parts_knows_Spy =
       Says_imp_knows_Spy [THEN parts.Inj, elim_format]

lemmas knows_Spy_partsEs =
     Says_imp_parts_knows_Spy parts.Body [elim_format]

lemmas Says_imp_analz_Spy = Says_imp_knows_Spy [THEN analz.Inj]

text\<open>Compatibility for the old "spies" function\<close>
lemmas spies_partsEs = knows_Spy_partsEs
lemmas Says_imp_spies = Says_imp_knows_Spy
lemmas parts_insert_spies = parts_insert_knows_A [of _ Spy]

subsection\<open>Knowledge of Agents\<close>

lemma knows_subset_knows_Says: "knows A evs \<subseteq> knows A (Says A' B X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Notes: "knows A evs \<subseteq> knows A (Notes A' X # evs)"
by (simp add: subset_insertI)

lemma knows_subset_knows_Gets: "knows A evs \<subseteq> knows A (Gets A' X # evs)"
by (simp add: subset_insertI)

text\<open>Agents know what they say\<close>
lemma Says_imp_knows [rule_format]: "Says A B X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they note\<close>
lemma Notes_imp_knows [rule_format]: "Notes A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>Agents know what they receive\<close>
lemma Gets_imp_knows_agents [rule_format]:
     "A \<noteq> Spy \<longrightarrow> Gets A X \<in> set evs \<longrightarrow> X \<in> knows A evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
done

text\<open>What agents DIFFERENT FROM Spy know
  was either said, or noted, or got, or known initially\<close>
lemma knows_imp_Says_Gets_Notes_initState [rule_format]:
     "[| X \<in> knows A evs; A \<noteq> Spy |] ==> \<exists> B.
  Says A B X \<in> set evs \<or> Gets A X \<in> set evs \<or> Notes A X \<in> set evs \<or> X \<in> initState A"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

text\<open>What the Spy knows -- for the time being --
  was either said or noted, or known initially\<close>
lemma knows_Spy_imp_Says_Notes_initState [rule_format]:
     "X \<in> knows Spy evs \<Longrightarrow> \<exists>A B.
  Says A B X \<in> set evs \<or> Notes A X \<in> set evs \<or> X \<in> initState Spy"
apply (erule rev_mp)
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) split: event.split)
apply blast
done

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) \<subseteq> used evs"
apply (induct_tac "evs", force)
apply (simp add: parts_insert_knows_A knows_Cons add: event.split, blast)
done

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) \<Longrightarrow> X \<in> used evs"
apply (induct_tac "evs")
apply (simp_all add: parts_insert_knows_A split: event.split, blast)
done

lemma used_Says [simp]: "used (Says A B X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Notes [simp]: "used (Notes A X # evs) = parts{X} \<union> used evs"
by simp

lemma used_Gets [simp]: "used (Gets A X # evs) = used evs"
by simp

lemma used_nil_subset: "used [] \<subseteq> used evs"
apply simp
apply (blast intro: initState_into_used)
done

text\<open>NOTE REMOVAL--laws above are cleaner, as they don't involve "case"\<close>
declare knows_Cons [simp del]
        used_Nil [simp del] used_Cons [simp del]

text\<open>For proving theorems of the form \<^term>\<open>X \<notin> analz (knows Spy evs) \<longrightarrow> P\<close>
  New events added by induction to "evs" are discarded.  Provided
  this information isn't needed, the proof will be much shorter, since
  it will omit complicated reasoning about \<^term>\<open>analz\<close>.\<close>

lemmas analz_mono_contra =
       knows_Spy_subset_knows_Spy_Says [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Notes [THEN analz_mono, THEN contra_subsetD]
       knows_Spy_subset_knows_Spy_Gets [THEN analz_mono, THEN contra_subsetD]

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (cases e, auto simp: knows_Cons)

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
apply (induct_tac evs, simp)
apply (blast intro: knows_subset_knows_Cons [THEN subsetD])
done

text\<open>For proving \<open>new_keys_not_used\<close>\<close>
lemma keysFor_parts_insert:
     "[| K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) |]
      ==> K \<in> keysFor (parts (G \<union> H)) | Key (invKey K) \<in> parts H"
by (force
    dest!: parts_insert_subset_Un [THEN keysFor_mono, THEN [2] rev_subsetD]
           analz_subset_parts [THEN keysFor_mono, THEN [2] rev_subsetD]
    intro: analz_subset_parts [THEN subsetD] parts_mono [THEN [2] rev_subsetD])

lemmas analz_impI = impI [where P = "Y \<notin> analz (knows Spy evs)"] for Y evs

ML
\<open>
fun analz_mono_contra_tac ctxt =
  resolve_tac ctxt @{thms analz_impI} THEN'
  REPEAT1 o (dresolve_tac ctxt @{thms analz_mono_contra})
  THEN' (mp_tac ctxt)
\<close>

method_setup analz_mono_contra = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT_FIRST (analz_mono_contra_tac ctxt)))\<close>
    "for proving theorems of the form X \<notin> analz (knows Spy evs) \<longrightarrow> P"

subsubsection\<open>Useful for case analysis on whether a hash is a spoof or not\<close>

lemmas syan_impI = impI [where P = "Y \<notin> synth (analz (knows Spy evs))"] for Y evs

ML
\<open>
fun synth_analz_mono_contra_tac ctxt =
  resolve_tac ctxt @{thms syan_impI} THEN'
  REPEAT1 o
    (dresolve_tac ctxt
     [@{thm knows_Spy_subset_knows_Spy_Says} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_Spy_subset_knows_Spy_Notes} RS @{thm synth_analz_mono} RS @{thm contra_subsetD},
      @{thm knows_Spy_subset_knows_Spy_Gets} RS @{thm synth_analz_mono} RS @{thm contra_subsetD}])
  THEN'
  mp_tac ctxt
\<close>

method_setup synth_analz_mono_contra = \<open>
    Scan.succeed (fn ctxt => SIMPLE_METHOD (REPEAT_FIRST (synth_analz_mono_contra_tac ctxt)))\<close>
    "for proving theorems of the form X \<notin> synth (analz (knows Spy evs)) \<longrightarrow> P"

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2007-2023  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Folding in ZF\<close>

theory Fold_ZF imports InductiveSeq_ZF

begin

text\<open>Suppose we have a binary operation $P: X\times X \rightarrow X$ written
  multiplicatively as $P\langle x, y \rangle= x\cdot y$.
  In informal mathematics we can take a sequence $\{ x_k \}_{k\in 0.. n}$
  of elements of $X$ and consider the product
  $x_0\cdot x_1 \cdot .. \cdot x_n$. To do the same thing in formalized
  mathematics we have to define precisely what is meant by that
  "$\cdot .. \cdot$". The definitition we want to use is based on the
  notion of sequence defined by induction discussed in
  \<open>InductiveSeq_ZF\<close>. We don't really want to derive the terminology
  for this from the word "product" as that would tie it conceptually
  to the multiplicative notation. This would be awkward when we want to reuse
  the same notions to talk about sums like $x_0 + x_1 + .. + x_n$.

  In functional programming there is something called "fold".
  Namely for a function $f$, initial point $a$ and list
  $\left[ b, c, d\right]$
  the expression \<open>fold(f, a, [b,c,d])\<close> is defined to be
  \<open>f(f(f(a,b),c),d)\<close> (in Haskell something like this is called
  \<open>foldl\<close>). If we write $f$ in multiplicative notation we get
  $a\cdot b \cdot c\cdot d$, so this is exactly what we need.
  The notion of folds in functional programming
  is actually much more general that what we need here
  (not that I know anything about that). In this theory file we just make
  a slight generalization and talk about folding a list with a binary
  operation $f:X\times Y \rightarrow X$ with $X$ not necessarily the same as
  $Y$.\<close>

subsection\<open>Folding in ZF\<close>

text\<open>Suppose we have a binary operation $f : X\times Y \rightarrow X$.
  Then every $y\in Y$ defines a transformation of $X$ defined by
  $T_y(x) = f\langle x,y\rangle$. In IsarMathLib such transformation is called
  as \<open>Fix2ndVar(f,y)\<close>. Using this notion,
  given a function $f: X\times Y\rightarrow X$ and a sequence
  $y = \{y_k\}_{k\in N}$ of elements of $X$
  we can get a sequence of transformations of $X$.
  This is defined in \<open>Seq2TransSeq\<close> below.
  Then we use that sequence of tranformations to define the sequence
  of partial folds (called \<open>FoldSeq\<close>) by means of
  \<open>InductiveSeqVarFN\<close> (defined in \<open>InductiveSeq_ZF\<close> theory)
  which implements the inductive sequence determined by a starting point
  and a sequence of transformations. Finally, we define the fold of a
  sequence as the last element of the sequence of the partial folds.\<close>

text\<open>Definition that specifies how to convert a sequence $a$
  of elements of $Y$ into a sequence of transformations of $X$, given a binary operation
  $f :X\times Y \rightarrow X$.\<close>

definition
  "Seq2TrSeq(f,a) \<equiv> {\<langle>k,Fix2ndVar(f,a`(k))\<rangle>. k \<in> domain(a)}"

text\<open>Definition of a sequence of partial folds.\<close>

definition
  "FoldSeq(f,x,a) \<equiv>
  InductiveSeqVarFN(x,fstdom(f),Seq2TrSeq(f,a),domain(a))"

text\<open>Definition of a fold.\<close>

definition
  "Fold(f,x,a) \<equiv> Last(FoldSeq(f,x,a))"

text\<open>If $X$ is a set with a binary operation $f:X\times Y \rightarrow X$ then
  \<open>Seq2TransSeqN(f,a)\<close> converts a sequence $a$ of elements of $Y$
  into the sequence of corresponding transformations of $X$.\<close>

lemma seq2trans_seq_props:
  assumes A1: "n \<in> nat" and A2: "f : X\<times>Y \<rightarrow> X" and A3: "a:n\<rightarrow>Y" and
  A4: "T = Seq2TrSeq(f,a)"
  shows
  "T : n \<rightarrow> (X\<rightarrow>X)" and
  "\<forall>k\<in>n. \<forall>x\<in>X. (T`(k))`(x) = f`\<langle>x,a`(k)\<rangle>"
proof -
  from \<open>a:n\<rightarrow>Y\<close> have D: "domain(a) = n" using func1_1_L1 by simp
  with A2 A3 A4 show "T : n \<rightarrow> (X\<rightarrow>X)"
    using apply_funtype fix_2nd_var_fun ZF_fun_from_total Seq2TrSeq_def
    by simp
  with A4 D have I: "\<forall>k \<in> n. T`(k) = Fix2ndVar(f,a`(k))"
    using Seq2TrSeq_def ZF_fun_from_tot_val0 by simp
  { fix k fix x assume A5: "k\<in>n"  "x\<in>X"
    with A1 A3 have "a`(k) \<in> Y" using apply_funtype
      by auto
    with A2 A5 I have "(T`(k))`(x) = f`\<langle>x,a`(k)\<rangle>"
      using fix_var_val by simp
  } thus "\<forall>k\<in>n. \<forall>x\<in>X. (T`(k))`(x) = f`\<langle>x,a`(k)\<rangle>"
    by simp
qed

text\<open>Basic properties of the sequence of partial folds of a sequence
  $a = \{y_k\}_{k\in \{0,..,n\} }$.\<close>

theorem fold_seq_props:
  assumes A1: "n \<in> nat" and A2: "f : X\<times>Y \<rightarrow> X" and
  A3: "y:n\<rightarrow>Y" and A4: "x\<in>X" and A5: "Y\<noteq>0" and
  A6: "F = FoldSeq(f,x,y)"
  shows
  "F: succ(n) \<rightarrow> X"
  "F`(0) = x" and
  "\<forall>k\<in>n. F`(succ(k)) = f`\<langle>F`(k), y`(k)\<rangle>"
proof -
  let ?T = "Seq2TrSeq(f,y)"
  from A1 A3 have D: "domain(y) = n"
    using func1_1_L1 by simp
  from \<open>f : X\<times>Y \<rightarrow> X\<close>  \<open>Y\<noteq>0\<close> have I: "fstdom(f) = X"
    using fstdomdef by simp
  with A1 A2 A3 A4 A6 D show
    II: "F: succ(n) \<rightarrow> X"  and "F`(0) = x"
    using seq2trans_seq_props FoldSeq_def fin_indseq_var_f_props
    by auto
  from A1 A2 A3 A4 A6 I D have "\<forall>k\<in>n. F`(succ(k)) = ?T`(k)`(F`(k))"
    using seq2trans_seq_props FoldSeq_def fin_indseq_var_f_props
    by simp
  moreover
  { fix k assume A5: "k\<in>n" hence "k \<in> succ(n)" by auto
    with A1 A2 A3 II A5 have "(?T`(k))`(F`(k)) = f`\<langle>F`(k),y`(k)\<rangle>"
      using apply_funtype seq2trans_seq_props by simp }
  ultimately show "\<forall>k\<in>n. F`(succ(k)) = f`\<langle>F`(k), y`(k)\<rangle>"
    by simp
qed

text\<open>A consistency condition: if we make the list shorter, then we get a shorter
  sequence of partial folds with the same values as in the original sequence.
  This can be proven as a special case of \<open>fin_indseq_var_f_restrict\<close>
  but a proof using \<open>fold_seq_props\<close> and induction turns out to be
  shorter.\<close>

lemma foldseq_restrict: assumes
  "n \<in> nat"   "k \<in> succ(n)" and
  "i \<in> nat"  "f : X\<times>Y \<rightarrow> X"  "a : n \<rightarrow> Y"  "b : i \<rightarrow> Y" and
  "n \<subseteq> i"   "\<forall>j \<in> n. b`(j) = a`(j)"   "x \<in> X"   "Y \<noteq> 0"
  shows "FoldSeq(f,x,b)`(k) = FoldSeq(f,x,a)`(k)"
proof -
  let ?P = "FoldSeq(f,x,a)"
  let ?Q = "FoldSeq(f,x,b)"
  from assms have
    "n \<in> nat"   "k \<in> succ(n)"
    "?Q`(0) = ?P`(0)" and
    "\<forall>j \<in> n. ?Q`(j) = ?P`(j) \<longrightarrow> ?Q`(succ(j)) = ?P`(succ(j))"
    using fold_seq_props by auto
  then show  "?Q`(k) = ?P`(k)" by (rule fin_nat_ind)
qed

text\<open>A special case of \<open>foldseq_restrict\<close> when the longer
  sequence is created from the shorter one by appending
  one element.\<close>

corollary fold_seq_append:
  assumes "n \<in> nat"   "f : X\<times>Y \<rightarrow> X"   "a:n \<rightarrow> Y" and
  "x\<in>X"   "k \<in> succ(n)"   "y\<in>Y"
  shows "FoldSeq(f,x,Append(a,y))`(k) = FoldSeq(f,x,a)`(k)"
proof -
  let ?b = "Append(a,y)"
  from assms have "?b : succ(n) \<rightarrow> Y"  "\<forall>j \<in> n. ?b`(j) = a`(j)"
    using append_props by auto
  with assms show ?thesis using foldseq_restrict by blast
qed

text\<open>What we really will be using is the notion of the fold
  of a sequence, which we define as the last element of
  (inductively defined) sequence of partial folds. The next theorem
  lists some properties of the product of the fold operation.\<close>

theorem fold_props:
  assumes A1: "n \<in> nat" and
  A2: "f : X\<times>Y \<rightarrow> X"  "a:n \<rightarrow> Y"  "x\<in>X"  "Y\<noteq>0"
  shows
  "Fold(f,x,a) =  FoldSeq(f,x,a)`(n)" and
  "Fold(f,x,a) \<in> X"
proof -
  from assms have " FoldSeq(f,x,a) : succ(n) \<rightarrow> X"
    using  fold_seq_props by simp
  with A1 show
    "Fold(f,x,a) =  FoldSeq(f,x,a)`(n)" and "Fold(f,x,a) \<in> X"
    using last_seq_elem apply_funtype Fold_def by auto
qed

text\<open>A corner case: what happens when we fold an empty list?\<close>

theorem fold_empty: assumes A1: "f : X\<times>Y \<rightarrow> X" and
  A2: "a:0\<rightarrow>Y"  "x\<in>X"  "Y\<noteq>0"
  shows "Fold(f,x,a) = x"
proof -
  let ?F = "FoldSeq(f,x,a)"
  from assms have I:
    "0 \<in> nat"  "f : X\<times>Y \<rightarrow> X"  "a:0\<rightarrow>Y"  "x\<in>X"  "Y\<noteq>0"
    by auto
  then have "Fold(f,x,a) = ?F`(0)" by (rule fold_props)
  moreover
  from I have
    "0 \<in> nat"  "f : X\<times>Y \<rightarrow> X"  "a:0\<rightarrow>Y"  "x\<in>X"  "Y\<noteq>0" and
    "?F = FoldSeq(f,x,a)" by auto
  then have "?F`(0) = x" by (rule fold_seq_props)
  ultimately show "Fold(f,x,a) = x" by simp
qed

text\<open>The next theorem tells us what happens to the fold of a sequence
  when we add one more element to it.\<close>

theorem fold_append:
  assumes A1: "n \<in> nat" and  A2: "f : X\<times>Y \<rightarrow> X" and
  A3: "a:n\<rightarrow>Y" and A4: "x\<in>X" and A5: "y\<in>Y"
  shows
  "FoldSeq(f,x,Append(a,y))`(n) = Fold(f,x,a)" and
  "Fold(f,x,Append(a,y)) = f`\<langle>Fold(f,x,a), y\<rangle>"
proof -
  let ?b = "Append(a,y)"
  let ?P = "FoldSeq(f,x,?b)"
  from A5 have I: "Y \<noteq> 0" by auto
  with assms show thesis1: "?P`(n) = Fold(f,x,a)"
    using fold_seq_append fold_props by simp
  from assms I have II:
    "succ(n) \<in> nat"   "f : X\<times>Y \<rightarrow> X"
    "?b : succ(n) \<rightarrow> Y"   "x\<in>X"  "Y \<noteq> 0"
    "?P = FoldSeq(f,x,?b)"
    using append_props by auto
  then have
    "\<forall>k \<in> succ(n). ?P`(succ(k)) =  f`\<langle>?P`(k), ?b`(k)\<rangle>"
    by (rule fold_seq_props)
  with A3 A5 thesis1 have "?P`(succ(n)) =  f`\<langle> Fold(f,x,a), y\<rangle>"
    using append_props by auto
  moreover
  from II have "?P : succ(succ(n)) \<rightarrow> X"
    by (rule fold_seq_props)
  then have "Fold(f,x,?b) = ?P`(succ(n))"
    using last_seq_elem Fold_def by simp
  ultimately show "Fold(f,x,Append(a,y)) = f`\<langle>Fold(f,x,a), y\<rangle>"
    by simp
qed

text\<open>Another way of formulating information contained in \<open>fold_append\<close> is to start
  with a longer sequence $a:n+1\rightarrow X$ and then detach the last element from it.
  This provides an identity between the fold of the longer sequence
  and the value of the folding function on the fold of the shorter sequence and the last element
  of the longer one. \<close>

lemma fold_detach_last:
  assumes "n \<in> nat" "f : X\<times>Y \<rightarrow> X" "x\<in>X" "\<forall>k\<in>n #+ 1. q(k) \<in> Y"
  shows "Fold(f,x,{\<langle>k,q(k)\<rangle>. k\<in>n #+ 1}) = f`\<langle>Fold(f,x,{\<langle>k,q(k)\<rangle>. k\<in>n}), q(n)\<rangle>"
proof -
  let ?a = "{\<langle>k,q(k)\<rangle>. k\<in>n #+ 1}"
  let ?b = "{\<langle>k,q(k)\<rangle>. k\<in>n}"
  from assms have
    "Fold(f,x,Append(?b,q(n))) = f`\<langle>Fold(f,x,?b), q(n)\<rangle>"
    using ZF_fun_from_total fold_append(2) by simp_all
  moreover from assms(1,4) have "?a = Append(?b,q(n))"
    using set_list_append1(4) by simp
  ultimately show "Fold(f,x,?a) = f`\<langle>Fold(f,x,?b), q(n)\<rangle>"
    by simp
qed

text\<open>The tail of the sequence of partial folds defined by the folding function $f$,
  starting point $x$ and a sequence $y$ is the same as the sequence of partial
  folds starting from $f(x,y(0))$.\<close>

lemma fold_seq_detach_first:
  assumes "n \<in> nat" "f : X\<times>Y \<rightarrow> X" "y:succ(n)\<rightarrow>Y" "x\<in>X"
  shows "FoldSeq(f,f`\<langle>x,y`(0)\<rangle>,Tail(y)) = Tail(FoldSeq(f,x,y))"
proof -
  let ?F = "FoldSeq(f,x,y)"
  let ?T = "Tail(?F)"
  let ?S = "Seq2TrSeq(f,Tail(y))"
  from assms(1) have "succ(n) \<in> nat" and "0 \<in> succ(n)"
      using empty_in_every_succ by simp_all
  with assms(3) have "y`(0)\<in>Y" using apply_funtype
      by simp
  hence "Y\<noteq>0" by auto
  have "n \<in> nat" "f`\<langle>x,y`(0)\<rangle> \<in> X" "?S:n\<rightarrow>(X\<rightarrow>X)"
    and "?T:succ(n) \<rightarrow> X" "?T`(0) = f`\<langle>x,y`(0)\<rangle>"
    and "\<forall>k\<in>n. ?T`(succ(k)) = (?S`(k))`(?T`(k))"
  proof -
    from assms(1) show "n \<in> nat" by simp
    from assms \<open>Y\<noteq>0\<close> \<open>succ(n) \<in> nat\<close> show "?T:succ(n) \<rightarrow> X"
      using fold_seq_props(1) tail_props(1) by simp
    from assms(2,4) \<open>y`(0)\<in>Y\<close> show "f`\<langle>x,y`(0)\<rangle> \<in> X"
      using apply_funtype by simp
    from assms(1,2,3) show "?S:n\<rightarrow>(X\<rightarrow>X)"
      using tail_props(1) seq2trans_seq_props by simp
    from assms \<open>Y\<noteq>0\<close> have I: "?F:succ(succ(n)) \<rightarrow> X"
      using fold_seq_props(1) by simp
    show "?T`(0) = f`\<langle>x,y`(0)\<rangle>"
    proof -
      from \<open>succ(n) \<in> nat\<close> \<open>0 \<in> succ(n)\<close> I
        have "?T`(0) = ?F`(succ(0))"
        using tail_props(2) by blast
      moreover from assms \<open>Y\<noteq>0\<close> \<open>0 \<in> succ(n)\<close>
        have "?F`(succ(0)) = f`\<langle>?F`(0), y`(0)\<rangle>"
        using fold_seq_props(3) by blast
      moreover from assms \<open>Y\<noteq>0\<close> have "?F`(0) = x"
        using fold_seq_props(2) by blast
      ultimately show "?T`(0) = f`\<langle>x,y`(0)\<rangle>" by simp
    qed
    show "\<forall>k\<in>n. ?T`(succ(k)) = (?S`(k))`(?T`(k))"
    proof -
      { fix k assume "k\<in>n"
        with assms(1) have
          "succ(k) \<in> succ(n)" "k\<in>succ(n)" "succ(k) \<in> succ(succ(n))"
          using succ_ineq by auto
        with \<open>succ(n) \<in> nat\<close> I have "?T`(succ(k)) = ?F`(succ(succ(k)))"
          using tail_props(2) by blast
        moreover from assms \<open>Y\<noteq>0\<close> \<open>succ(k) \<in> succ(n)\<close>
          have "?F`(succ(succ(k))) = f`\<langle>?F`(succ(k)), y`(succ(k))\<rangle>"
            using fold_seq_props(3) by blast
        moreover from assms(1,3) \<open>k\<in>n\<close> have "y`(succ(k)) = (Tail(y))`(k)"
          using tail_props(2) by simp
        moreover from assms \<open>k\<in>n\<close> I \<open>succ(k) \<in> succ(succ(n))\<close>
          have "f`\<langle>?F`(succ(k)),(Tail(y))`(k)\<rangle> = (?S`(k))`(?F`(succ(k)))"
            using tail_props(1) seq2trans_seq_props(2) apply_funtype
            by simp
        moreover from \<open>succ(n) \<in> nat\<close> I \<open>k\<in>succ(n)\<close>
          have "?T`(k) = ?F`(succ(k))"
            using tail_props(2) by blast
        ultimately have "?T`(succ(k)) = (?S`(k))`(?T`(k))" by simp
      } thus ?thesis by simp
    qed
  qed
  then have "?T = InductiveSeqVarFN(f`\<langle>x,y`(0)\<rangle>,X,?S,n)"
    by (rule is_fin_indseq_var_f)
  moreover have "fstdom(f) = X" and "domain(Tail(y)) = n"
  proof -
    from assms(2) \<open>Y\<noteq>0\<close> show "fstdom(f) = X"
      using fstdomdef by simp
    from assms(1,3) show "domain(Tail(y)) = n"
      using tail_props(1) func1_1_L1 by blast
  qed
  ultimately show ?thesis unfolding FoldSeq_def by simp
qed

end


theory ProcCVars
  imports WTLemma ResMapValid ReduceProper
begin

    (* #### we use this to define the full dominator *)
(*
fun complete_vars :: "nres_map \<Rightarrow> res_id set \<Rightarrow> res_id set" where
  "complete_vars rs_map s = { Loc x | x. \<exists> l z. Loc z \<in> s \<and> path_lookup rs_map z l x} \<union> s"  *)

definition dom_use_env :: "res_id set \<Rightarrow> perm_use_env"  where
  "dom_use_env s = (\<lambda> x. if x \<in> s then OwnPerm else NoPerm)"

definition np_dom_use_env where
  "np_dom_use_env env delta e = dom_use_env (non_prim_vars env delta e)"
  (*
definition full_dom_use_env where
  "full_dom_use_env env delta e = dom_use_env (complete_vars rs_map (non_prim_vars env delta e))"    *)

lemma strong_dom_use_env: "strong_use_env (dom_use_env s)"
  apply (simp add: strong_use_env_def)
  apply (simp add: dom_use_env_def)
  done

lemma dist_dom_leq_use_env: "\<lbrakk> s \<subseteq> s' \<rbrakk> \<Longrightarrow> leq_use_env (dom_use_env s) (dom_use_env s')"
  apply (simp add: dom_use_env_def)
  apply (simp add: leq_use_env_def)
  apply (auto)
  done
    (*
lemma full_dom_leq_use_env: "leq_use_env (np_dom_use_env env e) (full_dom_use_env env rs_map e)"
  apply (simp add: np_dom_use_env_def)
  apply (simp add: full_dom_use_env_def)
  apply (rule_tac dist_dom_leq_use_env)
  apply (auto)
  done*)

lemma wt_np_leq_use_env: "\<lbrakk> well_typed env delta r_s1 e tau r_s2 rx; is_own r \<rbrakk> \<Longrightarrow> leq_use_env (np_dom_use_env env delta e) (lift_use_env r_s1 r)"
  apply (simp add: leq_use_env_def)
  apply (simp add: np_dom_use_env_def)
  apply (simp add: dom_use_env_def)
  apply (auto)
  apply (simp add: is_own_def)
  apply (case_tac "r_s1 x = NoPerm")
   apply (cut_tac env="env" and ?r_s1.0="r_s1" and e="e" and x="x" in well_typed_no_npv_use)
     apply (auto)
  done

end


theory Typed_Rely_Guarantee
  imports Typed_Memory Bisimulation
begin

section \<open>Locale\<close>

definition secure :: "('Var, 'Val) Sec \<Rightarrow> ('Var, 'Val) TState"
  where "secure \<L> \<equiv> {(m,\<Gamma>). \<forall>x. m \<in> \<L> x \<longrightarrow> \<Gamma> x}"

locale typed_rely_guarantee = typed_memory + rg: bisimulation eval
  for eval :: "'Act \<Rightarrow> (('Var,'Val) Mem \<times> ('Var,'Val) Mem) set" +
  fixes flow :: "'Act \<Rightarrow> ('Var,'Val) Mem \<Rightarrow> ('Var) Type \<Rightarrow> ('Var) Type"
  assumes flow_sound: "(m\<^sub>1,m\<^sub>1') \<in> eval \<alpha> \<Longrightarrow> (m\<^sub>2,m\<^sub>2') \<in> eval \<alpha> \<Longrightarrow> flow \<alpha> m\<^sub>1 (m\<^sub>1 \<triangle> m\<^sub>2) \<ge>\<^sub>\<Gamma> m\<^sub>1' \<triangle> m\<^sub>2'"

context typed_rely_guarantee
begin

subsection \<open>Lifting Properties\<close>
text \<open>
This theory file maps the predicate language concepts to the complete theory found in BisimRG.
As a result, it must lift predicate language definitions into the memory set encoding found in
the complete theory.
\<close>
definition liftState :: "('Var, 'Val) TState \<Rightarrow> ('Var, 'Val) Mem rg.state"
  where "liftState P \<equiv> {(m\<^sub>1,m\<^sub>2). (m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2) \<in> P \<and> (m\<^sub>2,m\<^sub>1 \<triangle> m\<^sub>2) \<in> P}"

definition liftStep :: "('Var, 'Val) TStep \<Rightarrow> ('Var, 'Val) Mem rg.step"
  where "liftStep R \<equiv> {((m\<^sub>1,m\<^sub>2),(m\<^sub>1',m\<^sub>2')).
                ((m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2),(m\<^sub>1',m\<^sub>1' \<triangle> m\<^sub>2')) \<in> R \<and>
                ((m\<^sub>2,m\<^sub>1 \<triangle> m\<^sub>2),(m\<^sub>2',m\<^sub>1' \<triangle> m\<^sub>2')) \<in> R}"

definition stable :: "('Var, 'Val) TState \<Rightarrow> ('Var, 'Val) TStep \<Rightarrow> bool" where
  "stable \<equiv> \<lambda>f g. (\<forall>x y. x \<in> f \<longrightarrow> (x, y) \<in> g \<longrightarrow> y \<in> f)"

abbreviation invSec :: "('Var, 'Val) Sec \<Rightarrow> ('Var, 'Val) TStep"
  where "invSec \<L> \<equiv> preserve (secure \<L>)"

abbreviation lift\<^sub>R :: "('Var, 'Val) TStep \<Rightarrow> ('Var, 'Val) Sec \<Rightarrow> ('Var, 'Val) Mem rg.step"
  where "lift\<^sub>R R \<L> \<equiv> liftStep (invSec \<L> \<inter> R)"

abbreviation lift\<^sub>G :: "('Var, 'Val) TStep \<Rightarrow> ('Var, 'Val) Sec \<Rightarrow> ('Var, 'Val) Mem rg.step"
  where "lift\<^sub>G G \<L> \<equiv> liftStep (invSec \<L> \<inter> G)"

abbreviation lift\<^sub>Q :: "('Var, 'Val) TState \<Rightarrow> ('Var, 'Val) Sec \<Rightarrow> ('Var, 'Val) Mem rg.state"
  where "lift\<^sub>Q Q \<L> \<equiv> liftState (secure \<L> \<inter> Q)"

text \<open>Lift the meaning of entailment from the predicate language to sets of memory states\<close>
lemma lift_entail [intro]:
  shows "P \<subseteq> Q \<Longrightarrow> (liftState P \<subseteq> liftState Q)"
  by (auto simp: liftState_def)

lemma lift_step_entail [intro]:
  shows "P \<subseteq> Q \<Longrightarrow> (liftStep P \<subseteq> liftStep Q)"
  by (auto simp: liftStep_def)

lemma lift\<^sub>Q_entail:
  shows "P \<subseteq> Q \<Longrightarrow> (lift\<^sub>Q P \<L> \<subseteq> lift\<^sub>Q Q \<L>)"
  by (auto simp: liftState_def)

lemma lift\<^sub>G_entail:
  shows "P \<subseteq> Q \<Longrightarrow> (lift\<^sub>G P \<L> \<subseteq> lift\<^sub>G Q \<L>)"
  by (auto simp: liftStep_def)

text \<open>Lift the predicate language based definition of stability\<close>
lemma lift_stable [intro]:
  "stable P R \<Longrightarrow> rg.stable (liftState P) (liftStep R)"
  by (clarsimp simp add: stable_def rg.stable_def liftState_def liftStep_def)

text \<open>Support conjunction over stable predicates\<close>
lemma stable_conjI [intro]:
  assumes "stable P R" "stable Q R"
  shows "stable (P \<inter> Q) R"
  using assms by (auto simp: stable_def)

text \<open>Support preservation of an invariant over a stable predicate\<close>
lemma stable_invarI [intro]:
  assumes "stable Q R"
  shows "stable (P \<inter> Q) (preserve P \<inter> R)"
  using assms unfolding stable_def preserve_def by auto

lemma stable_invarI' [intro]:
  assumes "stable Q (invSec \<L> \<inter> R)"
  shows "stable (secure \<L> \<inter> Q) (invSec \<L> \<inter> R)"
  using assms unfolding stable_def preserve_def by auto

text \<open>Support simplification of conjunction in lifted predicates\<close>

lemma [simp]:
  "lift\<^sub>G (R\<^sub>1 \<inter> R\<^sub>2) \<L> = lift\<^sub>G R\<^sub>1 \<L> \<inter> lift\<^sub>G R\<^sub>2 \<L>"
  by (auto simp: liftStep_def)

text \<open>A wellformed security policy results in a wellformed environment predicate\<close>
lemma str_env_\<L> [intro]:
  shows "str_env (invSec \<L>)"
  by (auto simp: str_env_def preserve_def secure_def type_ord_def)

subsection \<open>Executable\<close>
text \<open>
The executable property captures the idea of incomplete actions,
such as expressions that may not be defined and guards that cannot resolve to be true.
This property can be resolved in a few different ways:
  - If the expression is only influenced by low variables, then it does not have to be executable
    under all conditions. This is the approach used for guards.
  - If the expression is influenced by high variables, then it must be consistently executable or
    not under the current context. This is used for some partial expression evaluations.
\<close>
definition executable :: "('Var, 'Val) TState \<Rightarrow> 'Act \<Rightarrow> bool"
  where "executable P \<alpha> \<equiv>
    \<forall>m\<^sub>1 m\<^sub>2. (m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2) \<in> P \<and> (m\<^sub>2,m\<^sub>1 \<triangle> m\<^sub>2) \<in>  P \<longrightarrow> (\<exists>m. (m\<^sub>1,m) \<in> eval \<alpha>) \<longrightarrow>  (\<exists>m. (m\<^sub>2,m) \<in> eval \<alpha>)"

lemma executable1:
  assumes "executable P \<alpha>"
  shows "\<forall>m\<^sub>1 m\<^sub>2. (m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2) \<in> P \<and> (m\<^sub>2,m\<^sub>1 \<triangle> m\<^sub>2) \<in>  P \<longrightarrow> (\<exists>m. (m\<^sub>1,m) \<in> eval \<alpha>) \<longrightarrow>  (\<exists>m. (m\<^sub>2,m) \<in> eval \<alpha>)"
  using assms by (simp add: executable_def)

lemma executable2:
  assumes "executable P \<alpha>"
  shows "\<forall>m\<^sub>1 m\<^sub>2. (m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2) \<in> P \<and> (m\<^sub>2,m\<^sub>1 \<triangle> m\<^sub>2) \<in>  P \<longrightarrow> (\<exists>m. (m\<^sub>2,m) \<in> eval \<alpha>) \<longrightarrow>  (\<exists>m. (m\<^sub>1,m) \<in> eval \<alpha>)"
  using assms by (metis executable_def mem_delta_flip)

lemma executable [intro]:
  assumes "executable (secure \<L> \<inter> P) \<alpha>"
  shows "rg.bisim_act (lift\<^sub>Q P \<L>) \<alpha>"
  using executable1 executable2 assms
  by (simp add: rg.bisim_act_def rg.progress_def liftState_def)

subsection \<open>Guarantee\<close>
text \<open>
The guarantee property ensures the action conforms to the thread's guarantee and security policy.
As the logic is incomplete, it requires a wellformed guarantee,
such that inaccuracies due to over-approximating type flow cannot invalidate the state.
\<close>

definition guarantee
  where "guarantee P G \<alpha> \<equiv> \<forall>m m' \<Gamma>. (m,\<Gamma>) \<in> P \<longrightarrow> (m,m') \<in> eval \<alpha> \<longrightarrow> ((m,\<Gamma>),(m',(flow \<alpha> m \<Gamma>))) \<in> G"

lemma guarantee_step:
  assumes "str_env G"
  assumes "guarantee (secure \<L> \<inter> P) G \<alpha>"
  assumes "(m\<^sub>1,m\<^sub>1') \<in> eval \<alpha>" "(m\<^sub>2,m\<^sub>2') \<in> eval \<alpha>"
  assumes "(m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2) \<in> secure \<L> \<inter> P"
  shows "((m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2),(m\<^sub>1',m\<^sub>1' \<triangle> m\<^sub>2')) \<in> G"
  using assms flow_sound unfolding str_env_def guarantee_def type_ord_def
  by metis

lemma guarantee [intro]:
  assumes "str_env G"
  assumes "guarantee (secure \<L> \<inter> P) G \<alpha>"
  shows "rg.lift\<^sub>P (lift\<^sub>Q P \<L>) \<inter> rg.lift\<^sub>a \<alpha> \<subseteq> liftStep G"
  using guarantee_step[OF assms]
  by (clarsimp simp add: rg.lift\<^sub>a_def liftState_def liftStep_def rg.lift\<^sub>P_def, metis mem_delta_flip)

lemma guarantee_conjE[elim]:
  assumes "guarantee P (A \<inter> B) \<alpha>"
  obtains "guarantee P A \<alpha>" "guarantee P B \<alpha>"
  using assms by (auto simp: guarantee_def)

subsection \<open>Weakest Precondition\<close>
text \<open>
The weakest precondition property ensures proof obligations are preserved across actions.
As the logic is incomplete, it requires a wellformed postcondition,
such that inaccuracies due to over-approximating type flow cannot invalidate the state.
\<close>
definition weakestpre
  where "weakestpre P Q \<alpha> \<equiv> \<forall>m m' \<Gamma>. (m,\<Gamma>) \<in> P \<longrightarrow> (m,m') \<in> eval \<alpha> \<longrightarrow> (m',flow \<alpha> m \<Gamma>) \<in> Q"

lemma weakestpre_step:
  assumes "str Q"
  assumes "weakestpre P Q \<alpha>"
  assumes "(m\<^sub>1,m\<^sub>1') \<in> eval \<alpha>" "(m\<^sub>2,m\<^sub>2') \<in> eval \<alpha>"
  assumes "(m\<^sub>1,m\<^sub>1 \<triangle> m\<^sub>2) \<in> P"
  shows "(m\<^sub>1',m\<^sub>1' \<triangle> m\<^sub>2') \<in> Q"
  using assms flow_sound unfolding weakestpre_def str_def by blast

lemma weakestpreQ [intro]:
  assumes "str Q"
  assumes "weakestpre (secure \<L> \<inter> P) Q \<alpha>"
  shows "(lift\<^sub>Q P \<L>)+[rg.lift\<^sub>a \<alpha>] \<subseteq> liftState Q"
  using weakestpre_step[OF assms]
  by (clarsimp simp add: rg.lift\<^sub>a_def rg.trans_def liftState_def; metis mem_delta_flip)

lemma weakestpre\<L> [intro]:
  assumes "guarantee (secure \<L> \<inter> P) (invSec \<L>) \<alpha>"
  shows "(lift\<^sub>Q P \<L>)+[rg.lift\<^sub>a \<alpha>] \<subseteq> liftState (secure \<L>)"
  using guarantee_step[OF str_env_\<L>[of \<L>] assms(1)]
  apply (clarsimp simp add: rg.lift\<^sub>a_def rg.trans_def liftState_def preserve_def)
  by (metis mem_delta_flip)

lemma weakestpre_conj [intro]:
  assumes "(lift\<^sub>Q P \<L>)+[rg.lift\<^sub>a \<alpha>] \<subseteq> liftState A"
  assumes "(lift\<^sub>Q P \<L>)+[rg.lift\<^sub>a \<alpha>] \<subseteq> liftState B"
  shows "(lift\<^sub>Q P \<L>)+[rg.lift\<^sub>a \<alpha>] \<subseteq> liftState (A \<inter> B)"
  using assms by (auto simp: liftState_def)

subsection \<open>Rules\<close>
text \<open>
A set of rules that specialise the general set seen in Rely_Guarantee for:
  - Consideration of a single memory and a type context
  - An invariant security policy \<L>
\<close>

definition Valid :: "('Var,'Val) TStep \<Rightarrow> ('Var,'Val) TStep \<Rightarrow> ('Var,'Val) Sec \<Rightarrow> ('Var,'Val) TState \<Rightarrow> 'Act Stmt \<Rightarrow> ('Var,'Val) TState \<Rightarrow> bool"
  ("_,_ \<turnstile>\<^sub>_ _ {_} _" [20, 20, 20, 20] 20)
  where "Valid R G \<L> P c Q \<equiv> rg.rules (lift\<^sub>R R \<L>) (lift\<^sub>G G \<L>) (lift\<^sub>Q P \<L>) (c) (lift\<^sub>Q Q \<L>)"

lemma skipRule [intro]:
  "stable P (invSec \<L> \<inter> R) \<Longrightarrow> R,G \<turnstile>\<^sub>\<L> P { Skip } P"
  unfolding Valid_def by blast

lemma seqRule [intro]:
  "R,G \<turnstile>\<^sub>\<L> Q { c\<^sub>2 } M \<Longrightarrow> R,G \<turnstile>\<^sub>\<L> P { c\<^sub>1 } Q \<Longrightarrow> R,G \<turnstile>\<^sub>\<L> P { c\<^sub>1 ;; c\<^sub>2 } M"
  unfolding Valid_def by blast

lemma choiceRule [intro]:
  "R,G \<turnstile>\<^sub>\<L> P { c\<^sub>1 } Q \<Longrightarrow> R,G \<turnstile>\<^sub>\<L> P { c\<^sub>2 } Q \<Longrightarrow> R,G \<turnstile>\<^sub>\<L> P { c\<^sub>1 \<sqinter> c\<^sub>2 } Q"
  unfolding Valid_def by blast

lemma loopRule [intro]:
  "stable P (invSec \<L> \<inter> R) \<Longrightarrow> R,G \<turnstile>\<^sub>\<L> P { c } P \<Longrightarrow> R,G \<turnstile>\<^sub>\<L> P { c* } P"
  unfolding Valid_def by blast

lemma parallelRule [intro]:
  "R\<^sub>1,G\<^sub>1 \<turnstile>\<^sub>\<L> P\<^sub>1 { c\<^sub>1 } Q\<^sub>1 \<Longrightarrow> R\<^sub>2,G\<^sub>2 \<turnstile>\<^sub>\<L> P\<^sub>2 { c\<^sub>2 } Q\<^sub>2 \<Longrightarrow> G\<^sub>2 \<subseteq> R\<^sub>1 \<Longrightarrow> G\<^sub>1 \<subseteq> R\<^sub>2 \<Longrightarrow> R\<^sub>1 \<inter> R\<^sub>2,G\<^sub>1 \<union> G\<^sub>2 \<turnstile>\<^sub>\<L> P\<^sub>1 \<inter> P\<^sub>2 { c\<^sub>1 || c\<^sub>2 } Q\<^sub>1 \<inter> Q\<^sub>2"
  unfolding Valid_def by (intro rg.parallelI, auto simp: liftStep_def)

lemma rewriteRule [intro]:
  "R,G \<turnstile>\<^sub>\<L> P { c } Q \<Longrightarrow> P' \<subseteq> P \<Longrightarrow> R' \<subseteq> R \<Longrightarrow> G \<subseteq> G' \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow>
                      R',G' \<turnstile>\<^sub>\<L> P' { c } Q'"
  unfolding Valid_def by (rule rg.rewrite, auto intro!: lift\<^sub>Q_entail lift\<^sub>G_entail)

lemma falseRule [intro]:
  "R,G \<turnstile>\<^sub>\<L> {} { c } Q"
proof -
  have "rg.rules (lift\<^sub>R R \<L>) (lift\<^sub>G G \<L>) {} (c) {}" using rg.false by auto
  thus ?thesis unfolding Valid_def by (rule rg.rewrite, auto simp: liftState_def)
qed

lemma loopRuleAlt [intro]:
  assumes "stable P (invSec \<L> \<inter> R)" "R,G \<turnstile>\<^sub>\<L> P {c} P" "P \<subseteq> Q"
  shows "R,G \<turnstile>\<^sub>\<L> P {c*} Q"
proof (rule rewriteRule)
  show "R,G \<turnstile>\<^sub>\<L> P {c*} P" using assms by auto
qed (insert assms(3), auto)

lemma actRule [intro]:
  assumes "stable P (invSec \<L> \<inter> R)" "stable Q (invSec \<L> \<inter> R)"
  assumes "str Q" "str_env G"
  assumes "guarantee (secure \<L> \<inter> P) (invSec \<L> \<inter> G) \<alpha>"
  assumes "weakestpre (secure \<L> \<inter> P) Q \<alpha>"
  assumes "executable (secure \<L> \<inter> P) \<alpha>"
  shows "R,G \<turnstile>\<^sub>\<L> P { Basic \<alpha> } Q"
  using assms unfolding Valid_def
  by (intro rg.act guarantee weakestpre_conj weakestpre\<L> weakestpreQ executable) auto

end

end