section {*L\_ATS\_Simulation\_Configuration\_WeakBRA*}
theory
  L_ATS_Simulation_Configuration_WeakBRA

imports
  L_ATS_Simulation_Configuration_WeakDET

begin

locale ATS_Simulation_Configuration_WeakBRA =
  ATS_Simulation_Configuration_WeakDET
  "TSstructure1 :: 'TSstructure1 \<Rightarrow> bool"
  "configurations1 :: 'TSstructure1 \<Rightarrow> 'conf1 set"
  "initial_configurations1 :: 'TSstructure1 \<Rightarrow> 'conf1 set"
  "step_labels1 :: 'TSstructure1 \<Rightarrow> 'label1 set"
  "step_relation1 :: 'TSstructure1 \<Rightarrow> 'conf1 \<Rightarrow> 'label1 \<Rightarrow> 'conf1 \<Rightarrow> bool"
  "effects1 :: 'TSstructure1 \<Rightarrow> 'event1 set"
  "marking_condition1 :: 'TSstructure1 \<Rightarrow> ('label1,'conf1)derivation \<Rightarrow> bool"
  "marked_effect1 :: 'TSstructure1 \<Rightarrow> ('label1,'conf1)derivation \<Rightarrow> 'event1 set"
  "unmarked_effect1 :: 'TSstructure1 \<Rightarrow> ('label1,'conf1)derivation \<Rightarrow> 'event1 set"
  "TSstructure2 :: 'TSstructure2 \<Rightarrow> bool"
  "configurations2 :: 'TSstructure2 \<Rightarrow> 'conf2 set"
  "initial_configurations2 :: 'TSstructure2 \<Rightarrow> 'conf2 set"
  "step_labels2 :: 'TSstructure2 \<Rightarrow> 'label2 set"
  "step_relation2 :: 'TSstructure2 \<Rightarrow> 'conf2 \<Rightarrow> 'label2 \<Rightarrow> 'conf2 \<Rightarrow> bool"
  "effects2 :: 'TSstructure2 \<Rightarrow> 'event2 set"
  "marking_condition2 :: 'TSstructure2 \<Rightarrow> ('label2,'conf2)derivation \<Rightarrow> bool"
  "marked_effect2 :: 'TSstructure2 \<Rightarrow> ('label2,'conf2)derivation \<Rightarrow> 'event2 set"
  "unmarked_effect2 :: 'TSstructure2 \<Rightarrow> ('label2,'conf2)derivation \<Rightarrow> 'event2 set"
  "relation_configurationLR :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2 \<Rightarrow> bool"
  "relation_initial_configurationLR :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2 \<Rightarrow> bool"
  "relation_effectLR :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'event1 \<Rightarrow> 'event2 \<Rightarrow> bool"
  "relation_TSstructureLR :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> bool"
  "relation_initial_simulationLR :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> (nat \<Rightarrow> ('label2, 'conf2) derivation_configuration option) \<Rightarrow> bool"
  "relation_step_simulationLR :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'conf1 \<Rightarrow> 'label1 \<Rightarrow> 'conf1 \<Rightarrow> 'conf2 \<Rightarrow> (nat \<Rightarrow> ('label2, 'conf2) derivation_configuration option) \<Rightarrow> bool"
  "relation_configurationRL :: 'TSstructure2 \<Rightarrow> 'TSstructure1 \<Rightarrow> 'conf2 \<Rightarrow> 'conf1 \<Rightarrow> bool"
  "relation_initial_configurationRL :: 'TSstructure2 \<Rightarrow> 'TSstructure1 \<Rightarrow> 'conf2 \<Rightarrow> 'conf1 \<Rightarrow> bool"
  "relation_effectRL :: 'TSstructure2 \<Rightarrow> 'TSstructure1 \<Rightarrow> 'event2 \<Rightarrow> 'event1 \<Rightarrow> bool"
  "relation_TSstructureRL :: 'TSstructure2 \<Rightarrow> 'TSstructure1 \<Rightarrow> bool"
  "relation_initial_simulationRL :: 'TSstructure2 \<Rightarrow> 'TSstructure1 \<Rightarrow> 'conf2 \<Rightarrow> (nat \<Rightarrow> ('label1, 'conf1) derivation_configuration option) \<Rightarrow> bool"
  "relation_step_simulationRL :: 'TSstructure2 \<Rightarrow> 'TSstructure1 \<Rightarrow> 'conf2 \<Rightarrow> 'label2 \<Rightarrow> 'conf2 \<Rightarrow> 'conf1 \<Rightarrow> (nat \<Rightarrow> ('label1, 'conf1) derivation_configuration option) \<Rightarrow> bool"
  "label_relation :: 'TSstructure1 \<Rightarrow> 'TSstructure2 \<Rightarrow> 'label1 \<Rightarrow> 'label2 \<Rightarrow> bool"
  for
    TSstructure1 configurations1 initial_configurations1 step_labels1 step_relation1 effects1 marking_condition1 marked_effect1 unmarked_effect1 TSstructure2 configurations2 initial_configurations2 step_labels2 step_relation2 effects2 marking_condition2 marked_effect2 unmarked_effect2 relation_configurationLR relation_initial_configurationLR relation_effectLR relation_TSstructureLR relation_initial_simulationLR relation_step_simulationLR relation_configurationRL relation_initial_configurationRL relation_effectRL relation_TSstructureRL relation_initial_simulationRL relation_step_simulationRL label_relation
    +

assumes AX_relation_configuration_inverse: "
  relation_TSstructureLR G1 G2
  \<Longrightarrow> relation_configurationRL G2 G1 c2 c1
  \<Longrightarrow> relation_configurationLR G1 G2 c1 c2"

assumes AX_marking_condition_translation: "
  relation_TSstructureRL G2 G1
  \<Longrightarrow> relation_TSstructureLR G1 G2
  \<Longrightarrow> LR.GR.derivation_initial G2 dR
  \<Longrightarrow> maximum_of_domain dR nR
  \<Longrightarrow> dR nR = Some (pair enR cnR)
  \<Longrightarrow> LR.GL.derivation_initial G1 dL
  \<Longrightarrow> maximum_of_domain dL nL
  \<Longrightarrow> relation_initial_configurationRL G2 G1 c0R c0L
  \<Longrightarrow> relation_configurationRL G2 G1 cnR cnL
  \<Longrightarrow> dR 0 = Some (pair None c0R)
  \<Longrightarrow> dL 0 = Some (pair None c0L)
  \<Longrightarrow> dL nL = Some (pair enL cnL)
  \<Longrightarrow> LR.GL.derivation G1 dL2
  \<Longrightarrow> LR.GL.belongs G1 dL2
  \<Longrightarrow> maximum_of_domain dL2 nL2
  \<Longrightarrow> marking_condition1 G1 (derivation_append dL dL2 nL)
  \<Longrightarrow> dL2 0 = Some (pair None cnL)
  \<Longrightarrow> relation_configurationLR G1 G2 cnL cnR
  \<Longrightarrow> dL2 nL2 = Some (pair e2nL c2nL)
  \<Longrightarrow> LR.GR.derivation G2 d2R
  \<Longrightarrow> LR.GR.belongs G2 d2R
  \<Longrightarrow> maximum_of_domain d2R n2R
  \<Longrightarrow> relation_configurationLR G1 G2 c2nL cn2R
  \<Longrightarrow> d2R 0 = Some (pair None cnR)
  \<Longrightarrow> d2R n2R = Some (pair en2R cn2R)
  \<Longrightarrow> marking_condition2 G2 (derivation_append dR d2R nR)"

context ATS_Simulation_Configuration_WeakBRA begin

theorem Nonblockingness_branching_is_preserved: "
  relation_TSstructureRL G2 G1
  \<Longrightarrow> relation_TSstructureLR G1 G2
  \<Longrightarrow> LR.GL.Nonblockingness_branching G1
  \<Longrightarrow> LR.GR.Nonblockingness_branching G2"
  apply(simp add: LR.GR.Nonblockingness_branching_def)
  apply(clarsimp)
  apply(rename_tac dh n)(*strict*)
  apply(rename_tac dR nR)
  apply(rename_tac dR nR)(*strict*)
  apply(subgoal_tac "\<exists>enR cnR. dR nR = Some (pair enR cnR)")
  apply(rename_tac dR nR)(*strict*)
  prefer 2
  apply(rule LR.GR.some_position_has_details_before_max_dom)
  apply(rename_tac dR nR)(*strict*)
  apply(rule LR.GR.derivation_initial_is_derivation)
  apply(force)
  apply(rename_tac dR nR)(*strict*)
  apply(force)
  apply(rename_tac dR nR)(*strict*)
  apply(force)
  apply(rename_tac dR nR)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR cnR)(*strict*)
  apply(subgoal_tac "\<exists>d2 n2. LR.GL.derivation_initial G1 d2 \<and> maximum_of_domain d2 n2 \<and> relation_initial_configurationRL G2 G1 (the (get_configuration (dR 0))) (the (get_configuration (d2 0))) \<and> relation_configurationRL G2 G1 cnR (the (get_configuration (d2 n2)))")
  apply(rename_tac dR nR enR cnR)(*strict*)
  prefer 2
  apply(rule RL.ATS_Simulation_Configuration_Weak_simulation_derivation_exists)
  apply(rename_tac dR nR enR cnR)(*strict*)
  apply(force)
  apply(rename_tac dR nR enR cnR)(*strict*)
  apply(force)
  apply(rename_tac dR nR enR cnR)(*strict*)
  apply(force)
  apply(rename_tac dR nR enR cnR)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR cnR d2 n2)(*strict*)
  apply(simp add: get_configuration_def)
  apply(subgoal_tac "\<exists>c. dR 0 = Some (pair None c)")
  apply(rename_tac dR nR enR cnR d2 n2)(*strict*)
   prefer 2
   apply (metis LR.GR.derivation_initial_is_derivation LR.GR.some_position_has_details_at_0)
  apply(rename_tac dR nR enR cnR d2 n2)(*strict*)
  apply(subgoal_tac "\<exists>c. d2 0 = Some (pair None c)")
   apply(rename_tac dR nR enR cnR d2 n2)(*strict*)
   prefer 2
   apply (metis LR.GL.derivation_initial_is_derivation LR.GL.some_position_has_details_at_0)
  apply(rename_tac dR nR enR cnR d2 n2)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR cnR d2 n2 c ca)(*strict*)
  apply(subgoal_tac "\<exists>e c. d2 n2 = Some (pair e c)")
   apply(rename_tac dR nR enR cnR d2 n2 c ca)(*strict*)
   prefer 2
   apply(rule LR.GL.some_position_has_details_before_max_dom)
     apply(rename_tac dR nR enR cnR d2 n2 c ca)(*strict*)
     apply(rule LR.GL.derivation_initial_is_derivation)
     apply(force)
    apply(rename_tac dR nR enR cnR d2 n2 c ca)(*strict*)
    apply(force)
   apply(rename_tac dR nR enR cnR d2 n2 c ca)(*strict*)
   apply(force)
  apply(rename_tac dR nR enR cnR d2 n2 c ca)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR cnR d2 n2 c ca e cb)(*strict*)
  apply(rename_tac dL nL c0R c0L enL cnL)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL)(*strict*)
  apply(simp add: LR.GL.Nonblockingness_branching_def)
  apply(erule_tac
      x="dL"
      in allE)
  apply(clarsimp)
  apply(erule_tac
      x="nL"
      in allE)
  apply(clarsimp)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dc x)(*strict*)
  apply(rename_tac dL2 nL2)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2)(*strict*)
  apply(subgoal_tac "\<exists>c. dL2 0 =Some (pair None c)")
   apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2)(*strict*)
   prefer 2
   apply (metis LR.GL.some_position_has_details_at_0)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
  apply(subgoal_tac "relation_configurationLR G1 G2 cnL cnR")
   apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
   prefer 2
   apply(rule AX_relation_configuration_inverse)
    apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
    apply(force)
   apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
   apply(force)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
  apply(subgoal_tac "\<exists>e c. dL2 nL2= Some (pair e c)")
   apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
   prefer 2
   apply(rule LR.GL.some_position_has_details_before_max_dom)
     apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
     apply(force)
    apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
    apply(force)
   apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
   apply(force)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
  apply(subgoal_tac "\<exists>d2 n2. LR.GR.derivation G2 d2 \<and> LR.GR.belongs G2 d2 \<and> maximum_of_domain d2 n2 \<and> the (get_configuration (d2 0)) = cnR \<and> relation_configurationLR G1 G2 (the (get_configuration (dL2 0))) (the (get_configuration (d2 0))) \<and> relation_configurationLR G1 G2 ca (the (get_configuration (d2 n2)))")
   apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
   prefer 2
   apply(rule LR.ATS_Simulation_Configuration_Weak_simulation_derivation_exists_witness2)
         apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
         apply(force)
        apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
        apply(force)
       apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
       apply(force)
      apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
      apply(simp add: derivation_append_fit_def)
     apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
     apply(simp add: derivation_append_fit_def)
    apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
    apply(simp add: derivation_append_fit_def)
    apply (metis LR.GR.belongs_configurations LR.GR.derivation_initial_belongs LR.AX_TSstructure_relation_TSstructure2_belongs)
   apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
   apply(simp add: derivation_append_fit_def)
  apply(rename_tac dR nR enR cnR dL nL c0R c0L enL cnL dL2 nL2 c e ca)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
  apply(rule_tac
      x="d2"
      in exI)
  apply(clarsimp)
  apply(rule conjI)
   apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
   apply(force)
  apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
  apply(subgoal_tac "\<exists>c. d2 0 = Some (pair None c)")
   apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
   prefer 2
   apply (metis LR.GR.some_position_has_details_at_0)
  apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
  apply(subgoal_tac "\<exists>e c. d2 n2 = Some (pair e c)")
   apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
   prefer 2
   apply(rule LR.GR.some_position_has_details_before_max_dom)
     apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
     apply(force)
    apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
    apply(force)
   apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
   apply(force)
  apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2)(*strict*)
  apply(clarsimp)
  apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2 cb ea cc)(*strict*)
  apply(rule conjI)
   apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2 cb ea cc)(*strict*)
   apply(simp add: derivation_append_fit_def)
   apply(simp add: get_configuration_def)
  apply(rename_tac dR nR enR dL nL c0R c0L enL cnL dL2 nL2 c e ca d2 n2 cb ea cc)(*strict*)
  apply(simp add: derivation_append_fit_def)
  apply(clarsimp)
  apply(rename_tac dR nR enR dL nL c0R c0L enL dL2 nL2 c e ca d2 n2 cb ea cc)(*strict*)
  apply(simp add: get_configuration_def)
  apply(rename_tac cnL e2nL c2nL d2R n2R cnR en2R cn2R)
  apply(rename_tac dR nR enR dL nL c0R c0L enL dL2 nL2 cnL e2nL c2nL d2R n2R cnR en2R cn2R)(*strict*)
  apply(rule AX_marking_condition_translation)
                      apply(rename_tac dR nR enR dL nL c0R c0L enL dL2 nL2 cnL e2nL c2nL d2R n2R cnR en2R cn2R)(*strict*)
                      apply(force)+
  done

