theory Simple_Network_Language
  imports Main
    Networks.State_Networks
    Uppaal_Networks.UPPAAL_State_Networks_Impl
    FinFun.FinFun
begin

paragraph \<open>Tagging\<close>

definition TAG ("_ \<bar> _" [8, 8] 9) where
  "TAG t x = x"

definition
  "TAG' t x = TAG t x"

lemmas TAG = TAG'_def[symmetric]

lemmas add_tag = TAG_def[symmetric]

lemma rm_TAG:
  assumes "TAG t x" "TAG t x = TAG' t x"
  shows True
  by auto

method tags uses del keep =
  (unfold keep)?,
  ((drule rm_TAG, rule del)+)?,
  (unfold keep[symmetric])?

datatype 'a tag = ANY 'a | TRANS 'a | SEL 'a | SEND 'a | RECV 'a

lemma
  assumes "TAG 1 False" "TAG (TRANS STR ''remove'') (x > 0)"
  shows False
  using assms
  apply -
  apply (tags del: TAG[of "TRANS t" for t] TAG[of 1] keep: TAG[of 1])
  unfolding TAG_def .

section \<open>Simple networks of automata with broadcast channels and committed locations\<close>

no_notation top_assn ("true")

datatype ('a, 'b) bexp =
  true |
  not "('a, 'b) bexp" |
  "and" "('a, 'b) bexp" "('a, 'b) bexp" |
  or "('a, 'b) bexp" "('a, 'b) bexp" |
  imply "('a, 'b) bexp" "('a, 'b) bexp" | \<comment> \<open>Boolean connectives\<close>
  eq "('a, 'b) exp" "('a, 'b) exp" |
  le "('a, 'b) exp" "('a, 'b) exp" |
  lt "('a, 'b) exp" "('a, 'b) exp" |
  ge "('a, 'b) exp" "('a, 'b) exp" |
  gt "('a, 'b) exp" "('a, 'b) exp"
and ('a, 'b) exp =
  const 'b | var 'a | if_then_else "('a, 'b) bexp" "('a, 'b) exp" "('a, 'b) exp" |
  binop "'b \<Rightarrow> 'b \<Rightarrow> 'b" "('a, 'b) exp" "('a, 'b) exp" | unop "'b \<Rightarrow> 'b" "('a, 'b) exp"

inductive check_bexp :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a, 'b :: linorder) bexp \<Rightarrow> bool \<Rightarrow> bool" and is_val
  where
  "check_bexp s true True" |
  "check_bexp s (not e) (\<not> b)" if "check_bexp s e b" |
  "check_bexp s (and e1 e2) (a \<and> b)" if "check_bexp s e1 a" "check_bexp s e2 b" |
  "check_bexp s (or e1 e2) (a \<or> b)" if "check_bexp s e1 a" "check_bexp s e2 b" |
  "check_bexp s (imply e1 e2) (a \<longrightarrow> b)" if "check_bexp s e1 a" "check_bexp s e2 b" |
  "check_bexp s (eq a b) (x = v)" if "is_val s a v" "is_val s b x" |
  "check_bexp s (le a b) (v \<le> x)" if "is_val s a v" "is_val s b x" |
  "check_bexp s (lt a b) (v < x)" if "is_val s a v" "is_val s b x" |
  "check_bexp s (ge a b) (v \<ge> x)" if "is_val s a v" "is_val s b x" |
  "check_bexp s (gt a b) (v > x)" if "is_val s a v" "is_val s b x" |
  "is_val s (const c) c" |
  "is_val s (var x)   v" if "s x = Some v" |
  "is_val s (if_then_else b e1 e2) (if bv then v1 else v2)"
  if "is_val s e1 v1" "is_val s e2 v2" "check_bexp s b bv" |
  "is_val s (binop f e1 e2) (f v1 v2)" if "is_val s e1 v1" "is_val s e2 v2" |
  "is_val s (unop f e) (f v)" if "is_val s e v"

