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

section \<open>Master Theorem with Reduced Subformulas\<close>

theory Restricted_Master_Theorem
imports
  Master_Theorem
begin

subsection \<open>Restricted Set of Subformulas\<close>

fun restricted_subformulas_inner :: "'a ltln \<Rightarrow> 'a ltln set"
where
  "restricted_subformulas_inner (\<phi> and\<^sub>n \<psi>) = restricted_subformulas_inner \<phi> \<union> restricted_subformulas_inner \<psi>"
| "restricted_subformulas_inner (\<phi> or\<^sub>n \<psi>) = restricted_subformulas_inner \<phi> \<union> restricted_subformulas_inner \<psi>"
| "restricted_subformulas_inner (X\<^sub>n \<phi>) = restricted_subformulas_inner \<phi>"
| "restricted_subformulas_inner (\<phi> U\<^sub>n \<psi>) = subformulas\<^sub>\<nu> (\<phi> U\<^sub>n \<psi>) \<union> subformulas\<^sub>\<mu> (\<phi> U\<^sub>n \<psi>)"
| "restricted_subformulas_inner (\<phi> R\<^sub>n \<psi>) = restricted_subformulas_inner \<phi> \<union> restricted_subformulas_inner \<psi>"
| "restricted_subformulas_inner (\<phi> W\<^sub>n \<psi>) = restricted_subformulas_inner \<phi> \<union> restricted_subformulas_inner \<psi>"
| "restricted_subformulas_inner (\<phi> M\<^sub>n \<psi>) = subformulas\<^sub>\<nu> (\<phi> M\<^sub>n \<psi>) \<union> subformulas\<^sub>\<mu> (\<phi> M\<^sub>n \<psi>)"
| "restricted_subformulas_inner _ = {}"

fun restricted_subformulas :: "'a ltln \<Rightarrow> 'a ltln set"
where
  "restricted_subformulas (\<phi> and\<^sub>n \<psi>) = restricted_subformulas \<phi> \<union> restricted_subformulas \<psi>"
| "restricted_subformulas (\<phi> or\<^sub>n \<psi>) = restricted_subformulas \<phi> \<union> restricted_subformulas \<psi>"
| "restricted_subformulas (X\<^sub>n \<phi>) = restricted_subformulas \<phi>"
| "restricted_subformulas (\<phi> U\<^sub>n \<psi>) = restricted_subformulas \<phi> \<union> restricted_subformulas \<psi>"
| "restricted_subformulas (\<phi> R\<^sub>n \<psi>) = restricted_subformulas \<phi> \<union> restricted_subformulas_inner \<psi>"
| "restricted_subformulas (\<phi> W\<^sub>n \<psi>) = restricted_subformulas_inner \<phi> \<union> restricted_subformulas \<psi>"
| "restricted_subformulas (\<phi> M\<^sub>n \<psi>) = restricted_subformulas \<phi> \<union> restricted_subformulas \<psi>"
| "restricted_subformulas _ = {}"

lemma GF_advice_restricted_subformulas_inner:
  "restricted_subformulas_inner (\<phi>[X]\<^sub>\<nu>) = {}"
  by (induction \<phi>) simp_all

lemma GF_advice_restricted_subformulas:
  "restricted_subformulas (\<phi>[X]\<^sub>\<nu>) = {}"
  by (induction \<phi>) (simp_all add: GF_advice_restricted_subformulas_inner)

lemma restricted_subformulas_inner_subset:
  "restricted_subformulas_inner \<phi> \<subseteq> subformulas\<^sub>\<nu> \<phi> \<union> subformulas\<^sub>\<mu> \<phi>"
  by (induction \<phi>) auto

lemma restricted_subformulas_subset':
  "restricted_subformulas \<phi> \<subseteq> restricted_subformulas_inner \<phi>"
  by (induction \<phi>) (insert restricted_subformulas_inner_subset, auto)

lemma restricted_subformulas_subset:
  "restricted_subformulas \<phi> \<subseteq> subformulas\<^sub>\<nu> \<phi> \<union> subformulas\<^sub>\<mu> \<phi>"
  using restricted_subformulas_inner_subset restricted_subformulas_subset' by auto

lemma restricted_subformulas_size:
  "\<psi> \<in> restricted_subformulas \<phi> \<Longrightarrow> size \<psi> < size \<phi>"
proof -
  have "\<And>\<phi>. restricted_subformulas_inner \<phi> \<subseteq> subfrmlsn \<phi>"
    using restricted_subformulas_inner_subset subformulas\<^sub>\<mu>\<^sub>\<nu>_subfrmlsn by blast

  then have inner: "\<And>\<psi> \<phi>. \<psi> \<in> restricted_subformulas_inner \<phi> \<Longrightarrow> size \<psi> \<le> size \<phi>"
    using subfrmlsn_size dual_order.strict_implies_order
    by blast

  show "\<psi> \<in> restricted_subformulas \<phi> \<Longrightarrow> size \<psi> < size \<phi>"
    by (induction \<phi> arbitrary: \<psi>) (fastforce dest: inner)+
qed

lemma restricted_subformulas_notin:
  "\<phi> \<notin> restricted_subformulas \<phi>"
  using restricted_subformulas_size by auto

lemma restricted_subformulas_superset:
  "\<psi> \<in> restricted_subformulas \<phi> \<Longrightarrow> subformulas\<^sub>\<nu> \<psi> \<union> subformulas\<^sub>\<mu> \<psi> \<subseteq> restricted_subformulas \<phi>"
proof -
  assume "\<psi> \<in> restricted_subformulas \<phi>"

  then obtain \<chi> x where
    "\<psi> \<in> restricted_subformulas_inner \<chi>" and "(x R\<^sub>n \<chi>) \<in> subformulas\<^sub>\<nu> \<phi> \<or> (\<chi> W\<^sub>n x) \<in> subformulas\<^sub>\<nu> \<phi> "
    by (induction \<phi>) auto

  moreover

  have "\<And>\<psi>\<^sub>1 \<psi>\<^sub>2. (\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2) \<in> subformulas\<^sub>\<nu> \<phi> \<Longrightarrow> restricted_subformulas_inner \<psi>\<^sub>2 \<subseteq> restricted_subformulas \<phi>"
    "\<And>\<psi>\<^sub>1 \<psi>\<^sub>2. (\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2) \<in> subformulas\<^sub>\<nu> \<phi> \<Longrightarrow> restricted_subformulas_inner \<psi>\<^sub>1 \<subseteq> restricted_subformulas \<phi>"
    by (induction \<phi>) (simp_all; insert restricted_subformulas_subset', blast)+

  moreover

  have "subformulas\<^sub>\<nu> \<psi> \<union> subformulas\<^sub>\<mu> \<psi> \<subseteq>  restricted_subformulas_inner \<chi>"
    using `\<psi> \<in> restricted_subformulas_inner \<chi>`
  proof (induction \<chi>)
    case (Until_ltln \<chi>1 \<chi>2)
    then show ?case
      apply (cases "\<psi> = \<chi>1 U\<^sub>n \<chi>2")
       apply auto[1]
      apply simp
      apply (cases "\<psi> \<in> subformulas\<^sub>\<nu> \<chi>1")
       apply (meson le_supI1 le_supI2 subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subfrmlsn subformulas\<^sub>\<nu>_subset subset_eq subset_insertI2)
      apply (cases "\<psi> \<in> subformulas\<^sub>\<nu> \<chi>2")
       apply (meson le_supI1 le_supI2 subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subfrmlsn subformulas\<^sub>\<nu>_subset subset_eq subset_insertI2)
      apply (cases "\<psi> \<in> subformulas\<^sub>\<mu> \<chi>1")
       apply (metis (no_types, hide_lams) Un_insert_right subformulas\<^sub>\<mu>_subfrmlsn subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subset subsetD sup.coboundedI2 sup_commute)
      apply simp
      by (metis (no_types, hide_lams) Un_insert_right subformulas\<^sub>\<mu>_subfrmlsn subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subset subsetD sup.coboundedI2 sup_commute)
  next
    case (Release_ltln \<chi>1 \<chi>2)
    then show ?case by simp blast
  next
    case (WeakUntil_ltln \<chi>1 \<chi>2)
    then show ?case by simp blast
  next
    case (StrongRelease_ltln \<chi>1 \<chi>2)
    then show ?case
      apply (cases "\<psi> = \<chi>1 M\<^sub>n \<chi>2")
       apply auto[1]
      apply simp
      apply (cases "\<psi> \<in> subformulas\<^sub>\<nu> \<chi>1")
       apply (meson le_supI1 le_supI2 subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subfrmlsn subformulas\<^sub>\<nu>_subset subset_eq subset_insertI2)
      apply (cases "\<psi> \<in> subformulas\<^sub>\<nu> \<chi>2")
       apply (meson le_supI1 le_supI2 subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subfrmlsn subformulas\<^sub>\<nu>_subset subset_eq subset_insertI2)
      apply (cases "\<psi> \<in> subformulas\<^sub>\<mu> \<chi>1")
       apply (metis (no_types, hide_lams) Un_insert_right subformulas\<^sub>\<mu>_subfrmlsn subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subset subsetD sup.coboundedI2 sup_commute)
      apply simp
      by (metis (no_types, hide_lams) Un_insert_right subformulas\<^sub>\<mu>_subfrmlsn subformulas\<^sub>\<mu>_subset subformulas\<^sub>\<nu>_subset subsetD sup.coboundedI2 sup_commute)
  qed auto

  ultimately

  show "subformulas\<^sub>\<nu> \<psi> \<union> subformulas\<^sub>\<mu> \<psi> \<subseteq> restricted_subformulas \<phi>"
    by blast
qed

lemma restricted_subformulas_W_\<mu>:
  "subformulas\<^sub>\<mu> \<phi> \<subseteq> restricted_subformulas (\<phi> W\<^sub>n \<psi>)"
  by (induction \<phi>) auto

lemma restricted_subformulas_R_\<mu>:
  "subformulas\<^sub>\<mu> \<psi> \<subseteq> restricted_subformulas (\<phi> R\<^sub>n \<psi>)"
  by (induction \<psi>) auto

lemma restrict_af_letter:
  "restricted_subformulas (af_letter \<phi> \<sigma>) = restricted_subformulas \<phi>"
proof (induction \<phi>)
  case (Release_ltln \<phi>1 \<phi>2)
  then show ?case
    using restricted_subformulas_subset' by simp blast
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)
  then show ?case
    using restricted_subformulas_subset' by simp blast