end

end


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

Lemmas on guarded messages for public protocols.
*)

theory Guard_Public imports Guard "../Public" Extensions begin

subsection{*Extensions to Theory @{text Public}*}

declare initState.simps [simp del]

subsubsection{*signature*}

definition sign :: "agent => msg => msg" where
"sign A X == {|Agent A, X, Crypt (priK A) (Hash X)|}"

lemma sign_inj [iff]: "(sign A X = sign A' X') = (A=A' & X=X')"
by (auto simp: sign_def)

subsubsection{*agent associated to a key*}

definition agt :: "key => agent" where
"agt K == @A. K = priK A | K = pubK A"

lemma agt_priK [simp]: "agt (priK A) = A"
by (simp add: agt_def)

lemma agt_pubK [simp]: "agt (pubK A) = A"
by (simp add: agt_def)

subsubsection{*basic facts about @{term initState}*}

lemma no_Crypt_in_parts_init [simp]: "Crypt K X ~:parts (initState A)"
by (cases A, auto simp: initState.simps)

lemma no_Crypt_in_analz_init [simp]: "Crypt K X ~:analz (initState A)"
by auto

lemma no_priK_in_analz_init [simp]: "A ~:bad
==> Key (priK A) ~:analz (initState Spy)"
by (auto simp: initState.simps)

lemma priK_notin_initState_Friend [simp]: "A ~= Friend C
==> Key (priK A) ~: parts (initState (Friend C))"
by (auto simp: initState.simps)

lemma keyset_init [iff]: "keyset (initState A)"
by (cases A, auto simp: keyset_def initState.simps)

subsubsection{*sets of private keys*}

definition priK_set :: "key set => bool" where
"priK_set Ks == ALL K. K:Ks --> (EX A. K = priK A)"

lemma in_priK_set: "[| priK_set Ks; K:Ks |] ==> EX A. K = priK A"
by (simp add: priK_set_def)

lemma priK_set1 [iff]: "priK_set {priK A}"
by (simp add: priK_set_def)

lemma priK_set2 [iff]: "priK_set {priK A, priK B}"
by (simp add: priK_set_def)

subsubsection{*sets of good keys*}

definition good :: "key set => bool" where
"good Ks == ALL K. K:Ks --> agt K ~:bad"

lemma in_good: "[| good Ks; K:Ks |] ==> agt K ~:bad"
by (simp add: good_def)

lemma good1 [simp]: "A ~:bad ==> good {priK A}"
by (simp add: good_def)

lemma good2 [simp]: "[| A ~:bad; B ~:bad |] ==> good {priK A, priK B}"
by (simp add: good_def)

subsubsection{*greatest nonce used in a trace, 0 if there is no nonce*}

primrec greatest :: "event list => nat"
where
  "greatest [] = 0"
| "greatest (ev # evs) = max (greatest_msg (msg ev)) (greatest evs)"

lemma greatest_is_greatest: "Nonce n:used evs ==> n <= greatest evs"
apply (induct evs, auto simp: initState.simps)
apply (drule used_sub_parts_used, safe)
apply (drule greatest_msg_is_greatest, arith)
by simp

subsubsection{*function giving a new nonce*}

definition new :: "event list => nat" where
"new evs == Suc (greatest evs)"

lemma new_isnt_used [iff]: "Nonce (new evs) ~:used evs"
by (clarify, drule greatest_is_greatest, auto simp: new_def)

subsection{*Proofs About Guarded Messages*}

subsubsection{*small hack necessary because priK is defined as the inverse of pubK*}

lemma pubK_is_invKey_priK: "pubK A = invKey (priK A)"
by simp

lemmas pubK_is_invKey_priK_substI = pubK_is_invKey_priK [THEN ssubst]

lemmas invKey_invKey_substI = invKey [THEN ssubst]

lemma "Nonce n:parts {X} ==> Crypt (pubK A) X:guard n {priK A}"
apply (rule pubK_is_invKey_priK_substI, rule invKey_invKey_substI)
by (rule Guard_Nonce, simp+)

subsubsection{*guardedness results*}

lemma sign_guard [intro]: "X:guard n Ks ==> sign A X:guard n Ks"
by (auto simp: sign_def)

lemma Guard_init [iff]: "Guard n Ks (initState B)"
by (induct B, auto simp: Guard_def initState.simps)

lemma Guard_knows_max': "Guard n Ks (knows_max' C evs)
==> Guard n Ks (knows_max C evs)"
by (simp add: knows_max_def)

lemma Nonce_not_used_Guard_spies [dest]: "Nonce n ~:used evs
==> Guard n Ks (spies evs)"
by (auto simp: Guard_def dest: not_used_not_known parts_sub)

lemma Nonce_not_used_Guard [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows (Friend C) evs)"
by (auto simp: Guard_def dest: known_used parts_trans)

lemma Nonce_not_used_Guard_max [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max (Friend C) evs)"
by (auto simp: Guard_def dest: known_max_used parts_trans)

lemma Nonce_not_used_Guard_max' [dest]: "[| evs:p; Nonce n ~:used evs;
Gets_correct p; one_step p |] ==> Guard n Ks (knows_max' (Friend C) evs)"
apply (rule_tac H="knows_max (Friend C) evs" in Guard_mono)
by (auto simp: knows_max_def)

subsubsection{*regular protocols*}

definition regular :: "event list set => bool" where
"regular p == ALL evs A. evs:p --> (Key (priK A):parts (spies evs)) = (A:bad)"

lemma priK_parts_iff_bad [simp]: "[| evs:p; regular p |] ==>
(Key (priK A):parts (spies evs)) = (A:bad)"
by (auto simp: regular_def)

lemma priK_analz_iff_bad [simp]: "[| evs:p; regular p |] ==>
(Key (priK A):analz (spies evs)) = (A:bad)"
by auto

lemma Guard_Nonce_analz: "[| Guard n Ks (spies evs); evs:p;
priK_set Ks; good Ks; regular p |] ==> Nonce n ~:analz (spies evs)"
apply (clarify, simp only: knows_decomp)
apply (drule Guard_invKey_keyset, simp+, safe)
apply (drule in_good, simp)
apply (drule in_priK_set, simp+, clarify)
apply (frule_tac A=A in priK_analz_iff_bad)
by (simp add: knows_decomp)+

end


\<^marker>\<open>creator "Maximilian P. L. Haslbeck"\<close>
\<^marker>\<open>contributor "Peter Lammich"\<close>
section \<open>More theory on NREST\<close>
theory NREST_Main
  imports NREST NREST_Type_Classes  Time_Refinement Data_Refinement
     NREST_Backwards_Reasoning NREST_Automation
begin

paragraph \<open>Summary\<close>
text \<open>This theory introduces more convenience lemmas on NREST\<close>

subsection \<open>Convenience Lemmas\<close>

lemma If_le_rule: "(c \<Longrightarrow> x \<le> a) \<Longrightarrow> (~c \<Longrightarrow> x \<le> b) \<Longrightarrow> x \<le> (if c then a else b)"
  by auto

lemma If_le_Some_rule2: "(c \<Longrightarrow> x \<le> a) \<Longrightarrow> c \<Longrightarrow> Some x \<le> (if c then Some a else None)"
  by auto

term inres
subsection \<open>Interaction between Currency Refinement and Data Refinement\<close>

lemma timerefine_R_cf_mono:
  fixes R :: "_ \<Rightarrow> (_, enat) acost"
  assumes "wfR'' R'"
  shows "R\<le>R' \<Longrightarrow> \<Down> S (\<Down>\<^sub>C R c) \<le> \<Down> S (\<Down>\<^sub>C R' c)"
  by (simp add: assms nrest_Rel_mono timerefine_R_mono_wfR'')