type_synonym
  ('c, 't, 's) invassn = "'s \<Rightarrow> ('c, 't) cconstraint"

type_synonym
  ('a, 'b) upd = "('a * ('a, 'b) exp) list"

type_synonym
  ('a, 's, 'c, 't, 'x, 'v) transition =
  "'s \<times> ('x, 'v) bexp \<times> ('c, 't) cconstraint \<times> 'a \<times> ('x, 'v) upd \<times> 'c list \<times> 's"

type_synonym
  ('a, 's, 'c, 't, 'x, 'v) sta =
  "'s set \<times> 's set \<times> ('a, 's, 'c, 't, 'x, 'v) transition set \<times> ('c, 't, 's) invassn"

type_synonym
  ('a, 's, 'c, 't, 'x, 'v) nta = "'a set \<times> ('a act, 's, 'c, 't, 'x, 'v) sta list \<times> ('x \<rightharpoonup> 'v * 'v)"

context begin

qualified definition conv_t where "conv_t \<equiv> \<lambda> (l,b,g,a,f,r,l'). (l,b,conv_cc g,a,f,r,l')"

qualified definition conv_A where "conv_A \<equiv> \<lambda> (C, U, T, I). (C, U, conv_t ` T, conv_cc o I)"

definition conv where
  "conv \<equiv> \<lambda>(broadcast, automata, bounds). (broadcast, map conv_A automata, bounds)"

end

datatype 'b label = Del | Internal 'b | Bin 'b | Broad 'b

definition bounded where
  "bounded bounds s \<equiv> dom s = dom bounds \<and>
    (\<forall>x \<in> dom s. fst (the (bounds x)) \<le> the (s x) \<and> the (s x) \<le> snd (the (bounds x)))"

definition is_upd where
  "is_upd s upds s' \<equiv> \<exists>xs. list_all2 (\<lambda> (l1, r1) (l2, r2). l1 = l2 \<and> is_val s r1 r2) upds xs
    \<and> s' = fold (\<lambda> (l, r) s. s(l := Some r)) xs s"

inductive is_upds where
  "is_upds s [] s" |
  "is_upds s (x # xs) s''" if "is_upd s x s'" "is_upds s' xs s''"

definition committed :: "('a, 's, 'c, 't, 'x, 'v) sta \<Rightarrow> 's set" where
  "committed A \<equiv> fst A"

definition urgent :: "('a, 's, 'c, 't, 'x, 'v) sta \<Rightarrow> 's set" where
  "urgent A \<equiv> fst (snd A)"

definition trans :: "('a, 's, 'c, 't, 'x, 'v) sta \<Rightarrow> ('a, 's, 'c, 't, 'x, 'v) transition set"
  where
  "trans A \<equiv> fst (snd (snd A))"

definition inv :: "('a, 's, 'c, 't, 'x, 'v) sta \<Rightarrow> ('c, 't, 's) invassn" where
  "inv A \<equiv> snd (snd (snd A))"

no_notation step_sn ("_ \<turnstile> \<langle>_, _, _\<rangle> \<rightarrow>\<^bsub>_\<^esub> \<langle>_, _, _\<rangle>" [61,61,61,61,61] 61)
no_notation steps_sn ("_ \<turnstile> \<langle>_, _, _\<rangle> \<rightarrow>* \<langle>_, _, _\<rangle>" [61, 61, 61,61,61] 61)

inductive step_u ::
  "('a, 's, 'c, 't :: time, 'x, 'v :: linorder) nta \<Rightarrow> 's list \<Rightarrow> ('x \<rightharpoonup> 'v) \<Rightarrow> ('c, 't) cval
  \<Rightarrow> 'a label \<Rightarrow> 's list \<Rightarrow> ('x \<rightharpoonup> 'v) \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _, _\<rangle> \<rightarrow>\<^bsub>_\<^esub> \<langle>_, _, _\<rangle>" [61,61,61,61,61] 61)
where
  step_t:
    "\<lbrakk>
      ''target invariant'' \<bar> \<forall>p < length N. u \<oplus> d \<turnstile> inv (N ! p) (L ! p);
      ''nonnegative''      \<bar> d \<ge> 0;
      ''urgent''           \<bar> (\<exists>p < length N. L ! p \<in> urgent (N ! p)) \<longrightarrow> d = 0;
      ''bounded''          \<bar> bounded B s
     \<rbrakk>
    \<Longrightarrow> (broadcast, N, B) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L, s, u \<oplus> d\<rangle>" |
  step_int:
    "\<lbrakk>
      TRANS ''silent'' \<bar> (l, b, g, Sil a, f, r, l') \<in> trans (N ! p);
      ''committed'' \<bar> l \<in> committed (N ! p) \<or> (\<forall>p < length N. L ! p \<notin> committed (N ! p));
      ''bexp''      \<bar> check_bexp s b True;
      ''guard''     \<bar> u \<turnstile> g;
      ''target invariant'' \<bar> \<forall>p < length N. u' \<turnstile> inv (N ! p) (L' ! p);
      ''loc''           \<bar> L!p = l;
      ''range''         \<bar> p < length L;
      ''new loc''       \<bar> L' = L[p := l'];
      ''new valuation'' \<bar> u' = [r\<rightarrow>0]u;
      ''is_upd''        \<bar> is_upd s f s';
      ''bounded''       \<bar> bounded B s'
    \<rbrakk>
    \<Longrightarrow> (broadcast, N, B) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Internal a\<^esub> \<langle>L', s', u'\<rangle>" |
  step_bin:
    "\<lbrakk>
      ''not broadcast'' \<bar> (a \<notin> broadcast);
      TRANS ''in''  \<bar> (l1, b1, g1, In a,  f1, r1, l1') \<in> trans (N ! p);
      TRANS ''out'' \<bar> (l2, b2, g2, Out a, f2, r2, l2') \<in> trans (N ! q);
      ''committed'' \<bar>
        l1 \<in> committed (N ! p) \<or> l2 \<in> committed (N ! q) \<or> (\<forall>p < length N. L ! p \<notin> committed (N ! p));
      ''bexp'' \<bar> check_bexp s b1 True; ''bexp'' \<bar> check_bexp s b2 True;
      ''guard'' \<bar> u \<turnstile> g1; ''guard'' \<bar> u \<turnstile> g2;
      ''target invariant'' \<bar> \<forall>p < length N. u' \<turnstile> inv (N ! p) (L' ! p);
      RECV ''loc'' \<bar> L!p = l1; SEND ''loc'' \<bar> L!q = l2;
      RECV ''range'' \<bar> p < length L; SEND ''range'' \<bar> q < length L;
      ''different'' \<bar> p \<noteq> q;
      ''new loc''       \<bar> L' = L[p := l1', q := l2'];
      ''new valuation'' \<bar> u' = [r1@r2\<rightarrow>0]u;
      ''upd'' \<bar> is_upd s f1 s'; ''upd'' \<bar> is_upd s' f2 s'';
      ''bounded'' \<bar> bounded B s''
    \<rbrakk>
    \<Longrightarrow> (broadcast, N, B) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Bin a\<^esub> \<langle>L', s'', u'\<rangle>" |
  step_broad:
    "\<lbrakk>
      ''broadcast'' \<bar> a \<in> broadcast;
      TRANS ''out'' \<bar> (l, b, g, Out a, f, r, l') \<in> trans (N ! p);
      TRANS ''in''  \<bar> (\<forall>p \<in> set ps. (L ! p, bs p, gs p, In a, fs p, rs p, ls' p) \<in> trans (N ! p));
      ''committed'' \<bar> (l \<in> committed (N ! p) \<or> (\<exists>p \<in> set ps. L ! p \<in> committed (N ! p))
      \<or> (\<forall>p < length N. L ! p \<notin> committed (N ! p)));
      ''bexp''    \<bar> check_bexp s b True;
      ''bexp''    \<bar> \<forall>p \<in> set ps. check_bexp s (bs p) True;
      ''guard''   \<bar> u \<turnstile> g;
      ''guard''   \<bar> \<forall>p \<in> set ps. u \<turnstile> gs p;
      ''maximal'' \<bar> \<forall>q < length N. q \<notin> set ps \<and> p \<noteq> q
        \<longrightarrow> (\<forall>b g f r l'. (L!q, b, g, In a, f, r, l') \<in> trans (N ! q)
        \<longrightarrow> \<not> check_bexp s b True \<or> \<not> u \<turnstile> g);
      ''target invariant'' \<bar> \<forall>p < length N. u' \<turnstile> inv (N ! p) (L' ! p);
      SEND ''loc''       \<bar> L!p = l;
      SEND ''range''     \<bar> p < length L;
      SEL ''range''      \<bar> set ps \<subseteq> {0..<length N};
      SEL ''not sender'' \<bar> p \<notin> set ps;
      SEL ''distinct''   \<bar> distinct ps;
      SEL ''sorted''     \<bar> sorted ps;
      ''new loc'' \<bar> L' = (fold (\<lambda>p L . L[p := ls' p]) ps L)[p := l'];
      ''new valuation'' \<bar> u' = [r@concat (map rs ps)\<rightarrow>0]u;
      ''upd''     \<bar> is_upd s f s';
      ''upds''    \<bar> is_upds s' (map fs ps) s'';
      ''bounded'' \<bar> bounded B s''
    \<rbrakk>
    \<Longrightarrow> (broadcast, N, B) \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Broad a\<^esub> \<langle>L', s'', u'\<rangle>"
lemmas [intro?] = step_u.intros[unfolded TAG_def]

text \<open>Comments:
\<^item> Should there be an error transition + state if states run of bounds or updates are undefined?
Then one could run a reachability check for the error state.
\<^item> Should the state be total?
\<^item> Note that intermediate states are allowed to run out of bounds
\<close>

definition steps_u ::
  "('a, 's, 'c, 't :: time, 'x, 'v :: linorder) nta \<Rightarrow> 's list \<Rightarrow> ('x \<rightharpoonup> 'v) \<Rightarrow> ('c, 't) cval
  \<Rightarrow> 's list \<Rightarrow> ('x \<rightharpoonup> 'v) \<Rightarrow> ('c, 't) cval \<Rightarrow> bool"
("_ \<turnstile> \<langle>_, _, _\<rangle> \<rightarrow>* \<langle>_, _, _\<rangle>" [61,61,61,61,61] 61)
where
  "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>* \<langle>L', s', u'\<rangle> \<equiv>
    (\<lambda> (L, s, u) (L', s', u'). \<exists>a. A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>)\<^sup>*\<^sup>* (L, s, u) (L', s', u')"

paragraph \<open>Misc\<close>

lemma clock_val_concat_iff:
  \<open>u \<turnstile> concat gs \<longleftrightarrow> (\<forall>g \<in> set gs. u \<turnstile> g)\<close>
  by (auto intro: guard_concat concat_guard)

lemma clock_val_append_iff:
  \<open>u \<turnstile> g1 @ g2 \<longleftrightarrow> u \<turnstile> g1 \<and> u \<turnstile> g2\<close>
proof -
  have "u \<turnstile> g1 @ g2 \<longleftrightarrow> u \<turnstile> concat [g1, g2]"
    by simp
  also have "... \<longleftrightarrow> u \<turnstile> g1 \<and> u \<turnstile> g2"
    unfolding clock_val_concat_iff by simp
  finally show ?thesis .
qed

subsection \<open>Product construction\<close>

locale Prod_TA_Defs =
  fixes A :: "('a, 's, 'c, 't, 'x, 'v :: linorder) nta"
begin

definition
  "broadcast = fst A"

definition
  "N i = fst (snd A) ! i"

definition
  "bounds = snd (snd A)"

definition \<comment>\<open>Number of processes\<close>
  "n_ps = length (fst (snd A))"

definition states  :: "'s list set" where
  "states \<equiv> {L. length L = n_ps \<and>
    (\<forall> i. i < n_ps --> L ! i \<in> (\<Union> (l, e, g, a, r, u, l') \<in> (trans (N i)). {l, l'}))}"

definition
  "prod_inv \<equiv> \<lambda>(L, s). if L \<in> states then concat (map (\<lambda>i. inv (N i) (L ! i)) [0..<n_ps]) else []"

definition
  "trans_int =
    {((L, s), g, Internal a, r, (L', s')) | L s l b g f p a r l' L' s'.
      (l, b, g, Sil a, f, r, l') \<in> trans (N p) \<and>
      (l \<in> committed (N p) \<or> (\<forall>p < n_ps. L ! p \<notin> committed (N p))) \<and>
      L!p = l \<and> p < length L \<and> L' = L[p := l'] \<and> is_upd s f s' \<and> check_bexp s b True \<and>
      L \<in> states \<and> bounded bounds s \<and> bounded bounds s'
    }"

definition
  "trans_bin =
    {((L, s), g1 @ g2, Bin a, r1 @ r2, (L', s'')) |
      L s L' s' s'' a p q l1 b1 g1 f1 r1 l1' l2 b2 g2 f2 r2 l2'.
      a \<notin> broadcast \<and>
      (l1, b1, g1, In a,  f1, r1, l1') \<in> trans (N p) \<and>
      (l2, b2, g2, Out a, f2, r2, l2') \<in> trans (N q) \<and>
      (l1 \<in> committed (N p) \<or> l2 \<in> committed (N q) \<or> (\<forall>p < n_ps. L ! p \<notin> committed (N p))) \<and>
      L!p = l1 \<and> L!q = l2 \<and> p < length L \<and> q < length L \<and> p \<noteq> q \<and>
      check_bexp s b1 True \<and> check_bexp s b2 True \<and>
      L' = L[p := l1', q := l2'] \<and> is_upd s f1 s' \<and> is_upd s' f2 s'' \<and>
      L \<in> states \<and> bounded bounds s \<and> bounded bounds s''
    }"

definition
  "trans_broad =
    {((L, s), g @ concat (map gs ps), Broad a, r @ concat (map rs ps), (L', s'')) |
    L s L' s' s'' a p l b g f r l' bs gs fs rs ls' ps.
      a \<in> broadcast  \<and>
      (l, b, g, Out a, f, r, l') \<in> trans (N p) \<and>
      (\<forall>p \<in> set ps. (L ! p, bs p, gs p, In a, fs p, rs p, ls' p) \<in> trans (N p)) \<and>
      (l \<in> committed (N p) \<or> (\<exists>p \<in> set ps. L ! p \<in> committed (N p))
      \<or> (\<forall>p < n_ps. L ! p \<notin> committed (N p))) \<and>
      (\<forall>q < n_ps. q \<notin> set ps \<and> p \<noteq> q \<longrightarrow>
        \<not> (\<exists>b g f r l'. (L!q, b, g, In a, f, r, l') \<in> trans (N q) \<and> check_bexp s b True)) \<and>
      L!p = l \<and>
      p < length L \<and> set ps \<subseteq> {0..<n_ps} \<and> p \<notin> set ps \<and> distinct ps \<and> sorted ps \<and>
      check_bexp s b True \<and> (\<forall>p \<in> set ps. check_bexp s (bs p) True) \<and>
      L' = (fold (\<lambda>p L . L[p := ls' p]) ps L)[p := l'] \<and>
      is_upd s f s' \<and> is_upds s' (map fs ps) s'' \<and>
      L \<in> states \<and> bounded bounds s \<and> bounded bounds s''
    }"

definition
  "trans_prod = trans_int \<union> trans_bin \<union> trans_broad"

definition
  "prod_ta = (trans_prod, prod_inv :: ('s list \<times> ('x \<Rightarrow> 'v option) \<Rightarrow> _))"

lemma inv_of_prod[simp]:
  "inv_of prod_ta = prod_inv"
  unfolding prod_ta_def inv_of_def by simp

lemma trans_of_prod[simp]:
  "trans_of prod_ta = trans_prod"
  unfolding prod_ta_def trans_of_def by simp

lemma A_split:
  \<open>A = (broadcast, map N [0..<n_ps], bounds)\<close>
  unfolding broadcast_def N_def bounds_def n_ps_def by (cases A) (simp add: List.map_nth)

lemma map_N_n_ps_simp:
  "map N [0..<n_ps] ! p = N p"
  unfolding N_def n_ps_def List.map_nth ..

lemma N_split_simp[simp]:
  assumes "A = (broadcast', N', B)"
  shows "N' ! i = N i"
  unfolding N_def unfolding assms by simp

lemma state_preservation_updI:
  assumes "l' \<in> (\<Union> (l, b, g, a, r, u, l') \<in> trans (N p). {l, l'})" "L \<in> states"
  shows "L[p := l'] \<in> states"
  using assms unfolding states_def by (fastforce simp: nth_list_update')

lemma state_preservation_fold_updI:
  assumes "\<forall>p \<in> set ps. ls' p \<in> (\<Union> (l, b, g, a, r, u, l') \<in> trans (N p). {l, l'})" "L \<in> states"
  shows "fold (\<lambda>p L. L[p := ls' p]) ps L \<in> states"
  using assms by (induction ps arbitrary: L) (auto intro: state_preservation_updI)

lemma state_set_states:
  "Simulation_Graphs_TA.state_set prod_ta \<subseteq> {(l, s). l \<in> states}"
  unfolding prod_ta_def state_set_def
  unfolding trans_of_def trans_prod_def
  unfolding trans_int_def trans_bin_def trans_broad_def
  by auto (auto intro: state_preservation_updI state_preservation_fold_updI)

lemma trans_prod_bounded_inv:
  \<open>bounded bounds s'\<close> if \<open>((L, s), g, a, r, (L', s')) \<in> trans_prod\<close>
  using that unfolding bounds_def trans_prod_def trans_int_def trans_bin_def trans_broad_def
  by (auto simp: bounds_def)

lemma trans_prod_states_inv:
  \<open>L' \<in> states\<close> if \<open>((L, s), g, a, r, (L', s')) \<in> trans_prod\<close> \<open>L \<in> states\<close>
  using that
  unfolding bounds_def trans_prod_def trans_int_def trans_bin_def trans_broad_def
  apply clarsimp
  apply safe
         apply (force intro!: state_preservation_updI)
        apply (force intro!: state_preservation_updI)
       apply (force intro!: state_preservation_updI)
      apply (force intro!: state_preservation_updI)
     apply (force intro!: state_preservation_updI)
    apply (fastforce intro!: state_preservation_updI state_preservation_fold_updI)
  subgoal
    apply (rule state_preservation_updI)
    apply force
    apply (force intro!: state_preservation_fold_updI)
    done
  apply (fastforce intro!: state_preservation_updI state_preservation_fold_updI)
  done

end (* Prod TA Defs *)

locale Prod_TA_sem =
  Prod_TA_Defs A for A :: "('a, 's, 'c, 't :: time, 'x, 'v :: linorder) nta"
begin

lemma prod_invI[intro]:
  \<open>u \<turnstile> prod_inv (L, s)\<close> if \<open>\<forall>p<n_ps. u \<turnstile> Simple_Network_Language.inv (N p) (L ! p)\<close>
  using that unfolding prod_inv_def by (auto intro!: guard_concat)

lemma prod_invD[dest]:
  \<open>\<forall>p<n_ps. u \<turnstile> Simple_Network_Language.inv (N p) (L ! p)\<close> if \<open>u \<turnstile> prod_inv (L, s)\<close> \<open>L \<in> states\<close>
  using that unfolding prod_inv_def by (auto elim: concat_guard)

lemma delay_sound:
  assumes "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>(L', s'), u'\<rangle>" "L \<in> states" "bounded bounds s"
          "\<forall>N \<in> set (fst (snd A)). urgent N = {}"
        shows "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', s', u'\<rangle>"
proof -
  from assms(4) have "l \<notin> urgent (N p)" if "p < n_ps" for p l
    using that unfolding N_def n_ps_def by auto
  then show ?thesis
    by (subst A_split) (use assms in \<open>cases, auto intro!: step_t simp: TAG_def\<close>)
qed

lemma action_sound:
  "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>" if "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>(L', s'), u'\<rangle>"
  using that
proof cases
  case prems: (1 g r)
  note [simp add] = map_N_n_ps_simp clock_val_append_iff clock_val_concat_iff
  from \<open>prod_ta \<turnstile> (L, s) \<longrightarrow>\<^bsup>g,a,r\<^esup> (L', s')\<close>[THEN state_setI2] have "L' \<in> states"
    using state_set_states that by fast
  from \<open>prod_ta \<turnstile> (L, s) \<longrightarrow>\<^bsup>g,a,r\<^esup> (L', s')\<close> show ?thesis
    unfolding trans_of_prod trans_prod_def
  proof safe
    assume "((L, s), g, a, r, L', s') \<in> trans_int"
    then show "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>"
      unfolding trans_int_def
      apply clarsimp
      using prems \<open>L' \<in> _\<close>
      by (subst A_split) (intro step_int; simp add: TAG_def; elim prod_invD; assumption)
  next
    assume "((L, s), g, a, r, L', s') \<in> trans_bin"
    then show "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>"
      unfolding trans_bin_def
      using prems \<open>L' \<in> _\<close>
      apply clarsimp
      apply (subst A_split, standard)
                     apply (assumption | simp; elim prod_invD; assumption)+
      done
  next
    assume "((L, s), g, a, r, L', s') \<in> trans_broad"
    then show "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>"
      using prems \<open>L' \<in> _\<close>
      unfolding trans_broad_def inv_of_prod
      apply clarsimp
      apply (subst A_split)
      apply standard
                          apply (assumption | simp; elim prod_invD; assumption | fastforce)+
      done
  qed
qed

lemma bounded_inv:
  \<open>bounded bounds s'\<close> if \<open>A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>\<close>
  using that unfolding bounds_def by cases (simp add: TAG_def)+

lemma states_inv:
  \<open>L' \<in> states\<close> if \<open>A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>\<close> \<open>L \<in> states\<close>
  using that unfolding bounds_def
proof cases
  case (step_t N d B broadcast)
  with \<open>L \<in> states\<close> show ?thesis
    by simp
next
  case prems[unfolded TAG_def]: (step_int l b g a f r l' N' p B broadcast)
  from \<open>A = _\<close> prems(3) have "l' \<in> (\<Union> (l, b, g, a, r, u, l') \<in> trans (N p). {l, l'})"
    by force
  with \<open>L \<in> states\<close> show ?thesis
    unfolding \<open>L' = _\<close> by (intro state_preservation_updI)
next
  case prems[unfolded TAG_def]:
    (step_bin broadcast a l1 b1 g1 f1 r1 l1' N' p l2 b2 g2 f2 r2 l2' q s' B)
  from \<open>A = _\<close> prems(4, 5) have
    "l1' \<in> (\<Union> (l, b, g, a, r, u, l') \<in> trans (N p). {l, l'})"
    "l2' \<in> (\<Union> (l, b, g, a, r, u, l') \<in> trans (N q). {l, l'})"
    by force+
  with \<open>L \<in> states\<close> show ?thesis
    unfolding \<open>L' = _\<close> by (intro state_preservation_updI)
next
  case prems[unfolded TAG_def]: (step_broad a broadcast l b g f r l' N' p ps bs gs fs rs ls' s' B)
  from \<open>A = _\<close> prems(4, 5) have
    "l' \<in> (\<Union> (l, b, g, a, r, u, l') \<in> trans (N p). {l, l'})"
    "\<forall> q \<in> set ps. ls' q \<in> (\<Union> (l, b, g, a, r, u, l') \<in> trans (N q). {l, l'})"
    by force+
  with \<open>L \<in> states\<close> show ?thesis
    unfolding \<open>L' = _\<close> by (intro state_preservation_updI state_preservation_fold_updI)
qed

end (* Prod TA Defs on a time domain *)

locale Prod_TA =
  Prod_TA_sem A for A :: "('a, 's, 'c, 't :: time, 'x, 'v :: linorder) nta" +
  assumes broadcast_receivers_unguarded:
    "\<forall>p < n_ps. \<forall>l b g a f r l'. (l, b, g, In a, f, r, l') \<in> trans (N p) \<and> a \<in> broadcast \<longrightarrow> g = []"
begin

lemma action_complete:
  "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>(L', s'), u'\<rangle>"
  if "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>" "a \<noteq> Del" "L \<in> states" "bounded bounds s"
using that(1) proof cases
  case (step_t N d B broadcast)
  then show ?thesis
    using that(2) by auto
next
  case prems[unfolded TAG_def]: (step_int l b g a' f r l' N' p B broadcast')
  have [simp]:
    "B = bounds" "broadcast' = broadcast" "length N' = n_ps"
    unfolding bounds_def broadcast_def n_ps_def unfolding prems(1) by simp+
  have [simp]:
    "N' ! i = N i" for i
    unfolding N_def unfolding prems(1) by simp
  have "prod_ta \<turnstile> (L, s) \<longrightarrow>\<^bsup>g,Internal a',r\<^esup> (L', s')"
  proof -
    from prems \<open>L \<in> states\<close> \<open>bounded _ s\<close> have "((L, s),g,Internal a',r,(L', s')) \<in> trans_int"
      unfolding trans_int_def
      by simp (rule exI conjI HOL.refl | assumption | (simp; fail))+
    then show ?thesis
      unfolding prod_ta_def trans_of_def trans_prod_def by simp
  qed
  moreover have "u \<turnstile> g"
    by (rule prems)
  moreover have "u' \<turnstile> inv_of prod_ta (L', s')"
    using prems(7) by auto
  moreover have "u' = [r\<rightarrow>0]u"
    by (rule prems)
  ultimately show ?thesis
    unfolding \<open>a = _\<close> ..
next
  case prems[unfolded TAG_def]:
    (step_bin a' broadcast' l1 b1 g1 f1 r1 l1' N' p l2 b2 g2 f2 r2 l2' q s'' B)
  have [simp]:
    "B = bounds" "broadcast' = broadcast" "length N' = n_ps"
    unfolding bounds_def broadcast_def n_ps_def unfolding prems(1) by simp+
  have [simp]:
    "N' ! i = N i" for i
    unfolding N_def unfolding prems(1) by simp
  have "prod_ta \<turnstile> (L, s) \<longrightarrow>\<^bsup>g1 @ g2,Bin a',r1 @ r2\<^esup> (L', s')"
  proof -
    from prems \<open>L \<in> states\<close> \<open>bounded bounds s\<close> have
      "((L, s),g1 @ g2,Bin a',r1 @ r2,(L', s')) \<in> trans_bin"
      unfolding trans_bin_def
      using [[simproc add: ex_reorder4]]
      by simp (rule exI conjI HOL.refl | assumption | fast)+
    then show ?thesis
      unfolding prod_ta_def trans_of_def trans_prod_def by simp
  qed
  moreover have "u \<turnstile> g1 @ g2"
    using \<open>u \<turnstile> g1\<close> \<open>u \<turnstile> g2\<close> by (rule guard_append)
  moreover have "u' \<turnstile> inv_of prod_ta (L', s')"
    using prems by auto
  moreover have "u' = [r1@r2\<rightarrow>0]u"
    by (rule prems)
  ultimately show ?thesis
    unfolding \<open>a = _\<close> ..
next
  case prems[unfolded TAG_def]: (step_broad a' broadcast' l b g f r l' N' p ps bs gs fs rs ls' s'' B)
  have [simp]:
    "B = bounds" "broadcast' = broadcast" "length N' = n_ps"
    unfolding bounds_def broadcast_def n_ps_def unfolding prems(1) by simp+
  have [simp]:
    "N' ! i = N i" for i
    unfolding N_def unfolding prems(1) by simp
  let ?r = "r @ concat (map rs ps)" and ?g = "g @ concat (map gs ps)"
  have "prod_ta \<turnstile> (L, s) \<longrightarrow>\<^bsup>?g,Broad a',?r\<^esup> (L', s')"
  proof -
    have *: "\<not> u \<turnstile> g \<longleftrightarrow> False" if
      "p < n_ps" "(l, b, g, In a', f, r, l') \<in> Simple_Network_Language.trans (N p)"
      "a' \<in> broadcast"
      for l b g a' f r l' p
    proof -
      from that broadcast_receivers_unguarded have \<open>g = []\<close>
        by blast
      then show ?thesis
        by auto
    qed
    from prems \<open>L \<in> states\<close> \<open>bounded bounds s\<close> have "((L, s),?g,Broad a',?r,(L', s')) \<in> trans_broad"
      unfolding trans_broad_def
      by clarsimp
         (intro exI conjI HOL.refl; (rule HOL.refl | assumption | fastforce simp: *))
   then show ?thesis
      unfolding prod_ta_def trans_of_def trans_prod_def by simp
  qed
  moreover have "u \<turnstile> ?g"
    using prems by (auto intro!: guard_append guard_concat)
  moreover have "u' \<turnstile> inv_of prod_ta (L', s')"
    using prems by auto
  moreover have "u' = [?r\<rightarrow>0]u"
    by (rule prems)
  ultimately show ?thesis
    unfolding \<open>a = _\<close> ..
qed

lemma delay_complete:
  assumes "A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>Del\<^esub> \<langle>L', s', u'\<rangle>"
  obtains d where "prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow>\<^bsup>d\<^esup> \<langle>(L', s'), u'\<rangle>"
  using assms
proof cases
  case prems: (step_t N' d B broadcast)
  have [simp]:
    "length N' = n_ps"
    unfolding n_ps_def unfolding prems(1) by simp+
  have [simp]:
    "N' ! i = N i" for i
    unfolding N_def unfolding prems(1) by simp
  from prems show ?thesis
  by (intro that[of d]; unfold \<open>u' = _\<close> \<open>L' = L\<close> \<open>s' = s\<close> TAG_def)
     (rule step_t.intros; (unfold inv_of_prod; rule prod_invI)?; simp)
qed

lemma step_iff:
  "(\<exists> a. A \<turnstile> \<langle>L, s, u\<rangle> \<rightarrow>\<^bsub>a\<^esub> \<langle>L', s', u'\<rangle>) \<longleftrightarrow> prod_ta \<turnstile> \<langle>(L, s), u\<rangle> \<rightarrow> \<langle>(L', s'), u'\<rangle>"
  if "bounded bounds s" "L \<in> states" "\<forall>N \<in> set (fst (snd A)). urgent N = {}"
  using that(1,2)
  apply (auto intro: action_sound delay_sound[OF _ _ _ that(3)])
  subgoal for a
    by (cases a; blast dest: action_complete elim: delay_complete)
  done

end (* Prod TA *)

end (* Theory *)


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory PleSle
imports
  "BilbyFsConsts.BilbyFs_Shallow_Desugar_Tuples"
  "../adt/WordArrayT"
  "../adt/ArrayT"
  "../adt/BufferT"
  "HOL-Eisbach.Eisbach"
begin

text{* axioms and lemmas that are *not* specific to 32 word. -> should be refactored.*}
axiomatization
where
 u32_to_u8_is_ucast:
  "u32_to_u8 = ucast"
and
 u64_to_u8_is_ucast:
  "u64_to_u8 = ucast"
and
 u64_to_u32_is_ucast:
  "u64_to_u32 = ucast"
and
 u16_to_u8_is_ucast:
  "u16_to_u8 = ucast"

lemmas less_to_le = order_class.order.strict_implies_order

lemma test_bit_out_of_bounds:
  "\<lbrakk>n \<ge> 8\<rbrakk> \<Longrightarrow> ((w :: 8 word) !! n) = False"
  by (auto dest!: test_bit_size simp:word_size)

lemma mod_range_eq:
  "\<lbrakk>n \<ge> (a::nat)*8; (n::nat) < (a+1)*8\<rbrakk> \<Longrightarrow> n mod 8 = n - (a*8)"
  by (simp add: div_nat_eqI modulo_nat_def mult.commute)

lemma range_le:
  "\<lbrakk>(n :: nat) \<ge> (a::nat)*8; n < (a+1)*8\<rbrakk> \<Longrightarrow>
      n - (a*8) < 8"
  by simp

lemma div_range_le:
  "\<lbrakk>n < (a*8)\<rbrakk> \<Longrightarrow> (n :: nat) div 8 < a"
  by auto

lemma take_decomp:
  "length l \<ge> n \<Longrightarrow> n > 0 \<Longrightarrow> (take n l) = ((hd l) # (take (n - 1) (tl l)))"
  by (induct l) (simp add: take_Cons split: nat.split)+

lemma take_drop_decomp:
  "k < length l \<Longrightarrow> length (drop k l) \<ge> n \<Longrightarrow> n > 0
    \<Longrightarrow> take n (drop k l) = (l ! k) # take (n - 1) (drop (k + 1) l)"
  by (simp add: take_decomp hd_drop_conv_nth drop_Suc[symmetric] drop_tl[symmetric])

lemma elem_take_n:
 "i<n \<Longrightarrow> (take n xs ! i) = xs ! i"
 by simp

lemma take_n_eq_simp:
 "take len ys = take len xs \<Longrightarrow>
  idx < len \<Longrightarrow>
    ys !idx = xs !idx"
by (metis elem_take_n)

 lemma take_n_and_len'_eq_simp:
 "take len ys = take len xs \<Longrightarrow>
  idx < len' \<Longrightarrow>
  len' \<le> len \<Longrightarrow>
    ys !idx = xs !idx"
by (erule take_n_eq_simp) simp

lemma drop_n_then_nth_eq:
 assumes "n + i \<le> length xs"
 assumes "n + i \<le> length ys"
 assumes "ys ! (n + i) = xs ! (n + i)"
 shows "drop n ys ! (0 + i) = drop n xs ! (0 + i)"
 using assms by auto

 lemma drop_n_then_nth_eq_wo_0:
 assumes "n + i \<le> length xs"
 assumes "n + i \<le> length ys"
 assumes "ys ! (n + i) = xs ! (n + i)"
 shows "drop n ys ! i = drop n xs ! i"
 using assms by auto

lemma plus_no_overflow_unat_lift:
  "(a::'a::len word )  < a + b \<Longrightarrow>  unat (a+b) = unat a + unat b"
  by unat_arith

method handle_wa_mod for offs :: "U32" =
(rule wordarray_modify_ret[where index=offs, simplified Let_def],
  simp_all add: wordarray_make ArrA.defs ElemAO.defs  ElemA.defs
   setu8_def[unfolded tuple_simps sanitizers], unat_arith)

lemma take_list_update:
  "i < length xs
    \<Longrightarrow> take n (xs[i := x]) = (if i < n then (take n xs)[i := x] else take n xs)"
  by (induct xs arbitrary: n i, simp_all add: take_Cons split: nat.split)

lemma drop_list_update:
  "i < length xs
    \<Longrightarrow> drop n (xs[i := x]) = (if i < n then drop n xs else (drop n xs)[i - n := x])"
  by (induct xs arbitrary: n i, simp_all add: drop_Cons split: nat.split)

definition ple16 :: "8 word list \<Rightarrow> 32 word \<Rightarrow> 16 word"
where
  "ple16 data offs \<equiv> word_rcat (rev (take 2 (drop (unat offs) data)))"

definition sle16 :: "U16 \<Rightarrow> U8 list"
where
  "sle16 \<equiv> rev \<circ> word_rsplit"

lemma deserialise_le16_ret:
assumes valid_offs:
  "unat offs + 1 < length (\<alpha>wa $ data\<^sub>f buf)"
assumes no_ovf:
  "offs < offs + 2"
shows
  "deserialise_le16 (buf, offs) = (ple16 (\<alpha>wa $ data\<^sub>f buf) offs)"
using valid_offs
  apply (subgoal_tac "(\<forall>i\<in>{0..1}. unat (offs+i) < length (\<alpha>wa (data\<^sub>f buf)))")
   prefer 2
   apply unat_arith
  apply (clarsimp simp: wordarray_get_ret[where arr="data\<^sub>f buf"] ple16_def
                        deserialise_le16_def)
  apply (subgoal_tac "(unat (offs + 1) > 0)")
   prefer 2
   apply (drule_tac x=1 in bspec, simp)
   using no_ovf apply unat_arith
   apply auto[1]
  apply (subst take_drop_decomp, (simp+))+
  apply (subst unatSuc[symmetric], (simp add: unat_gt_0[symmetric] add.commute[where b=offs]))+
  apply (rule trans, rule word_rcat_rsplit[symmetric])
  apply (rule arg_cong[where f=word_rcat])
  apply (subst word_rsplit_upt[where n=2], simp add: word_size)
   apply simp
  apply (simp add: upt_rec shiftr_over_or_dist shiftl_shiftr1 shiftl_shiftr2 word_size)
  apply (safe intro!: word_eqI, simp_all add: word_size word_ops_nth_size nth_ucast
        nth_shiftr nth_shiftl add.commute[where b=offs] test_bit_out_of_bounds)
  done

lemma serial_le16_helper:
 "unat offs + 2 < length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
   [u16_to_u8 v, u16_to_u8 (v >> 8)]
 = sle16 v"
  apply (clarsimp simp: u16_to_u8_is_ucast sle16_def)
  apply (subst word_rsplit_upt[where n=2])
    apply ((simp add: word_size upt_rec)+)[2]
   apply (simp add: upt_rec)
  done

lemma serialise_le16_ret:
  assumes no_overflow: "offs < offs + 2"
  and valid_offs:
   "unat offs + 2 < length (\<alpha>wa (data\<^sub>f buf))"
shows
  "(serialise_le16 (buf, offs, v)) =
   buf \<lparr>data\<^sub>f:=WordArrayT.make (buf_sub_slice buf offs (offs+2) (sle16 v))\<rparr>"
proof -
  have unat_plus:
    "\<And>n. n \<le> 2 \<longrightarrow> unat (offs + n) = unat offs + unat n"
    using no_overflow valid_offs
    by clarsimp unat_arith
  show ?thesis
  using valid_offs
  apply (simp add: serialise_le16_def[unfolded sanitizers] serialise_u8_def[unfolded sanitizers] Let_def)
  apply (handle_wa_mod "offs")
  apply (handle_wa_mod "offs+1")
    apply (simp add: serial_le16_helper[OF valid_offs, where v=v,symmetric])
  apply (rule arg_cong[where f="\<lambda>v. Buffer.data\<^sub>f_update v buf"])
  apply (rule ext)
  apply (rule arg_cong[where f="WordArrayT.make"])

  apply (simp add: buf_sub_slice_def)
  apply (rule trans, rule_tac n="unat offs" in append_take_drop_id[symmetric],
    rule arg_cong2[where f=append])
   apply (simp add: unat_plus order_le_less_trans[OF _ valid_offs] take_list_update)
  apply (simp add: unat_plus)
    apply (cut_tac valid_offs, simp)
   apply (simp add: max_absorb1)
   apply clarsimp
   apply (simp add: list_eq_iff_nth_eq)
   apply (rule conjI)
    using valid_offs
    apply (simp add: nth_Cons split: nat.split)
  using valid_offs
  apply (clarsimp simp only:)
  apply (subst nth_list_update, unat_arith) +
  apply clarsimp
  apply (rule arg_cong[where f="nth (\<alpha>wa (data\<^sub>f buf))"])
   apply simp
 done
qed

lemma ple16_take:
 assumes offs:"offs < offs+2"
 assumes ntake:"unat (offs + 2) \<le> ntake"
 shows   "ple16 (take ntake ys) offs = ple16 ys offs"
 apply (simp add: ple16_def)
 apply (rule arg_cong[where f="word_rcat"])
 apply (rule arg_cong[where f="rev"])
  apply (subst list_eq_iff_nth_eq)
  using offs ntake less_to_le[OF offs, simplified unat_plus_simple]
  apply fastforce
 done

lemma ple16_append:
  assumes no_overflow: "offs < offs + 2"
  assumes len_ys: "unat (offs + 2) \<le> length ys"
  shows   "ple16 (ys@zs) offs = ple16 ys offs"
  using plus_no_overflow_unat_lift[OF no_overflow]  len_ys
  by (simp add: ple16_def)

lemma ple16_append_Cons:
  assumes no_overflow: "offs < offs + 2"
  assumes len_ys: "unat (offs + 2) \<le> length (v#ys)"
  shows   "ple16 (v#ys@zs) offs = ple16 (v#ys) offs"
proof -
  have unat_nth_simp_Cons: "\<And> n xs ys .
    unat n < Suc (length xs) \<Longrightarrow> (v#xs@ys)!(unat n) = (v#xs)!(unat n)"
  by (case_tac "0 < unat n") (fastforce simp: nth_append) +
  show ?thesis
  apply(subgoal_tac "unat offs < Suc (length ys)")
   apply(rule ple16_append[where ys = "v#ys" and zs = "zs" and offs="offs",
       simplified List.append.append_Cons])
    using no_overflow apply clarsimp
   using len_ys apply clarsimp
  using assms by unat_arith
qed

definition ple64 :: "8 word list \<Rightarrow> 32 word \<Rightarrow> 64 word"
where
  "ple64 data offs \<equiv> word_rcat (rev (take 8 (drop (unat offs) data)))"

definition ple32 :: "8 word list \<Rightarrow> 32 word \<Rightarrow> 32 word"
where
  "ple32 data offs \<equiv> word_rcat (rev (take 4 (drop (unat offs) data)))"

definition sle32 :: "U32 \<Rightarrow> U8 list"
where
  "sle32 \<equiv> rev \<circ> word_rsplit"

lemma deserialise_le32_ret:
assumes valid_offs:
  "unat offs + 3 < length (\<alpha>wa $ data\<^sub>f buf)"
assumes no_ovf:
  "offs < offs + 3"
shows
  "deserialise_le32 (buf, offs) = (ple32 (\<alpha>wa $ data\<^sub>f buf) offs)"
using valid_offs
  apply (subgoal_tac "(\<forall>i\<in>{0..3}. unat (offs+i) < length (\<alpha>wa (data\<^sub>f buf)))")
   prefer 2
   apply unat_arith
  apply (clarsimp simp: wordarray_get_ret[where arr="data\<^sub>f buf"] ple32_def
                        deserialise_le32_def)
  apply (subgoal_tac "\<forall>j\<in>{1..3}. (unat (offs + j) > 0)")
   prefer 2
   apply clarsimp
   apply (drule_tac x=j in bspec, simp)
   using no_ovf apply unat_arith
   apply auto[1]
  apply (subst take_drop_decomp, (simp+))+
  apply (subst unatSuc[symmetric], (simp add: unat_gt_0[symmetric] add.commute[where b=offs]))+
  apply simp
  apply (rule trans, rule word_rcat_rsplit[symmetric])
  apply (rule arg_cong[where f=word_rcat])
  apply (subst word_rsplit_upt[where n=4], simp add: word_size)
   apply simp
  apply (simp add: upt_rec shiftr_over_or_dist shiftl_shiftr1 shiftl_shiftr2 word_size)
  apply (safe intro!: word_eqI, simp_all add: word_size word_ops_nth_size nth_ucast
        nth_shiftr nth_shiftl add.commute[where b=offs] test_bit_out_of_bounds)
  done

lemma serial_le32_helper:
 "unat offs + 4 < length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
   [u32_to_u8 v, u32_to_u8 (v >> 8), u32_to_u8 (v >> 16), u32_to_u8 (v >> 24)]
 = sle32 v"
  apply (clarsimp simp: u32_to_u8_is_ucast sle32_def)
  apply (subst word_rsplit_upt[where n=4])
    apply ((simp add: word_size upt_rec)+)[2]
   apply (simp add: upt_rec)
  done

lemma serialise_le32_ret:
  assumes no_overflow: "offs < offs + 4"
  and valid_offs:
   "unat offs + 4 < length (\<alpha>wa (data\<^sub>f buf))"
  notes  wa_modify_ret = wordarray_modify_ret[rotated - 1, simplified Let_def]
shows
  "(serialise_le32 (buf, offs, v)) =
  buf\<lparr>data\<^sub>f:=WordArrayT.make (buf_sub_slice buf offs (offs+4) (sle32 v))\<rparr>"
proof -
  have unat_plus:
    "\<And>n. n \<le> 4 \<longrightarrow> unat (offs + n) = unat offs + unat n"
    using no_overflow valid_offs
    by unat_arith auto
  show ?thesis
  using valid_offs
  apply (simp add: serialise_le32_def[unfolded sanitizers] serialise_u8_def[unfolded sanitizers] Let_def)
  apply (handle_wa_mod "offs")
  apply (handle_wa_mod "offs+1")
  apply (handle_wa_mod "offs+2")
  apply (handle_wa_mod "offs+3")
  apply (simp add: serial_le32_helper[OF valid_offs, where v=v,symmetric])
  apply (rule arg_cong[where f="\<lambda>v. Buffer.data\<^sub>f_update v buf"])
  apply (rule ext)
  apply (rule arg_cong[where f="WordArrayT.make"])

  apply (simp add: buf_sub_slice_def)
  apply (rule trans, rule_tac n="unat offs" in append_take_drop_id[symmetric],
    rule arg_cong2[where f=append])
   apply (simp add: unat_plus order_le_less_trans[OF _ valid_offs] take_list_update)
  apply (simp add: unat_plus)
    apply (cut_tac valid_offs, simp)
   apply (simp add: max_absorb1)
   apply (simp add: list_eq_iff_nth_eq)
   apply (rule conjI)
    using valid_offs
    apply (simp add: nth_Cons split: nat.split)
  using valid_offs
  apply (clarsimp simp only:)
  apply (subst nth_list_update, unat_arith) +
  apply force
 done
qed

lemma ple32_take:
 assumes offs:"offs < offs+4"
 assumes ntake:"unat (offs + 4) \<le> ntake"
 shows   "ple32 (take ntake ys) offs = ple32 ys offs"
  apply (simp add: ple32_def)
  apply (rule arg_cong[where f="word_rcat"])
  apply (rule arg_cong[where f="rev"])
  apply (subst list_eq_iff_nth_eq)
  using offs ntake less_to_le[OF offs, simplified unat_plus_simple]
  apply fastforce
 done

lemma plus4_offs_ntake:
  fixes offs ::U32
  assumes "unat (offs + 4) \<le> ntake"
  assumes offs_overflow: " (offs) <  ((offs+4))"
  assumes "n \<in> {0,1,2,3}"
  shows "unat (offs+n) < ntake"
  using assms apply (clarsimp)
  apply (erule disjE, unat_arith, fastforce?)+
  apply simp
  apply unat_arith
 done

lemma ple32_append:
  assumes no_overflow: "offs < offs+4"
  assumes len_ys: "unat (offs + 4) \<le> length ys"
  shows   "ple32 (ys@zs) offs = ple32 ys offs"
  using plus_no_overflow_unat_lift[OF no_overflow]  len_ys
  by (simp add: ple32_def)

lemma ple32_append_Cons:
  assumes no_overflow: "offs < offs+4"
  assumes len_ys: "unat (offs + 4) \<le> length (v#ys)"
  shows   "ple32 (v#ys@zs) offs = ple32 (v#ys) offs"
proof -
  have unat_nth_simp_Cons: "\<And> n xs ys .
    unat n < Suc (length xs) \<Longrightarrow> (v#xs@ys)!(unat n) = (v#xs)!(unat n)"
  by (case_tac "0 < unat n") (fastforce simp: nth_append) +
  show ?thesis
  apply(subgoal_tac "unat offs < Suc (length ys)")
   apply(rule ple32_append[where ys = "v#ys" and zs = "zs" and offs="offs", simplified List.append.append_Cons])
    using no_overflow apply clarsimp
   using len_ys apply clarsimp
  using assms by unat_arith
qed

definition sle64 :: "U64 \<Rightarrow> U8 list"
where
  "sle64 \<equiv> rev \<circ> word_rsplit"

lemma deserialise_le64_ret:
assumes valid_offs:
  "unat offs + 8 \<le> length (\<alpha>wa $ data\<^sub>f buf)"
assumes no_ovf:
  "offs \<le> offs + 8"
shows
  "deserialise_le64 (buf, offs) = (ple64 (\<alpha>wa $ data\<^sub>f buf) offs)"
using valid_offs
  apply (subgoal_tac "(\<forall>i\<in>{0..7}. unat (offs+i) < length (\<alpha>wa (data\<^sub>f buf)))")
   prefer 2
   apply unat_arith
  apply (clarsimp simp: wordarray_get_ret[where arr="data\<^sub>f buf"] ple64_def
                        deserialise_le64_def)
  apply (subgoal_tac "\<forall>j\<in>{1..7}. (unat (offs + j) > 0)")
   prefer 2
   apply clarsimp
   apply (drule_tac x=j in bspec, simp)
   using no_ovf apply unat_arith
   apply auto[1]
  apply (subst take_drop_decomp, (simp+))+
  apply (subst unatSuc[symmetric], (simp add: unat_gt_0[symmetric] add.commute[where b=offs])[1])+
  apply simp
  apply (rule trans, rule word_rcat_rsplit[symmetric])
  apply (rule arg_cong[where f=word_rcat])
  apply (subst word_rsplit_upt[where n=8], simp add: word_size)
   apply simp
  apply (simp add: upt_rec shiftr_over_or_dist shiftl_shiftr1 shiftl_shiftr2 word_size)
  apply (safe intro!: word_eqI, simp_all add: word_size word_ops_nth_size nth_ucast
        nth_shiftr nth_shiftl add.commute[where b=offs] test_bit_out_of_bounds)
  done

lemma serial_le64_helper:
 "unat offs + 8 < length (\<alpha>wa (data\<^sub>f buf)) \<Longrightarrow>
   [u64_to_u8 v, u64_to_u8 (v >> 8), u64_to_u8 (v >> 16), u64_to_u8 (v >> 24),
    u64_to_u8 (v >> 32),  u64_to_u8 (v >> 40), u64_to_u8 (v >> 48), u64_to_u8 (v >> 56)]
 = sle64 v"
  apply (clarsimp simp: u64_to_u8_is_ucast sle64_def)
  apply (subst word_rsplit_upt[where n=8])
    apply ((simp add: word_size upt_rec)+)[2]
   apply (simp add: upt_rec)
  done

lemma serialise_le64_ret:
  assumes no_overflow: "offs < offs + 8"
  and valid_offs:
   "unat offs + 8 < length (\<alpha>wa (data\<^sub>f buf))"
shows
  "(serialise_le64 (buf, offs, v)) =
  buf\<lparr>data\<^sub>f:=WordArrayT.make (buf_sub_slice buf offs (offs+8) (sle64 v))\<rparr>"
proof -
  have unat_plus:
    "\<And>n. n \<le> 8 \<longrightarrow> unat (offs + n) = unat offs + unat n"
    using no_overflow valid_offs
    by unat_arith auto
  show ?thesis

  apply (simp add: serialise_le64_def[unfolded sanitizers] serialise_u8_def[unfolded sanitizers] Let_def)
  using valid_offs apply -
  apply (handle_wa_mod "offs")
  apply (handle_wa_mod "offs+1")
  apply (handle_wa_mod "offs+2")
  apply (handle_wa_mod "offs+3")
  apply (handle_wa_mod "offs+4")
  apply (handle_wa_mod "offs+5")
  apply (handle_wa_mod "offs+6")
  apply (handle_wa_mod "offs+7")
          apply (simp add: serial_le64_helper[OF valid_offs, where v=v,symmetric])

  apply (rule arg_cong[where f="\<lambda>v. Buffer.data\<^sub>f_update v buf"])
  apply (rule ext)
  apply (rule arg_cong[where f="WordArrayT.make"])

  apply (simp add: buf_sub_slice_def)
  apply (rule trans, rule_tac n="unat offs" in append_take_drop_id[symmetric],
    rule arg_cong2[where f=append])
   apply (simp add: unat_plus order_le_less_trans[OF _ valid_offs] take_list_update)
  apply (simp add: unat_plus)
    apply (cut_tac valid_offs, simp)
   apply (simp add: max_absorb1)
   apply (simp add: list_eq_iff_nth_eq)
   apply (rule conjI)
    using valid_offs
    apply (simp add: nth_Cons split: nat.split)
  using valid_offs
  apply (clarsimp simp only:)
  apply (subst nth_list_update, unat_arith) +
  apply force
 done
qed

lemma ple64_take:
 assumes offs:"offs < offs+8"
 assumes ntake:"unat (offs + 8) \<le> ntake"
 shows   "ple64 (take ntake ys) offs = ple64 ys offs"
  apply (simp add: ple64_def)
  apply (rule arg_cong[where f="word_rcat"])
  apply (rule arg_cong[where f="rev"])
  apply (subst list_eq_iff_nth_eq)
  using offs ntake less_to_le[OF offs, simplified unat_plus_simple]
  apply fastforce
 done

lemma ple64_append:
  assumes no_overflow: "offs < offs + 8"
  assumes len_ys: "unat (offs + 8) \<le> length ys"
  shows   "ple64 (ys@zs) offs = ple64 ys offs"
  using plus_no_overflow_unat_lift[OF no_overflow]  len_ys
  by (simp add: ple64_def)

lemma ple64_append_Cons:
  assumes no_overflow: "offs < offs + 8"
  assumes len_ys: "unat (offs + 8) \<le> length (v#ys)"
  shows   "ple64 (v#ys@zs) offs = ple64 (v#ys) offs"
proof -
  have unat_nth_simp_Cons: "\<And> n xs ys .
    unat n < Suc (length xs) \<Longrightarrow> (v#xs@ys)!(unat n) = (v#xs)!(unat n)"
  by (case_tac "0 < unat n") (fastforce simp: nth_append) +
  show ?thesis
  apply(subgoal_tac "unat offs < Suc (length ys)")
   apply(rule ple64_append[where ys = "v#ys" and zs = "zs" and offs="offs", simplified List.append.append_Cons])
    using no_overflow apply clarsimp
   using len_ys apply clarsimp
  using assms by unat_arith
qed

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>LTL Translation Layer\<close>

theory LTL_Compat
  imports Main LTL.LTL "../LTL_FGXU"
begin

\<comment> \<open>The following infrastructure translates the generic @{datatype ltln} datatype to special structure used in this project\<close>

abbreviation LTLRelease :: "'a ltl \<Rightarrow> 'a ltl \<Rightarrow> 'a ltl" ("_ R _" [87,87] 86)
where
  "\<phi> R \<psi> \<equiv> (G \<psi>) or (\<psi> U (\<phi> and \<psi>))"

abbreviation LTLWeakUntil :: "'a ltl \<Rightarrow> 'a ltl \<Rightarrow> 'a ltl" ("_ W _" [87,87] 86)
where
  "\<phi> W \<psi> \<equiv> (\<phi> U \<psi>) or (G \<phi>)"

abbreviation LTLStrongRelease :: "'a ltl \<Rightarrow> 'a ltl \<Rightarrow> 'a ltl" ("_ M _" [87,87] 86)
where
  "\<phi> M \<psi> \<equiv> \<psi> U (\<phi> and \<psi>)"

fun ltln_to_ltl :: "'a ltln \<Rightarrow> 'a ltl"
where
  "ltln_to_ltl true\<^sub>n = true"
| "ltln_to_ltl false\<^sub>n = false"
| "ltln_to_ltl prop\<^sub>n(q) = p(q)"
| "ltln_to_ltl nprop\<^sub>n(q) = np(q)"
| "ltln_to_ltl (\<phi> and\<^sub>n \<psi>) = ltln_to_ltl \<phi> and ltln_to_ltl \<psi>"
| "ltln_to_ltl (\<phi> or\<^sub>n \<psi>) = ltln_to_ltl \<phi> or ltln_to_ltl \<psi>"
| "ltln_to_ltl (\<phi> U\<^sub>n \<psi>) = (if \<phi> = true\<^sub>n then F (ltln_to_ltl \<psi>) else (ltln_to_ltl \<phi>) U (ltln_to_ltl \<psi>))"
| "ltln_to_ltl (\<phi> R\<^sub>n \<psi>) = (if \<phi> = false\<^sub>n then G (ltln_to_ltl \<psi>) else (ltln_to_ltl \<phi>) R (ltln_to_ltl \<psi>))"
| "ltln_to_ltl (\<phi> W\<^sub>n \<psi>) = (if \<psi> = false\<^sub>n then G (ltln_to_ltl \<phi>) else (ltln_to_ltl \<phi>) W (ltln_to_ltl \<psi>))"
| "ltln_to_ltl (\<phi> M\<^sub>n \<psi>) = (if \<psi> = true\<^sub>n then F (ltln_to_ltl \<phi>) else (ltln_to_ltl \<phi>) M (ltln_to_ltl \<psi>))"
| "ltln_to_ltl (X\<^sub>n \<phi>) = X (ltln_to_ltl \<phi>)"

lemma ltln_to_ltl_semantics:
  "w \<Turnstile> ltln_to_ltl \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  by (induction \<phi> arbitrary: w)
     (simp_all del: semantics_ltln.simps(9-11), unfold ltln_Release_alterdef ltln_weak_strong(1) ltl_StrongRelease_Until_con, insert nat_less_le, auto)

lemma ltln_to_ltl_atoms:
  "vars (ltln_to_ltl \<phi>) = atoms_ltln \<phi>"
  by (induction \<phi>) auto

fun atoms_list :: "'a ltln \<Rightarrow>'a list"
where
  "atoms_list (\<phi> and\<^sub>n \<psi>) = List.union (atoms_list \<phi>) (atoms_list \<psi>)"
| "atoms_list (\<phi> or\<^sub>n \<psi>) = List.union (atoms_list \<phi>) (atoms_list \<psi>)"
| "atoms_list (\<phi> U\<^sub>n \<psi>) = List.union (atoms_list \<phi>) (atoms_list \<psi>)"
| "atoms_list (\<phi> R\<^sub>n \<psi>) = List.union (atoms_list \<phi>) (atoms_list \<psi>)"
| "atoms_list (\<phi> W\<^sub>n \<psi>) = List.union (atoms_list \<phi>) (atoms_list \<psi>)"
| "atoms_list (\<phi> M\<^sub>n \<psi>) = List.union (atoms_list \<phi>) (atoms_list \<psi>)"
| "atoms_list (X\<^sub>n \<phi>) = atoms_list \<phi>"
| "atoms_list (prop\<^sub>n(a)) = [a]"
| "atoms_list (nprop\<^sub>n(a)) = [a]"
| "atoms_list _ = []"

lemma atoms_list_correct:
  "set (atoms_list \<phi>) = atoms_ltln \<phi>"
  by (induction \<phi>) auto

lemma atoms_list_distinct:
  "distinct (atoms_list \<phi>)"
  by (induction \<phi>) auto

end


(*  Title:      HOL/Auth/ZhouGollmann.thy
    Author:     Giampaolo Bella and L C Paulson, Cambridge Univ Computer Lab
    Copyright   2003  University of Cambridge

The protocol of
  Jianying Zhou and Dieter Gollmann,
  A Fair Non-Repudiation Protocol,
  Security and Privacy 1996 (Oakland)
  55-61
*)

theory ZhouGollmann imports Public begin

abbreviation
  TTP :: agent where "TTP == Server"

abbreviation f_sub :: nat where "f_sub == 5"
abbreviation f_nro :: nat where "f_nro == 2"
abbreviation f_nrr :: nat where "f_nrr == 3"
abbreviation f_con :: nat where "f_con == 4"

definition broken :: "agent set" where
    --{*the compromised honest agents; TTP is included as it's not allowed to
        use the protocol*}
   "broken == bad - {Spy}"

declare broken_def [simp]

inductive_set zg :: "event list set"
  where

  Nil:  "[] \<in> zg"

| Fake: "[| evsf \<in> zg;  X \<in> synth (analz (spies evsf)) |]
         ==> Says Spy B X  # evsf \<in> zg"

| Reception:  "[| evsr \<in> zg; Says A B X \<in> set evsr |] ==> Gets B X # evsr \<in> zg"

  (*L is fresh for honest agents.
    We don't require K to be fresh because we don't bother to prove secrecy!
    We just assume that the protocol's objective is to deliver K fairly,
    rather than to keep M secret.*)
| ZG1: "[| evs1 \<in> zg;  Nonce L \<notin> used evs1; C = Crypt K (Number m);
           K \<in> symKeys;
           NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, C|}|]
       ==> Says A B {|Number f_nro, Agent B, Nonce L, C, NRO|} # evs1 \<in> zg"

  (*B must check that NRO is A's signature to learn the sender's name*)
| ZG2: "[| evs2 \<in> zg;
           Gets B {|Number f_nro, Agent B, Nonce L, C, NRO|} \<in> set evs2;
           NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, C|};
           NRR = Crypt (priK B) {|Number f_nrr, Agent A, Nonce L, C|}|]
       ==> Says B A {|Number f_nrr, Agent A, Nonce L, NRR|} # evs2  \<in>  zg"

  (*A must check that NRR is B's signature to learn the sender's name;
    without spy, the matching label would be enough*)
| ZG3: "[| evs3 \<in> zg; C = Crypt K M; K \<in> symKeys;
           Says A B {|Number f_nro, Agent B, Nonce L, C, NRO|} \<in> set evs3;
           Gets A {|Number f_nrr, Agent A, Nonce L, NRR|} \<in> set evs3;
           NRR = Crypt (priK B) {|Number f_nrr, Agent A, Nonce L, C|};
           sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|}|]
       ==> Says A TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|}
             # evs3 \<in> zg"

 (*TTP checks that sub_K is A's signature to learn who issued K, then
   gives credentials to A and B.  The Notes event models the availability of
   the credentials, but the act of fetching them is not modelled.  We also
   give con_K to the Spy. This makes the threat model more dangerous, while
   also allowing lemma @{text Crypt_used_imp_spies} to omit the condition
   @{term "K \<noteq> priK TTP"}. *)
| ZG4: "[| evs4 \<in> zg; K \<in> symKeys;
           Gets TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|}
             \<in> set evs4;
           sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|};
           con_K = Crypt (priK TTP) {|Number f_con, Agent A, Agent B,
                                      Nonce L, Key K|}|]
       ==> Says TTP Spy con_K
           #
           Notes TTP {|Number f_con, Agent A, Agent B, Nonce L, Key K, con_K|}
           # evs4 \<in> zg"

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

declare symKey_neq_priEK [simp]
declare symKey_neq_priEK [THEN not_sym, simp]

text{*A "possibility property": there are traces that reach the end*}
lemma "[|A \<noteq> B; TTP \<noteq> A; TTP \<noteq> B; K \<in> symKeys|] ==>
     \<exists>L. \<exists>evs \<in> zg.
           Notes TTP {|Number f_con, Agent A, Agent B, Nonce L, Key K,
               Crypt (priK TTP) {|Number f_con, Agent A, Agent B, Nonce L, Key K|} |}
               \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] zg.Nil
                    [THEN zg.ZG1, THEN zg.Reception [of _ A B],
                     THEN zg.ZG2, THEN zg.Reception [of _ B A],
                     THEN zg.ZG3, THEN zg.Reception [of _ A TTP],
                     THEN zg.ZG4])
apply (basic_possibility, auto)
done

subsection {*Basic Lemmas*}

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

lemma Gets_imp_knows_Spy:
     "[| Gets B X \<in> set evs; evs \<in> zg |]  ==> X \<in> spies evs"
by (blast dest!: Gets_imp_Says Says_imp_knows_Spy)

text{*Lets us replace proofs about @{term "used evs"} by simpler proofs
about @{term "parts (spies evs)"}.*}
lemma Crypt_used_imp_spies:
     "[| Crypt K X \<in> used evs; evs \<in> zg |]
      ==> Crypt K X \<in> parts (spies evs)"
apply (erule rev_mp)
apply (erule zg.induct)
apply (simp_all add: parts_insert_knows_A)
done

lemma Notes_TTP_imp_Gets:
     "[|Notes TTP {|Number f_con, Agent A, Agent B, Nonce L, Key K, con_K |}
           \<in> set evs;
        sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|};
        evs \<in> zg|]
    ==> Gets TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|} \<in> set evs"
