(*
    Author:   Benedikt Seidl
    Author:   Salomon Sickert
    License:  BSD
*)

section \<open>Advice functions\<close>

theory Advice
imports
  LTL.LTL LTL.Equivalence_Relations
  Syntactic_Fragments_and_Stability After
begin

subsection \<open>The GF and FG Advice Functions\<close>

fun GF_advice :: "'a ltln \<Rightarrow> 'a ltln set \<Rightarrow> 'a ltln" ("_[_]\<^sub>\<nu>" [90,60] 89)
  where
  "(X\<^sub>n \<psi>)[X]\<^sub>\<nu> = X\<^sub>n (\<psi>[X]\<^sub>\<nu>)"
| "(\<psi>\<^sub>1 and\<^sub>n \<psi>\<^sub>2)[X]\<^sub>\<nu> = (\<psi>\<^sub>1[X]\<^sub>\<nu>) and\<^sub>n (\<psi>\<^sub>2[X]\<^sub>\<nu>)"
| "(\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)[X]\<^sub>\<nu> = (\<psi>\<^sub>1[X]\<^sub>\<nu>) or\<^sub>n (\<psi>\<^sub>2[X]\<^sub>\<nu>)"
| "(\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2)[X]\<^sub>\<nu> = (\<psi>\<^sub>1[X]\<^sub>\<nu>) W\<^sub>n (\<psi>\<^sub>2[X]\<^sub>\<nu>)"
| "(\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2)[X]\<^sub>\<nu> = (\<psi>\<^sub>1[X]\<^sub>\<nu>) R\<^sub>n (\<psi>\<^sub>2[X]\<^sub>\<nu>)"
| "(\<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2)[X]\<^sub>\<nu> = (if (\<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2) \<in> X then (\<psi>\<^sub>1[X]\<^sub>\<nu>) W\<^sub>n (\<psi>\<^sub>2[X]\<^sub>\<nu>) else false\<^sub>n)"
| "(\<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2)[X]\<^sub>\<nu> = (if (\<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2) \<in> X then (\<psi>\<^sub>1[X]\<^sub>\<nu>) R\<^sub>n (\<psi>\<^sub>2[X]\<^sub>\<nu>) else false\<^sub>n)"
| "\<phi>[_]\<^sub>\<nu> = \<phi>"

fun FG_advice :: "'a ltln \<Rightarrow> 'a ltln set \<Rightarrow> 'a ltln" ("_[_]\<^sub>\<mu>" [90,60] 89)
where
  "(X\<^sub>n \<psi>)[Y]\<^sub>\<mu> = X\<^sub>n (\<psi>[Y]\<^sub>\<mu>)"
| "(\<psi>\<^sub>1 and\<^sub>n \<psi>\<^sub>2)[Y]\<^sub>\<mu> = (\<psi>\<^sub>1[Y]\<^sub>\<mu>) and\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
| "(\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2)[Y]\<^sub>\<mu> = (\<psi>\<^sub>1[Y]\<^sub>\<mu>) or\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
| "(\<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2)[Y]\<^sub>\<mu> = (\<psi>\<^sub>1[Y]\<^sub>\<mu>) U\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
| "(\<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2)[Y]\<^sub>\<mu> = (\<psi>\<^sub>1[Y]\<^sub>\<mu>) M\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>)"
| "(\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2)[Y]\<^sub>\<mu> = (if (\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2) \<in> Y then true\<^sub>n else (\<psi>\<^sub>1[Y]\<^sub>\<mu>) U\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>))"
| "(\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2)[Y]\<^sub>\<mu> = (if (\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2) \<in> Y then true\<^sub>n else (\<psi>\<^sub>1[Y]\<^sub>\<mu>) M\<^sub>n (\<psi>\<^sub>2[Y]\<^sub>\<mu>))"
| "\<phi>[_]\<^sub>\<mu> = \<phi>"

lemma GF_advice_\<nu>LTL:
  "\<phi>[X]\<^sub>\<nu> \<in> \<nu>LTL"
  "\<phi> \<in> \<nu>LTL \<Longrightarrow> \<phi>[X]\<^sub>\<nu> = \<phi>"
  by (induction \<phi>) auto

lemma FG_advice_\<mu>LTL:
  "\<phi>[X]\<^sub>\<mu> \<in> \<mu>LTL"
  "\<phi> \<in> \<mu>LTL \<Longrightarrow> \<phi>[X]\<^sub>\<mu> = \<phi>"
  by (induction \<phi>) auto

lemma GF_advice_subfrmlsn:
  "subfrmlsn (\<phi>[X]\<^sub>\<nu>) \<subseteq> {\<psi>[X]\<^sub>\<nu> | \<psi>. \<psi> \<in> subfrmlsn \<phi>}"
  by (induction \<phi>) force+

lemma FG_advice_subfrmlsn:
  "subfrmlsn (\<phi>[Y]\<^sub>\<mu>) \<subseteq> {\<psi>[Y]\<^sub>\<mu> | \<psi>. \<psi> \<in> subfrmlsn \<phi>}"
  by (induction \<phi>) force+

lemma GF_advice_subfrmlsn_card:
  "card (subfrmlsn (\<phi>[X]\<^sub>\<nu>)) \<le> card (subfrmlsn \<phi>)"
proof -
  have "card (subfrmlsn (\<phi>[X]\<^sub>\<nu>)) \<le> card {\<psi>[X]\<^sub>\<nu> | \<psi>. \<psi> \<in> subfrmlsn \<phi>}"
    by (simp add: subfrmlsn_finite GF_advice_subfrmlsn card_mono)

  also have "\<dots> \<le> card (subfrmlsn \<phi>)"
    by (metis Collect_mem_eq card_image_le image_Collect subfrmlsn_finite)

  finally show ?thesis .
qed

lemma FG_advice_subfrmlsn_card:
  "card (subfrmlsn (\<phi>[Y]\<^sub>\<mu>)) \<le> card (subfrmlsn \<phi>)"
proof -
  have "card (subfrmlsn (\<phi>[Y]\<^sub>\<mu>)) \<le> card {\<psi>[Y]\<^sub>\<mu> | \<psi>. \<psi> \<in> subfrmlsn \<phi>}"
    by (simp add: subfrmlsn_finite FG_advice_subfrmlsn card_mono)

  also have "\<dots> \<le> card (subfrmlsn \<phi>)"
    by (metis Collect_mem_eq card_image_le image_Collect subfrmlsn_finite)

  finally show ?thesis .
qed

lemma GF_advice_monotone:
  "X \<subseteq> Y \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[Y]\<^sub>\<nu>"
proof (induction \<phi> arbitrary: w)
  case (Until_ltln \<phi> \<psi>)
  then show ?case
    by (cases "\<phi> U\<^sub>n \<psi> \<in> X") (simp_all, blast)
next
  case (Release_ltln \<phi> \<psi>)
  then show ?case by (simp, blast)
next
  case (WeakUntil_ltln \<phi> \<psi>)
  then show ?case by (simp, blast)
next
  case (StrongRelease_ltln \<phi> \<psi>)
  then show ?case
    by (cases "\<phi> M\<^sub>n \<psi> \<in> X") (simp_all, blast)
qed auto

lemma FG_advice_monotone:
  "X \<subseteq> Y \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<mu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[Y]\<^sub>\<mu>"
proof (induction \<phi> arbitrary: w)
  case (Until_ltln \<phi> \<psi>)
  then show ?case by (simp, blast)
next
  case (Release_ltln \<phi> \<psi>)
  then show ?case
    by (cases "\<phi> R\<^sub>n \<psi> \<in> X") (auto, blast)
next
  case (WeakUntil_ltln \<phi> \<psi>)
  then show ?case
    by (cases "\<phi> W\<^sub>n \<psi> \<in> X") (auto, blast)
next
  case (StrongRelease_ltln \<phi> \<psi>)
  then show ?case by (simp, blast)
qed auto

lemma GF_advice_ite_simps[simp]:
  "(if P then true\<^sub>n else false\<^sub>n)[X]\<^sub>\<nu> = (if P then true\<^sub>n else false\<^sub>n)"
  "(if P then false\<^sub>n else true\<^sub>n)[X]\<^sub>\<nu> = (if P then false\<^sub>n else true\<^sub>n)"
  by simp_all

lemma FG_advice_ite_simps[simp]:
  "(if P then true\<^sub>n else false\<^sub>n)[Y]\<^sub>\<mu> = (if P then true\<^sub>n else false\<^sub>n)"
  "(if P then false\<^sub>n else true\<^sub>n)[Y]\<^sub>\<mu> = (if P then false\<^sub>n else true\<^sub>n)"
  by simp_all

subsection \<open>Advice Functions on Nested Propositions\<close>

definition nested_prop_atoms\<^sub>\<nu> :: "'a ltln \<Rightarrow> 'a ltln set \<Rightarrow> 'a ltln set"
where
  "nested_prop_atoms\<^sub>\<nu> \<phi> X = {\<psi>[X]\<^sub>\<nu> | \<psi>. \<psi> \<in> nested_prop_atoms \<phi>}"

definition nested_prop_atoms\<^sub>\<mu> :: "'a ltln \<Rightarrow> 'a ltln set \<Rightarrow> 'a ltln set"
where
  "nested_prop_atoms\<^sub>\<mu> \<phi> X = {\<psi>[X]\<^sub>\<mu> | \<psi>. \<psi> \<in> nested_prop_atoms \<phi>}"

lemma nested_prop_atoms\<^sub>\<nu>_finite:
  "finite (nested_prop_atoms\<^sub>\<nu> \<phi> X)"
  by (simp add: nested_prop_atoms\<^sub>\<nu>_def nested_prop_atoms_finite)

lemma nested_prop_atoms\<^sub>\<mu>_finite:
  "finite (nested_prop_atoms\<^sub>\<mu> \<phi> X)"
  by (simp add: nested_prop_atoms\<^sub>\<mu>_def nested_prop_atoms_finite)

lemma nested_prop_atoms\<^sub>\<nu>_card:
  "card (nested_prop_atoms\<^sub>\<nu> \<phi> X) \<le> card (nested_prop_atoms \<phi>)"
  unfolding nested_prop_atoms\<^sub>\<nu>_def
  by (metis Collect_mem_eq card_image_le image_Collect nested_prop_atoms_finite)

lemma nested_prop_atoms\<^sub>\<mu>_card:
  "card (nested_prop_atoms\<^sub>\<mu> \<phi> X) \<le> card (nested_prop_atoms \<phi>)"
  unfolding nested_prop_atoms\<^sub>\<mu>_def
  by (metis Collect_mem_eq card_image_le image_Collect nested_prop_atoms_finite)

lemma GF_advice_nested_prop_atoms\<^sub>\<nu>:
  "nested_prop_atoms (\<phi>[X]\<^sub>\<nu>) \<subseteq> nested_prop_atoms\<^sub>\<nu> \<phi> X"
  by (induction \<phi>) (unfold nested_prop_atoms\<^sub>\<nu>_def, force+)

lemma FG_advice_nested_prop_atoms\<^sub>\<mu>:
  "nested_prop_atoms (\<phi>[Y]\<^sub>\<mu>) \<subseteq> nested_prop_atoms\<^sub>\<mu> \<phi> Y"
  by (induction \<phi>) (unfold nested_prop_atoms\<^sub>\<mu>_def, force+)

lemma nested_prop_atoms\<^sub>\<nu>_subset:
  "nested_prop_atoms \<phi> \<subseteq> nested_prop_atoms \<psi> \<Longrightarrow> nested_prop_atoms\<^sub>\<nu> \<phi> X \<subseteq> nested_prop_atoms\<^sub>\<nu> \<psi> X"
  unfolding nested_prop_atoms\<^sub>\<nu>_def by blast

lemma nested_prop_atoms\<^sub>\<mu>_subset:
  "nested_prop_atoms \<phi> \<subseteq> nested_prop_atoms \<psi> \<Longrightarrow> nested_prop_atoms\<^sub>\<mu> \<phi> Y \<subseteq> nested_prop_atoms\<^sub>\<mu> \<psi> Y"
  unfolding nested_prop_atoms\<^sub>\<mu>_def by blast

lemma GF_advice_nested_prop_atoms_card:
  "card (nested_prop_atoms (\<phi>[X]\<^sub>\<nu>)) \<le> card (nested_prop_atoms \<phi>)"
proof -
  have "card (nested_prop_atoms (\<phi>[X]\<^sub>\<nu>)) \<le> card (nested_prop_atoms\<^sub>\<nu> \<phi> X)"
    by (simp add: nested_prop_atoms\<^sub>\<nu>_finite GF_advice_nested_prop_atoms\<^sub>\<nu> card_mono)

  then show ?thesis
    using nested_prop_atoms\<^sub>\<nu>_card le_trans by blast
qed

lemma FG_advice_nested_prop_atoms_card:
  "card (nested_prop_atoms (\<phi>[Y]\<^sub>\<mu>)) \<le> card (nested_prop_atoms \<phi>)"
proof -
  have "card (nested_prop_atoms (\<phi>[Y]\<^sub>\<mu>)) \<le> card (nested_prop_atoms\<^sub>\<mu> \<phi> Y)"
    by (simp add: nested_prop_atoms\<^sub>\<mu>_finite FG_advice_nested_prop_atoms\<^sub>\<mu> card_mono)

  then show ?thesis
    using nested_prop_atoms\<^sub>\<mu>_card le_trans by blast
qed

subsection \<open>Intersecting the Advice Set\<close>

lemma GF_advice_inter:
  "X \<inter> subformulas\<^sub>\<mu> \<phi> \<subseteq> S \<Longrightarrow> \<phi>[X \<inter> S]\<^sub>\<nu> = \<phi>[X]\<^sub>\<nu>"
  by (induction \<phi>) auto