lemma inresT_project_acost_timerefine: "inresT (project_acost b (\<Down>\<^sub>C E m')) x' t
       \<Longrightarrow> \<exists>t b. inresT (project_acost b m') x' t"
  unfolding inresT_def project_acost_def timerefine_def
  apply(cases m'; auto simp: le_fun_def split: if_splits option.splits)
  by (metis zero_enat_def zero_le)

lemma bindT_refine_conc_time:
  fixes m :: "('e1,('c1,enat)acost) nrest"
  fixes m' :: "('e2,('c2,enat)acost) nrest"
  assumes "wfR E" " m \<le> \<Down>R' (\<Down>\<^sub>C E m')"
  "(\<And>x x'. \<lbrakk>(x,x')\<in>R';  \<exists>t b. inresT (project_acost b m) x t;  \<exists>t b. inresT (project_acost b m') x' t;
    nofailT m; nofailT m'\<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (\<Down>\<^sub>C E (f' x') ))"
shows "bindT m f \<le>  \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
  using assms
proof -
  term "(\<Down>\<^sub>C E m')"
  term timerefine
  have "bindT m (\<lambda>x.  (f x)) \<le>  \<Down> R (bindT (\<Down>\<^sub>C E m') (\<lambda>x. \<Down>\<^sub>C E (f' x)))"
    apply(rule bindT_conc_acost_refine') apply(rule assms(2))
    apply(rule assms(3))
    by (auto simp: refine_pw_simps dest: inresT_project_acost_timerefine)
  also have "\<dots> \<le> \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
    apply(rule nrest_Rel_mono)
    apply(rule timerefine_bindT_ge) by(fact assms(1))
  finally show ?thesis .
qed
lemma bindT_refine_conc_time2:
  fixes m :: "('e1,('c1,enat)acost) nrest"
  fixes m' :: "('e2,('c2,enat)acost) nrest"
  assumes "wfR'' E" " m \<le> \<Down>R' (\<Down>\<^sub>C E m')"
  "(\<And>x x'. \<lbrakk>(x,x')\<in>R';  \<exists>t b. inresT (project_acost b m) x t;  \<exists>t b. inresT (project_acost b m') x' t;
    nofailT m; nofailT m'\<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (\<Down>\<^sub>C E (f' x') ))"
shows "bindT m f \<le>  \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
  using assms
proof -
  term "(\<Down>\<^sub>C E m')"
  term timerefine
  have "bindT m (\<lambda>x.  (f x)) \<le>  \<Down> R (bindT (\<Down>\<^sub>C E m') (\<lambda>x. \<Down>\<^sub>C E (f' x)))"
    apply(rule bindT_conc_acost_refine') apply(rule assms(2))
    apply(rule assms(3))
    by (auto simp: refine_pw_simps dest: inresT_project_acost_timerefine)
  also have "\<dots> \<le> \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
    apply(rule nrest_Rel_mono)
    apply(rule timerefine_bindT_ge2) by(fact assms(1))
  finally show ?thesis .
qed

lemma bindT_refine_conc_time_my:
  fixes m :: "('e1,('c1,enat)acost) nrest"
  fixes m' :: "('e2,('c2,enat)acost) nrest"
  assumes "wfR'' E" " m \<le> \<Down>R' (\<Down>\<^sub>C E m')"
  "(\<And>x x'. \<lbrakk>(x,x')\<in>R'; \<exists>t b. inresT (project_acost b m') x' t\<rbrakk>
         \<Longrightarrow> f x \<le> \<Down> R (\<Down>\<^sub>C E (f' x') ))"
shows "bindT m f \<le>  \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
  apply(rule bindT_refine_conc_time2) using assms by auto

lemma timerefine_conc_fun_ge:
  fixes C :: "('f, ('b, enat) acost) nrest"
  assumes "wfR E"
  shows "\<Down>\<^sub>C E (\<Down> R C) \<ge> \<Down>R (\<Down>\<^sub>C E C)"

  unfolding conc_fun_def timerefine_def
  apply(cases C) apply auto apply(rule le_funI)
  apply(rule Sup_least)
  apply (auto split: option.splits)
  subgoal
    by (metis (mono_tags, lifting) Sup_upper less_eq_option_Some_None mem_Collect_eq)
  unfolding less_eq_acost_def apply auto
  apply(rule Sum_any_mono)
  apply(rule mult_right_mono)
  subgoal
    by (metis (mono_tags, lifting) Sup_upper less_eq_option_Some mem_Collect_eq the_acost_mono)
    apply simp
  apply(rule wfR_finite_mult_left )
  using assms by simp

lemma timerefine_conc_fun_ge2:
  fixes C :: "('f, ('b, enat) acost) nrest"
  assumes "wfR'' E"
  shows "\<Down>\<^sub>C E (\<Down> R C) \<ge> \<Down>R (\<Down>\<^sub>C E C)"

  unfolding conc_fun_def timerefine_def
  apply(cases C) apply auto apply(rule le_funI)
  apply(rule Sup_least)
  apply (auto split: option.splits)
  subgoal
    by (metis (mono_tags, lifting) Sup_upper less_eq_option_Some_None mem_Collect_eq)
  unfolding less_eq_acost_def apply auto
  apply(rule Sum_any_mono)
  apply(rule mult_right_mono)
  subgoal
    by (metis (mono_tags, lifting) Sup_upper less_eq_option_Some mem_Collect_eq the_acost_mono)
    apply simp
  apply(rule wfR_finite_mult_left2 )
  using assms by simp

lemma timerefine_conc_fun_le2:
  assumes "continuous E"
  shows "timerefine' E (\<Down> R C) = \<Down>R (timerefine' E C)"
  unfolding timerefine'_def conc_fun_def
  apply(auto split: nrest.splits option.splits simp: fun_eq_iff)
  subgoal
    by (smt Sup_bot_conv(1) bot_option_def mem_Collect_eq)
  subgoal premises p for x2 x2a x2b x x2c
  proof -
    have "Sup {x2b a |a. (x, a) \<in> R} = Sup {map_option E (x2 a) |a. (x, a) \<in> R}"
      apply(rule arg_cong[where f=Sup])
      using p(3)[rule_format] p(4)
      apply auto
      subgoal by (smt map_option_eq_Some option.exhaust)
      subgoal by (metis not_None_eq option.simps(8) option.simps(9))
      done
    also have "\<dots> = map_option E (Sup {x2 a |a. (x, a) \<in> R})"
      apply(subst continuous_map_option[OF assms, THEN continuousD] )
      apply(rule arg_cong[where f=Sup])
      by auto
    also have "\<dots> = map_option E (Some x2c)"
      using p(2)[rule_format, of x, unfolded p(4)] by simp
    also have "\<dots> = Some (E x2c)" by simp
    finally show "Some (E x2c) = Sup {x2b a |a. (x, a) \<in> R}"  by simp
  qed
  done

(* TODO: move*)
lemma nrest_le_formatI:
  fixes a :: "(_,(_,enat)acost) nrest"
  shows  "a \<le> \<Down>Id (\<Down>\<^sub>C TId b) \<Longrightarrow> a \<le> b"
  by (auto simp add: timerefine_id)

subsection \<open>nrest_trel\<close>

definition nrest_trel where
  nrest_trel_def_internal: "nrest_trel R E \<equiv> {(c,a).  c \<le> \<Down>R (\<Down>\<^sub>C E a)}"

lemma nrest_trelD: "(c,a)\<in>nrest_trel R E \<Longrightarrow> c \<le> \<Down>R (\<Down>\<^sub>C E a)" by (simp add: nrest_trel_def_internal)

lemma nrest_trelI: "c \<le> \<Down>R (\<Down>\<^sub>C E a) \<Longrightarrow> (c,a)\<in>nrest_trel R E" by (simp add: nrest_trel_def_internal)

subsection \<open>Type Class nrest_cost\<close>

class nrest_cost = complete_lattice + needname_zero + nonneg + ordered_semiring + semiring_no_zero_divisors

subsection \<open>Setup for refinement condition generator\<close>

lemma consume_refine:
  fixes M :: "('e, ('b, enat) acost) nrest"
  assumes "wfR'' E"
  shows "\<lbrakk>t \<le> timerefineA E t'; M \<le> \<Down> R (\<Down>\<^sub>C E M')\<rbrakk> \<Longrightarrow> NREST.consume M t \<le> \<Down>R (\<Down>\<^sub>C E (NREST.consume M' t'))"
  apply(subst timerefine_consume)
  subgoal using assms .
  apply(subst conc_fun_consume)
  apply(rule consume_mono) by auto

lemma MIf_refine:
  fixes f :: "(_,(string, enat) acost) nrest"
  shows "struct_preserving E \<Longrightarrow> wfR'' E \<Longrightarrow> (b,b')\<in>bool_rel \<Longrightarrow> (b \<Longrightarrow> f \<le> \<Down>R (\<Down>\<^sub>C E f'))
           \<Longrightarrow> (\<not>b \<Longrightarrow> g \<le> \<Down>R (\<Down>\<^sub>C E g')) \<Longrightarrow>  MIf b f g  \<le> \<Down>R (\<Down>\<^sub>C E (MIf b' f' g' ))"
  by(auto simp: MIf_def timerefineA_update_apply_same_cost dest: struct_preservingD intro!: consume_refine)

lemma ASSERT_D_leI[refine,refine0]:
  fixes M :: "(_,(_,enat)acost) nrest"
  shows "\<Phi> \<Longrightarrow> (\<Phi> \<Longrightarrow> M \<le> \<Down>R M') \<Longrightarrow> ASSERT \<Phi> \<bind> (\<lambda>_. M) \<le> \<Down>R M'"
  by (auto)

lemma ASSERT_D2_leI[refine0]:
  fixes S' :: "(_,(_,enat)acost) nrest"
  shows "(\<Phi> \<Longrightarrow> S \<le> \<Down> R S') \<Longrightarrow> S \<le> \<Down> R (do {
                                     _ \<leftarrow> ASSERT \<Phi>;
                                     S'
                                   })"
  by (auto simp: pw_acost_le_iff refine_pw_simps)

lemma ASSERT_D3_leI[refine0]:
  fixes S' :: "(_,(_,enat)acost) nrest"
  shows "(\<Phi> \<Longrightarrow> S \<le> \<Down> R (\<Down>\<^sub>C E S')) \<Longrightarrow> S \<le> \<Down> R (\<Down>\<^sub>C E (do {
                                     _ \<leftarrow> ASSERT \<Phi>;
                                     S'
                                   }))"
  by (auto simp: pw_acost_le_iff refine_pw_simps)

lemma ASSERT_D4_leI[refine0]:
  fixes S' :: "(_,(_,enat)acost) nrest"
  shows "(\<Phi> \<Longrightarrow> S \<le> \<Down> R (\<Down>\<^sub>C E S')) \<Longrightarrow> do { _ \<leftarrow> ASSERT \<Phi>; S } \<le> \<Down> R (\<Down>\<^sub>C E (do {
                                     _ \<leftarrow> ASSERT \<Phi>;
                                     S'
                                   }))"
  by (auto simp: pw_acost_le_iff refine_pw_simps)

lemma refine_Id[refine0]: "S \<le> \<Down> Id S"
  by auto

lemma refine_TId[refine0]:
  fixes S :: "(_,(_,enat)acost) nrest"
  shows  "S \<le> \<Down> Id (\<Down>\<^sub>C TId S)"
  unfolding timerefine_id
  by auto

lemma SPEC_refine[refine]:
  fixes T :: "_ \<Rightarrow> ((_,enat)acost)"
  assumes *: "\<And>x. \<Phi> x \<Longrightarrow> \<exists>s'. \<Phi>' s' \<and> (x, s') \<in> R \<and> T x \<le> T' s'"
  shows "SPEC \<Phi> T \<le> \<Down>R (SPEC \<Phi>' T')"
  unfolding SPEC_def
  by (auto simp: pw_acost_le_iff refine_pw_simps dest!: * intro: order.trans[OF _ the_acost_mono])

lemma SPEC_both_refine:
  fixes T :: "_ \<Rightarrow> ((_,enat)acost)"
  assumes "\<And>x. \<Phi> x \<Longrightarrow> \<exists>s'. \<Phi>' s' \<and> (x, s') \<in> R \<and> T x \<le> timerefineA TR (T' s')"
  shows "SPEC \<Phi> T \<le> \<Down> R (\<Down>\<^sub>C TR (SPEC \<Phi>' T'))"
  apply(rule order.trans)
  defer
   apply(rule nrest_Rel_mono)
   apply(rule SPEC_timerefine[where A=\<Phi>'])
    prefer 3 apply(rule SPEC_refine[where T=T])
    defer apply simp apply(rule order_refl)
  by (fact assms)

lemma ASSERT_D5_leI[refine0]:
  fixes S' :: "(_,(_,enat)acost) nrest"
  shows "(\<Phi> \<Longrightarrow> \<Down> R (\<Down>\<^sub>C F S) \<le> \<Down> R (\<Down>\<^sub>C E S')) \<Longrightarrow> \<Down> R (\<Down>\<^sub>C F ( do { _ \<leftarrow> ASSERT \<Phi>; S })) \<le> \<Down> R (\<Down>\<^sub>C E (do {
                                     _ \<leftarrow> ASSERT \<Phi>;
                                     S'
                                   }))"
  by (auto simp: pw_acost_le_iff refine_pw_simps)

declare consume_refine[refine0]

lemma RETURNT_refine_t[refine]:
  assumes "(x,x')\<in>R"
  shows "RETURNT x \<le> \<Down>R (\<Down>\<^sub>C E (RETURNT x'))"
  apply(subst timerefine_RETURNT)
  apply(rule RETURNT_refine) by (fact assms)

declare RETURNT_refine_t[refine0]
declare timerefineA_TId[refine0]

lemma SPECT_refine_t[refine]:
  fixes t :: "(_,enat) acost"
  assumes "(x,x')\<in>R"
    and "t\<le> timerefineA E t'"
  shows "SPECT [x\<mapsto>t] \<le> \<Down>R (\<Down>\<^sub>C E (SPECT [x'\<mapsto>t']))"
  apply(subst timerefine_SPECT_map)
  using assms apply(auto simp: pw_acost_le_iff refine_pw_simps)
  apply(cases t) apply (auto simp: less_eq_acost_def)
  subgoal for b ta xa apply(rule order.trans[where b="xa b"]) by auto
  done