apply (erule rev_mp)
apply (erule zg.induct, auto)
done

text{*For reasoning about C, which is encrypted in message ZG2*}
lemma ZG2_msg_in_parts_spies:
     "[|Gets B {|F, B', L, C, X|} \<in> set evs; evs \<in> zg|]
      ==> C \<in> parts (spies evs)"
by (blast dest: Gets_imp_Says)

(*classical regularity lemma on priK*)
lemma Spy_see_priK [simp]:
     "evs \<in> zg ==> (Key (priK A) \<in> parts (spies evs)) = (A \<in> bad)"
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
done

text{*So that blast can use it too*}
declare  Spy_see_priK [THEN [2] rev_iffD1, dest!]

lemma Spy_analz_priK [simp]:
     "evs \<in> zg ==> (Key (priK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

subsection{*About NRO: Validity for @{term B}*}

text{*Below we prove that if @{term NRO} exists then @{term A} definitely
sent it, provided @{term A} is not broken.*}

text{*Strong conclusion for a good agent*}
lemma NRO_validity_good:
     "[|NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, C|};
        NRO \<in> parts (spies evs);
        A \<notin> bad;  evs \<in> zg |]
     ==> Says A B {|Number f_nro, Agent B, Nonce L, C, NRO|} \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
done

lemma NRO_sender:
     "[|Says A' B {|n, b, l, C, Crypt (priK A) X|} \<in> set evs; evs \<in> zg|]
    ==> A' \<in> {A,Spy}"
