           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               February 2005               |
            |                   June 2005 (modified)    |
            |              September 2005 (modified)    |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  April 2006  (modified)   |
            |                  March 2007  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2017         |
            |                  April 2018  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_F_law_fp
imports CSP_T.CSP_T_law_fp CSP_F_law_ufp
begin

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

         1. cpo fixed point theory in CSP-Prover
         2.
         3.
         4.

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

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
(* no simp rules in Isabelle 2017
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]
*)

(*=======================================================*
 |                                                       |
 |                        CPO                            |
 |                                                       |
 *=======================================================*)

(*-------------*
 |  existency  |
 *-------------*)

lemma semF_hasLFP_cpo:
 "Pf = PNfun ==> [[Pf]]Ffun hasLFP"
apply (rule Tarski_thm_EX)
apply (rule continuous_semFfun)
done

lemma semF_LFP_cpo:
  "[| Pf = PNfun ;
      FPmode = CPOmode | FPmode = MIXmode |]
  ==> [[$p]]F = LFP ([[Pf]]Ffun) p"
apply (simp add: semF_def)
apply (simp add: semFf_Proc_name)
apply (simp add: MF_def)
apply (simp add: semFfix_def)
apply (force)
done

lemma semF_LFP_fun_cpo:
  "[| Pf = PNfun ;
      FPmode = CPOmode | FPmode = MIXmode |]
  ==> (%p. [[$p]]F) = LFP ([[Pf]]Ffun)"
apply (simp (no_asm) add: fun_eq_iff)
apply (simp add: semF_LFP_cpo)
done

(*---------*
 |    MF   |
 *---------*)

lemma MF_fixed_point_cpo:
      "[| (Pf::'p=>('p,'a) proc) = PNfun; FPmode = CPOmode | FPmode = MIXmode |]
        ==> [[Pf]]Ffun (MF::'p => 'a domF) = (MF::'p => 'a domF)"
apply (simp add: MF_def)
apply (simp add: semFfix_def)
apply (erule disjE)
apply (simp_all)
apply (rule LFP_fp)
apply (simp add: semF_hasLFP_cpo)
apply (rule LFP_fp)
apply (simp add: semF_hasLFP_cpo)
done

(*-------------*
 |  greatest   |
 *-------------*)

lemma ALL_cspF_greatest_cpo:
  "[| Pf = PNfun ;
       FPmode = CPOmode ;
       ALL p. (Pf p) << f =F f p |] ==> ALL p. f p <=F $p"
apply (simp add: eqF_def refF_def)
apply (fold semF_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (fold order_prod_def)
apply (insert semF_LFP_fun_cpo[of "Pf"])
apply (simp)

apply (rule LFP_least)
apply (simp add: semF_hasLFP_cpo)

apply (simp add: semF_subst)
apply (simp add: semFfun_def)
done

lemma cspF_greatest_cpo:
  "[| Pf = PNfun ;
       FPmode = CPOmode ;
       ALL p. (Pf p) << f =F f p |] ==> f p <=F $p"
by (simp add: ALL_cspF_greatest_cpo)

(*-------------------------------------------------------*
 |                                                       |
 |           Fixpoint unwind (CSP-Prover rule)           |
 |                                                       |
 *-------------------------------------------------------*)

lemma ALL_cspF_unwind_cpo:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode |]
     ==> ALL p. ($p =F Pf p)"
apply (simp add: eqF_def)
apply (simp add: semFf_Proc_name)
apply (simp add: MF_def)
apply (simp add: semFfix_def)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: semFf_semFfun)
apply (simp add: LFP_fp semF_hasLFP_cpo)
apply (force)
done

(*  csp law  *)

lemma cspF_unwind_cpo:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode |]
     ==> $p =F Pf p"
by (simp add: ALL_cspF_unwind_cpo)

(*-------------------------------------------------------*
 |                                                       |
 |    fixed point inducntion (CSP-Prover intro rule)     |
 |                                                       |
 *-------------------------------------------------------*)

(*** right ***)

lemma cspF_fp_induct_cpo_ref_right_ALL:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode ;
       Q <=F f p;
       ALL p. f p <=F (Pf p)<<f |]
    ==> Q <=F $p"
apply (simp add: refF_semF)
apply (insert cpo_fixpoint_induction_rev
       [of "[[Pf]]Ffun" "(%p. [[f p]]F)"])
apply (simp add: LFP_fp semF_hasLFP_cpo)
apply (simp add: fold_order_prod_def)
apply (simp add: semF_subst_semFfun)

apply (simp add: continuous_semFfun)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+

apply (simp add: semF_LFP_cpo)
done

(*  csp law  *)

lemma cspF_fp_induct_cpo_ref_right:
   "[| Pf = PNfun ;
       FPmode = CPOmode | FPmode = MIXmode ;
       Q <=F f p;
       !! p. f p <=F (Pf p)<<f |]
    ==> Q <=F $p"
by (simp add: cspF_fp_induct_cpo_ref_right_ALL)

lemmas cspF_fp_induct_cpo_right
     = cspF_fp_induct_cpo_ref_right

(*=======================================================*
 |                                                       |
 |                    LFP <--> UFP                       |
 |                                                       |
 |                       MIXmode                         |
 |                                                       |
 *=======================================================*)

lemma semF_guarded_LFP_UFP:
  "[| Pf = PNfun ; guardedfun Pf |]
   ==> LFP ([[Pf]]Ffun) = UFP ([[Pf]]Ffun)"
by (simp add: semF_hasUFP_cms hasUFP_LFP_UFP)

(*----------- refinement -----------*)

(*** left ***)

lemma cspF_fp_induct_mix_ref_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p <=F Q ;
       ALL p. (Pf p)<<f <=F f p |]
    ==> $p <=F Q"
apply (simp add: refF_semF)
apply (insert cms_fixpoint_induction_ref
       [of "[[Pf]]Ffun" "(%p. [[f p]]F)" "UFP ([[Pf]]Ffun)"])
apply (simp add: semF_guarded_LFP_UFP[THEN sym])
apply (simp add: LFP_fp semF_hasLFP_cpo)

apply (simp add: fold_order_prod_def)
apply (simp add: semF_subst_semFfun)
apply (simp add: mono_semFfun)
apply (simp add: contra_alpha_to_contst contraction_alpha_semFfun)
apply (simp add: to_distance_rs)
apply (simp add: order_prod_def)
apply (drule_tac x="p" in spec)+
apply (simp add: semF_LFP_cpo)
done

(*  csp law  *)

lemma cspF_fp_induct_mix_ref_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p <=F Q ;
       !! p. (Pf p)<<f <=F f p |]
    ==> $p <=F Q"
by (simp add: cspF_fp_induct_mix_ref_left_ALL)

(*----------- equality -----------*)

(*** left ***)

lemma cspF_fp_induct_mix_eq_left_ALL:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p =F Q ;
       ALL p. (Pf p)<<f =F f p |]
    ==> $p =F Q"
apply (simp add: eqF_semF)
apply (simp add: fun_eq_iff[THEN sym])
apply (simp add: semF_subst_semFfun)
apply (insert semF_LFP_fun_cpo[of Pf])
apply (simp add: semF_guarded_LFP_UFP)
apply (subgoal_tac "(%p. [[$p]]F) = (%p. [[f p]]F)")
apply (simp add: fun_eq_iff)

apply (rule hasUFP_unique_solution[of "[[Pf]]Ffun"])
apply (simp_all add: semF_hasUFP_cms)
apply (simp add: UFP_fp semF_hasUFP_cms)
done

(*  csp law  *)

lemma cspF_fp_induct_mix_eq_left:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       f p =F Q ;
       !! p. (Pf p)<<f =F f p |]
    ==> $p =F Q"
by (simp add: cspF_fp_induct_mix_eq_left_ALL)

lemma cspF_fp_induct_mix_eq_right:
   "[| Pf = PNfun ;
       guardedfun Pf ;
       FPmode = MIXmode ;
       Q =F f p;
       !! p. f p =F (Pf p)<<f |]
    ==> Q =F $p"
apply (rule cspF_sym)
apply (rule cspF_fp_induct_mix_eq_left[of Pf f p Q])
apply (simp_all)
apply (rule cspF_sym)
apply (simp)
apply (rule cspF_sym)
apply (simp)
done

lemmas cspF_fp_induct_mix_left
     = cspF_fp_induct_mix_ref_left cspF_fp_induct_mix_eq_left

lemmas cspF_fp_induct_mix_right
     = cspF_fp_induct_cpo_ref_right cspF_fp_induct_mix_eq_right

(*=======================================================*
 |                                                       |
 |            mixing CPOmode and CMSmode                 |
 |                                                       |
 *=======================================================*)

lemma cspF_unwind:
   "[| Pf = PNfun ;
       FPmode = CPOmode
     | FPmode = CMSmode & guardedfun Pf
     | FPmode = MIXmode |]
     ==> $p =F Pf p"
apply (erule disjE)
apply (simp add: cspF_unwind_cpo)
apply (erule disjE)
apply (simp add: cspF_unwind_cms)
apply (simp add: cspF_unwind_cpo)
done

lemma cspF_fp_induct_ref_right:
   "[| Pf = PNfun ;
       FPmode = CPOmode
     | FPmode = CMSmode & guardedfun Pf
     | FPmode = MIXmode ;
       Q <=F f p;
       !! p. f p <=F (Pf p)<<f |]
    ==> Q <=F $p"
apply (erule disjE)
apply (simp add: cspF_fp_induct_cpo_right)
apply (erule disjE)
apply (simp add: cspF_fp_induct_cms_right)
apply (simp add: cspF_fp_induct_cpo_right)
done

lemma cspF_fp_induct_ref_left:
   "[| Pf = PNfun ;
       FPmode = CMSmode
     | FPmode = MIXmode ;
       guardedfun Pf ;
       f p <=F Q ;
       !! p. (Pf p)<<f <=F f p |]
    ==> $p <=F Q"
apply (erule disjE)
apply (simp add: cspF_fp_induct_cms_left)
apply (simp add: cspF_fp_induct_mix_left)
done

lemma cspF_fp_induct_eq_left:
   "[| Pf = PNfun ;
       FPmode = CMSmode
     | FPmode = MIXmode ;
       guardedfun Pf ;
       f p =F Q ;
       !! p. (Pf p)<<f =F f p |]
    ==> $p =F Q"
apply (erule disjE)
apply (simp add: cspF_fp_induct_cms_left)
apply (simp add: cspF_fp_induct_mix_left)
done

lemma cspF_fp_induct_eq_right:
   "[| Pf = PNfun ;
       FPmode = CMSmode
     | FPmode = MIXmode ;
       guardedfun Pf ;
       Q =F f p;
       !! p. f p =F (Pf p)<<f |]
    ==> Q =F $p"
apply (erule disjE)
apply (simp add: cspF_fp_induct_cms_right)
apply (simp add: cspF_fp_induct_mix_right)
done

(*** cpo and cms ***)

lemmas cspF_fp_induct_right = cspF_fp_induct_ref_right cspF_fp_induct_eq_right
lemmas cspF_fp_induct_left = cspF_fp_induct_ref_left cspF_fp_induct_eq_left

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
(*
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]
*)
end


