section "Implementing List Interface with DynamicArrays"
theory IICF_DArray_List
  imports "../Intf/IICF_List" "Imperative_HOL_Time.IHT_Dynamic_Array_More"
begin

definition "da_assn R \<equiv> hr_comp dyn_array (\<langle>the_pure R\<rangle>list_rel)"

lemma hn_refine_ex: "(\<And>b. hn_refine (R b) c Q RR a) \<Longrightarrow> hn_refine (\<exists>\<^sub>Ab. R b) c Q RR a"
   unfolding hn_refine_def mod_ex_dist by blast

context
  notes [intro!] = hfrefb_to_hoare_triple
  notes [simp] = pure_def hn_ctxt_def invalid_assn_def uncurry_t_def
                noparam_t_def oneparam_t_def
begin

  lemma mop_list_empty_rule_aux:
    "(uncurry0 dyn_array_new, noparam_t mop_empty_list)
         \<in> [\<lambda>_. True, \<lambda>_. 12]\<^sub>b unit_assn\<^sup>k \<rightarrow> (da_assn (R))"
    by (sep_auto heap: dyn_array_new_rule
                simp: mop_empty_list_def da_assn_def hr_comp_def)

  lemmas mop_list_empty_rule[sepref_fr_rules] = mop_list_empty_rule_aux[hfb_to_hnr]

  lemma models_impl_elem_in_is_pure:
    "is_pure R \<Longrightarrow> h1 \<Turnstile> R aa a \<Longrightarrow> (a, aa) \<in> the_pure R"
    by (metis pure_assn_rule pure_def pure_the_pure)

  lemma mop_list_push_rule_aux: "(uncurry push_array, uncurry_t mop_push_list)
       \<in> [\<lambda>_. CONSTRAINT is_pure R, \<lambda>_. 23]\<^sub>b (R\<^sup>k *\<^sub>a (da_assn (R))\<^sup>d) \<rightarrow> (da_assn (R))"
    supply param_append' = param_append[THEN fun_relD, THEN fun_relD]
    by (sep_auto heap: push_array_rule dest!: mod_starD
                    simp:  da_assn_def hr_comp_def  mop_push_list_def
                    intro!: models_impl_elem_in_is_pure param_append')

  lemmas mop_list_push_rule[sepref_fr_rules] = mop_list_push_rule_aux[hfb_to_hnr]

end

lemma dyn_da: "dyn_array = da_assn (pure Id)" unfolding da_assn_def by auto

declare da_assn_def[symmetric, fcomp_norm_unfold]

subsection "casting functions by tags"

thm mop_list_empty_rule[to_hfref,to_hnr]
thm mop_list_empty_rule[to_hfref]
thm mop_list_push_rule[to_hfref,to_hnr]
thm mop_list_push_rule[to_hfref]

subsection "synthesize some programs"

experiment
begin

sepref_definition test is "uncurry0 (do { xs \<leftarrow>mop_empty_list (\<lambda>_. 7);  mop_push_list (\<lambda>_. 10) (0::nat) xs })" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a da_assn (pure Id)"
  apply sepref_dbg_keep
  apply sepref_dbg_trans_keep
        apply sepref_dbg_trans_step_keep oops

sepref_definition test is "uncurry0 (do { xs \<leftarrow>mop_empty_list (\<lambda>_. 12);  mop_push_list (\<lambda>_. 23) (0::nat) xs })" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a da_assn (pure Id)"
  apply sepref_dbg_keep   done

end

subsection "combined with relation"

definition "dyn_array_assn R xs' p = (\<exists>\<^sub>Axs. dyn_array xs p * list_assn R xs' xs)"

end


theory hcKripkeThree
imports RRLoopThree
begin

locale scenarioHCKripkeThree = scenarioHCKripkeTwo +
fixes hc_actorsR :: "identity set"
defines hc_actorsR_def: "hc_actorsR \<equiv> {''Patient'', ''Doctor''}"
fixes hc_locationsR :: "location set"
defines hc_locationsR_def: "hc_locationsR \<equiv>
          {Location 0, Location 1, Location 2, Location 3}"

fixes sphoneR :: "location"
defines sphoneR_def: "sphoneR \<equiv> Location 0"
fixes homeR :: "location"
defines homeR_def: "homeR \<equiv> Location 1"
fixes hospitalR :: "location"
defines hospitalR_def: "hospitalR \<equiv> Location 2"
fixes cloudR :: "location"
defines cloudR_def: "cloudR \<equiv> Location 3"

fixes global_policyR :: "[infrastructure, identity] \<Rightarrow> bool"
defines global_policyR_def: "global_policyR I a \<equiv> a \<notin> hc_actorsR
                 \<longrightarrow> \<not>(enables I cloudR (Actor a) put)"

fixes ex_credsR :: "actor \<Rightarrow> (string set * string set)"
defines ex_credsR_def: "ex_credsR \<equiv> (\<lambda> x. if x = Actor ''Patient'' then
                         ({''PIN'',''skey''}, {}) else
                            (if x = Actor ''Doctor'' then
                                ({''PIN''},{}) else ({},{})))"

fixes ex_locsR :: "location \<Rightarrow> acond"
defines "ex_locsR \<equiv>  (\<lambda> x.  if x = cloudR then
             ({((Actor ''Patient'',{Actor ''Doctor''}),''42'')})
             else ({}))"

fixes ex_locR_ass :: "location \<Rightarrow> identity set"
defines ex_locR_ass_def: "ex_locR_ass \<equiv>
          (\<lambda> x.  if x = homeR then {''Patient''}
                 else (if x = hospitalR then {''Doctor'', ''Eve''}
                       else {}))"
fixes ex_graphR :: "igraph"
defines ex_graphR_def: "ex_graphR \<equiv> Lgraph
     {(homeR, cloudR), (sphoneR, cloudR), (cloudR,hospitalR)}
     ex_locR_ass
     ex_credsR ex_locsR"

fixes ex_graphR' :: "igraph"
defines ex_graphR'_def: "ex_graphR' \<equiv> Lgraph
     {(homeR, cloudR), (sphoneR, cloudR), (cloudR,hospitalR)}
       (\<lambda> x. if x = cloudR then {''Patient''} else
           (if x = hospitalR then {''Doctor'',''Eve''} else {}))
     ex_credsR ex_locsR"

fixes ex_graphR'' :: "igraph"
defines ex_graphR''_def: "ex_graphR'' \<equiv> Lgraph
     {(homeR, cloudR), (sphoneR, cloudR), (cloudR,hospitalR)}
       (\<lambda> x. if x = cloudR then {''Patient'', ''Eve''} else
           (if x = hospitalR then {''Doctor''} else {}))
     ex_credsR ex_locsR"

fixes local_policiesR :: "[igraph, location] \<Rightarrow> policy set"
defines local_policiesR_def: "local_policiesR G \<equiv>
    (\<lambda> x. if x = homeR then
        {(\<lambda> y. True, {put,get,move,eval})}
          else (if x = sphoneR then
             {((\<lambda> y. has G (y, ''PIN'')), {put,get,move,eval})}
                else (if x = cloudR then
                {(\<lambda> y. True, {put,get,move,eval})}
                       else (if x = hospitalR then
                {((\<lambda> y. (\<exists> n. (n  @\<^bsub>G\<^esub> hospitalR) \<and> Actor n = y \<and>
                           has G (y, ''skey''))), {put,get,move,eval})} else {}))))"

fixes rmapR :: "RRLoopThree.infrastructure \<Rightarrow> RRLoopTwo.infrastructure"
defines rmapR_def:
"rmapR I \<equiv> ref_map I local_policiesT"

fixes hc_scenarioR :: "infrastructure"
defines hc_scenarioR_def:
"hc_scenarioR \<equiv> Infrastructure ex_graphR local_policiesR"

fixes IhcR :: "infrastructure set"
defines IhcR_def:
  "IhcR \<equiv> {hc_scenarioR}"

fixes hc_scenarioR' :: "infrastructure"
defines hc_scenarioR'_def:
"hc_scenarioR' \<equiv> Infrastructure ex_graphR' local_policiesR"

fixes HCR' :: "infrastructure set"
defines HCR'_def:
  "HCR' \<equiv> {hc_scenarioR'}"

fixes hc_scenarioR'' :: "infrastructure"
defines hc_scenarioR''_def:
"hc_scenarioR'' \<equiv> Infrastructure ex_graphR'' local_policiesR"

fixes HCR'' :: "infrastructure set"
defines HCR''_def:
  "HCR'' \<equiv> {hc_scenarioR''}"

fixes hc_statesR
defines hc_statesR_def: "hc_statesR \<equiv> { I. hc_scenarioR \<rightarrow>\<^sub>i* I }"

fixes hc_KripkeR
defines "hc_KripkeR \<equiv> Kripke hc_statesR {hc_scenarioR}"

fixes shcR
defines "shcR \<equiv> {x. \<not> (global_policyR x ''Eve'')}"

assumes no_insider: "inj Actor"