apply (erule rev_mp)
apply (erule zg.induct, simp_all)
done

text{*Holds also for @{term "A = Spy"}!*}
theorem NRO_validity:
     "[|Gets B {|Number f_nro, Agent B, Nonce L, C, NRO|} \<in> set evs;
        NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, C|};
        A \<notin> broken;  evs \<in> zg |]
     ==> Says A B {|Number f_nro, Agent B, Nonce L, C, NRO|} \<in> set evs"
apply (drule Gets_imp_Says, assumption)
apply clarify
apply (frule NRO_sender, auto)
txt{*We are left with the case where the sender is @{term Spy} and not
  equal to @{term A}, because @{term "A \<notin> bad"}.
  Thus theorem @{text NRO_validity_good} applies.*}
apply (blast dest: NRO_validity_good [OF refl])
done

subsection{*About NRR: Validity for @{term A}*}

text{*Below we prove that if @{term NRR} exists then @{term B} definitely
sent it, provided @{term B} is not broken.*}

text{*Strong conclusion for a good agent*}
lemma NRR_validity_good:
     "[|NRR = Crypt (priK B) {|Number f_nrr, Agent A, Nonce L, C|};
        NRR \<in> parts (spies evs);
        B \<notin> bad;  evs \<in> zg |]
     ==> Says B A {|Number f_nrr, Agent A, Nonce L, NRR|} \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