(*  Title:      HOL/Auth/Kerberos_BAN_Gets.thy
    Author:     Giampaolo Bella, Catania University
*)

section\<open>The Kerberos Protocol, BAN Version, with Gets event\<close>

theory Kerberos_BAN_Gets imports Public begin

text\<open>From page 251 of
  Burrows, Abadi and Needham (1989).  A Logic of Authentication.
  Proc. Royal Soc. 426

  Confidentiality (secrecy) and authentication properties rely on
  temporal checks: strong guarantees in a little abstracted - but
  very realistic - model.
\<close>

(* Temporal modelization: session keys can be leaked
                          ONLY when they have expired *)

consts

    (*Duration of the session key*)
    sesKlife   :: nat

    (*Duration of the authenticator*)
    authlife :: nat

text\<open>The ticket should remain fresh for two journeys on the network at least\<close>
text\<open>The Gets event causes longer traces for the protocol to reach its end\<close>
specification (sesKlife)
  sesKlife_LB [iff]: "4 \<le> sesKlife"
    by blast

text\<open>The authenticator only for one journey\<close>
text\<open>The Gets event causes longer traces for the protocol to reach its end\<close>
specification (authlife)
  authlife_LB [iff]:    "2 \<le> authlife"
    by blast

abbreviation
  CT :: "event list \<Rightarrow> nat" where
  "CT == length"

abbreviation
  expiredK :: "[nat, event list] \<Rightarrow> bool" where
  "expiredK T evs == sesKlife + T < CT evs"

abbreviation
  expiredA :: "[nat, event list] \<Rightarrow> bool" where
  "expiredA T evs == authlife + T < CT evs"

definition
 (* Yields the subtrace of a given trace from its beginning to a given event *)
  before :: "[event, event list] \<Rightarrow> event list" ("before _ on _")
  where "before ev on evs = takeWhile (\<lambda>z. z \<noteq> ev) (rev evs)"

definition
 (* States than an event really appears only once on a trace *)
  Unique :: "[event, event list] \<Rightarrow> bool" ("Unique _ on _")
  where "Unique ev on evs = (ev \<notin> set (tl (dropWhile (\<lambda>z. z \<noteq> ev) evs)))"

inductive_set bankerb_gets :: "event list set"
 where

   Nil:  "[] \<in> bankerb_gets"

 | Fake: "\<lbrakk> evsf \<in> bankerb_gets;  X \<in> synth (analz (knows Spy evsf)) \<rbrakk>
          \<Longrightarrow> Says Spy B X # evsf \<in> bankerb_gets"

 | Reception: "\<lbrakk> evsr\<in> bankerb_gets; Says A B X \<in> set evsr \<rbrakk>
                \<Longrightarrow> Gets B X # evsr \<in> bankerb_gets"

 | BK1:  "\<lbrakk> evs1 \<in> bankerb_gets \<rbrakk>
          \<Longrightarrow> Says A Server \<lbrace>Agent A, Agent B\<rbrace> # evs1
                \<in>  bankerb_gets"

 | BK2:  "\<lbrakk> evs2 \<in> bankerb_gets;  Key K \<notin> used evs2; K \<in> symKeys;
             Gets Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs2 \<rbrakk>
          \<Longrightarrow> Says Server A
                (Crypt (shrK A)
                   \<lbrace>Number (CT evs2), Agent B, Key K,
                    (Crypt (shrK B) \<lbrace>Number (CT evs2), Agent A, Key K\<rbrace>)\<rbrace>)
                # evs2 \<in> bankerb_gets"

 | BK3:  "\<lbrakk> evs3 \<in> bankerb_gets;
             Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
               \<in> set evs3;
             Says A Server \<lbrace>Agent A, Agent B\<rbrace> \<in> set evs3;
             \<not> expiredK Tk evs3 \<rbrakk>
          \<Longrightarrow> Says A B \<lbrace>Ticket, Crypt K \<lbrace>Agent A, Number (CT evs3)\<rbrace> \<rbrace>
               # evs3 \<in> bankerb_gets"

 | BK4:  "\<lbrakk> evs4 \<in> bankerb_gets;
             Gets B \<lbrace>(Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>),
                         (Crypt K \<lbrace>Agent A, Number Ta\<rbrace>) \<rbrace> \<in> set evs4;
             \<not> expiredK Tk evs4;  \<not> expiredA Ta evs4 \<rbrakk>
          \<Longrightarrow> Says B A (Crypt K (Number Ta)) # evs4
                \<in> bankerb_gets"

        (*Old session keys may become compromised*)
 | Oops: "\<lbrakk> evso \<in> bankerb_gets;
         Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
               \<in> set evso;
             expiredK Tk evso \<rbrakk>
          \<Longrightarrow> Notes Spy \<lbrace>Number Tk, Key K\<rbrace> # evso \<in> bankerb_gets"

declare Says_imp_knows_Spy [THEN parts.Inj, dest]
declare parts.Body [dest]
declare analz_into_parts [dest]
declare Fake_parts_insert_in_Un [dest]
declare knows_Spy_partsEs [elim]

text\<open>A "possibility property": there are traces that reach the end.\<close>
lemma "\<lbrakk>Key K \<notin> used []; K \<in> symKeys\<rbrakk>
       \<Longrightarrow> \<exists>Timestamp. \<exists>evs \<in> bankerb_gets.
             Says B A (Crypt K (Number Timestamp))
                  \<in> set evs"
apply (cut_tac sesKlife_LB)
apply (cut_tac authlife_LB)
apply (intro exI bexI)
apply (rule_tac [2]
           bankerb_gets.Nil [THEN bankerb_gets.BK1, THEN bankerb_gets.Reception,
                            THEN bankerb_gets.BK2, THEN bankerb_gets.Reception,
                            THEN bankerb_gets.BK3, THEN bankerb_gets.Reception,
                            THEN bankerb_gets.BK4])
apply (possibility, simp_all (no_asm_simp) add: used_Cons)
done

text\<open>Lemmas about reception invariant: if a message is received it certainly
was sent\<close>
lemma Gets_imp_Says :
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> \<exists>A. Says A B X \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply auto
done

lemma Gets_imp_knows_Spy:
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> knows Spy evs"
apply (blast dest!: Gets_imp_Says Says_imp_knows_Spy)
done

lemma Gets_imp_knows_Spy_parts[dest]:
    "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> parts (knows Spy evs)"
apply (blast dest: Gets_imp_knows_Spy [THEN parts.Inj])
done

lemma Gets_imp_knows:
     "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> knows B evs"
by (metis Gets_imp_knows_Spy Gets_imp_knows_agents)

lemma Gets_imp_knows_analz:
    "\<lbrakk> Gets B X \<in> set evs; evs \<in> bankerb_gets \<rbrakk>  \<Longrightarrow> X \<in> analz (knows B evs)"
apply (blast dest: Gets_imp_knows [THEN analz.Inj])
done

text\<open>Lemmas for reasoning about predicate "before"\<close>
lemma used_Says_rev: "used (evs @ [Says A B X]) = parts {X} \<union> (used evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_Notes_rev: "used (evs @ [Notes A X]) = parts {X} \<union> (used evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_Gets_rev: "used (evs @ [Gets B X]) = used evs"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply auto
done

lemma used_evs_rev: "used evs = used (rev evs)"
apply (induct_tac "evs")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply (simp add: used_Says_rev)
apply (simp add: used_Gets_rev)
apply (simp add: used_Notes_rev)
done

lemma used_takeWhile_used [rule_format]:
      "x \<in> used (takeWhile P X) \<longrightarrow> x \<in> used X"
apply (induct_tac "X")
apply simp
apply (rename_tac a b)
apply (induct_tac "a")
apply (simp_all add: used_Nil)
apply (blast dest!: initState_into_used)+
done

lemma set_evs_rev: "set evs = set (rev evs)"
apply auto
done

lemma takeWhile_void [rule_format]:
      "x \<notin> set evs \<longrightarrow> takeWhile (\<lambda>z. z \<noteq> x) evs = evs"
apply auto
done

(**** Inductive proofs about bankerb_gets ****)

text\<open>Forwarding Lemma for reasoning about the encrypted portion of message BK3\<close>
lemma BK3_msg_in_parts_knows_Spy:
     "\<lbrakk>Gets A (Crypt KA \<lbrace>Timestamp, B, K, X\<rbrace>) \<in> set evs; evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> X \<in> parts (knows Spy evs)"
apply blast
done

lemma Oops_parts_knows_Spy:
     "Says Server A (Crypt (shrK A) \<lbrace>Timestamp, B, K, X\<rbrace>) \<in> set evs
      \<Longrightarrow> K \<in> parts (knows Spy evs)"
apply blast
done

text\<open>Spy never sees another agent's shared key! (unless it's bad at start)\<close>
lemma Spy_see_shrK [simp]:
     "evs \<in> bankerb_gets \<Longrightarrow> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all, blast+)
done

lemma Spy_analz_shrK [simp]:
     "evs \<in> bankerb_gets \<Longrightarrow> (Key (shrK A) \<in> analz (knows Spy evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk> Key (shrK A) \<in> parts (knows Spy evs);
                evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> A\<in>bad"
by (blast dest: Spy_see_shrK)

lemmas Spy_analz_shrK_D = analz_subset_parts [THEN subsetD, THEN Spy_see_shrK_D,  dest!]

text\<open>Nobody can have used non-existent keys!\<close>
lemma new_keys_not_used [simp]:
    "\<lbrakk>Key K \<notin> used evs; K \<in> symKeys; evs \<in> bankerb_gets\<rbrakk>
     \<Longrightarrow> K \<notin> keysFor (parts (knows Spy evs))"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all)
txt\<open>Fake\<close>
apply (force dest!: keysFor_parts_insert)
txt\<open>BK2, BK3, BK4\<close>
apply (force dest!: analz_shrK_Decrypt)+
done

subsection\<open>Lemmas concerning the form of items passed in messages\<close>

text\<open>Describes the form of K, X and K' when the Server sends this message.\<close>
lemma Says_Server_message_form:
     "\<lbrakk> Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
         \<in> set evs; evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> K' = shrK A \<and> K \<notin> range shrK \<and>
          Ticket = (Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>) \<and>
          Key K \<notin> used(before
                  Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
                  on evs) \<and>
          Tk = CT(before
                  Says Server A (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
                  on evs)"
unfolding before_def
apply (erule rev_mp)
apply (erule bankerb_gets.induct, simp_all)
txt\<open>We need this simplification only for Message 2\<close>
apply (simp (no_asm) add: takeWhile_tail)
apply auto
txt\<open>Two subcases of Message 2. Subcase: used before\<close>
apply (blast dest: used_evs_rev [THEN equalityD2, THEN contra_subsetD]
                   used_takeWhile_used)
txt\<open>subcase: CT before\<close>
apply (fastforce dest!: set_evs_rev [THEN equalityD2, THEN contra_subsetD, THEN takeWhile_void])
done

text\<open>If the encrypted message appears then it originated with the Server
  PROVIDED that A is NOT compromised!
  This allows A to verify freshness of the session key.
\<close>
lemma Kab_authentic:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>
           \<in> parts (knows Spy evs);
         A \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
       \<Longrightarrow> Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
             \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all, blast)