lemma GF_advice_inter_subformulas:
  "\<phi>[X \<inter> subformulas\<^sub>\<mu> \<phi>]\<^sub>\<nu> = \<phi>[X]\<^sub>\<nu>"
  using GF_advice_inter by blast

lemma GF_advice_minus_subformulas:
  "\<psi> \<notin> subformulas\<^sub>\<mu> \<phi> \<Longrightarrow> \<phi>[X - {\<psi>}]\<^sub>\<nu> = \<phi>[X]\<^sub>\<nu>"
proof -
  assume "\<psi> \<notin> subformulas\<^sub>\<mu> \<phi>"
  then have "subformulas\<^sub>\<mu> \<phi> \<inter> X \<subseteq> X - {\<psi>}"
    by blast
  then show "\<phi>[X - {\<psi>}]\<^sub>\<nu> = \<phi>[X]\<^sub>\<nu>"
    by (metis GF_advice_inter Diff_subset Int_absorb1 inf.commute)
qed

lemma GF_advice_minus_size:
  "\<lbrakk>size \<phi> \<le> size \<psi>; \<phi> \<noteq> \<psi>\<rbrakk> \<Longrightarrow> \<phi>[X - {\<psi>}]\<^sub>\<nu> = \<phi>[X]\<^sub>\<nu>"
  using subfrmlsn_size subformulas\<^sub>\<mu>_subfrmlsn GF_advice_minus_subformulas
  by fastforce

lemma FG_advice_inter_subformulas:
  "\<phi>[Y \<inter> subformulas\<^sub>\<nu> \<phi>]\<^sub>\<mu> = \<phi>[Y]\<^sub>\<mu>"
  using FG_advice_inter by blast

lemma FG_advice_minus_subformulas:
  "\<psi> \<notin> subformulas\<^sub>\<nu> \<phi> \<Longrightarrow> \<phi>[Y - {\<psi>}]\<^sub>\<mu> = \<phi>[Y]\<^sub>\<mu>"
proof -
  assume "\<psi> \<notin> subformulas\<^sub>\<nu> \<phi>"
  then have "subformulas\<^sub>\<nu> \<phi> \<inter> Y \<subseteq> Y - {\<psi>}"
    by blast
  then show "\<phi>[Y - {\<psi>}]\<^sub>\<mu>  = \<phi>[Y]\<^sub>\<mu>"
    by (metis FG_advice_inter Diff_subset Int_absorb1 inf.commute)
qed

lemma FG_advice_minus_size:
  "\<lbrakk>size \<phi> \<le> size \<psi>; \<phi> \<noteq> \<psi>\<rbrakk> \<Longrightarrow> \<phi>[Y - {\<psi>}]\<^sub>\<mu> = \<phi>[Y]\<^sub>\<mu>"
  using subfrmlsn_size subformulas\<^sub>\<nu>_subfrmlsn FG_advice_minus_subformulas
  by fastforce

lemma FG_advice_insert:
  "\<lbrakk>\<psi> \<notin> Y; size \<phi> < size \<psi>\<rbrakk> \<Longrightarrow> \<phi>[insert \<psi> Y]\<^sub>\<mu> = \<phi>[Y]\<^sub>\<mu>"
  by (metis FG_advice_minus_size Diff_insert_absorb less_imp_le neq_iff)

subsection \<open>Correctness GF-advice function\<close>

lemma GF_advice_a1:
  "\<lbrakk>\<F> \<phi> w \<subseteq> X; w \<Turnstile>\<^sub>n \<phi>\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu>"
proof (induction \<phi> arbitrary: w)
  case (Next_ltln \<phi>)
  then show ?case
    using \<F>_suffix by simp blast
next
  case (Until_ltln \<phi>1 \<phi>2)

  have "\<F> (\<phi>1 W\<^sub>n \<phi>2) w \<subseteq> \<F> (\<phi>1 U\<^sub>n \<phi>2) w"
    by fastforce
  then have "\<F> (\<phi>1 W\<^sub>n \<phi>2) w \<subseteq> X" and "w \<Turnstile>\<^sub>n \<phi>1 W\<^sub>n \<phi>2"
    using Until_ltln.prems ltln_strong_to_weak by blast+
  then have "w \<Turnstile>\<^sub>n \<phi>1[X]\<^sub>\<nu> W\<^sub>n \<phi>2[X]\<^sub>\<nu>"
    using Until_ltln.IH
    by simp (meson \<F>_suffix subset_trans sup.boundedE)

  moreover

  have "w \<Turnstile>\<^sub>n \<phi>1 U\<^sub>n \<phi>2"
    using Until_ltln.prems by simp
  then have "\<phi>1 U\<^sub>n \<phi>2 \<in> \<F> (\<phi>1 U\<^sub>n \<phi>2) w"
    by force
  then have "\<phi>1 U\<^sub>n \<phi>2 \<in> X"
    using Until_ltln.prems by fast

  ultimately show ?case
    by auto
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    by simp (meson \<F>_suffix subset_trans sup.boundedE)
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)
  then show ?case
    by simp (meson \<F>_suffix subset_trans sup.boundedE)
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)

  have "\<F> (\<phi>1 R\<^sub>n \<phi>2) w \<subseteq> \<F> (\<phi>1 M\<^sub>n \<phi>2) w"
    by fastforce
  then have "\<F> (\<phi>1 R\<^sub>n \<phi>2) w \<subseteq> X" and "w \<Turnstile>\<^sub>n \<phi>1 R\<^sub>n \<phi>2"
    using StrongRelease_ltln.prems ltln_strong_to_weak by blast+
  then have "w \<Turnstile>\<^sub>n \<phi>1[X]\<^sub>\<nu> R\<^sub>n \<phi>2[X]\<^sub>\<nu>"
    using StrongRelease_ltln.IH
    by simp (meson \<F>_suffix subset_trans sup.boundedE)

  moreover

  have "w \<Turnstile>\<^sub>n \<phi>1 M\<^sub>n \<phi>2"
    using StrongRelease_ltln.prems by simp
  then have "\<phi>1 M\<^sub>n \<phi>2 \<in> \<F> (\<phi>1 M\<^sub>n \<phi>2) w"
    by force
  then have "\<phi>1 M\<^sub>n \<phi>2 \<in> X"
    using StrongRelease_ltln.prems by fast

  ultimately show ?case
    by auto
qed auto

lemma GF_advice_a2_helper:
  "\<lbrakk>\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>); w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu>\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case (Next_ltln \<phi>)
  then show ?case
    unfolding GF_advice.simps semantics_ltln.simps(7)
    using GF_suffix by blast
next
  case (Until_ltln \<phi>1 \<phi>2)

  then have "\<phi>1 U\<^sub>n \<phi>2 \<in> X"
    using ccontr[of "\<phi>1 U\<^sub>n \<phi>2 \<in> X"] by force
  then have "w \<Turnstile>\<^sub>n F\<^sub>n \<phi>2"
    using Until_ltln.prems by fastforce

  moreover

  have "w \<Turnstile>\<^sub>n (\<phi>1 U\<^sub>n \<phi>2)[X]\<^sub>\<nu>"
    using Until_ltln.prems by simp
  then have "w \<Turnstile>\<^sub>n (\<phi>1[X]\<^sub>\<nu>) W\<^sub>n (\<phi>2[X]\<^sub>\<nu>)"
    unfolding GF_advice.simps using `\<phi>1 U\<^sub>n \<phi>2 \<in> X` by simp
  then have "w \<Turnstile>\<^sub>n \<phi>1 W\<^sub>n \<phi>2"
    unfolding GF_advice.simps semantics_ltln.simps(10)
    by (metis GF_suffix Until_ltln.IH Until_ltln.prems(1))

  ultimately show ?case
    using ltln_weak_to_strong by blast
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding GF_advice.simps semantics_ltln.simps(9)
    by (metis GF_suffix Release_ltln.IH Release_ltln.prems(1))
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding GF_advice.simps semantics_ltln.simps(10)
    by (metis GF_suffix)
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)

  then have "\<phi>1 M\<^sub>n \<phi>2 \<in> X"
    using ccontr[of "\<phi>1 M\<^sub>n \<phi>2 \<in> X"] by force
  then have "w \<Turnstile>\<^sub>n F\<^sub>n \<phi>1"
    using StrongRelease_ltln.prems by fastforce

  moreover

  have "w \<Turnstile>\<^sub>n (\<phi>1 M\<^sub>n \<phi>2)[X]\<^sub>\<nu>"
    using StrongRelease_ltln.prems by simp
  then have "w \<Turnstile>\<^sub>n (\<phi>1[X]\<^sub>\<nu>) R\<^sub>n (\<phi>2[X]\<^sub>\<nu>)"
    unfolding GF_advice.simps using `\<phi>1 M\<^sub>n \<phi>2 \<in> X` by simp
  then have "w \<Turnstile>\<^sub>n \<phi>1 R\<^sub>n \<phi>2"
    unfolding GF_advice.simps semantics_ltln.simps(9)
    by (metis GF_suffix StrongRelease_ltln.IH StrongRelease_ltln.prems(1))

  ultimately show ?case
    using ltln_weak_to_strong by blast
qed auto

lemma GF_advice_a2:
  "\<lbrakk>X \<subseteq> \<G>\<F> \<phi> w; w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu>\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  by (metis GF_advice_a2_helper \<G>\<F>_elim subset_eq)

lemma GF_advice_a3:
  "\<lbrakk>X = \<F> \<phi> w; X = \<G>\<F> \<phi> w\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu>"
  using GF_advice_a1 GF_advice_a2 by fastforce

subsection \<open>Correctness FG-advice function\<close>

lemma FG_advice_b1:
  "\<lbrakk>\<F>\<G> \<phi> w \<subseteq> Y; w \<Turnstile>\<^sub>n \<phi>\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[Y]\<^sub>\<mu>"
proof (induction \<phi> arbitrary: w)
  case (Next_ltln \<phi>)
  then show ?case
    using \<F>\<G>_suffix by simp blast
next
  case (Until_ltln \<phi>1 \<phi>2)
  then show ?case
    by simp (metis \<F>\<G>_suffix)
next
  case (Release_ltln \<phi>1 \<phi>2)

  show ?case
  proof (cases "\<phi>1 R\<^sub>n \<phi>2 \<in> Y")
    case False
    then have "\<phi>1 R\<^sub>n \<phi>2 \<notin> \<F>\<G> (\<phi>1 R\<^sub>n \<phi>2) w"
      using Release_ltln.prems by blast
    then have "\<not> w \<Turnstile>\<^sub>n G\<^sub>n \<phi>2"
      by fastforce
    then have "w \<Turnstile>\<^sub>n \<phi>1 M\<^sub>n \<phi>2"
      using Release_ltln.prems ltln_weak_to_strong by blast

    moreover

    have "\<F>\<G> (\<phi>1 M\<^sub>n \<phi>2) w \<subseteq> \<F>\<G> (\<phi>1 R\<^sub>n \<phi>2) w"
      by fastforce
    then have "\<F>\<G> (\<phi>1 M\<^sub>n \<phi>2) w \<subseteq> Y"
      using Release_ltln.prems by blast

    ultimately show ?thesis
      using Release_ltln.IH by simp (metis \<F>\<G>_suffix)
  qed simp
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)

  show ?case
  proof (cases "\<phi>1 W\<^sub>n \<phi>2 \<in> Y")
    case False
    then have "\<phi>1 W\<^sub>n \<phi>2 \<notin> \<F>\<G> (\<phi>1 W\<^sub>n \<phi>2) w"
      using WeakUntil_ltln.prems by blast
    then have "\<not> w \<Turnstile>\<^sub>n G\<^sub>n \<phi>1"
      by fastforce
    then have "w \<Turnstile>\<^sub>n \<phi>1 U\<^sub>n \<phi>2"
      using WeakUntil_ltln.prems ltln_weak_to_strong by blast

    moreover

    have "\<F>\<G> (\<phi>1 U\<^sub>n \<phi>2) w \<subseteq> \<F>\<G> (\<phi>1 W\<^sub>n \<phi>2) w"
      by fastforce
    then have "\<F>\<G> (\<phi>1 U\<^sub>n \<phi>2) w \<subseteq> Y"
      using WeakUntil_ltln.prems by blast

    ultimately show ?thesis
      using WeakUntil_ltln.IH by simp (metis \<F>\<G>_suffix)
  qed simp
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)
  then show ?case
    by simp (metis \<F>\<G>_suffix)
qed auto

lemma FG_advice_b2_helper:
  "\<lbrakk>\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n G\<^sub>n \<psi>; w \<Turnstile>\<^sub>n \<phi>[Y]\<^sub>\<mu>\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
proof (induction \<phi> arbitrary: w)
  case (Until_ltln \<phi>1 \<phi>2)
  then show ?case
    by simp (metis (no_types, lifting) suffix_suffix)
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
  proof (cases "\<phi>1 R\<^sub>n \<phi>2 \<in> Y")
    case True
    then show ?thesis
      using Release_ltln.prems by force
  next
    case False
    then have "w \<Turnstile>\<^sub>n (\<phi>1[Y]\<^sub>\<mu>) M\<^sub>n (\<phi>2[Y]\<^sub>\<mu>)"
      using Release_ltln.prems by simp
    then have "w \<Turnstile>\<^sub>n \<phi>1 M\<^sub>n \<phi>2"
      using Release_ltln
      by simp (metis (no_types, lifting) suffix_suffix)
    then show ?thesis
      using ltln_strong_to_weak by fast
  qed
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)
  then show ?case
  proof (cases "\<phi>1 W\<^sub>n \<phi>2 \<in> Y")
    case True
    then show ?thesis
      using WeakUntil_ltln.prems by force
  next
    case False
    then have "w \<Turnstile>\<^sub>n (\<phi>1[Y]\<^sub>\<mu>) U\<^sub>n (\<phi>2[Y]\<^sub>\<mu>)"
      using WeakUntil_ltln.prems by simp
    then have "w \<Turnstile>\<^sub>n \<phi>1 U\<^sub>n \<phi>2"
      using WeakUntil_ltln
      by simp (metis (no_types, lifting) suffix_suffix)
    then show ?thesis
      using ltln_strong_to_weak by fast
  qed
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)
  then show ?case
    by simp (metis (no_types, lifting) suffix_suffix)
