chapter \<open>The Framework\<close>

theory BasicDefs imports AuxLemmas begin

text \<open>
  As slicing is a program analysis that can be completely based on the
  information given in the CFG, we want to provide a framework which
  allows us to formalize and prove properties of slicing regardless of
  the actual programming language. So the starting point for the formalization
  is the definition of an abstract CFG, i.e.\ without considering features
  specific for certain languages. By doing so we ensure that our framework
  is as generic as possible since all proofs hold for every language whose
  CFG conforms to this abstract CFG.

  Static Slicing analyses a CFG prior to execution. Whereas dynamic
  slicing can provide better results for certain inputs (i.e.\ trace and
  initial state), static slicing is more conservative but provides
  results independent of inputs.

  Correctness for static slicing is defined using a weak
  simulation between nodes and states when traversing the original and
  the sliced graph. The weak simulation property demands that if a
  (node,state) tuples $(n_1,s_1)$ simulates $(n_2,s_2)$
  and making an observable move in the original graph leads from
  $(n_1,s_1)$ to $(n_1',s_1')$, this tuple simulates a
  tuple $(n_2,s_2)$ which is the result of making an
  observable move in the sliced graph beginning in $(n_2',s_2')$.
\<close>

section \<open>Basic Definitions\<close>

fun fun_upds :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<Rightarrow> 'b)"
where "fun_upds f [] ys = f"
  | "fun_upds f xs [] = f"
  | "fun_upds f (x#xs) (y#ys) = (fun_upds f xs ys)(x := y)"

notation fun_upds ("_'(_ /[:=]/ _')")

lemma fun_upds_nth:
  "\<lbrakk>i < length xs; length xs = length ys; distinct xs\<rbrakk>
  \<Longrightarrow> f(xs [:=] ys)(xs!i) = (ys!i)"
proof(induct xs arbitrary:ys i)
  case Nil thus ?case by simp