qed auto

lemma restrict_af:
  "restricted_subformulas (af \<phi> w) = restricted_subformulas \<phi>"
  by (induction w rule: rev_induct) (auto simp: restrict_af_letter)

subsection \<open>Restricted Master Theorem / Lemmas\<close>

lemma delay_2:
  assumes "\<mu>_stable \<phi> w"
  assumes "w \<Turnstile>\<^sub>n \<phi>"
  shows "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>]\<^sub>\<nu>"
  using assms
proof (induction \<phi> arbitrary: w)
  case (Prop_ltln x)
  then show ?case
    by (metis GF_advice.simps(10) GF_advice_af prefix_suffix)
next
  case (Nprop_ltln x)
  then show ?case
    by (metis GF_advice.simps(11) GF_advice_af prefix_suffix)
next
  case (And_ltln \<phi>1 \<phi>2)

  let ?X  = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas (\<phi>1 and\<^sub>n \<phi>2)"
  let ?X1 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>1"
  let ?X2 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>2"

  have "?X1 \<subseteq> ?X" and "?X2 \<subseteq> ?X"
    by auto

  moreover

  obtain i j where "suffix i w \<Turnstile>\<^sub>n af \<phi>1 (prefix i w)[?X1]\<^sub>\<nu>"
    and "suffix j w \<Turnstile>\<^sub>n af \<phi>2 (prefix j w)[?X2]\<^sub>\<nu>"
    using \<mu>_stable_subfrmlsn[OF \<open>\<mu>_stable (\<phi>1 and\<^sub>n \<phi>2) w\<close>] And_ltln by fastforce

  ultimately

  obtain k where "suffix k w \<Turnstile>\<^sub>n af \<phi>1 (prefix k w)[?X]\<^sub>\<nu>"
    and "suffix k w \<Turnstile>\<^sub>n af \<phi>2 (prefix k w)[?X]\<^sub>\<nu>"
    using GF_advice_sync_and GF_advice_monotone by blast

  thus ?case
    unfolding af_decompose semantics_ltln.simps(5) GF_advice.simps by blast
next
  case (Or_ltln \<phi>1 \<phi>2)
  let ?X  = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas (\<phi>1 and\<^sub>n \<phi>2)"
  let ?X1 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>1"
  let ?X2 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>2"

  have "?X1 \<subseteq> ?X" and "?X2 \<subseteq> ?X"
    by auto

  moreover

  obtain i j where "suffix i w \<Turnstile>\<^sub>n af \<phi>1 (prefix i w)[?X1]\<^sub>\<nu> \<or> suffix j w \<Turnstile>\<^sub>n af \<phi>2 (prefix j w)[?X2]\<^sub>\<nu>"
    using \<mu>_stable_subfrmlsn[OF \<open>\<mu>_stable (\<phi>1 or\<^sub>n \<phi>2) w\<close>] Or_ltln by fastforce

  ultimately

  obtain k where "suffix k w \<Turnstile>\<^sub>n af \<phi>1 (prefix k w)[?X]\<^sub>\<nu> \<or> suffix k w \<Turnstile>\<^sub>n af \<phi>2 (prefix k w)[?X]\<^sub>\<nu>"
    using GF_advice_monotone by blast

  thus ?case
    unfolding af_decompose semantics_ltln.simps(6) GF_advice.simps by auto
next
  case (Next_ltln \<phi>)
  then have stable: "\<mu>_stable \<phi> (suffix 1 w)"
    and suffix: "suffix 1 w \<Turnstile>\<^sub>n \<phi>"
    using \<F>_suffix \<G>\<F>_\<F>_subset \<G>\<F>_suffix
    by (simp_all add: \<mu>_stable_def) fast
  show ?case
    by (metis (no_types, lifting) Next_ltln.IH[OF stable suffix, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix] One_nat_def add.commute af_simps(3) foldl_Nil foldl_append restricted_subformulas.simps(3) subsequence_append subsequence_singleton)