qed auto

lemma FG_advice_b2:
  "\<lbrakk>Y \<subseteq> \<G> \<phi> w; w \<Turnstile>\<^sub>n \<phi>[Y]\<^sub>\<mu>\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  by (metis FG_advice_b2_helper \<G>_elim subset_eq)

lemma FG_advice_b3:
  "\<lbrakk>Y = \<F>\<G> \<phi> w; Y = \<G> \<phi> w\<rbrakk> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>[Y]\<^sub>\<mu>"
  using FG_advice_b1 FG_advice_b2 by fastforce

subsection \<open>Advice Functions and the ``after'' Function\<close>

lemma GF_advice_af_letter:
  "(x ## w) \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu> \<Longrightarrow> w \<Turnstile>\<^sub>n (af_letter \<phi> x)[X]\<^sub>\<nu>"
proof (induction \<phi>)
  case (Until_ltln \<phi>1 \<phi>2)

  then have "w \<Turnstile>\<^sub>n af_letter ((\<phi>1 U\<^sub>n \<phi>2)[X]\<^sub>\<nu>) x"
    using af_letter_build by blast

  then show ?case
    using Until_ltln.IH af_letter_build by fastforce
next
  case (Release_ltln \<phi>1 \<phi>2)

  then have "w \<Turnstile>\<^sub>n af_letter ((\<phi>1 R\<^sub>n \<phi>2)[X]\<^sub>\<nu>) x"
    using af_letter_build by blast

  then show ?case
    using Release_ltln.IH af_letter_build by auto
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)

  then have "w \<Turnstile>\<^sub>n af_letter ((\<phi>1 W\<^sub>n \<phi>2)[X]\<^sub>\<nu>) x"
    using af_letter_build by blast

  then show ?case
    using WeakUntil_ltln.IH af_letter_build by auto
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)

  then have "w \<Turnstile>\<^sub>n af_letter ((\<phi>1 M\<^sub>n \<phi>2)[X]\<^sub>\<nu>) x"
    using af_letter_build by blast

  then show ?case
    using StrongRelease_ltln.IH af_letter_build by force
qed auto

lemma FG_advice_af_letter:
  "w \<Turnstile>\<^sub>n (af_letter \<phi> x)[Y]\<^sub>\<mu> \<Longrightarrow> (x ## w) \<Turnstile>\<^sub>n \<phi>[Y]\<^sub>\<mu>"
proof (induction \<phi>)
  case (Prop_ltln a)
  then show ?case
    using semantics_ltln.simps(3) by fastforce
next
  case (Until_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding af_letter.simps FG_advice.simps semantics_ltln.simps(5,6)
    using af_letter_build apply (cases "w \<Turnstile>\<^sub>n af_letter \<phi>2 x[Y]\<^sub>\<mu>") apply force
    by (metis af_letter.simps(8) semantics_ltln.simps(5) semantics_ltln.simps(6))
next
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    apply (cases "\<phi>1 R\<^sub>n \<phi>2 \<in> Y")
    apply simp
    unfolding af_letter.simps FG_advice.simps semantics_ltln.simps(5,6)
    using af_letter_build  apply (cases "w \<Turnstile>\<^sub>n af_letter \<phi>1 x[Y]\<^sub>\<mu>") apply force
    by (metis (full_types) af_letter.simps(11) semantics_ltln.simps(5) semantics_ltln.simps(6))
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)
  then show ?case
    apply (cases "\<phi>1 W\<^sub>n \<phi>2 \<in> Y")
    apply simp
    unfolding af_letter.simps FG_advice.simps semantics_ltln.simps(5,6)
    using af_letter_build  apply (cases "w \<Turnstile>\<^sub>n af_letter \<phi>2 x[Y]\<^sub>\<mu>") apply force
    by (metis (full_types) af_letter.simps(8) semantics_ltln.simps(5) semantics_ltln.simps(6))
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)
  then show ?case
    unfolding af_letter.simps FG_advice.simps semantics_ltln.simps(5,6)
    using af_letter_build apply (cases "w \<Turnstile>\<^sub>n af_letter \<phi>1 x[Y]\<^sub>\<mu>") apply force
    by (metis af_letter.simps(11) semantics_ltln.simps(5) semantics_ltln.simps(6))
qed auto

lemma GF_advice_af:
  "(w \<frown> w') \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu> \<Longrightarrow> w' \<Turnstile>\<^sub>n (af \<phi> w)[X]\<^sub>\<nu>"
  by (induction w arbitrary: \<phi>) (simp, insert GF_advice_af_letter, fastforce)

lemma FG_advice_af:
  "w' \<Turnstile>\<^sub>n (af \<phi> w)[X]\<^sub>\<mu> \<Longrightarrow> (w \<frown> w') \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<mu>"
  by (induction w arbitrary: \<phi>) (simp, insert FG_advice_af_letter, fastforce)

lemma FG_advice_af_2:
  "suffix i w \<Turnstile>\<^sub>n (af \<phi> (prefix i w))[X]\<^sub>\<mu> \<Longrightarrow> w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<mu>"
  using FG_advice_af by force

(* TODO move to Omega_Words_Fun.thy ?? *)
lemma prefix_suffix_subsequence: "prefix i (suffix j w) = (w [j \<rightarrow> i + j])"
  by (simp add: add.commute)

text \<open>We show this generic lemma to prove the following theorems:\<close>

lemma GF_advice_sync:
  fixes index :: "nat \<Rightarrow> nat"
  fixes formula :: "nat \<Rightarrow> 'a ltln"
  assumes "\<And>i. i < n \<Longrightarrow> \<exists>j. suffix ((index i) + j) w \<Turnstile>\<^sub>n af (formula i) (w [index i \<rightarrow> (index i) + j])[X]\<^sub>\<nu>"
  shows "\<exists>k. (\<forall>i < n. k \<ge> index i \<and> suffix k w \<Turnstile>\<^sub>n af (formula i) (w [index i \<rightarrow> k])[X]\<^sub>\<nu>)"
  using assms
proof (induction n)
  case (Suc n)

  obtain k1 where leq1: "\<And>i. i < n \<Longrightarrow> k1 \<ge> index i"
    and suffix1: "\<And>i. i < n \<Longrightarrow> suffix k1 w \<Turnstile>\<^sub>n af (formula i) (w [(index i) \<rightarrow> k1])[X]\<^sub>\<nu>"
    using Suc less_SucI by blast

  obtain k2 where leq2: "k2 \<ge> index n"
    and suffix2: "suffix k2 w \<Turnstile>\<^sub>n af (formula n) (w [index n \<rightarrow> k2])[X]\<^sub>\<nu>"
    using le_add1 Suc.prems by blast

  define k where "k \<equiv> k1 + k2"

  have "\<And>i. i < Suc n \<Longrightarrow> k \<ge> index i"
    unfolding k_def by (metis leq1 leq2 less_SucE trans_le_add1 trans_le_add2)

  moreover

  {
    have "\<And>i. i < n \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af (formula i) (w [(index i) \<rightarrow> k])[X]\<^sub>\<nu>"
      unfolding k_def
      by (metis GF_advice_af_2[OF suffix1, unfolded suffix_suffix prefix_suffix_subsequence] af_subsequence_append leq1 add.commute le_add1)

    moreover

    have "suffix k w \<Turnstile>\<^sub>n af (formula n) (w [index n \<rightarrow> k])[X]\<^sub>\<nu>"
      unfolding k_def
      by (metis GF_advice_af_2[OF suffix2, unfolded suffix_suffix prefix_suffix_subsequence] af_subsequence_append leq2 add.commute le_add1)

    ultimately

    have "\<And>i. i \<le> n \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af (formula i) (w [(index i) \<rightarrow> k])[X]\<^sub>\<nu>"
      using nat_less_le by blast
  }

  ultimately

  show ?case
    by (meson less_Suc_eq_le)
qed simp

lemma GF_advice_sync_and:
  assumes "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>"
  assumes "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<psi> (prefix i w)[X]\<^sub>\<nu>"
  shows "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu> \<and> suffix i w \<Turnstile>\<^sub>n af \<psi> (prefix i w)[X]\<^sub>\<nu>"
proof -
  let ?formula = "\<lambda>i :: nat. (if (i = 0) then \<phi> else \<psi>)"

  have assms: "\<And>i. i < 2 \<Longrightarrow> \<exists>j. suffix j w \<Turnstile>\<^sub>n af (?formula i) (w [0 \<rightarrow> j])[X]\<^sub>\<nu>"
    using assms by simp
  obtain k where k_def: "\<And>i :: nat. i < 2 \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af (if i = 0 then \<phi> else \<psi>) (prefix k w)[X]\<^sub>\<nu>"
    using GF_advice_sync[of "2" "\<lambda>i. 0" w ?formula, simplified, OF assms, simplified] by blast
  show ?thesis
    using k_def[of 0] k_def[of 1] by auto
qed

lemma GF_advice_sync_less:
  assumes "\<And>i. i < n \<Longrightarrow> \<exists>j. suffix (i + j) w \<Turnstile>\<^sub>n af \<phi> (w [i \<rightarrow> j + i])[X]\<^sub>\<nu>"
  assumes "\<exists>j. suffix (n + j) w \<Turnstile>\<^sub>n af \<psi> (w [n \<rightarrow> j + n])[X]\<^sub>\<nu>"
  shows "\<exists>k \<ge> n. (\<forall>j < n. suffix k w \<Turnstile>\<^sub>n af \<phi> (w [j \<rightarrow> k])[X]\<^sub>\<nu>) \<and> suffix k w \<Turnstile>\<^sub>n af \<psi> (w [n \<rightarrow> k])[X]\<^sub>\<nu>"
proof -
  let ?index = "\<lambda>i. min i n"
  let ?formula = "\<lambda>i. if (i < n) then \<phi> else \<psi>"

  {
    fix i
    assume "i < Suc n"
    then have min_def: "min i n = i"
      by simp
    have "\<exists>j. suffix ((?index i) + j) w \<Turnstile>\<^sub>n af (?formula i) (w [?index i \<rightarrow> (?index i) + j])[X]\<^sub>\<nu>"
      unfolding min_def
      by (cases "i < n")
         (metis (full_types) assms(1) add.commute, metis (full_types) assms(2) \<open>i < Suc n\<close> add.commute  less_SucE)
  }

  then obtain k where leq: "(\<And>i. i < Suc n \<Longrightarrow> min i n \<le> k)"
    and suffix: "\<And>i. i < Suc n \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af (if i < n then \<phi> else \<psi>) (w [min i n \<rightarrow> k])[X]\<^sub>\<nu>"
    using GF_advice_sync[of "Suc n" ?index w ?formula X] by metis

  have "\<forall>j < n. suffix k w \<Turnstile>\<^sub>n af \<phi> (w [j \<rightarrow> k])[X]\<^sub>\<nu>"
    using suffix by (metis (full_types) less_SucI min.strict_order_iff)

  moreover

  have "suffix k w \<Turnstile>\<^sub>n af \<psi> (w [n \<rightarrow> k])[X]\<^sub>\<nu>"
    using suffix[of n, simplified] by blast

  moreover

  have "k \<ge> n"
    using leq by presburger

  ultimately
  show ?thesis
    by auto
qed

lemma GF_advice_sync_lesseq:
  assumes "\<And>i. i \<le> n \<Longrightarrow> \<exists>j. suffix (i + j) w \<Turnstile>\<^sub>n af \<phi> (w [i \<rightarrow> j + i])[X]\<^sub>\<nu>"
  assumes "\<exists>j. suffix (n + j) w \<Turnstile>\<^sub>n af \<psi> (w [n \<rightarrow> j + n])[X]\<^sub>\<nu>"
  shows "\<exists>k \<ge> n. (\<forall>j \<le> n. suffix k w \<Turnstile>\<^sub>n af \<phi> (w [j \<rightarrow> k])[X]\<^sub>\<nu>) \<and> suffix k w \<Turnstile>\<^sub>n af \<psi> (w [n \<rightarrow> k])[X]\<^sub>\<nu>"