done

lemma NRR_sender:
     "[|Says B' A {|n, a, l, Crypt (priK B) X|} \<in> set evs; evs \<in> zg|]
    ==> B' \<in> {B,Spy}"
apply (erule rev_mp)
apply (erule zg.induct, simp_all)
done

text{*Holds also for @{term "B = Spy"}!*}
theorem NRR_validity:
     "[|Says B' A {|Number f_nrr, Agent A, Nonce L, NRR|} \<in> set evs;
        NRR = Crypt (priK B) {|Number f_nrr, Agent A, Nonce L, C|};
        B \<notin> broken; evs \<in> zg|]
    ==> Says B A {|Number f_nrr, Agent A, Nonce L, NRR|} \<in> set evs"
apply clarify
apply (frule NRR_sender, auto)
txt{*We are left with the case where @{term "B' = Spy"} and  @{term "B' \<noteq> B"},
  i.e. @{term "B \<notin> bad"}, when we can apply @{text NRR_validity_good}.*}
 apply (blast dest: NRR_validity_good [OF refl])
done

subsection{*Proofs About @{term sub_K}*}

text{*Below we prove that if @{term sub_K} exists then @{term A} definitely
sent it, provided @{term A} is not broken.  *}

text{*Strong conclusion for a good agent*}
lemma sub_K_validity_good:
     "[|sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|};
        sub_K \<in> parts (spies evs);
        A \<notin> bad;  evs \<in> zg |]
     ==> Says A TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|} \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt{*Fake*}