next
  case (Until_ltln \<phi>1 \<phi>2)
  let ?X  = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas (\<phi>1 U\<^sub>n \<phi>2)"
  let ?X1 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>1"
  let ?X2 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>2"

  have stable_1: "\<And>i. \<mu>_stable \<phi>1 (suffix i w)"
    and stable_2: "\<And>i. \<mu>_stable \<phi>2 (suffix i w)"
    using \<mu>_stable_subfrmlsn[OF Until_ltln.prems(1)] by (simp add: \<mu>_stable_suffix)+

  obtain i where "\<And>j. j < i \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<phi>1" and "suffix i w \<Turnstile>\<^sub>n \<phi>2"
    using Until_ltln by auto

  then have "\<And>j. j < i \<Longrightarrow> \<exists>k. suffix (j + k) w \<Turnstile>\<^sub>n af \<phi>1 (w [j \<rightarrow> k + j])[?X1]\<^sub>\<nu>"
    and "\<exists>k. suffix (i + k) w \<Turnstile>\<^sub>n af \<phi>2 (w [i \<rightarrow> k + i])[?X2]\<^sub>\<nu>"
    using Until_ltln.IH(1)[OF stable_1, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
    using Until_ltln.IH(2)[OF stable_2, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
    by blast+

  moreover

  have "?X1 \<subseteq> ?X"
    and "?X2 \<subseteq> ?X"
    by auto

  ultimately

  obtain k where "k \<ge> i"
    and "suffix k w \<Turnstile>\<^sub>n af \<phi>2 (w [i \<rightarrow> k])[?X]\<^sub>\<nu>"
    and "\<And>j. j < i \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af \<phi>1 (w [j \<rightarrow> k])[?X]\<^sub>\<nu>"
    using GF_advice_sync_less[of i w \<phi>1 ?X \<phi>2] GF_advice_monotone[of _ ?X] by meson

  hence "suffix (Suc k) w \<Turnstile>\<^sub>n af (\<phi>1 U\<^sub>n \<phi>2) (prefix (Suc k) w)[?X]\<^sub>\<nu>"
    by (rule af_subsequence_U_GF_advice)

  then show ?case
    by blast
next
  case (WeakUntil_ltln \<phi>1 \<phi>2)

  let ?X  = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas (\<phi>1 W\<^sub>n \<phi>2)"
  let ?X1 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>1"
  let ?X2 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>2"

  have stable_1: "\<And>i. \<mu>_stable \<phi>1 (suffix i w)"
    and stable_2: "\<And>i. \<mu>_stable \<phi>2 (suffix i w)"
    using \<mu>_stable_subfrmlsn[OF WeakUntil_ltln.prems(1)] by (simp add: \<mu>_stable_suffix)+

  {
    assume Until_ltln: "w \<Turnstile>\<^sub>n \<phi>1 U\<^sub>n \<phi>2"
    then obtain i where "\<And>j. j < i \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<phi>1" and "suffix i w \<Turnstile>\<^sub>n \<phi>2"
      by auto

    then have "\<And>j. j < i \<Longrightarrow> \<exists>k. suffix (j + k) w \<Turnstile>\<^sub>n af \<phi>1 (w [j \<rightarrow> k + j])[?X1]\<^sub>\<nu>"
      and "\<exists>k. suffix (i + k) w \<Turnstile>\<^sub>n af \<phi>2 (w [i \<rightarrow> k + i])[?X2]\<^sub>\<nu>"
      using WeakUntil_ltln.IH(1)[OF stable_1, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
      using WeakUntil_ltln.IH(2)[OF stable_2, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
      by blast+

    moreover

    have "?X1 \<subseteq> ?X"
      and "?X2 \<subseteq> ?X"
      using restricted_subformulas_subset' by force+

    ultimately

    obtain k where "k \<ge> i"
      and "suffix k w \<Turnstile>\<^sub>n af \<phi>2 (w [i \<rightarrow> k])[?X]\<^sub>\<nu>"
      and "\<And>j. j < i \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af \<phi>1 (w [j \<rightarrow> k])[?X]\<^sub>\<nu>"
      using GF_advice_sync_less[of i w \<phi>1 ?X \<phi>2] GF_advice_monotone[of _ ?X] by meson

    hence "suffix (Suc k) w \<Turnstile>\<^sub>n af (\<phi>1 W\<^sub>n \<phi>2) (prefix (Suc k) w)[?X]\<^sub>\<nu>"
      by (rule af_subsequence_W_GF_advice)
    hence ?case
      by blast
  }
  moreover
  {
    assume Globally_ltln: "w \<Turnstile>\<^sub>n G\<^sub>n \<phi>1"

    {
      fix j
      have "suffix j w \<Turnstile>\<^sub>n \<phi>1"
        using Globally_ltln by simp
      then have "suffix j w \<Turnstile>\<^sub>n \<phi>1[{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)}]\<^sub>\<nu>"
        by (metis stable_1 GF_advice_a1 \<G>\<F>_suffix \<mu>_stable_def \<G>\<F>_elim mem_Collect_eq subsetI)
      then have "suffix j w \<Turnstile>\<^sub>n \<phi>1[?X]\<^sub>\<nu>"
        by (metis GF_advice_inter restricted_subformulas_W_\<mu> le_infI2)
    }

    then have "w \<Turnstile>\<^sub>n (\<phi>1 W\<^sub>n \<phi>2)[?X]\<^sub>\<nu>"
      by simp
    then have ?case
      using GF_advice_af_2 by blast
  }
  ultimately
  show ?case
    using WeakUntil_ltln.prems(2) ltln_weak_to_strong(1) by blast
next
  case (Release_ltln \<phi>1 \<phi>2)

  let ?X  = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas (\<phi>1 R\<^sub>n \<phi>2)"
  let ?X1 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>1"
  let ?X2 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>2"

  have stable_1: "\<And>i. \<mu>_stable \<phi>1 (suffix i w)"
    and stable_2: "\<And>i. \<mu>_stable \<phi>2 (suffix i w)"
    using \<mu>_stable_subfrmlsn[OF Release_ltln.prems(1)] by (simp add: \<mu>_stable_suffix)+

  {
    assume Until_ltln: "w \<Turnstile>\<^sub>n \<phi>1 M\<^sub>n \<phi>2"
    then obtain i where "\<And>j. j \<le> i \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<phi>2" and "suffix i w \<Turnstile>\<^sub>n \<phi>1"
      by auto

    then have "\<And>j. j \<le> i \<Longrightarrow> \<exists>k. suffix (j + k) w \<Turnstile>\<^sub>n af \<phi>2 (w [j \<rightarrow> k + j])[?X2]\<^sub>\<nu>"
      and "\<exists>k. suffix (i + k) w \<Turnstile>\<^sub>n af \<phi>1 (w [i \<rightarrow> k + i])[?X1]\<^sub>\<nu>"
      using Release_ltln.IH(1)[OF stable_1, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
      using Release_ltln.IH(2)[OF stable_2, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
      by blast+

    moreover

    have "?X1 \<subseteq> ?X"
      and "?X2 \<subseteq> ?X"
      using restricted_subformulas_subset' by force+

    ultimately

    obtain k where "k \<ge> i"
      and "suffix k w \<Turnstile>\<^sub>n af \<phi>1 (w [i \<rightarrow> k])[?X]\<^sub>\<nu>"
      and "\<And>j. j \<le> i \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af \<phi>2 (w [j \<rightarrow> k])[?X]\<^sub>\<nu>"
      using GF_advice_sync_lesseq[of i w \<phi>2 ?X \<phi>1] GF_advice_monotone[of _ ?X] by meson

    hence "suffix (Suc k) w \<Turnstile>\<^sub>n af (\<phi>1 R\<^sub>n \<phi>2) (prefix (Suc k) w)[?X]\<^sub>\<nu>"
      by (rule af_subsequence_R_GF_advice)
    hence ?case
      by blast
  }
  moreover
  {
    assume Globally_ltln: "w \<Turnstile>\<^sub>n G\<^sub>n \<phi>2"

    {
      fix j
      have "suffix j w \<Turnstile>\<^sub>n \<phi>2"
        using Globally_ltln by simp
      then have "suffix j w \<Turnstile>\<^sub>n \<phi>2[{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)}]\<^sub>\<nu>"
        by (metis stable_2 GF_advice_a1 \<G>\<F>_suffix \<mu>_stable_def \<G>\<F>_elim mem_Collect_eq subsetI)
      then have "suffix j w \<Turnstile>\<^sub>n \<phi>2[?X]\<^sub>\<nu>"
        by (metis GF_advice_inter restricted_subformulas_R_\<mu> le_infI2)
    }

    then have "w \<Turnstile>\<^sub>n (\<phi>1 R\<^sub>n \<phi>2)[?X]\<^sub>\<nu>"
      by simp
    then have ?case
      using GF_advice_af_2 by blast
  }
  ultimately
  show ?case
    using Release_ltln.prems(2) ltln_weak_to_strong(3) by blast
next
  case (StrongRelease_ltln \<phi>1 \<phi>2)

  let ?X  = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas (\<phi>1 M\<^sub>n \<phi>2)"
  let ?X1 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>1"
  let ?X2 = "{\<psi>. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>)} \<inter> restricted_subformulas \<phi>2"

  have stable_1: "\<And>i. \<mu>_stable \<phi>1 (suffix i w)"
    and stable_2: "\<And>i. \<mu>_stable \<phi>2 (suffix i w)"
    using \<mu>_stable_subfrmlsn[OF StrongRelease_ltln.prems(1)] by (simp add: \<mu>_stable_suffix)+

  obtain i where "\<And>j. j \<le> i \<Longrightarrow> suffix j w \<Turnstile>\<^sub>n \<phi>2" and "suffix i w \<Turnstile>\<^sub>n \<phi>1"
    using StrongRelease_ltln by auto

  then have "\<And>j. j \<le> i \<Longrightarrow> \<exists>k. suffix (j + k) w \<Turnstile>\<^sub>n af \<phi>2 (w [j \<rightarrow> k + j])[?X2]\<^sub>\<nu>"
    and "\<exists>k. suffix (i + k) w \<Turnstile>\<^sub>n af \<phi>1 (w [i \<rightarrow> k + i])[?X1]\<^sub>\<nu>"
    using StrongRelease_ltln.IH(1)[OF stable_1, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
    using StrongRelease_ltln.IH(2)[OF stable_2, unfolded suffix_suffix prefix_suffix_subsequence GF_suffix]
    by blast+

  moreover

  have "?X1 \<subseteq> ?X"
    and "?X2 \<subseteq> ?X"
    by auto

  ultimately

  obtain k where "k \<ge> i"
    and "suffix k w \<Turnstile>\<^sub>n af \<phi>1 (w [i \<rightarrow> k])[?X]\<^sub>\<nu>"
    and "\<And>j. j \<le> i \<Longrightarrow> suffix k w \<Turnstile>\<^sub>n af \<phi>2 (w [j \<rightarrow> k])[?X]\<^sub>\<nu>"
    using GF_advice_sync_lesseq[of i w \<phi>2 ?X \<phi>1] GF_advice_monotone[of _ ?X] by meson

  hence "suffix (Suc k) w \<Turnstile>\<^sub>n af (\<phi>1 M\<^sub>n \<phi>2) (prefix (Suc k) w)[?X]\<^sub>\<nu>"
    by (rule af_subsequence_M_GF_advice)

  then show ?case
    by blast
qed simp+

theorem master_theorem_restricted:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow>
    (\<exists>X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi>.
       (\<exists>Y \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi>.
         (\<exists>i. (suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>)
          \<and> (\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>))
          \<and> (\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)))))"
  (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs

  obtain i where "\<mu>_stable \<phi> (suffix i w)"
   by (metis MOST_nat less_Suc_eq suffix_\<mu>_stable)

  hence stable: "\<mu>_stable (af \<phi> (prefix i w)) (suffix i w)"
    by (simp add: \<F>_af \<G>\<F>_af \<mu>_stable_def)

  let ?\<phi>' = "af \<phi> (prefix i w)"
  let ?X' = "\<G>\<F> \<phi> w \<inter> restricted_subformulas \<phi>"
  let ?Y' = "\<F>\<G> \<phi> w \<inter> restricted_subformulas \<phi>"

  have 1: "suffix i w \<Turnstile>\<^sub>n ?\<phi>'"
    using `?lhs` af_ltl_continuation by force

  have 2: "\<And>j. af (af \<phi> (prefix i w)) (prefix j (suffix i w)) = af \<phi> (prefix (i + j) w)"
    by (simp add: subsequence_append)

  have 3: "\<G>\<F> \<phi> w = \<G>\<F> \<phi> (suffix i w)"
    using \<G>\<F>_af \<G>\<F>_suffix by blast

  have "\<exists>j. suffix (i + j) w \<Turnstile>\<^sub>n af (?\<phi>') (prefix j (suffix i w))[?X']\<^sub>\<nu>"
    using delay_2[OF stable 1] unfolding suffix_suffix 2 restrict_af 3 unfolding \<G>\<F>_semantics'
    by (metis (no_types, lifting) GF_advice_inter_subformulas af_subformulas\<^sub>\<mu> inf_assoc inf_commute)

  hence "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[?X']\<^sub>\<nu>"
    using 2 by auto

  moreover

  {
    fix \<psi>
    have "\<And>X. \<psi> \<in> restricted_subformulas \<phi> \<Longrightarrow> \<psi>[X \<inter> restricted_subformulas \<phi>]\<^sub>\<mu> = \<psi>[X]\<^sub>\<mu>"
      by (metis le_supE restricted_subformulas_superset FG_advice_inter inf.coboundedI2)
    hence "\<psi> \<in> ?X' \<Longrightarrow>  w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[?Y']\<^sub>\<mu>)"
      using \<G>\<F>_implies_GF by force
  }

  moreover

  {
    fix \<psi>
    have "\<And>X. \<psi> \<in> restricted_subformulas \<phi> \<Longrightarrow> \<psi>[X \<inter> restricted_subformulas \<phi>]\<^sub>\<nu> = \<psi>[X]\<^sub>\<nu>"
      by (metis le_supE restricted_subformulas_superset GF_advice_inter inf.coboundedI2)
    hence "\<psi> \<in> ?Y' \<Longrightarrow> w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[?X']\<^sub>\<nu>)"
      using \<F>\<G>_implies_FG by force
  }

  moreover

  have "?X' \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi>"
    using \<G>\<F>_subformulas\<^sub>\<mu> by blast

  moreover

  have "?Y' \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi>"
    using \<F>\<G>_subformulas\<^sub>\<nu> by blast

  ultimately show ?rhs
    by meson
qed (insert master_theorem, fast)

corollary master_theorem_restricted_language:
  "language_ltln \<phi> = \<Union> {L\<^sub>1 \<phi> X \<inter> L\<^sub>2 X Y \<inter> L\<^sub>3 X Y | X Y. X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi> \<and> Y \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi>}"
proof safe
  fix w
  assume "w \<in> language_ltln \<phi>"

  then have "w \<Turnstile>\<^sub>n \<phi>"
    unfolding language_ltln_def by simp

  then obtain X Y where
        1: "X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi>"
    and 2: "Y \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi>"
    and "\<exists>i. suffix i w \<Turnstile>\<^sub>n af \<phi> (prefix i w)[X]\<^sub>\<nu>"
    and "\<forall>\<psi> \<in> X. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[Y]\<^sub>\<mu>)"
    and "\<forall>\<psi> \<in> Y. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[X]\<^sub>\<nu>)"
    using master_theorem_restricted by metis

  then have "w \<in> L\<^sub>1 \<phi> X" and "w \<in> L\<^sub>2 X Y" and "w \<in> L\<^sub>3 X Y"
    unfolding L\<^sub>1_def L\<^sub>2_def L\<^sub>3_def by simp+

  then show "w \<in> \<Union> {L\<^sub>1 \<phi> X \<inter> L\<^sub>2 X Y \<inter> L\<^sub>3 X Y | X Y. X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi> \<and> Y \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi>}"
    using 1 2 by blast
next
  fix w X Y
  assume "X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi>" and "Y \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi>"
    and "w \<in> L\<^sub>1 \<phi> X" and "w \<in> L\<^sub>2 X Y" and "w \<in> L\<^sub>3 X Y"

  then show "w \<in> language_ltln \<phi>"
    unfolding language_ltln_def L\<^sub>1_def L\<^sub>2_def L\<^sub>3_def
    using master_theorem_restricted by blast
qed

subsection \<open>Definitions with Lists for Code Export\<close>

definition restricted_advice_sets :: "'a ltln \<Rightarrow> ('a ltln list \<times> 'a ltln list) list"
where
  "restricted_advice_sets \<phi> = List.product (subseqs (List.filter (\<lambda>x. x \<in> restricted_subformulas \<phi>) (subformulas\<^sub>\<mu>_list \<phi>))) (subseqs (List.filter (\<lambda>x. x \<in> restricted_subformulas \<phi>) (subformulas\<^sub>\<nu>_list \<phi>)))"

lemma subseqs_subformulas\<^sub>\<mu>_restricted_list:
  "X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi> \<longleftrightarrow> (\<exists>xs. X = set xs \<and> xs \<in> set (subseqs (List.filter (\<lambda>x. x \<in> restricted_subformulas \<phi>) (subformulas\<^sub>\<mu>_list \<phi>))))"
  by (metis in_set_subseqs inf_commute inter_set_filter subformulas\<^sub>\<mu>_list_set subset_subseq)

lemma subseqs_subformulas\<^sub>\<nu>_restricted_list:
  "Y \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi> \<longleftrightarrow> (\<exists>ys. Y = set ys \<and> ys \<in> set (subseqs (List.filter (\<lambda>x. x \<in> restricted_subformulas \<phi>) (subformulas\<^sub>\<nu>_list \<phi>))))"
  by (metis in_set_subseqs inf_commute inter_set_filter subformulas\<^sub>\<nu>_list_set subset_subseq)

lemma restricted_advice_sets_subformulas:
  "X \<subseteq> subformulas\<^sub>\<mu> \<phi> \<inter> restricted_subformulas \<phi> \<and> Y \<subseteq> subformulas\<^sub>\<nu> \<phi> \<inter> restricted_subformulas \<phi> \<longleftrightarrow> (\<exists>xs ys. X = set xs \<and> Y = set ys \<and> (xs, ys) \<in> set (restricted_advice_sets \<phi>))"
  unfolding restricted_advice_sets_def set_product subseqs_subformulas\<^sub>\<mu>_restricted_list subseqs_subformulas\<^sub>\<nu>_restricted_list by blast

lemma restricted_advice_sets_not_empty:
  "restricted_advice_sets \<phi> \<noteq> []"
  unfolding restricted_advice_sets_def using subseqs_not_empty product_not_empty by blast

end


theory Subst
imports ExecMessage
begin

section{* Substitutions *}

definition varsOnly :: "(execlit \<Rightarrow> execmsg) \<Rightarrow> bool"
where "varsOnly s \<equiv> \<forall> l. s l \<noteq> Lit l \<longrightarrow> (\<exists> varid i. l = EVar varid i)"

definition groundSubst :: "(execlit \<Rightarrow> execmsg) \<Rightarrow> bool"
where "groundSubst s \<equiv> \<forall> l. s l \<noteq> Lit l \<longrightarrow> ground (s l)"

typedef subst = "\<lambda> s. s \<in> varsOnly \<and> s \<in> groundSubst"
  by(auto simp: mem_def varsOnly_def groundSubst_def ran_def)

notation (xsymbols) Rep_subst ("_(_)" [1000, 0] 58)

text{*
We additionally support ASCII notation for applying
a substitution in order to make the certificate output of
Scyther readable in a text editor without the support for
Isabelle's math symbols.
*}
notation            Rep_subst ("_'(|_|')" [1000, 0] 58)

fun applyS :: "subst \<Rightarrow> execmsg \<Rightarrow> execmsg"
where
  "applyS s (Lit l)   = Rep_subst s l"
| "applyS s (Tup x y) = Tup  (applyS s x) (applyS s y)"
| "applyS s (Enc m k) = Enc  (applyS s m) (applyS s k)"
| "applyS s (Hash m)  = Hash (applyS s m)"
| "applyS s (K a b)   = K    (applyS s a) (applyS s b)"
| "applyS s (PK a)    = PK   (applyS s a)"
| "applyS s (SK a)    = SK   (applyS s a)"

definition emptyS :: "subst"
where "emptyS \<equiv> Abs_subst Lit"

definition extendS :: "subst \<Rightarrow> subst \<Rightarrow> subst"
where "extendS s1 s2 \<equiv> Abs_subst (applyS s2 o Rep_subst s1)"

definition domS :: "subst \<Rightarrow> execlit set"
where "domS s \<equiv> { l. Rep_subst s l \<noteq> Lit l }"

definition ranS :: "subst \<Rightarrow> execmsg set"
where "ranS s \<equiv> { Rep_subst s l | l. Rep_subst s l \<noteq> Lit l }"

fun inst :: "subst \<Rightarrow> i \<Rightarrow> pattern \<Rightarrow> execmsg"
where
  "inst s i (PConst c)   = Lit (EConst c)"
| "inst s i (PFresh n)   = Lit (ENonce  n i)"
| "inst s i (PVar   v)   = s(EVar v i)"
| "inst s i (PTup x y)   = Tup (inst s i x) (inst s i y)"
| "inst s i (PEnc m k)   = Enc (inst s i m) (inst s i k)"
| "inst s i (PSign m k)  =
     Tup (inst s i m)
         (Enc  (inst s i m) (inv (inst s i k)))"
| "inst s i (PHash m)    = Hash (inst s i m)"
| "inst s i (PSymK a b)  = K    (inst s i a) (inst s i b)"
| "inst s i (PAsymPK a)  = PK   (inst s i a)"
| "inst s i (PAsymSK a)  = SK   (inst s i a)"

subsection{* Properties *}

lemma notin_domS_conv [iff]:
  "(x \<notin> domS s) = (Rep_subst s x = Lit x)"
  by(auto simp: domS_def)

lemma applyS_in_domS_conv []:
  "(x \<in> domS s) = (Rep_subst s x \<noteq> Lit x)"
 by(auto simp: domS_def)

subsubsection{* Substitutions *}

text{* TODO: Make order in this bunch of rules. *}

lemma Rep_subst_varsOnly [simp,intro!]: "varsOnly (Rep_subst s)"
  by(insert Rep_subst, simp add: subst_def mem_def)

lemma Rep_subst_groundSubst [simp,intro!]: "groundSubst (Rep_subst s)"
  by(insert Rep_subst, simp add: subst_def mem_def)

lemma Rep_subst_ground [simp]:
  "Rep_subst s l \<noteq> Lit l \<Longrightarrow> ground (Rep_subst s l)"
  apply(insert Rep_subst_groundSubst[of s])
  apply(auto simp: groundSubst_def)
  done

lemma Rep_subst_simps [simp]:
  "Rep_subst s (EConst c)     = Lit (EConst c)"
  "Rep_subst s (EHonest a)    = Lit (EHonest a)"
  "Rep_subst s (ENonce n i) = Lit (ENonce n i)"
  "Rep_subst s (Eve a)        = Lit (Eve a)"
  "Rep_subst s (EveNonce n)   = Lit (EveNonce n)"
  by(insert Rep_subst_varsOnly[of s], auto simp: varsOnly_def)

lemma applyS_ground_msg [simp]: "ground m \<Longrightarrow> applyS s m = m"
  by(induct m, case_tac lit, auto)

lemma applyS_idem [simp]: "applyS s (applyS s m) = applyS s m"
  apply(induct m, case_tac lit, simp_all)
  apply(case_tac "Rep_subst s (EVar varid nat) = Lit (EVar varid nat)")
  apply(auto)
  done

lemma applyS_Rep_subst_idem [simp]:
  "applyS s (Rep_subst s l) = Rep_subst s l"
  apply(rule_tac s="applyS s (Lit l)" in subst)
  apply(simp, rule applyS_idem)
  done

lemma Rep_subst_varsOnlyE:
  "\<lbrakk> Rep_subst s l \<noteq> Lit l; \<And> v i. l = EVar v i \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  apply(insert Rep_subst_varsOnly[of s])
  unfolding varsOnly_def
  apply(drule_tac x=l in spec)
  apply(auto)
  done

lemma varsOnlyI [intro!]:
  "\<lbrakk> \<And> l. s l \<noteq> Lit l \<Longrightarrow> \<exists> v i. l = EVar v i \<rbrakk> \<Longrightarrow> varsOnly s"
  by(auto simp: varsOnly_def)

lemma groundSubstI [intro!]:
  "\<lbrakk> \<And> l. s l \<noteq> Lit l \<Longrightarrow> ground (s l) \<rbrakk> \<Longrightarrow> groundSubst s"
  by(auto simp: groundSubst_def)

lemma substI [intro!]:
  "\<lbrakk> groundSubst s; varsOnly s \<rbrakk> \<Longrightarrow> s \<in> subst"
  by(auto simp: subst_def mem_def)

lemma Abs_subst_extend_wts_inverse [simp]:
  "Rep_subst (Abs_subst (applyS s' o Rep_subst s)) = applyS s' o Rep_subst s"
  apply(subst Abs_subst_inverse, auto)
  apply(case_tac "Rep_subst s l = Lit l", simp, simp)
  apply(case_tac "Rep_subst s l = Lit l")
  apply(auto elim!: Rep_subst_varsOnlyE)
  done

lemma extendS_conv_applyS [simp]:
  "applyS (extendS s s') m = applyS s' (applyS s m)"
  by(induct m, induct_tac lit, auto simp: extendS_def)

lemma Abs_subst_emptyS_inverse [simp]:
  "Rep_subst (Abs_subst Lit) = Lit"
  by(subst Abs_subst_inverse, auto)

lemma domS_emptyS [simp]: "domS emptyS = {}"
  by(auto simp: domS_def emptyS_def)

lemma domS_extendS [simp]: "domS (extendS s s') = domS s \<union> domS s'"
  apply(auto simp: domS_def extendS_def)
  apply(case_tac "Rep_subst s x = Lit x")
  apply(auto elim!: Rep_subst_varsOnlyE)
  done

lemma applyS_emptyS [simp]: "applyS emptyS m = m"
  by(induct m, auto simp: emptyS_def)

lemma ground_inst_conv_FV:
  "ground (inst s i pt) = (\<forall> v \<in> FV pt. EVar v i \<in> domS s)"
  apply(induct pt)
  apply(simp_all)
  apply(case_tac "s(EVar varid i) = Lit (EVar varid i)")
  apply(auto simp: domS_def)
  done

lemma applyS_subdomain:
  "domS s' \<subseteq> domS s \<Longrightarrow> applyS s' (applyS s m) = applyS s m"
  apply(induct m rule: applyS.induct, simp_all)
  apply(case_tac "l \<in> domS s")
  apply(auto simp: domS_def)
  done

lemma Rep_subst_reorient [iff]:
  "(Lit l = Rep_subst s l') = (Rep_subst s l' = Lit l)"
  "(Lit l \<noteq> Rep_subst s l') = (Rep_subst s l' \<noteq> Lit l)"
  "(Tup x y = Rep_subst s l) = (Rep_subst s l = Tup x y)"
  "(Enc m k = Rep_subst s l) = (Rep_subst s l = Enc m k)"
  "(Hash m = Rep_subst s l) = (Rep_subst s l = Hash m)"
  "(K a b = Rep_subst s l) = (Rep_subst s l = K a b)"
  "(PK a = Rep_subst s l) = (Rep_subst s l = PK a)"
  "(SK a = Rep_subst s l) = (Rep_subst s l = SK a)"
  by auto

lemma sort_Rep_subst_eqs [simp]:
  "(Rep_subst s x = Rep_subst s y) = (Rep_subst s y = Rep_subst s x)"
  by auto

lemma Rep_subst_emptyS [simp]: "Rep_subst emptyS = Lit"
  by(rule ext, auto simp: emptyS_def)

lemma extendS_empty [simp]:
  "extendS s emptyS = s"
  "extendS emptyS s = s"
  by(auto simp: extendS_def Rep_subst_inverse o_def)

lemma Rep_subst_extendS_conv:
  "Rep_subst (extendS s s') m = applyS s' (Rep_subst s m)"
  by(simp add: extendS_def)

lemma applyS_Rep_subst_domS [simp]:
  "l \<in> domS s \<Longrightarrow> applyS s' (Rep_subst s l) = Rep_subst s l"
  by(simp add: applyS_in_domS_conv)

lemma extendS_assoc [simp]:
  "extendS (extendS s s') s'' = extendS s (extendS s' s'')"
  apply(simp add: extendS_def)
  apply(subst Abs_subst_inject)
  apply(safe)
  apply(case_tac "l \<in> domS s", simp)
  apply(case_tac "l \<in> domS s'", simp)
  apply(case_tac "l \<in> domS s''", simp)
  apply(simp)
  apply(case_tac "l \<in> domS s", simp, erule Rep_subst_varsOnlyE, simp)
  apply(case_tac "l \<in> domS s'", simp, erule Rep_subst_varsOnlyE, simp)
  apply(case_tac "l \<in> domS s''", simp, erule Rep_subst_varsOnlyE, simp)
  apply(simp)
  apply(case_tac "l \<in> domS s", simp)
  apply(case_tac "l \<in> domS s'", simp)
  apply(case_tac "l \<in> domS s''", simp)
  apply(simp)
  apply(case_tac "l \<in> domS s", simp, erule Rep_subst_varsOnlyE, simp)
  apply(case_tac "l \<in> domS s'", simp, erule Rep_subst_varsOnlyE, simp)
  apply(case_tac "l \<in> domS s''", simp, erule Rep_subst_varsOnlyE, simp)
  apply(simp)
  apply(rule ext)
  apply(case_tac "x \<in> domS s")
  apply(simp+)
  done

lemma ranSD: "\<lbrakk> ranS s \<subseteq> X; l \<in> domS s \<rbrakk> \<Longrightarrow> Rep_subst s l \<in> X"
  by(auto simp: ranS_def domS_def)

lemma inst_extendS_conv_applyS [simp]:
  "ground (inst s i pt) \<Longrightarrow>
   inst (extendS s s') i pt = inst s i pt"
  by(induct pt, auto simp: Rep_subst_extendS_conv)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Lemmas for Word Length 64"

theory Word_Lemmas_64
imports
  Word_Lemmas_Prefix
  Word_Setup_64
begin

lemma ucast_8_64_inj:
  "inj (ucast ::  8 word \<Rightarrow> 64 word)"
  by (rule down_ucast_inj) (clarsimp simp: is_down_def target_size source_size)

lemma upto_2_helper:
  "{0..<2 :: 64 word} = {0, 1}"
  by (safe; simp) unat_arith

lemmas upper_bits_unset_is_l2p_64 = upper_bits_unset_is_l2p [where 'a=64, folded word_bits_def]
lemmas le_2p_upper_bits_64 = le_2p_upper_bits [where 'a=64, folded word_bits_def]
lemmas le2p_bits_unset_64 = le2p_bits_unset[where 'a=64, folded word_bits_def]

lemma word_bits_len_of:
  "len_of TYPE (64) = word_bits"
  by (simp add: word_bits_conv)

lemmas unat_power_lower64' = unat_power_lower[where 'a=64]
lemmas unat_power_lower64 [simp] = unat_power_lower64'[unfolded word_bits_len_of]

lemmas word64_less_sub_le' = word_less_sub_le[where 'a = 64]
lemmas word64_less_sub_le[simp] = word64_less_sub_le' [folded word_bits_def]

lemma word_bits_size:
  "size (w::word64) = word_bits"
  by (simp add: word_bits_def word_size)

lemmas word64_power_less_1' = word_power_less_1[where 'a = 64]
lemmas word64_power_less_1[simp] = word64_power_less_1'[folded word_bits_def]

lemma of_nat64_0:
  "\<lbrakk>of_nat n = (0::word64); n < 2 ^ word_bits\<rbrakk> \<Longrightarrow> n = 0"
  by (erule of_nat_0, simp add: word_bits_def)

lemma unat_mask_2_less_4:
  "unat (p && mask 2 :: word64) < 4"
  apply (rule unat_less_helper)
  apply (rule order_le_less_trans, rule word_and_le1)
  apply (simp add: mask_def)
  done

lemmas unat_of_nat64' = unat_of_nat_eq[where 'a=64]
lemmas unat_of_nat64 = unat_of_nat64'[unfolded word_bits_len_of]

lemmas word_power_nonzero_64 = word_power_nonzero [where 'a=64, folded word_bits_def]

lemmas unat_mult_simple = iffD1 [OF unat_mult_lem [where 'a = 64, unfolded word_bits_len_of]]

lemmas div_power_helper_64 = div_power_helper [where 'a=64, folded word_bits_def]

lemma n_less_word_bits:
  "(n < word_bits) = (n < 64)"
  by (simp add: word_bits_def)

lemmas of_nat_less_pow_64 = of_nat_power [where 'a=64, folded word_bits_def]

lemma lt_word_bits_lt_pow:
  "sz < word_bits \<Longrightarrow> sz < 2 ^ word_bits"
  by (simp add: word_bits_conv)

lemma unat_less_word_bits:
  fixes y :: word64
  shows "x < unat y \<Longrightarrow> x < 2 ^ word_bits"
  unfolding word_bits_def
  by (rule order_less_trans [OF _ unat_lt2p])

lemmas unat_mask_word64' = unat_mask[where 'a=64]
lemmas unat_mask_word64 = unat_mask_word64'[folded word_bits_def]

lemma unat_less_2p_word_bits:
  "unat (x :: 64 word) < 2 ^ word_bits"
  apply (simp only: word_bits_def)
  apply (rule unat_lt2p)
  done

lemma Suc_unat_mask_div:
  "Suc (unat (mask sz div word_size::word64)) = 2 ^ (min sz word_bits - 3)"
  apply (case_tac "sz < word_bits")
   apply (case_tac "3\<le>sz")
    apply (clarsimp simp: word_size_def word_bits_def min_def mask_def)
    apply (drule (2) Suc_div_unat_helper
           [where 'a=64 and sz=sz and us=3, simplified, symmetric])
   apply (simp add: not_le word_size_def word_bits_def)
   apply (case_tac sz, simp add: unat_word_ariths)
   apply (case_tac nat, simp add: unat_word_ariths
                                  unat_mask_word64 min_def word_bits_def)
   apply (case_tac nata, simp add: unat_word_ariths unat_mask_word64 word_bits_def)
   apply simp
  apply (simp add: unat_word_ariths
                   unat_mask_word64 min_def word_bits_def word_size_def)
  done

lemmas word64_minus_one_le' = word_minus_one_le[where 'a=64]
lemmas word64_minus_one_le = word64_minus_one_le'[simplified]

lemma ucast_not_helper:
  fixes a::word8
  assumes a: "a \<noteq> 0xFF"
  shows "ucast a \<noteq> (0xFF::word64)"
proof
  assume "ucast a = (0xFF::word64)"
  also
  have "(0xFF::word64) = ucast (0xFF::word8)" by simp
  finally
  show False using a
    apply -
    apply (drule up_ucast_inj, simp)
    apply simp
    done
qed

lemma less_4_cases:
  "(x::word64) < 4 \<Longrightarrow> x=0 \<or> x=1 \<or> x=2 \<or> x=3"
  apply clarsimp
  apply (drule word_less_cases, erule disjE, simp, simp)+
  done

lemma if_then_1_else_0:
  "((if P then 1 else 0) = (0 :: word64)) = (\<not> P)"
  by simp

lemma if_then_0_else_1:
  "((if P then 0 else 1) = (0 :: word64)) = (P)"
  by simp

lemmas if_then_simps = if_then_0_else_1 if_then_1_else_0

lemma ucast_le_ucast_8_64:
  "(ucast x \<le> (ucast y :: word64)) = (x \<le> (y :: word8))"
  by (simp add: ucast_le_ucast)

lemma in_16_range:
  "0 \<in> S \<Longrightarrow> r \<in> (\<lambda>x. r + x * (16 :: word64)) ` S"
  "n - 1 \<in> S \<Longrightarrow> (r + (16 * n - 16)) \<in> (\<lambda>x :: word64. r + x * 16) ` S"
  by (clarsimp simp: image_def elim!: bexI[rotated])+

lemma eq_2_64_0:
  "(2 ^ 64 :: word64) = 0"
  by simp

lemma x_less_2_0_1:
  fixes x :: word64 shows
  "x < 2 \<Longrightarrow> x = 0 \<or> x = 1"
  by (rule x_less_2_0_1') auto

lemmas mask_64_max_word  = max_word_mask [symmetric, where 'a=64, simplified]

lemma of_nat64_n_less_equal_power_2:
 "n < 64 \<Longrightarrow> ((of_nat n)::64 word) < 2 ^ n"
  by (rule of_nat_n_less_equal_power_2, clarsimp simp: word_size)

lemma word_rsplit_0:
  "word_rsplit (0 :: word64) = [0, 0, 0, 0, 0, 0, 0, 0 :: word8]"
  apply (simp add: word_rsplit_def bin_rsplit_def Let_def)
  done

lemma unat_ucast_10_64 :
  fixes x :: "10 word"
  shows "unat (ucast x :: word64) = unat x"
  unfolding ucast_def unat_def
  apply (subst int_word_uint)
  apply (subst mod_pos_pos_trivial)
    apply simp
   apply (rule lt2p_lem)
   apply simp
  apply simp
  done

lemma bool_mask [simp]:
  fixes x :: word64
  shows "(0 < x && 1) = (x && 1 = 1)"
  by (rule bool_mask') auto

lemma word64_bounds:
  "- (2 ^ (size (x :: word64) - 1)) = (-9223372036854775808 :: int)"
  "((2 ^ (size (x :: word64) - 1)) - 1) = (9223372036854775807 :: int)"
  "- (2 ^ (size (y :: 64 signed word) - 1)) = (-9223372036854775808 :: int)"
  "((2 ^ (size (y :: 64 signed word) - 1)) - 1) = (9223372036854775807 :: int)"
  by (simp_all add: word_size)

lemma word_ge_min:"sint (x::64 word) \<ge> -9223372036854775808"
  by (metis sint_ge word64_bounds(1) word_size)

lemmas signed_arith_ineq_checks_to_eq_word64'
    = signed_arith_ineq_checks_to_eq[where 'a=64]
      signed_arith_ineq_checks_to_eq[where 'a="64 signed"]

lemmas signed_arith_ineq_checks_to_eq_word64
    = signed_arith_ineq_checks_to_eq_word64' [unfolded word64_bounds]

lemmas signed_mult_eq_checks64_to_64'
    = signed_mult_eq_checks_double_size[where 'a=64 and 'b=64]
      signed_mult_eq_checks_double_size[where 'a="64 signed" and 'b=64]

lemmas signed_mult_eq_checks64_to_64 = signed_mult_eq_checks64_to_64'[simplified]

lemmas sdiv_word64_max' = sdiv_word_max [where 'a=64] sdiv_word_max [where 'a="64 signed"]
lemmas sdiv_word64_max = sdiv_word64_max'[simplified word_size, simplified]

lemmas sdiv_word64_min' = sdiv_word_min [where 'a=64] sdiv_word_min [where 'a="64 signed"]
lemmas sdiv_word64_min = sdiv_word64_min' [simplified word_size, simplified]

lemmas sint64_of_int_eq' = sint_of_int_eq [where 'a=64]
lemmas sint64_of_int_eq = sint64_of_int_eq' [simplified]

lemma ucast_of_nats [simp]:
  "(ucast (of_nat x :: word64) :: sword64) = (of_nat x)"
  "(ucast (of_nat x :: word64) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word64) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword16) = (of_nat x)"
  "(ucast (of_nat x :: word16) :: sword8) = (of_nat x)"
  "(ucast (of_nat x :: word8) :: sword8) = (of_nat x)"
  by (auto simp: ucast_of_nat is_down)

lemmas signed_shift_guard_simpler_64'
    = power_strict_increasing_iff[where b="2 :: nat" and y=31]
lemmas signed_shift_guard_simpler_64 = signed_shift_guard_simpler_64'[simplified]

lemma word64_31_less:
  "31 < len_of TYPE (64 signed)" "31 > (0 :: nat)"
  "31 < len_of TYPE (64)" "31 > (0 :: nat)"
  by auto

lemmas signed_shift_guard_to_word_64
    = signed_shift_guard_to_word[OF word64_31_less(1-2)]
    signed_shift_guard_to_word[OF word64_31_less(3-4)]

lemma le_step_down_word_3:
  fixes x :: "64 word"
  shows "\<lbrakk>x \<le>  y; x \<noteq> y; y < 2 ^ 64 - 1\<rbrakk> \<Longrightarrow> x \<le> y - 1"
  by (rule le_step_down_word_2, assumption+)

lemma shiftr_1:
  "(x::word64) >> 1 = 0 \<Longrightarrow> x < 2"
  by word_bitwise clarsimp

lemma mask_step_down_64:
  "(b::64word) && 0x1 = (1::64word) \<Longrightarrow> (\<exists>x. x < 64 \<and> mask x = b >> 1) \<Longrightarrow> (\<exists>x. mask x = b)"
  apply clarsimp
  apply (rule_tac x="x + 1" in exI)
  apply (subgoal_tac "x \<le> 63")
   apply (erule le_step_down_nat, clarsimp simp:mask_def, word_bitwise, clarsimp+)+
   apply (clarsimp simp:mask_def, word_bitwise, clarsimp)
  apply clarsimp
  done

lemma unat_of_int_64:
  "\<lbrakk>i \<ge> 0; i \<le> 2 ^ 63\<rbrakk> \<Longrightarrow> (unat ((of_int i)::sword64)) = nat i"
  unfolding unat_def
  apply (subst eq_nat_nat_iff, clarsimp+)
  apply (simp add: word_of_int uint_word_of_int)
  done

lemmas word_ctz_not_minus_1_64 = word_ctz_not_minus_1[where 'a=64, simplified]

(* Helper for packing then unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64[simp]:
  "(((ucast ((ucast (x::64 word))::32 word))::64 word) || (((ucast ((ucast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_assemble_id)

(* Another variant of packing and unpacking a 64-bit variable. *)
lemma cast_chunk_assemble_id_64'[simp]:
  "(((ucast ((scast (x::64 word))::32 word))::64 word) || (((ucast ((scast (x >> 32))::32 word))::64 word) << 32)) = x"
  by (simp add:cast_chunk_scast_assemble_id)

(* Specialisations of down_cast_same for adding to local simpsets. *)
lemma cast_down_u64: "(scast::64 word \<Rightarrow> 32 word) = (ucast::64 word \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

lemma cast_down_s64: "(scast::64 sword \<Rightarrow> 32 word) = (ucast::64 sword \<Rightarrow> 32 word)"
  apply (subst down_cast_same[symmetric])
   apply (simp add:is_down)+
  done

end


(*<*)
theory Bossiness
imports
  COP
begin

(*>*)
section\<open> \<^citet>\<open>"Kojima:2010"\<close>: The non-existence of a stable and non-bossy mechanism \label{sec:bossiness} \<close>

text (in Contracts) \<open>

\<^citet>\<open>"Kojima:2010"\<close> says that ``a mechanism is @{emph \<open>nonbossy\<close>} if an
agent cannot change [the] allocation of other agents unless doing so
also changes her own allocation.'' He shows that no mechanism can be
both @{const "stable_on"} and @{emph \<open>nonbossy\<close>} in a one-to-one marriage
market. We establish this result in our matching-with-contracts
setting here.

There are two complications. Firstly, as not all agent preferences
yield stable matches (unlike the marriage market), we constrain
hospital choice functions to satisfy @{const
"ContractsWithBilateralSubstitutesAndIRC"}, which is the weakest
condition formalized here that ensures that @{const "fp_cop_F"} yields
stable matches. (We note that it is not the weakest condition
guaranteeing the existence of stable matches.)

Secondly, non-bossiness needs to separately treat the preferences of
the doctors and the choice functions of the hospitals.

We work in the @{const "Contracts"} locale for its types and the
constants @{term "Xd"} and @{term "Xh"}. To account for the
quantification over preferences, we directly use some raw constants
from the @{const "Contracts"} locale.

\<close>

context Contracts
begin

abbreviation (input) mechanism_domain :: "('d \<Rightarrow> 'x rel) \<Rightarrow> ('h \<Rightarrow> 'x cfun) \<Rightarrow> bool" where
  "mechanism_domain \<equiv> ContractsWithBilateralSubstitutesAndIRC Xd Xh"

definition nonbossy :: "'d set \<Rightarrow> ('d, 'h, 'x) mechanism \<Rightarrow> bool" where
  "nonbossy ds \<phi> \<longleftrightarrow>
    (\<forall>Pd Pd' Ch. \<forall>d\<in>ds. mechanism_domain Pd Ch \<and> mechanism_domain (Pd(d:=Pd')) Ch \<longrightarrow>
      dX (\<phi> Pd Ch ds) d = dX (\<phi> (Pd(d:=Pd')) Ch ds) d \<longrightarrow> \<phi> Pd Ch ds = \<phi> (Pd(d:=Pd')) Ch ds)
  \<and> (\<forall>Pd Ch Ch' h. mechanism_domain Pd Ch \<and> mechanism_domain Pd (Ch(h:=Ch')) \<longrightarrow>
      hX (\<phi> Pd Ch ds) h = hX (\<phi> Pd (Ch(h:=Ch')) ds) h \<longrightarrow> \<phi> Pd Ch ds = \<phi> Pd (Ch(h:=Ch')) ds)"

definition mechanism_stable :: "'d set \<Rightarrow> ('d, 'h, 'x) mechanism \<Rightarrow> bool" where
  "mechanism_stable ds \<phi>
     \<longleftrightarrow> (\<forall>Pd Ch. mechanism_domain Pd Ch \<longrightarrow> Contracts.stable_on Pd Ch ds (\<phi> Pd Ch ds))"

(*<*)

lemma nonbossy_Pd:
  assumes "nonbossy ds \<phi>"
  assumes "mechanism_domain Pd' Ch'"
  assumes "mechanism_domain (Pd'(d:=Pd'')) Ch'"
  assumes "dX (\<phi> Pd' Ch' ds) d = dX (\<phi> (Pd'(d:=Pd'')) Ch' ds) d"
  assumes "d \<in> ds"
  shows "\<phi> Pd' Ch' ds = \<phi> (Pd'(d:=Pd'')) Ch' ds"
using assms unfolding nonbossy_def by blast

lemma nonbossy_Ch:
  assumes "nonbossy ds \<phi>"
  assumes "mechanism_domain Pd' Ch'"
  assumes "mechanism_domain Pd' (Ch'(h:=Ch''))"
  assumes "hX (\<phi> Pd' Ch' ds) h = hX (\<phi> Pd' (Ch'(h:=Ch'')) ds) h"
  shows "\<phi> Pd' Ch' ds = \<phi> Pd' (Ch'(h:=Ch'')) ds"
using assms unfolding nonbossy_def by blast

(*>*)

end

text (in Contracts) \<open>

The proof is somewhat similar to those for Roth's impossibility
results (see, for instance, \<^citet>\<open>\<open>Theorem~4.4\<close> in "RothSotomayor:1990"\<close>).
It relies on the existence of at least three doctors, three hospitals,
and a complete set of contracts between these. The following locale
captures a suitable set of constraints.

\<close>

locale BossyConstants =
  fixes Xd :: "'x \<Rightarrow> 'd"
  fixes Xh :: "'x \<Rightarrow> 'h"
  fixes d1h1 d1h2 d1h3 :: 'x
  fixes d2h1 d2h2 d2h3 :: 'x
  fixes d3h1 d3h2 d3h3 :: 'x
  fixes ds :: "'d set"
  assumes ds: "distinct [Xd d1h1, Xd d2h1, Xd d3h1]"
  assumes hs: "distinct [Xh d1h1, Xh d1h2, Xh d1h3]"
  assumes Xd_xs:
    "Xd ` {d1h2, d1h3} = {Xd d1h1}"
    "Xd ` {d2h2, d2h3} = {Xd d2h1}"
    "Xd ` {d3h2, d3h3} = {Xd d3h1}"
  assumes Xh_xs:
    "Xh ` {d2h1, d3h1} = {Xh d1h1}"
    "Xh ` {d2h2, d3h2} = {Xh d1h2}"
    "Xh ` {d2h3, d3h3} = {Xh d1h3}"
  assumes dset: "{Xd d1h1, Xd d2h1, Xd d3h1} \<subseteq> ds"

locale ContractsWithBossyConstants =
  Contracts + BossyConstants
begin

abbreviation (input) "d1 \<equiv> Xd d1h1"
abbreviation (input) "d2 \<equiv> Xd d2h1"
abbreviation (input) "d3 \<equiv> Xd d3h1"

abbreviation (input) "h1 \<equiv> Xh d1h1"
abbreviation (input) "h2 \<equiv> Xh d1h2"
abbreviation (input) "h3 \<equiv> Xh d1h3"

(*<*)

lemma xs:
  shows "distinct [d1h1, d1h2, d1h3, d2h1, d2h2, d2h3, d3h1, d3h2, d3h3]"
using Xd_xs Xh_xs ds hs by auto

(*>*)

text\<open>

We proceed to show that variations on the following preferences for
doctors and hospitals force a stable mechanism to be bossy. Recall
that @{const "linord_of_list"} constructs a linear order from a list of
elements greatest to least. The hospital choice functions take at most
one contract from those on offer, and are again ordered from most
preferable to least.

\<close>

definition BPd :: "'b \<Rightarrow> 'a rel" where
  "BPd \<equiv> map_of_default {} [ (d1, linord_of_list [d1h3, d1h2, d1h1])
                           , (d2, linord_of_list [d2h3, d2h2, d2h1])
                           , (d3, linord_of_list [d3h1, d3h2, d3h3]) ]"

abbreviation mkhord :: "'d list \<Rightarrow> 'd cfun" where
  "mkhord xs X \<equiv> set_option (List.find (\<lambda>x. x\<in>X) xs)"

definition BCh :: "'c \<Rightarrow> 'a cfun" where
  "BCh \<equiv> map_of_default (\<lambda>_. {}) [ (h1, mkhord [d1h1, d2h1, d3h1])
                                 , (h2, mkhord [])
                                 , (h3, mkhord [d3h3, d2h3, d1h3]) ]"

text\<open>

Interpreting the @{const "Contracts"} locale gives us access to some
useful constants.

\<close>

interpretation Bossy: Contracts Xd Xh BPd BCh
using %invisible Xd_xs Xh_xs xs unfolding BPd_def BCh_def
by unfold_locales (auto simp: linord_of_list_Linear_order)

lemma BPd_BCh_mechanism_domain:
  shows "mechanism_domain BPd BCh"
by %invisible unfold_locales (auto simp: BCh_def bilateral_substitutes_on_def irc_on_def)

(*<*)

lemma BPd_simps:
  "BPd d1 = linord_of_list [d1h3, d1h2, d1h1]"
  "BPd d2 = linord_of_list [d2h3, d2h2, d2h1]"
  "BPd d3 = linord_of_list [d3h1, d3h2, d3h3]"
  "d \<notin> {d1, d2, d3} \<longleftrightarrow> BPd d = {}"
unfolding BPd_def using Xd_xs ds by auto

lemma BCh_simps:
  "BCh h1 = mkhord [d1h1, d2h1, d3h1]"
  "BCh h3 = mkhord [d3h3, d2h3, d1h3]"
  "h \<notin> {h1, h3} \<Longrightarrow> BCh h X = {}"
unfolding BCh_def using Xh_xs hs by auto

lemma Bossy_CD_on_Cd:
  shows "Bossy.CD_on ds X = Bossy.Cd d1 X \<union> Bossy.Cd d2 X \<union> Bossy.Cd d3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy.CD_on_def by clarsimp (metis BPd_simps(4) Bossy.Cd_range' Field_empty Int_iff empty_iff insertE)
  from dset show "?rhs \<subseteq> ?lhs"
    unfolding Bossy.CD_on_def by blast
qed

lemma Bossy_CH_BCh:
  shows "Bossy.CH X = BCh h1 X \<union> BCh h3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy.CH_def by clarsimp (simp add: BCh_def split: if_splits)
  show "?rhs \<subseteq> ?lhs"
    unfolding Bossy.CH_def by blast
qed

(*>*)

lemma Bossy_stable:
  shows "Bossy.stable_on ds X \<longleftrightarrow> X = {d1h1, d3h3}"
(*<*) (is "?lhs = ?rhs")
proof (rule iffI)
  assume ?lhs with Xd_xs ds xs show ?rhs
    apply -
    apply (frule Bossy.stable_on_allocation)
    apply (frule Bossy.stable_on_CH)
    apply (frule Bossy.stable_on_CD_on)

    (* Enumerate all possible contracts *)
    apply (frule Bossy_CH_range[OF Set.equalityD2])
    apply (drule subset_subseqs)

    apply clarsimp
    apply (elim disjE)
    apply (simp_all add: Bossy_CH_BCh BCh_simps insert_eq_iff insert_commute)
    using Bossy.stable_on_blocking_onD[where h="h3" and X''="{d3h3}" and X="X" and ds=ds]
          Bossy.stable_on_blocking_onD[where h="h1" and X''="{d2h1}" and X="X" and ds=ds]
          Bossy.stable_on_blocking_onD[where h="h1" and X''="{d1h1}" and X="X" and ds=ds]
    apply (simp_all add: Bossy_CH_BCh BCh_simps Bossy_CD_on_Cd BPd_simps)
    done
next
  assume ?rhs show ?lhs
  proof(rule Bossy.stable_onI)
    show "Bossy.individually_rational_on ds X"
    proof(rule Bossy.individually_rational_onI)
      from xs \<open>?rhs\<close> show "Bossy.CD_on ds X = X" by clarsimp (force simp: Bossy_CD_on_Cd BPd_simps)
      from \<open>?rhs\<close> show "Bossy.CH X = X" by (simp add: Bossy_CH_BCh BCh_simps insert_commute)
    qed
    show "Bossy.stable_no_blocking_on ds X"
    proof(rule Bossy.stable_no_blocking_onI)
      fix h X'' assume XXX: "X'' = BCh h (X \<union> X'')" "X'' \<noteq> BCh h X" "X'' \<subseteq> Bossy.CD_on ds (X \<union> X'')"
      from \<open>?rhs\<close> XXX(1,2) have h: "h \<in> {h1, h3}" using BCh_simps by auto
      from XXX(1) have X'': "X'' \<subseteq> set [d1h1, d1h3, d2h1, d2h3, d3h1, d3h3]"
        using Bossy_CH_range[unfolded Bossy.CH_def] by blast
      from \<open>?rhs\<close> XXX h X'' Xh_xs hs xs show False
        apply -
        apply (drule subset_subseqs)
        apply clarsimp
        apply (elim disjE)
        apply (simp_all add: BCh_simps)
        done
    qed
  qed
qed

(*>*)
text\<open>

The second preference order has doctor @{const "d2"} reject all
contracts and is otherwise the same as the first.

\<close>

definition BPd' :: "'b \<Rightarrow> 'a rel" where
  "BPd' = BPd(d2 := {})"

interpretation Bossy': Contracts Xd Xh BPd' BCh
using %invisible Xd_xs Xh_xs xs unfolding BPd_def BPd'_def BCh_def
by unfold_locales (auto simp: linord_of_list_Linear_order)

lemma BPd'_BCh_mechanism_domain:
  shows "mechanism_domain BPd' BCh"
by %invisible unfold_locales (auto simp: BCh_def bilateral_substitutes_on_def irc_on_def)

(*<*)

lemma BPd'_simps:
  "BPd' d1 = linord_of_list [d1h3, d1h2, d1h1]"
  "BPd' d3 = linord_of_list [d3h1, d3h2, d3h3]"
  "d \<notin> {d1, d3} \<longleftrightarrow> BPd' d = {}"
unfolding BPd_def BPd'_def using Xd_xs ds by auto

lemma Bossy'_CD_on_Cd:
  "Bossy'.CD_on ds X = Bossy'.Cd d1 X \<union> Bossy'.Cd d3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy'.CD_on_def by clarsimp (metis BPd'_simps(3) Bossy'.Cd_range' Field_empty Int_iff empty_iff insertE)
  from dset show "?rhs \<subseteq> ?lhs"
    unfolding Bossy'.CD_on_def by blast
qed

(*>*)

lemma Bossy'_stable:
  shows "Bossy'.stable_on ds X \<longleftrightarrow> X = {d1h3, d3h1} \<or> X = {d1h1, d3h3}"
(*<*) (is "?lhs = ?rhs")
proof (rule iffI)
  assume ?lhs
  with dset \<open>?lhs\<close> Xd_xs ds xs show ?rhs
    apply -
    apply (frule Bossy'.stable_on_allocation)
    apply (frule Bossy'.stable_on_CH)
    apply (frule Bossy'.stable_on_CD_on)

    (* Enumerate all possible contracts *)
    apply (frule Bossy_CH_range[OF Set.equalityD2])
    apply (drule subset_subseqs)

    apply clarsimp
    apply (elim disjE)
    apply (simp_all add: Bossy_CH_BCh BCh_simps insert_eq_iff insert_commute)
    using Bossy'.stable_on_blocking_onD[where h="h3" and X''="{d3h3}" and X="X" and ds=ds]
          Bossy'.stable_on_blocking_onD[where h="h1" and X''="{d1h1}" and X="X" and ds=ds]
    apply (simp_all add: Bossy_CH_BCh BCh_simps Bossy'_CD_on_Cd BPd'_simps)
    done
next
  assume ?rhs show ?lhs
  proof(rule Bossy'.stable_onI)
    show "Bossy'.individually_rational_on ds X"
    proof(rule Bossy'.individually_rational_onI)
      from ds xs \<open>?rhs\<close> show "Bossy'.CD_on ds X = X" by (force simp: Bossy'_CD_on_Cd BPd'_simps)
      from xs \<open>?rhs\<close> show "Bossy.CH X = X" by (force simp: Bossy_CH_BCh BCh_simps)
    qed
    show "Bossy'.stable_no_blocking_on ds X"
    proof(rule Bossy'.stable_no_blocking_onI)
      fix h X'' assume XXX: "X'' = BCh h (X \<union> X'')" "X'' \<noteq> BCh h X" "X'' \<subseteq> Bossy'.CD_on ds (X \<union> X'')"
      from \<open>?rhs\<close> XXX(1,2) have h: "h \<in> {h1, h2, h3}" using BCh_simps by auto
      from XXX(1) have X'': "X'' \<subseteq> set [d1h1, d1h3, d2h1, d2h3, d3h1, d3h3]"
        using Bossy_CH_range[unfolded Bossy.CH_def] by blast
      from \<open>?rhs\<close> XXX h X'' Xh_xs ds hs xs show False
        apply -
        apply (drule subset_subseqs)
        apply clarsimp
        apply (elim disjE)
        apply (simp_all add: BCh_simps)
        apply (simp_all add: Bossy'_CD_on_Cd Bossy'.maxR_def linord_of_list_linord_of_listP BPd'_simps)
        done
    qed
  qed
qed

(*>*)
text\<open>

The third preference order adjusts the choice function of hospital
@{const "h2"} and is otherwise the same as the second.

\<close>

definition BCh' :: "'c \<Rightarrow> 'a cfun" where
  "BCh' \<equiv> BCh(h2 := mkhord [d1h2, d2h2, d3h2])"

interpretation Bossy'': Contracts Xd Xh BPd' BCh'
using %invisible Xd_xs Xh_xs xs unfolding BPd_def BPd'_def BCh_def BCh'_def
by unfold_locales (auto simp: linord_of_list_Linear_order)

lemma BPd'_BCh'_mechanism_domain:
  shows "mechanism_domain BPd' BCh'"
by %invisible unfold_locales (auto simp: BCh_def BCh'_def bilateral_substitutes_on_def irc_on_def)

(*<*)

lemma BCh'_simps:
  "BCh' h1 = mkhord [d1h1, d2h1, d3h1]"
  "BCh' h2 = mkhord [d1h2, d2h2, d3h2]"
  "BCh' h3 = mkhord [d3h3, d2h3, d1h3]"
  "h \<notin> {h1, h2, h3} \<Longrightarrow> BCh' h X = {}"
unfolding BCh_def BCh'_def using Xh_xs hs by auto

lemma Bossy''_CH_BCh':
  "Bossy''.CH X = BCh' h1 X \<union> BCh' h2 X \<union> BCh' h3 X" (is "?lhs = ?rhs")
proof(rule equalityI)
  show "?lhs \<subseteq> ?rhs"
    unfolding Bossy''.CH_def by clarsimp (simp add: BCh_def BCh'_def split: if_splits)
  show "?rhs \<subseteq> ?lhs"
    unfolding Bossy''.CH_def by blast
qed

lemma Bossy''_CD_on_range:
  assumes "X \<subseteq> Bossy''.CD_on ds X'"
  shows "X \<subseteq> set [d1h1, d1h2, d1h3, d3h1, d3h2, d3h3]"
using assms by (auto simp: Bossy'_CD_on_Cd BPd'_simps dest!: Bossy''.Cd_range')

(*>*)

lemma Bossy''_stable:
  shows "Bossy''.stable_on ds X \<longleftrightarrow> X = {d3h1, d1h3}"
(*<*) (is "?lhs = ?rhs")
proof(rule iffI)
  assume ?lhs with Xd_xs ds xs show ?rhs
    apply -
    apply (frule Bossy''.stable_on_allocation)
    apply (frule Bossy''.stable_on_CH)
    apply (frule Bossy''.stable_on_CD_on)

    (* Enumerate all possible contracts *)
    apply (frule Bossy''_CD_on_range[OF Set.equalityD2])
    apply (drule subset_subseqs)

    apply clarsimp
    apply (elim disjE)
    apply (simp_all add: Bossy''_CH_BCh' BCh'_simps insert_eq_iff insert_commute)
    using Bossy''.stable_on_blocking_onD[where h="h1" and X''="{d3h1}" and X="X" and ds=ds]
          Bossy''.stable_on_blocking_onD[where h="h2" and X''="{d1h2}" and X="X" and ds=ds]
          Bossy''.stable_on_blocking_onD[where h="h3" and X''="{d1h3}" and X="X" and ds=ds]
    apply (simp_all add: BCh'_simps Bossy'_CD_on_Cd BPd'_simps)
    apply (simp_all add: Bossy''.maxR_def linord_of_list_linord_of_listP BPd'_simps)
    done
next
  assume ?rhs show ?lhs
  proof(rule Bossy''.stable_onI)
    show "Bossy''.individually_rational_on ds X"
    proof(rule Bossy''.individually_rational_onI)
      from ds xs \<open>?rhs\<close> show "Bossy''.CD_on ds X = X" by (force simp: Bossy'_CD_on_Cd BPd'_simps)
      from xs \<open>?rhs\<close> show "Bossy''.CH X = X" by (force simp: Bossy''_CH_BCh' BCh'_simps)
    qed
    show "Bossy''.stable_no_blocking_on ds X"
    proof(rule Bossy''.stable_no_blocking_onI)
      fix h X'' assume XXX: "X'' = BCh' h (X \<union> X'')" "X'' \<noteq> BCh' h X" "X'' \<subseteq> Bossy''.CD_on ds (X \<union> X'')"
      from \<open>?rhs\<close> XXX(1,2) have h: "h \<in> {h1, h2, h3}" using BCh'_simps by auto
      from XXX(3) have X'': "X'' \<subseteq> set [d1h1, d1h2, d1h3, d3h1, d3h2, d3h3]"
        using Bossy''_CD_on_range by blast
      from \<open>?rhs\<close> XXX h X'' Xh_xs ds hs xs show False
        apply -
        apply (drule subset_subseqs)
        apply clarsimp
        apply (elim disjE)
        apply (simp_all add: BCh'_simps)
        apply (simp_all add: Bossy'_CD_on_Cd BPd'_simps Bossy'.maxR_def linord_of_list_linord_of_listP)
        done
    qed
  qed
qed

(*>*)
text\<open>\<close>

theorem Theorem_1:
  shows "\<not>(mechanism_stable ds \<phi> \<and> nonbossy ds \<phi>)"
proof(rule notI, erule conjE)
  assume S: "Bossy.mechanism_stable ds \<phi>"
  assume NB: "Bossy.nonbossy ds \<phi>"
  from S Bossy'_stable BPd'_BCh_mechanism_domain
  consider (A) "\<phi> BPd' BCh ds = {d1h3, d3h1}" | (B) "\<phi> BPd' BCh ds = {d1h1, d3h3}"
    unfolding mechanism_stable_def by blast
  then show False
  proof cases
    case A
    from S BPd_BCh_mechanism_domain Bossy_stable have "\<phi> BPd BCh ds = {d1h1, d3h3}"
      unfolding mechanism_stable_def by blast
    with Xd_xs ds xs dset A show False
      using nonbossy_Pd[OF NB BPd_BCh_mechanism_domain BPd'_BCh_mechanism_domain[unfolded BPd'_def]]
      unfolding BPd'_def[symmetric] dX_def by fastforce
  next
    case B
    from S BPd'_BCh'_mechanism_domain Bossy''_stable have "\<phi> BPd' BCh' ds = {d3h1, d1h3}"
      unfolding mechanism_stable_def by blast
    with Xh_xs hs xs dset B show False
      using nonbossy_Ch[OF NB BPd'_BCh_mechanism_domain BPd'_BCh'_mechanism_domain[unfolded BCh'_def]]
      unfolding BCh'_def[symmetric] hX_def by fastforce
  qed
qed

text\<open>

In particular, the COP (see \S\ref{sec:cop}) is bossy as it always
yields stable matches under @{const "mechanism_stable"}.

\<close>

theorem Theorem_1_COP:
  "\<not>nonbossy ds Contracts.cop"
using ContractsWithBilateralSubstitutesAndIRC.Theorem_1 Theorem_1 mechanism_stable_def by blast

end

text\<open>

Therefore doctors can interfere with other doctors' allocations under
the COP without necessarily disadvantaging themselves, which has
implications for the notion of @{emph \<open>group strategy-proof\<close>}
\<^citep>\<open>"HatfieldKojima:2009"\<close>; see \S\ref{sec:strategic-gsp}.

\<close>
(*<*)

end
(*>*)