proof -
  let ?index = "\<lambda>i. min i n"
  let ?formula = "\<lambda>i. if (i \<le> n) then \<phi> else \<psi>"

  {
    fix i
    assume "i < Suc (Suc n)"
    hence "\<exists>j. suffix ((?index i) + j) w \<Turnstile>\<^sub>n af (?formula i) (w [?index i \<rightarrow> (?index i) + j])[X]\<^sub>\<nu>"
    proof (cases "i < Suc n")
      case True
      then have min_def: "min i n = i"
        by simp
      show ?thesis
        unfolding min_def by (metis (full_types) assms(1) Suc_leI Suc_le_mono True add.commute)
    next
      case False
      then have i_def: "i = Suc n"
        using \<open>i < Suc (Suc n)\<close> less_antisym by blast
      have min_def: "min i n = n"
        unfolding i_def by simp
      show ?thesis
        using assms(2) False
        by (simp add: min_def add.commute)
    qed
  }

  then obtain k where leq: "(\<And>i. i \<le> Suc n \<Longrightarrow> min i n \<le> k)"
    and suffix: "\<And>i :: nat. i < Suc (Suc n) \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af (if i \<le> n then \<phi> else \<psi>) (w [min i n \<rightarrow> k])[X]\<^sub>\<nu>"
    using GF_advice_sync[of "Suc (Suc n)" ?index w ?formula X]
    by (metis (no_types, hide_lams) less_Suc_eq min_le_iff_disj)

  have "\<forall>j \<le> n. suffix k w \<Turnstile>\<^sub>n af \<phi> (w [j \<rightarrow> k])[X]\<^sub>\<nu>"
    using suffix by (metis (full_types) le_SucI less_Suc_eq_le min.orderE)

  moreover

  have "suffix k w \<Turnstile>\<^sub>n af \<psi> (w [n \<rightarrow> k])[X]\<^sub>\<nu>"
    using suffix[of "Suc n", simplified] by linarith

  moreover

  have "k \<ge> n"
    using leq by presburger

  ultimately
  show ?thesis
    by auto
qed

lemma af_subsequence_U_GF_advice:
  assumes "i \<le> n"
  assumes "suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [i \<rightarrow> n]))[X]\<^sub>\<nu>)"
  assumes "\<And>j. j < i \<Longrightarrow> suffix n w \<Turnstile>\<^sub>n ((af \<phi> (w [j \<rightarrow> n]))[X]\<^sub>\<nu>)"
  shows "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> U\<^sub>n \<psi>) (prefix (Suc n) w))[X]\<^sub>\<nu>"
  using assms
proof (induction i arbitrary: w n)
  case 0
  then have A: "suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [0 \<rightarrow> n]))[X]\<^sub>\<nu>)"
    by blast
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF A, of 1] by simp
  then show ?case
    unfolding GF_advice.simps af_subsequence_U semantics_ltln.simps by blast
next
  case (Suc i)
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<phi> (prefix (Suc n) w))[X]\<^sub>\<nu>"
    using Suc.prems(3)[OF zero_less_Suc, THEN GF_advice_af_2, unfolded suffix_suffix, of 1]
    by simp
  moreover
  have B: "(Suc (n - 1)) = n"
    using Suc by simp
  note Suc.IH[of "n - 1" "suffix 1 w", unfolded suffix_suffix] Suc.prems
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> U\<^sub>n \<psi>) (w [1 \<rightarrow> (Suc n)]))[X]\<^sub>\<nu>"
    by (metis B One_nat_def Suc_le_mono Suc_mono plus_1_eq_Suc subsequence_shift)
  ultimately
  show ?case
    unfolding af_subsequence_U semantics_ltln.simps GF_advice.simps by blast
qed

lemma af_subsequence_M_GF_advice:
  assumes "i \<le> n"
  assumes "suffix n w \<Turnstile>\<^sub>n ((af \<phi> (w [i \<rightarrow> n]))[X]\<^sub>\<nu>)"
  assumes "\<And>j. j \<le> i \<Longrightarrow> suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [j \<rightarrow> n]))[X]\<^sub>\<nu>)"
  shows "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> M\<^sub>n \<psi>) (prefix (Suc n) w))[X]\<^sub>\<nu>"
  using assms
proof (induction i arbitrary: w n)
  case 0
  then have A: "suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [0 \<rightarrow> n]))[X]\<^sub>\<nu>)"
    by blast
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF A, of 1] by simp
  moreover
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<phi> (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF "0.prems"(2), of 1, unfolded suffix_suffix] by auto
  ultimately
  show ?case
    unfolding af_subsequence_M GF_advice.simps semantics_ltln.simps by blast
next
  case (Suc i)
  have "suffix 1 (suffix n w) \<Turnstile>\<^sub>n af (af \<psi> (prefix n w)) [suffix n w 0][X]\<^sub>\<nu>"
    by (metis (no_types) GF_advice_af_2 Suc.prems(3) plus_1_eq_Suc subsequence_singleton suffix_0 suffix_suffix zero_le)
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (prefix (Suc n) w))[X]\<^sub>\<nu>"
    using Suc.prems(3)[THEN GF_advice_af_2, unfolded suffix_suffix, of 1] by simp
  moreover
  have B: "(Suc (n - 1)) = n"
    using Suc by simp
  note Suc.IH[of _ "suffix 1 w", unfolded subsequence_shift suffix_suffix]
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> M\<^sub>n \<psi>) (w [1 \<rightarrow> (Suc n)]))[X]\<^sub>\<nu>"
    by (metis B One_nat_def Suc_le_mono plus_1_eq_Suc Suc.prems)
  ultimately
  show ?case
    unfolding af_subsequence_M semantics_ltln.simps GF_advice.simps by blast
qed

lemma af_subsequence_R_GF_advice:
  assumes "i \<le> n"
  assumes "suffix n w \<Turnstile>\<^sub>n ((af \<phi> (w [i \<rightarrow> n]))[X]\<^sub>\<nu>)"
  assumes "\<And>j. j \<le> i \<Longrightarrow> suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [j \<rightarrow> n]))[X]\<^sub>\<nu>)"
  shows "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> R\<^sub>n \<psi>) (prefix (Suc n) w))[X]\<^sub>\<nu>"
  using assms
proof (induction i arbitrary: w n)
  case 0
  then have A: "suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [0 \<rightarrow> n]))[X]\<^sub>\<nu>)"
    by blast
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF A, of 1] by simp
  moreover
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<phi> (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF "0.prems"(2), of 1, unfolded suffix_suffix] by auto
  ultimately
  show ?case
    unfolding af_subsequence_R GF_advice.simps semantics_ltln.simps by blast
next
  case (Suc i)
  have "suffix 1 (suffix n w) \<Turnstile>\<^sub>n af (af \<psi> (prefix n w)) [suffix n w 0][X]\<^sub>\<nu>"
    by (metis (no_types) GF_advice_af_2 Suc.prems(3) plus_1_eq_Suc subsequence_singleton suffix_0 suffix_suffix zero_le)
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (prefix (Suc n) w))[X]\<^sub>\<nu>"
    using Suc.prems(3)[THEN GF_advice_af_2, unfolded suffix_suffix, of 1] by simp
  moreover
  have B: "(Suc (n - 1)) = n"
    using Suc by simp
  note Suc.IH[of _ "suffix 1 w", unfolded subsequence_shift suffix_suffix]
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> R\<^sub>n \<psi>) (w [1 \<rightarrow> (Suc n)]))[X]\<^sub>\<nu>"
    by (metis B One_nat_def Suc_le_mono plus_1_eq_Suc Suc.prems)
  ultimately
  show ?case
    unfolding af_subsequence_R semantics_ltln.simps GF_advice.simps by blast
qed

lemma af_subsequence_W_GF_advice:
  assumes "i \<le> n"
  assumes "suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [i \<rightarrow> n]))[X]\<^sub>\<nu>)"
  assumes "\<And>j. j < i \<Longrightarrow> suffix n w \<Turnstile>\<^sub>n ((af \<phi> (w [j \<rightarrow> n]))[X]\<^sub>\<nu>)"
  shows "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> W\<^sub>n \<psi>) (prefix (Suc n) w))[X]\<^sub>\<nu>"
  using assms
proof (induction i arbitrary: w n)
  case 0
  then have A: "suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [0 \<rightarrow> n]))[X]\<^sub>\<nu>)"
    by blast
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF A, of 1] by simp
  then show ?case
    unfolding af_subsequence_W GF_advice.simps semantics_ltln.simps by blast
next
  case (Suc i)
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<phi> (prefix (Suc n) w))[X]\<^sub>\<nu>"
    using Suc.prems(3)[OF zero_less_Suc, THEN GF_advice_af_2, unfolded suffix_suffix, of 1]
    by simp
  moreover
  have B: "(Suc (n - 1)) = n"
    using Suc by simp
  note Suc.IH[of "n - 1" "suffix 1 w", unfolded suffix_suffix] Suc.prems
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> W\<^sub>n \<psi>) (w [1 \<rightarrow> (Suc n)]))[X]\<^sub>\<nu>"
    by (metis B One_nat_def Suc_le_mono Suc_mono plus_1_eq_Suc subsequence_shift)
  ultimately
  show ?case
    unfolding af_subsequence_W unfolding semantics_ltln.simps GF_advice.simps by simp
qed

lemma af_subsequence_R_GF_advice_connect:
  assumes "i \<le> n"
  assumes "suffix n w \<Turnstile>\<^sub>n af (\<phi> R\<^sub>n \<psi>) (w [i \<rightarrow> n])[X]\<^sub>\<nu>"
  assumes "\<And>j. j \<le> i \<Longrightarrow> suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [j \<rightarrow> n]))[X]\<^sub>\<nu>)"
  shows "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> R\<^sub>n \<psi>) (prefix (Suc n) w))[X]\<^sub>\<nu>"
  using assms
proof (induction i arbitrary: w n)
  case 0
  then have A: "suffix n w \<Turnstile>\<^sub>n ((af \<psi> (w [0 \<rightarrow> n]))[X]\<^sub>\<nu>)"
    by blast
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF A, of 1] by simp
  moreover
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> R\<^sub>n \<psi>) (w [0 \<rightarrow> Suc n]))[X]\<^sub>\<nu>"
    using GF_advice_af_2[OF "0.prems"(2), of 1, unfolded suffix_suffix] by simp
  ultimately
  show ?case
    unfolding af_subsequence_R GF_advice.simps semantics_ltln.simps by blast
next
  case (Suc i)
  have "suffix 1 (suffix n w) \<Turnstile>\<^sub>n af (af \<psi> (prefix n w)) [suffix n w 0][X]\<^sub>\<nu>"
    by (metis (no_types) GF_advice_af_2 Suc.prems(3) plus_1_eq_Suc subsequence_singleton suffix_0 suffix_suffix zero_le)
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<psi> (prefix (Suc n) w))[X]\<^sub>\<nu>"
    using Suc.prems(3)[THEN GF_advice_af_2, unfolded suffix_suffix, of 1] by simp
  moreover
  have B: "(Suc (n - 1)) = n"
    using Suc by simp
  note Suc.IH[of _ "suffix 1 w", unfolded subsequence_shift suffix_suffix]
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> R\<^sub>n \<psi>) (w [1 \<rightarrow> (Suc n)]))[X]\<^sub>\<nu>"
    by (metis B One_nat_def Suc_le_mono plus_1_eq_Suc Suc.prems)
  ultimately
  show ?case
    unfolding af_subsequence_R semantics_ltln.simps GF_advice.simps by blast
qed

lemma af_subsequence_W_GF_advice_connect:
  assumes "i \<le> n"
  assumes "suffix n w \<Turnstile>\<^sub>n af (\<phi> W\<^sub>n \<psi>) (w [i \<rightarrow> n])[X]\<^sub>\<nu>"
  assumes "\<And>j. j < i \<Longrightarrow> suffix n w \<Turnstile>\<^sub>n ((af \<phi> (w [j \<rightarrow> n]))[X]\<^sub>\<nu>)"
  shows "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> W\<^sub>n \<psi>) (prefix (Suc n) w))[X]\<^sub>\<nu>"
  using assms
proof (induction i arbitrary: w n)
  case 0
  have "suffix (Suc n) w \<Turnstile>\<^sub>n af_letter (af (\<phi> W\<^sub>n \<psi>) (prefix n w)) (w n)[X]\<^sub>\<nu>"
    by (simp add: "0.prems"(2) GF_advice_af_letter)
  moreover
  have "prefix (Suc n) w = prefix n w @ [w n]"
    using subseq_to_Suc by blast
  ultimately show ?case
    by (metis (no_types) foldl.simps(1) foldl.simps(2) foldl_append)
next
  case (Suc i)
  have "suffix (Suc n) w \<Turnstile>\<^sub>n (af \<phi> (prefix (Suc n) w))[X]\<^sub>\<nu>"
    using Suc.prems(3)[OF zero_less_Suc, THEN GF_advice_af_2, unfolded suffix_suffix, of 1] by simp
  moreover
  have "n > 0" and B: "(Suc (n - 1)) = n"
    using Suc by simp+
  note Suc.IH[of "n - 1" "suffix 1 w", unfolded suffix_suffix] Suc.prems
  then have "suffix (Suc n) w \<Turnstile>\<^sub>n (af (\<phi> W\<^sub>n \<psi>) (w [1 \<rightarrow> (Suc n)]))[X]\<^sub>\<nu>"
    by (metis B One_nat_def Suc_le_mono Suc_mono plus_1_eq_Suc subsequence_shift)
  ultimately
  show ?case
    unfolding af_subsequence_W unfolding semantics_ltln.simps GF_advice.simps by simp
qed

subsection \<open>Advice Functions and Propositional Entailment\<close>

lemma GF_advice_prop_entailment:
  "\<A> \<Turnstile>\<^sub>P \<phi>[X]\<^sub>\<nu> \<Longrightarrow> {\<psi>. \<psi>[X]\<^sub>\<nu> \<in> \<A>} \<Turnstile>\<^sub>P \<phi>"
  "false\<^sub>n \<notin> \<A> \<Longrightarrow> {\<psi>. \<psi>[X]\<^sub>\<nu> \<in> \<A>} \<Turnstile>\<^sub>P \<phi> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<phi>[X]\<^sub>\<nu>"
  by (induction \<phi>) (auto, meson, meson)

lemma GF_advice_iff_prop_entailment:
  "false\<^sub>n \<notin> \<A> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<phi>[X]\<^sub>\<nu> \<longleftrightarrow> {\<psi>. \<psi>[X]\<^sub>\<nu> \<in> \<A>} \<Turnstile>\<^sub>P \<phi>"
  by (metis GF_advice_prop_entailment)