apply (blast dest!: Fake_parts_sing_imp_Un)
done

lemma sub_K_sender:
     "[|Says A' TTP {|n, b, l, k, Crypt (priK A) X|} \<in> set evs;  evs \<in> zg|]
    ==> A' \<in> {A,Spy}"
apply (erule rev_mp)
apply (erule zg.induct, simp_all)
done

text{*Holds also for @{term "A = Spy"}!*}
theorem sub_K_validity:
     "[|Gets TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|} \<in> set evs;
        sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|};
        A \<notin> broken;  evs \<in> zg |]
     ==> Says A TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|} \<in> set evs"
apply (drule Gets_imp_Says, assumption)
apply clarify
apply (frule sub_K_sender, auto)
txt{*We are left with the case where the sender is @{term Spy} and not
  equal to @{term A}, because @{term "A \<notin> bad"}.
  Thus theorem @{text sub_K_validity_good} applies.*}
apply (blast dest: sub_K_validity_good [OF refl])
done

subsection{*Proofs About @{term con_K}*}

text{*Below we prove that if @{term con_K} exists, then @{term TTP} has it,
and therefore @{term A} and @{term B}) can get it too.  Moreover, we know
that @{term A} sent @{term sub_K}*}

lemma con_K_validity:
     "[|con_K \<in> used evs;
        con_K = Crypt (priK TTP)
                  {|Number f_con, Agent A, Agent B, Nonce L, Key K|};
        evs \<in> zg |]
    ==> Notes TTP {|Number f_con, Agent A, Agent B, Nonce L, Key K, con_K|}
          \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt{*Fake*}
