(******************************************************************************)
(* Project: Isabelle/UTP: Unifying Theories of Programming in Isabelle/HOL    *)
(* File: Normalise.thy                                                        *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@gmail.com and simon.foster@york.ac.uk                  *)
(******************************************************************************)
(* LAST REVIEWED: 09 Jun 2022 *)

section \<open>Normalisation\<close>

theory Normalise
imports Main
 "HOL-Eisbach.Eisbach"
begin

subsection \<open>Theorem Attribute\<close>

text \<open>Theorems and tactic used for normalisation.\<close>

named_theorems normalise "normalisation theorems"

subsection \<open>Normalisation Tactic\<close>

method normalise = (simp add: normalise)

subsection \<open>Type Class @{text normalise}\<close>

text \<open>
  Instantiation of the class @{text normalise} signals that normalisation can
  be performed on constructions that involve the underlying type. For now, we
  only consider chains of function updates. Importantly, the type must provide
  a linear order to ensure that normalisation does not loop.
\<close>

class normalise = linorder
begin
theorem fun_upd_normalise [normalise]:
fixes x :: "'a"
fixes y :: "'a"
shows "x < y \<Longrightarrow> f(y := a, x := b) = f(x := b, y := a)"
by (simp add: fun_upd_twist)
end

text \<open>
  The tactic below is not very efficient as using backtracking. In practice,
  it is slightly quicker to use plain simplification instead of substitution.
  Both approaches, however, suffer from the same drawback that dead ends may
  need to be explored. A better solution would implement some form of guarded
  rewriting.
\<close>

method fun_upd_normalise_tac =
  (subst fun_upd_normalise, (simp; fail))+

end


(*
   Title: The pi-calculus
   Author/Maintainer: Jesper Bengtson (jebe.dk), 2012
*)
theory Strong_Late_Bisim_Subst
  imports Strong_Late_Bisim
begin

abbreviation
  StrongEqJudge (infixr "\<sim>\<^sup>s" 65) where "P \<sim>\<^sup>s Q \<equiv> (P, Q) \<in> (substClosed bisim)"

lemma congBisim:
  fixes P :: pi
  and   Q :: pi

  assumes "P \<sim>\<^sup>s Q"

  shows "P \<sim> Q"
using assms substClosedSubset by blast

lemma eqvt:
  shows "eqvt (substClosed bisim)"
by(rule eqvtSubstClosed[OF Strong_Late_Bisim.bisimEqvt])

lemma eqClosed:
  fixes P :: pi
  and   Q :: pi
  and   perm :: "name prm"

  assumes "P \<sim>\<^sup>s Q"

  shows "(perm \<bullet> P) \<sim>\<^sup>s (perm \<bullet> Q)"
using assms
by(rule eqvtRelI[OF eqvt])

lemma reflexive:
  fixes P :: pi

  shows "P \<sim>\<^sup>s P"
by(force simp add: substClosed_def intro: Strong_Late_Bisim.reflexive)

end


(*
    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
(*>*)