lemma RECT_refine_t:
  assumes M: "mono2 body"
  assumes R0: "(x,x')\<in>R"
  assumes RS: "\<And>f f' x x'. \<lbrakk> \<And>x x'. (x,x')\<in>R \<Longrightarrow> f x \<le>\<Down>S (\<Down>\<^sub>C E (f' x')); (x,x')\<in>R \<rbrakk>
    \<Longrightarrow> body f x \<le>\<Down>S (\<Down>\<^sub>C E (body' f' x'))"
  shows "RECT (\<lambda>f x. body f x) x \<le>\<Down>S (\<Down>\<^sub>C E (RECT (\<lambda>f' x'. body' f' x') x'))"
  unfolding RECT_flat_gfp_def
  apply (clarsimp simp add: M)
  apply (rule flatf_fixp_transfer[where
        fp'="flatf_gfp body"
    and B'=body
    and P="\<lambda>x x'. (x',x)\<in>R",
    OF _ _ flatf_ord.fixp_unfold[OF M[THEN trimonoD_flatf_ge]] R0])
  apply simp
  apply (simp add: trimonoD_flatf_ge)
  by (rule RS)

lemma RECT'_refine_t:
  fixes body :: "('b \<Rightarrow> ('c, (char list, enat) acost) nrest)
   \<Rightarrow> 'b \<Rightarrow> ('c, (char list, enat) acost) nrest"
  assumes M: "mono2 body"
  assumes wfRE: "wfR'' E"
  assumes spE: "struct_preserving E"
  assumes R0: "(x,x')\<in>R"
  assumes RS: "\<And>f f' x x'. \<lbrakk> \<And>x x'. (x,x')\<in>R \<Longrightarrow> f x \<le>\<Down>S (\<Down>\<^sub>C E (f' x')); (x,x')\<in>R \<rbrakk>
    \<Longrightarrow> body f x \<le>\<Down>S (\<Down>\<^sub>C E (body' f' x'))"
  shows "RECT' (\<lambda>f x. body f x) x \<le>\<Down>S (\<Down>\<^sub>C E (RECT' (\<lambda>f' x'. body' f' x') x'))"
  unfolding RECT'_def
  apply(rule consume_refine[OF wfRE])
  subgoal using spE[THEN struct_preservingD(1)] by simp
  unfolding RECT_flat_gfp_def
  apply (clarsimp simp add: M[THEN RECT'_unfold_aux])
  apply (rule flatf_fixp_transfer[where
        fp'="flatf_gfp ((\<lambda>D. body (\<lambda>x. NREST.consume (D x) (cost ''call'' 1))))"
    and B'="(\<lambda>D. body (\<lambda>x. NREST.consume (D x) (cost ''call'' 1)))"
    and P="\<lambda>x x'. (x',x)\<in>R",
    OF _ _ flatf_ord.fixp_unfold[OF M[THEN RECT'_unfold_aux, THEN trimonoD_flatf_ge]] R0])
  apply simp
  apply (simp add: trimonoD_flatf_ge)
  apply (rule RS)
   apply(rule consume_refine[OF wfRE])
  subgoal using spE[THEN struct_preservingD(1)] by simp
   apply simp apply simp
  done

lemma monadic_WHILEIT_refine_t[refine]:
  fixes b :: "'c \<Rightarrow> (bool, (char list, enat) acost) nrest"
  assumes wfR[simp]:  "wfR'' E"
  assumes sp_E: "struct_preserving E"
  assumes [refine]: "(s',s) \<in> R"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s \<rbrakk> \<Longrightarrow> I' s'"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s' \<rbrakk> \<Longrightarrow> b' s' \<le>\<Down>bool_rel (\<Down>\<^sub>C E (b s))"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s'; nofailT (b s);
                    \<exists>t e. inresT (project_acost  e (b s)) True t \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (\<Down>\<^sub>C E (f s))"
  shows "monadic_WHILEIT I' b' f' s' \<le> \<Down>R (\<Down>\<^sub>C E (monadic_WHILEIT I b f s))"
  unfolding monadic_WHILEIT_def unfolding MIf_def
  apply (refine_rcg bindT_refine_conc_time2 RECT_refine_t IdI wfR struct_preservingD[OF sp_E])
  apply simp
  subgoal by refine_mono
  apply (assumption?; auto)+
  apply (refine_rcg consume_refine_easy bindT_refine_conc_time2 wfR struct_preservingD[OF sp_E] RETURNT_refine_t )
       apply (assumption?; auto)+
  apply(rule RETURNT_refine_t)
  apply (assumption?; auto)+
  done

lemma monadic_WHILEIT_refine':
  fixes b :: "'c \<Rightarrow> (bool, (char list, enat) acost) nrest"
  assumes wfR[simp]:  "wfR'' E"
  assumes sp_E: "struct_preserving E"
  assumes [refine]: "(s',s) \<in> R"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s \<rbrakk> \<Longrightarrow> I' s'"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s' \<rbrakk> \<Longrightarrow> b' s' \<le>\<Down>bool_rel (\<Down>\<^sub>C E (b s))"
  assumes [refine]: "\<And>s' s. \<lbrakk> (s',s)\<in>R; I s; I' s'; inres (b s) True \<rbrakk> \<Longrightarrow> f' s' \<le>\<Down>R (\<Down>\<^sub>C E (f s))"
  shows "monadic_WHILEIT I' b' f' s' \<le> \<Down>R (\<Down>\<^sub>C E (monadic_WHILEIT I b f s))"
  apply(rule monadic_WHILEIT_refine_t[OF assms(1-5)])
  by(auto intro: assms(6) inres_if_inresT_acost)

subsection \<open>mop call\<close>

definition mop_call where
  "mop_call m = consume m (cost ''call'' 1)"

lemma gwp_call[vcg_rules']:
  fixes m :: "(_,(_,enat) acost) nrest"
  assumes "Some (cost ''call'' 1 + t) \<le> gwp m Q"
  shows  "Some t \<le> gwp (mop_call m) Q"
  unfolding mop_call_def
  apply(rule gwp_consume) by(rule assms)

lemma mop_call_refine:
  fixes M :: "('e, (string, enat) acost) nrest"
  assumes "wfR'' E"
    "struct_preserving E"
  shows "\<lbrakk> M \<le> \<Down> R (\<Down>\<^sub>C E M')\<rbrakk> \<Longrightarrow> mop_call M \<le> \<Down>R (\<Down>\<^sub>C E (mop_call M'))"
  unfolding mop_call_def
  apply(subst timerefine_consume)
  subgoal using assms(1) .
  apply(subst conc_fun_consume)
  apply(rule consume_mono)
  using assms(2)[THEN struct_preservingD(1)]
  by auto

subsection \<open>Shortcuts for specifications of operations\<close>

  definition "SPECc1' c aop == (\<lambda>a. SPECT ( [(aop a)\<mapsto>c]))"
  definition "SPECc1 name aop == (\<lambda>a. SPECT ( [(aop a)\<mapsto>(cost name 1)]))"
  definition "SPECc2 name aop == ( (\<lambda>a b. SPECT ( [(aop a b)\<mapsto>(cost name 1)])))"

lemma RETURNT_eq_SPECc2_iff[simp]: "RETURNTecost v \<le> SPECc2 n f a b
      \<longleftrightarrow> (f a b = v)"
  unfolding SPECc2_def apply (auto simp: pw_acost_le_iff refine_pw_simps)
  using zero_enat_def by(auto simp: )

lemma inres_SPECc2: "inres (SPECc2 n op a b) t \<longleftrightarrow> (op a b = t)"
  by(auto simp: inres_def SPECc2_def)

lemma SPECc2_alt: "SPECc2 name aop = ( (\<lambda>a b. consume (RETURNT (aop a b)) (cost name 1)))"
  unfolding SPECc2_def consume_def by(auto simp: RETURNT_def intro!: ext)

lemma SPECc1_alt: "SPECc1 name aop = ( (\<lambda>a. consume (RETURNT (aop a)) (cost name 1)))"
  unfolding SPECc1_def consume_def by(auto simp: RETURNT_def intro!: ext)

lemma gwp_SPECc2:
  assumes "Some (t + cost c 1) \<le> Q (op a b)"
  shows "Some t \<le> gwp (SPECc2 c op a b) Q"
  unfolding SPECc2_def
  apply(refine_vcg \<open>-\<close>)
  using assms by auto

lemma SPECc2_refine':
  fixes TR :: "'h \<Rightarrow> ('h, enat) acost"
  shows "(op x y, op' x' y')\<in>R \<Longrightarrow> preserves_curr TR n  \<Longrightarrow> SPECc2 n op x y \<le> \<Down> R (\<Down>\<^sub>C TR (SPECc2 n op' x' y'))"
  unfolding SPECc2_def
  apply(subst SPECT_refine_t) by (auto simp: preserves_curr_def timerefineA_cost_apply)

lemma SPECc2_refine:
  "(op x y, op' x' y')\<in>R \<Longrightarrow> cost n (1::enat) \<le> TR n'  \<Longrightarrow> SPECc2 n op x y \<le> \<Down> R (\<Down>\<^sub>C TR (SPECc2 n' op' x' y'))"
  unfolding SPECc2_def
  apply(subst SPECT_refine_t) apply auto
  apply(rule order.trans) apply (simp add: )
  apply(subst timerefineA_cost) by simp

subsection \<open>normalize blocks\<close>

text \<open>The idea of the following tactic is to normalize all straight line blocks,
      such that they have the form (doN { [ASSUMEs]; consumea T; [RETURNs]; FURTHER }.
      To that end, it assumes that most operations are unfolded and only contain consumea, RETURN
      or consume (RETURN _) _. The RETURNs will be propagated with @{thm nres_bind_left_identity},
      ASSERTIONs will be pulled to the front, consumeas will be shrinked and assoc rule is applied.

      It then is assumed, that FURTHER statements in the concrete and abstract are in lock step.

      [ Then refine_block will split products, collect and discharge ASSUME statements,
      pay for the consumea; and then stop at a FURTHER statement.
      One can then give "rules" that process the FURTHER statements. ]
      This process is way better done by refine_rcg!

      This allows that not only lockstep refinement is possible, but that by unfolding certain
      operations, their effects get
        \<close>

lemma consumea_refine:
  fixes t :: "(_,enat) acost"
  shows "((), ()) \<in> R \<Longrightarrow> t \<le> timerefineA F t' \<Longrightarrow> consumea t \<le> \<Down> R (\<Down>\<^sub>C F (consumea t'))"
  unfolding consumea_def
  apply(rule SPECT_refine_t) by auto

lemma consumea_Id_refine:
  fixes t :: "(_,enat) acost"
  shows "t \<le> timerefineA F t' \<Longrightarrow> consumea t \<le> \<Down> Id (\<Down>\<^sub>C F (consumea t'))"
  unfolding consumea_def
  apply(rule SPECT_refine_t) by auto

lemma swap_consumea_ASSERT: "do { consumea t; ASSERT P; M:: ('c, ('d, enat) acost) nrest} = do {ASSERT P; consumea t; M}"
  apply(auto simp: pw_acost_eq_iff refine_pw_simps consumea_def)
  apply (metis zero_enat_def zero_le)
  using le_Suc_ex zero_enat_def by force

lemma consumea_0_noop:
  fixes m :: "('b,'c::{complete_lattice,zero,monoid_add}) nrest"
  shows "do { consumea 0; m } = m"
  apply(auto simp: consumea_def bindT_def split: nrest.splits intro!: ext)
  subgoal for x2 x apply(cases "x2 x") by auto
  done

thm refine0

lemma forget_inresT_project_acos: "\<exists>t b. inresT (project_acost b (consumea tt)) x' t \<Longrightarrow> True"
  by simp

lemma forget_nofailT_consumea: "nofailT (consumea tt) \<Longrightarrow> True"
  by simp

lemmas normalize_inres_precond = forget_nofailT_consumea forget_inresT_project_acos
                                  inresT_consumea_D EX_inresT_SPECTONE_D

method normalize_blocks = (simp only: swap_consumea_ASSERT nres_acost_bind_assoc consume_alt consumea_shrink nres_bind_left_identity)
method refine_block uses rules = (drule normalize_inres_precond |split prod.splits | intro allI impI
                                    | rule refine0 consumea_Id_refine SPECT_refine_t bindT_refine_conc_time_my rules)
method refine_blocks uses rules = repeat_all_new \<open>refine_block rules: rules\<close>

subsection \<open>Simple bind rule with inres\<close>

lemma bindT_refine_conc_time_my_inres:
  fixes m :: "('e1,('c1,enat)acost) nrest"
  fixes m' :: "('e2,('c2,enat)acost) nrest"
  assumes "wfR'' E" " m \<le> \<Down>R' (\<Down>\<^sub>C E m')"
  "(\<And>x x'. \<lbrakk>(x,x')\<in>R'; inres m' x'\<rbrakk>
         \<Longrightarrow> f x \<le> \<Down> R (\<Down>\<^sub>C E (f' x') ))"
shows "bindT m f \<le>  \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
  apply(rule bindT_refine_conc_time2) using assms
  by (auto dest: inres_if_inresT_acost)

lemma bindT_refine_conc_time_easy:
  fixes m :: "('e1,('c1,enat)acost) nrest"
  fixes m' :: "('e2,('c2,enat)acost) nrest"
  assumes "wfR E" " m \<le> \<Down>R' (\<Down>\<^sub>C E m')"
  "(\<And>x x'. \<lbrakk>(x,x')\<in>R' \<rbrakk> \<Longrightarrow> f x \<le> \<Down> R (\<Down>\<^sub>C E (f' x') ))"
shows "bindT m f \<le>  \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
  apply(rule bindT_refine_conc_time)
    apply fact
   apply fact
  apply(rule assms(3)) apply simp
  done

lemma bindT_refine_easy:
  fixes m :: "('e1,('c1,enat)acost) nrest"
  fixes m' :: "('e2,('c2,enat)acost) nrest"
  assumes "wfR'' E" " m \<le> \<Down>R' (\<Down>\<^sub>C E m')"
  "(\<And>x x'. \<lbrakk>(x,x')\<in>R'\<rbrakk>
         \<Longrightarrow> f x \<le> \<Down> R (\<Down>\<^sub>C E (f' x') ))"
shows "bindT m f \<le>  \<Down> R (\<Down>\<^sub>C E (bindT m' f'))"
  apply(rule bindT_refine_conc_time2) using assms
  by (auto dest: inres_if_inresT_acost)

end


(*****************************************************************************
 * Featherweight-OCL --- A Formal Semantics for UML-OCL Version OCL 2.5
 *                       for the OMG Standard.
 *                       http://www.brucker.ch/projects/hol-testgen/
 *
 * UML_String.thy --- Library definitions.
 * This file is part of HOL-TestGen.
 *
 * Copyright (c) 2012-2015 Université Paris-Saclay, Univ. Paris-Sud, France
 *               2013-2015 IRT SystemX, France
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are
 * met:
 *
 *     * Redistributions of source code must retain the above copyright
 *       notice, this list of conditions and the following disclaimer.
 *
 *     * Redistributions in binary form must reproduce the above
 *       copyright notice, this list of conditions and the following
 *       disclaimer in the documentation and/or other materials provided
 *       with the distribution.
 *
 *     * Neither the name of the copyright holders nor the names of its
 *       contributors may be used to endorse or promote products derived
 *       from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 * LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ******************************************************************************)

theory  UML_String
imports "../UML_PropertyProfiles"
begin

section\<open>Basic Type String: Operations\<close>

subsection\<open>Fundamental Properties on Strings: Strict Equality \label{sec:string-strict-eq}\<close>

text\<open>The last basic operation belonging to the fundamental infrastructure
of a value-type in OCL is the weak equality, which is defined similar
to the @{typ "('\<AA>)Boolean"}-case as strict extension of the strong equality:\<close>
overloading StrictRefEq \<equiv> "StrictRefEq :: [('\<AA>)String,('\<AA>)String] \<Rightarrow> ('\<AA>)Boolean"
begin
  definition StrictRefEq\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g[code_unfold] :
    "(x::('\<AA>)String) \<doteq> y \<equiv> \<lambda> \<tau>. if (\<upsilon> x) \<tau> = true \<tau> \<and> (\<upsilon> y) \<tau> = true \<tau>
                                  then (x \<triangleq> y) \<tau>
                                  else invalid \<tau>"
end

text\<open>Property proof in terms of @{term "profile_bin\<^sub>S\<^sub>t\<^sub>r\<^sub>o\<^sub>n\<^sub>g\<^sub>E\<^sub>q_\<^sub>v_\<^sub>v"}\<close>
interpretation  StrictRefEq\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g : profile_bin\<^sub>S\<^sub>t\<^sub>r\<^sub>o\<^sub>n\<^sub>g\<^sub>E\<^sub>q_\<^sub>v_\<^sub>v "\<lambda> x y. (x::('\<AA>)String) \<doteq> y"
         by unfold_locales (auto simp: StrictRefEq\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g)

subsection\<open>Basic String Constants\<close>

text\<open>Although the remaining part of this library reasons about
integers abstractly, we provide here as example some convenient shortcuts.\<close>

definition OclStringa ::"('\<AA>)String" ("\<a>")    where      "\<a> = (\<lambda> _ . \<lfloor>\<lfloor>''a''\<rfloor>\<rfloor>)"
definition OclStringb ::"('\<AA>)String" ("\<b>")    where      "\<b> = (\<lambda> _ . \<lfloor>\<lfloor>''b''\<rfloor>\<rfloor>)"
definition OclStringc ::"('\<AA>)String" ("\<c>")    where      "\<c> = (\<lambda> _ . \<lfloor>\<lfloor>''c''\<rfloor>\<rfloor>)"
text\<open>Etc.\<close>
text_raw\<open>\isatagafp\<close>

subsection\<open>Validity and Definedness Properties\<close>

lemma  "\<delta>(null::('\<AA>)String) = false" by simp
lemma  "\<upsilon>(null::('\<AA>)String) = true"  by simp

lemma [simp,code_unfold]: "\<upsilon> (\<lambda>_. \<lfloor>\<lfloor>n\<rfloor>\<rfloor>) = true"
by(simp add:valid_def true_def
               bot_fun_def bot_option_def)

(* ecclectic proofs to make examples executable *)
lemma [simp,code_unfold]: "\<delta> \<a> = true" by(simp add:OclStringa_def)
lemma [simp,code_unfold]: "\<upsilon> \<a> = true" by(simp add:OclStringa_def)
text_raw\<open>\endisatagafp\<close>

subsection\<open>String Operations\<close>

subsubsection\<open>Definition\<close>
text\<open>Here is a common case of a built-in operation on built-in types.
Note that the arguments must be both defined (non-null, non-bot).\<close>
text\<open>Note that we can not follow the lexis of the OCL Standard for Isabelle
technical reasons; these operators are heavily overloaded in the HOL library
that a further overloading would lead to heavy technical buzz in this
document.
\<close>
definition OclAdd\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g ::"('\<AA>)String \<Rightarrow> ('\<AA>)String \<Rightarrow> ('\<AA>)String" (infix "+\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g" 40)
where "x +\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g y \<equiv> \<lambda> \<tau>. if (\<delta> x) \<tau> = true \<tau> \<and> (\<delta> y) \<tau> = true \<tau>
                       then \<lfloor>\<lfloor>concat [\<lceil>\<lceil>x \<tau>\<rceil>\<rceil>, \<lceil>\<lceil>y \<tau>\<rceil>\<rceil>]\<rfloor>\<rfloor>
                       else invalid \<tau> "
interpretation OclAdd\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g : profile_bin\<^sub>d_\<^sub>d "(+\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g)" "\<lambda> x y. \<lfloor>\<lfloor>concat [\<lceil>\<lceil>x\<rceil>\<rceil>, \<lceil>\<lceil>y\<rceil>\<rceil>]\<rfloor>\<rfloor>"
         by unfold_locales (auto simp:OclAdd\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g_def bot_option_def null_option_def)

(* TODO : size(), concat, substring(s:string) toInteger, toReal, at(i:Integer), characters() etc. *)

subsubsection\<open>Basic Properties\<close>

lemma OclAdd\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g_not_commute: "\<exists>X Y. (X +\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g Y) \<noteq> (Y +\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g X)"
  apply(rule_tac x = "\<lambda>_. \<lfloor>\<lfloor>''b''\<rfloor>\<rfloor>" in exI)
  apply(rule_tac x = "\<lambda>_. \<lfloor>\<lfloor>''a''\<rfloor>\<rfloor>" in exI)
  apply(simp_all add:OclAdd\<^sub>S\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g_def)
  by(auto, drule fun_cong, auto)

subsection\<open>Test Statements\<close>
text\<open>Here follows a list of code-examples, that explain the meanings
of the above definitions by compilation to code and execution to @{term "True"}.\<close>
(*
Assert "\<tau> \<Turnstile> ( \<nine> \<le>\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g \<one>\<zero> )"
Assert "\<tau> \<Turnstile> (( \<four> +\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g \<four> ) \<le>\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g \<one>\<zero> )"
Assert "\<tau> |\<noteq> (( \<four> +\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g ( \<four> +\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g \<four> )) <\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g \<one>\<zero> )"
Assert "\<tau> \<Turnstile> not (\<upsilon> (null +\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g \<one>)) "
*)

text\<open>Here follows a list of code-examples, that explain the meanings
of the above definitions by compilation to code and execution to @{term "True"}.\<close>

text\<open>Elementary computations on String\<close>

Assert "\<tau> \<Turnstile> \<a> <> \<b>"
Assert "\<tau> \<Turnstile> \<b> <> \<a>"
Assert "\<tau> \<Turnstile> \<b> \<doteq> \<b>"

Assert "\<tau> \<Turnstile> \<upsilon> \<a>"
Assert "\<tau> \<Turnstile> \<delta> \<a>"
Assert "\<tau> \<Turnstile> \<upsilon> (null::('\<AA>)String)"
Assert "\<tau> \<Turnstile> (invalid \<triangleq> invalid)"
Assert "\<tau> \<Turnstile> (null \<triangleq> null)"
Assert "\<tau> \<Turnstile> (\<a> \<triangleq> \<a>)"
Assert "\<tau> |\<noteq> (\<a> \<triangleq> \<b>)"
Assert "\<tau> |\<noteq> (invalid \<triangleq> \<b>)"
Assert "\<tau> |\<noteq> (null \<triangleq> \<b>)"
Assert "\<tau> |\<noteq> (invalid \<doteq> (invalid::('\<AA>)String))" (* Without typeconstraint not executable.*)
Assert "\<tau> |\<noteq> \<upsilon> (invalid \<doteq> (invalid::('\<AA>)String))" (* Without typeconstraint not executable.*)
Assert "\<tau> |\<noteq> (invalid <> (invalid::('\<AA>)String))" (* Without typeconstraint not executable.*)
Assert "\<tau> |\<noteq> \<upsilon> (invalid <> (invalid::('\<AA>)String))" (* Without typeconstraint not executable.*)
Assert "\<tau> \<Turnstile> (null \<doteq> (null::('\<AA>)String) )" (* Without typeconstraint not executable.*)
Assert "\<tau> \<Turnstile> (null \<doteq> (null::('\<AA>)String) )" (* Without typeconstraint not executable.*)
Assert "\<tau> \<Turnstile> (\<b> \<doteq> \<b>)"
Assert "\<tau> |\<noteq> (\<b> <> \<b>)"
Assert "\<tau> |\<noteq> (\<b> \<doteq> \<c>)"
Assert "\<tau> \<Turnstile> (\<b> <> \<c>)"
(*Assert "\<tau> |\<noteq> (\<zero> <\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g null)"
Assert "\<tau> |\<noteq> (\<delta> (\<zero> <\<^sub>s\<^sub>t\<^sub>r\<^sub>i\<^sub>n\<^sub>g null))"
*)

end


(*  Title:      HOL/NanoJava/TypeRel.thy
    Author:     David von Oheimb, Technische Universitaet Muenchen
*)

section "Type relations"

theory TypeRel
imports Decl
begin

text\<open>Direct subclass relation\<close>

definition subcls1 :: "(cname \<times> cname) set"
where
  "subcls1 \<equiv> {(C,D). C\<noteq>Object \<and> (\<exists>c. class C = Some c \<and> super c=D)}"

abbreviation
  subcls1_syntax :: "[cname, cname] => bool"  ("_ \<prec>C1 _" [71,71] 70)
  where "C \<prec>C1 D == (C,D) \<in> subcls1"
abbreviation
  subcls_syntax  :: "[cname, cname] => bool" ("_ \<preceq>C _"  [71,71] 70)
  where "C \<preceq>C D == (C,D) \<in> subcls1^*"

subsection "Declarations and properties not used in the meta theory"

text\<open>Widening, viz. method invocation conversion\<close>
inductive
  widen :: "ty => ty => bool"  ("_ \<preceq> _" [71,71] 70)
where
  refl [intro!, simp]: "T \<preceq> T"
| subcls: "C\<preceq>C D \<Longrightarrow> Class C \<preceq> Class D"
| null [intro!]: "NT \<preceq> R"

lemma subcls1D:
  "C\<prec>C1D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>c. class C = Some c \<and> super c=D)"
apply (unfold subcls1_def)
apply auto
done

lemma subcls1I: "\<lbrakk>class C = Some m; super m = D; C \<noteq> Object\<rbrakk> \<Longrightarrow> C\<prec>C1D"
apply (unfold subcls1_def)
apply auto
done

lemma subcls1_def2:
  "subcls1 =
    (SIGMA C: {C. is_class C} . {D. C\<noteq>Object \<and> super (the (class C)) = D})"
apply (unfold subcls1_def is_class_def)
apply (auto split:if_split_asm)
done

lemma finite_subcls1: "finite subcls1"
apply(subst subcls1_def2)
apply(rule finite_SigmaI [OF finite_is_class])
apply(rule_tac B = "{super (the (class C))}" in finite_subset)
apply  auto
done

definition ws_prog :: "bool" where
 "ws_prog \<equiv> \<forall>(C,c)\<in>set Prog. C\<noteq>Object \<longrightarrow>
                              is_class (super c) \<and> (super c,C)\<notin>subcls1^+"

lemma ws_progD: "\<lbrakk>class C = Some c; C\<noteq>Object; ws_prog\<rbrakk> \<Longrightarrow>
  is_class (super c) \<and> (super c,C)\<notin>subcls1^+"
apply (unfold ws_prog_def class_def)
apply (drule_tac map_of_SomeD)
apply auto
done

lemma subcls1_irrefl_lemma1: "ws_prog \<Longrightarrow> subcls1^-1 \<inter> subcls1^+ = {}"
by (fast dest: subcls1D ws_progD)

(* irrefl_tranclI in Transitive_Closure.thy is more general *)
lemma irrefl_tranclI': "r^-1 Int r^+ = {} ==> !x. (x, x) ~: r^+"
by(blast elim: tranclE dest: trancl_into_rtrancl)

lemmas subcls1_irrefl_lemma2 = subcls1_irrefl_lemma1 [THEN irrefl_tranclI']

lemma subcls1_irrefl: "\<lbrakk>(x, y) \<in> subcls1; ws_prog\<rbrakk> \<Longrightarrow> x \<noteq> y"
apply (rule irrefl_trancl_rD)
apply (rule subcls1_irrefl_lemma2)
apply auto
done

lemmas subcls1_acyclic = subcls1_irrefl_lemma2 [THEN acyclicI]

lemma wf_subcls1: "ws_prog \<Longrightarrow> wf (subcls1\<inverse>)"
by (auto intro: finite_acyclic_wf_converse finite_subcls1 subcls1_acyclic)

definition class_rec ::"cname \<Rightarrow> (class \<Rightarrow> ('a \<times> 'b) list) \<Rightarrow> ('a \<rightharpoonup> 'b)"
where
  "class_rec \<equiv> wfrec (subcls1\<inverse>) (\<lambda>rec C f.
     case class C of None \<Rightarrow> undefined
      | Some m \<Rightarrow> (if C = Object then empty else rec (super m) f) ++ map_of (f m))"

lemma class_rec: "\<lbrakk>class C = Some m;  ws_prog\<rbrakk> \<Longrightarrow>
 class_rec C f = (if C = Object then empty else class_rec (super m) f) ++
                 map_of (f m)"
apply (drule wf_subcls1)
apply (subst def_wfrec[OF class_rec_def], auto)
apply (subst cut_apply, auto intro: subcls1I)
done

\<comment>\<open>Methods of a class, with inheritance and hiding\<close>
definition "method" :: "cname => (mname \<rightharpoonup> methd)" where
  "method C \<equiv> class_rec C methods"

lemma method_rec: "\<lbrakk>class C = Some m; ws_prog\<rbrakk> \<Longrightarrow>
method C = (if C=Object then empty else method (super m)) ++ map_of (methods m)"
apply (unfold method_def)
apply (erule (1) class_rec [THEN trans])
apply simp
done

\<comment>\<open>Fields of a class, with inheritance and hiding\<close>
definition field  :: "cname => (fname \<rightharpoonup> ty)" where
  "field C \<equiv> class_rec C flds"

lemma flds_rec: "\<lbrakk>class C = Some m; ws_prog\<rbrakk> \<Longrightarrow>
field C = (if C=Object then empty else field (super m)) ++ map_of (flds m)"
apply (unfold field_def)
apply (erule (1) class_rec [THEN trans])
apply simp
done

end


header {*  \isachapter{Dynamic Slicing}
  \isaheader{Dynamic Program Dependence Graph} *}

theory DynPDG imports
  "../Basic/DynDataDependence"
  "../Basic/CFGExit_wf"
  "../Basic/DynStandardControlDependence"
  "../Basic/DynWeakControlDependence"
begin

subsection {* The dynamic PDG *}

locale DynPDG =
  CFGExit_wf sourcenode targetnode kind valid_edge Entry Def Use state_val Exit
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and Exit :: "'node" ("'('_Exit'_')") +
  fixes dyn_control_dependence :: "'node \<Rightarrow> 'node \<Rightarrow> 'edge list \<Rightarrow> bool"
("_ controls _ via _" [51,0,0])
  assumes Exit_not_dyn_control_dependent:"n controls n' via as \<Longrightarrow> n' \<noteq> (_Exit_)"
  assumes dyn_control_dependence_path:
  "n controls n' via as  \<Longrightarrow> n -as\<rightarrow>* n' \<and> as \<noteq> []"

begin

inductive cdep_edge :: "'node \<Rightarrow> 'edge list \<Rightarrow> 'node \<Rightarrow> bool"
    ("_ -_\<rightarrow>\<^bsub>cd\<^esub> _" [51,0,0] 80)
  and ddep_edge :: "'node \<Rightarrow> 'var \<Rightarrow> 'edge list \<Rightarrow> 'node \<Rightarrow> bool"
    ("_ -'{_'}_\<rightarrow>\<^bsub>dd\<^esub> _" [51,0,0,0] 80)
  and DynPDG_edge :: "'node \<Rightarrow> 'var option \<Rightarrow> 'edge list \<Rightarrow> 'node \<Rightarrow> bool"

where
      -- "Syntax"
  "n -as\<rightarrow>\<^bsub>cd\<^esub> n' == DynPDG_edge n None as n'"
  | "n -{V}as\<rightarrow>\<^bsub>dd\<^esub> n' == DynPDG_edge n (Some V) as n'"

      -- "Rules"
  | DynPDG_cdep_edge:
  "n controls n' via as \<Longrightarrow> n -as\<rightarrow>\<^bsub>cd\<^esub> n'"

  | DynPDG_ddep_edge:
  "n influences V in n' via as \<Longrightarrow> n -{V}as\<rightarrow>\<^bsub>dd\<^esub> n'"

inductive DynPDG_path :: "'node \<Rightarrow> 'edge list \<Rightarrow> 'node \<Rightarrow> bool"
("_ -_\<rightarrow>\<^sub>d* _" [51,0,0] 80)

where DynPDG_path_Nil:
  "valid_node n \<Longrightarrow> n -[]\<rightarrow>\<^sub>d* n"

  | DynPDG_path_Append_cdep:
  "\<lbrakk>n -as\<rightarrow>\<^sub>d* n''; n'' -as'\<rightarrow>\<^bsub>cd\<^esub> n'\<rbrakk> \<Longrightarrow> n -as@as'\<rightarrow>\<^sub>d* n'"

  | DynPDG_path_Append_ddep:
  "\<lbrakk>n -as\<rightarrow>\<^sub>d* n''; n'' -{V}as'\<rightarrow>\<^bsub>dd\<^esub> n'\<rbrakk> \<Longrightarrow> n -as@as'\<rightarrow>\<^sub>d* n'"

lemma DynPDG_empty_path_eq_nodes:"n -[]\<rightarrow>\<^sub>d* n' \<Longrightarrow> n = n'"
apply - apply(erule DynPDG_path.cases)
  apply simp
 apply(auto elim:DynPDG_edge.cases dest:dyn_control_dependence_path)
by(auto elim:DynPDG_edge.cases simp:dyn_data_dependence_def)

lemma DynPDG_path_cdep:"n -as\<rightarrow>\<^bsub>cd\<^esub> n' \<Longrightarrow> n -as\<rightarrow>\<^sub>d* n'"
apply(subgoal_tac "n -[]@as\<rightarrow>\<^sub>d* n'")
 apply simp
apply(rule DynPDG_path_Append_cdep, rule DynPDG_path_Nil)
by(auto elim!:DynPDG_edge.cases dest:dyn_control_dependence_path path_valid_node)

lemma DynPDG_path_ddep:"n -{V}as\<rightarrow>\<^bsub>dd\<^esub> n' \<Longrightarrow> n -as\<rightarrow>\<^sub>d* n'"
apply(subgoal_tac "n -[]@as\<rightarrow>\<^sub>d* n'")
 apply simp
apply(rule DynPDG_path_Append_ddep, rule DynPDG_path_Nil)
by(auto elim!:DynPDG_edge.cases dest:path_valid_node simp:dyn_data_dependence_def)

lemma DynPDG_path_Append:
  "\<lbrakk>n'' -as'\<rightarrow>\<^sub>d* n'; n -as\<rightarrow>\<^sub>d* n''\<rbrakk> \<Longrightarrow> n -as@as'\<rightarrow>\<^sub>d* n'"
apply(induct rule:DynPDG_path.induct)
  apply(auto intro:DynPDG_path.intros)
 apply(rotate_tac 1,drule DynPDG_path_Append_cdep,simp+)
apply(rotate_tac 1,drule DynPDG_path_Append_ddep,simp+)
done

lemma DynPDG_path_Exit:"\<lbrakk>n -as\<rightarrow>\<^sub>d* n'; n' = (_Exit_)\<rbrakk> \<Longrightarrow> n = (_Exit_)"
apply(induct rule:DynPDG_path.induct)
by(auto elim:DynPDG_edge.cases dest:Exit_not_dyn_control_dependent
        simp:dyn_data_dependence_def)

lemma DynPDG_path_not_inner:
  "\<lbrakk>n -as\<rightarrow>\<^sub>d* n'; \<not> inner_node n'\<rbrakk> \<Longrightarrow> n = n'"
proof(induct rule:DynPDG_path.induct)
  case (DynPDG_path_Nil n)
  thus ?case by simp
next
  case (DynPDG_path_Append_cdep n as n'' as' n')
  from `n'' -as'\<rightarrow>\<^bsub>cd\<^esub> n'` `\<not> inner_node n'` have False
    apply -
    apply(erule DynPDG_edge.cases) apply(auto simp:inner_node_def)
      apply(fastforce dest:dyn_control_dependence_path path_valid_node)
     apply(fastforce dest:dyn_control_dependence_path path_valid_node)
    by(fastforce dest:Exit_not_dyn_control_dependent)
  thus ?case by simp
next
  case (DynPDG_path_Append_ddep n as n'' V as' n')
  from `n'' -{V}as'\<rightarrow>\<^bsub>dd\<^esub> n'` `\<not> inner_node n'` have False
    apply -
    apply(erule DynPDG_edge.cases)
    by(auto dest:path_valid_node simp:inner_node_def dyn_data_dependence_def)
  thus ?case by simp
qed

lemma DynPDG_cdep_edge_CFG_path:
  assumes "n -as\<rightarrow>\<^bsub>cd\<^esub> n'" shows "n -as\<rightarrow>* n'" and "as \<noteq> []"
  using `n -as\<rightarrow>\<^bsub>cd\<^esub> n'`
  by(auto elim:DynPDG_edge.cases dest:dyn_control_dependence_path)

lemma DynPDG_ddep_edge_CFG_path:
  assumes "n -{V}as\<rightarrow>\<^bsub>dd\<^esub> n'" shows "n -as\<rightarrow>* n'" and "as \<noteq> []"
  using `n -{V}as\<rightarrow>\<^bsub>dd\<^esub> n'`
  by(auto elim:DynPDG_edge.cases simp:dyn_data_dependence_def)

lemma DynPDG_path_CFG_path:
  "n -as\<rightarrow>\<^sub>d* n' \<Longrightarrow> n -as\<rightarrow>* n'"
proof(induct rule:DynPDG_path.induct)
  case DynPDG_path_Nil thus ?case by(rule empty_path)
next
  case (DynPDG_path_Append_cdep n as n'' as' n')
  from `n'' -as'\<rightarrow>\<^bsub>cd\<^esub> n'` have "n'' -as'\<rightarrow>* n'"
    by(rule DynPDG_cdep_edge_CFG_path(1))
  with `n -as\<rightarrow>* n''` show ?case by(rule path_Append)
next
  case (DynPDG_path_Append_ddep n as n'' V as' n')
  from `n'' -{V}as'\<rightarrow>\<^bsub>dd\<^esub> n'` have "n'' -as'\<rightarrow>* n'"
    by(rule DynPDG_ddep_edge_CFG_path(1))
  with `n -as\<rightarrow>* n''` show ?case by(rule path_Append)
qed

lemma DynPDG_path_split:
  "n -as\<rightarrow>\<^sub>d* n' \<Longrightarrow>
  (as = [] \<and> n = n') \<or>
  (\<exists>n'' asx asx'. (n -asx\<rightarrow>\<^bsub>cd\<^esub> n'') \<and> (n'' -asx'\<rightarrow>\<^sub>d* n') \<and>
        (as = asx@asx')) \<or>
  (\<exists>n'' V asx asx'. (n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> n'') \<and> (n'' -asx'\<rightarrow>\<^sub>d* n') \<and>
        (as = asx@asx'))"
proof(induct rule:DynPDG_path.induct)
  case (DynPDG_path_Nil n) thus ?case by auto
next
  case (DynPDG_path_Append_cdep n as n'' as' n')
  note IH = `as = [] \<and> n = n'' \<or>
    (\<exists>nx asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx') \<or>
    (\<exists>nx V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx')`
  from IH show ?case
  proof
    assume "as = [] \<and> n = n''"
    with `n'' -as'\<rightarrow>\<^bsub>cd\<^esub> n'` have "valid_node n'"
      by(fastforce intro:path_valid_node(2) DynPDG_path_CFG_path
                        DynPDG_path_cdep)
    with `as = [] \<and> n = n''` `n'' -as'\<rightarrow>\<^bsub>cd\<^esub> n'`
    have "\<exists>n'' asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> n'' \<and> n'' -asx'\<rightarrow>\<^sub>d* n' \<and> as@as' = asx@asx'"
      by(auto intro:DynPDG_path_Nil)
    thus ?thesis by simp
  next
    assume "(\<exists>nx asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx') \<or>
      (\<exists>nx V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx')"
    thus ?thesis
    proof
      assume "\<exists>nx asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx'"
      then obtain nx asx asx' where "n -asx\<rightarrow>\<^bsub>cd\<^esub> nx" and "nx -asx'\<rightarrow>\<^sub>d* n''"
        and "as = asx@asx'" by auto
      from `n'' -as'\<rightarrow>\<^bsub>cd\<^esub> n'` have "n'' -as'\<rightarrow>\<^sub>d* n'" by(rule DynPDG_path_cdep)
      with `nx -asx'\<rightarrow>\<^sub>d* n''` have "nx -asx'@as'\<rightarrow>\<^sub>d* n'"
        by(fastforce intro:DynPDG_path_Append)
      with `n -asx\<rightarrow>\<^bsub>cd\<^esub> nx` `as = asx@asx'`
      have "\<exists>n'' asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> n'' \<and> n'' -asx'\<rightarrow>\<^sub>d* n' \<and> as@as' = asx@asx'"
        by auto
      thus ?thesis by simp
    next
      assume "\<exists>nx V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx'"
      then obtain nx V asx asx' where "n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx" and "nx -asx'\<rightarrow>\<^sub>d* n''"
        and "as = asx@asx'" by auto
      from `n'' -as'\<rightarrow>\<^bsub>cd\<^esub> n'` have "n'' -as'\<rightarrow>\<^sub>d* n'" by(rule DynPDG_path_cdep)
      with `nx -asx'\<rightarrow>\<^sub>d* n''` have "nx -asx'@as'\<rightarrow>\<^sub>d* n'"
        by(fastforce intro:DynPDG_path_Append)
      with `n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx` `as = asx@asx'`
      have "\<exists>n'' V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> n'' \<and> n'' -asx'\<rightarrow>\<^sub>d* n' \<and> as@as' = asx@asx'"
        by auto
      thus ?thesis by simp
    qed
  qed
next
  case (DynPDG_path_Append_ddep n as n'' V as' n')
  note IH = `as = [] \<and> n = n'' \<or>
    (\<exists>nx asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx') \<or>
    (\<exists>nx V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx')`
  from IH show ?case
  proof
    assume "as = [] \<and> n = n''"
    with `n'' -{V}as'\<rightarrow>\<^bsub>dd\<^esub> n'` have "valid_node n'"
      by(fastforce intro:path_valid_node(2) DynPDG_path_CFG_path
                        DynPDG_path_ddep)
    with `as = [] \<and> n = n''` `n'' -{V}as'\<rightarrow>\<^bsub>dd\<^esub> n'`
    have "\<exists>n'' V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> n'' \<and> n'' -asx'\<rightarrow>\<^sub>d* n' \<and> as@as' = asx@asx'"
      by(fastforce intro:DynPDG_path_Nil)
    thus ?thesis by simp
  next
    assume "(\<exists>nx asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx') \<or>
      (\<exists>nx V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx')"
    thus ?thesis
    proof
      assume "\<exists>nx asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx'"
      then obtain nx asx asx' where "n -asx\<rightarrow>\<^bsub>cd\<^esub> nx" and "nx -asx'\<rightarrow>\<^sub>d* n''"
        and "as = asx@asx'" by auto
      from `n'' -{V}as'\<rightarrow>\<^bsub>dd\<^esub> n'` have "n'' -as'\<rightarrow>\<^sub>d* n'" by(rule DynPDG_path_ddep)
      with `nx -asx'\<rightarrow>\<^sub>d* n''` have "nx -asx'@as'\<rightarrow>\<^sub>d* n'"
        by(fastforce intro:DynPDG_path_Append)
      with `n -asx\<rightarrow>\<^bsub>cd\<^esub> nx` `as = asx@asx'`
      have "\<exists>n'' asx asx'. n -asx\<rightarrow>\<^bsub>cd\<^esub> n'' \<and> n'' -asx'\<rightarrow>\<^sub>d* n' \<and> as@as' = asx@asx'"
        by auto
      thus ?thesis by simp
    next
      assume "\<exists>nx V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> nx \<and> nx -asx'\<rightarrow>\<^sub>d* n'' \<and> as = asx@asx'"
      then obtain nx V' asx asx' where "n -{V'}asx\<rightarrow>\<^bsub>dd\<^esub> nx" and "nx -asx'\<rightarrow>\<^sub>d* n''"
        and "as = asx@asx'" by auto
      from `n'' -{V}as'\<rightarrow>\<^bsub>dd\<^esub> n'` have "n'' -as'\<rightarrow>\<^sub>d* n'" by(rule DynPDG_path_ddep)
      with `nx -asx'\<rightarrow>\<^sub>d* n''` have "nx -asx'@as'\<rightarrow>\<^sub>d* n'"
        by(fastforce intro:DynPDG_path_Append)
      with `n -{V'}asx\<rightarrow>\<^bsub>dd\<^esub> nx` `as = asx@asx'`
      have "\<exists>n'' V asx asx'. n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> n'' \<and> n'' -asx'\<rightarrow>\<^sub>d* n' \<and> as@as' = asx@asx'"
        by auto
      thus ?thesis by simp
    qed
  qed
qed

lemma DynPDG_path_rev_cases [consumes 1,
  case_names DynPDG_path_Nil DynPDG_path_cdep_Append DynPDG_path_ddep_Append]:
  "\<lbrakk>n -as\<rightarrow>\<^sub>d* n'; \<lbrakk>as = []; n = n'\<rbrakk> \<Longrightarrow> Q;
    \<And>n'' asx asx'. \<lbrakk>n -asx\<rightarrow>\<^bsub>cd\<^esub> n''; n'' -asx'\<rightarrow>\<^sub>d* n';
                       as = asx@asx'\<rbrakk> \<Longrightarrow> Q;
    \<And>V n'' asx asx'. \<lbrakk>n -{V}asx\<rightarrow>\<^bsub>dd\<^esub> n''; n'' -asx'\<rightarrow>\<^sub>d* n';
                       as = asx@asx'\<rbrakk> \<Longrightarrow> Q\<rbrakk>
  \<Longrightarrow> Q"
by(blast dest:DynPDG_path_split)

lemma DynPDG_ddep_edge_no_shorter_ddep_edge:
  assumes ddep:"n -{V}as\<rightarrow>\<^bsub>dd\<^esub> n'"
  shows "\<forall>as' a as''. tl as = as'@a#as'' \<longrightarrow> \<not> sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'"
proof -
  from ddep have influence:"n influences V in n' via as"
    by(auto elim!:DynPDG_edge.cases)
  then obtain  a asx where as:"as = a#asx"
    and notin:"n \<notin> set (sourcenodes asx)"
    by(auto dest:dyn_influence_source_notin_tl_edges simp:dyn_data_dependence_def)
  from influence as
  have imp:"\<forall>nx \<in> set (sourcenodes asx). V \<notin> Def nx"
    by(auto simp:dyn_data_dependence_def)
  { fix as' a' as''
    assume eq:"tl as = as'@a'#as''"
      and ddep':"sourcenode a' -{V}a'#as''\<rightarrow>\<^bsub>dd\<^esub> n'"
    from eq as notin have noteq:"sourcenode a' \<noteq> n" by(auto simp:sourcenodes_def)
    from ddep' have "V \<in> Def (sourcenode a')"
      by(auto elim!:DynPDG_edge.cases simp:dyn_data_dependence_def)
    with eq as noteq imp have False by(auto simp:sourcenodes_def) }
  thus ?thesis by blast
qed

lemma no_ddep_same_state:
  assumes path:"n -as\<rightarrow>* n'" and Uses:"V \<in> Use n'" and preds:"preds (kinds as) s"
  and no_dep:"\<forall>as' a as''. as = as'@a#as'' \<longrightarrow> \<not> sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'"
  shows "state_val (transfers (kinds as) s) V = state_val s V"
proof -
  { fix n''
    assume inset:"n'' \<in> set (sourcenodes as)" and Defs:"V \<in> Def n''"
    hence "\<exists>nx \<in> set (sourcenodes as). V \<in> Def nx" by auto
    then obtain nx ns' ns'' where nodes:"sourcenodes as = ns'@nx#ns''"
        and Defs':"V \<in> Def nx" and notDef:"\<forall>nx' \<in> set ns''. V \<notin> Def nx'"
      by(fastforce elim!:rightmost_element_property)
    from nodes obtain as' a as''
      where as'':"sourcenodes as'' = ns''" and as:"as=as'@a#as''"
      and source:"sourcenode a = nx"
      by(fastforce elim:map_append_append_maps simp:sourcenodes_def)
    from as path have path':"sourcenode a -a#as''\<rightarrow>* n'"
      by(fastforce dest:path_split_second)
    from notDef as'' source
    have "\<forall>n'' \<in> set (sourcenodes as''). V \<notin> Def n''"
      by(auto simp:sourcenodes_def)
    with path' Defs' Uses source
    have influence:"nx influences V in n' via (a#as'')"
      by(simp add:dyn_data_dependence_def)
    hence "nx \<notin> set (sourcenodes as'')" by(rule dyn_influence_source_notin_tl_edges)
    with influence source
    have "\<exists>asx a'. sourcenode a' -{V}a'#asx\<rightarrow>\<^bsub>dd\<^esub> n' \<and> sourcenode a' = nx \<and>
          (\<exists>asx'. a#as'' = asx'@a'#asx)"
      by(fastforce intro:DynPDG_ddep_edge)
    with nodes no_dep as have False by(auto simp:sourcenodes_def) }
  hence "\<forall>n \<in> set (sourcenodes as). V \<notin> Def n" by auto
  with wf path preds show ?thesis by(fastforce intro:CFG_path_no_Def_equal)
qed

lemma DynPDG_ddep_edge_only_first_edge:
  "\<lbrakk>n -{V}a#as\<rightarrow>\<^bsub>dd\<^esub> n'; preds (kinds (a#as)) s\<rbrakk> \<Longrightarrow>
    state_val (transfers (kinds (a#as)) s) V = state_val (transfer (kind a) s) V"
  apply -
  apply(erule DynPDG_edge.cases)
  apply auto
  apply(frule dyn_influence_Cons_source)
  apply(frule dyn_influence_source_notin_tl_edges)
  by(erule dyn_influence_only_first_edge)

lemma Use_value_change_implies_DynPDG_ddep_edge:
  assumes "n -as\<rightarrow>* n'" and "V \<in> Use n'" and "preds (kinds as) s"
  and "preds (kinds as) s'" and "state_val s V = state_val s' V"
  and "state_val (transfers (kinds as) s) V \<noteq>
             state_val (transfers (kinds as) s') V"
  obtains as' a as'' where "as = as'@a#as''"
  and "sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'"
  and "state_val (transfers (kinds as) s) V =
       state_val (transfers (kinds (as'@[a])) s) V"
  and "state_val (transfers (kinds as) s') V =
       state_val (transfers (kinds (as'@[a])) s') V"
proof(atomize_elim)
  show "\<exists>as' a as''. as = as'@a#as'' \<and>
                     sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n' \<and>
             state_val (transfers (kinds as) s) V =
             state_val (transfers (kinds (as'@[a])) s) V \<and>
             state_val (transfers (kinds as) s') V =
             state_val (transfers (kinds (as'@[a])) s') V"
  proof(cases "\<forall>as' a as''. as = as'@a#as'' \<longrightarrow>
                 \<not> sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'")
    case True
    with `n -as\<rightarrow>* n'` `V \<in> Use n'` `preds (kinds as) s` `preds (kinds as) s'`
    have "state_val (transfers (kinds as) s) V = state_val s V"
      and "state_val (transfers (kinds as) s') V = state_val s' V"
      by(auto intro:no_ddep_same_state)
    with `state_val s V = state_val s' V`
      `state_val (transfers (kinds as) s) V \<noteq> state_val (transfers (kinds as) s') V`
    show ?thesis by simp
  next
    case False
    then obtain as' a as'' where [simp]:"as = as'@a#as''"
      and "sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'" by auto
    from `preds (kinds as) s` have "preds (kinds (a#as'')) (transfers (kinds as') s)"
      by(simp add:kinds_def preds_split)
    with `sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'` have all:
      "state_val (transfers (kinds (a#as'')) (transfers (kinds as') s)) V =
       state_val (transfer (kind a) (transfers (kinds as') s)) V"
      by(auto dest!:DynPDG_ddep_edge_only_first_edge)
    from `preds (kinds as) s'`
    have "preds (kinds (a#as'')) (transfers (kinds as') s')"
      by(simp add:kinds_def preds_split)
    with `sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'` have all':
      "state_val (transfers (kinds (a#as'')) (transfers (kinds as') s')) V =
       state_val (transfer (kind a) (transfers (kinds as') s')) V"
      by(auto dest!:DynPDG_ddep_edge_only_first_edge)
    hence eq:"\<And>s. transfers (kinds as) s =
      transfers (kinds (a#as'')) (transfers (kinds as') s)"
      by(simp add:transfers_split[THEN sym] kinds_def)
    with all have "state_val (transfers (kinds as) s) V =
                   state_val (transfers (kinds (as'@[a])) s) V"
      by(simp add:transfers_split kinds_def)
    moreover
    from eq all' have "state_val (transfers (kinds as) s') V =
                       state_val (transfers (kinds (as'@[a])) s') V"
      by(simp add:transfers_split kinds_def)
    ultimately show ?thesis using `sourcenode a -{V}a#as''\<rightarrow>\<^bsub>dd\<^esub> n'` by simp blast
  qed
qed

end

subsection {* Instantiate dynamic PDG *}

subsubsection {* Standard control dependence *}

locale DynStandardControlDependencePDG =
  Postdomination sourcenode targetnode kind valid_edge Entry Exit +
  CFGExit_wf sourcenode targetnode kind valid_edge Entry Def Use state_val Exit
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and Exit :: "'node" ("'('_Exit'_')")

begin

lemma DynPDG_scd:
  "DynPDG sourcenode targetnode kind valid_edge (_Entry_)
          Def Use state_val (_Exit_) dyn_standard_control_dependence"
proof(unfold_locales)
  fix n n' as assume "n controls\<^sub>s n' via as"
  show "n' \<noteq> (_Exit_)"
  proof
    assume "n' = (_Exit_)"
    with `n controls\<^sub>s n' via as` show False
      by(fastforce intro:Exit_not_dyn_standard_control_dependent)
  qed
next
  fix n n' as assume "n controls\<^sub>s n' via as"
  thus "n -as\<rightarrow>* n' \<and> as \<noteq> []"
    by(fastforce simp:dyn_standard_control_dependence_def)
qed

end

subsubsection {* Weak control dependence *}

locale DynWeakControlDependencePDG =
  StrongPostdomination sourcenode targetnode kind valid_edge Entry Exit +
  CFGExit_wf sourcenode targetnode kind valid_edge Entry Def Use state_val Exit
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") and Def :: "'node \<Rightarrow> 'var set"
  and Use :: "'node \<Rightarrow> 'var set" and state_val :: "'state \<Rightarrow> 'var \<Rightarrow> 'val"
  and Exit :: "'node" ("'('_Exit'_')")

begin

end

subsection {* Data slice *}

definition (in CFG) empty_control_dependence :: "'node \<Rightarrow> 'node \<Rightarrow> 'edge list \<Rightarrow> bool"
where "empty_control_dependence n n' as \<equiv> False"

lemma (in CFGExit_wf) DynPDG_scd:
  "DynPDG sourcenode targetnode kind valid_edge (_Entry_)
          Def Use state_val  (_Exit_) empty_control_dependence"
proof(unfold_locales)
  fix n n' as assume "empty_control_dependence n n' as"
  thus "n' \<noteq> (_Exit_)" by(simp add:empty_control_dependence_def)
next
  fix n n' as assume "empty_control_dependence n n' as"
  thus "n -as\<rightarrow>* n' \<and> as \<noteq> []" by(simp add:empty_control_dependence_def)
qed

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

section "Additional Syntax for Word Bit Operations"

theory Word_Syntax
imports
  "HOL-Word.WordBitwise"
  WordBitwise_Signed
  Hex_Words
  Norm_Words
  Word_Type_Syntax
begin

text \<open>Additional bit and type syntax that forces word types.\<close>

type_synonym word8 = "8 word"
type_synonym word16 = "16 word"
type_synonym word32 = "32 word"
type_synonym word64 = "64 word"

lemma len8: "len_of (x :: 8 itself) = 8" by simp
lemma len16: "len_of (x :: 16 itself) = 16" by simp
lemma len32: "len_of (x :: 32 itself) = 32" by simp
lemma len64: "len_of (x :: 64 itself) = 64" by simp

abbreviation
  wordNOT  :: "'a::len0 word \<Rightarrow> 'a word"      ("~~ _" [70] 71)
where
  "~~ x == NOT x"

abbreviation
  wordAND  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "&&" 64)
where
  "a && b == a AND b"

abbreviation
  wordOR   :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "||"  59)
where
  "a || b == a OR b"

abbreviation
  wordXOR  :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixr "xor" 59)
where
  "a xor b == a XOR b"

(* testing for presence of word_bitwise *)
lemma "((x :: word32) >> 3) AND 7 = (x AND 56) >> 3"
  by word_bitwise

(* FIXME: move to Word distribution *)
lemma bin_nth_minus_Bit0[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit0 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n; simp)

lemma bin_nth_minus_Bit1[simp]:
  "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit1 w)) n = bin_nth (numeral w) (n - 1)"
  by (cases n; simp)

end


subsection \<^marker>\<open>tag aponly\<close> \<open>Single Non-Empty World Structures\<close>

theory SingleWorldStructure
  imports ParticularStructureMorphisms
begin

locale single_world_particular_struct =
    particular_struct where Typ\<^sub>p = Typ\<^sub>p and Typ\<^sub>q = Typ\<^sub>q
  for Typ\<^sub>p :: \<open>'p itself\<close> and Typ\<^sub>q :: \<open>'q itself\<close> +
  assumes
    only_empty_and_another_world: \<open>\<exists>w \<noteq> \<emptyset>. \<W> = {\<emptyset>,w}\<close>
begin

definition \<open>\<w> \<equiv> THE w. w \<noteq> \<emptyset> \<and> w \<in> \<W>\<close>

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_non_empty_world_unique: \<open>\<exists>!w. w \<noteq> \<emptyset> \<and> w \<in> \<W>\<close>
  using only_empty_and_another_world
  by (metis empty_iff insert_iff)

lemma \<^marker>\<open>tag (proof) aponly\<close> single_world[simp,intro!]: \<open>\<w> \<in> \<W>\<close> \<open>\<w> \<noteq> \<emptyset>\<close>
  by (simp only: \<w>_def ; rule the1I2[OF sw_non_empty_world_unique] ; simp)+

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_worlds_case[cases set]:
  assumes \<open>w \<in> \<W>\<close>
  obtains (empty) \<open>w = \<emptyset>\<close> | (single) \<open>w = \<w>\<close>
  using assms only_empty_and_another_world single_world
  by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_in_worlds[dest!]: \<open>\<lbrakk> w \<in> \<W> ; x \<in> w \<rbrakk> \<Longrightarrow> w = \<w> \<and> x \<in> \<w>\<close>
  using sw_worlds_case by auto

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_particulars_simp[simp]: \<open>endurants = \<w>\<close>
  apply (simp only: \<P>_def)
  by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_worlds_simp: \<open>\<W> = {\<emptyset>, \<w>}\<close>
  using only_empty_and_another_world single_world(2) by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_particulars_I[iff]: \<open>x \<in> \<P> \<longleftrightarrow> x \<in> \<w>\<close>
  by (simp only: sw_particulars_simp)

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_ed_iff[simp]: \<open>ed x y \<longleftrightarrow> x \<in> \<w> \<and> y \<in> \<w>\<close>
  apply (simp only: ed_def ; intro iffI conjI ballI impI ; simp?)
  by blast

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_no_indep[simp]: \<open>\<not> indep x y\<close>
  by (simp add: indep_def)

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_empty_world[simp,intro!]: \<open>\<emptyset> \<in> \<W>\<close>
  by (simp add: sw_worlds_simp)

end

locale single_world_pre_particular_struct_morphism =
   pre_particular_struct_morphism where Typ\<^sub>p\<^sub>1 = \<open>Typ\<^sub>p\<^sub>1\<close> and Typ\<^sub>p\<^sub>2 = \<open>Typ\<^sub>p\<^sub>2\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close> +
   src: single_world_particular_struct where \<Gamma> = \<open>\<Gamma>\<^sub>1\<close> and Typ\<^sub>p = \<open>Typ\<^sub>p\<^sub>1\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close> +
   tgt: single_world_particular_struct where \<Gamma> = \<open>\<Gamma>\<^sub>2\<close> and Typ\<^sub>p = \<open>Typ\<^sub>p\<^sub>2\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close>
  for
    Typ\<^sub>p\<^sub>1 :: \<open>'p\<^sub>1 itself\<close> and
    Typ\<^sub>p\<^sub>2 :: \<open>'p\<^sub>2 itself\<close> and
    Typ\<^sub>q :: \<open>'q itself\<close>
begin

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_world_corresp_iff[simp]:
  \<open>w\<^sub>s \<Leftrightarrow> w\<^sub>t \<longleftrightarrow> (w\<^sub>s = \<emptyset> \<and> w\<^sub>t = \<emptyset>) \<or>
      (w\<^sub>s = src.\<w> \<and> w\<^sub>t = tgt.\<w> \<and> \<phi> ` src.\<w> \<subseteq> tgt.\<w>)\<close>
  apply (intro iffI conjI disjCI
        ; (elim conjE disjE)?
        ; simp
        ; (elim world_corresp_E)?
        ; (intro world_corresp_I)?
        ; simp?)
  subgoal by blast
  subgoal by (metis Set.subset_empty  empty_is_image image_subsetI morph_preserves_particulars
              src.sw_in_worlds src.sw_particulars_simp src.sw_worlds_case
              tgt.sw_particulars_simp tgt.sw_worlds_case)
  subgoal by blast
  done

lemma \<^marker>\<open>tag (proof) aponly\<close> sw_particular_struct_morphism_iff:
  \<open>particular_struct_morphism \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi> \<longleftrightarrow>
    \<phi> ` src.\<w> \<subseteq> tgt.\<w> \<close>
    (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume \<open>?P\<close>
  then interpret phi: particular_struct_morphism \<Gamma>\<^sub>1 \<Gamma>\<^sub>2 \<phi> by simp
  show \<open>?Q\<close>
    apply (intro conjI ballI impI subsetI ; (elim conjE imageE)? ; simp)
    using morph_preserves_particulars by blast
next
  assume A: \<open>?Q\<close>
  show \<open>?P\<close>
    apply (unfold_locales ; simp)
    subgoal G1 for w\<^sub>s
      apply (cases w\<^sub>s rule: src.sw_worlds_case ; simp)
       apply (intro exI[of _ \<emptyset>] ; simp)
      using A by linarith
    subgoal G2 for w\<^sub>t
      apply (cases w\<^sub>t rule: tgt.sw_worlds_case ; simp)
      apply (intro exI[of _ \<emptyset>] ; simp)
      using A by linarith
    done
qed

end

locale single_world_particular_struct_morphism =
    single_world_pre_particular_struct_morphism
      where Typ\<^sub>p\<^sub>1 = \<open>Typ\<^sub>p\<^sub>1\<close> and Typ\<^sub>p\<^sub>2 = \<open>Typ\<^sub>p\<^sub>2\<close> and Typ\<^sub>q = \<open>Typ\<^sub>q\<close>
  for
    Typ\<^sub>p\<^sub>1 :: \<open>'p\<^sub>1 itself\<close> and
    Typ\<^sub>p\<^sub>2 :: \<open>'p\<^sub>2 itself\<close> and
    Typ\<^sub>q :: \<open>'q itself\<close>  +
  assumes
    image_subset: \<open>\<phi> ` src.\<w> \<subseteq> tgt.\<w>\<close> and
    morph_closes_quale_assoc_1:
      \<open>\<And>x\<^sub>t y\<^sub>t q. \<lbrakk> x\<^sub>t \<in> \<phi> ` src.\<w> ; y\<^sub>t \<in> tgt.\<w> ; q \<in> \<Q>\<^sub>s ; y\<^sub>t \<triangleleft>\<^sub>t x\<^sub>t ; y\<^sub>t \<leadsto>\<^sub>t q \<rbrakk>
            \<Longrightarrow> y\<^sub>t \<in> \<phi> ` src.\<w>\<close>

sublocale single_world_particular_struct_morphism \<subseteq> particular_struct_morphism
  apply (simp only: sw_particular_struct_morphism_iff)
  using image_subset morph_closes_quale_assoc_1 by metis

end


theory "Lowe_modified_BAN_concrete_Andrew_Secure_RPC_cert_auto"
imports
  "ESPLogic"
begin

(* section:  Lowe modified BAN concrete Andrew Secure RPC  *)

(* text:
  Modeled after the model in the SPORE library.

  Notable differences:

    1. 'succ(x)' is invertible. Hence, we just model it as a tuple ('succ',x) of
       a global constant 'succ' and the variable x.  This means that we only
       exploit the tagging properties of 'succ', but do not assume any
       information hiding.

    2. Instead of implicit typing, we are using explicit global constants to
       discern messages.
 *)

role A
where "A =
  [ Send ''1'' <| sAV ''A'', sN ''Na'' |>
  , Recv ''2'' <| sMV ''B'',
                  PEnc <| sC ''2'', sN ''Na'', sMV ''Kab'', sMV ''B'' |>
                       ( sKbd (AVar ''A'') (MVar ''B'') )
               |>
  , Send ''3'' ( PEnc <| sC ''3'', sN ''Na'' |> ( sMV ''Kab'' ) )
  , Recv ''4'' ( sMV ''Nb'' )
  ]"

role B
where "B =
  [ Recv ''1'' <| sMV ''A'', sMV ''Na'' |>
  , Send ''2'' <| sAV ''B'',
                  PEnc <| sC ''2'', sMV ''Na'', sN ''Kab'', sAV ''B'' |>
                       ( sKbd (MVar ''A'') (AVar ''B'') )
               |>
  , Recv ''3'' ( PEnc <| sC ''3'', sMV ''Na'' |> ( sN ''Kab'' ) )
  , Send ''4'' ( sN ''Nb'' )
  ]"

protocol Andrew
where "Andrew = { A, B }"

locale restricted_Andrew_state = Andrew_state

type_invariant Andrew_msc_typing for Andrew
where "Andrew_msc_typing = mk_typing
  [ ((B, ''A''), (KnownT B_1))
  , ((A, ''B''), (KnownT A_2))
  , ((A, ''Kab''), (SumT (KnownT A_2) (NonceT B ''Kab'')))
  , ((B, ''Na''), (KnownT B_1))
  , ((A, ''Nb''), (KnownT A_4))
  ]"

sublocale Andrew_state < Andrew_msc_typing_state
proof -
  have "(t,r,s) : approx Andrew_msc_typing"
  proof(cases rule: reachable_in_approxI_ext
        [OF Andrew_msc_typing.monoTyp, completeness_cases_rule])
    case (A_2_B t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_B
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (A_2_Kab t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = A_2_Kab
    thus ?case
    proof(sources! "
        Enc {| LC ''2'', LN ''Na'' tid0, s(MV ''Kab'' tid0), s(MV ''B'' tid0) |}
            ( Kbd ( s(AV ''A'' tid0) ) ( s(MV ''B'' tid0) ) ) ")
    qed (safe?, simp_all?, insert facts, (((fastforce intro: event_predOrdI split: if_splits))+)?)
  next
    case (B_1_A t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_A
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  next
    case (B_1_Na t r s tid0)
    then interpret state: Andrew_msc_typing_state t r s
      by unfold_locales auto
    note_prefix_closed (state) facts = B_1_Na
    thus ?case
    by (fastforce intro: event_predOrdI split: if_splits)
  qed
  thus "Andrew_msc_typing_state t r s" by unfold_locales auto
qed

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

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

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

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

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

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

end

(* text:
Note the additional B identity in the second message above. It guarantees that
despite using a bidirectional longterm symmetric key, we have agreement on the
involved roles.
 *)

(* subsection:  Security Properties  *)

lemma (in restricted_Andrew_state) B_sec_Kab:
  assumes facts:
    "roleMap r tid0 = Some B"
    "RLKR(s(AV ''B'' tid0)) ~: reveals t"
    "RLKR(s(MV ''A'' tid0)) ~: reveals t"
    "LN ''Kab'' tid0 : knows t"
  shows "False"
using facts proof(sources! " LN ''Kab'' tid0 ")
  case B_2_Kab note_unified facts = this facts
  thus ?thesis by (auto dest!: ltk_secrecy)
qed (safe?, simp_all?, insert facts, (fastforce+)?)

lemma (in restricted_Andrew_state) A_sec_Kab:
  assumes facts:
    "roleMap r tid0 = Some A"
    "RLKR(s(AV ''A'' tid0)) ~: reveals t"
    "RLKR(s(MV ''B'' tid0)) ~: reveals t"
    "( tid0, A_2 ) : steps t"
    "s(MV ''Kab'' tid0) : knows t"
  shows "False"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''Na'' tid0, s(MV ''Kab'' tid0), s(MV ''B'' tid0) |}
                       ( Kbd ( s(AV ''A'' tid0) ) ( s(MV ''B'' tid0) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (B_2_enc tid1) note_unified facts = this facts
    thus ?thesis by (fastforce dest: B_sec_Kab intro: event_predOrdI)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Andrew_state) A_noninjective_agreement:
  assumes facts:
    "roleMap r tid1 = Some A"
    "RLKR(s(AV ''A'' tid1)) ~: reveals t"
    "RLKR(s(MV ''B'' tid1)) ~: reveals t"
    "( tid1, A_2 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some B &
        s(AV ''A'' tid1) = s(MV ''A'' tid2) &
        s(MV ''B'' tid1) = s(AV ''B'' tid2) &
        LN ''Na'' tid1 = s(MV ''Na'' tid2) &
        s(MV ''Kab'' tid1) = LN ''Kab'' tid2)"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''2'', LN ''Na'' tid1, s(MV ''Kab'' tid1), s(MV ''B'' tid1) |}
                       ( Kbd ( s(AV ''A'' tid1) ) ( s(MV ''B'' tid1) ) ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (auto dest!: ltk_secrecy)
  next
    case (B_2_enc tid2) note_unified facts = this facts
    thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

lemma (in restricted_Andrew_state) B_noninjective_agreement:
  assumes facts:
    "roleMap r tid1 = Some B"
    "RLKR(s(AV ''B'' tid1)) ~: reveals t"
    "RLKR(s(MV ''A'' tid1)) ~: reveals t"
    "( tid1, B_3 ) : steps t"
  shows
    "(?  tid2.
        roleMap r tid2 = Some A &
        s(MV ''A'' tid1) = s(AV ''A'' tid2) &
        s(AV ''B'' tid1) = s(MV ''B'' tid2) &
        s(MV ''Na'' tid1) = LN ''Na'' tid2 &
        LN ''Kab'' tid1 = s(MV ''Kab'' tid2))"
proof -
  note_prefix_closed facts = facts
  thus ?thesis proof(sources! "
                   Enc {| LC ''3'', s(MV ''Na'' tid1) |} ( LN ''Kab'' tid1 ) ")
    case fake note_unified facts = this facts
    thus ?thesis by (fastforce dest: B_sec_Kab intro: event_predOrdI)
  next
    case (A_3_enc tid2) note_unified facts = this facts
    thus ?thesis proof(sources! "
                     Enc {| LC ''2'', LN ''Na'' tid2, LN ''Kab'' tid1, s(MV ''B'' tid2) |}
                         ( Kbd ( s(AV ''A'' tid2) ) ( s(MV ''B'' tid2) ) ) ")
      case fake note_unified facts = this facts
      thus ?thesis by (fastforce dest: B_sec_Kab intro: event_predOrdI)
    next
      case (B_2_enc tid3) note_unified facts = this facts
      thus ?thesis by (fastforce intro: event_predOrdI split: if_splits)
    qed (safe?, simp_all?, insert facts, (fastforce+)?)
  qed (safe?, simp_all?, insert facts, (fastforce+)?)
qed

end