apply (blast dest!: Fake_parts_sing_imp_Un)
txt{*ZG2*}
apply (blast dest: parts_cut)
done

text{*If @{term TTP} holds @{term con_K} then @{term A} sent
 @{term sub_K}.  We assume that @{term A} is not broken.  Importantly, nothing
  needs to be assumed about the form of @{term con_K}!*}
lemma Notes_TTP_imp_Says_A:
     "[|Notes TTP {|Number f_con, Agent A, Agent B, Nonce L, Key K, con_K|}
           \<in> set evs;
        sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|};
        A \<notin> broken; evs \<in> zg|]
     ==> Says A TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|} \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt{*ZG4*}
apply clarify
apply (rule sub_K_validity, auto)
done

text{*If @{term con_K} exists, then @{term A} sent @{term sub_K}.  We again
   assume that @{term A} is not broken. *}
theorem B_sub_K_validity:
     "[|con_K \<in> used evs;
        con_K = Crypt (priK TTP) {|Number f_con, Agent A, Agent B,
                                   Nonce L, Key K|};
        sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|};
        A \<notin> broken; evs \<in> zg|]
     ==> Says A TTP {|Number f_sub, Agent B, Nonce L, Key K, sub_K|} \<in> set evs"
by (blast dest: con_K_validity Notes_TTP_imp_Says_A)