done

text\<open>If the TICKET appears then it originated with the Server\<close>
text\<open>FRESHNESS OF THE SESSION KEY to B\<close>
lemma ticket_authentic:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace> \<in> parts (knows Spy evs);
         B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
       \<Longrightarrow> Says Server A
            (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                          Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
           \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all, blast)
done

text\<open>EITHER describes the form of X when the following message is sent,
  OR     reduces it to the Fake case.
  Use \<open>Says_Server_message_form\<close> if applicable.\<close>
lemma Gets_Server_message_form:
     "\<lbrakk> Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
            \<in> set evs;
         evs \<in> bankerb_gets \<rbrakk>
 \<Longrightarrow> (K \<notin> range shrK \<and> X = (Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>))
          | X \<in> analz (knows Spy evs)"
apply (case_tac "A \<in> bad")
apply (force dest!: Gets_imp_knows_Spy [THEN analz.Inj])
apply (blast dest!: Kab_authentic Says_Server_message_form)
done

text\<open>Reliability guarantees: honest agents act as we expect\<close>

lemma BK3_imp_Gets:
   "\<lbrakk> Says A B \<lbrace>Ticket, Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs;
      A \<notin> bad; evs \<in> bankerb_gets \<rbrakk>
    \<Longrightarrow> \<exists> Tk. Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
      \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply auto
done

lemma BK4_imp_Gets:
   "\<lbrakk> Says B A (Crypt K (Number Ta)) \<in> set evs;
      B \<notin> bad; evs \<in> bankerb_gets \<rbrakk>
  \<Longrightarrow> \<exists> Tk. Gets B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                    Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply auto
done

lemma Gets_A_knows_K:
  "\<lbrakk> Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
     evs \<in> bankerb_gets \<rbrakk>
 \<Longrightarrow> Key K \<in> analz (knows A evs)"
apply (force dest: Gets_imp_knows_analz)
done

lemma Gets_B_knows_K:
  "\<lbrakk> Gets B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
             Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs;
     evs \<in> bankerb_gets \<rbrakk>
 \<Longrightarrow> Key K \<in> analz (knows B evs)"
apply (force dest: Gets_imp_knows_analz)
done

(****
 The following is to prove theorems of the form

  Key K \<in> analz (insert (Key KAB) (knows Spy evs)) \<Longrightarrow>
  Key K \<in> analz (knows Spy evs)

 A more general formula must be proved inductively.

****)

