(*
Title: SIFUM-Type-Systems
Authors: Sylvia Grewe, Heiko Mantel, Daniel Schoepe
*)
section \<open>Definition of the SIFUM-Security Property\<close>

theory Security
imports Main Preliminaries
begin

context sifum_security begin

subsection \<open>Evaluation of Concurrent Programs\<close>

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

abbreviation conf_abv :: "'Com \<Rightarrow> 'Var Mds \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> (_,_,_) LocalConf"
  ("\<langle>_, _, _\<rangle>" [0, 0, 0] 1000)
  where
  "\<langle> c, mds, mem \<rangle> \<equiv> ((c, mds), mem)"

(* Evaluation of global configurations: *)
inductive_set meval :: "(_,_,_) GlobalConf rel"
  and meval_abv :: "_ \<Rightarrow> _ \<Rightarrow> bool" (infixl "\<rightarrow>" 70)
  where
  "conf \<rightarrow> conf' \<equiv> (conf, conf') \<in> meval" |
  meval_intro [iff]: "\<lbrakk> (cms ! n, mem) \<leadsto> (cm', mem'); n < length cms \<rbrakk> \<Longrightarrow>
  ((cms, mem), (cms [n := cm'], mem')) \<in> meval"

inductive_cases meval_elim [elim!]: "((cms, mem), (cms', mem')) \<in> meval"

(* Syntactic sugar for the reflexive-transitive closure of meval: *)
abbreviation meval_clos :: "_ \<Rightarrow> _ \<Rightarrow> bool" (infixl "\<rightarrow>\<^sup>*" 70)
  where
  "conf \<rightarrow>\<^sup>* conf' \<equiv> (conf, conf') \<in> meval\<^sup>*"

fun lc_set_var :: "(_, _, _) LocalConf \<Rightarrow> 'Var \<Rightarrow> 'Val \<Rightarrow> (_, _, _) LocalConf"
  where
  "lc_set_var (c, mem) x v = (c, mem (x := v))"

fun meval_k :: "nat \<Rightarrow> ('Com, 'Var, 'Val) GlobalConf \<Rightarrow> (_, _, _) GlobalConf \<Rightarrow> bool"
  where
  "meval_k 0 c c' = (c = c')" |
  "meval_k (Suc n) c c' = (\<exists> c''. meval_k n c c'' \<and> c'' \<rightarrow> c')"

(* k steps of evaluation (for global configurations: *)
abbreviation meval_k_abv :: "nat \<Rightarrow> (_, _, _) GlobalConf \<Rightarrow> (_, _, _) GlobalConf \<Rightarrow> bool"
  ("_ \<rightarrow>\<index> _" [100, 100] 80)
  where
  "gc \<rightarrow>\<^bsub>k \<^esub>gc' \<equiv> meval_k k gc gc'"

subsection \<open>Low-equivalence and Strong Low Bisimulations\<close>

(* Low-equality between memory states: *)
definition low_eq :: "('Var, 'Val) Mem \<Rightarrow> (_, _) Mem \<Rightarrow> bool" (infixl "=\<^sup>l" 80)
  where
  "mem\<^sub>1 =\<^sup>l mem\<^sub>2 \<equiv> (\<forall> x. dma x = Low \<longrightarrow> mem\<^sub>1 x = mem\<^sub>2 x)"

(* Low-equality modulo a given mode state: *)
definition low_mds_eq :: "'Var Mds \<Rightarrow> ('Var, 'Val) Mem \<Rightarrow> (_, _) Mem \<Rightarrow> bool"
  ("_ =\<index>\<^sup>l _" [100, 100] 80)
  where
  "(mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<equiv> (\<forall> x. dma x = Low \<and> x \<notin> mds AsmNoRead \<longrightarrow> mem\<^sub>1 x = mem\<^sub>2 x)"

(* Initial mode state: *)
definition "mds\<^sub>s" :: "'Var Mds" where
  "mds\<^sub>s x = {}"

lemma [simp]: "(\<forall> mds. mem =\<^bsub>mds\<^esub>\<^sup>l mem') \<Longrightarrow> mem =\<^sup>l mem'"
  by (auto simp: low_mds_eq_def low_eq_def)

(* Closedness under globally consistent changes: *)
definition closed_glob_consistent :: "(('Com, 'Var, 'Val) LocalConf) rel \<Rightarrow> bool"
  where
  "closed_glob_consistent \<R> =
  (\<forall> c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R> \<longrightarrow>
   (\<forall> x. ((dma x = High \<and> x \<notin> mds AsmNoWrite) \<longrightarrow>
           (\<forall> v\<^sub>1 v\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 (x := v\<^sub>1) \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 (x := v\<^sub>2) \<rangle>) \<in> \<R>)) \<and>
         ((dma x = Low \<and> x \<notin> mds AsmNoWrite) \<longrightarrow>
           (\<forall> v. (\<langle> c\<^sub>1, mds, mem\<^sub>1 (x := v) \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 (x := v) \<rangle>) \<in> \<R>))))"

(* Strong low bisimulations modulo modes: *)
definition strong_low_bisim_mm :: "(('Com, 'Var, 'Val) LocalConf) rel \<Rightarrow> bool"
  where
  "strong_low_bisim_mm \<R> \<equiv>
  sym \<R> \<and>
  closed_glob_consistent \<R> \<and>
  (\<forall> c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2. (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R> \<longrightarrow>
   (mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2) \<and>
   (\<forall> c\<^sub>1' mds' mem\<^sub>1'. \<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<leadsto> \<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle> \<longrightarrow>
    (\<exists> c\<^sub>2' mem\<^sub>2'. \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle> \<leadsto> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle> \<and>
                  (\<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle>, \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle>) \<in> \<R>)))"

inductive_set mm_equiv :: "(('Com, 'Var, 'Val) LocalConf) rel"
  and mm_equiv_abv :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow>
  ('Com, 'Var, 'Val) LocalConf \<Rightarrow> bool" (infix "\<approx>" 60)
  where
  "mm_equiv_abv x y \<equiv> (x, y) \<in> mm_equiv" |
  mm_equiv_intro [iff]: "\<lbrakk> strong_low_bisim_mm \<R> ; (lc\<^sub>1, lc\<^sub>2) \<in> \<R> \<rbrakk> \<Longrightarrow> (lc\<^sub>1, lc\<^sub>2) \<in> mm_equiv"

inductive_cases mm_equiv_elim [elim]: "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"

definition low_indistinguishable :: "'Var Mds \<Rightarrow> 'Com \<Rightarrow> 'Com \<Rightarrow> bool"
  ("_ \<sim>\<index> _" [100, 100] 80)
  where "c\<^sub>1 \<sim>\<^bsub>mds\<^esub> c\<^sub>2 = (\<forall> mem\<^sub>1 mem\<^sub>2. mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2 \<longrightarrow>
    \<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>)"

subsection \<open>SIFUM-Security\<close>

(* SIFUM-security for commands: *)
definition com_sifum_secure :: "'Com \<Rightarrow> bool"
  where "com_sifum_secure c = c \<sim>\<^bsub>mds\<^sub>s\<^esub> c"

definition add_initial_modes :: "'Com list \<Rightarrow> ('Com \<times> 'Var Mds) list"
  where "add_initial_modes cmds = zip cmds (replicate (length cmds) mds\<^sub>s)"

definition no_assumptions_on_termination :: "'Com list \<Rightarrow> bool"
  where "no_assumptions_on_termination cmds =
  (\<forall> mem mem' cms'.
    (add_initial_modes cmds, mem) \<rightarrow>\<^sup>* (cms', mem') \<and>
    list_all (\<lambda> c. c = stop) (map fst cms') \<longrightarrow>
      (\<forall> mds' \<in> set (map snd cms'). mds' AsmNoRead = {} \<and> mds' AsmNoWrite = {}))"

(* SIFUM-security for programs: *)
definition prog_sifum_secure :: "'Com list \<Rightarrow> bool"
  where "prog_sifum_secure cmds =
  (no_assumptions_on_termination cmds \<and>
   (\<forall> mem\<^sub>1 mem\<^sub>2. mem\<^sub>1 =\<^sup>l mem\<^sub>2 \<longrightarrow>
    (\<forall> k cms\<^sub>1' mem\<^sub>1'.
     (add_initial_modes cmds, mem\<^sub>1) \<rightarrow>\<^bsub>k\<^esub> (cms\<^sub>1', mem\<^sub>1') \<longrightarrow>
      (\<exists> cms\<^sub>2' mem\<^sub>2'. (add_initial_modes cmds, mem\<^sub>2) \<rightarrow>\<^bsub>k\<^esub> (cms\<^sub>2', mem\<^sub>2') \<and>
                      map snd cms\<^sub>1' = map snd cms\<^sub>2' \<and>
                      length cms\<^sub>2' = length cms\<^sub>1' \<and>
                      (\<forall> x. dma x = Low \<and> (\<forall> i < length cms\<^sub>1'.
                        x \<notin> snd (cms\<^sub>1' ! i) AsmNoRead) \<longrightarrow> mem\<^sub>1' x = mem\<^sub>2' x)))))"

subsection \<open>Sound Mode Use\<close>

definition doesnt_read :: "'Com \<Rightarrow> 'Var \<Rightarrow> bool"
  where
  "doesnt_read c x = (\<forall> mds mem c' mds' mem'.
  \<langle> c, mds, mem \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle> \<longrightarrow>
  ((\<forall> v. \<langle> c, mds, mem (x := v) \<rangle> \<leadsto> \<langle> c', mds', mem' (x := v) \<rangle>) \<or>
   (\<forall> v. \<langle> c, mds, mem (x := v) \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle>)))"

definition doesnt_modify :: "'Com \<Rightarrow> 'Var \<Rightarrow> bool"
  where
  "doesnt_modify c x = (\<forall> mds mem c' mds' mem'. (\<langle> c, mds, mem \<rangle> \<leadsto> \<langle> c', mds', mem' \<rangle>) \<longrightarrow>
                        mem x = mem' x)"

(* Local reachability of local configurations: *)
inductive_set loc_reach :: "('Com, 'Var, 'Val) LocalConf \<Rightarrow> ('Com, 'Var, 'Val) LocalConf set"
  for lc :: "(_, _, _) LocalConf"
  where
  refl : "\<langle>fst (fst lc), snd (fst lc), snd lc\<rangle> \<in> loc_reach lc" |
  step : "\<lbrakk> \<langle>c', mds', mem'\<rangle> \<in> loc_reach lc;
            \<langle>c', mds', mem'\<rangle> \<leadsto> \<langle>c'', mds'', mem''\<rangle> \<rbrakk> \<Longrightarrow>
          \<langle>c'', mds'', mem''\<rangle> \<in> loc_reach lc" |
  mem_diff : "\<lbrakk> \<langle> c', mds', mem' \<rangle> \<in> loc_reach lc;
                (\<forall> x \<in> mds' AsmNoWrite. mem' x = mem'' x) \<rbrakk> \<Longrightarrow>
              \<langle> c', mds', mem'' \<rangle> \<in> loc_reach lc"

definition locally_sound_mode_use :: "(_, _, _) LocalConf \<Rightarrow> bool"
  where
  "locally_sound_mode_use lc =
  (\<forall> c' mds' mem'. \<langle> c', mds', mem' \<rangle> \<in> loc_reach lc \<longrightarrow>
    (\<forall> x. (x \<in> mds' GuarNoRead \<longrightarrow> doesnt_read c' x) \<and>
          (x \<in> mds' GuarNoWrite \<longrightarrow> doesnt_modify c' x)))"

definition compatible_modes :: "('Var Mds) list \<Rightarrow> bool"
  where
  "compatible_modes mdss = (\<forall> (i :: nat) x. i < length mdss \<longrightarrow>
    (x \<in> (mdss ! i) AsmNoRead \<longrightarrow>
     (\<forall> j < length mdss. j \<noteq> i \<longrightarrow> x \<in> (mdss ! j) GuarNoRead)) \<and>
    (x \<in> (mdss ! i) AsmNoWrite \<longrightarrow>
     (\<forall> j < length mdss. j \<noteq> i \<longrightarrow> x \<in> (mdss ! j) GuarNoWrite)))"

definition reachable_mode_states :: "('Com, 'Var, 'Val) GlobalConf \<Rightarrow> (('Var Mds) list) set"
  where "reachable_mode_states gc =
  {mdss. (\<exists> cms' mem'. gc \<rightarrow>\<^sup>* (cms', mem') \<and> map snd cms' = mdss)}"

definition globally_sound_mode_use :: "('Com, 'Var, 'Val) GlobalConf \<Rightarrow> bool"
  where "globally_sound_mode_use gc =
  (\<forall> mdss. mdss \<in> reachable_mode_states gc \<longrightarrow> compatible_modes mdss)"

primrec sound_mode_use :: "(_, _, _) GlobalConf \<Rightarrow> bool"
  where
  "sound_mode_use (cms, mem) =
     (list_all (\<lambda> cm. locally_sound_mode_use (cm, mem)) cms \<and>
      globally_sound_mode_use (cms, mem))"

(* We now show that mm_equiv itself forms a strong low bisimulation modulo modes: *)
lemma mm_equiv_sym:
  assumes equivalent: "\<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle> \<approx> \<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>"
  shows "\<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle> \<approx> \<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>"
proof -
  from equivalent obtain \<R>
    where \<R>_bisim: "strong_low_bisim_mm \<R> \<and> (\<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>, \<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>) \<in> \<R>"
    by (metis mm_equiv.simps)
  hence "sym \<R>"
    by (auto simp: strong_low_bisim_mm_def)
  hence "(\<langle>c\<^sub>2, mds\<^sub>2, mem\<^sub>2\<rangle>, \<langle>c\<^sub>1, mds\<^sub>1, mem\<^sub>1\<rangle>) \<in> \<R>"
    by (metis \<R>_bisim symE)
  thus ?thesis
    by (metis \<R>_bisim mm_equiv.intros)
qed

lemma low_indistinguishable_sym: "lc \<sim>\<^bsub>mds\<^esub> lc' \<Longrightarrow> lc' \<sim>\<^bsub>mds\<^esub> lc"
  by (auto simp: mm_equiv_sym low_indistinguishable_def low_mds_eq_def)

lemma mm_equiv_glob_consistent: "closed_glob_consistent mm_equiv"
  unfolding closed_glob_consistent_def
  apply clarify
  apply (erule mm_equiv_elim)
  by (auto simp: strong_low_bisim_mm_def closed_glob_consistent_def)

lemma mm_equiv_strong_low_bisim: "strong_low_bisim_mm mm_equiv"
  unfolding strong_low_bisim_mm_def
proof (auto)
  show "closed_glob_consistent mm_equiv" by (rule mm_equiv_glob_consistent)
next
  fix c\<^sub>1 mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2 x
  assume "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle> \<approx> \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"
  then obtain \<R> where
    "strong_low_bisim_mm \<R> \<and> (\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>, \<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>) \<in> \<R>"
    by blast
  thus "mem\<^sub>1 =\<^bsub>mds\<^esub>\<^sup>l mem\<^sub>2" by (auto simp: strong_low_bisim_mm_def)
next
  fix c\<^sub>1 :: 'Com
  fix mds mem\<^sub>1 c\<^sub>2 mem\<^sub>2 c\<^sub>1' mds' mem\<^sub>1'
  let ?lc\<^sub>1 = "\<langle> c\<^sub>1, mds, mem\<^sub>1 \<rangle>" and
      ?lc\<^sub>1' = "\<langle> c\<^sub>1', mds', mem\<^sub>1' \<rangle>" and
      ?lc\<^sub>2 = "\<langle> c\<^sub>2, mds, mem\<^sub>2 \<rangle>"
  assume "?lc\<^sub>1 \<approx> ?lc\<^sub>2"
  then obtain \<R> where "strong_low_bisim_mm \<R> \<and> (?lc\<^sub>1, ?lc\<^sub>2) \<in> \<R>"
    by (rule mm_equiv_elim, blast)
  moreover assume "?lc\<^sub>1 \<leadsto> ?lc\<^sub>1'"
  ultimately show "\<exists> c\<^sub>2' mem\<^sub>2'. ?lc\<^sub>2 \<leadsto> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle> \<and> ?lc\<^sub>1' \<approx> \<langle> c\<^sub>2', mds', mem\<^sub>2' \<rangle>"
    by (simp add: strong_low_bisim_mm_def mm_equiv_sym, blast)
next
  show "sym mm_equiv"
    by (auto simp: sym_def mm_equiv_sym)
qed

end

end


theory EdmondsKarp_Algo
imports EdmondsKarp_Termination_Abstract FordFulkerson_Algo
begin
text \<open>
  In this theory, we formalize an abstract version of
  Edmonds-Karp algorithm, which we obtain by refining the
  Ford-Fulkerson algorithm to always use shortest augmenting paths.

  Then, we show that the algorithm always terminates within $O(VE)$ iterations.
\<close>

subsection \<open>Algorithm\<close>

context Network
begin

text \<open>First, we specify the refined procedure for finding augmenting paths\<close>
definition "find_shortest_augmenting_spec f \<equiv> assert (NFlow c s t f) \<then>
  (select p. Graph.isShortestPath (residualGraph c f) s p t)"

text \<open>We show that our refined procedure is actually a refinement\<close>
thm SELECT_refine
lemma find_shortest_augmenting_refine[refine]:
  "(f',f)\<in>Id \<Longrightarrow> find_shortest_augmenting_spec f' \<le> \<Down>(\<langle>Id\<rangle>option_rel) (find_augmenting_spec f)"
  unfolding find_shortest_augmenting_spec_def find_augmenting_spec_def
  apply (refine_vcg)
  apply (auto
    simp: NFlow.shortest_is_augmenting RELATESI
    dest: NFlow.augmenting_path_imp_shortest)
  done

text \<open>Next, we specify the Edmonds-Karp algorithm.
  Our first specification still uses partial correctness,
  termination will be proved afterwards. \<close>
definition "edka_partial \<equiv> do {
  let f = (\<lambda>_. 0);

  (f,_) \<leftarrow> while\<^bsup>fofu_invar\<^esup>
    (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,_). do {
      p \<leftarrow> find_shortest_augmenting_spec f;
      case p of
        None \<Rightarrow> return (f,True)
      | Some p \<Rightarrow> do {
          assert (p\<noteq>[]);
          assert (NPreflow.isAugmentingPath c s t f p);
          assert (Graph.isShortestPath (residualGraph c f) s p t);
          let f = NFlow.augment_with_path c f p;
          assert (NFlow c s t f);
          return (f, False)
        }
    })
    (f,False);
  assert (NFlow c s t f);
  return f
}"

lemma edka_partial_refine[refine]: "edka_partial \<le> \<Down>Id fofu"
  unfolding edka_partial_def fofu_def
  apply (refine_rcg bind_refine')
  apply (refine_dref_type)
  apply (vc_solve simp: find_shortest_augmenting_spec_def)
  done

end \<comment> \<open>Network\<close>

subsubsection \<open>Total Correctness\<close>
context Network begin
text \<open>We specify the total correct version of Edmonds-Karp algorithm.\<close>
definition "edka \<equiv> do {
  let f = (\<lambda>_. 0);

  (f,_) \<leftarrow> while\<^sub>T\<^bsup>fofu_invar\<^esup>
    (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,_). do {
      p \<leftarrow> find_shortest_augmenting_spec f;
      case p of
        None \<Rightarrow> return (f,True)
      | Some p \<Rightarrow> do {
          assert (p\<noteq>[]);
          assert (NPreflow.isAugmentingPath c s t f p);
          assert (Graph.isShortestPath (residualGraph c f) s p t);
          let f = NFlow.augment_with_path c f p;
          assert (NFlow c s t f);
          return (f, False)
        }
    })
    (f,False);
  assert (NFlow c s t f);
  return f
}"

text \<open>Based on the measure function, it is easy to obtain a well-founded
  relation that proves termination of the loop in the Edmonds-Karp algorithm:\<close>
definition "edka_wf_rel \<equiv> inv_image
  (less_than_bool <*lex*> measure (\<lambda>cf. ek_analysis_defs.ekMeasure cf s t))
  (\<lambda>(f,brk). (\<not>brk,residualGraph c f))"

text \<open>The following theorem states that the total correct
  version of Edmonds-Karp algorithm refines the partial correct one.\<close>
theorem edka_refine[refine]: "edka \<le> \<Down>Id edka_partial"
  unfolding edka_def edka_partial_def
  apply (refine_rcg bind_refine'
    WHILEIT_refine_WHILEI[where V=edka_wf_rel])
  apply (refine_dref_type)
  apply (simp; fail)
  subgoal
    txt \<open>Unfortunately, the verification condition for introducing
      the variant requires a bit of manual massaging to be solved:\<close>
    apply (simp)
    apply (erule bind_sim_select_rule)
    apply (auto split: option.split
      simp: NFlow.augment_with_path_def
      simp: assert_bind_spec_conv Let_def
      simp: find_shortest_augmenting_spec_def
      simp: edka_wf_rel_def NFlow.shortest_path_decr_ek_measure
    ; fail) []
  done

  txt \<open>The other VCs are straightforward\<close>
  apply (vc_solve)
  done

subsubsection \<open>Complexity Analysis\<close>

text \<open>For the complexity analysis, we additionally show that the measure
  function is bounded by $O(VE)$. Note that our absolute bound is not as
  precise as possible, but clearly $O(VE)$.\<close>
  (* TODO: #edgesSp even bound by |E|, as either e or swap e lays on shortest path! *)

  interpret ek: ek_analysis cf
    by unfold_locales auto

  have cardV_positive: "card V > 0" and cardE_positive: "card E > 0"
    using card_0_eq[OF finite_V] V_not_empty apply blast
    using card_0_eq[OF finite_E] E_not_empty apply blast
    done

  show ?thesis proof (cases "cf.connected s t")
    case False hence "ek.ekMeasure = 0" by (auto simp: ek.ekMeasure_def)
    with cardV_positive cardE_positive show ?thesis
      by auto
  next
    case True

    have "cf.min_dist s t > 0"
      apply (rule ccontr)
      apply (auto simp: Graph.min_dist_z_iff True s_not_t[symmetric])
      done

    have "cf = c"
      unfolding residualGraph_def E_def
      by auto
    hence "ek.uE = E\<union>E\<inverse>" unfolding ek.uE_def by simp

    from True have "ek.ekMeasure
      = (card cf.V - cf.min_dist s t) * (card ek.uE + 1) + (card (ek.spEdges))"
      unfolding ek.ekMeasure_def by simp
    also from
      mlex_bound[of "card cf.V - cf.min_dist s t" "card V",
                 OF _ ek.card_spEdges_less]
    have "\<dots> < card V * (card ek.uE+1)"
      using \<open>cf.min_dist s t > 0\<close> \<open>card V > 0\<close>
      by (auto simp: resV_netV)
    also have "card ek.uE \<le> 2*card E" unfolding \<open>ek.uE = E\<union>E\<inverse>\<close>
      apply (rule order_trans)
      apply (rule card_Un_le)
      by auto
    finally show ?thesis by (auto simp: algebra_simps)
  qed
qed

text \<open>Finally, we present a version of the Edmonds-Karp algorithm
  which is instrumented with a loop counter, and asserts that
  there are less than $2|V||E|+|V| = O(|V||E|)$ iterations.

  Note that we only count the non-breaking loop iterations.
  \<close>

text \<open>The refinement is achieved by a refinement relation, coupling the
  instrumented loop state with the uninstrumented one\<close>
definition "edkac_rel \<equiv> {((f,brk,itc), (f,brk)) | f brk itc.
    itc + ek_analysis_defs.ekMeasure (residualGraph c f) s t
  < 2 * card V * card E + card V
}"

definition "edka_complexity \<equiv> do {
  let f = (\<lambda>_. 0);

  (f,_,itc) \<leftarrow> while\<^sub>T
    (\<lambda>(f,brk,_). \<not>brk)
    (\<lambda>(f,_,itc). do {
      p \<leftarrow> find_shortest_augmenting_spec f;
      case p of
        None \<Rightarrow> return (f,True,itc)
      | Some p \<Rightarrow> do {
          let f = NFlow.augment_with_path c f p;
          return (f, False,itc + 1)
        }
    })
    (f,False,0);
  assert (itc < 2 * card V * card E + card V);
  return f
}"

lemma edka_complexity_refine: "edka_complexity \<le> \<Down>Id edka"
proof -
  have [refine_dref_RELATES]:
    "RELATES edkac_rel"
    by (auto simp: RELATES_def)

  show ?thesis
    unfolding edka_complexity_def edka_def
    apply (refine_rcg)
    apply (refine_dref_type)
    apply (vc_solve simp: edkac_rel_def "NFlow.augment_with_path_def")
    subgoal using ekMeasure_upper_bound by auto []
    subgoal by (drule (1) NFlow.shortest_path_decr_ek_measure; auto)
    done
qed

text \<open>We show that this algorithm never fails, and computes a maximum flow.\<close>
theorem "edka_complexity \<le> (spec f. isMaxFlow f)"
proof -
  note edka_complexity_refine
  also note edka_refine
  also note edka_partial_refine
  also note fofu_partial_correct
  finally show ?thesis .
qed

end \<comment> \<open>Network\<close>
end \<comment> \<open>Theory\<close>


section\<open>Relativization of the cumulative hierarchy\<close>
theory Relative_Univ
  imports
    "ZF-Constructible.Rank"
    Internalizations
    Recursion_Thms

begin

lemma (in M_trivial) powerset_abs' [simp]:
  assumes
    "M(x)" "M(y)"
  shows
    "powerset(M,x,y) \<longleftrightarrow> y = {a\<in>Pow(x) . M(a)}"
  using powerset_abs assms by simp

lemma Collect_inter_Transset:
  assumes
    "Transset(M)" "b \<in> M"
  shows
    "{x\<in>b . P(x)} = {x\<in>b . P(x)} \<inter> M"
    using assms unfolding Transset_def
  by (auto)

lemma (in M_trivial) family_union_closed: "\<lbrakk>strong_replacement(M, \<lambda>x y. y = f(x)); M(A); \<forall>x\<in>A. M(f(x))\<rbrakk>
      \<Longrightarrow> M(\<Union>x\<in>A. f(x))"
  using RepFun_closed ..

(* "Vfrom(A,i) \<equiv> transrec(i, %x f. A \<union> (\<Union>y\<in>x. Pow(f`y)))" *)
(* HVfrom is *not* the recursive step for Vfrom. It is the
   relativized version *)
definition
  HVfrom :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> i" where
  "HVfrom(M,A,x,f) \<equiv> A \<union> (\<Union>y\<in>x. {a\<in>Pow(f`y). M(a)})"

(* z = Pow(f`y) *)
definition
  is_powapply :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_powapply(M,f,y,z) \<equiv> M(z) \<and> (\<exists>fy[M]. fun_apply(M,f,y,fy) \<and> powerset(M,fy,z))"

(* Trivial lemma *)
lemma is_powapply_closed: "is_powapply(M,f,y,z) \<Longrightarrow> M(z)"
  unfolding is_powapply_def by simp

(* is_Replace(M,A,P,z) \<equiv> \<forall>u[M]. u \<in> z \<longleftrightarrow> (\<exists>x[M]. x\<in>A & P(x,u)) *)
definition
  is_HVfrom :: "[i\<Rightarrow>o,i,i,i,i] \<Rightarrow> o" where
  "is_HVfrom(M,A,x,f,h) \<equiv> \<exists>U[M]. \<exists>R[M].  union(M,A,U,h)
        \<and> big_union(M,R,U) \<and> is_Replace(M,x,is_powapply(M,f),R)"

definition
  is_Vfrom :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_Vfrom(M,A,i,V) \<equiv> is_transrec(M,is_HVfrom(M,A),i,V)"

definition
  is_Vset :: "[i\<Rightarrow>o,i,i] \<Rightarrow> o" where
  "is_Vset(M,i,V) \<equiv> \<exists>z[M]. empty(M,z) \<and> is_Vfrom(M,z,i,V)"

subsection\<open>Formula synthesis\<close>

schematic_goal sats_is_powapply_fm_auto:
  assumes
    "f\<in>nat" "y\<in>nat" "z\<in>nat" "env\<in>list(A)" "0\<in>A"
  shows
    "is_powapply(##A,nth(f, env),nth(y, env),nth(z, env))
    \<longleftrightarrow> sats(A,?ipa_fm(f,y,z),env)"
  unfolding is_powapply_def is_Collect_def powerset_def subset_def
  using nth_closed assms
   by (simp) (rule sep_rules  | simp)+

schematic_goal is_powapply_iff_sats:
  assumes
    "nth(f,env) = ff" "nth(y,env) = yy" "nth(z,env) = zz" "0\<in>A"
    "f \<in> nat"  "y \<in> nat" "z \<in> nat" "env \<in> list(A)"
  shows
       "is_powapply(##A,ff,yy,zz) \<longleftrightarrow> sats(A, ?is_one_fm(a,r), env)"
  unfolding \<open>nth(f,env) = ff\<close>[symmetric] \<open>nth(y,env) = yy\<close>[symmetric]
    \<open>nth(z,env) = zz\<close>[symmetric]
  by (rule sats_is_powapply_fm_auto(1); simp add:assms)

(* rank *)
definition
  Hrank :: "[i,i] \<Rightarrow> i" where
  "Hrank(x,f) = (\<Union>y\<in>x. succ(f`y))"

definition
  PHrank :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "PHrank(M,f,y,z) \<equiv> M(z) \<and> (\<exists>fy[M]. fun_apply(M,f,y,fy) \<and> successor(M,fy,z))"

definition
  is_Hrank :: "[i\<Rightarrow>o,i,i,i] \<Rightarrow> o" where
  "is_Hrank(M,x,f,hc) \<equiv> (\<exists>R[M]. big_union(M,R,hc) \<and>is_Replace(M,x,PHrank(M,f),R)) "

definition
  rrank :: "i \<Rightarrow> i" where
  "rrank(a) \<equiv> Memrel(eclose({a}))^+"

lemma (in M_eclose) wf_rrank : "M(x) \<Longrightarrow> wf(rrank(x))"
  unfolding rrank_def using wf_trancl[OF wf_Memrel] .

lemma (in M_eclose) trans_rrank : "M(x) \<Longrightarrow> trans(rrank(x))"
  unfolding rrank_def using trans_trancl .

lemma (in M_eclose) relation_rrank : "M(x) \<Longrightarrow> relation(rrank(x))"
  unfolding rrank_def using relation_trancl .

lemma (in M_eclose) rrank_in_M : "M(x) \<Longrightarrow> M(rrank(x))"
  unfolding rrank_def by simp

subsection\<open>Absoluteness results\<close>

locale M_eclose_pow = M_eclose +
  assumes
    power_ax : "power_ax(M)" and
    powapply_replacement : "M(f) \<Longrightarrow> strong_replacement(M,is_powapply(M,f))" and
    HVfrom_replacement : "\<lbrakk> M(i) ; M(A) \<rbrakk> \<Longrightarrow>
                          transrec_replacement(M,is_HVfrom(M,A),i)" and
    PHrank_replacement : "M(f) \<Longrightarrow> strong_replacement(M,PHrank(M,f))" and
    is_Hrank_replacement : "M(x) \<Longrightarrow> wfrec_replacement(M,is_Hrank(M),rrank(x))"

begin

lemma is_powapply_abs: "\<lbrakk>M(f); M(y)\<rbrakk> \<Longrightarrow> is_powapply(M,f,y,z) \<longleftrightarrow> M(z) \<and> z = {x\<in>Pow(f`y). M(x)}"
  unfolding is_powapply_def by simp

lemma "\<lbrakk>M(A); M(x); M(f); M(h) \<rbrakk> \<Longrightarrow>
      is_HVfrom(M,A,x,f,h) \<longleftrightarrow>
      (\<exists>R[M]. h = A \<union> \<Union>R \<and> is_Replace(M, x,\<lambda>x y. y = {x \<in> Pow(f ` x) . M(x)}, R))"
  using is_powapply_abs unfolding is_HVfrom_def by auto

lemma Replace_is_powapply:
  assumes
    "M(R)" "M(A)" "M(f)"
  shows
  "is_Replace(M, A, is_powapply(M, f), R) \<longleftrightarrow> R = Replace(A,is_powapply(M,f))"
proof -
  have "univalent(M,A,is_powapply(M,f))"
    using \<open>M(A)\<close> \<open>M(f)\<close> unfolding univalent_def is_powapply_def by simp
  moreover
  have "\<And>x y. \<lbrakk> x\<in>A; is_powapply(M,f,x,y) \<rbrakk> \<Longrightarrow> M(y)"
    using \<open>M(A)\<close> \<open>M(f)\<close> unfolding is_powapply_def by simp
  ultimately
  show ?thesis using \<open>M(A)\<close> \<open>M(R)\<close> Replace_abs by simp
qed

lemma powapply_closed:
  "\<lbrakk> M(y) ; M(f) \<rbrakk> \<Longrightarrow> M({x \<in> Pow(f ` y) . M(x)})"
  using apply_closed power_ax unfolding power_ax_def by simp

lemma RepFun_is_powapply:
  assumes
    "M(R)" "M(A)" "M(f)"
  shows
  "Replace(A,is_powapply(M,f)) = RepFun(A,\<lambda>y.{x\<in>Pow(f`y). M(x)})"
proof -
  have "{y . x \<in> A, M(y) \<and> y = {x \<in> Pow(f ` x) . M(x)}} = {y . x \<in> A, y = {x \<in> Pow(f ` x) . M(x)}}"
    using assms powapply_closed transM[of _ A] by blast
  also
  have " ... = {{x \<in> Pow(f ` y) . M(x)} . y \<in> A}" by auto
  finally
  show ?thesis using assms is_powapply_abs transM[of _ A] by simp
qed

lemma RepFun_powapply_closed:
  assumes
    "M(f)" "M(A)"
  shows
    "M(Replace(A,is_powapply(M,f)))"
proof -
  have "univalent(M,A,is_powapply(M,f))"
    using \<open>M(A)\<close> \<open>M(f)\<close> unfolding univalent_def is_powapply_def by simp
  moreover
  have "\<lbrakk> x\<in>A ; is_powapply(M,f,x,y) \<rbrakk> \<Longrightarrow> M(y)" for x y
    using assms unfolding is_powapply_def by simp
  ultimately
  show ?thesis using assms powapply_replacement by simp
qed

lemma Union_powapply_closed:
  assumes
    "M(x)" "M(f)"
  shows
    "M(\<Union>y\<in>x. {a\<in>Pow(f`y). M(a)})"
proof -
  have "M({a\<in>Pow(f`y). M(a)})" if "y\<in>x" for y
    using that assms transM[of _ x] powapply_closed by simp
  then
  have "M({{a\<in>Pow(f`y). M(a)}. y\<in>x})"
    using assms transM[of _ x]  RepFun_powapply_closed RepFun_is_powapply by simp
  then show ?thesis using assms by simp
qed

lemma relation2_HVfrom: "M(A) \<Longrightarrow> relation2(M,is_HVfrom(M,A),HVfrom(M,A))"
    unfolding is_HVfrom_def HVfrom_def relation2_def
    using Replace_is_powapply RepFun_is_powapply
          Union_powapply_closed RepFun_powapply_closed by auto

lemma HVfrom_closed :
  "M(A) \<Longrightarrow> \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(HVfrom(M,A,x,g))"
  unfolding HVfrom_def using Union_powapply_closed by simp

lemma transrec_HVfrom:
  assumes "M(A)"
  shows "Ord(i) \<Longrightarrow> {x\<in>Vfrom(A,i). M(x)} = transrec(i,HVfrom(M,A))"
proof (induct rule:trans_induct)
  case (step i)
  have "Vfrom(A,i) = A \<union> (\<Union>y\<in>i. Pow((\<lambda>x\<in>i. Vfrom(A, x)) ` y))"
    using def_transrec[OF Vfrom_def, of A i] by simp
  then
  have "Vfrom(A,i) = A \<union> (\<Union>y\<in>i. Pow(Vfrom(A, y)))"
    by simp
  then
  have "{x\<in>Vfrom(A,i). M(x)} = {x\<in>A. M(x)} \<union> (\<Union>y\<in>i. {x\<in>Pow(Vfrom(A, y)). M(x)})"
    by auto
  with \<open>M(A)\<close>
  have "{x\<in>Vfrom(A,i). M(x)} = A \<union> (\<Union>y\<in>i. {x\<in>Pow(Vfrom(A, y)). M(x)})"
    by (auto intro:transM)
  also
  have "... = A \<union> (\<Union>y\<in>i. {x\<in>Pow({z\<in>Vfrom(A,y). M(z)}). M(x)})"
  proof -
    have "{x\<in>Pow(Vfrom(A, y)). M(x)} = {x\<in>Pow({z\<in>Vfrom(A,y). M(z)}). M(x)}"
      if "y\<in>i" for y by (auto intro:transM)
    then
    show ?thesis by simp
  qed
  also from step
  have " ... = A \<union> (\<Union>y\<in>i. {x\<in>Pow(transrec(y, HVfrom(M, A))). M(x)})" by auto
  also
  have " ... = transrec(i, HVfrom(M, A))"
    using def_transrec[of "\<lambda>y. transrec(y, HVfrom(M, A))" "HVfrom(M, A)" i,symmetric]
    unfolding HVfrom_def by simp
  finally
  show ?case .
qed

lemma Vfrom_abs: "\<lbrakk> M(A); M(i); M(V); Ord(i) \<rbrakk> \<Longrightarrow> is_Vfrom(M,A,i,V) \<longleftrightarrow> V = {x\<in>Vfrom(A,i). M(x)}"
  unfolding is_Vfrom_def
  using relation2_HVfrom HVfrom_closed HVfrom_replacement
    transrec_abs[of "is_HVfrom(M,A)" i "HVfrom(M,A)"] transrec_HVfrom by simp

lemma Vfrom_closed: "\<lbrakk> M(A); M(i); Ord(i) \<rbrakk> \<Longrightarrow> M({x\<in>Vfrom(A,i). M(x)})"
  unfolding is_Vfrom_def
  using relation2_HVfrom HVfrom_closed HVfrom_replacement
    transrec_closed[of "is_HVfrom(M,A)" i "HVfrom(M,A)"] transrec_HVfrom by simp

lemma Vset_abs: "\<lbrakk> M(i); M(V); Ord(i) \<rbrakk> \<Longrightarrow> is_Vset(M,i,V) \<longleftrightarrow> V = {x\<in>Vset(i). M(x)}"
  using Vfrom_abs unfolding is_Vset_def by simp

lemma Vset_closed: "\<lbrakk> M(i); Ord(i) \<rbrakk> \<Longrightarrow> M({x\<in>Vset(i). M(x)})"
  using Vfrom_closed unfolding is_Vset_def by simp

lemma Hrank_trancl:"Hrank(y, restrict(f,Memrel(eclose({x}))-``{y}))
                  = Hrank(y, restrict(f,(Memrel(eclose({x}))^+)-``{y}))"
  unfolding Hrank_def
  using restrict_trans_eq by simp

lemma rank_trancl: "rank(x) = wfrec(rrank(x), x, Hrank)"
proof -
  have "rank(x) =  wfrec(Memrel(eclose({x})), x, Hrank)"
    (is "_ = wfrec(?r,_,_)")
    unfolding rank_def transrec_def Hrank_def by simp
  also
  have " ... = wftrec(?r^+, x, \<lambda>y f. Hrank(y, restrict(f,?r-``{y})))"
    unfolding wfrec_def ..
  also
  have " ... = wftrec(?r^+, x, \<lambda>y f. Hrank(y, restrict(f,(?r^+)-``{y})))"
    using Hrank_trancl by simp
  also
  have " ... =  wfrec(?r^+, x, Hrank)"
    unfolding wfrec_def using trancl_eq_r[OF relation_trancl trans_trancl] by simp
  finally
  show ?thesis unfolding rrank_def .
qed

lemma univ_PHrank : "\<lbrakk> M(z) ; M(f) \<rbrakk> \<Longrightarrow> univalent(M,z,PHrank(M,f))"
  unfolding univalent_def PHrank_def by simp

lemma PHrank_abs :
    "\<lbrakk> M(f) ; M(y) \<rbrakk> \<Longrightarrow> PHrank(M,f,y,z) \<longleftrightarrow> M(z) \<and> z = succ(f`y)"
  unfolding PHrank_def by simp

lemma PHrank_closed : "PHrank(M,f,y,z) \<Longrightarrow> M(z)"
  unfolding PHrank_def by simp

lemma Replace_PHrank_abs:
  assumes
    "M(z)" "M(f)" "M(hr)"
  shows
    "is_Replace(M,z,PHrank(M,f),hr) \<longleftrightarrow> hr = Replace(z,PHrank(M,f))"
proof -
  have "\<And>x y. \<lbrakk>x\<in>z; PHrank(M,f,x,y) \<rbrakk> \<Longrightarrow> M(y)"
    using \<open>M(z)\<close> \<open>M(f)\<close> unfolding PHrank_def by simp
  then
  show ?thesis using \<open>M(z)\<close> \<open>M(hr)\<close> \<open>M(f)\<close> univ_PHrank Replace_abs by simp
qed

lemma RepFun_PHrank:
  assumes
    "M(R)" "M(A)" "M(f)"
  shows
  "Replace(A,PHrank(M,f)) = RepFun(A,\<lambda>y. succ(f`y))"
proof -
  have "{z . y \<in> A, M(z) \<and> z = succ(f`y)} = {z . y \<in> A, z = succ(f`y)}"
    using assms PHrank_closed transM[of _ A] by blast
  also
  have " ... = {succ(f`y) . y \<in> A}" by auto
  finally
  show ?thesis using assms PHrank_abs transM[of _ A] by simp
qed

lemma RepFun_PHrank_closed :
  assumes
    "M(f)" "M(A)"
  shows
    "M(Replace(A,PHrank(M,f)))"
proof -
  have "\<lbrakk> x\<in>A ; PHrank(M,f,x,y) \<rbrakk> \<Longrightarrow> M(y)" for x y
    using assms unfolding PHrank_def by simp
  with univ_PHrank
  show ?thesis using assms PHrank_replacement by simp
qed

lemma relation2_Hrank :
  "relation2(M,is_Hrank(M),Hrank)"
  unfolding is_Hrank_def Hrank_def relation2_def
  using Replace_PHrank_abs RepFun_PHrank RepFun_PHrank_closed by auto

lemma Union_PHrank_closed:
  assumes
    "M(x)" "M(f)"
  shows
    "M(\<Union>y\<in>x. succ(f`y))"
proof -
  have "M(succ(f`y))" if "y\<in>x" for y
    using that assms transM[of _ x] by simp
  then
  have "M({succ(f`y). y\<in>x})"
    using assms transM[of _ x]  RepFun_PHrank_closed RepFun_PHrank by simp
  then show ?thesis using assms by simp
qed

lemma is_Hrank_closed :
  "M(A) \<Longrightarrow> \<forall>x[M]. \<forall>g[M]. function(g) \<longrightarrow> M(Hrank(x,g))"
  unfolding Hrank_def using RepFun_PHrank_closed Union_PHrank_closed by simp

lemma rank_closed: "M(a) \<Longrightarrow> M(rank(a))"
  unfolding rank_trancl
  using relation2_Hrank is_Hrank_closed is_Hrank_replacement
        wf_rrank relation_rrank trans_rrank rrank_in_M
         trans_wfrec_closed[of "rrank(a)" a "is_Hrank(M)"] by simp

lemma M_into_Vset:
  assumes "M(a)"
  shows "\<exists>i[M]. \<exists>V[M]. ordinal(M,i) \<and> is_Vfrom(M,0,i,V) \<and> a\<in>V"
proof -
  let ?i="succ(rank(a))"
  from assms
  have "a\<in>{x\<in>Vfrom(0,?i). M(x)}" (is "a\<in>?V")
    using Vset_Ord_rank_iff by simp
  moreover from assms
  have "M(?i)"
    using rank_closed by simp
  moreover
  note \<open>M(a)\<close>
  moreover from calculation
  have "M(?V)"
    using Vfrom_closed by simp
  moreover from calculation
  have "ordinal(M,?i) \<and> is_Vfrom(M, 0, ?i, ?V) \<and> a \<in> ?V"
    using Ord_rank Vfrom_abs by simp
  ultimately
  show ?thesis by blast
qed

end
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)
theory Peterson_Atomicity
imports
  Lib.Lib
  Atomicity_Lib
begin

text \<open>
 Preliminaries, a type of identities.
\<close>

datatype ident = A | B

primrec other_ident
where
    "other_ident A = B"
  | "other_ident B = A"

lemma other_ident_split:
  "P (other_ident x) = ((x = A \<longrightarrow> P B) \<and> (x = B \<longrightarrow> P A))"
  by (cases x, simp_all)

lemma neq_A_B[simp]:
  "(x \<noteq> A) = (x = B)"
  "(A \<noteq> x) = (x = B)"
  "(x \<noteq> B) = (x = A)"
  "(B \<noteq> x) = (x = A)"
  by (simp | cases x)+

lemma forall_ident_eq:
  "(\<forall>ident. P ident) = (P A \<and> P B)"
  using ident.nchotomy
  by metis

lemma other_other_ident_simps[simp]:
  "other_ident (other_ident x) = x"
  "(other_ident x = y) = (x \<noteq> y)"
  "(x = other_ident y) = (x \<noteq> y)"
  by (simp_all split: other_ident_split add: eq_commute)

text \<open>
The state of the algorithm. The variables A/B are condensed into
an ab_v variable, so we can parametrise by thread A/B. The priority
variable is t_v, and the critical section cs has two variable to
operate on, cs1_v and cs2_v.

Labels are needed to track where we're up to for the preconditions,
relies and guarantees.
\<close>

datatype label = Awaiting | Critical | Exited

record ('a, 'b) p_state =
  ab_v :: "ident \<Rightarrow> bool"
  ab_label :: "ident \<Rightarrow> label"
  t_v :: "ident"
  cs1_v :: "'a"
  cs2_v :: "'b"

locale mx_locale =
  fixes cs1 :: "'b \<Rightarrow> 'a"
    and cs2 :: "(('a, 'b) p_state, unit) tmonad"
    and csI :: "'b \<Rightarrow> bool"
begin

definition
  set_ab :: "ident \<Rightarrow> bool \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state"
where
  "set_ab ident trying s = (s \<lparr> ab_v := (ab_v s) (ident := trying) \<rparr>)"

definition
  set_label :: "ident \<Rightarrow> label \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state"
where
  "set_label ident label s = (s \<lparr> ab_label := (ab_label s) (ident := label) \<rparr>)"

definition
  locked :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "locked ident s = (ab_v s (other_ident ident) \<longrightarrow> t_v s = ident)"

definition
  acquire_lock :: "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "acquire_lock ident = do
    interference;
    modify (set_ab ident True);
    modify (\<lambda>s. s \<lparr> t_v := other_ident ident \<rparr>);
    modify (set_label ident Awaiting);
    interference;
    Await (locked ident);
    modify (set_label ident Critical)
   od"

definition
  release_lock :: "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "release_lock ident = do
    modify (set_ab ident False);
    modify (set_label ident Exited);
    interference;
    return ()
   od"

definition
  abs_critical_section :: "(('a, 'b) p_state, unit) tmonad"
where
  "abs_critical_section = do
    interferences;
    modify (\<lambda>s. s \<lparr> cs1_v := cs1 (cs2_v s) \<rparr>);
    cs2;
    interference
  od"

definition
  abs_peterson_proc ::
    "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "abs_peterson_proc ident = do
    acquire_lock ident;
    abs_critical_section;
    release_lock ident
  od"

definition
  critical_section :: "(('a, 'b) p_state, unit) tmonad"
where
  "critical_section = do
    interference;
    modify (\<lambda>s. s \<lparr> cs1_v := cs1 (cs2_v s) \<rparr>);
    interference;
    cs2;
    interference
  od"

definition
  peterson_proc :: "ident \<Rightarrow> (('a, 'b) p_state, unit) tmonad"
where
  "peterson_proc ident = do
    acquire_lock ident;
    critical_section;
    release_lock ident
  od"

abbreviation "critical label \<equiv> label = Critical"

text \<open>The required invariant. We can't both be in the critical section.
Whenever neither of us is in the critical section, its invariant holds.\<close>
definition
  req_peterson_inv :: "('a, 'b) p_state \<Rightarrow> bool"
where
  "req_peterson_inv s = (\<not> (critical (ab_label s A) \<and> critical (ab_label s B))
    \<and> (critical (ab_label s A) \<or> critical (ab_label s B) \<or> csI (cs2_v s)))"

text \<open>The key invariant. We can't both be enabled, where that means
either we're in the critical section or waiting to enter with priority.
\<close>
abbreviation(input)
  enabled :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "enabled ident s \<equiv> (critical (ab_label s ident)
    \<or> (ab_label s ident = Awaiting \<and> t_v s = ident))"

definition
  key_peterson_inv :: "('a, 'b) p_state \<Rightarrow> bool"
where
  "key_peterson_inv s = (\<not> (enabled A s \<and> enabled B s))"

text \<open>Some trivia about labels and variables.\<close>
definition
  local_peterson_inv :: "('a, 'b) p_state \<Rightarrow> bool"
where
  "local_peterson_inv s
    = (\<forall>ident. ab_label s ident \<noteq> Exited \<longrightarrow> ab_v s ident)"

definition
  "invs s = (req_peterson_inv s
    \<and> key_peterson_inv s \<and> local_peterson_inv s)"

lemmas invs_defs = req_peterson_inv_def key_peterson_inv_def local_peterson_inv_def

definition
  peterson_rel :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "peterson_rel ident s_prior s = (\<comment> \<open>assume invs\<close> invs s_prior \<longrightarrow>
            \<comment> \<open>invariants are preserved\<close>
        (invs s
            \<comment> \<open>I won't adjust your variables\<close>
        \<and> (ab_v s (other_ident ident) = ab_v s_prior (other_ident ident))
        \<and> (ab_label s (other_ident ident) = ab_label s_prior (other_ident ident))
            \<comment> \<open>I will only ever give you priority\<close>
        \<and> (t_v s_prior = other_ident ident \<longrightarrow> t_v s = other_ident ident)
            \<comment> \<open>If you're in the critical section, I won't change cs2_v and cs1_v\<close>
        \<and> (critical (ab_label s_prior (other_ident ident))
                \<longrightarrow> cs2_v s = cs2_v s_prior \<and> cs1_v s = cs1_v s_prior)
  ))"

lemma peterson_rel_rtranclp[simp]:
  "rtranclp (peterson_rel ident) = (peterson_rel ident)"
  apply (rule rtranclp_id2)
   apply (clarsimp simp: peterson_rel_def)
  apply (clarsimp simp: peterson_rel_def)
  done

lemma reflp_peterson_rel[simp]:
 "reflp (peterson_rel x)"
  apply (rule reflpI)
  apply (clarsimp simp add: peterson_rel_def)
  done
declare reflp_peterson_rel[THEN reflpD, simp]

lemma peterson_rel_imp_assume_invs:
  "invs x \<Longrightarrow> (peterson_rel ident x y \<and> invs x \<and> invs y \<longrightarrow> P x y)
    \<Longrightarrow> (peterson_rel ident x y \<longrightarrow> P x y)"
  by (simp add: peterson_rel_def)

end

text \<open>
We assume validity for the underspecified critical section code represented by
@{text cs2}.

We also assume some basic sanity properties about the structure of @{text cs2}.
\<close>
locale mx_locale_wp = mx_locale cs1 cs2 csI for cs1 :: "'b \<Rightarrow> 'a" and cs2 and csI +
  assumes
    cs_wp: "\<forall>s c. I s \<and> lockf s \<longrightarrow> I s \<and> lockf (s \<lparr> cs2_v := c \<rparr>)
      \<Longrightarrow>
      \<lbrace> \<lambda>s0' s'. csI (cs2_v s') \<and> s0' = s0 \<and> s' = s \<and> I s \<and> lockf s
                 \<and> cs1_v s' = cs1 (cs2_v s') \<rbrace>,
      \<lbrace> \<lambda>s0 s. I s0 \<and> lockf s0 \<longrightarrow> cs2_v s = cs2_v s0 \<and> I s \<and> lockf s
                                    \<and> cs1_v s = cs1_v s0 \<rbrace>
        cs2
      \<lbrace> \<lambda>s0 s. I s0 \<longrightarrow> (\<exists>c. s = s0 \<lparr> cs2_v := c \<rparr>) \<and> I s \<and> lockf s \<rbrace>,
      \<lbrace> \<lambda>_ s0' s'. \<exists>c. csI c \<and> s' = s \<lparr> cs2_v := c \<rparr>
                       \<and> (\<exists>c'. s0' = s0 \<or> s0' = s \<lparr> cs2_v := c' \<rparr>)
                       \<and> I s' \<and> lockf s' \<rbrace>"
    and cs_closed: "prefix_closed cs2"
    and cs_not_env_steps_first: "not_env_steps_first cs2"
begin

method_setup rev_drule = \<open>
  Attrib.thms >> curry (fn (thms, ctxt)
    => SIMPLE_METHOD (dresolve_tac ctxt thms 1 #> Seq.list_of #> rev #> Seq.of_list))
\<close>

lemma cs2_wp_apply_peterson[wp]:
 "\<lbrace> (\<lambda>s0 s. csI (cs2_v s)
      \<and> invs s0 \<and> invs s \<and> critical (ab_label s ident)
      \<and> cs1_v s = cs1 (cs2_v s)
      \<and> (\<forall>s0' c' c. csI c \<longrightarrow> (\<exists>c'. s0' = s0 \<or> s0' = s \<lparr> cs2_v := c' \<rparr>)
              \<longrightarrow>  Q () s0' (s \<lparr> cs2_v := c\<rparr>))) \<rbrace>,
  \<lbrace> peterson_rel (other_ident ident) \<rbrace>
    cs2
  \<lbrace> peterson_rel ident \<rbrace>,
  \<lbrace> Q \<rbrace>"
  apply (rule validI_name_pre[OF cs_closed], clarsimp simp del: imp_disjL)
  apply (rule validI_weaken_pre)
   apply (rule validI_well_behaved[OF cs_closed])
     apply (rule validI_strengthen_post)
      apply (rule_tac s=s and ?s0.0=s0
         and lockf="\<lambda>s. critical (ab_label s ident)"
         and I="invs" in cs_wp)
      apply (clarsimp simp: invs_defs invs_def)
     apply (clarsimp simp del: imp_disjL)
    apply (simp only: imp_conjL[symmetric])
    apply (thin_tac "\<forall>x. P x" for P)
    apply (clarsimp simp: peterson_rel_def)
   apply (thin_tac "\<forall>x. P x" for P)
   apply (clarsimp simp: peterson_rel_def)
   apply (cases ident; fastforce simp: invs_def key_peterson_inv_def)
  apply clarsimp
  done

lemma release_lock_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     release_lock ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (simp add: release_lock_def)
  apply (rule validI_weaken_pre)
   apply wpsimp+
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def set_label_def
                      set_ab_def invs_defs
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

lemma abs_critical_section_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s \<and> invs s0
            \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     abs_critical_section
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>"
  apply (simp add: abs_critical_section_def)
  apply (rule validI_weaken_pre)
   apply wpsimp+
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def invs_defs
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

lemma acquire_lock_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     acquire_lock ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s \<and> invs s0
               \<and> ab_label s ident = Critical \<and> csI (cs2_v s) \<rbrace>"
  apply (simp add: acquire_lock_def)
  apply (rule validI_weaken_pre)
   apply (wpsimp wp: Await_sync_twp)+
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def set_label_def set_ab_def
                      locked_def invs_defs
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

theorem abs_peterson_proc_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     abs_peterson_proc ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (simp add: abs_peterson_proc_def bind_assoc)
  apply (rule validI_weaken_pre)
   apply (wpsimp wp: release_lock_mutual_excl acquire_lock_mutual_excl
                     abs_critical_section_mutual_excl)+
  done

definition
  peterson_sr :: "(('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state  \<Rightarrow> bool)"
where
  "peterson_sr sa sc \<equiv>
    t_v sa = t_v sc \<and> ab_v sa = ab_v sc
    \<and> ab_label sa = ab_label sc \<and> cs2_v sa = cs2_v sc"

definition
  peterson_sr' :: "(('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state  \<Rightarrow> bool)"
where
  "peterson_sr' sa sc \<equiv> sa = sc \<lparr> cs1_v := cs1_v sa \<rparr>"

definition
  peterson_sr_cs1 :: "(('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state  \<Rightarrow> bool)"
where
  "peterson_sr_cs1 sa sc \<equiv> peterson_sr sa sc \<and> cs1_v sa = cs1_v sc"

end
text \<open>
Finally we assume that we can prove refinement for @{text cs2}, although this
may depend on being in a state where @{term cs1_v} has been correctly
initialised.
\<close>
locale mx_locale_refine = mx_locale_wp cs1 cs2 csI for cs1 :: "'b \<Rightarrow> 'a" and cs2 and csI +
  assumes
    cs_refine:
          "prefix_refinement peterson_sr peterson_sr_cs1 peterson_sr \<top>\<top>
                             (\<lambda>_ s. cs1_v s = cs1 (cs2_v s)) \<top>\<top>
                             (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
                             cs2 cs2"
begin

lemma
  "peterson_sr = peterson_sr'"
  by (auto simp: p_state.splits peterson_sr_def peterson_sr'_def intro!: ext)

lemma peterson_sr_set_ab[simp]:
 "peterson_sr s t \<Longrightarrow> peterson_sr (set_ab ident v s) (set_ab ident v t)"
  by (simp add: peterson_sr_def set_ab_def)

lemma env_stable_peterson_sr:
  "env_stable AR R peterson_sr peterson_sr \<top>"
  by (fastforce simp: env_stable_def rely_stable_def env_rely_stable_iosr_def peterson_sr_def)

lemmas prefix_refinement_interference_peterson =
  prefix_refinement_interference[OF env_stable_peterson_sr]

lemma peterson_sr_reflp[simp]:
  "reflp peterson_sr"
  by (simp add: peterson_sr_def reflpI)

lemma peterson_sr_equivp[simp]:
  "equivp peterson_sr"
  by (auto simp: peterson_sr_def intro!: sympI equivpI transpI)

lemma peterson_sr_cs1_invs: "peterson_sr_cs1 s t \<Longrightarrow> invs s = invs t"
   apply (auto simp: peterson_sr_def peterson_sr_cs1_def invs_def
                     req_peterson_inv_def key_peterson_inv_def
                     local_peterson_inv_def)[1]
  done

lemma env_stable_peterson_sr_cs1:
  "env_stable (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
               peterson_sr peterson_sr_cs1 (\<lambda>s. invs s \<and> critical (ab_label s ident))"
  apply (simp add: env_stable_def rely_stable_def env_rely_stable_iosr_def
                 peterson_rel_def)
  apply (rule conjI)
   apply (auto simp: peterson_sr_def peterson_sr_cs1_def)[1]
  apply (rule conjI)
   apply clarsimp
   apply (clarsimp simp: peterson_sr_cs1_invs)
   apply (auto simp: peterson_sr_cs1_def peterson_sr_def)[1]
  apply (auto simp: peterson_sr_cs1_def peterson_sr_def)[1]
  done

lemmas prefix_refinement_interference_peterson_cs1 =
  prefix_refinement_interference[OF env_stable_peterson_sr_cs1]

lemmas prefix_refinement_bind_2left_2right
      = prefix_refinement_bind[where a="bind a a'" and c="bind c c'" for a a' c c', simplified bind_assoc]
lemmas rel_tr_refinement_bind_left_general_2left_2right
       = rel_tr_refinement_bind_left_general[where f="bind f f'" and g="bind g g'" for f f' g g', simplified bind_assoc]

lemma peterson_rel_imp_invs:
  "peterson_rel ident x y \<Longrightarrow> invs x \<Longrightarrow> invs y"
  by (simp add: peterson_rel_def)

lemma peterson_rel_imp_label:
  "peterson_rel (other_ident ident) x y \<Longrightarrow> invs x
   \<Longrightarrow> ab_label x ident = ab_label y ident"
  by (simp add: peterson_rel_def)

lemma peterson_rel_set_label:
  "peterson_rel (other_ident ident) (set_label ident label s) s'
   \<Longrightarrow> invs (set_label ident label s)
   \<Longrightarrow> ab_label s' ident = label"
  by (simp add: peterson_rel_def set_label_def)

lemma acquire_lock_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    \<top>\<top> \<top>\<top>
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (acquire_lock ident) (acquire_lock ident)"
  apply (unfold acquire_lock_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (rule prefix_refinement_bind_sr)
       apply (rule prefix_refinement_interference_peterson)
      apply (simp add: modify_modify_bind)
      apply (rule prefix_refinement_bind_sr)
         apply (rule pfx_refn_modifyT)
         apply (clarsimp simp add: peterson_sr_def set_label_def set_ab_def forall_ident_eq)
        apply (rule prefix_refinement_bind_sr)
           apply (rule prefix_refinement_interference_peterson)
          apply (rule prefix_refinement_bind_sr)
             apply (rule prefix_refinement_Await[OF env_stable_peterson_sr abs_rely_stableT])
              apply (clarsimp simp add: peterson_sr_def locked_def)
             apply (clarsimp simp add: peterson_sr_def locked_def)
            apply (rule pfx_refn_modifyT)
            apply (clarsimp simp add: peterson_sr_def set_label_def)
           apply (wpsimp wp: Await_sync_twp)+
  done

lemma peterson_sr_invs[simp]:
  "peterson_sr as cs \<Longrightarrow> invs as \<Longrightarrow> invs cs"
  by (simp add: peterson_sr_def invs_def invs_defs)

lemma peterson_sr_invs_sym:
  "peterson_sr as cs \<Longrightarrow> invs cs \<Longrightarrow> invs as"
  by (simp add: peterson_sr_def invs_def invs_defs)

lemma peterson_sr_ab_label:
  "peterson_sr as cs \<Longrightarrow> ab_label as = ab_label cs"
  by (simp add: peterson_sr_def)

lemma critical_section_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>_ s. invs s \<and> ab_label s ident = Critical) \<top>\<top>
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    abs_critical_section critical_section"
  apply (simp add: abs_critical_section_def critical_section_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (rule prefix_refinement_interferences_split)
    apply (rule prefix_refinement_bind_sr)
       apply (rule prefix_refinement_interference_peterson)

      (* reorder the interference and modify*)
      apply (rule pfx_refinement_use_rel_tr_refinement_equivp
                  [where Q="\<lambda>s. invs s \<and> ab_label s (ident) = Critical"])
        apply (rule rel_tr_refinement_bind_left_general_2left_2right)
          apply simp
         apply (rule disjI1,
                     clarsimp simp: not_env_steps_first_all
                                    cs_not_env_steps_first release_lock_def)
        apply (rule rshuttle_modify_interference)
          apply (simp add: peterson_sr_def peterson_rel_def)
         apply (clarsimp simp: peterson_rel_def)
        apply (clarsimp simp: p_state.splits)
        apply (clarsimp simp: peterson_rel_def invs_def invs_defs)
       apply simp

      apply (rule prefix_refinement_bind_sr)
         apply (rule prefix_refinement_interference_peterson)
        apply (rule prefix_refinement_bind[where intsr=peterson_sr_cs1])
           apply (rule pfx_refn_modifyT)
           apply (clarsimp simp add: peterson_sr_def peterson_sr_cs1_def)
          apply (rule prefix_refinement_bind_sr)
             apply (rule cs_refine)
            apply (rule prefix_refinement_interference_peterson)

           apply (wpsimp wp: validI_triv[OF cs_closed])+
  apply (subst peterson_rel_imp_label[symmetric], assumption, simp)
  apply (drule peterson_rel_imp_invs, simp)
  apply (simp add: peterson_sr_ab_label)
  done

lemma release_lock_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    \<top>\<top> \<top>\<top>
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (release_lock ident) (release_lock ident)"
  apply (unfold release_lock_def)
  apply (rule prefix_refinement_weaken_pre)
    apply (simp add: modify_modify_bind)
    apply (rule prefix_refinement_bind_sr)
       apply (rule pfx_refn_modifyT)
       apply (clarsimp simp add: peterson_sr_def peterson_sr_cs1_def set_label_def set_ab_def)
      apply (rule prefix_refinement_interference_peterson)
     apply wpsimp+
  done

lemma critical_section_prefix_closed[simp]:
  "prefix_closed critical_section"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed critical_section_def)

lemma abs_critical_section_prefix_closed[simp]:
  "prefix_closed abs_critical_section"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed abs_critical_section_def)

lemma peterson_rel_trans:
 "peterson_rel ident x y \<Longrightarrow> peterson_rel ident y z \<Longrightarrow>
  peterson_rel ident x z"
 by (clarsimp simp: peterson_rel_def)

lemma invs_set_label_Critical:
  "invs s \<Longrightarrow> locked ident s \<Longrightarrow> ab_label s ident = Awaiting
   \<Longrightarrow> invs (set_label ident Critical s)"
  by (auto simp: invs_def invs_defs set_label_def locked_def)

lemma acquire_lock_wp:
  "\<lbrace> \<lambda>s0 s. invs s \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     acquire_lock ident
   \<lbrace> \<top>\<top> \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. invs s \<and> ab_label s ident = Critical \<rbrace>"
  apply (simp add: acquire_lock_def)
  apply (rule validI_weaken_pre)
   apply (wpsimp wp: Await_sync_twp)+
  apply (subst (asm) peterson_rel_imp_label, assumption+)
  apply (drule(1) peterson_rel_imp_invs)
  apply (drule(1) peterson_rel_trans)
  apply (thin_tac "peterson_rel (other_ident ident) s'a x")
  apply (frule peterson_rel_set_label)
   apply (fastforce simp: set_label_def set_ab_def
                          locked_def invs_def invs_defs)
  apply (drule peterson_rel_imp_invs)
   apply (fastforce simp: set_label_def set_ab_def
                          locked_def invs_def invs_defs)
  apply (clarsimp simp: invs_set_label_Critical)
  apply (clarsimp simp: set_label_def set_ab_def)
  done

lemma acquire_lock_prefix_closed[simp]:
  "prefix_closed (acquire_lock ident)"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed acquire_lock_def)

theorem peterson_proc_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>_ s. invs s \<and> ab_label s ident = Exited)
    (\<lambda>_ s. invs s \<and> ab_label s ident = Exited)
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (abs_peterson_proc ident)
    (peterson_proc ident)"
 apply (simp add: abs_peterson_proc_def peterson_proc_def)
   apply (rule prefix_refinement_weaken_pre)
   apply (rule prefix_refinement_bind_sr)
       apply (rule acquire_lock_refinement)
      apply (rule prefix_refinement_bind_sr)
         apply (rule critical_section_refinement)
        apply (rule release_lock_refinement)
       apply (wpsimp wp: validI_triv acquire_lock_wp
                     simp: pred_conj_def)+
  done

definition
  peterson_rel2 :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "peterson_rel2 ident s_prior s = (\<comment> \<open>assume invs\<close> invs s_prior \<longrightarrow>
            \<comment> \<open>If you're in the critical section, I won't change cs1_v\<close>
        (critical (ab_label s_prior (other_ident ident))
                \<longrightarrow> cs1_v s = cs1_v s_prior))"

definition
  peterson_rel3 :: "ident \<Rightarrow> ('a, 'b) p_state \<Rightarrow> ('a, 'b) p_state \<Rightarrow> bool"
where
  "peterson_rel3 ident s_prior s = (\<comment> \<open>assume invs\<close> invs s_prior \<longrightarrow>
            \<comment> \<open>invariants are preserved\<close>
        (invs s
            \<comment> \<open>I won't adjust your variables\<close>
        \<and> (ab_v s (other_ident ident) = ab_v s_prior (other_ident ident))
        \<and> (ab_label s (other_ident ident) = ab_label s_prior (other_ident ident))
            \<comment> \<open>I will only ever give you priority\<close>
        \<and> (t_v s_prior = other_ident ident \<longrightarrow> t_v s = other_ident ident)
            \<comment> \<open>If you're in the critical section, I won't change cs2_v\<close>
        \<and> (critical (ab_label s_prior (other_ident ident))
                \<longrightarrow> cs2_v s = cs2_v s_prior)))"

lemma peterson_rel_helpers:
  "peterson_rel2 ident s0 s \<and> peterson_rel3 ident s0 s
   \<longrightarrow> peterson_rel ident s0 s"
  by (clarsimp simp: peterson_rel_def peterson_rel2_def peterson_rel3_def)

lemma peterson_rel_peterson_rel2:
  "peterson_rel ident s0 s \<longrightarrow> peterson_rel2 ident s0 s"
  by (clarsimp simp: peterson_rel_def peterson_rel2_def)

lemma peterson_sr_peterson_rel3:
  "peterson_sr as0 cs0 \<Longrightarrow> peterson_sr as cs
   \<Longrightarrow> peterson_rel ident as0 as \<Longrightarrow> peterson_rel3 ident cs0 cs"
  apply (clarsimp simp: peterson_rel_def peterson_rel3_def invs_def
                        invs_defs peterson_sr_ab_label)
  apply (clarsimp simp: peterson_sr_def)
  done

lemma peterson_proc_prefix_closed[simp]:
  "prefix_closed (peterson_proc ident)"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed peterson_proc_def acquire_lock_def release_lock_def)