begin

 lemma same_nodes0[rule_format]: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow> nodes(graphI z) = nodes(graphI z')"
    apply clarify
  apply (erule RRLoopThree.state_transition_in.cases)
  by (simp add: move_graph_a_def atI_def actors_graph_def nodes_def)+

lemma same_nodes: "(hc_scenarioR, s) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*
\<Longrightarrow> RRLoopThree.nodes (graphI hc_scenarioR) = RRLoopThree.nodes (graphI s)"
  apply (erule rtrancl_induct)
   apply (rule refl)
  apply (drule CollectD)
    apply simp
    apply (drule same_nodes0)
  by simp

lemma finite_data_imp0:
"(hc_scenarioR, I) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*  \<Longrightarrow>
(\<forall>l::location. finite (RRLoopThree.lgra (RRLoopThree.graphI hc_scenarioR) l)) \<longrightarrow>
(\<forall>l::location. finite (RRLoopThree.lgra (RRLoopThree.graphI I) l))"
    apply (erule rtrancl_induct)
   apply simp+
  apply clarify
  apply (erule state_transition_in.cases)
  apply (simp add: move_graph_a_def)
by simp+

lemma finite_data0:
"(hc_scenarioR, I) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*  \<Longrightarrow>
\<forall>l::location. finite (RRLoopThree.lgra (RRLoopThree.graphI I) l)"
  apply (drule finite_data_imp0)
by (simp add: hc_scenarioR_def ex_graphR_def ex_locsR_def)

lemma init_state_policy0: "\<lbrakk> \<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow>  delta(z) = delta(z');
                          (x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<rbrakk> \<Longrightarrow>
                          delta(x) = delta(y)"
  apply (rule mp)
  prefer 2
   apply (rotate_tac 1)
    apply assumption
  thm rtrancl_induct
  apply (erule rtrancl_induct)
    apply (rule impI)
   apply (rule refl)
    apply (subgoal_tac "delta y = delta z")
   apply (erule impE)
    apply assumption
    apply (rule impI)
   apply (rule trans)
    apply assumption+
  apply (drule_tac x = y in spec)
  apply (drule_tac x = z in spec)
    apply (rotate_tac -1)
  apply (erule impE)
    apply simp
by assumption

lemma init_state_policy: "\<lbrakk> (x,y) \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<rbrakk> \<Longrightarrow>
                          delta(x) = delta(y)"
  apply (rule init_state_policy0)
    apply (rule delta_invariant)
  by assumption

lemma refmapTwo_lem: "\<forall>s::RRLoopThree.infrastructure.
       (hc_scenarioR, s) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<longrightarrow>
       (\<forall>s'::RRLoopThree.infrastructure. s \<rightarrow>\<^sub>n s' \<longrightarrow> rmapR s \<rightarrow>\<^sub>n rmapR s')"
  apply clarify
  apply (subgoal_tac "nodes(graphI hc_scenarioR) = nodes(graphI s)")
   prefer 2
   apply (erule same_nodes)
  apply (subgoal_tac "delta hc_scenarioR = delta s")
  prefer 2
  apply (erule init_state_policy)
  apply (erule state_transition_in.cases)
proof -
(* move *)
show "\<And>(s::RRLoopThree.infrastructure) (s'::RRLoopThree.infrastructure) (G::RRLoopThree.igraph)
       (I::RRLoopThree.infrastructure) (h::char list) (l::location) (l'::location)
       I'::RRLoopThree.infrastructure.
       (hc_scenarioR, s)
       \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
       RRLoopThree.nodes (RRLoopThree.graphI hc_scenarioR) = RRLoopThree.nodes (RRLoopThree.graphI s) \<Longrightarrow>
       RRLoopThree.delta hc_scenarioR = RRLoopThree.delta s \<Longrightarrow>
       s = I \<Longrightarrow>
       s' = I' \<Longrightarrow>
       G = RRLoopThree.graphI I \<Longrightarrow>
       h @\<^bsub>G\<^esub> l \<Longrightarrow>
       l \<in> RRLoopThree.nodes G \<Longrightarrow>
       l' \<in> RRLoopThree.nodes G \<Longrightarrow>
       h \<in> RRLoopThree.actors_graph (RRLoopThree.graphI I) \<Longrightarrow>
       RRLoopThree.enables I l' (Actor h) move \<Longrightarrow>
       I' =
       RRLoopThree.infrastructure.Infrastructure (RRLoopThree.move_graph_a h l l' (RRLoopThree.graphI I))
        (RRLoopThree.delta I) \<Longrightarrow>
       rmapR s \<rightarrow>\<^sub>n rmapR s'"
  apply (rule_tac I = "rmapR s" and I' = "rmapR s'" and l = l and l' = l'
                             and a = h
 in RRLoopTwo.state_transition_in.move)
  apply (rule refl)
            apply (simp add: rmapR_def ref_map_def atI_def RRLoopTwo.atI_def)
           apply (simp add: rmapR_def ref_map_def nodes_def RRLoopTwo.nodes_def)
           apply (simp add: rmapR_def ref_map_def nodes_def RRLoopTwo.nodes_def)
         apply (simp add: rmapR_def ref_map_def actors_graph_def RRLoopTwo.actors_graph_def)
         apply (rule_tac x = l in exI)
         apply (simp add: nodes_def RRLoopTwo.nodes_def atI_def)
  prefer 2
        apply (simp add: rmapR_def ref_map_def move_graph_a_def RRLoopTwo.move_graph_a_def)
  apply (simp add: rmapR_def ref_map_def enables_def RRLoopTwo.enables_def)
        apply (erule bexE)
  apply (rule_tac x = x in bexI, assumption)
  apply(simp add: local_policiesT_def local_policiesR_def hospitalT_def sphoneR_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def
                 atI_def RRLoopTwo.atI_def)
        apply (rule conjI)
        apply (rule impI)
        apply (drule sym)
  apply (drule sym)
  apply (simp add: hc_scenarioR_def local_policiesT_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopOne.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
        apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
        apply (simp add: hc_scenarioR_def local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
  apply (subgoal_tac "RRLoopThree.nodes (RRLoopThree.graphI I) = {Location 0, Location 1, Location 2, Location 3}")
  apply simp
  apply (drule sym)
  apply (simp add: local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
  apply (simp add: hospitalT_def sphoneT_def RRLoopThree.nodes_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
   apply (simp add: local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
   apply (simp add: hospitalT_def sphoneT_def RRLoopThree.nodes_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
  by blast
(* get *)
next show "\<And>(s::RRLoopThree.infrastructure) (s'::RRLoopThree.infrastructure) (G::RRLoopThree.igraph)
       (I::RRLoopThree.infrastructure) (h::char list) (l::location) (l'::location) (h'::char list)
       (hs::actor set) (n::char list) I'::RRLoopThree.infrastructure.
       (hc_scenarioR, s)
       \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
       RRLoopThree.nodes (RRLoopThree.graphI hc_scenarioR) = RRLoopThree.nodes (RRLoopThree.graphI s) \<Longrightarrow>
       RRLoopThree.delta hc_scenarioR = RRLoopThree.delta s \<Longrightarrow>
       s = I \<Longrightarrow>
       s' = I' \<Longrightarrow>
       G = RRLoopThree.graphI I \<Longrightarrow>
       h @\<^bsub>G\<^esub> l \<Longrightarrow>
       l \<in> RRLoopThree.nodes G \<Longrightarrow>
       l' \<in> RRLoopThree.nodes G \<Longrightarrow>
       RRLoopThree.enables I l (Actor h) get \<Longrightarrow>
       ((Actor h', hs), n) \<in> RRLoopThree.lgra G l' \<Longrightarrow>
       Actor h \<in> hs \<Longrightarrow>
       I' =
       RRLoopThree.infrastructure.Infrastructure
        (RRLoopThree.igraph.Lgraph (RRLoopThree.gra G) (RRLoopThree.agra G) (RRLoopThree.cgra G)
          ((RRLoopThree.lgra G)(l := RRLoopThree.lgra G l \<union> {((Actor h', hs), n)})))
        (RRLoopThree.delta I) \<Longrightarrow>
       rmapR s \<rightarrow>\<^sub>n rmapR s'"
    apply (rule_tac I = "rmapR s" and I' = "rmapR s'" and l = l and h = h and l' = l' and
                                  n = n
         in RRLoopTwo.state_transition_in.get_data)
  apply (rule refl)
        apply (simp add: rmapR_def ref_map_def atI_def RRLoopTwo.atI_def)
                apply (simp add: rmapR_def ref_map_def nodes_def RRLoopTwo.nodes_def)
           apply (simp add: rmapR_def ref_map_def nodes_def RRLoopTwo.nodes_def)
      prefer 2
       apply (simp add: rmapR_def ref_map_def)
(* *)
      prefer 2
      apply (simp add: rmapR_def ref_map_def)
     prefer 2
      apply (simp add: rmapR_def ref_map_def)
(* enables get*)
 apply (simp add: rmapR_def ref_map_def enables_def RRLoopTwo.enables_def)
        apply (erule bexE)
  apply (rule_tac x = x in bexI, assumption)
  apply(simp add: local_policiesT_def local_policiesR_def hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def
                 atI_def RRLoopTwo.atI_def)
        apply (rule conjI)
        apply (rule impI)
        apply (drule sym)
     apply (drule sym)
  apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
     apply (rule impI)+
(* *)
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
        apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
        apply (simp add: hc_scenarioR_def local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
  apply (subgoal_tac "RRLoopThree.nodes (RRLoopThree.graphI I) = {Location 0, Location 1, Location 2, Location 3}")
  apply simp
  apply (drule sym)
  apply (simp add: hc_scenarioR_def local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
    by blast
(* eval *)
next show "\<And>(s::RRLoopThree.infrastructure) (s'::RRLoopThree.infrastructure) (G::RRLoopThree.igraph)
       (I::RRLoopThree.infrastructure) (h::char list) (l::location) (h'::char list) (hs::actor set)
       (n::char list) (I'::RRLoopThree.infrastructure) f::label_fun.
       (hc_scenarioR, s) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
       RRLoopThree.nodes (RRLoopThree.graphI hc_scenarioR) = RRLoopThree.nodes (RRLoopThree.graphI s) \<Longrightarrow>
       RRLoopThree.delta hc_scenarioR = RRLoopThree.delta s \<Longrightarrow>
       s = I \<Longrightarrow>
       s' = I' \<Longrightarrow>
       G = RRLoopThree.graphI I \<Longrightarrow>
       h @\<^bsub>G\<^esub> l \<Longrightarrow>
       l \<in> RRLoopThree.nodes G \<Longrightarrow>
       RRLoopThree.enables I l (Actor h) eval \<Longrightarrow>
       ((Actor h', hs), n) \<in> RRLoopThree.lgra G l \<Longrightarrow>
       Actor h \<in> hs \<or> h = h' \<Longrightarrow>
       I' =
       RRLoopThree.infrastructure.Infrastructure
        (RRLoopThree.igraph.Lgraph (RRLoopThree.gra G) (RRLoopThree.agra G) (RRLoopThree.cgra G)
          ((RRLoopThree.lgra G)
           (l := RRLoopThree.lgra G l - {(y::actor \<times> actor set, x::char list). x = n} \<union>
                 {f \<Updown> ((Actor h', hs), n)})))
        (RRLoopThree.delta I) \<Longrightarrow>
       rmapR s \<rightarrow>\<^sub>n rmapR s'"
    apply (rule_tac I = "rmapR s" and I' = "rmapR s'" and l = l and h = h and
                     n = n  and f = "Rep_label_fun f"
           in RRLoopTwo.state_transition_in.process)
  apply (rule refl)
        apply (simp add: rmapR_def ref_map_def atI_def RRLoopTwo.atI_def)
                apply (simp add: rmapR_def ref_map_def nodes_def RRLoopTwo.nodes_def)
      prefer 2
       apply (simp add: rmapR_def ref_map_def)
      prefer 2
      apply (simp add: rmapR_def ref_map_def)
     prefer 2
      apply (simp add: rmapR_def ref_map_def secure_process_def)
(* enables eval *)
 apply (simp add: rmapR_def ref_map_def enables_def RRLoopTwo.enables_def)
        apply (erule bexE)
  apply (rule_tac x = x in bexI, assumption)
  apply(simp add: local_policiesT_def local_policiesR_def hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def
                 atI_def RRLoopTwo.atI_def)
        apply (rule conjI)
        apply (rule impI)
        apply (drule sym)
  apply (drule sym)
  apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopOne.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
        apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
        apply (simp add: hc_scenarioR_def local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
  apply (subgoal_tac "RRLoopThree.nodes (RRLoopThree.graphI I) = {Location 0, Location 1, Location 2, Location 3}")
  apply simp
  apply (drule sym)
  apply (simp add: hc_scenarioR_def local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
    by blast
(* delete *)
next show "\<And>(s::RRLoopThree.infrastructure) (s'::RRLoopThree.infrastructure) (G::RRLoopThree.igraph)
       (I::RRLoopThree.infrastructure) (h::char list) (l::location) (hs::actor set) (n::char list)
       I'::RRLoopThree.infrastructure.
       (hc_scenarioR, s) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
       RRLoopThree.nodes (RRLoopThree.graphI hc_scenarioR) = RRLoopThree.nodes (RRLoopThree.graphI s) \<Longrightarrow>
       RRLoopThree.delta hc_scenarioR = RRLoopThree.delta s \<Longrightarrow>
       s = I \<Longrightarrow>
       s' = I' \<Longrightarrow>
       G = RRLoopThree.graphI I \<Longrightarrow>
       h \<in> RRLoopThree.actors_graph G \<Longrightarrow>
       l \<in> RRLoopThree.nodes G \<Longrightarrow>
       ((Actor h, hs), n) \<in> RRLoopThree.lgra G l \<Longrightarrow>
       I' =
       RRLoopThree.infrastructure.Infrastructure
        (RRLoopThree.igraph.Lgraph (RRLoopThree.gra G) (RRLoopThree.agra G) (RRLoopThree.cgra G)
          ((RRLoopThree.lgra G)(l := RRLoopThree.lgra G l - {(y::actor \<times> actor set, x::char list). x = n})))
        (RRLoopThree.delta I) \<Longrightarrow>
       rmapR s \<rightarrow>\<^sub>n rmapR s'"
    apply (rule_tac I = "rmapR s" and I' = "rmapR s'" and l = l and h = h and n = n
                     in RRLoopTwo.state_transition_in.del_data)
  apply (rule refl)
       apply (simp add: rmapR_def ref_map_def atI_def RRLoopTwo.actors_graph_def actors_graph_def
                        RRLoopTwo.nodes_def nodes_def)
                apply (simp add: rmapR_def ref_map_def nodes_def RRLoopTwo.nodes_def)

     apply (simp add: rmapR_def ref_map_def)
    by (simp add: rmapR_def ref_map_def)
(* put *)
next show "\<And>(s::RRLoopThree.infrastructure) (s'::RRLoopThree.infrastructure) (G::RRLoopThree.igraph)
       (I::RRLoopThree.infrastructure) (h::char list) (l::location) (I'::RRLoopThree.infrastructure)
       (hs::actor set) n::char list.
       (hc_scenarioR, s) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>* \<Longrightarrow>
       RRLoopThree.nodes (RRLoopThree.graphI hc_scenarioR) = RRLoopThree.nodes (RRLoopThree.graphI s) \<Longrightarrow>
       RRLoopThree.delta hc_scenarioR = RRLoopThree.delta s \<Longrightarrow>
       s = I \<Longrightarrow>
       s' = I' \<Longrightarrow>
       G = RRLoopThree.graphI I \<Longrightarrow>
       h @\<^bsub>G\<^esub> l \<Longrightarrow>
       l \<in> RRLoopThree.nodes G \<Longrightarrow>
       RRLoopThree.enables I l (Actor h) put \<Longrightarrow>
       I' =
       RRLoopThree.infrastructure.Infrastructure
        (RRLoopThree.igraph.Lgraph (RRLoopThree.gra G) (RRLoopThree.agra G) (RRLoopThree.cgra G)
          ((RRLoopThree.lgra G)(l := RRLoopThree.lgra G l \<union> {((Actor h, hs), n)})))
        (RRLoopThree.delta I) \<Longrightarrow>
       rmapR s \<rightarrow>\<^sub>n rmapR s'"
    apply (rule_tac I = "rmapR s" and I' = "rmapR s'" and l = l and h = h and n = n
                     in RRLoopTwo.state_transition_in.put)
  apply (rule refl)
       apply (simp add: rmapR_def ref_map_def atI_def RRLoopTwo.atI_def)
     apply (simp add: rmapR_def ref_map_def RRLoopTwo.nodes_def nodes_def)
       prefer 2
     apply (simp add: rmapR_def ref_map_def)
(* enables put*)
 apply (simp add: rmapR_def ref_map_def enables_def RRLoopTwo.enables_def)
        apply (erule bexE)
  apply (rule_tac x = x in bexI,assumption)
  apply(simp add: local_policiesT_def local_policiesR_def hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def
                 atI_def RRLoopTwo.atI_def)
        apply (rule conjI)
        apply (rule impI)
        apply (drule sym)
  apply (drule sym)
  apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
         apply (simp add: has_def RRLoopTwo.has_def atI_def
                RRLoopTwo.credentials_def RRLoopThree.credentials_def)
         apply (rule impI)+
        apply (rule conjI)
        apply (rule impI)+
        apply (drule sym)
  apply (drule sym)
        apply (simp add: hc_scenarioR_def local_policiesR_def)
        apply (simp add: hc_scenarioR_def local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
  apply (subgoal_tac "RRLoopThree.nodes (RRLoopThree.graphI I) = {Location 0, Location 1, Location 2, Location 3}")
  apply simp
  apply (drule sym)
  apply (simp add: hc_scenarioR_def local_policiesR_def ex_graphR_def RRLoopThree.nodes_def)
  apply (simp add: hospitalT_def sphoneT_def
                  homeT_def cloudT_def cloudR_def homeR_def sphoneR_def hospitalR_def hc_scenarioR_def)
    by blast
qed

theorem refmapTwo: "hc_KripkeT  \<sqsubseteq>\<^sub>rmapR hc_KripkeR"
proof (rule strong_mt', simp add: hc_KripkeR_def hc_KripkeT_def hc_statesT_def hc_statesR_def state_transition_refl_def, rule conjI)
  show "rmapR hc_scenarioR = hc_scenarioT"
    apply (simp add: rmapR_def ref_map_def hc_scenarioR_def hc_scenarioT_def ex_graphR_def ex_graphT_def
           homeR_def homeT_def cloudR_def cloudT_def sphoneR_def sphoneT_def hospitalR_def hospitalT_def
           ex_locR_ass_def ex_locT_ass_def ex_credsR_def ex_credsT_def
           ex_locsR_def ex_locsT_def)
    apply (rule ext)
by (simp add: hospitalR_def hospitalT_def)
next show "\<forall>s::RRLoopThree.infrastructure.
       (hc_scenarioR, s) \<in> {(x::RRLoopThree.infrastructure, y::RRLoopThree.infrastructure). x \<rightarrow>\<^sub>i y}\<^sup>* \<longrightarrow>
       (\<forall>s'::RRLoopThree.infrastructure. s \<rightarrow>\<^sub>i s' \<longrightarrow> rmapR s \<rightarrow>\<^sub>i rmapR s')"
    apply (unfold state_transition_infra_def RRLoopTwo.state_transition_infra_def)
    by (rule refmapTwo_lem)
qed

(* show attack "Eve can do put at cloud"  *)
lemma step1: "hc_scenarioR \<rightarrow>\<^sub>n hc_scenarioR'"
proof (rule_tac l = homeR and h = "''Patient''" and l' = cloudR in move)
  show "graphI hc_scenarioR = graphI hc_scenarioR" by (rule refl)
next show "''Patient'' @\<^bsub>graphI hc_scenarioR\<^esub> homeR"
    by (simp add: hc_scenarioR_def ex_graphR_def ex_locR_ass_def atI_def nodes_def)
next show "homeR \<in> nodes (graphI hc_scenarioR)"
    by (simp add: hc_scenarioR_def ex_graphR_def ex_locR_ass_def atI_def nodes_def, blast)
next show "cloudR \<in> nodes (graphI hc_scenarioR)"
    by (simp add: hc_scenarioR_def nodes_def ex_graphR_def, blast)
next show "''Patient'' \<in> actors_graph (graphI hc_scenarioR)"
    by (simp add: actors_graph_def hc_scenarioR_def ex_graphR_def ex_locR_ass_def nodes_def, blast)
next show "enables hc_scenarioR cloudR (Actor ''Patient'') move"
    by (simp add: enables_def hc_scenarioR_def ex_graphR_def local_policiesR_def
                    ex_credsR_def ex_locsR_def has_def credentials_def)
next show "hc_scenarioR' =
    Infrastructure (move_graph_a ''Patient'' homeR cloudR (graphI hc_scenarioR)) (delta hc_scenarioR)"
    apply (simp add: hc_scenarioR'_def ex_graphR'_def move_graph_a_def
                   hc_scenarioR_def ex_graphR_def homeR_def cloudR_def hospitalR_def
                    ex_locR_ass_def ex_credsR_def)
    apply (rule ext)
    by (simp add: hospitalR_def)
qed

lemma step1r: "hc_scenarioR  \<rightarrow>\<^sub>n* hc_scenarioR'"
proof (simp add: state_transition_in_refl_def)
  show " (hc_scenarioR, hc_scenarioR') \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
  by (insert step1, auto)
qed

lemma step2r: "hc_scenarioR'  \<rightarrow>\<^sub>n* hc_scenarioR''"
proof (simp add: state_transition_in_refl_def)
  show "(hc_scenarioR', hc_scenarioR'') \<in> {(x::infrastructure, y::infrastructure). x \<rightarrow>\<^sub>n y}\<^sup>*"
    by (insert step2, auto)
qed

(* Second attack: Eve can go to cloud and override Bob's data
   (that she got from outide the sysmte) and ass it as her own
   (labeling it as hers) because the policy allows Eve to put on cloud. *)
(* Note the first bunch of lemmas develops the attack refinement *)
lemma hcR_ref: "[\<N>\<^bsub>(IhcR,shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(IhcR,shcR)\<^esup> \<sqsubseteq>
                  [\<N>\<^bsub>(IhcR,HCR')\<^esub>, \<N>\<^bsub>(HCR',shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(IhcR,shcR)\<^esup>"
proof (rule_tac l = "[]" and l' = "[\<N>\<^bsub>(IhcR,HCR')\<^esub>, \<N>\<^bsub>(HCR',shcR)\<^esub>]" and
                  l'' = "[]" and si = IhcR and si' = IhcR and
                  si'' = shcR and si''' = shcR in refI, simp, rule refl)
  show "([\<N>\<^bsub>(IhcR, HCR')\<^esub>, \<N>\<^bsub>(HCR', shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(IhcR, shcR)\<^esup>) =
    ([] @ [\<N>\<^bsub>(IhcR, HCR')\<^esub>, \<N>\<^bsub>(HCR', shcR)\<^esub>] @ [] \<oplus>\<^sub>\<and>\<^bsup>(IhcR, shcR)\<^esup>)"
  by simp
qed

lemma att_hcR: "\<turnstile>[\<N>\<^bsub>(IhcR,HCR')\<^esub>, \<N>\<^bsub>(HCR',shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(IhcR,shcR)\<^esup>"
proof (subst att_and, simp, rule conjI)
  show " \<turnstile>\<N>\<^bsub>(IhcR, HCR')\<^esub>"
   apply (simp add: IhcR_def HCR'_def att_base)
   apply (subst state_transition_infra_def)
   by (rule step1)
next show "\<turnstile>[\<N>\<^bsub>(HCR', shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(HCR', shcR)\<^esup>"
   apply (subst att_and, simp)
   apply (simp add: HCR'_def shcR_def att_base)
   apply (subst state_transition_infra_def)
   apply (rule_tac x = hc_scenarioR'' in exI)
   apply (rule conjI)
   apply (simp add: global_policyR_def hc_scenarioR''_def hc_actorsR_def
                    enables_def local_policiesR_def cloudR_def sphoneR_def)
    by (rule step2)
qed

lemma hcR_abs_att: "\<turnstile>\<^sub>V [\<N>\<^bsub>(IhcR,shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(IhcR,shcR)\<^esup>"
proof (rule ref_valI, rule hcR_ref, rule att_hcR)
qed

lemma hcR_att: "hc_KripkeR \<turnstile> EF {x. \<not>(global_policyR x ''Eve'')}"
proof -
  have a: " \<turnstile>[\<N>\<^bsub>(IhcR, HCR')\<^esub>, \<N>\<^bsub>(HCR', shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(IhcR, shcR)\<^esup>"
    by (rule att_hcR)
  hence "(IhcR,shcR) = attack ([\<N>\<^bsub>(IhcR, HCR')\<^esub>, \<N>\<^bsub>(HCR', shcR)\<^esub>] \<oplus>\<^sub>\<and>\<^bsup>(IhcR, shcR)\<^esup>)"
    by simp
  hence "Kripke {s::infrastructure. \<exists>i::infrastructure\<in>IhcR. i \<rightarrow>\<^sub>i* s} IhcR \<turnstile> EF shcR"
    apply (insert a)
    apply (erule AT_EF)
    by simp
  thus  "hc_KripkeR \<turnstile> EF {x::infrastructure. \<not> global_policyR x ''Eve''}"
    by (simp add: hc_KripkeR_def hc_statesR_def IhcR_def shcR_def)
qed

theorem hc_EFR: "hc_KripkeR \<turnstile> EF shcR"
proof (insert hcR_att, simp add: shcR_def)
qed

(* Privacy preservation *)
lemma priv_pres: "h \<in> hc_actorsR \<Longrightarrow> l \<in> hc_locationsR \<Longrightarrow>
         owns (Igraph hc_scenarioR) l (Actor h) d \<Longrightarrow>
         hc_KripkeR \<turnstile> AG {x. \<forall> l \<in> hc_locationsR. owns (Igraph x) l (Actor h) d }"
proof (simp add: hc_KripkeR_def check_def, rule conjI)
  show "hc_scenarioR \<in> hc_statesR" by (simp add: hc_statesR_def state_transition_refl_def)
next show "h \<in> hc_actorsR \<Longrightarrow>
    l \<in> hc_locationsR \<Longrightarrow>
    owns (Igraph hc_scenarioR) l (Actor h) d \<Longrightarrow>
    hc_scenarioR \<in> AG {x::infrastructure. \<forall>l::location\<in>hc_locationsR. owns (Igraph x) l (Actor h) d}"
      apply (unfold AG_def)
      apply (simp add: gfp_def)
      apply (rule_tac x = "{x::infrastructure. \<forall>l::location\<in>hc_locationsR. owns (Igraph x) l (Actor h) d}" in exI)
      apply (rule conjI)
      apply (rule subset_refl)
      apply (rule conjI)
      apply (unfold AX_def)
      apply (simp add: owns_def)
      by (simp add: hc_scenarioR_def owns_def)
  qed

end
end


(*
Copyright 2018

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
theory U_exec
  imports "../Presimplified_Semantics_Manual2"
begin

section \<open>Logical operators over predicates.\<close>

definition pred_AND :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool)" (infixr "&&" 35)
  where "pred_AND p0 p1 s \<equiv> p0 s \<and> p1 s"

definition pred_OR :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool)" (infixr "||" 30)
  where "pred_OR p0 p1 s \<equiv> p0 s \<or> p1 s"

definition pred_NOT :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool)" ("! _" [40] 40)
  where "pred_NOT p0 s \<equiv> \<not> p0 s"

definition pred_IMP :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" (infixr "\<longmapsto>" 25)
  where "pred_IMP p0 p1 s \<equiv> p0 s \<longrightarrow> p1 s"

definition pred_True :: "('s \<Rightarrow> bool) \<Rightarrow> bool" ("\<turnstile> _ "[25] 25)
  where "pred_True p0 \<equiv> \<forall>s. p0 s"

definition pred_EQ :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" (infixl "===" 50)
  where "pred_EQ p\<^sub>0 p\<^sub>1 s \<equiv> p\<^sub>0 s = p\<^sub>1 s"

definition pred_NOTEQ :: "('s \<Rightarrow> bool) \<Rightarrow> ('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" (infixl "!=" 50)
  where "pred_NOTEQ p\<^sub>0 p\<^sub>1 s \<equiv> p\<^sub>0 s \<noteq> p\<^sub>1 s"

lemmas pred_logic = pred_AND_def pred_OR_def pred_NOT_def pred_IMP_def pred_True_def pred_EQ_def
  pred_NOTEQ_def

lemma pred_OR_False[simp]:
  \<open>(a || (\<lambda>_. False)) = a\<close>
  by (rule ext) (simp add: pred_OR_def)

lemma pred_OR_False'[simp]:
  \<open>((\<lambda>_. False) || a) = a\<close>
  by (rule ext) (simp add: pred_OR_def)

lemma pred_OR_lambda[simp]: \<comment> \<open>This might work better as a member of @{thm pred_logic}\<close>
  \<open>((\<lambda>a. P a) || (\<lambda>a. Q a)) = (\<lambda>a. P a \<or> Q a)\<close>
  by (rule ext) (simp add: pred_OR_def)

section \<open>Execution stuff start\<close>

type_synonym state_pred = \<open>state \<Rightarrow> bool\<close>

definition eq (infix "\<triangleq>" 50) where
  \<open>eq = (=)\<close> \<comment> \<open>Used to prevent schematic goals from finishing early\<close>

lemma eq_eq: \<comment> \<open>Rule to go from @{const eq} to @{const HOL.eq} in forward fashion.\<close>
  assumes \<open>a \<triangleq> b\<close>
  shows \<open>a = b\<close>
  using assms
  by (simp add: eq_def)

locale exec_code = presimplified_semantics +
  fixes fetch :: \<open>64 word \<Rightarrow> instr \<times> nat\<close>
    and \<alpha> :: assembly \<comment> \<open>*** wants to get rid of this eventually.\<close>
begin

fun all_flag_annotation :: flag_annotation where
  \<open>all_flag_annotation loc = UNIV\<close>

definition step :: \<open>instr \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> state\<close> where
  \<open>step i s \<sigma> \<equiv> exec_instr \<alpha> semantics all_flag_annotation i s \<sigma>\<close>

(* START TO BE MERGED *)

lemma ucast_dereference[simp]:
  assumes "s * 8 = LENGTH('b)"
      and "LENGTH('a) > LENGTH('b)"
  shows "ucast (\<sigma> \<turnstile> *[a,s] :: 'a::len word) = (\<sigma> \<turnstile> *[a,s]::'b::len word)"
  apply (rule word_eqI)
  using assms
  by (auto simp add: read_region_def word_size nth_ucast test_bit_of_cat_bytes length_read_bytes)

lemma take_too_many_bits_to_ucast[simp]:
  fixes a :: "'a::len0 word"
  assumes "h \<ge> LENGTH('a)"
  shows "(\<langle>h,0\<rangle>a :: 'b::len word) = ucast a"
  apply (rule word_eqI)
  using assms
  by (auto simp add: take_bits_def word_size nth_ucast ucast_bl)

lemma byte0_of_bv_cat:
  fixes b :: \<open>'a::len word \<times> nat\<close>
  assumes \<open>snd b = 8\<close>
    and \<open>LENGTH('a) \<ge> 8\<close>
  shows \<open>\<lbrace>0,0\<rbrace>fst (bv_cat a b) = [ucast (fst b)]\<close>
  using assms
  apply (intro nth_equalityI)
   apply auto
  apply (subst nth_bytes_of)
   apply auto
  apply (cases a)
  apply (cases b)
  apply (auto simp: bv_cat.simps)
  apply (intro word_eqI)
  apply (auto simp: word_size test_bit_of_take_bits word_ao_nth nth_ucast nth_shiftl test_bit_of_byte_of)
  done

text \<open>Some @{const sint} lemmas that are interesting, though no longer immediately useful.\<close>
lemma sint_1:
  assumes \<open>LENGTH('a) > 1\<close>
  shows \<open>sint (1::'a::len word) = 1\<close>
  using assms
  by (metis (full_types) diff_zero less_irrefl uint_1 word_msb_1 word_sint_msb_eq)

lemma sint_minus_1_lt_0_not_lt_0_is_0:
  fixes w :: \<open>'a::len word\<close>
  assumes
    \<open>LENGTH('a) > 1\<close>
    \<open>sint (w - 1) < 0\<close>
    \<open>\<not> sint w < 0\<close>
shows \<open>w = 0\<close>
  using assms
  by (smt arith_simps(16) arith_simps(52) mem_Collect_eq sint_1 sint_word_ariths(2) sints_num word_sbin.inverse_norm word_sint.Abs_inverse' word_sint.Rep)

lemma shift_truncate_0:
  fixes w :: \<open>'a::len word\<close>
  assumes \<open>7 < LENGTH('a)\<close>
  shows \<open>\<langle>7,0\<rangle>(w << 8) = (0::'b::len word)\<close>
proof -
  {
    fix i :: nat
    assume \<open>i < LENGTH('b)\<close>
    hence \<open>(\<langle>7,0\<rangle>(w << 8)::'b word) !! i = (0::'b::len word) !! i\<close>
      using assms
      by (auto simp: test_bit_of_take_bits nth_shiftl)
  }
  note idxs = this
  show ?thesis
    apply (rule word_eqI)
    using idxs
    by (auto simp: word_size)
qed

lemma shift_truncate_1:
  fixes w :: \<open>'a::len word\<close>
  assumes \<open>7 < LENGTH('a)\<close>
  shows \<open>\<langle>7,0\<rangle>((w << 8) OR 1) = (1::'b::len word)\<close>
  apply (rule word_eqI)
  using assms
  by (auto simp: word_size test_bit_of_take_bits nth_shiftl word_ao_nth simp del: take_bits_bitOR)

lemma sextend_useless_32_32:
  \<open>sextend a 32 32 = a\<close> for a :: \<open>32 word\<close>
  unfolding sextend.simps
  apply (auto simp add: simp_rules mask_def)
  apply (subst useless_and[where ?a=\<open>a OR - 4294967296::32 word\<close>, simplified])
  using or_mask_all_0[of a]
  by auto

lemma w_minus_1_le_1_is_1_or_2:
  fixes w :: \<open>32 word\<close>
  assumes \<open>w - 1 \<le> 1\<close>
  shows \<open>w = 1 \<or> w = 2\<close>
  using assms
  by unat_arith simp

lemma ucast_ucast:
  fixes a :: "'a::len word"
  shows "(ucast (ucast a::'c::len word) :: 'b::len word) = (if LENGTH('b) \<le> LENGTH('c) then ucast a else \<langle>(min LENGTH('a) LENGTH('c)) -1,0\<rangle> a)"
  apply (intro word_eqI)
  using test_bit_bl[of a]
  by (auto simp add: word_size nth_ucast test_bit_of_take_bits max_def min_def)

(* TODO updates in TakeBits_Rewriting *)
lemma take_bits_to_ucast[simp]:
  assumes "LENGTH('a) > LENGTH('b)"
      and "h = LENGTH('b) - 1"
    shows "(\<langle>h,0\<rangle>(a::'b::len word) ::'a::len word) = ucast a"
  using assms
  by (simp add: take_bits_remove)
declare take_bits_remove[simp del]

lemma ucast_take_bits'[simp]:
  fixes a :: "'a::len word"
  assumes "LENGTH('a) > LENGTH('b)"
      and "h = LENGTH('b) - 1"
    shows "(ucast (\<langle>h,0\<rangle>a::'a word) :: 'b::len0 word) = \<langle>h,0\<rangle>a"
  apply (rule word_eqI)
  using assms
  by (auto simp add: word_size nth_ucast test_bit_of_take_bits)

lemma take_bits_ucast_bit16[simp]:
  fixes a :: "32 word"
  shows "(\<langle>63,16\<rangle>(ucast a::64 word) ::64 word) = ucast (\<langle>31,16\<rangle>a::48 word)"
  apply (rule word_eqI)
  subgoal for i
  using test_bit_size[of "\<langle>31,16\<rangle>a::48 word" i] test_bit_size[of a "16+i"]
  apply (auto simp add: word_size nth_ucast test_bit_of_take_bits )
  done
  done

lemma take_bits_high_byte_ucast[simp]:
  fixes a :: "'a::len0 word"
  assumes "LENGTH('a) \<ge> 16"
      and "LENGTH('b) \<ge> 16"
  shows "\<langle>15,8\<rangle>(ucast a :: 'b::len0 word) = (\<langle>15,8\<rangle>a :: 'c::len0 word)"
  apply (rule word_eqI)
  using assms
  by (auto simp add: word_size nth_ucast test_bit_of_take_bits)

declare take_bits_bitAND_bit64[simp del]
declare take_bits_bitAND_bit32[simp del]
declare take_bits_bitAND_bit64_high[simp del]
declare take_bits_bitOR_bit32[simp del]
declare take_bits_bitXOR_bit32[simp del]

lemma ucast_shiftl:
  fixes a :: "'a :: len word"
  assumes "LENGTH('b) \<le> LENGTH('a)"
  shows "(ucast (a << n) :: 'b::len word) = ucast a << n"
  apply (rule word_eqI)
  using assms
  by (auto simp add: nth_shiftl word_size nth_ucast)

lemma take_bits_shiftl[simp]:
  fixes a :: "'b::len word"
  assumes "h+1 = LENGTH('a)"
      and "h < LENGTH('b)"
  shows "(\<langle>h,0\<rangle>(a << n) :: 'a::len word) = (\<langle>h,0\<rangle> a :: 'a::len word) << n"
  apply (rule word_eqI)
  using assms
  by (auto simp add: word_size test_bit_of_take_bits nth_shiftl min_def split: if_split_asm)

lemma bv_cat_normalize[simp]:
  assumes "s0 > h+1-l"
  shows "fst (bv_cat (\<langle>h,l\<rangle>a, s0) (b,s1)) = fst (bv_cat (\<langle>h,l\<rangle>a, h+1-l) (b,s1))"
  by (auto simp add: bv_cat.simps)

(* END updates in TakeBits_Rewriting *)

lemma udiv_64bit[simp]:
  fixes a b :: "64 word"
  shows "(ucast a :: 128 word) udiv b = a div b"
  apply (auto simp add: unat_word_ariths udiv_def unat_ucast is_up)
  apply (unat_arith)
  by (auto simp add: uint_nat of_nat_div uno_simps)

lemma udiv_32bit[simp]:
  fixes a b :: "32 word"
  shows "(ucast a :: 64 word) udiv b = a div b"
  apply (auto simp add: unat_word_ariths udiv_def unat_ucast is_up)
  apply (unat_arith)
  by (auto simp add: uint_nat of_nat_div uno_simps)

text \<open>Set up rewriting of signed comparisons. Everything is rewritten to either <s or <=s\<close>
declare signed_not_le[simp del]
declare signed_le_def[symmetric,simp del]

lemma ge_signed_to_lt_signed[simp]:
  shows "a \<ge>s b \<longleftrightarrow> \<not> a <s b"
  by (auto simp add: signed_greater_than_def signed_ge_def word_sless_def word_sle_def)

lemma signed_not_le[simp]:
  shows "a \<le>s b \<longleftrightarrow> a <=s b"
  unfolding signed_le_def signed_greater_than_def
  by auto

lemma gt_signed_to_le_signed[simp]:
  shows "a >s b \<longleftrightarrow> \<not> a <=s b"
  by (auto simp add: signed_greater_than_def signed_ge_def word_sless_def word_sle_def)

lemma unequal_and_le_to_le_signed[simp]:
  shows "a \<noteq> b \<and> b <=s a \<longleftrightarrow> b <s a"
  by (auto simp add: signed_greater_than_def signed_ge_def word_sless_def word_sle_def)

declare sf_neq_of_iff_le[simp add]

lemma word_and_1_is_0_for_all_sizes:
  fixes w :: \<open>'a::len word\<close>
  assumes \<open>\<langle>h,0\<rangle>w AND 1 = (0::'b::len word)\<close>
  and \<open>h < LENGTH('a)\<close>
  shows \<open>\<langle>h,0\<rangle>w AND 1 = (0::'c::len word)\<close>
proof -
  {
    fix i :: nat
    assume \<open>i < LENGTH('b)\<close> \<open>i < LENGTH('c)\<close>
    hence \<open>(\<langle>h,0\<rangle>w AND 1::'b word) !! i = (\<langle>h,0\<rangle>w AND 1::'c word) !! i\<close>
      using assms
      by (smt test_bit_1 test_bit_of_take_bits word_ao_nth)
  }
  thus ?thesis
    using assms
    by (smt is_zero_all_bits nth_0 test_bit_1 word_ao_nth)
qed

lemmas simp_rules = assembly.defs(1) Let_def ucast_ucast ucast_shiftl
                    Suc3_eq_add_3 semantics.defs(1)
                    incr_rip_def apply_binop_def jmp_def case_prod_unfold
                    take_rev drop_rev ucast_id unat_ucast is_up
                    get_set_rewrite_rules
                    memory_read_rewrite_rules memory_write_rewrite_rules nth_ucast
                    algebra_simps(1-8,11-) eq_diff_eq[symmetric]
                    byte0_of_bv_cat
                    shift_truncate_0 shift_truncate_1 sextend_useless_32_32
                    w_minus_1_le_1_is_1_or_2 word_and_1_is_0_for_all_sizes

abbreviation \<open>update_rip i s \<equiv> s\<lparr>regs := (regs s)(rip := i)\<rparr>\<close>

(* END TO BE MERGED *)

method rewrite_one_let' uses add del =
  \<comment> \<open>First, rewrite the first let'\<close>
  (simp add: add simp_rules del: del imp_disjL cong: Let'_weak_cong)?,
  \<comment> \<open>This may produce '-versions of functions, which should be substituted by their original\<close>
  (subst get'_def)?, (subst set'_def)?, (subst write_block'_def)?, (subst read_region'_def)?,
  \<comment> \<open>Unfold the rewritten let'\<close>
  subst inline_Let',
  \<comment> \<open>If the rewritten let' contained an if statement, split the goal \<close>
  ((rule ifI | rule conjI | rule impI)+)?,
  \<comment> \<open>Some cleaning up of the entire goal\<close>
  (simp only: nat_to_numeral if_not_true not_True_eq_False simp_Let'_mem simp_Let'_mem2 case_prod_unfold)?

section \<open>Correctness\<close>

lemma preservation_write_bytes:
assumes "write_bytes block m a' \<noteq> m a'"
    and "no_block_overflow (fst block, length (snd block))"
  shows "a' \<ge> fst block \<and> a' < fst block + of_nat (length (snd block))"
  using assms
proof (induct rule: write_bytes.induct)
  case (1 a m)
  then show ?case
    by (auto simp add: write_bytes.simps)
next
  case (2 a'' b bs m)
  have "no_block_overflow (a'' + 1, length bs)"
    using 2(3)
    unfolding no_block_overflow.simps
    by unat_arith
  moreover
  have "a'' < a'' + (1 + of_nat (length bs))"
    apply (subst x_lt_x_plus_y)
    using 2(3)
     apply (simp add: no_block_overflow.simps max_word_eq)
     apply unat_arith
     apply (auto simp add: unat_of_nat)
    using 2(3)
    apply (simp add: no_block_overflow.simps max_word_eq)
    apply unat_arith
    by (auto simp add: unat_of_nat)
  moreover
  have "a'' + 1 \<le> a' \<Longrightarrow> a'' \<le> a'"
    using 2(3)
    apply (simp add: no_block_overflow.simps)
    apply unat_arith
    by (auto simp add: unat_of_nat)
  ultimately
  show ?case
    using 2(1)[of "m(a'' := b)"] 2(2-)
    apply (subst (asm) write_bytes.simps)
    by (cases "a' = a''") (auto simp add: Let'_def Machine.set_def fun_upd_def field_simps split: if_split_asm)
qed

lemma preservation_write_blocks:
  assumes "no_block_overflow (a, length bs)"
    and "a' < a \<or> a + of_nat (length bs) \<le> a'"
  shows "write_blocks [a \<rhd> bs] m a' = m a'"
  using assms
  using preservation_write_bytes[of "(a, bs)" m a']
  apply (auto simp add: simp_rules Let'_def write_blocks.simps(2) write_block.simps)
   apply unat_arith
  apply unat_arith
  by auto

section \<open>Exec and ACode\<close>

text \<open>@{text ii} is a dummy variable used for block rule matching; each block has a unique ID.\<close>
function exec_block :: \<open>nat \<Rightarrow> 64 word \<Rightarrow> nat \<Rightarrow> state \<Rightarrow> state\<close> where
  \<open>exec_block n end ii \<sigma> = (let'
      ip = RIP \<sigma>;
      (i, s) = fetch ip;
      \<sigma>' = step i s \<sigma>
    in if ip = end \<or> n = 0 then
       \<sigma>'
    else
      exec_block (n - 1) end ii \<sigma>'
  )\<close>
  by auto
termination exec_block
  by (relation \<open>measure (\<lambda>(n, _). n)\<close>) auto
declare exec_block.simps[simp del]

end

end


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

section{*The Otway-Rees Protocol as Modified by Abadi and Needham*}

theory OtwayRees_AN imports Public begin

text{*
This simplified version has minimal encryption and explicit messages.

Note that the formalization does not even assume that nonces are fresh.
This is because the protocol does not rely on uniqueness of nonces for
security, only for freshness, and the proof script does not prove freshness
properties.

From page 11 of
  Abadi and Needham (1996).
  Prudent Engineering Practice for Cryptographic Protocols.
  IEEE Trans. SE 22 (1)
*}

inductive_set otway :: "event list set"
  where
   Nil: --{*The empty trace*}
        "[] \<in> otway"

 | Fake: --{*The Spy may say anything he can say.  The sender field is correct,
            but agents don't use that information.*}
         "[| evsf \<in> otway;  X \<in> synth (analz (knows Spy evsf)) |]
          ==> Says Spy B X  # evsf \<in> otway"

 | Reception: --{*A message that has been sent can be received by the
                  intended recipient.*}
              "[| evsr \<in> otway;  Says A B X \<in>set evsr |]
               ==> Gets B X # evsr \<in> otway"

 | OR1:  --{*Alice initiates a protocol run*}
         "evs1 \<in> otway
          ==> Says A B {|Agent A, Agent B, Nonce NA|} # evs1 \<in> otway"

 | OR2:  --{*Bob's response to Alice's message.*}
         "[| evs2 \<in> otway;
             Gets B {|Agent A, Agent B, Nonce NA|} \<in>set evs2 |]
          ==> Says B Server {|Agent A, Agent B, Nonce NA, Nonce NB|}
                 # evs2 \<in> otway"

 | OR3:  --{*The Server receives Bob's message.  Then he sends a new
           session key to Bob with a packet for forwarding to Alice.*}
         "[| evs3 \<in> otway;  Key KAB \<notin> used evs3;
             Gets Server {|Agent A, Agent B, Nonce NA, Nonce NB|}
               \<in>set evs3 |]
          ==> Says Server B
               {|Crypt (shrK A) {|Nonce NA, Agent A, Agent B, Key KAB|},
                 Crypt (shrK B) {|Nonce NB, Agent A, Agent B, Key KAB|}|}
              # evs3 \<in> otway"

 | OR4:  --{*Bob receives the Server's (?) message and compares the Nonces with
             those in the message he previously sent the Server.
             Need @{term "B \<noteq> Server"} because we allow messages to self.*}
         "[| evs4 \<in> otway;  B \<noteq> Server;
             Says B Server {|Agent A, Agent B, Nonce NA, Nonce NB|} \<in>set evs4;
             Gets B {|X, Crypt(shrK B){|Nonce NB,Agent A,Agent B,Key K|}|}
               \<in>set evs4 |]
          ==> Says B A X # evs4 \<in> otway"

 | Oops: --{*This message models possible leaks of session keys.  The nonces
             identify the protocol run.*}
         "[| evso \<in> otway;
             Says Server B
                      {|Crypt (shrK A) {|Nonce NA, Agent A, Agent B, Key K|},
                        Crypt (shrK B) {|Nonce NB, Agent A, Agent B, Key K|}|}
               \<in>set evso |]
          ==> Notes Spy {|Nonce NA, Nonce NB, Key K|} # evso \<in> otway"

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

text{*A "possibility property": there are traces that reach the end*}
lemma "[| B \<noteq> Server; Key K \<notin> used [] |]
      ==> \<exists>evs \<in> otway.
           Says B A (Crypt (shrK A) {|Nonce NA, Agent A, Agent B, Key K|})
             \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] otway.Nil
                    [THEN otway.OR1, THEN otway.Reception,
                     THEN otway.OR2, THEN otway.Reception,
                     THEN otway.OR3, THEN otway.Reception, THEN otway.OR4])
apply (possibility, simp add: used_Cons)
done

lemma Gets_imp_Says [dest!]:
     "[| Gets B X \<in> set evs; evs \<in> otway |] ==> \<exists>A. Says A B X \<in> set evs"
by (erule rev_mp, erule otway.induct, auto)

text{* For reasoning about the encrypted portion of messages *}

lemma OR4_analz_knows_Spy:
     "[| Gets B {|X, Crypt(shrK B) X'|} \<in> set evs;  evs \<in> otway |]
      ==> X \<in> analz (knows Spy evs)"
by blast

text{*Theorems of the form @{term "X \<notin> parts (spies evs)"} imply that
NOBODY sends messages containing X! *}

text{*Spy never sees a good agent's shared key!*}
lemma Spy_see_shrK [simp]:
     "evs \<in> otway ==> (Key (shrK A) \<in> parts (knows Spy evs)) = (A \<in> bad)"
by (erule otway.induct, simp_all, blast+)

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

lemma Spy_see_shrK_D [dest!]:
     "[|Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> otway|] ==> A \<in> bad"
by (blast dest: Spy_see_shrK)

subsection{*Proofs involving analz *}

text{*Describes the form of K and NA when the Server sends this message.*}
lemma Says_Server_message_form:
     "[| Says Server B
            {|Crypt (shrK A) {|NA, Agent A, Agent B, Key K|},
              Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
           \<in> set evs;
         evs \<in> otway |]
      ==> K \<notin> range shrK & (\<exists>i. NA = Nonce i) & (\<exists>j. NB = Nonce j)"
apply (erule rev_mp)
apply (erule otway.induct, auto)
done

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

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

 A more general formula must be proved inductively.
****)

text{* Session keys are not used to encrypt other session keys *}

text{*The equality makes the induction hypothesis easier to apply*}
lemma analz_image_freshK [rule_format]:
 "evs \<in> otway ==>
   \<forall>K KK. KK <= -(range shrK) -->
          (Key K \<in> analz (Key`KK Un (knows Spy evs))) =
          (K \<in> KK | Key K \<in> analz (knows Spy evs))"
apply (erule otway.induct)
apply (frule_tac [8] Says_Server_message_form)
apply (drule_tac [7] OR4_analz_knows_Spy, analz_freshK, spy_analz, auto)
done

lemma analz_insert_freshK:
  "[| evs \<in> otway;  KAB \<notin> range shrK |] ==>
      (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{*The Key K uniquely identifies the Server's message.*}
lemma unique_session_keys:
     "[| Says Server B
          {|Crypt (shrK A) {|NA, Agent A, Agent B, K|},
            Crypt (shrK B) {|NB, Agent A, Agent B, K|}|}
         \<in> set evs;
        Says Server B'
          {|Crypt (shrK A') {|NA', Agent A', Agent B', K|},
            Crypt (shrK B') {|NB', Agent A', Agent B', K|}|}
         \<in> set evs;
        evs \<in> otway |]
     ==> A=A' & B=B' & NA=NA' & NB=NB'"
apply (erule rev_mp, erule rev_mp, erule otway.induct, simp_all)
apply blast+  --{*OR3 and OR4*}
done

subsection{*Authenticity properties relating to NA*}

text{*If the encrypted message appears then it originated with the Server!*}
lemma NA_Crypt_imp_Server_msg [rule_format]:
    "[| A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
     ==> Crypt (shrK A) {|NA, Agent A, Agent B, Key K|} \<in> parts (knows Spy evs)
       --> (\<exists>NB. Says Server B
                    {|Crypt (shrK A) {|NA, Agent A, Agent B, Key K|},
                      Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
                    \<in> set evs)"
apply (erule otway.induct, force)
apply (simp_all add: ex_disj_distrib)
apply blast+  --{*Fake, OR3*}
done

text{*Corollary: if A receives B's OR4 message then it originated with the
      Server. Freshness may be inferred from nonce NA.*}
lemma A_trusts_OR4:
     "[| Says B' A (Crypt (shrK A) {|NA, Agent A, Agent B, Key K|}) \<in> set evs;
         A \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> \<exists>NB. Says Server B
                  {|Crypt (shrK A) {|NA, Agent A, Agent B, Key K|},
                    Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
                 \<in> set evs"
by (blast intro!: NA_Crypt_imp_Server_msg)

text{*Crucial secrecy property: Spy does not see the keys sent in msg OR3
    Does not in itself guarantee security: an attack could violate
    the premises, e.g. by having @{term "A=Spy"}*}
lemma secrecy_lemma:
     "[| A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
      ==> Says Server B
           {|Crypt (shrK A) {|NA, Agent A, Agent B, Key K|},
             Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
          \<in> set evs -->
          Notes Spy {|NA, NB, Key K|} \<notin> set evs -->
          Key K \<notin> analz (knows Spy evs)"
apply (erule otway.induct, force)
apply (frule_tac [7] Says_Server_message_form)
apply (drule_tac [6] OR4_analz_knows_Spy)
apply (simp_all add: analz_insert_eq analz_insert_freshK pushes)
apply spy_analz  --{*Fake*}
apply (blast dest: unique_session_keys)+  --{*OR3, OR4, Oops*}
done

lemma Spy_not_see_encrypted_key:
     "[| Says Server B
            {|Crypt (shrK A) {|NA, Agent A, Agent B, Key K|},
              Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
           \<in> set evs;
         Notes Spy {|NA, NB, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
  by (metis secrecy_lemma)

text{*A's guarantee.  The Oops premise quantifies over NB because A cannot know
  what it is.*}
lemma A_gets_good_key:
     "[| Says B' A (Crypt (shrK A) {|NA, Agent A, Agent B, Key K|}) \<in> set evs;
         \<forall>NB. Notes Spy {|NA, NB, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
  by (metis A_trusts_OR4 secrecy_lemma)

subsection{*Authenticity properties relating to NB*}

text{*If the encrypted message appears then it originated with the Server!*}
lemma NB_Crypt_imp_Server_msg [rule_format]:
 "[| B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
  ==> Crypt (shrK B) {|NB, Agent A, Agent B, Key K|} \<in> parts (knows Spy evs)
      --> (\<exists>NA. Says Server B
                   {|Crypt (shrK A) {|NA, Agent A, Agent B, Key K|},
                     Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
                   \<in> set evs)"
apply (erule otway.induct, force, simp_all add: ex_disj_distrib)
apply blast+  --{*Fake, OR3*}
done

text{*Guarantee for B: if it gets a well-formed certificate then the Server
  has sent the correct message in round 3.*}
lemma B_trusts_OR3:
     "[| Says S B {|X, Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
           \<in> set evs;
         B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> \<exists>NA. Says Server B
                   {|Crypt (shrK A) {|NA, Agent A, Agent B, Key K|},
                     Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
                   \<in> set evs"
by (blast intro!: NB_Crypt_imp_Server_msg)

text{*The obvious combination of @{text B_trusts_OR3} with
      @{text Spy_not_see_encrypted_key}*}
lemma B_gets_good_key:
     "[| Gets B {|X, Crypt (shrK B) {|NB, Agent A, Agent B, Key K|}|}
          \<in> set evs;
         \<forall>NA. Notes Spy {|NA, NB, Key K|} \<notin> set evs;
         A \<notin> bad;  B \<notin> bad;  A \<noteq> B;  evs \<in> otway |]
      ==> Key K \<notin> analz (knows Spy evs)"
by (blast dest: B_trusts_OR3 Spy_not_see_encrypted_key)

end


theory inNotData

imports Data_inc
  begin

typedef inNot="{cout}"
  by auto

instance inNot::finite
  apply (intro_classes)
  using type_definition.Abs_image type_definition_inNot typedef_finite_UNIV by fastforce

instantiation inNot::somechan
begin
definition Rep_inNot_def: "Rep = Rep_inNot"

lemma repnot_range[simp]: "range (Rep::inNot \<Rightarrow> channel) = {cout}"
  apply(subst Rep_inNot_def)
  using type_definition.Rep_range type_definition_inNot by fastforce

instance
  apply(intro_classes)
  apply clarsimp
  unfolding Rep_inNot_def by (meson Rep_inNot_inject injI)
end

lemma inNot_chdom[simp]: "chDom TYPE (inNot) = {cout}"
  by (simp add: somechandom)

section \<open>Constructors\<close>

definition "Notin \<equiv> Abs_inNot cout"

free_constructors inNot for Notin
  apply auto?  (* TODO: kann man das "auto" entfernen? *)
  unfolding Notin_def
  apply (metis Rep_inNot Rep_inNot_inverse empty_iff insert_iff)
  apply (simp add: Abs_inNot_inject)?
  done

lemma notin_rep [simp]: "Rep Notin = cout"
  unfolding Rep_inNot_def Notin_def
  by (simp add: Abs_inNot_inverse)

section \<open>Preperation for locale instantiation\<close>

(* Tuple:
      1. Value should go to port cout. It is of type "bool"
*)

(* The first parameter is the converter from user-type (here bool) to "M"

  for every type in the tuple such a function must be in the parameter. So if the tuple
  would consist of (nat\<times>bool) there are 2 converters required *)

fun inNotChan::"('bool \<Rightarrow> 'a) \<Rightarrow> ('bool) \<Rightarrow> inNot \<Rightarrow> 'a" where
"inNotChan boolConv  (port_cout) Notin = boolConv port_cout"

(* Helper Function for lemmata (mostly surj). Should be hidden from the user! *)
definition inNotChan_inv::"('bool \<Rightarrow> 'a) \<Rightarrow> (inNot \<Rightarrow> 'a) \<Rightarrow> ('bool)" where
"inNotChan_inv boolConv f = ((inv boolConv) (f Notin))"

lemma inNotChan_surj_helper:
    assumes "f Notin \<in> range boolConv"
  shows "inNotChan boolConv (inNotChan_inv boolConv f) = f"
  unfolding inNotChan_inv_def
  apply(rule ext, rename_tac "c")
  apply(case_tac c; simp)
  by (auto simp add: assms f_inv_into_f)

lemma inNotChan_surj:
    assumes "f Notin \<in> range boolConv"
      shows "f \<in> range (inNotChan boolConv)"
  by (metis UNIV_I image_iff assms inNotChan_surj_helper)

lemma inNotChan_inj: assumes "inj boolConv"
  shows "inj (inNotChan boolConv)"
  apply (auto simp add: inj_def)
   by (metis assms inNotChan.simps injD)+

lemma rangecout[simp]:"range (Tsyn o (map_option) \<B>) = ctype cout"
  apply(auto simp add: ctype_def)
 by (metis option.simps(9) range_eqI)

subsection \<open>SBE\<close>
(* Dieses Beispiel ist zeitsychron, daher das "Tsyn" *)
abbreviation "buildNotInSBE \<equiv> inNotChan (Tsyn o map_option \<B>)"
(* Die Signatur lautet: "bool option \<times> bool option \<Rightarrow> inNot \<Rightarrow> M"
    Das "option" kommt aus der Zeit. "None" = keine Nachricht *)

lemma buildnotin_ctype: "buildNotInSBE a c \<in> ctype (Rep c)"
  apply(cases c; cases a)
  by(auto simp add: ctype_def)

lemma buildnotin_inj: "inj buildNotInSBE"
  apply(rule inNotChan_inj)
  by simp

lemma buildnotin_range: "range (\<lambda>a. buildNotInSBE a c) = ctype (Rep c)"
  apply(cases c)
  apply(auto simp add: image_iff ctype_def)
  by (metis option.simps(9))+

lemma buildnotin_surj: assumes "\<And>c. sbe c \<in> ctype (Rep c)"
  shows "sbe \<in> range buildNotInSBE"
  apply(rule inNotChan_surj)
   apply (metis notin_rep assms rangecout) (* Die metis-Sachen kann man bestimmt in einen 1-Zeiler umwandeln *)
  done

interpretation notInSBE: sbeGen "buildNotInSBE"
  apply(unfold_locales)
  apply(simp add: buildnotin_ctype)
  apply (simp add: buildnotin_inj)
  apply (simp add: buildnotin_surj)
  by simp

subsection \<open>SB\<close>

abbreviation "buildNotInSB \<equiv> inNotChan (Rep_cfun (smap (Tsyn o map_option \<B>)))"

lemma buildNotInSB_ctype: "sValues\<cdot>(buildNotInSB a c) \<subseteq> ctype (Rep c)"
  apply(cases c; cases a)
  by (auto simp add: ctype_def smap_sValues)

lemma buildNotInSB_inj: "inj buildNotInSB"
  apply(rule inNotChan_inj, rule smap_inj)
  by (simp)

lemma smap_rang2values: assumes "sValues\<cdot>s \<subseteq> range f"
    shows "s \<in> range (Rep_cfun (smap f))"
  using assms smap_well by force

lemma buildNotInSB_surj: assumes "sb_well sb"
  shows "sb \<in> range buildNotInSB"
  apply(rule inNotChan_surj; rule smap_rang2values; rule sbwellD)
  apply (simp_all add: assms)
  using rangecout apply simp
  done

interpretation notInSB: sbGen "buildNotInSB"
  apply(unfold_locales)
  apply (simp add: buildNotInSB_ctype)
  apply (simp add: buildNotInSB_inj)
  by (simp add: buildNotInSB_surj)

end