lemma FG_advice_prop_entailment:
  "true\<^sub>n \<in> \<A> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<phi>[Y]\<^sub>\<mu> \<Longrightarrow> {\<psi>. \<psi>[Y]\<^sub>\<mu> \<in> \<A>} \<Turnstile>\<^sub>P \<phi>"
  "{\<psi>. \<psi>[Y]\<^sub>\<mu> \<in> \<A>} \<Turnstile>\<^sub>P \<phi> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<phi>[Y]\<^sub>\<mu>"
  by (induction \<phi>) auto

lemma FG_advice_iff_prop_entailment:
  "true\<^sub>n \<in> \<A> \<Longrightarrow> \<A> \<Turnstile>\<^sub>P \<phi>[X]\<^sub>\<mu> \<longleftrightarrow> {\<psi>. \<psi>[X]\<^sub>\<mu> \<in> \<A>} \<Turnstile>\<^sub>P \<phi>"
  by (metis FG_advice_prop_entailment)

lemma GF_advice_subst:
  "\<phi>[X]\<^sub>\<nu> = subst \<phi> (\<lambda>\<psi>. Some (\<psi>[X]\<^sub>\<nu>))"
  by (induction \<phi>) auto

lemma FG_advice_subst:
  "\<phi>[X]\<^sub>\<mu> = subst \<phi> (\<lambda>\<psi>. Some (\<psi>[X]\<^sub>\<mu>))"
  by (induction \<phi>) auto

lemma GF_advice_prop_congruent:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> \<phi>[X]\<^sub>\<nu> \<longrightarrow>\<^sub>P \<psi>[X]\<^sub>\<nu>"
  "\<phi> \<sim>\<^sub>P \<psi> \<Longrightarrow> \<phi>[X]\<^sub>\<nu> \<sim>\<^sub>P \<psi>[X]\<^sub>\<nu>"
  by (metis GF_advice_subst subst_respects_ltl_prop_entailment)+

lemma FG_advice_prop_congruent:
  "\<phi> \<longrightarrow>\<^sub>P \<psi> \<Longrightarrow> \<phi>[X]\<^sub>\<mu> \<longrightarrow>\<^sub>P \<psi>[X]\<^sub>\<mu>"
  "\<phi> \<sim>\<^sub>P \<psi> \<Longrightarrow> \<phi>[X]\<^sub>\<mu> \<sim>\<^sub>P \<psi>[X]\<^sub>\<mu>"
  by (metis FG_advice_subst subst_respects_ltl_prop_entailment)+

subsection \<open>GF-advice with Equivalence Relations\<close>

locale GF_advice_congruent = ltl_equivalence +
  fixes
    normalise :: "'a ltln \<Rightarrow> 'a ltln"
  assumes
    normalise_eq: "\<phi> \<sim> normalise \<phi>"
  assumes
    normalise_monotonic: "w \<Turnstile>\<^sub>n \<phi>[X]\<^sub>\<nu> \<Longrightarrow> w \<Turnstile>\<^sub>n (normalise \<phi>)[X]\<^sub>\<nu>"
  assumes
    normalise_eventually_equivalent:
      "w \<Turnstile>\<^sub>n (normalise \<phi>)[X]\<^sub>\<nu> \<Longrightarrow> (\<exists>i. suffix i w \<Turnstile>\<^sub>n (af \<phi> (prefix i w))[X]\<^sub>\<nu>)"
  assumes
    GF_advice_congruent: "\<phi> \<sim> \<psi> \<Longrightarrow> (normalise \<phi>)[X]\<^sub>\<nu> \<sim> (normalise \<psi>)[X]\<^sub>\<nu>"
begin

lemma normalise_language_equivalent[simp]:
  "w \<Turnstile>\<^sub>n normalise \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n \<phi>"
  using normalise_eq ltl_lang_equiv_def eq_implies_lang by blast

end

interpretation prop_GF_advice_compatible: GF_advice_congruent "(\<sim>\<^sub>P)" "id"
  by unfold_locales (simp add: GF_advice_af GF_advice_prop_congruent(2))+

end


(*
   Title: Psi-calculi
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong_Struct_Cong
  imports Weak_Cong_Pres Weak_Bisim_Struct_Cong
begin

context env begin

lemma weakPsiCongParComm:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> Q \<doteq> Q \<parallel> P"
by(metis bisimParComm strongBisimWeakPsiCong)

lemma weakPsiCongResComm:
  fixes x :: name
  and   \<Psi> :: 'b
  and   y :: name
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "y \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>y\<rparr>P) \<doteq> \<lparr>\<nu>y\<rparr>(\<lparr>\<nu>x\<rparr>P)"
using assms
by(metis bisimResComm strongBisimWeakPsiCong)

lemma weakPsiCongResComm':
  fixes x    :: name
  and   \<Psi>   :: 'b
  and   xvec :: "name list"
  and   P    :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "xvec \<sharp>* \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(\<lparr>\<nu>*xvec\<rparr>P) \<doteq> \<lparr>\<nu>*xvec\<rparr>(\<lparr>\<nu>x\<rparr>P)"
using assms
by(metis bisimResComm' strongBisimWeakPsiCong)

lemma weakPsiCongScopeExt:
  fixes x :: name
  and   \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<doteq> P \<parallel> \<lparr>\<nu>x\<rparr>Q"
using assms
by(metis bisimScopeExt strongBisimWeakPsiCong)

lemma weakPsiCongScopeExtChain:
  fixes xvec :: "name list"
  and   \<Psi>    :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes "xvec \<sharp>* \<Psi>"
  and     "xvec \<sharp>* P"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> Q) \<doteq> P \<parallel> (\<lparr>\<nu>*xvec\<rparr>Q)"
using assms
by(metis bisimScopeExtChain strongBisimWeakPsiCong)

lemma weakPsiCongParAssoc:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> (P \<parallel> Q) \<parallel> R \<doteq> P \<parallel> (Q \<parallel> R)"
by(metis bisimParAssoc strongBisimWeakPsiCong)

lemma weakPsiCongParNil:
  fixes P :: "('a, 'b, 'c) psi"

  shows "\<Psi> \<rhd> P \<parallel> \<zero> \<doteq> P"
by(metis bisimParNil strongBisimWeakPsiCong)

lemma weakPsiCongResNil:
  fixes x :: name
  and   \<Psi> :: 'b

  assumes "x \<sharp> \<Psi>"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>\<zero> \<doteq> \<zero>"
using assms
by(metis bisimResNil strongBisimWeakPsiCong)

lemma weakPsiCongOutputPushRes:
  fixes x :: name
  and   \<Psi> :: 'b
  and   M :: 'a
  and   N :: 'a
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> M"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<langle>N\<rangle>.P) \<doteq> M\<langle>N\<rangle>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis bisimOutputPushRes strongBisimWeakPsiCong)

lemma weakPsiCongInputPushRes:
  fixes x    :: name
  and   \<Psi>    :: 'b
  and   M    :: 'a
  and   xvec :: "name list"
  and   N    :: 'a
  and   P    :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> M"
  and     "x \<sharp> xvec"
  and     "x \<sharp> N"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(M\<lparr>\<lambda>*xvec N\<rparr>.P) \<doteq> M\<lparr>\<lambda>*xvec N\<rparr>.\<lparr>\<nu>x\<rparr>P"
using assms
by(metis bisimInputPushRes strongBisimWeakPsiCong)

lemma weakPsiCongCasePushRes:
  fixes x  :: name
  and   \<Psi>  :: 'b
  and   Cs :: "('c \<times> ('a, 'b, 'c) psi) list"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> (map fst Cs)"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(Cases Cs) \<doteq> Cases(map (\<lambda>(\<phi>, P). (\<phi>, \<lparr>\<nu>x\<rparr>P)) Cs)"
using assms
by(metis bisimCasePushRes strongBisimWeakPsiCong)

lemma weakBangExt:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"

  assumes "guarded P"

  shows "\<Psi> \<rhd> !P \<doteq> P \<parallel> !P"
using assms
by(metis bangExt strongBisimWeakPsiCong)

lemma weakPsiCongParSym:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"

  shows "\<Psi> \<rhd> R \<parallel> P \<doteq> R \<parallel> Q"
using assms
by(metis weakPsiCongParComm weakPsiCongParPres weakPsiCongTransitive)

lemma weakPsiCongScopeExtSym:
  fixes x :: name
  and   Q :: "('a, 'b, 'c) psi"
  and   P :: "('a, 'b, 'c) psi"

  assumes "x \<sharp> \<Psi>"
  and     "x \<sharp> Q"

  shows "\<Psi> \<rhd> \<lparr>\<nu>x\<rparr>(P \<parallel> Q) \<doteq> (\<lparr>\<nu>x\<rparr>P) \<parallel> Q"
using assms
by(metis weakPsiCongScopeExt weakPsiCongTransitive weakPsiCongParComm weakPsiCongE weakPsiCongResPres)

lemma weakPsiCongScopeExtChainSym:
  fixes xvec :: "name list"
  and   Q    :: "('a, 'b, 'c) psi"
  and   P    :: "('a, 'b, 'c) psi"

  assumes "xvec \<sharp>* \<Psi>"
  and     "xvec \<sharp>* Q"

  shows "\<Psi> \<rhd> \<lparr>\<nu>*xvec\<rparr>(P \<parallel> Q) \<doteq> (\<lparr>\<nu>*xvec\<rparr>P) \<parallel> Q"
using assms
by(induct xvec) (auto intro: weakPsiCongScopeExtSym weakPsiCongReflexive weakPsiCongTransitive weakPsiCongResPres)

lemma weakPsiCongParPresSym:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"
  and   R :: "('a, 'b, 'c) psi"

  assumes "\<And>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"

  shows "\<Psi> \<rhd> R \<parallel> P \<doteq> R \<parallel> Q"
using assms
by(metis weakPsiCongParComm weakPsiCongParPres weakPsiCongTransitive)

lemma tauCongChainBangI:
  fixes \<Psi> :: 'b
  and   P  :: "('a, 'b, 'c) psi"
  and   P' :: "('a, 'b, 'c) psi"

  assumes "\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sub>\<tau> P'"
  and     "guarded P"

  obtains Q where "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q" and "\<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