lemma peterson_proc_mutual_excl_helper:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     peterson_proc ident
   \<lbrace> peterson_rel3 ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel3 ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (rule prefix_refinement_validI')
        apply (rule peterson_proc_refinement)
       apply (rule abs_peterson_proc_mutual_excl)
      apply (clarsimp simp: peterson_sr_peterson_rel3 peterson_sr_ab_label)
     apply (clarsimp simp: peterson_sr_peterson_rel3)
    apply clarsimp
    apply (rule_tac x=t0 in exI)
    apply (rule_tac x="t \<lparr>cs1_v := cs1_v t0\<rparr>" in exI)
    apply (clarsimp simp: peterson_rel_def peterson_sr_def)
   apply clarsimp
   apply (rule_tac x="t \<lparr>cs1_v := cs1_v s0\<rparr>" in exI)
   apply (clarsimp simp: peterson_rel_def peterson_sr_def invs_def invs_defs)
  apply clarsimp
  done

lemma peterson_proc_mutual_excl_helper':
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     peterson_proc ident
   \<lbrace> peterson_rel2 ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel2 ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (simp add: peterson_proc_def acquire_lock_def release_lock_def
                   critical_section_def)
  apply (rule validI_weaken_pre)
   apply (wp Await_sync_twp | simp add: split_def
          | rule validI_strengthen_guar[OF _ allI[OF allI[OF peterson_rel_peterson_rel2]]])+
  apply (clarsimp simp: imp_conjL)
  apply (strengthen peterson_rel_imp_assume_invs | simp)+
  apply (cases ident)
  apply (safe, simp_all)
  by ((clarsimp simp: peterson_rel_def peterson_rel2_def forall_ident_eq
                      set_label_def set_ab_def locked_def invs_defs cs_closed
    | rule invs_def[THEN iffD2] conjI
    | rev_drule invs_def[THEN iffD1])+)

lemma peterson_proc_mutual_excl:
  "\<lbrace> \<lambda>s0 s. peterson_rel ident s0 s \<and> invs s
            \<and> ab_label s ident = Exited \<rbrace>,
   \<lbrace> peterson_rel (other_ident ident) \<rbrace>
     peterson_proc ident
   \<lbrace> peterson_rel ident \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. peterson_rel ident s0 s \<and> invs s
               \<and> ab_label s ident = Exited \<rbrace>"
  apply (rule validI_strengthen_guar, rule validI_strengthen_post, rule validI_guar_post_conj_lift)
     apply (rule peterson_proc_mutual_excl_helper)
    apply (rule peterson_proc_mutual_excl_helper')
   apply (clarsimp simp: peterson_rel_helpers)+
  done

definition "abs_peterson_proc_system \<equiv>
     parallel (do repeat (abs_peterson_proc A); interference od)
              (do repeat (abs_peterson_proc B); interference od)"

lemma validI_repeat_interference:
  "\<lbrace>P\<rbrace>, \<lbrace>R\<rbrace> f \<lbrace>G\<rbrace>, \<lbrace>\<lambda>_. P\<rbrace>
   \<Longrightarrow> \<forall>s0 s. P s0 s \<longrightarrow> (\<forall>s'. R\<^sup>*\<^sup>* s s' \<longrightarrow> Q () s' s') \<and> G s0 s
   \<Longrightarrow> \<lbrace>P\<rbrace>, \<lbrace>R\<rbrace> do repeat f; interference od \<lbrace>G\<rbrace>, \<lbrace>Q\<rbrace>"
  apply (rule bind_twp)
   apply simp
   apply (rule interference_twp)
  apply (rule validI_strengthen_post)
   apply (rule repeat_validI, assumption)
  apply simp
  done

lemma abs_peterson_proc_system_mutual_excl:
  "\<lbrace> \<lambda>s0 s. s0 = s \<and> invs s \<and> ab_label s = (\<lambda>_. Exited) \<rbrace>,
   \<lbrace> \<lambda>s0 s. s0 = s \<rbrace>
     abs_peterson_proc_system
   \<lbrace> \<lambda>s0 s. invs s0 \<longrightarrow> invs s \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. invs s \<rbrace>"
  apply (rule validI_weaken_pre, rule validI_strengthen_post)
    apply (unfold abs_peterson_proc_system_def)
    apply (rule rg_validI[where Qf="\<lambda>_ _. invs" and Qg="\<lambda>_ _. invs"])
           apply (rule validI_repeat_interference[OF abs_peterson_proc_mutual_excl])
           apply (clarsimp simp: peterson_rel_imp_invs)
          apply (rule validI_repeat_interference[OF abs_peterson_proc_mutual_excl])
          apply (clarsimp simp: peterson_rel_imp_invs)
         apply (simp add: reflp_ge_eq)+
  apply (clarsimp simp: peterson_rel_def)+
  done

definition "peterson_proc_system \<equiv>
     parallel (do repeat (peterson_proc A); interference od)
              (do repeat (peterson_proc B); interference od)"

lemma abs_peterson_proc_prefix_closed[simp]:
  "prefix_closed (abs_peterson_proc ident)"
  by (auto intro!: prefix_closed_bind
           simp: cs_closed abs_peterson_proc_def acquire_lock_def release_lock_def)

lemma peterson_repeat_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>s0 s. peterson_rel ident s0 s \<and> invs s \<and> ab_label s ident = Exited)
    (\<lambda>s0 s. peterson_rel ident s0 s \<and> invs s \<and> ab_label s ident = Exited)
    (peterson_rel (other_ident ident)) (peterson_rel (other_ident ident))
    (do repeat (abs_peterson_proc ident);
        interference
     od)
    (do repeat (peterson_proc ident);
        interference
     od)"
  apply (rule prefix_refinement_weaken_pre)
    apply (rule prefix_refinement_bind_sr)
       apply (rule prefix_refinement_repeat[rotated])
         apply (rule abs_peterson_proc_mutual_excl[THEN validI_strengthen_guar])
         apply simp
        apply (rule peterson_proc_mutual_excl[THEN validI_strengthen_guar, THEN validI_weaken_pre])
         apply simp+
       apply (rule peterson_proc_refinement[THEN prefix_refinement_weaken_pre])
        apply simp+
      apply (rule prefix_refinement_interference_peterson)
     apply (wpsimp wp: validI_triv)+
  done

theorem peterson_proc_system_refinement:
  "prefix_refinement peterson_sr peterson_sr peterson_sr \<top>\<top>
    (\<lambda>s0 s. s0 = s \<and> invs s \<and> ab_label s = (\<lambda>_. Exited))
    (\<lambda>t0 t. t0 = t \<and> invs t \<and> ab_label t = (\<lambda>_. Exited))
    (\<lambda>s0 s. s0 = s) (\<lambda>t0 t. t0 = t)
    abs_peterson_proc_system peterson_proc_system"
  apply (unfold abs_peterson_proc_system_def peterson_proc_system_def)
  apply (rule prefix_refinement_parallel')
         apply (rule prefix_refinement_weaken_rely, rule prefix_refinement_weaken_pre)
             apply (rule peterson_repeat_refinement)
            apply simp
           apply simp
          apply (rule eq_refl, rule bipred_disj_op_eq, simp)
         apply (rule eq_refl, rule bipred_disj_op_eq, simp)
        apply (rule prefix_refinement_weaken_rely, rule prefix_refinement_weaken_pre)
            apply (rule peterson_repeat_refinement)
           apply simp
          apply simp
         apply (rule eq_refl, rule bipred_disj_op_eq, simp)
        apply (rule eq_refl, rule bipred_disj_op_eq, simp)
       apply (clarsimp intro!: par_tr_fin_bind par_tr_fin_interference)
      apply (clarsimp intro!: par_tr_fin_bind par_tr_fin_interference)
     apply (rule validI_weaken_pre, rule validI_weaken_rely)
       apply (rule validI_repeat_interference; simp)
        apply (rule peterson_proc_mutual_excl)
       apply (simp+)[3]
    apply (rule validI_weaken_pre, rule validI_weaken_rely)
      apply (rule validI_repeat_interference; simp)
       apply (rule peterson_proc_mutual_excl)
      apply (simp+)[3]
  apply (rule validI_weaken_pre, rule validI_weaken_rely)
     apply (rule validI_repeat_interference; simp)
      apply (rule abs_peterson_proc_mutual_excl)
     apply (simp+)[3]
  apply (rule validI_weaken_pre, rule validI_weaken_rely)
    apply (rule validI_repeat_interference; simp)
     apply (rule abs_peterson_proc_mutual_excl)
    apply (simp+)[3]
  done

lemma peterson_proc_system_prefix_closed[simp]:
  "prefix_closed (peterson_proc_system)"
  by (auto intro!: prefix_closed_bind parallel_prefix_closed
             simp: cs_closed peterson_proc_system_def)

theorem peterson_proc_system_mutual_excl:
  "\<lbrace> \<lambda>s0 s. s0 = s \<and> invs s \<and> ab_label s = (\<lambda>_. Exited) \<rbrace>,
   \<lbrace> \<lambda>s0 s. s0 = s \<rbrace>
     peterson_proc_system
   \<lbrace> \<lambda>s0 s. invs s0 \<longrightarrow> invs s \<rbrace>,
   \<lbrace> \<lambda>rv s0 s. invs s \<rbrace>"
  apply (rule prefix_refinement_validI')
        apply (rule peterson_proc_system_refinement)
       apply (rule abs_peterson_proc_system_mutual_excl)
      apply clarsimp
     apply (clarsimp simp: peterson_sr_invs_sym )
    apply (fastforce simp: peterson_rel_def peterson_sr_def)
   apply clarsimp
  apply (fastforce simp: peterson_sr_def)
  done

end
end


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

Datatype of events; function "spies"; freshness

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

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

theory Event imports Message begin

consts  \<comment> \<open>Initial states of agents --- a parameter of the construction\<close>
  initState :: "agent \<Rightarrow> msg set"

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

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

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

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

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

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

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

lemma Notes_imp_used: "Notes A X \<in> set evs \<Longrightarrow> X \<in> used evs"
  by (induct evs) (auto split: event.split)

lemma Says_imp_used: "Says A B X \<in> set evs \<Longrightarrow> X \<in> used evs"
  by (induct evs) (auto split: event.split)

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

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

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

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

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

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

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

text\<open>Spy sees what is sent on the traffic\<close>
lemma Says_imp_knows_Spy:
     "Says A B X \<in> set evs \<Longrightarrow> X \<in> knows Spy evs"
  by (induct evs) (auto split: event.split)

lemma Notes_imp_knows_Spy [rule_format]:
     "Notes A X \<in> set evs \<Longrightarrow> A \<in> bad \<Longrightarrow> X \<in> knows Spy evs"
  by (induct evs) (auto split: event.split)

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

lemmas knows_Spy_partsEs =
     Says_imp_parts_knows_Spy parts.Body [elim_format]

lemmas Says_imp_analz_Spy = Says_imp_knows_Spy [THEN analz.Inj]

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

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

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

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

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

text\<open>Agents know what they say\<close>
lemma Says_imp_knows [rule_format]: "Says A B X \<in> set evs \<Longrightarrow> X \<in> knows A evs"
  by (induct evs) (force split: event.split)+

text\<open>Agents know what they note\<close>
lemma Notes_imp_knows [rule_format]: "Notes A X \<in> set evs \<Longrightarrow> X \<in> knows A evs"
  by (induct evs) (force split: event.split)+

text\<open>Agents know what they receive\<close>
lemma Gets_imp_knows_agents [rule_format]:
     "A \<noteq> Spy \<Longrightarrow> Gets A X \<in> set evs \<Longrightarrow> X \<in> knows A evs"
  by (induct evs) (force split: event.split)+

text\<open>What agents DIFFERENT FROM Spy know
  was either said, or noted, or got, or known initially\<close>
lemma knows_imp_Says_Gets_Notes_initState:
  "\<lbrakk>X \<in> knows A evs; A \<noteq> Spy\<rbrakk> \<Longrightarrow>
     \<exists>B. Says A B X \<in> set evs \<or> Gets A X \<in> set evs \<or> Notes A X \<in> set evs \<or> X \<in> initState A"
  by(induct evs) (auto split: event.split_asm if_split_asm)

text\<open>What the Spy knows -- for the time being --
  was either said or noted, or known initially\<close>
lemma knows_Spy_imp_Says_Notes_initState:
  "X \<in> knows Spy evs \<Longrightarrow>
    \<exists>A B. Says A B X \<in> set evs \<or> Notes A X \<in> set evs \<or> X \<in> initState Spy"
  by(induct evs) (auto split: event.split_asm if_split_asm)

lemma parts_knows_Spy_subset_used: "parts (knows Spy evs) \<subseteq> used evs"
  by (induct evs) (auto simp: parts_insert_knows_A split: event.split_asm if_split_asm)

lemmas usedI = parts_knows_Spy_subset_used [THEN subsetD, intro]

lemma initState_into_used: "X \<in> parts (initState B) \<Longrightarrow> X \<in> used evs"
  by (induct evs) (auto simp: parts_insert_knows_A split: event.split)

text \<open>New simprules to replace the primitive ones for @{term used} and @{term knows}\<close>

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

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

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

lemma used_nil_subset: "used [] \<subseteq> used evs"
  using initState_into_used by auto

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

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

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

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

lemma initState_subset_knows: "initState A \<subseteq> knows A evs"
  by (induct evs) (use knows_subset_knows_Cons in fastforce)+

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

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

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

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

text\<open>Useful for case analysis on whether a hash is a spoof or not\<close>
lemmas syan_impI = impI [where P = "Y \<notin> synth (analz (knows Spy evs))"] for Y evs

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

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

end


(*  Title:      HOL/HOLCF/IOA/meta_theory/RefMappings.thy
    Author:     Olaf Müller
*)

section {* Refinement Mappings in HOLCF/IOA *}

theory RefMappings
imports Traces
begin

default_sort type

definition
  move :: "[('a,'s)ioa,('a,'s)pairs,'s,'a,'s] => bool" where
  "move ioa ex s a t =
    (is_exec_frag ioa (s,ex) &  Finite ex &
     laststate (s,ex)=t  &
     mk_trace ioa$ex = (if a:ext(ioa) then a>>nil else nil))"

definition
  is_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_ref_map f C A =
   ((!s:starts_of(C). f(s):starts_of(A)) &
   (!s t a. reachable C s &
            s -a--C-> t
            --> (? ex. move A ex (f s) a (f t))))"

definition
  is_weak_ref_map :: "[('s1=>'s2),('a,'s1)ioa,('a,'s2)ioa] => bool" where
  "is_weak_ref_map f C A =
   ((!s:starts_of(C). f(s):starts_of(A)) &
   (!s t a. reachable C s &
            s -a--C-> t
            --> (if a:ext(C)
                 then (f s) -a--A-> (f t)
                 else (f s)=(f t))))"

subsection "transitions and moves"

lemma transition_is_ex: "s -a--A-> t ==> ? ex. move A ex s a t"
apply (rule_tac x = " (a,t) >>nil" in exI)
apply (simp add: move_def)
done

lemma nothing_is_ex: "(~a:ext A) & s=t ==> ? ex. move A ex s a t"
apply (rule_tac x = "nil" in exI)
apply (simp add: move_def)
done

lemma ei_transitions_are_ex: "(s -a--A-> s') & (s' -a'--A-> s'') & (~a':ext A)
         ==> ? ex. move A ex s a s''"
apply (rule_tac x = " (a,s') >> (a',s'') >>nil" in exI)
apply (simp add: move_def)
done

lemma eii_transitions_are_ex: "(s1 -a1--A-> s2) & (s2 -a2--A-> s3) & (s3 -a3--A-> s4) &
      (~a2:ext A) & (~a3:ext A) ==>
      ? ex. move A ex s1 a1 s4"
apply (rule_tac x = " (a1,s2) >> (a2,s3) >> (a3,s4) >>nil" in exI)
apply (simp add: move_def)
done

subsection "weak_ref_map and ref_map"

lemma weak_ref_map2ref_map:
  "[| ext C = ext A;
     is_weak_ref_map f C A |] ==> is_ref_map f C A"
apply (unfold is_weak_ref_map_def is_ref_map_def)
apply auto
apply (case_tac "a:ext A")
apply (auto intro: transition_is_ex nothing_is_ex)
done

lemma imp_conj_lemma: "(P ==> Q-->R) ==> P&Q --> R"
  by blast

declare split_if [split del]
declare if_weak_cong [cong del]

lemma rename_through_pmap: "[| is_weak_ref_map f C A |]
      ==> (is_weak_ref_map f (rename C g) (rename A g))"
apply (simp add: is_weak_ref_map_def)
apply (rule conjI)
(* 1: start states *)
apply (simp add: rename_def rename_set_def starts_of_def)
(* 2: reachable transitions *)
apply (rule allI)+
apply (rule imp_conj_lemma)
apply (simp (no_asm) add: rename_def rename_set_def)
apply (simp add: externals_def asig_inputs_def asig_outputs_def asig_of_def trans_of_def)
apply safe
apply (simplesubst split_if)
 apply (rule conjI)
 apply (rule impI)
 apply (erule disjE)
 apply (erule exE)
apply (erule conjE)
(* x is input *)
 apply (drule sym)
 apply (drule sym)
apply simp
apply hypsubst+
apply (frule reachable_rename)
apply simp
(* x is output *)
 apply (erule exE)
apply (erule conjE)
 apply (drule sym)
 apply (drule sym)
apply simp
apply hypsubst+
apply (frule reachable_rename)
apply simp
(* x is internal *)
apply (frule reachable_rename)
apply auto
done

declare split_if [split]
declare if_weak_cong [cong]

end