subsection{*Proving fairness*}

text{*Cannot prove that, if @{term B} has NRO, then  @{term A} has her NRR.
It would appear that @{term B} has a small advantage, though it is
useless to win disputes: @{term B} needs to present @{term con_K} as well.*}

text{*Strange: unicity of the label protects @{term A}?*}
lemma A_unicity:
     "[|NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, Crypt K M|};
        NRO \<in> parts (spies evs);
        Says A B {|Number f_nro, Agent B, Nonce L, Crypt K M', NRO'|}
          \<in> set evs;
        A \<notin> bad; evs \<in> zg |]
     ==> M'=M"
apply clarify
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, auto)
txt{*ZG1: freshness*}
apply (blast dest: parts.Body)
done

text{*Fairness lemma: if @{term sub_K} exists, then @{term A} holds
NRR.  Relies on unicity of labels.*}
lemma sub_K_implies_NRR:
     "[| NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, Crypt K M|};
         NRR = Crypt (priK B) {|Number f_nrr, Agent A, Nonce L, Crypt K M|};
         sub_K \<in> parts (spies evs);
         NRO \<in> parts (spies evs);
         sub_K = Crypt (priK A) {|Number f_sub, Agent B, Nonce L, Key K|};
         A \<notin> bad;  evs \<in> zg |]
     ==> Gets A {|Number f_nrr, Agent A, Nonce L, NRR|} \<in> set evs"
apply clarify
apply hypsubst_thin
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt{*Fake*}
apply blast
txt{*ZG1: freshness*}
apply (blast dest: parts.Body)
txt{*ZG3*}
apply (blast dest: A_unicity [OF refl])
done

lemma Crypt_used_imp_L_used:
     "[| Crypt (priK TTP) {|F, A, B, L, K|} \<in> used evs; evs \<in> zg |]
      ==> L \<in> used evs"
apply (erule rev_mp)
apply (erule zg.induct, auto)
txt{*Fake*}
apply (blast dest!: Fake_parts_sing_imp_Un)
txt{*ZG2: freshness*}
apply (blast dest: parts.Body)
done

text{*Fairness for @{term A}: if @{term con_K} and @{term NRO} exist,
then @{term A} holds NRR.  @{term A} must be uncompromised, but there is no
assumption about @{term B}.*}
theorem A_fairness_NRO:
     "[|con_K \<in> used evs;
        NRO \<in> parts (spies evs);
        con_K = Crypt (priK TTP)
                      {|Number f_con, Agent A, Agent B, Nonce L, Key K|};
        NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, Crypt K M|};
        NRR = Crypt (priK B) {|Number f_nrr, Agent A, Nonce L, Crypt K M|};
        A \<notin> bad;  evs \<in> zg |]
    ==> Gets A {|Number f_nrr, Agent A, Nonce L, NRR|} \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
   txt{*Fake*}
   apply (simp add: parts_insert_knows_A)
   apply (blast dest: Fake_parts_sing_imp_Un)
  txt{*ZG1*}
  apply (blast dest: Crypt_used_imp_L_used)
 txt{*ZG2*}
 apply (blast dest: parts_cut)
txt{*ZG4*}
apply (blast intro: sub_K_implies_NRR [OF refl]
             dest: Gets_imp_knows_Spy [THEN parts.Inj])
done

text{*Fairness for @{term B}: NRR exists at all, then @{term B} holds NRO.
@{term B} must be uncompromised, but there is no assumption about @{term
A}. *}
theorem B_fairness_NRR:
     "[|NRR \<in> used evs;
        NRR = Crypt (priK B) {|Number f_nrr, Agent A, Nonce L, C|};
        NRO = Crypt (priK A) {|Number f_nro, Agent B, Nonce L, C|};
        B \<notin> bad; evs \<in> zg |]
    ==> Gets B {|Number f_nro, Agent B, Nonce L, C, NRO|} \<in> set evs"
apply clarify
apply (erule rev_mp)
apply (erule zg.induct)
apply (frule_tac [5] ZG2_msg_in_parts_spies, simp_all)
txt{*Fake*}
apply (blast dest!: Fake_parts_sing_imp_Un)
txt{*ZG2*}
apply (blast dest: parts_cut)
done

text{*If @{term con_K} exists at all, then @{term B} can get it, by @{text
con_K_validity}.  Cannot conclude that also NRO is available to @{term B},
because if @{term A} were unfair, @{term A} could build message 3 without
building message 1, which contains NRO. *}

end