next
  case (Cons x' xs')
  note IH = \<open>\<And>ys i. \<lbrakk>i < length xs'; length xs' = length ys; distinct xs'\<rbrakk>
    \<Longrightarrow> f(xs' [:=] ys) (xs'!i) = ys!i\<close>
  from \<open>distinct (x'#xs')\<close> have "distinct xs'" and "x' \<notin> set xs'" by simp_all
  from \<open>length (x'#xs') = length ys\<close> obtain y' ys' where [simp]:"ys = y'#ys'"
    and "length xs' = length ys'"
    by(cases ys) auto
  show ?case
  proof(cases i)
    case 0 thus ?thesis by simp
  next
    case (Suc j)
    with \<open>i < length (x'#xs')\<close> have "j < length xs'" by simp
    from IH[OF this \<open>length xs' = length ys'\<close> \<open>distinct xs'\<close>]
    have "f(xs' [:=] ys') (xs'!j) = ys'!j" .
    with \<open>x' \<notin> set xs'\<close> \<open>j < length xs'\<close>
    have "f((x'#xs') [:=] ys) ((x'#xs')!(Suc j)) = ys!(Suc j)" by fastforce
    with Suc show ?thesis by simp
  qed
qed

lemma fun_upds_eq:
  assumes "V \<in> set xs" and "length xs = length ys" and "distinct xs"
  shows "f(xs [:=] ys) V = f'(xs [:=] ys) V"
proof -
  from \<open>V \<in> set xs\<close> obtain i where "i < length xs" and "xs!i = V"
    by(fastforce simp:in_set_conv_nth)
  with \<open>length xs = length ys\<close> \<open>distinct xs\<close>
  have "f(xs [:=] ys)(xs!i) = (ys!i)" by -(rule fun_upds_nth)
  moreover
  from \<open>i < length xs\<close> \<open>xs!i = V\<close> \<open>length xs = length ys\<close> \<open>distinct xs\<close>
  have "f'(xs [:=] ys)(xs!i) = (ys!i)" by -(rule fun_upds_nth)
  ultimately show ?thesis using \<open>xs!i = V\<close> by simp
qed

lemma fun_upds_notin:"x \<notin> set xs \<Longrightarrow> f(xs [:=] ys) x = f x"
by(induct xs arbitrary:ys,auto,case_tac ys,auto)

subsection \<open>\<open>distinct_fst\<close>\<close>

definition distinct_fst :: "('a \<times> 'b) list \<Rightarrow> bool" where
  "distinct_fst  \<equiv>  distinct \<circ> map fst"

lemma distinct_fst_Nil [simp]:
  "distinct_fst []"
  by(simp add:distinct_fst_def)

lemma distinct_fst_Cons [simp]:
  "distinct_fst ((k,x)#kxs) = (distinct_fst kxs \<and> (\<forall>y. (k,y) \<notin> set kxs))"
by(auto simp:distinct_fst_def image_def)

lemma distinct_fst_isin_same_fst:
  "\<lbrakk>(x,y) \<in> set xs; (x,y') \<in> set xs; distinct_fst xs\<rbrakk>
  \<Longrightarrow> y = y'"
by(induct xs,auto simp:distinct_fst_def image_def)

subsection\<open>Edge kinds\<close>

text \<open>Every procedure has a unique name, e.g. in object oriented languages
  \<open>pname\<close> refers to class + procedure.\<close>

text \<open>A state is a call stack of tuples, which consists of:
  \begin{enumerate}
  \item data information, i.e.\ a mapping from the local variables in the call
  frame to their values, and
  \item control flow information, e.g.\ which node called the current procedure.
  \end{enumerate}

  Update and predicate edges check and manipulate only the data information
  of the top call stack element. Call and return edges however may use the data and
  control flow information present in the top stack element to state if this edge is
  traversable. The call edge additionally has a list of functions to determine what
  values the parameters have in a certain call frame and control flow information for
  the return. The return edge is concerned with passing the values
  of the return parameter values to the underlying stack frame. See the funtions
  \<open>transfer\<close> and \<open>pred\<close> in locale \<open>CFG\<close>.\<close>

datatype (dead 'var, dead 'val, dead 'ret, dead 'pname) edge_kind =
    UpdateEdge "('var \<rightharpoonup> 'val) \<Rightarrow> ('var \<rightharpoonup> 'val)"                  ("\<Up>_")
  | PredicateEdge "('var \<rightharpoonup> 'val) \<Rightarrow> bool"                         ("'(_')\<^sub>\<surd>")
  | CallEdge "('var \<rightharpoonup> 'val) \<times> 'ret \<Rightarrow> bool" "'ret" "'pname"
             "(('var \<rightharpoonup> 'val) \<rightharpoonup> 'val) list"                       ("_:_\<hookrightarrow>\<^bsub>_\<^esub>_" 70)
  | ReturnEdge "('var \<rightharpoonup> 'val) \<times> 'ret \<Rightarrow> bool" "'pname"
               "('var \<rightharpoonup> 'val) \<Rightarrow> ('var \<rightharpoonup> 'val) \<Rightarrow> ('var \<rightharpoonup> 'val)" ("_\<hookleftarrow>\<^bsub>_\<^esub>_" 70)

definition intra_kind :: "('var,'val,'ret,'pname) edge_kind \<Rightarrow> bool"
where "intra_kind et \<equiv> (\<exists>f. et = \<Up>f) \<or> (\<exists>Q. et = (Q)\<^sub>\<surd>)"

lemma edge_kind_cases [case_names Intra Call Return]:
  "\<lbrakk>intra_kind et \<Longrightarrow> P; \<And>Q r p fs. et = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs \<Longrightarrow> P;
    \<And>Q p f. et = Q\<hookleftarrow>\<^bsub>p\<^esub>f \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by(cases et,auto simp:intra_kind_def)

end


(*
(C) Copyright Andreas Viktor Hess, DTU, 2015-2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Miscellaneous.thy
    Author:     Andreas Viktor Hess, DTU
*)

section \<open>Miscellaneous Lemmata\<close>
theory Miscellaneous
imports Main "HOL-Library.Sublist" "HOL-Library.While_Combinator"
begin

subsection \<open>List: zip, filter, map\<close>
lemma zip_arg_subterm_split:
  assumes "(x,y) \<in> set (zip xs ys)"
  obtains xs' xs'' ys' ys'' where "xs = xs'@x#xs''" "ys = ys'@y#ys''" "length xs' = length ys'"
proof -
  from assms have "\<exists>zs zs' vs vs'. xs = zs@x#zs' \<and> ys = vs@y#vs' \<and> length zs = length vs"
  proof (induction ys arbitrary: xs)
    case (Cons y' ys' xs)
    then obtain x' xs' where x': "xs = x'#xs'"
      by (metis empty_iff list.exhaust list.set(1) set_zip_leftD)
    show ?case
      by (cases "(x, y) \<in> set (zip xs' ys')",
          metis \<open>xs = x'#xs'\<close> Cons.IH[of xs'] Cons_eq_appendI list.size(4),
          use Cons.prems x' in fastforce)
  qed simp
  thus ?thesis using that by blast
qed

lemma zip_arg_index:
  assumes "(x,y) \<in> set (zip xs ys)"
  obtains i where "xs ! i = x" "ys ! i = y" "i < length xs" "i < length ys"
proof -
  obtain xs1 xs2 ys1 ys2 where "xs = xs1@x#xs2" "ys = ys1@y#ys2" "length xs1 = length ys1"
    using zip_arg_subterm_split[OF assms] by moura
  thus ?thesis using nth_append_length[of xs1 x xs2] nth_append_length[of ys1 y ys2] that by simp
qed

lemma filter_nth: "i < length (filter P xs) \<Longrightarrow> P (filter P xs ! i)"
using nth_mem by force

lemma list_all_filter_eq: "list_all P xs \<Longrightarrow> filter P xs = xs"
by (metis list_all_iff filter_True)

lemma list_all_filter_nil:
  assumes "list_all P xs"
    and "\<And>x. P x \<Longrightarrow> \<not>Q x"
  shows "filter Q xs = []"
using assms by (induct xs) simp_all

lemma list_all_concat: "list_all (list_all f) P \<longleftrightarrow> list_all f (concat P)"
by (induct P) auto

lemma map_upt_index_eq:
  assumes "j < length xs"
  shows "(map (\<lambda>i. xs ! is i) [0..<length xs]) ! j = xs ! is j"
using assms by (simp add: map_nth)

lemma map_snd_list_insert_distrib:
  assumes "\<forall>(i,p) \<in> insert x (set xs). \<forall>(i',p') \<in> insert x (set xs). p = p' \<longrightarrow> i = i'"
  shows "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)"
using assms
proof (induction xs rule: List.rev_induct)
  case (snoc y xs)
  hence IH: "map snd (List.insert x xs) = List.insert (snd x) (map snd xs)" by fastforce

  obtain iy py where y: "y = (iy,py)" by (metis surj_pair)
  obtain ix px where x: "x = (ix,px)" by (metis surj_pair)

  have "(ix,px) \<in> insert x (set (y#xs))" "(iy,py) \<in> insert x (set (y#xs))" using y x by auto
  hence *: "iy = ix" when "py = px" using that snoc.prems by auto

  show ?case
  proof (cases "px = py")
    case True
    hence "y = x" using * y x by auto
    thus ?thesis using IH by simp
  next
    case False
    hence "y \<noteq> x" using y x by simp
    have "List.insert x (xs@[y]) = (List.insert x xs)@[y]"
    proof -
      have 1: "insert y (set xs) = set (xs@[y])" by simp
      have 2: "x \<notin> insert y (set xs) \<or> x \<in> set xs" using \<open>y \<noteq> x\<close> by blast
      show ?thesis using 1 2 by (metis (no_types) List.insert_def append_Cons insertCI)
    qed
    thus ?thesis using IH y x False by (auto simp add: List.insert_def)
  qed
qed simp

lemma map_append_inv: "map f xs = ys@zs \<Longrightarrow> \<exists>vs ws. xs = vs@ws \<and> map f vs = ys \<and> map f ws = zs"
proof (induction xs arbitrary: ys zs)
  case (Cons x xs')
  note prems = Cons.prems
  note IH = Cons.IH

  show ?case
  proof (cases ys)
    case (Cons y ys')
    then obtain vs' ws where *: "xs' = vs'@ws" "map f vs' = ys'" "map f ws = zs"
      using prems IH[of ys' zs] by auto
    hence "x#xs' = (x#vs')@ws" "map f (x#vs') = y#ys'" using Cons prems by force+
    thus ?thesis by (metis Cons *(3))
  qed (use prems in simp)
qed simp

subsection \<open>List: subsequences\<close>
lemma subseqs_set_subset:
  assumes "ys \<in> set (subseqs xs)"
  shows "set ys \<subseteq> set xs"
using assms subseqs_powset[of xs] by auto

lemma subset_sublist_exists:
  "ys \<subseteq> set xs \<Longrightarrow> \<exists>zs. set zs = ys \<and> zs \<in> set (subseqs xs)"
proof (induction xs arbitrary: ys)
  case Cons thus ?case by (metis (no_types, lifting) Pow_iff imageE subseqs_powset)
qed simp

lemma map_subseqs: "map (map f) (subseqs xs) = subseqs (map f xs)"
proof (induct xs)
  case (Cons x xs)
  have "map (Cons (f x)) (map (map f) (subseqs xs)) = map (map f) (map (Cons x) (subseqs xs))"
    by (induct "subseqs xs") auto
  thus ?case by (simp add: Let_def Cons)
qed simp

lemma subseqs_Cons:
  assumes "ys \<in> set (subseqs xs)"
  shows "ys \<in> set (subseqs (x#xs))"
by (metis assms Un_iff set_append subseqs.simps(2))

lemma subseqs_subset:
  assumes "ys \<in> set (subseqs xs)"
  shows "set ys \<subseteq> set xs"
using assms by (metis Pow_iff image_eqI subseqs_powset)

subsection \<open>List: prefixes, suffixes\<close>
lemma suffix_Cons': "suffix [x] (y#ys) \<Longrightarrow> suffix [x] ys \<or> (y = x \<and> ys = [])"
using suffix_Cons[of "[x]"] by auto

lemma prefix_Cons': "prefix (x#xs) (x#ys) \<Longrightarrow> prefix xs ys"
by simp

lemma prefix_map: "prefix xs (map f ys) \<Longrightarrow> \<exists>zs. prefix zs ys \<and> map f zs = xs"
using map_append_inv unfolding prefix_def by fast

lemma length_prefix_ex:
  assumes "n \<le> length xs"
  shows "\<exists>ys zs. xs = ys@zs \<and> length ys = n"
  using assms
proof (induction n)
  case (Suc n)
  then obtain ys zs where IH: "xs = ys@zs" "length ys = n" by moura
  hence "length zs > 0" using Suc.prems(1) by auto
  then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
  hence "length (ys@[v]) = Suc n" using IH(2) by simp
  thus ?case using IH(1) v by (metis append.assoc append_Cons append_Nil)
qed simp

lemma length_prefix_ex':
  assumes "n < length xs"
  shows "\<exists>ys zs. xs = ys@xs ! n#zs \<and> length ys = n"
proof -
  obtain ys zs where xs: "xs = ys@zs" "length ys = n" using assms length_prefix_ex[of n xs] by moura
  hence "length zs > 0" using assms by auto
  then obtain v vs where v: "zs = v#vs" by (metis Suc_length_conv gr0_conv_Suc)
  hence "(ys@zs) ! n = v" using xs by auto
  thus ?thesis using v xs by auto
qed

lemma length_prefix_ex2:
  assumes "i < length xs" "j < length xs" "i < j"
  shows "\<exists>ys zs vs. xs = ys@xs ! i#zs@xs ! j#vs \<and> length ys = i \<and> length zs = j - i - 1"
by (smt assms length_prefix_ex' nth_append append.assoc append.simps(2) add_diff_cancel_left'
        diff_Suc_1 length_Cons length_append)

subsection \<open>List: products\<close>
lemma product_lists_Cons:
  "x#xs \<in> set (product_lists (y#ys)) \<longleftrightarrow> (xs \<in> set (product_lists ys) \<and> x \<in> set y)"
by auto

lemma product_lists_in_set_nth:
  assumes "xs \<in> set (product_lists ys)"
  shows "\<forall>i<length ys. xs ! i \<in> set (ys ! i)"
proof -
  have 0: "length ys = length xs" using assms(1) by (simp add: in_set_product_lists_length)
  thus ?thesis using assms
  proof (induction ys arbitrary: xs)
    case (Cons y ys)
    obtain x xs' where xs: "xs = x#xs'" using Cons.prems(1) by (metis length_Suc_conv)
    hence "xs' \<in> set (product_lists ys) \<Longrightarrow> \<forall>i<length ys. xs' ! i \<in> set (ys ! i)"
          "length ys = length xs'" "x#xs' \<in> set (product_lists (y#ys))"
      using Cons by simp_all
    thus ?case using xs product_lists_Cons[of x xs' y ys] by (simp add: nth_Cons')
  qed simp
qed

lemma product_lists_in_set_nth':
  assumes "\<forall>i<length xs. ys ! i \<in> set (xs ! i)"
    and "length xs = length ys"
  shows "ys \<in> set (product_lists xs)"
using assms
proof (induction xs arbitrary: ys)
  case (Cons x xs)
  obtain y ys' where ys: "ys = y#ys'" using Cons.prems(2) by (metis length_Suc_conv)
  hence "ys' \<in> set (product_lists xs)" "y \<in> set x" "length xs = length ys'"
    using Cons by fastforce+
  thus ?case using ys product_lists_Cons[of y ys' x xs] by (simp add: nth_Cons')
qed simp

subsection \<open>Other Lemmata\<close>
lemma inv_set_fset: "finite M \<Longrightarrow> set (inv set M) = M"
unfolding inv_def by (metis (mono_tags) finite_list someI_ex)

lemma lfp_eqI':
  assumes "mono f"
    and "f C = C"
    and "\<forall>X \<in> Pow C. f X = X \<longrightarrow> X = C"
  shows "lfp f = C"
by (metis PowI assms lfp_lowerbound lfp_unfold subset_refl)

lemma lfp_while':
  fixes f::"'a set \<Rightarrow> 'a set" and M::"'a set"
  defines "N \<equiv> while (\<lambda>A. f A \<noteq> A) f {}"
  assumes f_mono: "mono f"
    and N_finite: "finite N"
    and N_supset: "f N \<subseteq> N"
  shows "lfp f = N"
proof -
  have *: "f X \<subseteq> N" when "X \<subseteq> N" for X using N_supset monoD[OF f_mono that] by blast
  show ?thesis
    using lfp_while[OF f_mono * N_finite]
    by (simp add: N_def)
qed

lemma lfp_while'':
  fixes f::"'a set \<Rightarrow> 'a set" and M::"'a set"
  defines "N \<equiv> while (\<lambda>A. f A \<noteq> A) f {}"
  assumes f_mono: "mono f"
    and lfp_finite: "finite (lfp f)"
  shows "lfp f = N"
proof -
  have *: "f X \<subseteq> lfp f" when "X \<subseteq> lfp f" for X
    using lfp_fixpoint[OF f_mono] monoD[OF f_mono that]
    by blast
  show ?thesis
    using lfp_while[OF f_mono * lfp_finite]
    by (simp add: N_def)
qed

lemma partition_index_bij:
  fixes n::nat
  obtains I k where
    "bij_betw I {0..<n} {0..<n}" "k \<le> n"
    "\<forall>i. i < k \<longrightarrow> P (I i)"
    "\<forall>i. k \<le> i \<and> i < n \<longrightarrow> \<not>(P (I i))"
proof -
  define A where "A = filter P [0..<n]"
  define B where "B = filter (\<lambda>i. \<not>P i) [0..<n]"
  define k where "k = length A"
  define I where "I = (\<lambda>n. (A@B) ! n)"

  note defs = A_def B_def k_def I_def

  have k1: "k \<le> n" by (metis defs(1,3) diff_le_self dual_order.trans length_filter_le length_upt)

  have "i < k \<Longrightarrow> P (A ! i)" for i by (metis defs(1,3) filter_nth)
  hence k2: "i < k \<Longrightarrow> P ((A@B) ! i)" for i by (simp add: defs nth_append)

  have "i < length B \<Longrightarrow> \<not>(P (B ! i))" for i by (metis defs(2) filter_nth)
  hence "i < length B \<Longrightarrow> \<not>(P ((A@B) ! (k + i)))" for i using k_def by simp
  hence "k \<le> i \<and> i < k + length B \<Longrightarrow> \<not>(P ((A@B) ! i))" for i
    by (metis add.commute add_less_imp_less_right le_add_diff_inverse2)
  hence k3: "k \<le> i \<and> i < n \<Longrightarrow> \<not>(P ((A@B) ! i))" for i by (simp add: defs sum_length_filter_compl)

  have *: "length (A@B) = n" "set (A@B) = {0..<n}" "distinct (A@B)"
    by (metis defs(1,2) diff_zero length_append length_upt sum_length_filter_compl)
       (auto simp add: defs)

  have I: "bij_betw I {0..<n} {0..<n}"
  proof (intro bij_betwI')
    fix x y show "x \<in> {0..<n} \<Longrightarrow> y \<in> {0..<n} \<Longrightarrow> (I x = I y) = (x = y)"
      by (metis *(1,3) defs(4) nth_eq_iff_index_eq atLeastLessThan_iff)
  next
    fix x show "x \<in> {0..<n} \<Longrightarrow> I x \<in> {0..<n}"
      by (metis *(1,2) defs(4) atLeastLessThan_iff nth_mem)
  next
    fix y show "y \<in> {0..<n} \<Longrightarrow> \<exists>x \<in> {0..<n}. y = I x"
      by (metis * defs(4) atLeast0LessThan distinct_Ex1 lessThan_iff)
  qed

  show ?thesis using k1 k2 k3 I that by (simp add: defs)
qed

lemma finite_lists_length_eq':
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> finite {y. P x y}"
  shows "finite {ys. length xs = length ys \<and> (\<forall>y \<in> set ys. \<exists>x \<in> set xs. P x y)}"
proof -
  define Q where "Q \<equiv> \<lambda>ys. \<forall>y \<in> set ys. \<exists>x \<in> set xs. P x y"
  define M where "M \<equiv> {y. \<exists>x \<in> set xs. P x y}"

  have 0: "finite M" using assms unfolding M_def by fastforce

  have "Q ys \<longleftrightarrow> set ys \<subseteq> M"
       "(Q ys \<and> length ys = length xs) \<longleftrightarrow> (length xs = length ys \<and> Q ys)"
    for ys
    unfolding Q_def M_def by auto
  thus ?thesis
    using finite_lists_length_eq[OF 0, of "length xs"]
    unfolding Q_def by presburger
qed

lemma trancl_eqI:
  assumes "\<forall>(a,b) \<in> A. \<forall>(c,d) \<in> A. b = c \<longrightarrow> (a,d) \<in> A"
  shows "A = A\<^sup>+"
proof
  show "A\<^sup>+ \<subseteq> A"
  proof
    fix x assume x: "x \<in> A\<^sup>+"
    then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
    hence "(a,b) \<in> A\<^sup>+" using x by metis
    hence "(a,b) \<in> A" using assms by (induct rule: trancl_induct) auto
    thus "x \<in> A" using ab by metis
  qed
qed auto

lemma trancl_eqI':
  assumes "\<forall>(a,b) \<in> A. \<forall>(c,d) \<in> A. b = c \<and> a \<noteq> d \<longrightarrow> (a,d) \<in> A"
    and "\<forall>(a,b) \<in> A. a \<noteq> b"
  shows "A = {(a,b) \<in> A\<^sup>+. a \<noteq> b}"
proof
  show "{(a,b) \<in> A\<^sup>+. a \<noteq> b} \<subseteq> A"
  proof
    fix x assume x: "x \<in> {(a,b) \<in> A\<^sup>+. a \<noteq> b}"
    then obtain a b where ab: "x = (a,b)" by (metis surj_pair)
    hence "(a,b) \<in> A\<^sup>+" "a \<noteq> b" using x by blast+
    hence "(a,b) \<in> A"
    proof (induction rule: trancl_induct)
      case base thus ?case by blast
    next
      case step thus ?case using assms(1) by force
    qed
    thus "x \<in> A" using ab by metis
  qed
qed (use assms(2) in auto)

lemma distinct_concat_idx_disjoint:
  assumes xs: "distinct (concat xs)"
    and ij: "i < length xs" "j < length xs" "i < j"
  shows "set (xs ! i) \<inter> set (xs ! j) = {}"
proof -
  obtain ys zs vs where ys: "xs = ys@xs ! i#zs@xs ! j#vs" "length ys = i" "length zs = j - i - 1"
    using length_prefix_ex2[OF ij] by moura
  thus ?thesis
    using xs concat_append[of "ys@xs ! i#zs" "xs ! j#vs"]
          distinct_append[of "concat (ys@xs ! i#zs)" "concat (xs ! j#vs)"]
    by auto
qed

lemma remdups_ex2:
  "length (remdups xs) > 1 \<Longrightarrow> \<exists>a \<in> set xs. \<exists>b \<in> set xs. a \<noteq> b"
by (metis distinct_Ex1 distinct_remdups less_trans nth_mem set_remdups zero_less_one zero_neq_one)

lemma trancl_minus_refl_idem:
  defines "cl \<equiv> \<lambda>ts. {(a,b) \<in> ts\<^sup>+. a \<noteq> b}"
  shows "cl (cl ts) = cl ts"
proof -
  have 0: "(ts\<^sup>+)\<^sup>+ = ts\<^sup>+" "cl ts \<subseteq> ts\<^sup>+" "(cl ts)\<^sup>+ \<subseteq> (ts\<^sup>+)\<^sup>+"
  proof -
    show "(ts\<^sup>+)\<^sup>+ = ts\<^sup>+" "cl ts \<subseteq> ts\<^sup>+" unfolding cl_def by auto
    thus "(cl ts)\<^sup>+ \<subseteq> (ts\<^sup>+)\<^sup>+" using trancl_mono[of _ "cl ts" "ts\<^sup>+"] by blast
  qed

  have 1: "t \<in> cl (cl ts)" when t: "t \<in> cl ts" for t
    using t 0 unfolding cl_def by fast

  have 2: "t \<in> cl ts" when t: "t \<in> cl (cl ts)" for t
  proof -
    obtain a b where ab: "t = (a,b)" by (metis surj_pair)
    have "t \<in> (cl ts)\<^sup>+" and a_neq_b: "a \<noteq> b" using t unfolding cl_def ab by force+
    hence "t \<in> ts\<^sup>+" using 0 by blast
    thus ?thesis using a_neq_b unfolding cl_def ab by blast
  qed

  show ?thesis using 1 2 by blast
qed

subsection \<open>Infinite Paths in Relations as Mappings from Naturals to States\<close>
context
begin

private fun rel_chain_fun::"nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a" where
  "rel_chain_fun 0 x _ _ = x"
| "rel_chain_fun (Suc i) x y r = (if i = 0 then y else SOME z. (rel_chain_fun i x y r, z) \<in> r)"

lemma infinite_chain_intro:
  fixes r::"('a \<times> 'a) set"
  assumes "\<forall>(a,b) \<in> r. \<exists>c. (b,c) \<in> r" "r \<noteq> {}"
  shows "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> r"
proof -
  from assms(2) obtain a b where "(a,b) \<in> r" by auto

  let ?P = "\<lambda>i. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) \<in> r"
  let ?Q = "\<lambda>i. \<exists>z. (rel_chain_fun i a b r, z) \<in> r"

  have base: "?P 0" using \<open>(a,b) \<in> r\<close> by auto

  have step: "?P (Suc i)" when i: "?P i" for i
  proof -
    have "?Q (Suc i)" using assms(1) i by auto
    thus ?thesis using someI_ex[OF \<open>?Q (Suc i)\<close>] by auto
  qed

  have "\<forall>i::nat. (rel_chain_fun i a b r, rel_chain_fun (Suc i) a b r) \<in> r"
    using base step nat_induct[of ?P] by simp
  thus ?thesis by fastforce
qed

end

lemma infinite_chain_intro':
  fixes r::"('a \<times> 'a) set"
  assumes base: "\<exists>b. (x,b) \<in> r" and step: "\<forall>b. (x,b) \<in> r\<^sup>+ \<longrightarrow> (\<exists>c. (b,c) \<in> r)"
  shows "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> r"
proof -
  let ?s = "{(a,b) \<in> r. a = x \<or> (x,a) \<in> r\<^sup>+}"

  have "?s \<noteq> {}" using base by auto

  have "\<exists>c. (b,c) \<in> ?s" when ab: "(a,b) \<in> ?s" for a b
  proof (cases "a = x")
    case False
    hence "(x,a) \<in> r\<^sup>+" using ab by auto
    hence "(x,b) \<in> r\<^sup>+" using \<open>(a,b) \<in> ?s\<close> by auto
    thus ?thesis using step by auto
  qed (use ab step in auto)
  hence "\<exists>f. \<forall>i. (f i, f (Suc i)) \<in> ?s" using infinite_chain_intro[of ?s] \<open>?s \<noteq> {}\<close> by blast
  thus ?thesis by auto
qed

lemma infinite_chain_mono:
  assumes "S \<subseteq> T" "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> S"
  shows "\<exists>f. \<forall>i::nat. (f i, f (Suc i)) \<in> T"
using assms by auto

end


theory Proofs7
  imports Requirements VCTheoryLemmas
begin

definition inv7 where "inv7 s \<equiv> R7 s \<and> extraInv s"

theorem proof_7_1: "VC1 inv7 s0"
  apply(unfold VC1_def inv7_def R7_def extraInv_def)
  by auto

theorem proof_7_347: "VC347 R7 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC347_def inv7_def R7_def extraInv_def)
  by auto

theorem proof_7_348: "VC348 R7 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC348_def inv7_def R7_def extraInv_def)
  by auto

theorem proof_7_349: "VC349 R7 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC349_def inv7_def R7_def extraInv_def)
  by auto

theorem proof_7_350: "VC350 R7 env s0 PdOut_value paid_value opened_value"
  apply(unfold VC350_def inv7_def R7_def extraInv_def)
  apply(rule impI)
  apply(rule conjI)
   apply simp
  apply((rule allI)+)
  apply(rule impI)
  apply(simp split: if_splits)
  using substate_toEnvNum_id apply blast
  by auto

end


theory ToyList
imports Main
begin

text\<open>\noindent
HOL already has a predefined theory of lists called \<open>List\<close> ---
\<open>ToyList\<close> is merely a small fragment of it chosen as an example.
To avoid some ambiguities caused by defining lists twice, we manipulate
the concrete syntax and name space of theory \<^theory>\<open>Main\<close> as follows.
\<close>

no_notation Nil ("[]") and Cons (infixr "#" 65) and append (infixr "@" 65)
hide_type list
hide_const rev

datatype 'a list = Nil                          ("[]")
                 | Cons 'a "'a list"            (infixr "#" 65)

text\<open>\noindent
The datatype\index{datatype@\isacommand {datatype} (command)}
\tydx{list} introduces two
constructors \cdx{Nil} and \cdx{Cons}, the
empty~list and the operator that adds an element to the front of a list. For
example, the term \isa{Cons True (Cons False Nil)} is a value of
type \<^typ>\<open>bool list\<close>, namely the list with the elements \<^term>\<open>True\<close> and
\<^term>\<open>False\<close>. Because this notation quickly becomes unwieldy, the
datatype declaration is annotated with an alternative syntax: instead of
@{term[source]Nil} and \isa{Cons x xs} we can write
\<^term>\<open>[]\<close>\index{$HOL2list@\isa{[]}|bold} and
\<^term>\<open>x # xs\<close>\index{$HOL2list@\isa{\#}|bold}. In fact, this
alternative syntax is the familiar one.  Thus the list \isa{Cons True
(Cons False Nil)} becomes \<^term>\<open>True # False # []\<close>. The annotation
\isacommand{infixr}\index{infixr@\isacommand{infixr} (annotation)}
means that \<open>#\<close> associates to
the right: the term \<^term>\<open>x # y # z\<close> is read as \<open>x # (y # z)\<close>
and not as \<open>(x # y) # z\<close>.
The \<open>65\<close> is the priority of the infix \<open>#\<close>.

\begin{warn}
  Syntax annotations can be powerful, but they are difficult to master and
  are never necessary.  You
  could drop them from theory \<open>ToyList\<close> and go back to the identifiers
  @{term[source]Nil} and @{term[source]Cons}.  Novices should avoid using
  syntax annotations in their own theories.
\end{warn}
Next, two functions \<open>app\<close> and \cdx{rev} are defined recursively,
in this order, because Isabelle insists on definition before use:
\<close>

primrec app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
"[] @ ys       = ys" |
"(x # xs) @ ys = x # (xs @ ys)"

primrec rev :: "'a list \<Rightarrow> 'a list" where
"rev []        = []" |
"rev (x # xs)  = (rev xs) @ (x # [])"

text\<open>\noindent
Each function definition is of the form
\begin{center}
\isacommand{primrec} \textit{name} \<open>::\<close> \textit{type} \textit{(optional syntax)} \isakeyword{where} \textit{equations}
\end{center}
The equations must be separated by \<open>|\<close>.
%
Function \<open>app\<close> is annotated with concrete syntax. Instead of the
prefix syntax \<open>app xs ys\<close> the infix
\<^term>\<open>xs @ ys\<close>\index{$HOL2list@\isa{\at}|bold} becomes the preferred
form.

\index{*rev (constant)|(}\index{append function|(}
The equations for \<open>app\<close> and \<^term>\<open>rev\<close> hardly need comments:
\<open>app\<close> appends two lists and \<^term>\<open>rev\<close> reverses a list.  The
keyword \commdx{primrec} indicates that the recursion is
of a particularly primitive kind where each recursive call peels off a datatype
constructor from one of the arguments.  Thus the
recursion always terminates, i.e.\ the function is \textbf{total}.
\index{functions!total}

The termination requirement is absolutely essential in HOL, a logic of total
functions. If we were to drop it, inconsistencies would quickly arise: the
``definition'' $f(n) = f(n)+1$ immediately leads to $0 = 1$ by subtracting
$f(n)$ on both sides.
% However, this is a subtle issue that we cannot discuss here further.

\begin{warn}
  As we have indicated, the requirement for total functions is an essential characteristic of HOL\@. It is only
  because of totality that reasoning in HOL is comparatively easy.  More
  generally, the philosophy in HOL is to refrain from asserting arbitrary axioms (such as
  function definitions whose totality has not been proved) because they
  quickly lead to inconsistencies. Instead, fixed constructs for introducing
  types and functions are offered (such as \isacommand{datatype} and
  \isacommand{primrec}) which are guaranteed to preserve consistency.
\end{warn}

\index{syntax}%
A remark about syntax.  The textual definition of a theory follows a fixed
syntax with keywords like \isacommand{datatype} and \isacommand{end}.
% (see Fig.~\ref{fig:keywords} in Appendix~\ref{sec:Appendix} for a full list).
Embedded in this syntax are the types and formulae of HOL, whose syntax is
extensible (see \S\ref{sec:concrete-syntax}), e.g.\ by new user-defined infix operators.
To distinguish the two levels, everything
HOL-specific (terms and types) should be enclosed in
\texttt{"}\dots\texttt{"}.
To lessen this burden, quotation marks around a single identifier can be
dropped, unless the identifier happens to be a keyword, for example
\isa{"end"}.
When Isabelle prints a syntax error message, it refers to the HOL syntax as
the \textbf{inner syntax} and the enclosing theory language as the \textbf{outer syntax}.

Comments\index{comment} must be in enclosed in \texttt{(*}and\texttt{*)}.

\section{Evaluation}
\index{evaluation}

Assuming you have processed the declarations and definitions of
\texttt{ToyList} presented so far, you may want to test your
functions by running them. For example, what is the value of
\<^term>\<open>rev(True#False#[])\<close>? Command
\<close>

value "rev (True # False # [])"

text\<open>\noindent yields the correct result \<^term>\<open>False # True # []\<close>.
But we can go beyond mere functional programming and evaluate terms with
variables in them, executing functions symbolically:\<close>

value "rev (a # b # c # [])"

text\<open>\noindent yields \<^term>\<open>c # b # a # []\<close>.

\section{An Introductory Proof}
\label{sec:intro-proof}

Having convinced ourselves (as well as one can by testing) that our
definitions capture our intentions, we are ready to prove a few simple
theorems. This will illustrate not just the basic proof commands but
also the typical proof process.

\subsubsection*{Main Goal.}

Our goal is to show that reversing a list twice produces the original
list.
\<close>

theorem rev_rev [simp]: "rev(rev xs) = xs"

txt\<open>\index{theorem@\isacommand {theorem} (command)|bold}%
\noindent
This \isacommand{theorem} command does several things:
\begin{itemize}
\item
It establishes a new theorem to be proved, namely \<^prop>\<open>rev(rev xs) = xs\<close>.
\item
It gives that theorem the name \<open>rev_rev\<close>, for later reference.
\item
It tells Isabelle (via the bracketed attribute \attrdx{simp}) to take the eventual theorem as a simplification rule: future proofs involving
simplification will replace occurrences of \<^term>\<open>rev(rev xs)\<close> by
\<^term>\<open>xs\<close>.
\end{itemize}
The name and the simplification attribute are optional.
Isabelle's response is to print the initial proof state consisting
of some header information (like how many subgoals there are) followed by
@{subgoals[display,indent=0]}
For compactness reasons we omit the header in this tutorial.
Until we have finished a proof, the \rmindex{proof state} proper
always looks like this:
\begin{isabelle}
~1.~$G\sb{1}$\isanewline
~~\vdots~~\isanewline
~$n$.~$G\sb{n}$
\end{isabelle}
The numbered lines contain the subgoals $G\sb{1}$, \dots, $G\sb{n}$
that we need to prove to establish the main goal.\index{subgoals}
Initially there is only one subgoal, which is identical with the
main goal. (If you always want to see the main goal as well,
set the flag \isa{Proof.show_main_goal}\index{*show_main_goal (flag)}
--- this flag used to be set by default.)

Let us now get back to \<^prop>\<open>rev(rev xs) = xs\<close>. Properties of recursively
defined functions are best established by induction. In this case there is
nothing obvious except induction on \<^term>\<open>xs\<close>:
\<close>

apply(induct_tac xs)

txt\<open>\noindent\index{*induct_tac (method)}%
This tells Isabelle to perform induction on variable \<^term>\<open>xs\<close>. The suffix
\<^term>\<open>tac\<close> stands for \textbf{tactic},\index{tactics}
a synonym for ``theorem proving function''.
By default, induction acts on the first subgoal. The new proof state contains
two subgoals, namely the base case (@{term[source]Nil}) and the induction step
(@{term[source]Cons}):
@{subgoals[display,indent=0,margin=65]}

The induction step is an example of the general format of a subgoal:\index{subgoals}
\begin{isabelle}
~$i$.~{\isasymAnd}$x\sb{1}$~\dots$x\sb{n}$.~{\it assumptions}~{\isasymLongrightarrow}~{\it conclusion}
\end{isabelle}\index{$IsaAnd@\isasymAnd|bold}
The prefix of bound variables \isasymAnd$x\sb{1}$~\dots~$x\sb{n}$ can be
ignored most of the time, or simply treated as a list of variables local to
this subgoal. Their deeper significance is explained in Chapter~\ref{chap:rules}.
The {\it assumptions}\index{assumptions!of subgoal}
are the local assumptions for this subgoal and {\it
  conclusion}\index{conclusion!of subgoal} is the actual proposition to be proved.
Typical proof steps
that add new assumptions are induction and case distinction. In our example
the only assumption is the induction hypothesis \<^term>\<open>rev (rev list) =
  list\<close>, where \<^term>\<open>list\<close> is a variable name chosen by Isabelle. If there
are multiple assumptions, they are enclosed in the bracket pair
\indexboldpos{\isasymlbrakk}{$Isabrl} and
\indexboldpos{\isasymrbrakk}{$Isabrr} and separated by semicolons.

Let us try to solve both goals automatically:
\<close>

apply(auto)

txt\<open>\noindent
This command tells Isabelle to apply a proof strategy called
\<open>auto\<close> to all subgoals. Essentially, \<open>auto\<close> tries to
simplify the subgoals.  In our case, subgoal~1 is solved completely (thanks
to the equation \<^prop>\<open>rev [] = []\<close>) and disappears; the simplified version
of subgoal~2 becomes the new subgoal~1:
@{subgoals[display,indent=0,margin=70]}
In order to simplify this subgoal further, a lemma suggests itself.
\<close>
(*<*)
oops
(*>*)

subsubsection\<open>First Lemma\<close>

text\<open>
\indexbold{abandoning a proof}\indexbold{proofs!abandoning}
After abandoning the above proof attempt (at the shell level type
\commdx{oops}) we start a new proof:
\<close>

lemma rev_app [simp]: "rev(xs @ ys) = (rev ys) @ (rev xs)"

txt\<open>\noindent The keywords \commdx{theorem} and
\commdx{lemma} are interchangeable and merely indicate
the importance we attach to a proposition.  Therefore we use the words
\emph{theorem} and \emph{lemma} pretty much interchangeably, too.

There are two variables that we could induct on: \<^term>\<open>xs\<close> and
\<^term>\<open>ys\<close>. Because \<open>@\<close> is defined by recursion on
the first argument, \<^term>\<open>xs\<close> is the correct one:
\<close>

apply(induct_tac xs)

txt\<open>\noindent
This time not even the base case is solved automatically:
\<close>

apply(auto)

txt\<open>
@{subgoals[display,indent=0,goals_limit=1]}
Again, we need to abandon this proof attempt and prove another simple lemma
first. In the future the step of abandoning an incomplete proof before
embarking on the proof of a lemma usually remains implicit.
\<close>
(*<*)
oops
(*>*)

subsubsection\<open>Second Lemma\<close>

text\<open>
We again try the canonical proof procedure:
\<close>

lemma app_Nil2 [simp]: "xs @ [] = xs"
apply(induct_tac xs)
apply(auto)

txt\<open>
\noindent
It works, yielding the desired message \<open>No subgoals!\<close>:
@{goals[display,indent=0]}
We still need to confirm that the proof is now finished:
\<close>

done

text\<open>\noindent
As a result of that final \commdx{done}, Isabelle associates the lemma just proved
with its name. In this tutorial, we sometimes omit to show that final \isacommand{done}
if it is obvious from the context that the proof is finished.

% Instead of \isacommand{apply} followed by a dot, you can simply write
% \isacommand{by}\indexbold{by}, which we do most of the time.
Notice that in lemma @{thm[source]app_Nil2},
as printed out after the final \isacommand{done}, the free variable \<^term>\<open>xs\<close> has been
replaced by the unknown \<open>?xs\<close>, just as explained in
\S\ref{sec:variables}.

Going back to the proof of the first lemma
\<close>

lemma rev_app [simp]: "rev(xs @ ys) = (rev ys) @ (rev xs)"
apply(induct_tac xs)
apply(auto)

txt\<open>
\noindent
we find that this time \<open>auto\<close> solves the base case, but the
induction step merely simplifies to
@{subgoals[display,indent=0,goals_limit=1]}
Now we need to remember that \<open>@\<close> associates to the right, and that
\<open>#\<close> and \<open>@\<close> have the same priority (namely the \<open>65\<close>
in their \isacommand{infixr} annotation). Thus the conclusion really is
\begin{isabelle}
~~~~~(rev~ys~@~rev~list)~@~(a~\#~[])~=~rev~ys~@~(rev~list~@~(a~\#~[]))
\end{isabelle}
and the missing lemma is associativity of \<open>@\<close>.
\<close>
(*<*)oops(*>*)

subsubsection\<open>Third Lemma\<close>

text\<open>
Abandoning the previous attempt, the canonical proof procedure
succeeds without further ado.
\<close>

lemma app_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
apply(induct_tac xs)
apply(auto)
done

text\<open>
\noindent
Now we can prove the first lemma:
\<close>

lemma rev_app [simp]: "rev(xs @ ys) = (rev ys) @ (rev xs)"
apply(induct_tac xs)
apply(auto)
done

text\<open>\noindent
Finally, we prove our main theorem:
\<close>

theorem rev_rev [simp]: "rev(rev xs) = xs"
apply(induct_tac xs)
apply(auto)
done

text\<open>\noindent
The final \commdx{end} tells Isabelle to close the current theory because
we are finished with its development:%
\index{*rev (constant)|)}\index{append function|)}
\<close>

end


theory MultiWorkerWithQueue
  imports Main "../spec/SQS"
begin

datatype Node
  = Worker nat
  | Queue
  | Acceptor

datatype 'val Message
  = SQSRequest "'val SQSRequest"
  | SQSResponse "'val SQSResponse"
  | Accept 'val

record 'val WorkerState =
  alive :: bool
  process :: "(MessageId \<times> 'val) list"

record 'val State =
  workers :: "nat \<rightharpoonup> 'val WorkerState"
  accepted :: "'val set"
  queue :: "(Node, 'val) SQSState"

datatype ('proc,'msg) Send = Send (msg_recipient: 'proc) (send_payload: 'msg)

datatype 'msg Event
  = Received (msg_sender: Node) (received_message: 'msg)
  | WorkerStep
  | QueueStep

fun valid_event :: "(Node, 'val Message) Send Event \<Rightarrow> Node \<Rightarrow> (Node \<times> (Node, 'val Message) Send) set \<Rightarrow> bool" where
  "valid_event (Received sender msg) _ msgs = ((sender, msg) \<in> msgs)"
| "valid_event WorkerStep _ _ = True"
| "valid_event _ _ _ = False"

type_synonym ('st, 'val) StepStateFunction = "'st \<Rightarrow> (Node, 'val Message) Send Event \<Rightarrow> ('st \<times> (Node, 'val Message) Send set)"
type_synonym 'val StepFunction = "Node \<Rightarrow> ('val State, 'val) StepStateFunction"

fun worker_step :: "('val WorkerState, 'val) StepStateFunction" where
  "worker_step st WorkerStep = (if List.null (process st)
    then (st, {Send Queue (SQSRequest (Receive 10))})
    else (st \<lparr> process := tl (process st) \<rparr>, {Send Acceptor (Accept (snd (hd (process st)))), Send Queue (SQSRequest (Delete (fst (hd (process st)))))}))"
| "worker_step st (Received _ (Send _ (SQSResponse (Returned xs)))) = (st \<lparr> process := xs \<rparr>, {})"
| "worker_step st _ = (st, {})"

fun queue_step :: "((Node, 'val) SQSState, 'val) StepStateFunction" where
  "queue_step st (Received proc (Send _ (SQSRequest req))) = (st \<lparr> request := Some (proc,req) \<rparr>, {})"
| "queue_step st QueueStep = (let st' = SQS_step st in (st', case response st' of None \<Rightarrow> {} | Some (proc,resp) \<Rightarrow> {Send proc (SQSResponse resp)}))"
| "queue_step st _ = (st, {})"

fun step :: "'val StepFunction" where
  "step (Worker proc) st (Received target msg) =
    (if Worker proc = target then (let (w, ms) = worker_step (the (workers st proc)) (Received target msg) in (st \<lparr> workers := workers st (proc \<mapsto> w) \<rparr>, ms)) else (st, {}))
  "
| "step Acceptor st (Received _ (Send _ (Accept val))) = (st \<lparr> accepted := accepted st \<union> {val} \<rparr>, {})"
| "step _ st _ = (st, {})"

record 'val world =
  world_state :: "'val State"
  world_events :: "(Node \<times> (Node, 'val Message) Send Event) list"
  world_messages :: "(Node \<times> (Node, 'val Message) Send) set"

inductive execute_step :: "'val StepFunction \<Rightarrow> 'val world \<Rightarrow> 'val world \<Rightarrow> bool" where
  exec_step: "\<lbrakk> valid_event event proc msgs;
    step' proc st event = (st', ns);
    events' = events @ [(proc, event)];
    msgs' = msgs \<union> (\<lambda>msg. (proc,msg)) ` ns
  \<rbrakk> \<Longrightarrow> execute_step step' \<lparr> world_state = st, world_events = events, world_messages = msgs \<rparr> \<lparr> world_state = st', world_events = events', world_messages = msgs' \<rparr>"

definition execute where
  "execute step' \<equiv> rtranclp (execute_step step')"

inductive execute_traced :: "'val StepFunction \<Rightarrow> 'val world \<Rightarrow> 'val world \<Rightarrow> 'val world list \<Rightarrow> bool" where
  execute_traced_empty: "execute_traced step' w w []"
| execute_traced_cons: "\<lbrakk> execute_traced step' w1 w2 path; execute_step step' w2 w3 \<rbrakk> \<Longrightarrow> execute_traced step' w1 w3 (path @ [w2])"

lemma execute_induct: "execute step' w w' \<Longrightarrow> (\<And>w. P w w) \<Longrightarrow> (\<And>w1 w2 w3. execute step' w1 w2 \<Longrightarrow> P w1 w2 \<Longrightarrow> execute_step step' w2 w3 \<Longrightarrow> P w1 w3) \<Longrightarrow> P w w'"
  apply (simp add: execute_def)
  apply (erule rtranclp_induct)
   apply auto
  done

lemma execute_imps_trace:
  assumes "execute step' w w'"
  obtains path where "execute_traced step' w w' path"
  apply (induct rule: execute_induct)
  apply (rule assms)
  using execute_traced_empty apply blast
  using execute_traced_cons by blast

lemma trace_imps_execute:
  assumes "execute_traced step' w w' path"
  shows "execute step' w w'"
  apply (rule execute_traced.induct)
  apply (rule assms)
  apply (simp add: execute_def)
  by (simp add: execute_def)

lemma execute_traced_coherence_0: "\<lbrakk> execute_traced step w w' path; length path = 0 \<rbrakk> \<Longrightarrow> w = w'"
  apply (induct rule: execute_traced.induct)
  apply simp
  apply simp
  done

lemma execute_traced_coherence_Suc:
  assumes "execute_traced step w w' path" "length path = Suc n"
  obtains w0 path' where "path = path' @ [w0]" "execute_traced step w w0 path'" "execute_step step w0 w'" "length path' = n"
  using assms
  apply (induct arbitrary: rule: execute_traced.induct)
  apply simp
  apply simp
  done

lemma step_accepted_monotonic: "step proc st event = (st',ns) \<Longrightarrow> accepted st \<subseteq> accepted st'"
  apply (cases proc)
  apply auto
proof-
  fix x1 x
  assume hyp: "step (Worker x1) st event = (st', ns)" "proc = Worker x1" "x \<in> accepted st"
  have "step (Worker x1) st event = (st',ns) \<Longrightarrow> accepted st \<subseteq> accepted st'"
    apply (cases event)
    apply auto
  proof-
    fix x11 x12 x
    assume "(if Worker x1 = x11 then let (w, y) = worker_step (the (workers st x1)) (Received x11 x12) in (st\<lparr>workers := workers st(x1 \<mapsto> w)\<rparr>, y) else (st, {})) = (st', ns)"
      and "event = Received x11 x12" "x \<in> accepted st"

    have "
       (if Worker x1 = x11 then let (w, y) = worker_step (the (workers st x1)) (Received x11 x12) in (st\<lparr>workers := workers st(x1 \<mapsto> w)\<rparr>, y) else (st, {})) =
       (st', ns) \<Longrightarrow>
       event = Received x11 x12 \<Longrightarrow> x \<in> accepted st \<Longrightarrow> x \<in> accepted st'"
      apply (cases x11)
      apply auto
    proof-
      fix x1a
      show "(if x1 = x1a then let (w, y) = worker_step (the (workers st x1)) (Received (Worker x1a) x12) in (st\<lparr>workers := workers st(x1 \<mapsto> w)\<rparr>, y) else (st, {})) =
           (st', ns) \<Longrightarrow>
           event = Received (Worker x1a) x12 \<Longrightarrow> x \<in> accepted st \<Longrightarrow> x11 = Worker x1a \<Longrightarrow> x \<in> accepted st'"
        apply (cases "x1 = x1a")
        apply auto
        apply (cases "worker_step (the (workers st x1a)) (Received (Worker x1a) x12)")
        apply auto
        done
    qed

    show "x \<in> accepted st'"
      by (simp add: \<open>(if Worker x1 = x11 then let (w, y) = worker_step (the (workers st x1)) (Received x11 x12) in (st\<lparr>workers := workers st(x1 \<mapsto> w)\<rparr>, y) else (st, {})) = (st', ns)\<close> \<open>\<lbrakk>(if Worker x1 = x11 then let (w, y) = worker_step (the (workers st x1)) (Received x11 x12) in (st\<lparr>workers := workers st(x1 \<mapsto> w)\<rparr>, y) else (st, {})) = (st', ns); event = Received x11 x12; x \<in> accepted st\<rbrakk> \<Longrightarrow> x \<in> accepted st'\<close> \<open>event = Received x11 x12\<close> \<open>x \<in> accepted st\<close>)
  qed

  show "x \<in> accepted st'"
    using \<open>step (Worker x1) st event = (st', ns) \<Longrightarrow> accepted st \<subseteq> accepted st'\<close> hyp(1) hyp(3) by blast
next
  fix x
  show "step Acceptor st event = (st', ns) \<Longrightarrow> proc = Acceptor \<Longrightarrow> x \<in> accepted st \<Longrightarrow> x \<in> accepted st'"
    apply (cases event)
    apply auto
  proof-
    fix x11 x12
    show "step Acceptor st (Received x11 x12) = (st', ns) \<Longrightarrow> proc = Acceptor \<Longrightarrow> x \<in> accepted st \<Longrightarrow> event = Received x11 x12 \<Longrightarrow> x \<in> accepted st'"
      apply (cases x12)
      apply (cases "send_payload x12")
      apply auto
      done
  qed
qed

lemma accepted_step_monotonic: "execute_step step w w' \<Longrightarrow> accepted (world_state w) \<subseteq> accepted (world_state w')"
  apply (erule execute_step.cases)
  apply simp
  using step_accepted_monotonic by blast

lemma accepted_monotonic:
  fixes w :: "'val world"
  shows "execute step w w' \<Longrightarrow> accepted (world_state w) \<subseteq> accepted (world_state w')"
proof-
  assume "execute step w w'"
  obtain path where "execute_traced step w w' path"
    using \<open>execute step w w'\<close> execute_imps_trace by blast
  {
    fix n :: nat
    have "\<lbrakk> length path = n; execute_traced step w w' path \<rbrakk> \<Longrightarrow> accepted (world_state w) \<subseteq> accepted (world_state w')"
      apply (induct n arbitrary: path w w')
      using execute_traced_coherence_0 apply blast
    proof-
      fix n :: nat and path :: "'val world list" and w w'
      assume hyp: "(\<And>(path :: 'val world list) w w'. length path = n \<Longrightarrow> execute_traced step w w' path \<Longrightarrow> accepted (world_state w) \<subseteq> accepted (world_state w'))"
        and "length path = Suc n" "execute_traced step w w' path"
      obtain w0 :: "'val world" and path' where "path = path' @ [w0]" "execute_traced step w w0 path'" "execute_step step w0 w'" "length path' = n"
        using \<open>execute_traced step w w' path\<close> \<open>length path = Suc n\<close> execute_traced_coherence_Suc by blast
      have "accepted (world_state w) \<subseteq> accepted (world_state w0)"
        using \<open>execute_traced step w w0 path'\<close> \<open>length path' = n\<close> hyp by auto
      moreover have "accepted (world_state w0) \<subseteq> accepted (world_state w')"
        by (simp add: \<open>execute_step step w0 w'\<close> accepted_step_monotonic)
      ultimately show "accepted (world_state w) \<subseteq> accepted (world_state w')"
        by simp
    qed
  }
  thus ?thesis
    using \<open>execute_traced step w w' path\<close> by blast
qed

definition initialState :: "nat \<Rightarrow> 'val State" where
  "initialState W \<equiv> \<lparr> workers = map_of (map (\<lambda>i. (i, \<lparr> alive = True, process = [] \<rparr>)) (map nat [0..int W])), accepted = {}, queue = initialSQSState \<rparr>"

definition initialWorld :: "nat \<Rightarrow> 'val world" where
  "initialWorld W \<equiv> \<lparr> world_state = initialState W, world_events = [], world_messages = {} \<rparr>"

lemma worker_step_wont_change_accepted:
  "step (Worker w) st event = (st',ns) \<Longrightarrow> accepted st' = accepted st"
  apply (cases event)
  apply simp_all
proof-
  fix x11 x12
  show "(if Worker w = x11 then let (wa, y) = worker_step (the (workers st w)) (Received x11 x12) in (st\<lparr>workers := workers st(w \<mapsto> wa)\<rparr>, y) else (st, {})) =
       (st', ns) \<Longrightarrow>
       event = Received x11 x12 \<Longrightarrow> accepted st' = accepted st"
    apply (cases "Worker w = x11")
    apply simp_all
    apply (cases "worker_step (the (workers st w)) (Received x11 x12)")
    apply simp
    apply (cases st, cases st')
    apply simp
    done
qed

lemma step_accepted_change_onlyif:
  assumes "step proc st event = (st', ns)" "val \<in> accepted st' - accepted st"
  obtains r s where "event = Received r (Send s (Accept val))"
  using assms
  apply (cases event)
  apply simp_all
  apply (cases proc)
  apply simp_all
  using assms(1) worker_step_wont_change_accepted apply blast
proof-
  fix x11 x12
  show "(\<And>r s. x11 = r \<and> x12 = Send.Send s (Accept val) \<Longrightarrow> thesis) \<Longrightarrow>
       step Acceptor st (Received x11 x12) = (st', ns) \<Longrightarrow> val \<in> accepted st' \<and> val \<notin> accepted st \<Longrightarrow> event = Received x11 x12 \<Longrightarrow> proc = Acceptor \<Longrightarrow> thesis"
    apply (cases x12)
    apply (cases "send_payload x12")
    apply auto
    done
qed

lemma execute_step_accepted_change_onlyif:
  assumes "execute_step step w w'" "val \<in> accepted (world_state w') - accepted (world_state w)"
  obtains p r s where "world_events w' = world_events w @ [(p, Received r (Send s (Accept val)))]"
  using assms
  apply (cases rule: execute_step.cases)
  apply simp
  by (meson Diff_iff step_accepted_change_onlyif)

lemma execute_step_events_increasing_as_set:
  assumes "execute_step step w w'"
  shows "set (world_events w) \<subseteq> set (world_events w')"
  using assms
  apply (cases rule: execute_step.cases)
  apply auto
  done

lemma execute_step_backward_Accept:
  assumes "execute step (initialWorld W) w'" "val \<in> accepted (world_state w')"
  obtains p r s where "(p, Received r (Send s (Accept val))) \<in> set (world_events w')"
proof-
  obtain path where "execute_traced step (initialWorld W) w' path"
    using assms(1) execute_imps_trace by blast
  { fix n
    have "\<lbrakk> length path = n; execute_traced step (initialWorld W) w' path; val \<in> accepted (world_state w') \<rbrakk> \<Longrightarrow> \<exists>p r s. (p, Received r (Send s (Accept val))) \<in> set (world_events w')"
      apply (induct n arbitrary: path w')
    proof-
      fix path w'
      assume "length path = 0"
        and "execute_traced step (initialWorld W) w' path"
        and "val \<in> accepted (world_state w')"
      have "w' = initialWorld W"
        using \<open>execute_traced step (initialWorld W) w' path\<close> \<open>length path = 0\<close> execute_traced_coherence_0 by fastforce
      hence "accepted (world_state w') = {}"
        by (simp add: initialWorld_def initialState_def)
      show "\<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w')"
        using \<open>accepted (world_state w') = {}\<close> \<open>val \<in> accepted (world_state w')\<close> by blast
    next
      fix n path w'
      assume "(\<And>path w'.
           length path = n \<Longrightarrow>
           execute_traced step (initialWorld W) w' path \<Longrightarrow>
           val \<in> accepted (world_state w') \<Longrightarrow> \<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w'))"
        and "length path = Suc n" "execute_traced step (initialWorld W) w' path" "val \<in> accepted (world_state w')"
      obtain w'' path' where "path = path' @ [w'']" "length path' = n" "execute_traced step (initialWorld W) w'' path'" "execute_step step w'' w'"
        using \<open>execute_traced step (initialWorld W) w' path\<close> \<open>length path = Suc n\<close> execute_traced_coherence_Suc by blast
      have "accepted (world_state w'') \<subseteq> accepted (world_state w')"
        using \<open>execute_step step w'' w'\<close> accepted_step_monotonic by blast
      have "val \<in> accepted (world_state w'') \<or> val \<in> accepted (world_state w') - accepted (world_state w'')"
        by (simp add: \<open>val \<in> accepted (world_state w')\<close>)
      moreover have "val \<in> accepted (world_state w'') \<Longrightarrow> \<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w')"
      proof-
        have "val \<in> accepted (world_state w'') \<Longrightarrow> \<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w'')"
          using \<open>\<And>w' path. \<lbrakk>length path = n; execute_traced step (initialWorld W) w' path; val \<in> accepted (world_state w')\<rbrakk> \<Longrightarrow> \<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w')\<close> \<open>execute_traced step (initialWorld W) w'' path'\<close> \<open>length path' = n\<close> by blast
        moreover have "set (world_events w'') \<subseteq> set (world_events w')"
          using \<open>execute_step step w'' w'\<close> execute_step_events_increasing_as_set by blast
        ultimately show "val \<in> accepted (world_state w'') \<Longrightarrow> \<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w')"
          by blast
      qed
      moreover have "val \<in> accepted (world_state w') - accepted (world_state w'') \<Longrightarrow> \<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w')"
      proof-
        assume "val \<in> accepted (world_state w') - accepted (world_state w'')"
        have "execute_step step w'' w'"
          by (simp add: \<open>execute_step step w'' w'\<close>)
        obtain p r s where "world_events w' = world_events w'' @ [(p, Received r (Send s (Accept val)))]"
          by (meson \<open>execute_step step w'' w'\<close> \<open>val \<in> accepted (world_state w') - accepted (world_state w'')\<close> execute_step_accepted_change_onlyif)
        show ?thesis
          using \<open>world_events w' = world_events w'' @ [(p, Received r (Send.Send s (Accept val)))]\<close> by auto
      qed
      ultimately show "\<exists>p r s. (p, Received r (Send.Send s (Accept val))) \<in> set (world_events w')"
        by blast
    qed
  }
  thus ?thesis
    using \<open>execute_traced step (initialWorld W) w' path\<close> assms(2) that by blast
qed

(*
lemma exists_consume_queue_tasks_execution:
  obtains w' df xs where
    "execute step w w'"
    "world_events w' = world_events w @ df"
    "map snd df = Received (Worker 0) (SQSRequest (Receive 1)) # Received Queue (Send (Worker 0) (SQSResponse (Returned xs))) # []"
*)

theorem liveness:
  assumes "execute step (initialWorld W) w"
  obtains w' where "execute step w w'" "ran (messages (SQS.queue (queue (world_state w')))) = {}" "accepted (world_state w') = {0..W}"
  sorry

end


section \<open> Relation Toolkit \<close>

theory Relation_Toolkit
  imports Set_Toolkit Overriding
begin

subsection \<open> Conversions \<close>

text \<open> The majority of the relation toolkit is also part of HOL. We just need to generalise
  some of the syntax. \<close>

declare [[coercion rel_apply]]
declare [[coercion pfun_app]]
declare [[coercion pfun_of]]

text \<open> The following definition is semantically identical to @{const pfun_graph}, but is used to
  represent coercions with associated reasoning. \<close>

definition rel_of_pfun :: "'a \<Zpfun> 'b \<Rightarrow> 'a \<leftrightarrow> 'b" ("[_]\<^sub>\<Zpfun>") where
[code_unfold]: "rel_of_pfun = pfun_graph"

declare [[coercion rel_of_pfun]]
declare [[coercion pfun_of_pinj]]

notation pfun_of_pinj ("[_]\<^sub>\<Zpinj>")

subsection \<open> First component projection \<close>

text \<open> Z supports n-ary Cartesian products. We cannot support such structures directly in
  Isabelle/HOL, but instead add the projection notations for the first and second components.
  A homogeneous finite Cartesian product type also exists in the Multivariate Analysis package. \<close>

abbreviation (input) "first \<equiv> fst"
notation first ("_.1" [999] 999)

subsection \<open> Second component projection \<close>

abbreviation (input) "second \<equiv> snd"
notation second ("_.2" [999] 999)

subsection \<open> Maplet \<close>

subsection \<open> Domain \<close>

hide_const (open) dom

consts dom :: "'f \<Rightarrow> 'a set"

adhoc_overloading
  dom Map.dom and
  dom Relation.Domain and
  dom Partial_Fun.pdom and
  dom Finite_Fun.fdom and
  dom Partial_Inj.pidom

subsection \<open> Range \<close>

hide_const (open) ran

consts ran :: "'f \<Rightarrow> 'a set"

adhoc_overloading
  ran Map.ran and
  ran Relation.Range and
  ran Partial_Fun.pran and
  ran Finite_Fun.fran and
  ran Partial_Inj.piran

subsection \<open> Identity relation \<close>

notation Id_on ("id[_]")

subsection \<open> Relational composition \<close>

notation relcomp (infixr "\<^bold>;" 75)

subsection \<open> Functional composition \<close>

text \<open> Composition is probably the most difficult of the Z functions to implement correctly. Firstly,
  the notation @{term "(\<circ>)"} is already defined for HOL functions, and we need to respect that
  in order to use the HOL library functions. Secondly, Z composition can be used to compose
  heterogeneous relations and functions, which is not easy to type infer. Consequently, we opt
  to use adhoc overloading here. \<close>

consts zcomp :: "'f \<Rightarrow> 'g \<Rightarrow> 'h"

adhoc_overloading
  zcomp Fun.comp and
  zcomp pfun_comp and
  zcomp ffun_comp

text \<open> Once we overload @{term Fun.comp}, we need to at least have output syntax set up. \<close>

notation (output) zcomp (infixl "\<circ>" 55)

bundle Z_Relation_Syntax
begin

no_notation Fun.comp (infixl "\<circ>" 55)
notation zcomp (infixl "\<circ>" 55)

end

subsection \<open> Domain restriction and subtraction \<close>

consts dom_res :: "'a set \<Rightarrow> 'r \<Rightarrow> 'r" (infixr "\<Zdres>" 85)

abbreviation ndres (infixr "\<Zndres>" 85) where "ndres A P \<equiv> CONST dom_res (- A) P"

adhoc_overloading
  dom_res rel_domres
  and dom_res pdom_res
  and dom_res fdom_res
  and dom_res pinj_dres

syntax "_ndres" :: "logic \<Rightarrow> logic \<Rightarrow> logic"
translations "_ndres A P" == "CONST dom_res (- A) P"

subsection \<open> Range restriction and subtraction \<close>

consts ran_res :: "'r \<Rightarrow> 'a set \<Rightarrow> 'r" (infixl "\<Zrres>" 86)

abbreviation nrres (infixl "\<Znrres>" 86) where "nrres P A \<equiv> CONST ran_res P (- A)"

adhoc_overloading
  ran_res rel_ranres
  and ran_res pran_res
  and ran_res fran_res
  and ran_res pinj_rres

subsection \<open> Relational inversion \<close>

notation converse ("(_\<^sup>\<sim>)" [1000] 999)

lemma relational_inverse: "r\<^sup>\<sim> = {(p.2, p.1) | p. p \<in> r}"
  by auto

subsection \<open> Relational image \<close>

notation Image ("_\<lparr>_\<rparr>" [990] 990)

lemma Image_eq: "Image r a = {p.2 | p. p \<in> r \<and> p.1 \<in> a}"
  by (auto simp add: Image_def)

subsection \<open> Overriding \<close>

lemma dom_override: "dom ((Q :: 'a \<leftrightarrow> 'b) \<oplus> R) = (dom Q) \<union> (dom R)"
  by (simp add: Un_Int_distrib2)

lemma override_Un: "dom Q \<inter> dom R = {} \<Longrightarrow> Q \<oplus> R = Q \<union> R"
  by (simp add: override_eq Int_commute rel_domres_compl_disj)

subsection \<open> Proof Support \<close>

text \<open> The objective of these laws is to, as much as possible, convert relational constructions
  into functional ones. The benefit is better proof automation in the more type constrained setting. \<close>

lemma rel_of_pfun_eq_iff [simp]: "[f]\<^sub>\<Zpfun> = [g]\<^sub>\<Zpfun> \<longleftrightarrow> f = g"
  by (simp add: pfun_eq_graph rel_of_pfun_def)

lemma rel_of_pfun_le_iff [simp]: "[f]\<^sub>\<Zpfun> \<subseteq> [g]\<^sub>\<Zpfun> \<longleftrightarrow> f \<le> g"
  by (simp add: pfun_graph_le_iff rel_of_pfun_def)

lemma rel_of_pfun_pabs: "[pabs A P f]\<^sub>\<Zpfun> = {(k, v). k \<in> A \<and> P k \<and> v = f k}"
  by (simp add: rel_of_pfun_def pfun_graph_pabs)

lemma rel_of_pfun_apply [simp]: "[f]\<^sub>\<Zpfun> x = f x"
  by (simp add: rel_of_pfun_def)

lemma rel_of_pfun_functional [simp]: "functional [f]\<^sub>\<Zpfun>"
  by (simp add: rel_of_pfun_def)

lemma rel_of_pfun_override [simp]: "[f]\<^sub>\<Zpfun> \<oplus> [g]\<^sub>\<Zpfun> = [f \<oplus> g]\<^sub>\<Zpfun>"
  by (simp add: pfun_graph_override rel_of_pfun_def)

lemma rel_of_pfun_comp [simp]: "[f]\<^sub>\<Zpfun> O [g]\<^sub>\<Zpfun> = [g \<circ>\<^sub>p f]\<^sub>\<Zpfun>"
  by (simp add: pfun_graph_comp rel_of_pfun_def)

lemma pfun_comp_inv: "[f \<circ>\<^sub>p g]\<^sub>\<Zpfun>\<^sup>\<sim> = [f]\<^sub>\<Zpfun>\<^sup>\<sim> O [g]\<^sub>\<Zpfun>\<^sup>\<sim>"
  by (metis converse_relcomp rel_of_pfun_comp)

lemma rel_of_pfun_dom [simp]: "Domain [f]\<^sub>\<Zpfun> = pdom f"
  by (simp add: Dom_pfun_graph rel_of_pfun_def)

lemma rel_of_pfun_ran [simp]: "Range [f]\<^sub>\<Zpfun> = pran f"
  by (simp add: Range_pfun_graph rel_of_pfun_def)

lemma rel_of_pfun_domres [simp]: "A \<Zdres> [f]\<^sub>\<Zpfun> = [A \<Zdres> f]\<^sub>\<Zpfun>"
  by (simp add: pfun_graph_domres rel_of_pfun_def)

lemma rel_of_pfun_ranres [simp]: "[f]\<^sub>\<Zpfun> \<Zrres> A = [f \<Zrres> A]\<^sub>\<Zpfun>"
  by (simp add: rel_of_pfun_def pfun_graph_rres)

lemma rel_of_pfun_image [simp]: "[f]\<^sub>\<Zpfun> \<lparr> A \<rparr> = pfun_image f A"
  by (simp add: Image_as_rel_domres)

lemma rel_of_pfun_member_iff [simp]:
  "(k, v) \<in> [f]\<^sub>\<Zpfun> \<longleftrightarrow> (k \<in> dom f \<and> f k = v)"
  by (simp add: rel_of_pfun_def)

lemma rel_of_pinj_conv [simp]: "[[f]\<^sub>\<Zpinj>]\<^sub>\<Zpfun>\<inverse> = [[pinv f]\<^sub>\<Zpinj>]\<^sub>\<Zpfun>"
  by (simp add: pfun_graph_pfun_inv pinv.rep_eq rel_of_pfun_def)

lemma dom_pinv [simp]: "dom [pinv f]\<^sub>\<Zpinj> = ran [f]\<^sub>\<Zpinj>"
  by (simp add: pinv.rep_eq)

lemma ran_pinv [simp]: "ran [pinv f]\<^sub>\<Zpinj> = dom [f]\<^sub>\<Zpinj>"
  by (metis dom_pinv pinv_pinv)

lemma pfun_inj_rel_conv [simp]: "pfun_inj f \<Longrightarrow> [f]\<^sub>\<Zpfun>\<^sup>\<sim> = [pfun_inv f]\<^sub>\<Zpfun>"
  by (simp add: pfun_graph_pfun_inv rel_of_pfun_def)

end


theory  Correspondence_theory2  imports DDLE
begin  (*System F *)
lemma limited_corresponds_to_Dstar:
 "(\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<longleftrightarrow> (\<forall>\<Phi> \<Psi>. \<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>>  \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>)"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddevalid_def  sledgehammer
  by auto

(*System G  *)
lemma limited_trans_corresponds_to_SP_Dstar_1:
 "((\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<and> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))
  \<longrightarrow>
  ((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
  sledgehammer by smt oops  (* this direction is provable *)

lemma limited_trans_corresponds_to_SP_Dstar_2: (* this is still too hard for the ATPs *)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow>
  ((\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x)) \<and> (\<forall>x y z. (x r y \<and> y r z) \<longrightarrow> x r z))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
  sledgehammer

lemma limited_trans_corresponds_to_SP_Dstar_2a: (* splitting the conjunct, limitednedd is easy for the ATPs*)
 "((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>))
  \<longrightarrow>
  (\<forall>\<phi>. (\<exists>x. (\<phi>)x) \<longrightarrow> (\<exists>x. opt<\<phi>>x))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def ddeopt_def
  sledgehammer by auto
(*
(\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow> (\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>
*)
lemma limited_trans_corresponds_to_SP_Dstar_2b: (* splitting the conjunct, transitivity is too hard for the ATPs*)
 "(\<forall>x y z. ((\<forall>\<Phi> \<Psi> \<chi>.\<lfloor>(\<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>> \<^bold>\<and> \<circle><\<Psi>\<^bold>\<rightarrow>\<chi>|\<Phi>>) \<^bold>\<rightarrow> \<circle><\<chi>|\<Phi>\<^bold>\<and>\<Psi>>\<rfloor>) \<and> (\<forall>\<Phi> \<Psi>.\<lfloor>\<diamond>\<Phi> \<^bold>\<rightarrow>(\<circle><\<Psi>|\<Phi>> \<^bold>\<rightarrow> \<^bold>\<not>\<circle><\<^bold>\<not>\<Psi>|\<Phi>>)\<rfloor>)\<and> (x r y \<and> y r z))
  \<longrightarrow>
  (x r z))"
  unfolding ddecond_def ddediomond_def ddeimp_def ddeneg_def ddeand_def ddevalid_def sledgehammer
(*
  sledgehammer () nitpick nunchaku
  sledgehammer [timeout=600, remote_leo2 remote_leo3 remote_satallax] ()
   by smt
*)

  (* this direction unfortunately not yet, but we also do not get a countermodel; proof might be to hard *)

(*** end of header part ***)

end


(*<*)
theory BD_Security_Triggers
  imports BD_Security_TS
begin
(*>*)

subsection \<open>Trigger-preserving BD security\<close>

text \<open>Section 3.3 of \<^cite>\<open>"cosmed-jar2018"\<close> gives a recipe for incorporating declassification
triggers into the bound, and discusses the question whether this is always possible without loss of
generality, giving a partially positive answer:  the transformed security property is equivalent to
a slightly strengthened version of the original one.\<close>

subsubsection \<open>Definition\<close>

context Abstract_BD_Security
begin

text \<open>The strengthened variant of BD Security is called \<^emph>\<open>trigger-preserving\<close> in
\<^cite>\<open>"cosmed-jar2018"\<close>, because the difference to regular BD Security is that the (non-firing of
the) declassification trigger in the original trace is preserved in alternative traces.\<close>

definition secureTT :: bool where
"secureTT \<equiv>
 \<forall>tr vl vl1.
   validSystemTrace tr \<and> TT tr \<and> B vl vl1 \<and> V tr = vl \<longrightarrow>
   (\<exists>tr1. validSystemTrace tr1 \<and> TT tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1)"

text \<open>This indeed strengthens the original notion of BD Security.\<close>

lemma secureTT_secure: "secureTT \<Longrightarrow> secure"
  unfolding secureTT_def secure_def
  by blast

lemma secureTT_E:
  assumes "secureTT"
  and "validSystemTrace tr" and "TT tr" and "B vl vl1" and "V tr = vl"
  obtains tr1 where "validSystemTrace tr1" and "TT tr1" and "O tr1 = O tr" and "V tr1 = vl1"
  using assms unfolding secureTT_def
  by blast

lemma secure_E:
  assumes "secure"
  and "validSystemTrace tr" and "TT tr" and "B vl vl1" and "V tr = vl"
  obtains tr1 where "validSystemTrace tr1" and "O tr1 = O tr" and "V tr1 = vl1"
  using assms unfolding secure_def
  by blast

end

subsubsection \<open>Incorporating static triggers into the bound\<close>

text \<open>By making transitions that fire the trigger emit a dedicated secret value (here \<^term>\<open>None\<close>),
the (non-firing of the) trigger can be incorporated into the bound.\<close>

locale BD_Security_TS_Triggerless = Orig: BD_Security_TS
begin

abbreviation "\<phi>' trn \<equiv> \<phi> trn \<or> T trn"

abbreviation "f' trn \<equiv> (if T trn then None else Some (f trn))"

abbreviation "T' trn \<equiv> False"

abbreviation "B' vl' vl1' \<equiv> B (these vl') (these vl1') \<and> never Option.is_none vl' \<and> never Option.is_none vl1'"

sublocale Prime?: BD_Security_TS where \<phi> = \<phi>' and f = f' and T = T' and B = B' .

lemma map_Some_these: "never Option.is_none xs \<Longrightarrow> map Some (these xs) = xs"
proof (induction xs)
  case (Cons x xs) then show ?case by (cases x) auto
qed auto

lemma V'_never_none_T[simp]: "Prime.V tr = vl \<Longrightarrow> never Option.is_none vl \<longleftrightarrow> never T tr"
proof (induction tr arbitrary: vl)
  case (Cons trn tr) then show ?case by (cases "\<phi>' trn") auto
qed auto

lemma V'_V: "never T tr \<longleftrightarrow> Prime.V tr = map Some (Orig.V tr)"
proof (induction tr)
  case (Cons trn tr) then show ?case by (cases "\<phi>' trn") auto
qed auto

lemma V_Some_never_T: "Prime.V tr = map Some vl \<Longrightarrow> never T tr"
proof (induction tr arbitrary: vl)
  case (Cons trn tr) then show ?case by (cases "\<phi>' trn") auto
qed auto

text \<open>In the modified setup, the notions of trigger-preserving and original BD Security coincide
due to the trigger being vacuously false.\<close>

lemma secureTT_iff_secure: "Prime.secureTT \<longleftrightarrow> Prime.secure"
  unfolding secureTT_def secure_def
  by (auto simp: list_all_iff)

text \<open>The modified property is equivalent to trigger-preserving BD Security in the original setup
\<^cite>\<open>\<open>Proposition 2\<close> in "cosmed-jar2018"\<close>.\<close>

lemma secureTT_iff_secure': "Orig.secureTT \<longleftrightarrow> Prime.secure"
proof
  assume secure: "Orig.secureTT"
  then show "Prime.secure"
  proof (unfold Prime.secure_def, intro allI impI, elim conjE)
    fix tr vl vl1
    assume tr: "Orig.validFrom istate tr" and V: "V tr = vl" and B: "B (these vl) (these vl1)"
       and vl: "never Option.is_none vl" and vl1: "never Option.is_none vl1"
    with secure obtain tr1 where "Orig.validFrom istate tr1" and "never T tr1"
                             and "Prime.O tr1 = Prime.O tr" and "Orig.V tr1 = these vl1"
      by (elim Orig.secureTT_E) (auto simp: V'_V)
    then show "\<exists>tr1. Orig.validFrom istate tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1" using vl1
      by (intro exI[of _ tr1]) (auto simp: V'_V map_Some_these iff: list_all_iff)
  qed
next
  assume secure': "Prime.secure"
  then show "Orig.secureTT"
  proof (unfold Orig.secureTT_def, intro allI impI, elim conjE)
    fix tr vl vl1
    assume "Orig.validFrom istate tr" and "never T tr" and "B vl vl1" and "Orig.V tr = vl"
    with secure' obtain tr1 where "Orig.validFrom istate tr1" and "Prime.O tr1 = Prime.O tr"
                              and V: "Prime.V tr1 = map Some vl1"
      by (elim Prime.secure_E) (auto iff: V'_V list_all_iff)
    moreover have "never T tr1" using V by (intro V_Some_never_T)
    ultimately show "\<exists>tr1. Orig.validFrom istate tr1 \<and> never T tr1 \<and> O tr1 = O tr \<and> Orig.V tr1 = vl1"
      by (intro exI[of _ tr1]) (auto simp: V'_V)
  qed
qed

text \<open>The modified property also strengthens the regular notion of BD Security in the original
setup \<^cite>\<open>\<open>Proposition 1\<close> in "cosmed-jar2018"\<close>.\<close>

lemma secure'_secure: "Prime.secure \<Longrightarrow> Orig.secure"
  using secureTT_iff_secure' Orig.secureTT_secure
  by simp

end

subsubsection \<open>Reflexive-transitive closure of declassification bounds\<close>

text \<open>Another property of trigger-preserving BD Security is that security w.r.t. an arbitrary bound
\<^term>\<open>B\<close> is equivalent to security w.r.t. its reflexive-transitive closure \<^term>\<open>B\<^sup>*\<^sup>*\<close>
\<^cite>\<open>\<open>Proposition 3\<close> in "cosmed-jar2018"\<close>.\<close>

locale Abstract_BD_Security_Transitive_Closure = Orig: Abstract_BD_Security
begin

sublocale Prime?: Abstract_BD_Security where B = "B\<^sup>*\<^sup>*" .

lemma secureTT_iff_secureTT': "Orig.secureTT \<longleftrightarrow> Prime.secureTT"
proof
  assume "Orig.secureTT"
  then show "Prime.secureTT"
  proof (unfold Prime.secureTT_def, intro allI impI, elim conjE)
    fix tr vl vl1
    assume tr: "validSystemTrace tr" and TT: "TT tr" and B: "B\<^sup>*\<^sup>* vl vl1" and V: "V tr = vl"
    from B show "\<exists>tr1. validSystemTrace tr1 \<and> TT tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1"
    proof (induction rule: rtranclp_induct)
      case base
      show "\<exists>tr1. validSystemTrace tr1 \<and> TT tr1 \<and> O tr1 = O tr \<and> V tr1 = vl"
        using tr TT V
        by (intro exI[where x = tr]) auto
    next
      case (step vl' vl1')
      then obtain tr1
        where tr1: "validSystemTrace tr1" "TT tr1" and O1: "O tr1 = O tr" and V1: "V tr1 = vl'"
        by blast
      show "\<exists>tr1. validSystemTrace tr1 \<and> TT tr1 \<and> O tr1 = O tr \<and> V tr1 = vl1'"
        by (rule Orig.secureTT_E[OF \<open>Orig.secureTT\<close> tr1 \<open>B vl' vl1'\<close> V1]) (use O1 V in auto)
    qed
  qed
next
  assume "Prime.secureTT"
  then show "Orig.secureTT"
    unfolding Prime.secureTT_def Orig.secureTT_def
    by blast
qed

end

(*<*)
end
(*>*)