text\<open>Session keys are not used to encrypt other session keys\<close>
lemma analz_image_freshK [rule_format (no_asm)]:
     "evs \<in> bankerb_gets \<Longrightarrow>
   \<forall>K KK. KK \<subseteq> - (range shrK) \<longrightarrow>
          (Key K \<in> analz (Key`KK \<union> (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule bankerb_gets.induct)
apply (drule_tac [8] Says_Server_message_form)
apply (erule_tac [6] Gets_Server_message_form [THEN disjE], analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
     "\<lbrakk> evs \<in> bankerb_gets;  KAB \<notin> range shrK \<rbrakk> \<Longrightarrow>
      (Key K \<in> analz (insert (Key KAB) (knows Spy evs))) =
      (K = KAB | Key K \<in> analz (knows Spy evs))"
by (simp only: analz_image_freshK analz_image_freshK_simps)

text\<open>The session key K uniquely identifies the message\<close>
lemma unique_session_keys:
     "\<lbrakk> Says Server A
           (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>) \<in> set evs;
         Says Server A'
          (Crypt (shrK A') \<lbrace>Number Tk', Agent B', Key K, X'\<rbrace>) \<in> set evs;
         evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> A=A' \<and> Tk=Tk' \<and> B=B' \<and> X = X'"
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] BK3_msg_in_parts_knows_Spy, simp_all)
txt\<open>BK2: it can't be a new key\<close>
apply blast
done

lemma unique_session_keys_Gets:
     "\<lbrakk> Gets A
           (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>) \<in> set evs;
        Gets A
          (Crypt (shrK A) \<lbrace>Number Tk', Agent B', Key K, X'\<rbrace>) \<in> set evs;
        A \<notin> bad; evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow> Tk=Tk' \<and> B=B' \<and> X = X'"
apply (blast dest!: Kab_authentic unique_session_keys)
done

lemma Server_Unique:
     "\<lbrakk> Says Server A
            (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        evs \<in> bankerb_gets \<rbrakk> \<Longrightarrow>
   Unique Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>)
   on evs"
apply (erule rev_mp, erule bankerb_gets.induct, simp_all add: Unique_def)
apply blast
done

subsection\<open>Non-temporal guarantees, explicitly relying on non-occurrence of
oops events - refined below by temporal guarantees\<close>

text\<open>Non temporal treatment of confidentiality\<close>

text\<open>Lemma: the session key sent in msg BK2 would be lost by oops
    if the spy could see it!\<close>
lemma lemma_conf [rule_format (no_asm)]:
     "\<lbrakk> A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
  \<Longrightarrow> Says Server A
          (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
         \<in> set evs \<longrightarrow>
      Key K \<in> analz (knows Spy evs) \<longrightarrow> Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<in> set evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (frule_tac [6] Gets_Server_message_form [THEN disjE])
apply (simp_all (no_asm_simp) add: analz_insert_eq analz_insert_freshK pushes)
txt\<open>Fake\<close>
apply spy_analz
txt\<open>BK2\<close>
apply (blast intro: parts_insertI)
txt\<open>BK3\<close>
apply (case_tac "Aa \<in> bad")
 prefer 2 apply (blast dest: Kab_authentic unique_session_keys)
apply (blast dest: Gets_imp_knows_Spy [THEN analz.Inj] Crypt_Spy_analz_bad elim!: MPair_analz)
txt\<open>Oops\<close>
apply (blast dest: unique_session_keys)
done

text\<open>Confidentiality for the Server: Spy does not see the keys sent in msg BK2
as long as they have not expired.\<close>
lemma Confidentiality_S:
     "\<lbrakk> Says Server A
          (Crypt K' \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
apply (frule Says_Server_message_form, assumption)
apply (blast intro: lemma_conf)
done

text\<open>Confidentiality for Alice\<close>
lemma Confidentiality_A:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: Kab_authentic Confidentiality_S)

text\<open>Confidentiality for Bob\<close>
lemma Confidentiality_B:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
          \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: ticket_authentic Confidentiality_S)

text\<open>Non temporal treatment of authentication\<close>

text\<open>Lemmas \<open>lemma_A\<close> and \<open>lemma_B\<close> in fact are common to both temporal and non-temporal treatments\<close>
lemma lemma_A [rule_format]:
     "\<lbrakk> A \<notin> bad; B \<notin> bad; evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow>
         Key K \<notin> analz (knows Spy evs) \<longrightarrow>
         Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
         \<in> set evs \<longrightarrow>
          Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (knows Spy evs) \<longrightarrow>
         Says A B \<lbrace>X, Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace>
             \<in> set evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] Gets_Server_message_form)
apply (frule_tac [7] BK3_msg_in_parts_knows_Spy, analz_mono_contra)
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>Fake\<close>
apply blast
txt\<open>BK2\<close>
apply (force dest: Crypt_imp_invKey_keysFor)
txt\<open>BK3\<close>
apply (blast dest: Kab_authentic unique_session_keys)
done
lemma lemma_B [rule_format]:
     "\<lbrakk> B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Key K \<notin> analz (knows Spy evs) \<longrightarrow>
          Says Server A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>)
          \<in> set evs \<longrightarrow>
          Crypt K (Number Ta) \<in> parts (knows Spy evs) \<longrightarrow>
          Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Oops_parts_knows_Spy)
apply (frule_tac [6] Gets_Server_message_form)
apply (drule_tac [7] BK3_msg_in_parts_knows_Spy, analz_mono_contra)
apply (simp_all (no_asm_simp) add: all_conj_distrib)
txt\<open>Fake\<close>
apply blast
txt\<open>BK2\<close>
apply (force dest: Crypt_imp_invKey_keysFor)
txt\<open>BK4\<close>
apply (blast dest: ticket_authentic unique_session_keys
                   Gets_imp_knows_Spy [THEN analz.Inj] Crypt_Spy_analz_bad)
done

text\<open>The "r" suffix indicates theorems where the confidentiality assumptions are relaxed by the corresponding arguments.\<close>

text\<open>Authentication of A to B\<close>
lemma B_authenticates_A_r:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (knows Spy evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>  \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
by (blast dest!: ticket_authentic
          intro!: lemma_A
          elim!: Confidentiality_S [THEN [2] rev_notE])

text\<open>Authentication of B to A\<close>
lemma A_authenticates_B_r:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (knows Spy evs);
        Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (knows Spy evs);
        Notes Spy \<lbrace>Number Tk, Key K\<rbrace> \<notin> set evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
by (blast dest!: Kab_authentic
          intro!: lemma_B elim!: Confidentiality_S [THEN [2] rev_notE])

lemma B_authenticates_A:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (spies evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>  \<in> parts (spies evs);
        Key K \<notin> analz (spies evs);
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
apply (blast dest!: ticket_authentic intro!: lemma_A)
done

lemma A_authenticates_B:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (spies evs);
        Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace> \<in> parts (spies evs);
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
apply (blast dest!: Kab_authentic intro!: lemma_B)
done

subsection\<open>Temporal guarantees, relying on a temporal check that insures that
no oops event occurred. These are available in the sense of goal availability\<close>

text\<open>Temporal treatment of confidentiality\<close>

text\<open>Lemma: the session key sent in msg BK2 would be EXPIRED
    if the spy could see it!\<close>
lemma lemma_conf_temporal [rule_format (no_asm)]:
     "\<lbrakk> A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
  \<Longrightarrow> Says Server A
          (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K,
                            Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>\<rbrace>)
         \<in> set evs \<longrightarrow>
      Key K \<in> analz (knows Spy evs) \<longrightarrow> expiredK Tk evs"
apply (erule bankerb_gets.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (frule_tac [6] Gets_Server_message_form [THEN disjE])
apply (simp_all (no_asm_simp) add: less_SucI analz_insert_eq analz_insert_freshK pushes)
txt\<open>Fake\<close>
apply spy_analz
txt\<open>BK2\<close>
apply (blast intro: parts_insertI less_SucI)
txt\<open>BK3\<close>
apply (case_tac "Aa \<in> bad")
 prefer 2 apply (blast dest: Kab_authentic unique_session_keys)
apply (blast dest: Gets_imp_knows_Spy [THEN analz.Inj] Crypt_Spy_analz_bad elim!: MPair_analz intro: less_SucI)
txt\<open>Oops: PROOF FAILS if unsafe intro below\<close>
apply (blast dest: unique_session_keys intro!: less_SucI)
done

text\<open>Confidentiality for the Server: Spy does not see the keys sent in msg BK2
as long as they have not expired.\<close>
lemma Confidentiality_S_temporal:
     "\<lbrakk> Says Server A
          (Crypt K' \<lbrace>Number T, Agent B, Key K, X\<rbrace>) \<in> set evs;
         \<not> expiredK T evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
apply (frule Says_Server_message_form, assumption)
apply (blast intro: lemma_conf_temporal)
done

text\<open>Confidentiality for Alice\<close>
lemma Confidentiality_A_temporal:
     "\<lbrakk> Crypt (shrK A) \<lbrace>Number T, Agent B, Key K, X\<rbrace> \<in> parts (knows Spy evs);
         \<not> expiredK T evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: Kab_authentic Confidentiality_S_temporal)

text\<open>Confidentiality for Bob\<close>
lemma Confidentiality_B_temporal:
     "\<lbrakk> Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
          \<in> parts (knows Spy evs);
        \<not> expiredK Tk evs;
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets
      \<rbrakk> \<Longrightarrow> Key K \<notin> analz (knows Spy evs)"
by (blast dest!: ticket_authentic Confidentiality_S_temporal)

text\<open>Temporal treatment of authentication\<close>

text\<open>Authentication of A to B\<close>
lemma B_authenticates_A_temporal:
     "\<lbrakk> Crypt K \<lbrace>Agent A, Number Ta\<rbrace> \<in> parts (knows Spy evs);
         Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>
         \<in> parts (knows Spy evs);
         \<not> expiredK Tk evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                     Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs"
by (blast dest!: ticket_authentic
          intro!: lemma_A
          elim!: Confidentiality_S_temporal [THEN [2] rev_notE])

text\<open>Authentication of B to A\<close>
lemma A_authenticates_B_temporal:
     "\<lbrakk> Crypt K (Number Ta) \<in> parts (knows Spy evs);
         Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, X\<rbrace>
         \<in> parts (knows Spy evs);
         \<not> expiredK Tk evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
      \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs"
by (blast dest!: Kab_authentic
          intro!: lemma_B elim!: Confidentiality_S_temporal [THEN [2] rev_notE])

subsection\<open>Combined guarantees of key distribution and non-injective agreement on the session keys\<close>

lemma B_authenticates_and_keydist_to_A:
     "\<lbrakk> Gets B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs;
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
    \<Longrightarrow> Says A B \<lbrace>Crypt (shrK B) \<lbrace>Number Tk, Agent A, Key K\<rbrace>,
                  Crypt K \<lbrace>Agent A, Number Ta\<rbrace>\<rbrace> \<in> set evs
     \<and>  Key K \<in> analz (knows A evs)"
apply (blast dest: B_authenticates_A BK3_imp_Gets Gets_A_knows_K)
done

lemma A_authenticates_and_keydist_to_B:
     "\<lbrakk> Gets A (Crypt (shrK A) \<lbrace>Number Tk, Agent B, Key K, Ticket\<rbrace>) \<in> set evs;
        Gets A (Crypt K (Number Ta)) \<in> set evs;
        Key K \<notin> analz (spies evs);
        A \<notin> bad;  B \<notin> bad;  evs \<in> bankerb_gets \<rbrakk>
    \<Longrightarrow> Says B A (Crypt K (Number Ta)) \<in> set evs
    \<and>   Key K \<in> analz (knows B evs)"
apply (blast dest: A_authenticates_B BK4_imp_Gets Gets_B_knows_K)
done

end


theory MPA
imports OpSem
begin

datatype PC =
  L1
| L2
| L3

consts t1 :: T
consts t2 :: T
consts d :: L
consts f :: L

definition "thrdsvars \<equiv> t1 \<noteq> t2 \<and>
                        d \<noteq> f"

record mp_state =
  pc :: "T \<Rightarrow> PC"
  state :: surrey_state
  r :: V

definition
  "update_pc t nv pcf \<equiv> pcf (t := nv)"

lemmas mp_sis [simp] =
  update_pc_def
  thrdsvars_def

definition prog :: "T \<Rightarrow>  mp_state \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog t s s' \<equiv>
(
  if t = t1
    then
      if (pc s) t = L1
        then
           pc s'  = update_pc t L2 (pc s) \<and>
           (state s) [d:=5]\<^sub>t (state s') \<and>
           r s = r s'
        else
          if (pc s) t = L2
            then
              pc s' = update_pc t L3 (pc s) \<and>
              (state s) [f:=\<^sup>R 1]\<^sub>t (state s') \<and>
              r s = r s'
            else
              False
  else
    if t = t2
      then
        if (pc s) t = L1
          then
            (pc s' = update_pc t L2 (pc s) \<and>
            ((state s) [1 \<leftarrow>\<^sup>A f]\<^sub>t (state s')))
            \<or>
            (pc s'  = pc s \<and>
            (\<exists> v . v \<noteq> 1 \<and> ((state s) [v \<leftarrow>\<^sup>A f]\<^sub>t (state s'))))
         else
          if (pc s) t = L2
            then
              pc s' = update_pc t L3 (pc s) \<and>
              ((state s) [r s' \<leftarrow> d]\<^sub>t (state s'))
            else
              False
   else
    False
)"

definition prog_inv :: "T \<Rightarrow> PC \<Rightarrow> mp_state \<Rightarrow> bool " where
"prog_inv t p s \<equiv> let t' = t2 in
  if t = t1
    then
      (case p of
          L1 \<Rightarrow> (\<not> [f \<approx>\<^sub>t' 1] (state s)) \<and> [d =\<^sub>t 0] (state s)
        | L2 \<Rightarrow> (\<not> [f \<approx>\<^sub>t' 1] (state s)) \<and> [d =\<^sub>t 5] (state s)
        | L3 \<Rightarrow> [d =\<^sub>t 5] (state s)
      )
  else
     if t = t2 then
      (case p of
          L1 \<Rightarrow> [f = 1]\<^sub>t \<lparr>d = 5\<rparr> (state s)
        | L2 \<Rightarrow> [d =\<^sub>t 5] (state s)
        | L3 \<Rightarrow> r s = 5
      )
  else False
"

(*initial_state \<sigma> I*)
definition init_map  :: "(L \<Rightarrow> V) \<Rightarrow> bool" where
  "init_map \<phi> \<equiv> \<phi> d = 0 \<and> \<phi> f = 0"

definition init_s  :: "surrey_state  \<Rightarrow> bool"
  where
    "init_s ss \<equiv> \<exists> \<phi>. initial_state ss \<phi> \<and> init_map \<phi>"

definition init  :: "mp_state  \<Rightarrow> bool"
  where
    "init s \<equiv> (pc s) t1 = L1
      \<and> (pc s) t2 = L1
    \<and> init_s (state s)"

lemma init_only_one_write : "initial_state \<sigma>  \<phi> \<Longrightarrow>  w1 \<in> (writes_on \<sigma> x) \<Longrightarrow>  w2 \<in> (writes_on \<sigma> x) \<Longrightarrow> tst w1 = tst w2 \<and> w1 = w2"
  apply (unfold initial_state_def value_def lastWr_def writes_on_def)
  apply simp
  apply clarify by auto

lemma thrdView_of_init : "initial_state \<sigma> \<phi> \<Longrightarrow> (x, ts) \<in> writes \<sigma> \<Longrightarrow>  thrView \<sigma> t x = (x, ts) "
  apply (unfold initial_state_def)
  apply simp
  using init_only_one_write
  by clarsimp

lemma init_writes_write_on [simp]: "initial_state \<sigma> \<phi> \<Longrightarrow> (x, ts) \<in> writes \<sigma> \<Longrightarrow> (x, ts) \<in> writes_on \<sigma> x"
  apply (unfold initial_state_def writes_on_def)
  by simp

lemma [simp]: "initial_state \<sigma>  \<phi> \<Longrightarrow>  thrView \<sigma> t x = lastWr \<sigma> x"
  apply (unfold lastWr_def)
  apply (case_tac "\<exists> x ts . (x, ts) \<in> writes \<sigma>")
  defer
  apply (metis (full_types) initial_wfs initially_write_unique lastWr_def last_write_write_on wfs_def)
  apply clarsimp
  apply (case_tac "xa = x") defer
   apply (metis init_only_one_write initial_wfs lastWr_def last_write_write_on wfs_def)
 apply clarsimp
  apply (case_tac "(x, ts) \<in> writes_on \<sigma> x") defer
   apply simp
  by (metis init_only_one_write initial_wfs lastWr_def last_write_write_on thrdView_of_init)

lemma init_post_inv : "init s \<Longrightarrow>  d_obs_t (state s) t f 0 \<and>  d_obs_t (state s) t d 0"
  apply (unfold init_def init_s_def  init_map_def d_obs_t_def d_obs_def)
  by clarsimp

lemma t1_local:
  assumes "thrdsvars"
      and "wfs (state s)"
      and "prog_inv t1 ((pc s) t1) s"
      and "prog t1 s s'"
    shows "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply (simp add: prog_def prog_inv_def)
  apply (cases "pc s t1", auto)
  apply (metis One_nat_def not_p_obs_WrX_val_pres numeral_eq_one_iff semiring_norm(86))
  using d_obs_WrX_set apply blast
  using d_obs_WrR_other  by blast

lemma t1_global :
  assumes "prog_inv t1 ((pc s) t1) s"
   and "prog_inv t2 ((pc s) t2) s"
  and "thrdsvars"
  and "prog t2 s s'"
shows  "prog_inv t1 ((pc s') t1) s'"
  using assms
  apply (simp add: prog_inv_def prog_def)
  apply (cases "(pc s) t1", auto)
  apply (cases "(pc s) t2", auto)
  using not_pobs_RdA_pres apply blast
  using dobs_RdA_pres apply blast
  using not_pobs_RdA_pres apply blast
  using dobs_RdA_pres apply blast
  using not_pobs_RdX_pres apply blast
  using dobs_RdX_pres apply blast
  apply (cases "(pc s) t2", auto)
  using not_pobs_RdA_pres apply blast
  using dobs_RdA_pres apply blast
  using not_pobs_RdA_pres apply blast
  using dobs_RdA_pres apply blast
  using not_pobs_RdX_pres apply blast
  using dobs_RdX_pres apply blast
  apply (cases "(pc s) t2", auto)
  using dobs_RdA_pres apply blast
  using dobs_RdA_pres apply blast
  using dobs_RdX_pres by blast

(*
lemma t1_global:
  assumes "thrdsvars"
      and "prog_inv t1 ((pc s) t2) s"
      and "prog t2 s s'"
    shows "prog_inv t1 ((pc s') t2) s'"
  using assms
  apply (simp add: prog_inv_def prog_def)
  apply (case_tac "pc s t2", auto)
  using not_pobs_RdA_pres apply blast+
  apply (simp add: RdA_def p_obs_Rd_intro2)
  using not_pobs_RdA_pres apply blast
  using dobs_RdA_pres apply blast
  using dobs_RdX_pres by blast
*)

lemma t2_local:
  assumes "thrdsvars"
      and "wfs (state s)"
      and "prog_inv t2 ((pc s) t2) s"
      and "prog t2 s s'"
    shows "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply (simp add: prog_def prog_inv_def)
  apply (cases "pc s t2", auto)
  using c_obs_RdA_d_obs apply blast
  using cobs_RdA_pres apply auto[1]
  using RdX_def d_obs_p_obs_agree p_obs_Rd_intro2 by fastforce

lemma t2_global :
  assumes "wfs (state s)"
    and "prog_inv t2 ((pc s) t2) s"
   and "prog_inv t1 ((pc s) t1) s"
  and "thrdsvars"
  and "prog t1 s s'"
shows  "prog_inv t2 ((pc s') t2) s'"
  using assms
  apply (simp add: prog_inv_def prog_def)
  apply (cases "(pc s) t2", auto)
  apply (cases "(pc s) t1", auto)
  apply (metis not_p_obs_WrX_pres not_p_obs_implies_c_obs)
  apply (metis c_obs_WrR_intro)
  apply (cases "(pc s) t1", auto)
  apply (simp add: d_obs_def d_obs_t_def)
  apply (metis dobs_WrR_pres)
  by (metis (full_types) PC.simps(9) fun_upd_other update_pc_def)

theorem final_inv:
  assumes "wfs (state s)"
  and "thrdsvars"
  and "t \<in> {t1, t2}"
  and "t' \<in> {t1, t2}"
  and "prog_inv t ((pc s) t) s"
  and "prog_inv t' ((pc s) t') s"
  and "prog t' s s'"
shows "prog_inv t ((pc s') t) s'"
  using assms apply (simp del: thrdsvars_def)
  using t1_global t1_local t2_global t2_local by blast

end

(*
\<comment> \<open>Don't need the following two lemmas anymore\<close>
lemma init_wfs :  "init s \<Longrightarrow> wfs (state s)"
  apply (unfold init_def wfs_def init_s_def)
  using initial_wfs wfs_def by blast

lemma wfs_inv: "wfs (state s) \<Longrightarrow> prog t s s' \<Longrightarrow> wfs (state s')"
  apply (unfold wfs_def prog_def)
  apply clarsimp
  apply (case_tac "t = t1")
  apply (cases "(pc s) t")
  apply clarsimp
  apply (metis fst_conv prod.exhaust_sel var_def wfs_def wfs_preserved)
    apply clarsimp
  apply (metis fst_conv prod.exhaust_sel var_def wfs_def wfs_preserved)
  apply clarsimp
  by (metis fst_conv prod.exhaust_sel var_def wfs_def wfs_preserved)
*)


(* Title:     Quantum-Semantics/QSyntax.thy
   Author:    David Sanan, Nanyang Technological University
   Copyright   2020
   License:     BSD
*)

theory QSyntax
  imports HOL.Complex vars HOL.Orderings   Q_State vars
begin

subsection \<open>Syntax\<close>

text \<open>Datatype for quantum programs\<close>
text \<open>State definition\<close>

\<comment>\<open>Following the semantics of Quantum_Sep, the state is composed of
  a triple (\<delta>,\<sigma>,Q), where \<delta> is a real representing probability, \<sigma> represents
the stack and Q represents the quatum state\<close>

\<comment>\<open>The stack is similar to Quantum_Sep, but this stack does not have
  quantum variables, which have been moved to the quantum state.
 The quantum state is composed of a non-fixed list of quantum variables
represented by their position index, and a vector of complex number
  representing the current state of the quibits.
  Each quantum variable contains a set of address of type 'q that has to be
 a lineal order. These addresses correspond with a quibit of the complex vector.
The vector represents the different components of the base representing
the quibits. Since the quantum state is the result of the tensor product
of the different variables, the vector dimension is the product of the size of each
variable\<close>

type_synonym q_vars = "(nat \<Rightarrow>nat set)"
type_synonym  qstate = "q_vars \<times> (complex) QState"
type_synonym qheap = "nat set \<times> complex vec"
type_synonym 's state = "real \<times> 's \<times>  qstate"
type_synonym 's pred = "'s \<Rightarrow> bool"
type_synonym 's assn = "'s set"
type_synonym 's expr_q = "'s\<times>q_vars \<Rightarrow> nat set"
type_synonym 's expr_c = "'s \<Rightarrow> complex"
type_synonym 's expr_nat = "'s \<Rightarrow> nat"
type_synonym 's expr_t = "'s \<Rightarrow> nat"
type_synonym 's expr_a = "'s \<Rightarrow> nat"
type_synonym ('s,'b) expr = "'s \<Rightarrow> 'b"

definition get_prob ::"'s state \<Rightarrow> real"
  where "get_prob \<sigma> = fst \<sigma>"

definition get_qstate ::"'s state \<Rightarrow> qstate"
  where "get_qstate \<sigma> = snd (snd \<sigma>)"

definition get_stack::"'s state \<Rightarrow> 's"
  where "get_stack \<sigma> = fst (snd \<sigma>)"

definition set_prob ::"'s state \<Rightarrow> real \<Rightarrow> 's state"
  where "set_prob \<sigma> v = (v, get_stack \<sigma>, get_qstate \<sigma>)"

definition set_qstate ::"'s state \<Rightarrow> qstate \<Rightarrow> 's state"
  where "set_qstate \<sigma> v = (get_prob \<sigma>, get_stack \<sigma>, v)"

definition set_stack::"'s state \<Rightarrow> 's \<Rightarrow> 's state"
  where "set_stack \<sigma> v = (get_prob \<sigma>, v, get_qstate \<sigma>)"

datatype 's XQState = Normal "'s state" | Fault

datatype ('a, 's) com =
    Skip
  | SMod "'s \<Rightarrow> 's"
  | QMod "complex Matrix.mat" "'s expr_q"
  | IF "'s assn" "('a, 's) com" "('a, 's) com"
  | While "'s assn" "('a, 's) com"
  | Seq "('a, 's) com" "('a, 's) com"  ("_;;/ _" [60, 61] 60)
  | Measure "'a"   "'s expr_q" ("_:=meassure / _" [60, 61] 60)
  | Alloc "'a"  "('s,nat) expr"  "('s,complex list) expr"  ("_:=alloc[_] (_)" [60, 61] 60)
  | Dispose "('s,nat) expr"

type_synonym ('v,'b,'s) QConf = "('v,'s) com \<times> 's XQState"

definition Q_domain::"q_vars \<Rightarrow> nat set"
  where "Q_domain q_vars \<equiv> \<Union> (q_vars ` UNIV)"

definition ket_dim ::"q_vars \<Rightarrow> nat"
  where "ket_dim q_vars \<equiv>  card (Q_domain q_vars)"

definition new_q_addr::"('s \<Rightarrow> nat) \<Rightarrow> 's state \<Rightarrow> (nat set) set"
  where "new_q_addr f \<sigma>  \<equiv> {s.  card s = (f (get_stack \<sigma>)) \<and> (Min s > Max (Q_domain (fst (get_qstate \<sigma>))))}"

lemma all_gt: "finite s' \<Longrightarrow> finite s \<Longrightarrow>
       Min s > Max s' \<Longrightarrow> e \<in> s \<Longrightarrow> e' \<in> s' \<Longrightarrow> e > e'"
  using Max_less_iff less_le_trans by fastforce

lemma neq_q_addr_finites:"f (get_stack \<sigma>)\<noteq>0 \<Longrightarrow> S \<in> new_q_addr f \<sigma> \<Longrightarrow> finite S"
  unfolding new_q_addr_def
  using card_infinite by force

lemma new_q_addr_gt_old_q_addr:
  "f (get_stack \<sigma>)\<noteq>0 \<Longrightarrow> finite (Q_domain (fst (get_qstate \<sigma>))) \<Longrightarrow>
   S \<in> new_q_addr f \<sigma> \<Longrightarrow> e \<in> S \<Longrightarrow>
   e' \<in> (Q_domain (fst (get_qstate \<sigma>))) \<Longrightarrow> e > e'"
  unfolding new_q_addr_def using all_gt
  by (metis (mono_tags, lifting) card_infinite mem_Collect_eq)

lemma new_q_addr_ortho_old_q_addr:
  assumes a0:"f (get_stack \<sigma>)\<noteq>0" and a1:"finite  (Q_domain (fst (get_qstate \<sigma>)))" and a2:"S \<in> new_q_addr f \<sigma>"
  shows "S \<subseteq> - (Q_domain (fst (get_qstate \<sigma>)))"
proof -
  have f4: "card S = f (get_stack \<sigma>) \<and> Max (Q_domain (fst (get_qstate \<sigma>))) < Min S"
    using a2 unfolding new_q_addr_def  by fastforce
  then have "card S \<noteq> 0"
    using a0 by simp
  then have "finite S"
    by (meson card_infinite)
  then show ?thesis
    using f4 a1 by (meson ComplI Max.coboundedI Min.coboundedI le_less_trans
                    less_le_not_le subsetI)
qed

(* definition list_dims_set::"'q set \<Rightarrow> nat list"
  where "list_dims_set qvars \<equiv> if qvars = {} then [1]
                            else replicate (card qvars) 2"

definition list_dims::"'q::linorder set \<Rightarrow> nat list"
  where "list_dims qvars \<equiv> replicate (card qvars) 2" *)

definition dom_q_vars::"q_vars \<Rightarrow> nat set"
  where "dom_q_vars q_vars \<equiv> Set.filter (\<lambda>e. q_vars e\<noteq>{}) UNIV"

definition dims_heap::"q_vars \<Rightarrow> nat list"
  where "dims_heap q_vars \<equiv> (list_dims o Q_domain) q_vars"

definition qvars_lin_set::"q_vars \<Rightarrow> nat set"
  where "qvars_lin_set q_vars \<equiv> {0 ..< (ket_dim q_vars)}"

definition qvars_lin_sets::"q_vars \<Rightarrow> q_vars \<Rightarrow> nat set"
  where "qvars_lin_sets q_vars q_vars' \<equiv> {(ket_dim q_vars) ..< (ket_dim q_vars')}"

(* definition top_lin_set::"'q set \<Rightarrow> nat" where
  "top_lin_set qset \<equiv> if qset = {} then 1 else card qset"

definition lin_set_alt::"'q set \<Rightarrow> nat set"
  where "lin_set_alt qset \<equiv> if qset = {} then {0} else {0 ..< (card qset)}"

definition lin_sets_alt::"nat \<Rightarrow> 'q set \<Rightarrow> nat set"
  where "lin_sets_alt n q_vars' \<equiv> if q_vars' = {} then  {n}
                                   else  {n ..< card (q_vars')}"

definition lin_set::"'q::linorder set \<Rightarrow> nat set"
  where "lin_set qset \<equiv> {0 ..< (card qset)}"

definition lin_sets::"'q::linorder set \<Rightarrow> 'q::linorder set \<Rightarrow> nat set"
  where "lin_sets q_vars q_vars' \<equiv> {card (q_vars) ..< card (q_vars')}"
*)

definition sorted_list_from_set::"'q::linorder set \<Rightarrow> 'q::linorder list"
  where "sorted_list_from_set s \<equiv> THE l. strict_sorted l \<and> set l = s"

definition to_heap::"qstate \<Rightarrow> (complex) QState"
  where "to_heap q \<equiv> (snd q)"

definition projection1::"nat \<Rightarrow> nat \<Rightarrow> 'a::comm_ring_1 mat" ("1\<^sub>_ _") where
  "projection1 k n \<equiv> mat n n (\<lambda> (i,j). if i = k \<and> j = k then 1 else 0)"

locale h = vars + partial_state2

context h
begin

lemma "(l::('a, 's) com) = l"
  by auto

end

end


theory RubyType
imports PureRuby
begin

consts
  pure :: "i"

inductive
  domains "pure" <= "(ChEl <~> ChEl) * ChTy * ChTy"
  intros
    spread: "\<lbrakk> A:ChTy; B:ChTy; f:A~B \<rbrakk> \<Longrightarrow> <spread(f), A, B>:pure"
    delay: "A:ChTy \<Longrightarrow> <D(A), A, A>:pure"
    comp: "\<lbrakk> <R, A, B>:pure; <S, B, C>:pure \<rbrakk> \<Longrightarrow> <R;;S, A, C>:pure"
    par: "\<lbrakk> <R, A1, B1>:pure; <S, A2, B2>:pure \<rbrakk> \<Longrightarrow> <[[R,S]], A1*A2, B1*B2>:pure"
  type_intros spread_chel_rel D_chel_rel comp_type par_chel_rel prod_in_chty

definition rrel :: "[i, i] \<Rightarrow> i" ("(_<R>/_)" [73, 72] 72) where
  "A<R>B == {r:A<~>B. <r, A, B>:pure}"

theorem pure_induct:
  "\<lbrakk> <x3, x2, x1>:pure;
    \<And> A B f. \<lbrakk> A:ChTy; B:ChTy; f:A~B \<rbrakk> \<Longrightarrow> P_pure4(spread(f), A, B);
    \<And> A. A:ChTy \<Longrightarrow> P_pure4(D(A), A, A);
    \<And> A B C R S. \<lbrakk> <R, A, B>:pure; <S, B, C>:pure;
      P_pure4(R, A, B); P_pure4(S, B, C) \<rbrakk> \<Longrightarrow> P_pure4(R ;; S, A, C);
    \<And> A1 A2 B1 B2 R S. \<lbrakk> <R, A1, B1>:pure; <S, A2, B2>:pure;
      P_pure4(R, A1, B1); P_pure4(S, A2, B2) \<rbrakk> \<Longrightarrow> P_pure4([[R,S]], A1*A2, B1*B2) \<rbrakk>
  \<Longrightarrow> P_pure4(x3, x2, x1)"
apply(rule pure.induct, simp_all)
done

theorem pure_rel: "<R, A, B>:pure \<Longrightarrow> R:A<~>B"
apply(rule pure.induct, simp)
apply(erule spread_type)
apply(rule delay_type)
apply(rule comp_type, simp, simp)
apply(rule par_type, simp+)
done

theorem ruby_induct:
  "\<lbrakk> R: A<R>B;
    \<And> f A B. f:A~B \<Longrightarrow> P(A, B, spread(f));
    \<And> A. P(A, A, D(A));
    \<And> R S A B C.
      \<lbrakk> R:A<R>B; S:B<R>C; P(A, B, R); P(B, C, S) \<rbrakk>
      \<Longrightarrow> P(A, C, R;;S);
    \<And> R S A1 A2 B1 B2.
      \<lbrakk> R:A1<R>B1; S:A2<R>B2; P(A1, B1, R); P(A2, B2, S) \<rbrakk>
      \<Longrightarrow> P(A1*A2, B1*B2, [[R,S]]) \<rbrakk> \<Longrightarrow> P(A, B, R)"
apply(auto simp add: rrel_def)
apply(rule pure_induct, simp+)
apply(frule pure_rel) back
apply(frule pure_rel) back back
apply(simp)
apply(frule pure_rel) back
apply(frule pure_rel) back back
apply(simp)
done

theorem ruby_sub_sig: "A<R>B \<subseteq> A<~>B"
apply(auto simp add: rrel_def)
done

theorem spreadR: "\<lbrakk> A:ChTy; B:ChTy; f:A~B \<rbrakk> \<Longrightarrow> spread(f):A<R>B"
apply(auto simp add: rrel_def)
apply(insert spread_type[of f A B], blast)
apply(rule pure.spread, simp+)
done

theorem delayR: "A:ChTy \<Longrightarrow> D(A):A<R>A"
apply(auto simp add: rrel_def)
apply(insert delay_type[of A], blast)
apply(rule pure.delay, simp+)
done

theorem compR: "\<lbrakk> R:A<R>C; S:C<R>B \<rbrakk> \<Longrightarrow> R;;S:A<R>B"
apply(auto simp add: rrel_def)
apply(insert comp_type[of R "sig(A)" "sig(C)" S "sig(B)"], blast)
apply(rule pure.comp, simp+)
done

theorem parR: "\<lbrakk> R:A1<R>B1; S:A2<R>B2 \<rbrakk> \<Longrightarrow> [[R,S]]:A1*A2<R>B1*B2"
apply(auto simp add: rrel_def)
apply(insert par_type[of R A1 B1 S A2 B2], blast)
apply(rule pure.par, simp+)
done

theorem rrelD1: "R:A<R>B \<Longrightarrow> A:ChTy"
apply(auto simp add: rrel_def)
apply(insert dom_subset, blast)
done

theorem rrelD2: "R:A<R>B \<Longrightarrow> B:ChTy"
apply(auto simp add: rrel_def)
apply(insert dom_subset, auto)
done

lemmas RubyR =
  spreadR delayR compR parR

lemmas Ruby_ch =
  Ruby_ch rrelD1 rrelD2

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory RWHelper_DP
imports ProofHelpers_DP KHeap_DP
begin

definition eq_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> bool"
where "eq_on m s s' \<equiv> \<forall>ptr\<in> m. s ptr = s' ptr"

lemma eq_on_subset:
  "\<lbrakk>B \<subseteq> A ; eq_on A s s' \<rbrakk> \<Longrightarrow> eq_on B s s'"
  by (auto simp:eq_on_def)

definition WritingOf :: "(('a \<Rightarrow>'b option) \<Rightarrow> ('a \<Rightarrow> 'b option)) \<Rightarrow> 'a set"
where "WritingOf f \<equiv> UN s:UNIV. {ptr. (f s) ptr \<noteq> s ptr} "

definition IsReadingEstimateOf :: "'a set \<Rightarrow> (('a \<Rightarrow> 'b option) \<Rightarrow> ('a \<Rightarrow> 'b option)) \<Rightarrow> 'a set \<Rightarrow> bool"
  where "IsReadingEstimateOf m f estimate \<equiv> (\<forall>s s'. (eq_on m s s') \<longrightarrow> (eq_on estimate (f s) (f s')))"

definition ReadingEstimateOf :: "(('a \<Rightarrow>'b option) \<Rightarrow> ('a \<Rightarrow> 'b option)) \<Rightarrow> ('a set) \<Rightarrow> ('a set)"
where "ReadingEstimateOf f estimate \<equiv> Inter {m. IsReadingEstimateOf m f estimate }"

abbreviation ReadingOf :: "(('a \<Rightarrow>'b option) \<Rightarrow> ('a \<Rightarrow> 'b option)) \<Rightarrow> 'a set"
where "ReadingOf f \<equiv>  ReadingEstimateOf f (WritingOf f)"

lemma eq_on_trans:
  "\<lbrakk>eq_on a s sa ; eq_on a sa sb\<rbrakk> \<Longrightarrow> eq_on a s sb"
  by (simp add:eq_on_def)

lemma ReadingEstimateOf_inter:
  "\<lbrakk>IsReadingEstimateOf a f r; IsReadingEstimateOf b f r \<rbrakk> \<Longrightarrow> IsReadingEstimateOf (a \<inter> b) f r"
  apply (clarsimp simp:IsReadingEstimateOf_def)
  apply (drule_tac x = s in spec)
  apply (drule_tac x = "(\<lambda>ptr. if ptr\<in>(b - a) then (s' ptr) else (s ptr))" in spec)
  apply (drule_tac x = "(\<lambda>ptr. if ptr\<in>(b - a) then (s' ptr) else (s ptr))" in spec)
  apply (drule_tac x = s' in spec)
  apply (erule impE)
   apply (simp add:eq_on_def)
  apply (erule impE)
   apply (simp add:eq_on_def)
  apply (rule eq_on_trans)
  apply simp+
  done

lemma ReadingEstimateOf_read_subset:
  "\<lbrakk>IsReadingEstimateOf a f w;  a \<subseteq> b\<rbrakk> \<Longrightarrow> IsReadingEstimateOf b f w"
  by (auto simp add:IsReadingEstimateOf_def eq_on_def)

lemma ReadingEstimateOf_write_subset:
  "\<lbrakk>IsReadingEstimateOf a f w;  w' \<subseteq> w\<rbrakk> \<Longrightarrow> IsReadingEstimateOf a f w'"
  by (auto simp add:IsReadingEstimateOf_def eq_on_def)

lemma reading_estimateD:
  "\<lbrakk>IsReadingEstimateOf a f w; eq_on a s s'\<rbrakk> \<Longrightarrow> eq_on w (f s) (f s')"
  by (auto simp:IsReadingEstimateOf_def)

lemma not_writingD:
  "ptr \<notin> WritingOf f \<Longrightarrow> (f s) ptr = s ptr"
  by (auto simp:WritingOf_def)

lemma well_ordered_estimate:
  "WritingOf f \<subseteq> writing_estimate \<Longrightarrow>
    ReadingOf f \<subseteq> ReadingEstimateOf f writing_estimate"
  by (auto simp add:IsReadingEstimateOf_def ReadingEstimateOf_def eq_on_subset)

lemma writing_estimate_pipe:
  "\<lbrakk>WritingOf f \<subseteq> Q; WritingOf g \<subseteq> Q\<rbrakk> \<Longrightarrow> WritingOf (f\<circ>g) \<subseteq> Q"
  apply (subst WritingOf_def)
  apply clarsimp
  apply (rule ccontr)
  apply (drule(1) contra_subsetD)+
  apply (drule_tac s = "g xa" in not_writingD)
  apply (drule_tac s = xa in not_writingD)
  apply simp
  done

lemma reading_writing_estimate:
  "\<lbrakk>eq_on R s s'; IsReadingEstimateOf R g (WritingOf g)\<rbrakk> \<Longrightarrow> eq_on R (g s) (g s')"
  apply (subst eq_on_def)
  apply clarsimp
  apply (case_tac "ptr \<in> WritingOf g")
   apply (clarsimp simp:IsReadingEstimateOf_def)
   apply (elim impE allE)
    apply simp
   apply (clarsimp simp:eq_on_def)
  apply (clarsimp simp:WritingOf_def eq_on_def)
  done

lemma reading_estimate_pipe:
  assumes reg: "IsReadingEstimateOf R g M"
  and ref: " IsReadingEstimateOf R f M"
  and wg: "WritingOf g \<subseteq> M"
  and wf: "WritingOf f \<subseteq> M"
  shows "IsReadingEstimateOf R (f \<circ> g) M"
  apply (clarsimp simp: IsReadingEstimateOf_def)
  apply (cut_tac ReadingEstimateOf_write_subset[OF reg wg])
  apply (drule(1) reading_writing_estimate[rotated])
  apply (erule reading_estimateD[OF ref])
  done

definition
  "IsSepWritingEstimateOf f P proj m \<equiv> \<forall>ptr v.
  \<lbrace>\<lambda>s. (proj s) ptr = v \<and> P s \<and> ptr \<in> (UNIV - m) \<rbrace> f \<lbrace>\<lambda>r s. (proj s) ptr = v \<rbrace>"

definition
  "IsStrongSepWritingEstimateOf f P proj m g \<equiv> \<forall>state.
  \<lbrace>\<lambda>s. (proj s) = state \<and> P s \<rbrace> f
  \<lbrace>\<lambda>r s. (proj s) |` m = (g state) \<and> (proj s) |` (UNIV - m) = state |` (UNIV - m)\<rbrace>"

definition
  "IsSepReadingEstimateOf r f P proj m \<equiv> \<forall>substate. \<exists>g.
  \<lbrace>\<lambda>s. (proj s) |` r = substate \<and> P s  \<rbrace> f \<lbrace>\<lambda>r s. (proj s) |` m = g substate\<rbrace>"

lemma sep_writing_estimateD:
  "\<lbrakk>IsSepWritingEstimateOf f P proj m; (r, s') \<in> fst (f s);P s \<rbrakk>
  \<Longrightarrow> proj s |` (UNIV - m) = proj s' |` (UNIV - m)"
  apply (rule ext)
  apply (clarsimp simp: restrict_map_def
    IsSepWritingEstimateOf_def)
  apply (drule_tac x = x in spec)
  apply (drule_tac x = "proj s x" in spec)
  apply (drule(1) use_valid)
   apply simp+
  done

lemma sep_writing_estimate_imp:
  "\<lbrakk>IsSepWritingEstimateOf f P' proj m; \<And>s. P s \<Longrightarrow> P' s\<rbrakk>
  \<Longrightarrow> IsSepWritingEstimateOf f P proj m"
  apply (clarsimp simp:IsSepWritingEstimateOf_def)
  apply (drule_tac x = ptr in spec)
  apply (drule_tac x = v in spec)
  apply (erule hoare_pre)
  apply clarsimp
  done

lemma sep_strong_writing_estimateD:
  "\<lbrakk>IsStrongSepWritingEstimateOf f P proj m g; (r, s') \<in> fst (f s);P s \<rbrakk>
  \<Longrightarrow> proj s' |` m = g (proj s) \<and> proj s' |` (UNIV - m) = proj s |` (UNIV - m)"
  apply (simp add:
    IsStrongSepWritingEstimateOf_def)
  apply (drule_tac x = "proj s " in spec)
  apply (drule use_valid)
   apply assumption
   apply simp+
  done

lemma intent_reset_twice[simp]:
 "intent_reset (intent_reset z) = intent_reset z"
  apply (case_tac z)
  apply (simp_all add:intent_reset_def)
  done

lemma largest_set:
  "UNIV \<subseteq> cmps \<Longrightarrow> cmps = UNIV"
  by auto

definition "sep_map_predicate p P cmps \<equiv> \<lambda>s. \<exists>obj. (sep_map_general p obj cmps s \<and> P obj)"

definition "sep_heap_dom P m = (\<forall>s. P s \<longrightarrow> dom (sep_heap s) = m)"
definition "sep_irq_node_dom P m = (\<forall>s. P s \<longrightarrow> dom (sep_irq_node s) = m)"

definition "sep_map_spec P s =  (\<forall>s'. P s' \<longrightarrow> s' =  s)"

lemma sep_heap_domD:
  "\<lbrakk>sep_heap_dom P m; P s ; p \<notin> m\<rbrakk>
   \<Longrightarrow> p \<notin> dom (sep_heap s)"
  by (fastforce simp:sep_heap_dom_def)

lemma sep_heap_domD':
  "\<lbrakk>sep_heap_dom P m;P s\<rbrakk>
   \<Longrightarrow> m = dom (sep_heap s)"
  by (fastforce simp:sep_heap_dom_def)

lemma sep_irq_node_domD':
  "\<lbrakk>sep_irq_node_dom P m; P s\<rbrakk>
   \<Longrightarrow> m = dom (sep_irq_node s)"
  by (fastforce simp: sep_irq_node_dom_def)

lemma sep_specD:
  "\<lbrakk>sep_map_spec P s; P s'\<rbrakk> \<Longrightarrow> s = s'"
  by (clarsimp simp: sep_map_spec_def)

lemma sep_heap_dom_sep_map_predicate:
  "m = {ptr}\<times> cmps \<Longrightarrow>
  sep_heap_dom (sep_map_predicate ptr P cmps) m"
  apply (clarsimp simp: sep_map_general_def
    object_to_sep_state_def
    sep_heap_dom_def sep_map_predicate_def
    split:sep_state.splits if_splits)
  apply (rule set_eqI)
  apply (clarsimp simp:dom_def object_project_def split:cdl_component_id.splits)
  done

lemma sep_irq_node_dom_sep_map_predicate:
  "sep_irq_node_dom (sep_map_predicate ptr P cmps) {}"
  apply (clarsimp simp: sep_map_general_def object_to_sep_state_def
    sep_irq_node_dom_def sep_map_predicate_def
    split:sep_state.splits if_split_asm)
  done

lemma sep_map_rewrite_spec:
  "sep_map_general = (\<lambda>p obj cmps.  sep_map_predicate p ((=) obj) cmps)"
  "sep_map_o = (\<lambda>p obj. sep_map_predicate p ((=) obj) UNIV)"
  "sep_map_f = (\<lambda>p obj. sep_map_predicate p ((=) obj) {Fields})"
  "sep_map_c = (\<lambda>p cap. let (ptr,slot) = p in
   sep_map_predicate ptr (\<lambda>obj. object_slots obj = [ slot \<mapsto> cap]) {Slot slot})"
  by (fastforce simp: sep_map_predicate_def sep_any_def sep_map_general_def
                      sep_map_o_def sep_map_f_def sep_map_c_def split_def
               split: sep_state.splits)+

lemma sep_map_rewrite_any:
  "sep_any_map_c = (\<lambda>ptr state.
   sep_map_predicate (fst ptr) (\<lambda>obj. \<exists>cap. object_slots obj = [(snd ptr) \<mapsto> cap]) {Slot (snd ptr)} state)"
  by (fastforce simp: sep_map_predicate_def sep_map_general_def sep_any_def
                      sep_map_o_def sep_map_f_def sep_map_c_def split_def
               split: sep_state.splits)

lemma sep_heap_dom_conj:
  "\<lbrakk>sep_heap_dom P m;sep_heap_dom P' m'\<rbrakk> \<Longrightarrow> sep_heap_dom (P \<and>* P') (m \<union> m')"
  apply (clarsimp simp: sep_heap_dom_def sep_conj_def
                        sep_disj_sep_state_def sep_state_disj_def)
  apply (auto simp: map_disj_def plus_sep_state_def sep_state_add_def)
  done

lemma sep_heap_dom_simps:
  "sep_heap_dom (slot \<mapsto>c -) ({(fst slot,Slot (snd slot))})"
  "sep_heap_dom (slot \<mapsto>c cap) ({(fst slot,Slot (snd slot))})"
  apply (simp add:sep_map_rewrite_any sep_heap_dom_sep_map_predicate)
  apply (simp add:sep_map_rewrite_spec sep_heap_dom_sep_map_predicate split_def)
  done

lemma sep_irq_node_dom_simps:
  "sep_irq_node_dom (slot \<mapsto>c -) {}"
  "sep_irq_node_dom (slot \<mapsto>c cap) {}"
  apply (simp add:sep_map_rewrite_any sep_irq_node_dom_sep_map_predicate)
  apply (simp add:sep_map_rewrite_spec sep_irq_node_dom_sep_map_predicate split_def)
  done

lemma sep_map_spec_conj:
  "\<lbrakk>sep_map_spec P s; sep_map_spec P' s'\<rbrakk>
    \<Longrightarrow> sep_map_spec (P \<and>* P')
                     (SepState (sep_heap s ++ sep_heap s')
                               (sep_irq_node s ++ sep_irq_node s'))"
  by (clarsimp simp: sep_map_spec_def sep_conj_def
                     plus_sep_state_def sep_state_add_def)

lemma sep_spec_simps:
  "sep_map_spec (slot \<mapsto>c cap)
  (SepState [(fst slot,Slot (snd slot)) \<mapsto> (CDL_Cap (Some (reset_cap_asid cap)))]
            Map.empty)"
  apply (clarsimp simp:sep_map_spec_def sep_map_c_def sep_map_general_def)
  apply (case_tac s')
  apply (clarsimp simp:object_to_sep_state_def)
  apply (rule ext)
  apply (clarsimp simp: object_project_def object_slots_object_clean
                 split: if_split_asm)
  done

lemma sep_conj_spec:
  "\<lbrakk> < P \<and>* Q > s\<rbrakk>
   \<Longrightarrow> \<exists>s'. < P \<and>* (=) s' > s"
  by (auto simp:sep_state_projection_def sep_conj_def
    sep_disj_sep_state_def sep_state_disj_def)

lemma sep_conj_spec_value:
  "\<lbrakk> < P \<and>* (=) s' > s; sep_heap_dom P m; p \<notin> m\<rbrakk>
  \<Longrightarrow> (sep_heap s') p = (sep_heap (sep_state_projection s) |` (UNIV - m)) p"
  apply (clarsimp simp:sep_state_projection_def sep_conj_def
    sep_disj_sep_state_def sep_state_disj_def)
  apply (drule(2) sep_heap_domD)
  apply (simp add: plus_sep_state_def sep_state_add_def
            split: sep_state.splits)
  apply (clarsimp simp: map_add_def split:option.splits)
  done

lemma write_estimate_via_sep:
  assumes sep_valid: "\<And>obj Q. \<lbrace>\<lambda>s. < P \<and>* Q > s \<rbrace>
    f \<lbrace>\<lambda>r s. < P' \<and>* Q > s \<rbrace>"
  and sep_heap_dom: "sep_heap_dom P m"
  and sep_heap_dom': "sep_heap_dom P' m"
  shows "IsSepWritingEstimateOf f (\<lambda>s. < P \<and>* Q> s)
    (\<lambda>s.  sep_heap (sep_state_projection s)) m"
  apply (clarsimp simp: valid_def IsSepWritingEstimateOf_def)
  apply (drule sep_conj_spec)
  apply clarsimp
  apply (drule use_valid[OF _ sep_valid])
   apply simp
  apply (drule(1) sep_conj_spec_value[OF _ sep_heap_dom])
  apply (drule(1) sep_conj_spec_value[OF _ sep_heap_dom'])
  apply simp
  done

lemma sep_map_dom_predicate:
  "\<lbrakk>sep_heap_dom P m; sep_irq_node_dom P m';
    <P \<and>* P'> b\<rbrakk>
  \<Longrightarrow> P (SepState (sep_heap (sep_state_projection b) |` m)
                  (sep_irq_node (sep_state_projection b) |` m'))"
  apply (clarsimp simp: sep_state_projection_def sep_conj_def
                        plus_sep_state_def sep_state_add_def)
  apply (drule(1) sep_heap_domD')
  apply (drule(1) sep_irq_node_domD')
  apply simp
  apply (case_tac x,case_tac y)
  apply (clarsimp simp: sep_state_projection_def sep_conj_def
                        sep_disj_sep_state_def sep_state_disj_def)
  apply (simp add: map_add_restrict_dom_left)
  done

lemma strong_write_estimate_via_sep:
  assumes sep_valid: "\<And>obj Q. \<lbrace>\<lambda>s. < P \<and>* Q > s \<rbrace>
    f \<lbrace>\<lambda>r s. < P' \<and>* Q > s \<rbrace>"
  and sep_heap_dom: "sep_heap_dom P m"
  and sep_heap_dom': "sep_heap_dom P' m"
  and sep_irq_node_dom' : "sep_irq_node_dom P' m'"
  and sep_spec: "sep_map_spec P' state"
  shows "IsStrongSepWritingEstimateOf f (\<lambda>s. < P \<and>* Q> s)
    (\<lambda>s.  sep_heap (sep_state_projection s)) m (\<lambda>s. sep_heap state)"
  apply (clarsimp simp: valid_def IsStrongSepWritingEstimateOf_def)
  apply (drule sep_conj_spec)
  apply clarsimp
  apply (drule use_valid[OF _ sep_valid])
   apply simp
  apply (rule conjI)
   apply simp
   apply (drule sep_map_dom_predicate[OF sep_heap_dom' sep_irq_node_dom'])
   apply (drule sep_specD[OF sep_spec])
   apply (case_tac state,simp)
  apply (rule ext,clarsimp simp:restrict_map_def)
  apply (drule sep_conj_spec_value)
    apply (rule sep_heap_dom)
   apply simp
  apply (drule(1) sep_conj_spec_value[OF _ sep_heap_dom'])
  apply simp
  done

lemma map_eqI:
  "\<lbrakk>a |` m = b |` m;a |` (UNIV - m)  = b |` (UNIV - m)\<rbrakk> \<Longrightarrow> a = b"
  apply (rule ext)
  apply (drule_tac x = x in fun_cong)+
  apply (auto simp:restrict_map_def split:if_splits)
  done

lemma using_writing_estimate:
  assumes we: "IsSepWritingEstimateOf f P proj m"
  shows "\<lbrace>\<lambda>s. P s \<and> Q ((proj s) |` (UNIV - m)) \<rbrace> f \<lbrace>\<lambda>r s. Q ((proj s) |` (UNIV - m))\<rbrace>"
  apply (clarsimp simp:valid_def)
  apply (erule arg_cong[where f = Q,THEN iffD1,rotated])
  apply (erule sep_writing_estimateD[OF we])
  apply simp
  done

lemma using_strong_writing_estimate:
  assumes we: "IsStrongSepWritingEstimateOf f P proj m g"
  shows
  "\<lbrace>\<lambda>s. P s \<and> Q ((proj s) |` (UNIV - m) ++ g (proj s))  \<rbrace> f \<lbrace>\<lambda>r s. Q (proj s)\<rbrace>"
  apply (clarsimp simp:valid_def)
  apply (erule arg_cong[where f = Q,THEN iffD1,rotated])
  apply (rule map_eqI[where m = m])
   apply (drule(1) sep_strong_writing_estimateD[OF we,THEN conjunct1,symmetric])
   apply (rule ext)
   apply (clarsimp simp:restrict_map_def
     map_add_def split:option.splits)
  apply (frule(1) sep_strong_writing_estimateD[OF we,THEN conjunct1,symmetric])
  apply (drule(1) sep_strong_writing_estimateD[OF we,THEN conjunct2,symmetric])
  apply (rule ext)
  apply simp
  done

(* Here are some examples that we get valid rules from existing sep_logical rules *)

(* 1.  We need some predicates in the furture to make sure schedule will do the right thing *)

definition "scheduable_cap cap \<equiv> case cap of
  RunningCap \<Rightarrow> True | RestartCap \<Rightarrow> True | _ \<Rightarrow> False"

definition tcb_scheduable :: "cdl_tcb \<Rightarrow> bool"
  where "tcb_scheduable \<equiv> \<lambda>tcb. (cdl_tcb_caps tcb) tcb_pending_op_slot
  = Some RunningCap \<or> (cdl_tcb_caps tcb) tcb_pending_op_slot = Some RestartCap"

abbreviation "tcb_at_heap \<equiv> \<lambda>P ptr heap.
  object_at_heap (\<lambda>obj. \<exists>tcb. obj = Tcb tcb  \<and>  P tcb)  ptr heap"

definition all_scheduable_tcbs :: "(word32 \<Rightarrow> cdl_object option) \<Rightarrow> cdl_object_id set"
where  "all_scheduable_tcbs \<equiv> \<lambda>m. {ptr. tcb_at_heap tcb_scheduable ptr m}"

definition sep_all_scheduable_tcbs :: "(32 word \<times> cdl_component_id \<Rightarrow> cdl_component option) \<Rightarrow> cdl_object_id set"
where "sep_all_scheduable_tcbs m \<equiv> {ptr. \<exists>obj cap. m (ptr,Fields) = Some (CDL_Object obj) \<and> is_tcb obj
  \<and> m (ptr,Slot tcb_pending_op_slot) = Some (CDL_Cap (Some cap)) \<and> scheduable_cap cap}"

lemma is_tcb_obj_type:
  "is_tcb = (\<lambda>x. object_type x = TcbType)"
  by (auto simp:is_tcb_def object_type_def split:cdl_object.splits)

lemma all_scheduable_tcbs_rewrite:
  "all_scheduable_tcbs (cdl_objects s) =
  sep_all_scheduable_tcbs (sep_heap (sep_state_projection s))"
 apply (intro set_eqI iffI)
  apply (clarsimp simp:all_scheduable_tcbs_def sep_state_projection_def
    sep_all_scheduable_tcbs_def object_at_heap_def object_project_def
    is_tcb_obj_type)
  apply (clarsimp simp:object_type_def object_slots_object_clean
    tcb_scheduable_def object_slots_def scheduable_cap_def)
  apply (fastforce simp:object_clean_def asid_reset_def update_slots_def
    reset_cap_asid_def intent_reset_def object_slots_def
    split:if_splits)
 apply (clarsimp simp:all_scheduable_tcbs_def sep_state_projection_def
    sep_all_scheduable_tcbs_def object_at_heap_def object_project_def
    is_tcb_obj_type split:option.splits)
 apply (clarsimp simp:object_type_def tcb_scheduable_def
   scheduable_cap_def object_slots_def object_clean_def asid_reset_def
   update_slots_def intent_reset_def reset_cap_asid_def
   split:cdl_object.splits cdl_cap.splits option.splits)
 done

lemma update_slots_rev:
  "update_slots slots obj = obj' \<Longrightarrow>
  obj = update_slots (object_slots obj) obj'"
  by (clarsimp simp:update_slots_def object_slots_def
    split:cdl_object.splits)

lemma all_scheduable_tcbsD:
  "ptr \<in> all_scheduable_tcbs (cdl_objects s)
  \<Longrightarrow> tcb_at_heap tcb_scheduable ptr (cdl_objects s)"
  by (simp add:all_scheduable_tcbs_def)

lemma all_scheduable_tcbsD':
  "ptr \<notin> all_scheduable_tcbs (cdl_objects s)
  \<Longrightarrow> \<not> tcb_at_heap tcb_scheduable ptr (cdl_objects s)"
  by (simp add:all_scheduable_tcbs_def)

lemma scheduable_cap_reset_cap_asid[simp]:
  "scheduable_cap (reset_cap_asid cap) = scheduable_cap cap"
  by (case_tac cap,simp_all add: reset_cap_asid_def scheduable_cap_def)

lemma set_cap_all_scheduable_tcbs:
  "\<lbrace>\<lambda>s. all_scheduable_tcbs (cdl_objects s) = {cur_thread} \<and> (cap = RunningCap \<or> cap = RestartCap) \<rbrace>
    set_cap (cur_thread,tcb_pending_op_slot) cap
  \<lbrace>\<lambda>rv s. all_scheduable_tcbs (cdl_objects s) = {cur_thread} \<rbrace>"
  apply (rule hoare_name_pre_state)
  apply (cut_tac all_scheduable_tcbsD[where ptr = cur_thread])
   prefer 2
   apply fastforce
  apply (clarsimp simp:all_scheduable_tcbs_rewrite)
  apply (rule hoare_pre)
   apply (rule using_strong_writing_estimate
     [where proj = "(\<lambda>a. sep_heap (sep_state_projection a))"])
   apply (rule strong_write_estimate_via_sep[OF set_cap_wp])
     apply (rule sep_heap_dom_simps sep_irq_node_dom_simps sep_spec_simps)+
  apply (rule conjI)
   apply (clarsimp simp:sep_map_c_conj
     Let_def sep_any_exist all_scheduable_tcbs_rewrite[symmetric]
     dest!:in_singleton)
   apply (clarsimp simp:object_at_heap_def tcb_scheduable_def
     sep_state_projection_def object_project_def)
   apply (rule conjI)
    apply (clarsimp simp:object_slots_def object_clean_def
      update_slots_def intent_reset_def asid_reset_def
      split:option.splits)
    apply fastforce+
  apply (rule subst,assumption)
  apply (drule in_singleton)
  apply (intro set_eqI iffI)
   apply (clarsimp simp: sep_all_scheduable_tcbs_def sep_state_projection_def
                  split: if_split_asm option.splits)
  apply (fastforce simp: sep_all_scheduable_tcbs_def map_add_def
                         sep_state_projection_def scheduable_cap_def
                 split: option.splits)
  done

lemma sep_inv_to_all_scheduable_tcbs:
  assumes sep: "\<And>P. \<lbrace><P>\<rbrace> f \<lbrace>\<lambda>r. <P>\<rbrace>"
  shows "\<lbrace>\<lambda>s. P (all_scheduable_tcbs (cdl_objects s))\<rbrace> f
   \<lbrace>\<lambda>r s. P (all_scheduable_tcbs (cdl_objects s))\<rbrace>"
  apply (clarsimp simp:valid_def all_scheduable_tcbs_rewrite)
  apply (erule use_valid)
   apply (rule hoare_strengthen_post)
    apply (rule sep)
   apply assumption
  apply simp
  done

lemma validE_to_valid:
  assumes validE:"\<And>E. \<lbrace>P\<rbrace>f\<lbrace>\<lambda>r. Q\<rbrace>,\<lbrace>\<lambda>r s. E\<rbrace>"
  shows "\<lbrace>P\<rbrace>f\<lbrace>\<lambda>r. Q\<rbrace>"
  using validE[where E = False]
  apply (clarsimp simp:validE_def valid_def)
  apply (drule_tac spec)
  apply (erule(1) impE)
  apply (drule_tac bspec)
   apply assumption
  apply (auto split:sum.splits)
  done

end


theory Master
  imports RedSafeAppLemma ProcLemma ExclLemma WellTypedAlt SolverInfer
begin

lemma safe_red_all: "\<lbrakk> well_typed_system env rs_map p_map s1 ps1; red_proc_set (s1, ps1) r_ax (s2, ps2) \<rbrakk> \<Longrightarrow>
  (\<exists> r_s g_ax p_map'. well_typed_system (red_env env g_ax) (red_nres_map rs_map g_ax) p_map' s2 ps2 \<and> safe_act s1 r_s g_ax)"
  apply (rule_tac safe_red_proc_set)
    apply (auto)
  apply (rule_tac sares_valid)
  done

end