proof -
  assume "\<And>Q. \<lbrakk>\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q; \<Psi> \<rhd> Q \<sim> P' \<parallel> !P\<rbrakk> \<Longrightarrow> thesis"
  moreover from \<open>\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sub>\<tau> P'\<close> have "\<exists>Q. \<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q \<and> \<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
  proof(induct x1=="P \<parallel> P" P' rule: tauStepChainInduct)
    case(TauBase R')
    from \<open>\<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> R'\<close>
    obtain Q where "\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> Q" and "Q \<sim> R' \<parallel> !P" using \<open>guarded P\<close>
      by(rule tauBangI)
    from \<open>\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> Q\<close> have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q" by auto
    moreover from \<open>Q \<sim> R' \<parallel> !P\<close> have "\<Psi> \<rhd> Q \<sim> R' \<parallel> !P"
      apply(drule_tac bisimE(3)[where \<Psi>'=\<Psi>])
      by(rule_tac statEqBisim, assumption) (metis Identity AssertionStatEqSym AssertionStatEqTrans Commutativity)
    ultimately show ?case by blast
  next
    case(TauStep R' R'')
    then obtain Q where PChain: "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q" and "\<Psi> \<rhd> Q \<sim> R' \<parallel> !P" by auto
    from \<open>\<Psi> \<rhd> R' \<longmapsto>\<tau> \<prec> R''\<close> have "\<Psi> \<otimes> \<one> \<rhd> R' \<longmapsto>\<tau> \<prec> R''" by(rule statEqTransition) (metis Identity AssertionStatEqSym)
    hence "\<Psi> \<rhd> R' \<parallel> !P \<longmapsto>\<tau> \<prec> R'' \<parallel> !P" by(rule_tac Par1) auto
    with \<open>\<Psi> \<rhd> Q \<sim> R' \<parallel> !P\<close> obtain Q' where QTrans: "\<Psi> \<rhd> Q \<longmapsto>\<tau> \<prec> Q'" and "\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P"
      by(force dest: bisimE(2) simE)
    from PChain QTrans have "\<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q'" by(auto dest: tauActTauStepChain)
    thus ?case using \<open>\<Psi> \<rhd> Q' \<sim> R'' \<parallel> !P\<close> by blast
  qed
  ultimately show ?thesis by blast
qed

lemma weakPsiCongBangPres:
  fixes \<Psi> :: 'b
  and   P :: "('a, 'b, 'c) psi"
  and   Q :: "('a, 'b, 'c) psi"

  assumes PeqQ: "\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"
  and     "guarded P"
  and     "guarded Q"

  shows   "\<Psi> \<rhd> !P \<doteq> !Q"
proof -
  from assms have "(\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q) \<and> guarded P \<and> guarded Q" by auto
  hence "\<Psi> \<rhd> \<zero> \<parallel> !P \<doteq> \<zero> \<parallel> !Q"
  proof(induct rule: weakPsiCongSymI[where C="\<lambda>P. \<zero> \<parallel> !P"])
    case(cSym P Q)
    thus ?case by(auto dest: weakPsiCongSym)
  next
    case(cWeakBisim P Q)
    thus ?case by(metis weakPsiCongE weakBisimBangPresAux)
  next
    case(cSim P Q)
    then have "\<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q" and "guarded P" and "guarded Q" by auto
    moreover hence "\<Psi> \<rhd> P \<approx> Q" by(metis weakPsiCongE weakBisimE)
    moreover have "\<And>\<Psi> P Q. (\<forall>\<Psi>. (\<Psi> \<rhd> P \<doteq> Q)) \<Longrightarrow> \<Psi> \<rhd> P \<leadsto>\<guillemotleft>weakBisim\<guillemotright> Q"
      by(blast dest: weakPsiCongE)
    moreover note weakBisimClosed bisimClosed weakBisimE(3) bisimE(3) weakBisimE(2)
                  weakBisimE(4) bisimE(4) statEqWeakBisim statEqBisim weakBisimTransitive bisimTransitive weakBisimParAssoc[THEN weakBisimE(4)]
                  bisimParAssoc[THEN bisimE(4)] weakBisimParPres
    moreover have "\<And>P Q. \<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q \<Longrightarrow> \<forall>\<Psi>. \<Psi> \<rhd> P \<parallel> P \<doteq> Q \<parallel> Q"
      by(metis weakPsiCongParPres weakPsiCongParComm weakPsiCongSym weakPsiCongTransitive)
    moreover note bisimParPresSym
    moreover from strongBisimWeakBisim have "bisim \<subseteq> weakBisim" by auto
    moreover have "\<And>\<Psi> \<Psi>\<^sub>R P Q R A\<^sub>R. \<lbrakk>\<Psi> \<otimes> \<Psi>\<^sub>R \<rhd> P \<approx> Q; extractFrame R = \<langle>A\<^sub>R, \<Psi>\<^sub>R\<rangle>; A\<^sub>R \<sharp>* \<Psi>; A\<^sub>R \<sharp>* P; A\<^sub>R \<sharp>* Q\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> R \<parallel> P \<approx> R \<parallel> Q"
      by(metis weakBisimParComm weakBisimTransitive weakBisimParPresAux)
    moreover note weakBisimResChainPres bisimResChainPres weakBisimScopeExtChainSym bisimScopeExtChainSym
    moreover have "\<And>\<Psi> P R S Q. \<lbrakk>\<Psi> \<rhd> P \<approx> R; \<Psi> \<rhd> R \<approx> S; \<Psi> \<rhd> S \<sim> Q\<rbrakk> \<Longrightarrow> \<Psi> \<rhd> P \<approx> Q"
      by(blast dest: weakBisimTransitive strongBisimWeakBisim)
    moreover note weakBisimBangPresAux
    moreover from bangActE have "\<And>\<Psi> P \<alpha> P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>\<alpha> \<prec> P'; bn \<alpha> \<sharp>* P; guarded P; \<alpha> \<noteq> \<tau>; bn \<alpha> \<sharp>* subject \<alpha>\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> P \<longmapsto>\<alpha> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
      by blast
    moreover from bangTauE have "\<And>\<Psi> P P'. \<lbrakk>\<Psi> \<rhd> !P \<longmapsto>\<tau> \<prec> P'; guarded P\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> P \<parallel> P \<longmapsto>\<tau> \<prec> Q \<and> P' \<sim> Q \<parallel> !P"
      by blast
    moreover from tauCongChainBangI have "\<And>\<Psi> P P'. \<lbrakk>\<Psi> \<rhd> P \<parallel> P \<Longrightarrow>\<^sub>\<tau> P'; guarded P\<rbrakk> \<Longrightarrow> \<exists>Q. \<Psi> \<rhd> !P \<Longrightarrow>\<^sub>\<tau> Q \<and> \<Psi> \<rhd> Q \<sim> P' \<parallel> !P"
      by blast
    ultimately show ?case
      by(rule_tac weakCongSimBangPres[where Rel=weakBisim and Rel'=bisim and Rel''=weakBisim and Eq="\<lambda>P Q. \<forall>\<Psi>. \<Psi> \<rhd> P \<doteq> Q"])
  qed
  thus ?thesis
    by(metis weakPsiCongParNil weakPsiCongParComm weakPsiCongTransitive weakPsiCongSym)
qed

end

end


(*  Title:      ZF/UNITY/SubstAx.thy
    Author:     Sidi O Ehmety, Computer Laboratory
    Copyright   2001  University of Cambridge

Theory ported from HOL.
*)

section{*Weak LeadsTo relation (restricted to the set of reachable states)*}

theory SubstAx
imports WFair Constrains
begin

definition
  (* The definitions below are not `conventional', but yield simpler rules *)
  Ensures :: "[i,i] => i"            (infixl "Ensures" 60)  where
  "A Ensures B == {F \<in> program. F \<in> (reachable(F) \<inter> A) ensures (reachable(F) \<inter> B) }"

definition
  LeadsTo :: "[i, i] => i"            (infixl "LeadsTo" 60)  where
  "A LeadsTo B == {F \<in> program. F:(reachable(F) \<inter> A) leadsTo (reachable(F) \<inter> B)}"

notation (xsymbols)
  LeadsTo  (infixl " \<longmapsto>w " 60)

(*Resembles the previous definition of LeadsTo*)

(* Equivalence with the HOL-like definition *)
lemma LeadsTo_eq:
"st_set(B)==> A LeadsTo B = {F \<in> program. F:(reachable(F) \<inter> A) leadsTo B}"
apply (unfold LeadsTo_def)
apply (blast dest: psp_stable2 leadsToD2 constrainsD2 intro: leadsTo_weaken)
done

lemma LeadsTo_type: "A LeadsTo B <=program"
by (unfold LeadsTo_def, auto)

(*** Specialized laws for handling invariants ***)

(** Conjoining an Always property **)
lemma Always_LeadsTo_pre: "F \<in> Always(I) ==> (F:(I \<inter> A) LeadsTo A') \<longleftrightarrow> (F \<in> A LeadsTo A')"
by (simp add: LeadsTo_def Always_eq_includes_reachable Int_absorb2 Int_assoc [symmetric] leadsToD2)

lemma Always_LeadsTo_post: "F \<in> Always(I) ==> (F \<in> A LeadsTo (I \<inter> A')) \<longleftrightarrow> (F \<in> A LeadsTo A')"
apply (unfold LeadsTo_def)
apply (simp add: Always_eq_includes_reachable Int_absorb2 Int_assoc [symmetric] leadsToD2)
done

(* Like 'Always_LeadsTo_pre RS iffD1', but with premises in the good order *)
lemma Always_LeadsToI: "[| F \<in> Always(C); F \<in> (C \<inter> A) LeadsTo A' |] ==> F \<in> A LeadsTo A'"
by (blast intro: Always_LeadsTo_pre [THEN iffD1])

(* Like 'Always_LeadsTo_post RS iffD2', but with premises in the good order *)
lemma Always_LeadsToD: "[| F \<in> Always(C);  F \<in> A LeadsTo A' |] ==> F \<in> A LeadsTo (C \<inter> A')"
by (blast intro: Always_LeadsTo_post [THEN iffD2])

(*** Introduction rules \<in> Basis, Trans, Union ***)

lemma LeadsTo_Basis: "F \<in> A Ensures B ==> F \<in> A LeadsTo B"
by (auto simp add: Ensures_def LeadsTo_def)

lemma LeadsTo_Trans:
     "[| F \<in> A LeadsTo B;  F \<in> B LeadsTo C |] ==> F \<in> A LeadsTo C"
apply (simp (no_asm_use) add: LeadsTo_def)
apply (blast intro: leadsTo_Trans)
done

lemma LeadsTo_Union:
"[|(!!A. A \<in> S ==> F \<in> A LeadsTo B); F \<in> program|]==>F \<in> \<Union>(S) LeadsTo B"
apply (simp add: LeadsTo_def)
apply (subst Int_Union_Union2)
apply (rule leadsTo_UN, auto)
done

(*** Derived rules ***)

lemma leadsTo_imp_LeadsTo: "F \<in> A leadsTo B ==> F \<in> A LeadsTo B"
apply (frule leadsToD2, clarify)
apply (simp (no_asm_simp) add: LeadsTo_eq)
apply (blast intro: leadsTo_weaken_L)
done

(*Useful with cancellation, disjunction*)
lemma LeadsTo_Un_duplicate: "F \<in> A LeadsTo (A' \<union> A') ==> F \<in> A LeadsTo A'"
by (simp add: Un_ac)

lemma LeadsTo_Un_duplicate2:
     "F \<in> A LeadsTo (A' \<union> C \<union> C) ==> F \<in> A LeadsTo (A' \<union> C)"
by (simp add: Un_ac)

lemma LeadsTo_UN:
    "[|(!!i. i \<in> I ==> F \<in> A(i) LeadsTo B); F \<in> program|]
     ==>F:(\<Union>i \<in> I. A(i)) LeadsTo B"
apply (simp add: LeadsTo_def)
apply (simp (no_asm_simp) del: UN_simps add: Int_UN_distrib)
apply (rule leadsTo_UN, auto)
done

(*Binary union introduction rule*)
lemma LeadsTo_Un:
     "[| F \<in> A LeadsTo C; F \<in> B LeadsTo C |] ==> F \<in> (A \<union> B) LeadsTo C"
apply (subst Un_eq_Union)
apply (rule LeadsTo_Union)
apply (auto dest: LeadsTo_type [THEN subsetD])
done

(*Lets us look at the starting state*)
lemma single_LeadsTo_I:
    "[|(!!s. s \<in> A ==> F:{s} LeadsTo B); F \<in> program|]==>F \<in> A LeadsTo B"
apply (subst UN_singleton [symmetric], rule LeadsTo_UN, auto)
done

lemma subset_imp_LeadsTo: "[| A \<subseteq> B; F \<in> program |] ==> F \<in> A LeadsTo B"
apply (simp (no_asm_simp) add: LeadsTo_def)
apply (blast intro: subset_imp_leadsTo)
done

lemma empty_LeadsTo: "F \<in> 0 LeadsTo A \<longleftrightarrow> F \<in> program"
by (auto dest: LeadsTo_type [THEN subsetD]
            intro: empty_subsetI [THEN subset_imp_LeadsTo])
declare empty_LeadsTo [iff]

lemma LeadsTo_state: "F \<in> A LeadsTo state \<longleftrightarrow> F \<in> program"
by (auto dest: LeadsTo_type [THEN subsetD] simp add: LeadsTo_eq)
declare LeadsTo_state [iff]

lemma LeadsTo_weaken_R: "[| F \<in> A LeadsTo A';  A'<=B'|] ==> F \<in> A LeadsTo B'"
apply (unfold LeadsTo_def)
apply (auto intro: leadsTo_weaken_R)
done

lemma LeadsTo_weaken_L: "[| F \<in> A LeadsTo A'; B \<subseteq> A |] ==> F \<in> B LeadsTo A'"
apply (unfold LeadsTo_def)
apply (auto intro: leadsTo_weaken_L)
done

lemma LeadsTo_weaken: "[| F \<in> A LeadsTo A'; B<=A; A'<=B' |] ==> F \<in> B LeadsTo B'"
by (blast intro: LeadsTo_weaken_R LeadsTo_weaken_L LeadsTo_Trans)

lemma Always_LeadsTo_weaken:
"[| F \<in> Always(C);  F \<in> A LeadsTo A'; C \<inter> B \<subseteq> A;   C \<inter> A' \<subseteq> B' |]
      ==> F \<in> B LeadsTo B'"
apply (blast dest: Always_LeadsToI intro: LeadsTo_weaken Always_LeadsToD)
done

(** Two theorems for "proof lattices" **)

lemma LeadsTo_Un_post: "F \<in> A LeadsTo B ==> F:(A \<union> B) LeadsTo B"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_Un subset_imp_LeadsTo)

lemma LeadsTo_Trans_Un: "[| F \<in> A LeadsTo B;  F \<in> B LeadsTo C |]
      ==> F \<in> (A \<union> B) LeadsTo C"
apply (blast intro: LeadsTo_Un subset_imp_LeadsTo LeadsTo_weaken_L LeadsTo_Trans dest: LeadsTo_type [THEN subsetD])
done

(** Distributive laws **)
lemma LeadsTo_Un_distrib: "(F \<in> (A \<union> B) LeadsTo C)  \<longleftrightarrow> (F \<in> A LeadsTo C & F \<in> B LeadsTo C)"
by (blast intro: LeadsTo_Un LeadsTo_weaken_L)

lemma LeadsTo_UN_distrib: "(F \<in> (\<Union>i \<in> I. A(i)) LeadsTo B) \<longleftrightarrow>  (\<forall>i \<in> I. F \<in> A(i) LeadsTo B) & F \<in> program"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_UN LeadsTo_weaken_L)

lemma LeadsTo_Union_distrib: "(F \<in> \<Union>(S) LeadsTo B)  \<longleftrightarrow>  (\<forall>A \<in> S. F \<in> A LeadsTo B) & F \<in> program"
by (blast dest: LeadsTo_type [THEN subsetD]
             intro: LeadsTo_Union LeadsTo_weaken_L)

(** More rules using the premise "Always(I)" **)

lemma EnsuresI: "[| F:(A-B) Co (A \<union> B);  F \<in> transient (A-B) |] ==> F \<in> A Ensures B"
apply (simp add: Ensures_def Constrains_eq_constrains)
apply (blast intro: ensuresI constrains_weaken transient_strengthen dest: constrainsD2)
done

lemma Always_LeadsTo_Basis: "[| F \<in> Always(I); F \<in> (I \<inter> (A-A')) Co (A \<union> A');
         F \<in> transient (I \<inter> (A-A')) |]
  ==> F \<in> A LeadsTo A'"
apply (rule Always_LeadsToI, assumption)
apply (blast intro: EnsuresI LeadsTo_Basis Always_ConstrainsD [THEN Constrains_weaken] transient_strengthen)
done

(*Set difference: maybe combine with leadsTo_weaken_L??
  This is the most useful form of the "disjunction" rule*)
lemma LeadsTo_Diff:
     "[| F \<in> (A-B) LeadsTo C;  F \<in> (A \<inter> B) LeadsTo C |] ==> F \<in> A LeadsTo C"
by (blast intro: LeadsTo_Un LeadsTo_weaken)

lemma LeadsTo_UN_UN:
     "[|(!!i. i \<in> I ==> F \<in> A(i) LeadsTo A'(i)); F \<in> program |]
      ==> F \<in> (\<Union>i \<in> I. A(i)) LeadsTo (\<Union>i \<in> I. A'(i))"
apply (rule LeadsTo_Union, auto)
apply (blast intro: LeadsTo_weaken_R)
done

(*Binary union version*)
lemma LeadsTo_Un_Un:
  "[| F \<in> A LeadsTo A'; F \<in> B LeadsTo B' |] ==> F:(A \<union> B) LeadsTo (A' \<union> B')"
by (blast intro: LeadsTo_Un LeadsTo_weaken_R)

(** The cancellation law **)

lemma LeadsTo_cancel2: "[| F \<in> A LeadsTo(A' \<union> B); F \<in> B LeadsTo B' |] ==> F \<in> A LeadsTo (A' \<union> B')"
by (blast intro: LeadsTo_Un_Un subset_imp_LeadsTo LeadsTo_Trans dest: LeadsTo_type [THEN subsetD])

lemma Un_Diff: "A \<union> (B - A) = A \<union> B"
by auto

lemma LeadsTo_cancel_Diff2: "[| F \<in> A LeadsTo (A' \<union> B); F \<in> (B-A') LeadsTo B' |] ==> F \<in> A LeadsTo (A' \<union> B')"
apply (rule LeadsTo_cancel2)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: Un_Diff)
done

lemma LeadsTo_cancel1: "[| F \<in> A LeadsTo (B \<union> A'); F \<in> B LeadsTo B' |] ==> F \<in> A LeadsTo (B' \<union> A')"
apply (simp add: Un_commute)
apply (blast intro!: LeadsTo_cancel2)
done

lemma Diff_Un2: "(B - A) \<union> A = B \<union> A"
by auto

lemma LeadsTo_cancel_Diff1: "[| F \<in> A LeadsTo (B \<union> A'); F \<in> (B-A') LeadsTo B' |] ==> F \<in> A LeadsTo (B' \<union> A')"
apply (rule LeadsTo_cancel1)
prefer 2 apply assumption
apply (simp (no_asm_simp) add: Diff_Un2)
done

(** The impossibility law **)

(*The set "A" may be non-empty, but it contains no reachable states*)
lemma LeadsTo_empty: "F \<in> A LeadsTo 0 ==> F \<in> Always (state -A)"
apply (simp (no_asm_use) add: LeadsTo_def Always_eq_includes_reachable)
apply (cut_tac reachable_type)
apply (auto dest!: leadsTo_empty)
done

(** PSP \<in> Progress-Safety-Progress **)

(*Special case of PSP \<in> Misra's "stable conjunction"*)
lemma PSP_Stable: "[| F \<in> A LeadsTo A';  F \<in> Stable(B) |]==> F:(A \<inter> B) LeadsTo (A' \<inter> B)"
apply (simp add: LeadsTo_def Stable_eq_stable, clarify)
apply (drule psp_stable, assumption)
apply (simp add: Int_ac)
done

lemma PSP_Stable2: "[| F \<in> A LeadsTo A'; F \<in> Stable(B) |] ==> F \<in> (B \<inter> A) LeadsTo (B \<inter> A')"
apply (simp (no_asm_simp) add: PSP_Stable Int_ac)
done

lemma PSP: "[| F \<in> A LeadsTo A'; F \<in> B Co B'|]==> F \<in> (A \<inter> B') LeadsTo ((A' \<inter> B) \<union> (B' - B))"
apply (simp (no_asm_use) add: LeadsTo_def Constrains_eq_constrains)
apply (blast dest: psp intro: leadsTo_weaken)
done

lemma PSP2: "[| F \<in> A LeadsTo A'; F \<in> B Co B' |]==> F:(B' \<inter> A) LeadsTo ((B \<inter> A') \<union> (B' - B))"
by (simp (no_asm_simp) add: PSP Int_ac)

lemma PSP_Unless:
"[| F \<in> A LeadsTo A'; F \<in> B Unless B'|]==> F:(A \<inter> B) LeadsTo ((A' \<inter> B) \<union> B')"
apply (unfold op_Unless_def)
apply (drule PSP, assumption)
apply (blast intro: LeadsTo_Diff LeadsTo_weaken subset_imp_LeadsTo)
done

(*** Induction rules ***)

(** Meta or object quantifier ????? **)
lemma LeadsTo_wf_induct: "[| wf(r);
         \<forall>m \<in> I. F \<in> (A \<inter> f-``{m}) LeadsTo
                            ((A \<inter> f-``(converse(r) `` {m})) \<union> B);
         field(r)<=I; A<=f-``I; F \<in> program |]
      ==> F \<in> A LeadsTo B"
apply (simp (no_asm_use) add: LeadsTo_def)
apply auto
apply (erule_tac I = I and f = f in leadsTo_wf_induct, safe)
apply (drule_tac [2] x = m in bspec, safe)
apply (rule_tac [2] A' = "reachable (F) \<inter> (A \<inter> f -`` (converse (r) ``{m}) \<union> B) " in leadsTo_weaken_R)
apply (auto simp add: Int_assoc)
done

lemma LessThan_induct: "[| \<forall>m \<in> nat. F:(A \<inter> f-``{m}) LeadsTo ((A \<inter> f-``m) \<union> B);
      A<=f-``nat; F \<in> program |] ==> F \<in> A LeadsTo B"
apply (rule_tac A1 = nat and f1 = "%x. x" in wf_measure [THEN LeadsTo_wf_induct])
apply (simp_all add: nat_measure_field)
apply (simp add: ltI Image_inverse_lessThan vimage_def [symmetric])
done

(******
 To be ported ??? I am not sure.

  integ_0_le_induct
  LessThan_bounded_induct
  GreaterThan_bounded_induct

*****)

(*** Completion \<in> Binary and General Finite versions ***)

lemma Completion: "[| F \<in> A LeadsTo (A' \<union> C);  F \<in> A' Co (A' \<union> C);
         F \<in> B LeadsTo (B' \<union> C);  F \<in> B' Co (B' \<union> C) |]
      ==> F \<in> (A \<inter> B) LeadsTo ((A' \<inter> B') \<union> C)"
apply (simp (no_asm_use) add: LeadsTo_def Constrains_eq_constrains Int_Un_distrib)
apply (blast intro: completion leadsTo_weaken)
done

lemma Finite_completion_aux:
     "[| I \<in> Fin(X);F \<in> program |]
      ==> (\<forall>i \<in> I. F \<in> (A(i)) LeadsTo (A'(i) \<union> C)) \<longrightarrow>
          (\<forall>i \<in> I. F \<in> (A'(i)) Co (A'(i) \<union> C)) \<longrightarrow>
          F \<in> (\<Inter>i \<in> I. A(i)) LeadsTo ((\<Inter>i \<in> I. A'(i)) \<union> C)"
apply (erule Fin_induct)
apply (auto simp del: INT_simps simp add: Inter_0)
apply (rule Completion, auto)
apply (simp del: INT_simps add: INT_extend_simps)
apply (blast intro: Constrains_INT)
done

lemma Finite_completion:
     "[| I \<in> Fin(X); !!i. i \<in> I ==> F \<in> A(i) LeadsTo (A'(i) \<union> C);
         !!i. i \<in> I ==> F \<in> A'(i) Co (A'(i) \<union> C);
         F \<in> program |]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) LeadsTo ((\<Inter>i \<in> I. A'(i)) \<union> C)"
by (blast intro: Finite_completion_aux [THEN mp, THEN mp])

lemma Stable_completion:
     "[| F \<in> A LeadsTo A';  F \<in> Stable(A');
         F \<in> B LeadsTo B';  F \<in> Stable(B') |]
    ==> F \<in> (A \<inter> B) LeadsTo (A' \<inter> B')"
apply (unfold Stable_def)
apply (rule_tac C1 = 0 in Completion [THEN LeadsTo_weaken_R])
    prefer 5
    apply blast
apply auto
done

lemma Finite_stable_completion:
     "[| I \<in> Fin(X);
         (!!i. i \<in> I ==> F \<in> A(i) LeadsTo A'(i));
         (!!i. i \<in> I ==>F \<in> Stable(A'(i)));   F \<in> program  |]
      ==> F \<in> (\<Inter>i \<in> I. A(i)) LeadsTo (\<Inter>i \<in> I. A'(i))"
apply (unfold Stable_def)
apply (rule_tac C1 = 0 in Finite_completion [THEN LeadsTo_weaken_R], simp_all)
apply (rule_tac [3] subset_refl, auto)
done

ML {*
(*proves "ensures/leadsTo" properties when the program is specified*)
fun ensures_tac ctxt sact =
  SELECT_GOAL
    (EVERY [REPEAT (Always_Int_tac ctxt 1),
            etac @{thm Always_LeadsTo_Basis} 1
                ORELSE   (*subgoal may involve LeadsTo, leadsTo or ensures*)
                REPEAT (ares_tac [@{thm LeadsTo_Basis}, @{thm leadsTo_Basis},
                                  @{thm EnsuresI}, @{thm ensuresI}] 1),
            (*now there are two subgoals: co & transient*)
            simp_tac (ctxt addsimps (Named_Theorems.get ctxt @{named_theorems program})) 2,
            res_inst_tac ctxt [(("act", 0), sact)] @{thm transientI} 2,
               (*simplify the command's domain*)
            simp_tac (ctxt addsimps [@{thm domain_def}]) 3,
            (* proving the domain part *)
           clarify_tac ctxt 3, dtac @{thm swap} 3, force_tac ctxt 4,
           rtac @{thm ReplaceI} 3, force_tac ctxt 3, force_tac ctxt 4,
           asm_full_simp_tac ctxt 3, rtac @{thm conjI} 3, simp_tac ctxt 4,
           REPEAT (rtac @{thm state_update_type} 3),
           constrains_tac ctxt 1,
           ALLGOALS (clarify_tac ctxt),
           ALLGOALS (asm_full_simp_tac (ctxt addsimps [@{thm st_set_def}])),
                      ALLGOALS (clarify_tac ctxt),
          ALLGOALS (asm_lr_simp_tac ctxt)]);
*}

method_setup ensures = {*
    Args.goal_spec -- Scan.lift Args.name_inner_syntax >>
    (fn (quant, s) => fn ctxt => SIMPLE_METHOD'' quant (ensures_tac ctxt s))
*} "for proving progress properties"

end


theory Finite_Linear_Tick_Param

imports
  Finite_Linear_Model
  Finite_Linear_Ops
begin

text \<open>This theory extends the finite linear model to capture termination by
      considering the special event 'tick' and where termination is unstable. \<close>

type_synonym 'e tick = "'e fltrace \<Rightarrow> 'e"
type_synonym 'e fltracetick = "'e \<Rightarrow> 'e fltrace"

(* Do we actually need to refuse everything after tick?*)

(* Problem with this treatment of tick, rather than at the
   data-type level is that we need to enforce tick as the
   last event possible for a trace via a healthiness
   condition. *)

primrec events :: "'e fltrace \<Rightarrow> 'e set" where
"events \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> = {}" |
"events (A #\<^sub>\<F>\<^sub>\<L> xs) = {event(A)} \<union> events(xs)"

definition Skip :: "'e \<Rightarrow> 'e fltrace set" where
"Skip tick = {\<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>,\<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>}"

definition SeqComp :: "'e fltrace set \<Rightarrow> 'e \<Rightarrow> 'e fltrace set \<Rightarrow> 'e fltrace set" ("(_/ '(_');\<^sub>\<F>\<^sub>\<L> _)" [51, 51, 51] 50) where (*(infixl ";\<^sub>\<F>\<^sub>\<L>" 65) where*)
"P (tick);\<^sub>\<F>\<^sub>\<L> Q = {x|x s t. (s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> t \<in> Q \<and> x = s &\<^sub>\<F>\<^sub>\<L> t) \<or> (s \<in> P \<and> tick \<notin> events(s) \<and> x = s)}" (*  \<union> {s|s. s\<in> P \<and> tick \<notin> events(s)}" *)

fun tickWF :: "'e \<Rightarrow> 'e fltrace \<Rightarrow> bool" where
"tickWF tick \<langle>A\<rangle>\<^sub>\<F>\<^sub>\<L> = (tick \<notin>\<^sub>\<F>\<^sub>\<L> A)" |
"tickWF tick (A #\<^sub>\<F>\<^sub>\<L> xs) = (tick \<notin>\<^sub>\<F>\<^sub>\<L> acceptance(A) \<and> (if event(A) = tick then (xs = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) else tickWF tick xs))"

definition FLTick0 :: "'e \<Rightarrow> 'e fltrace set \<Rightarrow> bool" where
"FLTick0 tick P \<equiv> \<forall>x. x \<in> P \<longrightarrow> tickWF tick x"

lemma FLTick0_Skip:
  "FLTick0 tick (Skip tick)"
  unfolding Skip_def FLTick0_def by auto

lemma tickWF_last_x_is_emptyset:
  assumes "tickWF tick x" "tick \<in> events x"
  shows "last x = \<bullet>"
  using assms apply (induct x rule:tickWF.induct, auto)
  by fastforce

lemma tickWF_consFL_iff_fixpoint:
  assumes "tick \<in> events x" "tickWF tick (x &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  shows "x = x &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms apply (induct x, auto, case_tac xa, auto, case_tac x1, auto)
  apply (case_tac x1a, auto)
   apply (case_tac a, auto)
  apply presburger
  by (metis amember.simps(1) tickWF.simps(1))

fun butlastaevent :: "'a fltrace \<Rightarrow> 'a fltrace" where
"butlastaevent \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L> = \<langle>x\<rangle>\<^sub>\<F>\<^sub>\<L>" |
"butlastaevent (x #\<^sub>\<F>\<^sub>\<L> \<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>) = \<langle>y\<rangle>\<^sub>\<F>\<^sub>\<L>" |
"butlastaevent (x #\<^sub>\<F>\<^sub>\<L> xs) = x #\<^sub>\<F>\<^sub>\<L> butlastaevent xs"

lemma tickWF_tick_events_butlastaevent:
  assumes "tick \<in> events x" "tickWF tick x"
  shows "x = butlastaevent x &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
  using assms apply (induct x)
   apply (case_tac x, auto, case_tac x1a, auto)
  apply (case_tac x1a, auto)
   apply (case_tac "b = tick", auto)
   apply (case_tac x, auto)
   apply (case_tac "b = tick", auto)
  by (case_tac x, auto)

lemma x_in_P_tickWF_exists:
  assumes "x \<in> P" "tickWF tick x"
  shows "\<exists>s. s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> (\<exists>t. (t = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<or> t = \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> x = s &\<^sub>\<F>\<^sub>\<L> t) \<or> s \<in> P \<and> tick \<notin> events s \<and> x = s"
  using assms
proof (cases "tick \<in> events(x)")
  case True
  then have butlastaevent:"x = butlastaevent x &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>"
    by (simp add: assms(2) tickWF_tick_events_butlastaevent)
  then have "(\<exists>t. (t = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<or> t = \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> x = butlastaevent x &\<^sub>\<F>\<^sub>\<L> t)"
    by blast
  then have "butlastaevent x &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> (\<exists>t. (t = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<or> t = \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> x = butlastaevent x &\<^sub>\<F>\<^sub>\<L> t)"
    using butlastaevent assms(1) by auto
  then have "\<exists>s. s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> (\<exists>t. (t = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<or> t = \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> x = s &\<^sub>\<F>\<^sub>\<L> t \<and> s = butlastaevent x)"
    by blast
  then have "\<exists>s. s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<in> P \<and> (\<exists>t. (t = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<or> t = \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>) \<and> x = s &\<^sub>\<F>\<^sub>\<L> t)"
    by blast
  then show ?thesis
    by auto
next
  case False
  then show ?thesis using assms by auto
qed

lemma Skip_right_unit:
  assumes "FL1 P" "FLTick0 tick P"
  shows "(P (tick);\<^sub>\<F>\<^sub>\<L> (Skip tick)) = P"
  using assms unfolding SeqComp_def Skip_def apply auto
  using x_in_P_tickWF_exists
  by (metis FLTick0_def)

lemma s_and_tick_iff:
  "s &\<^sub>\<F>\<^sub>\<L> \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> = \<langle>(\<bullet>,tick)\<^sub>\<F>\<^sub>\<L>,\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L> \<longleftrightarrow> (s = \<langle>\<bullet>\<rangle>\<^sub>\<F>\<^sub>\<L>)"
  by (induct s, auto, case_tac x, auto, case_tac s, auto, case_tac x1, auto)

lemma Stop_is_left_zero:
  shows "(Stop (tick);\<^sub>\<F>\<^sub>\<L> P) = Stop"
  unfolding Stop_def SeqComp_def apply auto
   apply (case_tac s, auto, case_tac x1, auto, case_tac t, auto, case_tac x1, auto)
  by (case_tac s, auto, case_tac x1, auto)

lemma Div_is_left_zero:
  shows "(Div (tick);\<^sub>\<F>\<^sub>\<L> P) = Div"
  unfolding Div_def SeqComp_def apply auto
  by (metis Finite_Linear_Model.last.simps(1) Finite_Linear_Model.last.simps(2) bullet_right_zero2 fltrace.distinct(1) last_dist_plus rev3.simps(1) rev3_little_more)

lemma Skip_left_unit:
  assumes "FL0 P" "FL1 P"
  shows "(Skip tick (tick);\<^sub>\<F>\<^sub>\<L> P) = P"
  using assms unfolding SeqComp_def Skip_def apply auto
  apply (auto simp add:s_and_tick_iff)
  by (metis Finite_Linear_Model.last.simps(1) Finite_Linear_Model.last.simps(2) bullet_right_zero2 fltrace.distinct(1) last_dist_plus rev3.simps(1) rev3_little_more)

lemma SeqComp_dist_IntChoice_left:
  shows "P (tick);\<^sub>\<F>\<^sub>\<L> (Q \<sqinter>\<^sub>\<F>\<^sub>\<L> R) = (P (tick);\<^sub>\<F>\<^sub>\<L> Q) \<sqinter>\<^sub>\<F>\<^sub>\<L> (P (tick);\<^sub>\<F>\<^sub>\<L> R)"
  unfolding SeqComp_def IntChoice_def by auto

lemma SeqComp_dist_IntChoice_right:
  shows "(P \<sqinter>\<^sub>\<F>\<^sub>\<L> Q) (tick);\<^sub>\<F>\<^sub>\<L> R = (P (tick);\<^sub>\<F>\<^sub>\<L> R) \<sqinter>\<^sub>\<F>\<^sub>\<L> (Q (tick);\<^sub>\<F>\<^sub>\<L> R)"
  unfolding SeqComp_def IntChoice_def by auto

lemma
  shows "(P \<box>\<^sub>\<F>\<^sub>\<L> Q) (tick);\<^sub>\<F>\<^sub>\<L> R = (P (tick);\<^sub>\<F>\<^sub>\<L> R) \<box>\<^sub>\<F>\<^sub>\<L> (Q (tick);\<^sub>\<F>\<^sub>\<L> R)"
  unfolding SeqComp_def ExtChoice_def apply auto
  oops

lemma not_in_events_not_in_butlast_twice:
  assumes "tick \<notin> events(x)"
  shows "tick \<notin> events(butlast(butlast x))"
  using assms by (induct x, auto)

end


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

section\<open>The Woo-Lam Protocol\<close>

theory WooLam imports Public begin

text\<open>Simplified version from page 11 of
  Abadi and Needham (1996).
  Prudent Engineering Practice for Cryptographic Protocols.
  IEEE Trans. S.E. 22(1), pages 6-15.

Note: this differs from the Woo-Lam protocol discussed by Lowe (1996):
  Some New Attacks upon Security Protocols.
  Computer Security Foundations Workshop
\<close>

inductive_set woolam :: "event list set"
  where
         (*Initial trace is empty*)
   Nil:  "[] \<in> woolam"

         (** These rules allow agents to send messages to themselves **)

         (*The spy MAY say anything he CAN say.  We do not expect him to
           invent new nonces here, but he can also use NS1.  Common to
           all similar protocols.*)
 | Fake: "\<lbrakk>evsf \<in> woolam;  X \<in> synth (analz (spies evsf))\<rbrakk>
          \<Longrightarrow> Says Spy B X  # evsf \<in> woolam"

         (*Alice initiates a protocol run*)
 | WL1:  "evs1 \<in> woolam \<Longrightarrow> Says A B (Agent A) # evs1 \<in> woolam"

         (*Bob responds to Alice's message with a challenge.*)
 | WL2:  "\<lbrakk>evs2 \<in> woolam;  Says A' B (Agent A) \<in> set evs2\<rbrakk>
          \<Longrightarrow> Says B A (Nonce NB) # evs2 \<in> woolam"

         (*Alice responds to Bob's challenge by encrypting NB with her key.
           B is *not* properly determined -- Alice essentially broadcasts
           her reply.*)
 | WL3:  "\<lbrakk>evs3 \<in> woolam;
             Says A  B (Agent A)  \<in> set evs3;
             Says B' A (Nonce NB) \<in> set evs3\<rbrakk>
          \<Longrightarrow> Says A B (Crypt (shrK A) (Nonce NB)) # evs3 \<in> woolam"

         (*Bob forwards Alice's response to the Server.  NOTE: usually
           the messages are shown in chronological order, for clarity.
           But here, exchanging the two events would cause the lemma
           WL4_analz_spies to pick up the wrong assumption!*)
 | WL4:  "\<lbrakk>evs4 \<in> woolam;
             Says A'  B X         \<in> set evs4;
             Says A'' B (Agent A) \<in> set evs4\<rbrakk>
          \<Longrightarrow> Says B Server \<lbrace>Agent A, Agent B, X\<rbrace> # evs4 \<in> woolam"

         (*Server decrypts Alice's response for Bob.*)
 | WL5:  "\<lbrakk>evs5 \<in> woolam;
             Says B' Server \<lbrace>Agent A, Agent B, Crypt (shrK A) (Nonce NB)\<rbrace>
               \<in> set evs5\<rbrakk>
          \<Longrightarrow> Says Server B (Crypt (shrK B) \<lbrace>Agent A, Nonce NB\<rbrace>)
                 # evs5 \<in> woolam"

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

(*A "possibility property": there are traces that reach the end*)
lemma "\<exists>NB. \<exists>evs \<in> woolam.
             Says Server B (Crypt (shrK B) \<lbrace>Agent A, Nonce NB\<rbrace>) \<in> set evs"
apply (intro exI bexI)
apply (rule_tac [2] woolam.Nil
                    [THEN woolam.WL1, THEN woolam.WL2, THEN woolam.WL3,
                     THEN woolam.WL4, THEN woolam.WL5], possibility)
done

(*Could prove forwarding lemmas for WL4, but we do not need them!*)

(**** Inductive proofs about woolam ****)

(** Theorems of the form X \<notin> parts (spies evs) imply that NOBODY
    sends messages containing X! **)

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

lemma Spy_analz_shrK [simp]:
     "evs \<in> woolam \<Longrightarrow> (Key (shrK A) \<in> analz (spies evs)) = (A \<in> bad)"
by auto

lemma Spy_see_shrK_D [dest!]:
     "\<lbrakk>Key (shrK A) \<in> parts (knows Spy evs);  evs \<in> woolam\<rbrakk> \<Longrightarrow> A \<in> bad"
by (blast dest: Spy_see_shrK)

(**** Autheticity properties for Woo-Lam ****)

(*** WL4 ***)

(*If the encrypted message appears then it originated with Alice*)
lemma NB_Crypt_imp_Alice_msg:
     "\<lbrakk>Crypt (shrK A) (Nonce NB) \<in> parts (spies evs);
         A \<notin> bad;  evs \<in> woolam\<rbrakk>
      \<Longrightarrow> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*Guarantee for Server: if it gets a message containing a certificate from
  Alice, then she originated that certificate.  But we DO NOT know that B
  ever saw it: the Spy may have rerouted the message to the Server.*)
lemma Server_trusts_WL4 [dest]:
     "\<lbrakk>Says B' Server \<lbrace>Agent A, Agent B, Crypt (shrK A) (Nonce NB)\<rbrace>
           \<in> set evs;
         A \<notin> bad;  evs \<in> woolam\<rbrakk>
      \<Longrightarrow> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (blast intro!: NB_Crypt_imp_Alice_msg)

(*** WL5 ***)

(*Server sent WL5 only if it received the right sort of message*)
lemma Server_sent_WL5 [dest]:
     "\<lbrakk>Says Server B (Crypt (shrK B) \<lbrace>Agent A, NB\<rbrace>) \<in> set evs;
         evs \<in> woolam\<rbrakk>
      \<Longrightarrow> \<exists>B'. Says B' Server \<lbrace>Agent A, Agent B, Crypt (shrK A) NB\<rbrace>
             \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*If the encrypted message appears then it originated with the Server!*)
lemma NB_Crypt_imp_Server_msg [rule_format]:
     "\<lbrakk>Crypt (shrK B) \<lbrace>Agent A, NB\<rbrace> \<in> parts (spies evs);
         B \<notin> bad;  evs \<in> woolam\<rbrakk>
      \<Longrightarrow> Says Server B (Crypt (shrK B) \<lbrace>Agent A, NB\<rbrace>) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(*Guarantee for B.  If B gets the Server's certificate then A has encrypted
  the nonce using her key.  This event can be no older than the nonce itself.
  But A may have sent the nonce to some other agent and it could have reached
  the Server via the Spy.*)
lemma B_trusts_WL5:
     "\<lbrakk>Says S B (Crypt (shrK B) \<lbrace>Agent A, Nonce NB\<rbrace>) \<in> set evs;
         A \<notin> bad;  B \<notin> bad;  evs \<in> woolam\<rbrakk>
      \<Longrightarrow> \<exists>B. Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
by (blast dest!: NB_Crypt_imp_Server_msg)

(*B only issues challenges in response to WL1.  Not used.*)
lemma B_said_WL2:
     "\<lbrakk>Says B A (Nonce NB) \<in> set evs;  B \<noteq> Spy;  evs \<in> woolam\<rbrakk>
      \<Longrightarrow> \<exists>A'. Says A' B (Agent A) \<in> set evs"
by (erule rev_mp, erule woolam.induct, force, simp_all, blast+)

(**CANNOT be proved because A doesn't know where challenges come from...*)
lemma "\<lbrakk>A \<notin> bad;  B \<noteq> Spy;  evs \<in> woolam\<rbrakk>
  \<Longrightarrow> Crypt (shrK A) (Nonce NB) \<in> parts (spies evs) \<and>
      Says B A (Nonce NB) \<in> set evs
      \<longrightarrow> Says A B (Crypt (shrK A) (Nonce NB)) \<in> set evs"
apply (erule rev_mp, erule woolam.induct, force, simp_all, blast, auto)
oops

end