(*<*)
theory Strategic
imports
  COP
begin

(*>*)
section\<open> Strategic results \label{sec:strategic} \<close>

text (in ContractsWithSubstitutes) \<open>

We proceed to establish a series of strategic results for the COP (see
\S\ref{sec:contracts-cop} and \S\ref{sec:cop}), making use of the
invariants we developed for it. These results also apply to the
matching-with-contracts setting of \S\ref{sec:contracts}, and where
possible we specialize our lemmas to it.

\<close>

subsection\<open> \<^citet>\<open>"HatfieldMilgrom:2005"\<close>: Theorems~10 and~11: Truthful revelation as a Dominant Strategy \label{sec:strategic-contracts} \<close>

text (in ContractsWithSubstitutes) \<open>

Theorems~10 and 11 demonstrate that doctors cannot obtain better
results for themselves in the doctor-optimal match (i.e., @{term "cop ds"}, equal to @{term "match (gfp_F ds)"} by @{thm [source]
"Theorem_15_match"} assuming hospital preferences satisfy @{const
"substitutes"}) by misreporting their preferences. (See
\<^citet>\<open>\<open>\S4.2\<close> in "RothSotomayor:1990"\<close> for a discussion about the
impossibility of a mechanism being strategy-proof for all agents.)

\<^citet>\<open>\<open>{\S}III(B)\<close> in "HatfieldMilgrom:2005"\<close> provide the
following intuition:
\begin{quote}

We will show the positive incentive result for the doctor-offering
algorithm in two steps which highlight the different roles of the two
preference assumptions. First, we show that the @{const "substitutes"}
condition, by itself, guarantees that doctors cannot benefit by
exaggerating the ranking of an unattainable contract. More precisely,
if there exists a preferences list for a doctor @{term "d"} such that
@{term "d"} obtains contract @{term "x"} by submitting this list, then
@{term "d"} can also obtain @{term "x"} by submitting a preference
list that includes only contract @{term "x"} [Theorem~10]. Second, we
will show that adding the law of aggregate demand guarantees that a
doctor does at least as well as reporting truthfully as by reporting
any singleton [Theorem~11]. Together, these are the dominant strategy
result.

\end{quote}

We prove Theorem~10 via a lemma that states that the contracts above
@{term "x \<in> X"} for some stable match @{term "X"} with respect to
manipulated preferences @{term "Pd (Xd x)"} do not improve the outcome
for doctor @{term "Xd x"} with respect to their true preferences
@{term "Pd' (Xd x)"} in the doctor-optimal match for @{term "Pd'"}.

This is weaker than \<^citet>\<open>\<open>Lemma~1\<close> in "HatfieldKojima:2009"\<close> (see
\S\ref{sec:strategic-hk2010-lemma1}) as we do not guarantee that the
allocation does not change. By the bossiness result of
\S\ref{sec:bossiness}, such manipulations can change the outcomes of
the other doctors; this lemma establishes that only weak improvements
are possible.

\<close>

context ContractsWithUnilateralSubstitutesAndIRC
begin

context
  fixes d' :: "'b"
  fixes Pd' :: "'b \<Rightarrow> 'a rel"
  assumes Pd'_d'_linear: "Linear_order (Pd' d')"
  assumes Pd'_d'_range: "Field (Pd' d') \<subseteq> {y. Xd y = d'}"
  assumes Pd': "\<forall>d. d\<noteq>d' \<longrightarrow> Pd' d = Pd d"
begin

(*<*)

lemma PdXXX_linear:
  shows "Linear_order (Pd' d)"
using Pd_linear Pd'_d'_linear Pd' by (cases "d = d'") simp_all

lemma PdXXX_range:
  shows "Field (Pd' d) \<subseteq> {x. Xd x = d}"
using Pd_range Pd'_d'_range Pd' by (cases "d = d'") simp_all

lemmas PdXXX_range' = subsetD[OF PdXXX_range, simplified, of x] for x

(*>*)

interpretation PdXXX: ContractsWithUnilateralSubstitutesAndIRC Xd Xh Pd' Ch
using %invisible PdXXX_linear PdXXX_range Ch_range Ch_singular Ch_unilateral_substitutes Ch_irc
by unfold_locales blast+

theorem Pd_above_irrelevant:
  assumes d'_Field: "dX X d' \<subseteq> Field (Pd' d')"
  assumes d'_Above: "Above (Pd' d') (dX X d') \<subseteq> Above (Pd d') (dX X d')"
  assumes "x \<in> X"
  assumes "stable_on ds X"
  shows "\<exists>y \<in> PdXXX.cop ds. (x, y) \<in> Pd' (Xd x)"
proof(rule PdXXX.Theorem_5[OF ccontr \<open>x \<in> X\<close>])
  assume "\<not>PdXXX.stable_on ds X"
  then show False
  proof(cases rule: PdXXX.not_stable_on_cases)
    case not_individually_rational
    from Pd' \<open>stable_on ds X\<close> d'_Field have "x \<in> PdXXX.Cd (Xd x) X" if "x \<in> X" for x
      using that unfolding dX_def by (force simp: stable_on_range' stable_on_allocation PdXXX.Cd_single)
    with \<open>stable_on ds X\<close> not_individually_rational show False
      unfolding PdXXX.individually_rational_on_def
      by (auto simp: PdXXX.mem_CD_on_Cd stable_on_Xd dest: stable_on_CH PdXXX.CD_on_range')
  next
    case not_no_blocking
    then obtain h X'' where "PdXXX.blocking_on ds X h X''"
      unfolding PdXXX.stable_no_blocking_on_def by blast
    have "blocking_on ds X h X''"
    proof(rule blocking_onI)
      fix x assume "x \<in> X''"
      note Pbos = PdXXX.blocking_on_Field[OF \<open>PdXXX.blocking_on ds X h X''\<close>]
                  PdXXX.blocking_on_allocation[OF \<open>PdXXX.blocking_on ds X h X''\<close>]
                  PdXXX.blocking_on_CD_on'[OF \<open>PdXXX.blocking_on ds X h X''\<close> \<open>x \<in> X''\<close>]
      show "x \<in> CD_on ds (X \<union> X'')"
      proof(cases "Xd x = d'")
        case True
        from Pd_linear' d'_Field d'_Above \<open>x \<in> X''\<close> \<open>Xd x = d'\<close> Pbos
        have "dX X'' (Xd x) \<subseteq> Field (Pd (Xd x))"
          by (force simp: PdXXX.mem_CD_on_Cd PdXXX.Cd_Above PdXXX.dX_Int_Field_Pd Above_union
                          Int_Un_distrib2 dX_singular intro: Above_Field)
        moreover from \<open>stable_on ds X\<close> have "dX X (Xd x) \<subseteq> Field (Pd (Xd x))"
          by (force dest: dX_range' stable_on_range')
        moreover note Pd_linear' Pd_range PdXXX_range d'_Field d'_Above \<open>x \<in> X''\<close> \<open>Xd x = d'\<close> Pbos
        ultimately show ?thesis
          by (clarsimp simp: PdXXX.mem_CD_on_Cd PdXXX.Cd_Above_dX mem_CD_on_Cd Cd_Above_dX
                             Above_union dX_union Int_Un_distrib2)
             (fastforce simp: dX_singular intro: Above_Linear_singleton)
      next
        case False
        with \<open>x \<in> PdXXX.CD_on ds (X \<union> X'')\<close> show ?thesis
          by (clarsimp simp: Pd' PdXXX.mem_CD_on_Cd mem_CD_on_Cd PdXXX.Cd_greatest Cd_greatest)
      qed
    qed (use \<open>PdXXX.blocking_on ds X h X''\<close> in \<open>simp_all add: PdXXX.blocking_on_def\<close>)
    with \<open>stable_on ds X\<close> show False by (simp add: blocking_on_imp_not_stable)
  qed
qed

end

end

text\<open>

We now specialize this lemma to Theorem~10 by defining a preference
order for the doctors where distinguished doctors @{term "ds"} submit
single preferences for the contracts they receive in the
doctor-optimal match.

The function @{thm "override_on_def"} denotes function update at
several points.

\<close>

context Contracts
begin

definition Pd_singletons_for_ds :: "'x set \<Rightarrow> 'd set \<Rightarrow> 'd \<Rightarrow> 'x rel" where
  "Pd_singletons_for_ds X ds \<equiv> override_on Pd (\<lambda>d. dX X d \<times> dX X d) ds"

(*<*)

lemma Pd_singletons_for_ds_range:
  shows "Field (Pd_singletons_for_ds X ds d) \<subseteq> {x. Xd x = d}"
using Pd_range dX_range unfolding Pd_singletons_for_ds_def
by (clarsimp simp: Field_def override_on_def) blast

lemma Pd_singletons_for_ds_linear:
  assumes "allocation X"
  shows "Linear_order (Pd_singletons_for_ds X ds d)"
unfolding Pd_singletons_for_ds_def using Pd_linear dX_linear[OF assms] by (simp add: override_on_def)

lemma Pd_singletons_for_ds_simps:
  shows "d \<in> ds \<Longrightarrow> Pd_singletons_for_ds X ds d = dX X d \<times> dX X d"
    and "d \<notin> ds \<Longrightarrow> Pd_singletons_for_ds X ds d = Pd d"
unfolding Pd_singletons_for_ds_def by simp_all

(*>*)

end

text\<open>

We interpret our @{const "ContractsWithUnilateralSubstitutesAndIRC"}
locale with respect to this updated preference order, which gives us
the stable match and properties of it.

\<close>

context ContractsWithUnilateralSubstitutesAndIRC
begin

context
  fixes ds :: "'b set"
  fixes X :: "'a set"
  assumes "stable_on ds X"
begin

interpretation
  Singleton_for_d: ContractsWithUnilateralSubstitutesAndIRC Xd Xh "Pd_singletons_for_ds X {d}" Ch for d
using %invisible Pd_singletons_for_ds_linear Pd_singletons_for_ds_range Ch_range Ch_singular Ch_unilateral_substitutes Ch_irc
                 stable_on_allocation[OF \<open>stable_on ds X\<close>]
by unfold_locales blast+

text\<open>

Our version of \<^citet>\<open>\<open>Theorem~10\<close> in "HatfieldMilgrom:2005"\<close> (for the COP)
states that if a doctor submits a preference order containing just
@{term "x"}, where @{term "x"} is their contract in some stable match
@{term "X"}, then that doctor receives exactly @{term "x"} in the
doctor-optimal match and all other doctors do at least as well.

\<close>

theorem Theorem_10_fp_cop_F:
  assumes "x \<in> X"
  shows "\<exists>y \<in> Singleton_for_d.cop d ds. (x, y) \<in> Pd_singletons_for_ds X {d} (Xd x)"
proof(rule Pd_above_irrelevant[where ds=ds and d'=d and X=X])
  from stable_on_allocation \<open>stable_on ds X\<close>
  show "Above (Pd_singletons_for_ds X {d} d) (Singleton_for_d.dX X d) \<subseteq> Above (Pd d) (Singleton_for_d.dX X d)"
    by (clarsimp simp: Above_def Pd_singletons_for_ds_simps dX_def) (metis inj_on_eq_iff stable_on_range' Pd_refl)
qed (use stable_on_allocation \<open>stable_on ds X\<close> Pd_singletons_for_ds_linear Pd_singletons_for_ds_range assms
     in \<open>simp_all, simp_all add: Pd_singletons_for_ds_simps dX_def\<close>)

end

end

text (in ContractsWithSubstitutesAndIRC) \<open>

We can recover the original Theorem~10 by specializing this result to
@{const "gfp_F"}.

\<close>

context ContractsWithSubstitutesAndIRC
begin

interpretation
  Singleton_for_d: ContractsWithSubstitutesAndIRC Xd Xh "Pd_singletons_for_ds (match (gfp_F ds)) {d}" Ch
for ds d
using %invisible Pd_singletons_for_ds_linear Pd_singletons_for_ds_range Ch_range Ch_singular Ch_substitutes Ch_irc gfp_F_stable_on
                 stable_on_allocation[OF gfp_F_stable_on[of ds]]
by unfold_locales blast+

theorem Theorem_10:
  assumes "x \<in> match (gfp_F ds)"
  shows "\<exists>y \<in> match (Singleton_for_d.gfp_F ds d ds). (x, y) \<in> Pd_singletons_for_ds (match (gfp_F ds)) {d} (Xd x)"
using Theorem_10_fp_cop_F Singleton_for_d.Theorem_15_match Theorem_15_match gfp_F_stable_on assms by simp

corollary Theorem_10_d:
  assumes "x \<in> match (gfp_F ds)"
  shows "x \<in> match (Singleton_for_d.gfp_F ds (Xd x) ds)"
using gfp_F_stable_on[of ds] Theorem_10[OF assms(1), of "Xd x"] assms
by (clarsimp simp: Pd_singletons_for_ds_simps dX_def inj_on_eq_iff dest!: stable_on_allocation)

end

text (in ContractsWithSubstitutes) \<open>

The second theorem \<^citep>\<open>\<open>Theorem~11\<close> in "HatfieldMilgrom:2005"\<close> depends on
both Theorem~10 and the rural hospitals theorem
(\S\ref{sec:contracts-rh}, \S\ref{sec:cop-rh}). It shows that,
assuming everything else is fixed, if doctor @{term "d'"} obtains
contract @{term "x"} with (manipulated) preferences @{term "Pd d'"} in
the doctor-optimal match, then they will obtain a contract at least as
good by submitting their true preferences @{term "Pd' d'"} (with
respect to these true preferences).

\<close>

locale TruePrefs = Contracts +
  fixes x :: "'a"
  fixes X :: "'a set"
  fixes ds :: "'b set"
  fixes Pd' :: "'b \<Rightarrow> 'a rel"
  assumes x: "x \<in> X"
  assumes X: "stable_on ds X"
  assumes Pd'_d'_x: "x \<in> Field (Pd' (Xd x))"
  assumes Pd'_d'_linear: "Linear_order (Pd' (Xd x))"
  assumes Pd'_d'_range: "Field (Pd' (Xd x)) \<subseteq> {y. Xd y = Xd x}"
  assumes Pd': "\<forall>d. d\<noteq>Xd x \<longrightarrow> Pd' d = Pd d"

(*<*)

begin

lemma Pd'_linear:
  shows "Linear_order (Pd' d)"
using Pd_linear Pd'_d'_linear Pd' by (cases "d = Xd x") simp_all

lemma Pd'_range:
  shows "Field (Pd' d) \<subseteq> {x. Xd x = d}"
using Pd_range Pd'_d'_range Pd' by (cases "d = Xd x") simp_all

definition Pd'_tax :: "'b \<Rightarrow> 'a rel" where
  "Pd'_tax = (Pd'(Xd x := Restr (Pd' (Xd x)) (above (Pd' (Xd x)) x)))"

lemma Pd'_tax_linear:
  shows "Linear_order (Pd'_tax d)"
using Pd'_linear Pd'_d'_linear Linear_order_Restr unfolding Pd'_tax_def by auto

lemma Pd'_tax_range:
  shows "Field (Pd'_tax d) \<subseteq> {x. Xd x = d}"
using Pd'_range Pd'_tax_Pd' by (meson mono_Field subset_trans)

lemma Pd'_tax_x:
  shows "x \<in> Field (Pd'_tax (Xd x))"
using Pd'_d'_x Pd'_d'_linear unfolding Pd'_tax_def above_def order_on_defs
by (fastforce intro: FieldI2 dest: refl_onD)

lemma Pd'_Above:
  assumes "Y \<subseteq> above (Pd' (Xd x)) x"
  assumes "Y \<noteq> {}"
  shows "Above (Pd' d) Y \<subseteq> Above (Pd'_tax d) Y"
using Pd'_d'_linear assms unfolding Above_def Pd'_tax_def above_def order_on_defs
by (auto simp: Refl_Field_Restr subset_eq elim: transE)

end

(*>*)

locale ContractsWithUnilateralSubstitutesAndIRCAndLADAndTruePrefs =
  ContractsWithUnilateralSubstitutesAndIRCAndLAD + TruePrefs
begin

interpretation TruePref: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh Pd' Ch
using %invisible Pd'_linear Pd'_range Ch_range Ch_singular Ch_unilateral_substitutes Ch_irc Ch_lad
by unfold_locales blast+

interpretation TruePref_tax: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh Pd'_tax Ch
using %invisible Pd'_tax_linear Pd'_tax_range Ch_range Ch_singular Ch_unilateral_substitutes Ch_irc Ch_lad
by unfold_locales blast+

interpretation
  Singleton_for_d: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh "Pd_singletons_for_ds X {Xd x}" Ch
using %invisible Pd_singletons_for_ds_linear Pd_singletons_for_ds_range Ch_range Ch_singular Ch_unilateral_substitutes Ch_irc Ch_lad X stable_on_allocation[OF X]
by unfold_locales blast+

(*<*)

lemma Xd_x_ds:
  shows "Xd x \<in> ds"
using %invisible X stable_on_Xd x by blast

lemma TruePref_tax_Cd_not_x:
  assumes "d \<noteq> Xd x"
  shows "TruePref_tax.Cd d = Singleton_for_d.Cd d"
using assms spec[OF Pd', of d] stable_on_allocation[OF X]
unfolding TruePref_tax.Cd_def Singleton_for_d.Cd_def by (simp add: Pd'_tax_def Pd_singletons_for_ds_simps)

(*>*)

lemma Theorem_11_Pd'_tax:
  shows "\<exists>y\<in>TruePref_tax.cop ds. (x, y) \<in> Pd'_tax (Xd x)"
proof(rule ccontr)
  let ?Z = "TruePref_tax.cop ds"
  assume "\<not>?thesis" then have "Xd x \<notin> Xd ` ?Z"
    using Pd'_range Pd'_linear[of "Xd x"] Pd'_d'_x unfolding order_on_defs
    by - (clarsimp, drule (1) bspec,
          fastforce simp: Pd'_tax_def above_def Refl_Field_Restr dest: refl_onD
                   dest!: CH_range' TruePref_tax.fp_cop_F_range_inv')
  show False
  proof(cases "Singleton_for_d.stable_on ds ?Z")
    case True
    moreover
    from Theorem_10_fp_cop_F[OF X x, of "Xd x"] X
    have "x \<in> CH (Singleton_for_d.fp_cop_F ds)"
      by (force simp: Pd_singletons_for_ds_simps dX_def dest: inj_onD stable_on_allocation)
    with Singleton_for_d.fp_cop_F_allocation
    have "Singleton_for_d.Cd (Xd x) (Singleton_for_d.cop ds) = {x}"
      by (meson Singleton_for_d.Cd_single Singleton_for_d.Cd_singleton Singleton_for_d.fp_cop_F_range_inv'
                TruePref_tax.CH_range')
    with Singleton_for_d.Theorem_1[of ds]
    have "x \<in> Y" if "Singleton_for_d.stable_on ds Y" for Y
      using Singleton_for_d.Theorem_6_fp_cop_F(1)[where ds="ds" and X="Y" and d="Xd x"] that Xd_x_ds x
            card_Suc_eq[where A="Singleton_for_d.Cd (Xd x) Y" and k=0] stable_on_allocation[OF X]
      by (fastforce simp: Singleton_for_d.Cd_singleton[symmetric] Pd_singletons_for_ds_simps dX_def
                    dest: Singleton_for_d.Cd_range' inj_onD)
    moreover note \<open>Xd x \<notin> Xd ` ?Z\<close>
    ultimately show False by blast
  next
    case False note \<open>\<not>Singleton_for_d.stable_on ds ?Z\<close>
    then show False
    proof(cases rule: Singleton_for_d.not_stable_on_cases)
      case not_individually_rational
      with TruePref_tax.Theorem_1[of ds] \<open>Xd x \<notin> Xd ` ?Z\<close>
      show False
        unfolding TruePref_tax.stable_on_def Singleton_for_d.individually_rational_on_def
                  TruePref_tax.individually_rational_on_def Singleton_for_d.CD_on_def
        by (auto dest: Singleton_for_d.Cd_range')
           (metis TruePref_tax.mem_CD_on_Cd TruePref_tax_Cd_not_x image_eqI)
    next
      case not_no_blocking
      then obtain h X'' where "Singleton_for_d.blocking_on ds ?Z h X''"
        unfolding Singleton_for_d.stable_no_blocking_on_def by blast
      have "TruePref_tax.blocking_on ds ?Z h X''"
      proof(rule TruePref_tax.blocking_onI)
        fix y assume "y \<in> X''"
        with \<open>Singleton_for_d.blocking_on ds ?Z h X''\<close> have YYY: "y \<in> Singleton_for_d.CD_on ds (?Z \<union> X'')"
          unfolding Singleton_for_d.blocking_on_def by blast
        show "y \<in> TruePref_tax.CD_on ds (?Z \<union> X'')"
        proof(cases "Xd y = Xd x")
          case True
          with inj_on_eq_iff[OF stable_on_allocation x] X YYY have "y = x"
            by (fastforce simp: Singleton_for_d.mem_CD_on_Cd Pd_singletons_for_ds_simps dX_def
                          dest: Singleton_for_d.Cd_range')
          with X Xd_x_ds TruePref_tax.Theorem_1[of ds] \<open>Xd x \<notin> Xd ` ?Z\<close> \<open>y \<in> X''\<close>
          show ?thesis
            using Singleton_for_d.blocking_on_allocation[OF \<open>Singleton_for_d.blocking_on ds ?Z h X''\<close>]
            by (clarsimp simp: TruePref_tax.mem_CD_on_Cd TruePref_tax.Cd_greatest greatest_def Pd'_tax_x)
               (metis TruePref_tax.Pd_range' image_eqI inj_on_contraD TruePref_tax.Pd_refl)
        next
          case False with YYY show ?thesis
            by (simp add: Singleton_for_d.mem_CD_on_Cd TruePref_tax.mem_CD_on_Cd TruePref_tax_Cd_not_x)
        qed
      qed (use \<open>Singleton_for_d.blocking_on ds ?Z h X''\<close> in \<open>simp_all add: Singleton_for_d.blocking_on_def\<close>)
      with TruePref_tax.Theorem_1[of ds] show False by (simp add: TruePref_tax.blocking_on_imp_not_stable)
    qed
  qed
qed

theorem Theorem_11_fp_cop_F:
  shows "\<exists>y\<in>TruePref.cop ds. (x, y) \<in> Pd' (Xd x)"
proof -
  from Theorem_11_Pd'_tax
  obtain y where y: "y \<in> CH (TruePref_tax.fp_cop_F ds)"
            and xy: "(x, y) \<in> Pd'_tax (Xd x)" ..
  from TruePref_tax.stable_on_range'[OF TruePref_tax.Theorem_1]
  have "dX (CH (TruePref_tax.fp_cop_F ds)) (Xd x) \<subseteq> Field (Pd' (Xd x))"
    by (clarsimp simp: dX_def) (metis (no_types, opaque_lifting) Pd'_tax_Pd' contra_subsetD mono_Field)
  moreover
  from TruePref_tax.fp_cop_F_allocation[of ds] Pd'_tax_Pd' y xy
  have "Above (Pd' (Xd x)) (dX (CH (TruePref_tax.fp_cop_F ds)) (Xd x))
     \<subseteq> Above (Pd'_tax (Xd x)) (dX (CH (TruePref_tax.fp_cop_F ds)) (Xd x))"
    by - (rule Pd'_Above; fastforce simp: dX_singular above_def dest: TruePref_tax.Pd_Xd)
  moreover note Pd'_linear Pd'_range TruePref_tax.Theorem_1[of ds] y
  ultimately have z: "\<exists>z\<in>CH (TruePref.fp_cop_F ds). (y, z) \<in> Pd' (Xd y)"
    by - (rule TruePref_tax.Pd_above_irrelevant[where d'="Xd x" and X="CH (TruePref_tax.fp_cop_F ds)"];
          simp add: Pd'_tax_def)
  from Pd'_linear xy z show ?thesis
    unfolding Pd'_tax_def order_on_defs by clarsimp (metis TruePref.Pd_Xd transE)
qed

end

locale ContractsWithSubstitutesAndLADAndTruePrefs =
  ContractsWithSubstitutesAndLAD + TruePrefs

sublocale ContractsWithSubstitutesAndLADAndTruePrefs
        < ContractsWithUnilateralSubstitutesAndIRCAndLADAndTruePrefs
by %invisible unfold_locales

context ContractsWithSubstitutesAndLADAndTruePrefs
begin

interpretation TruePref: ContractsWithSubstitutesAndLAD Xd Xh Pd' Ch
using %invisible Pd'_linear Pd'_range Ch_range Ch_singular Ch_substitutes Ch_irc Ch_lad
by unfold_locales blast+

theorem Theorem_11:
  shows "\<exists>y\<in>match (TruePref.gfp_F ds). (x, y) \<in> Pd' (Xd x)"
using Theorem_11_fp_cop_F TruePref.Theorem_15_match by simp

end

text\<open>

Note that this theorem depends on the hypotheses introduced by the
@{const "TruePrefs"} locale, and only applies to doctor @{term "Xd
x"}. The following sections show more general and syntactically
self-contained results.

We omit \<^citet>\<open>\<open>Theorem~12\<close> in "HatfieldMilgrom:2005"\<close>, which demonstrates
the almost-necessity of LAD for truth revelation to be the dominant
strategy for doctors.

\<close>

subsection\<open> \<^citet>\<open>"HatfieldKojima:2009" and "HatfieldKojima:2010"\<close>: The doctor-optimal match is group strategy-proof \label{sec:strategic-gsp} \<close>

text \<open>

\<^citet>\<open>\<open>Theorem~7\<close> in "HatfieldKojima:2010"\<close> assert that the COP is group
strategy-proof, which we define below. We begin by focusing on a
single agent \<^citep>\<open>"HatfieldKojima:2009"\<close>: \begin{quote}

A mechanism @{term "\<phi>"} is @{emph \<open>strategy-proof\<close>} if, for any
preference profile @{term "Pd"}, there is no doctor @{term "d"} and
preferences @{term "Pd'"} such that @{term "d"} strictly prefers
@{term "y\<^sub>d"} to @{term "x\<^sub>d"} according to @{term "Pd
d"}, where @{term "x\<^sub>d"} and @{term "y\<^sub>d"} are the
(possibly null) contracts for @{term "d"} in @{term "\<phi> Pd"} and
\<open>\<phi> Pd(d := Pd')\<close>, respectively.

\end{quote}

The syntax @{thm "fun_upd_def"} denotes function update at a point.

We make this definition in the \<open>Contracts\<close> locale to
avail ourselves of some types and the \<open>Xd\<close> and
\<open>Xh\<close> constants. We also restrict hospital preferences to
those that guarantee our earlier strategic results.  As @{term
"gfp_F"} requires these to satisfy the stronger @{const "substitutes"}
constraint for stable matches to exist, we now deal purely with the
COP.

\<close>

context Contracts
begin

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

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

(*<*)

lemma strategy_proofI:
  assumes "\<And>Pd Pd' Ch d y. \<lbrakk> mechanism_domain Pd Ch; mechanism_domain (Pd(d:=Pd')) Ch; d \<in> ds;
                             y \<in> \<phi> (Pd(d := Pd')) Ch ds; y \<in> Field (Pd d);
                             \<forall>x\<in>dX (\<phi> Pd Ch ds) d. x \<noteq> y \<and> (x, y) \<in> Pd d \<rbrakk> \<Longrightarrow> False"
  shows "strategy_proof ds \<phi>"
unfolding strategy_proof_def AboveS_def using assms by blast

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

theorem fp_cop_F_strategy_proof:
  shows "strategy_proof ds Contracts.cop" (is "strategy_proof _ ?\<phi>")
proof %invisible (rule strategy_proofI)
  fix Pd Pd' Ch d y
  assume A: "mechanism_domain Pd Ch" and B: "mechanism_domain (Pd(d:=Pd')) Ch"
     and y: "y \<in> ?\<phi> (Pd(d := Pd')) Ch ds" "y \<in> Field (Pd d)" "\<forall>x\<in>dX (?\<phi> Pd Ch ds) d. x \<noteq> y \<and> (x, y) \<in> Pd d"
  from A interpret TruePref: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh Pd Ch .
  from B interpret ManiPref: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh "Pd(d := Pd')" Ch .
  from B y interpret ManiPref: ContractsWithUnilateralSubstitutesAndIRCAndLADAndTruePrefs Xd Xh "Pd(d := Pd')" Ch y "?\<phi> (Pd(d := Pd')) Ch ds" ds Pd
    by unfold_locales (simp_all add: FieldI2 TruePref.Pd_Xd TruePref.Pd_linear TruePref.Pd_range' subsetI ManiPref.Theorem_1)
  from ManiPref.Theorem_11_fp_cop_F obtain z where "z \<in> TruePref.cop ds" "(y, z) \<in> Pd (Xd y)" ..
  with TruePref.Pd_linear TruePref.stable_on_allocation[OF TruePref.Theorem_1[of ds]] TruePref.Pd_Xd TruePref.Pd_range' y
  show False
    unfolding order_on_defs antisym_def dX_def by (metis (mono_tags, lifting) mem_Collect_eq)
qed

end

text\<open>

The adaptation to groups is straightforward
\<^citep>\<open>"HatfieldKojima:2009" and "HatfieldKojima:2010"\<close>:
\begin{quote}

A mechanism @{term "\<phi>"} is @{emph \<open>group strategy-proof\<close>} if, for
any preference profile @{term "Pd"}, there is no group of doctors
@{term "ds' \<subseteq> ds"} and a preference profile @{term "Pd'"}
such that every @{term "d \<in> ds'"} strictly prefers @{term
"y\<^sub>d"} to @{term "x\<^sub>d"} according to @{term "Pd d"}, where
@{term "x\<^sub>d"} and @{term "y\<^sub>d"} are the (possibly null)
contracts for @{term "d"} in @{term "\<phi> Pd"} and \<open>\<phi>
Pd(d\<^sub>1 := Pd' d\<^sub>1, \<dots>, d\<^sub>n := Pd' d\<^sub>n)\<close>,
respectively.

\end{quote}

This definition requires all doctors in the coalition to strictly
prefer the outcome with manipulated preferences, as
\citeauthor{Kojima:2010}'s bossiness results (see
\S\ref{sec:bossiness}) show that a doctor may influence other doctors'
allocations without affecting their own. See
\<^citet>\<open>\<open>\S3\<close> in "HatfieldKojima:2009"\<close> for discussion, and also
\<^citet>\<open>\<open>Chapter~4\<close> in "RothSotomayor:1990"\<close>; in particular their \S4.3.1
discusses the robustness of these results and exogenous transfers.

\<close>

context Contracts
begin

definition group_strategy_proof :: "'d set \<Rightarrow> ('d, 'h, 'x) mechanism \<Rightarrow> bool" where
  "group_strategy_proof ds \<phi> \<longleftrightarrow>
    (\<forall>Pd Ch. mechanism_domain Pd Ch \<longrightarrow>
     \<not>(\<exists>ds'\<subseteq>ds. ds' \<noteq> {} \<and> (\<exists>Pd'. mechanism_domain (override_on Pd Pd' ds') Ch
       \<and> (\<forall>d\<in>ds'. \<exists>y\<in>\<phi> (override_on Pd Pd' ds') Ch ds. y \<in> AboveS (Pd d) (dX (\<phi> Pd Ch ds) d)))))"

(*<*)

lemma group_strategy_proofI:
  assumes "\<And>Pd Pd' Ch ds'. \<lbrakk> mechanism_domain Pd Ch; mechanism_domain (override_on Pd Pd' ds') Ch; ds' \<subseteq> ds; ds' \<noteq> {};
                             \<forall>d\<in>ds'. \<exists>y\<in>\<phi> (override_on Pd Pd' ds') Ch ds. y \<in> AboveS (Pd d) (dX (\<phi> Pd Ch ds) d) \<rbrakk> \<Longrightarrow> False"
  shows "group_strategy_proof ds \<phi>"
unfolding group_strategy_proof_def using assms by blast

lemmas group_strategy_proofD = iffD1[OF group_strategy_proof_def, simplified, unfolded disj_imp, simplified, rule_format]

(*>*)

lemma group_strategy_proof_strategy_proof:
  assumes "group_strategy_proof ds \<phi>"
  shows "strategy_proof ds \<phi>"
proof %invisible (rule strategy_proofI)
  fix Pd Pd' Ch d y
  assume "mechanism_domain Pd Ch" "mechanism_domain (Pd(d := Pd')) Ch" "d \<in> ds"
         "y \<in> \<phi> (Pd(d := Pd')) Ch ds" "y \<in> Field (Pd d)" "\<forall>x\<in>dX (\<phi> Pd Ch ds) d. x \<noteq> y \<and> (x, y) \<in> Pd d"
  with assms show False
    unfolding group_strategy_proof_def
    by (clarsimp dest!: spec[where x=Pd] spec[where x=Ch])
       (fastforce simp: override_on_insert AboveS_def dest!: spec[where x="{d}"])
qed

end

text\<open>

\label{sec:strategic-hk2010-lemma1}

Perhaps surprisingly, \<^citet>\<open>\<open>Lemma~1, for a single
doctor\<close> in "HatfieldKojima:2010"\<close> assert that shuffling any contract above
the doctor-optimal one to the top of a doctor's preference order
preserves exactly the doctor-optimal match, which on the face of it
seems to contradict the bossiness result of \S\ref{sec:bossiness}: by
the earlier strategy-proofness results, this cannot affect the outcome
for that particular doctor, but by bossiness it may affect others.
The key observation is that this manipulation preserves blocking
coalitions in the presence of @{const "lad"}.

This result is central to showing the group-strategy-proofness of the
COP.

\<close>

context Contracts
begin

definition shuffle_to_top :: "'x set \<Rightarrow> 'd \<Rightarrow> 'x rel" where
  "shuffle_to_top Y = (\<lambda>d. Pd d - dX Y d \<times> UNIV \<union> (Domain (Pd d) \<union> dX Y d) \<times> dX Y d)"

definition Pd_shuffle_to_top :: "'d set \<Rightarrow> 'x set \<Rightarrow> 'd \<Rightarrow> 'x rel" where
  "Pd_shuffle_to_top ds' Y = override_on Pd (shuffle_to_top Y) ds'"

(*<*)

lemma shuffle_to_top_Field:
  assumes "allocation Y"
  shows "Field (shuffle_to_top Y d) = Field (Pd d) \<union> dX Y d"
unfolding shuffle_to_top_def Field_def using dX_empty_or_singleton[OF assms]
by (auto simp: Domain.simps; meson FieldI2 equalityE Pd_refl)

lemma shuffle_to_top_Total:
  assumes "allocation Y"
  shows "Total (shuffle_to_top Y d)"
using Pd_linear'[of d] dX_empty_or_singleton[OF assms]
unfolding order_on_defs total_on_def shuffle_to_top_Field[OF assms]
by (auto simp: shuffle_to_top_def Domain.simps dest: refl_onD)

lemma shuffle_to_top_linear:
  assumes "allocation Y"
  shows "Linear_order (shuffle_to_top Y d)"
using Pd_linear'[of d] dX_empty_or_singleton[OF assms] shuffle_to_top_Total[OF assms]
unfolding shuffle_to_top_def order_on_defs
by (auto simp: Field_def intro!: antisymI refl_onI transI dest: refl_onD antisymD elim: transE)

lemma shuffle_to_top_range:
  shows "Field (shuffle_to_top Y d) \<subseteq> {x. Xd x = d}"
unfolding shuffle_to_top_def using Pd_range dX_range by (force simp: Field_def)

lemma shuffle_to_top_range':
  assumes "(x, y) \<in> shuffle_to_top Y d"
  shows "x \<in> Field (Pd d) \<union> dX Y d \<and> y \<in> Field (Pd d) \<union> dX Y d"
using assms unfolding shuffle_to_top_def by (auto intro: FieldI1 FieldI2)

lemma Pd_shuffle_to_top_linear:
  assumes "allocation Y"
  shows "Linear_order (Pd_shuffle_to_top ds' Y d)"
unfolding Pd_shuffle_to_top_def using Pd_linear shuffle_to_top_linear[OF assms] by (cases "d \<in> ds'") simp_all

lemma Pd_shuffle_to_top_range:
  shows "Field (Pd_shuffle_to_top ds' Y d) \<subseteq> {x. Xd x = d}"
unfolding Pd_shuffle_to_top_def using Pd_range shuffle_to_top_range by (cases "d \<in> ds'") simp_all

lemma Pd_shuffle_to_top_simps:
  shows "Pd_shuffle_to_top (insert d ds') Y = (Pd_shuffle_to_top ds' Y)(d := shuffle_to_top Y d)"
    and "d \<in> ds' \<Longrightarrow> Pd_shuffle_to_top ds' Y d = shuffle_to_top Y d"
    and "d \<notin> ds' \<Longrightarrow> Pd_shuffle_to_top ds' Y d = Pd d"
unfolding Pd_shuffle_to_top_def by (simp_all add: override_on_insert)

lemma Pd_shuffle_to_top_Field:
  assumes "allocation Y"
  shows "Field (Pd_shuffle_to_top ds' Y d) = Field (Pd d) \<union> (if d \<in> ds' then dX Y d else {})"
by (simp add: Pd_shuffle_to_top_simps shuffle_to_top_Field[OF assms])

lemma Above_shuffle_to_top:
  assumes "x \<in> Above (shuffle_to_top Y (Xd x)) X"
  assumes "y \<in> Y"
  assumes "allocation Y"
  assumes "y \<in> X"
  shows "x = y"
using assms unfolding Above_def shuffle_to_top_def
by (fastforce simp: dX_singular dest: Pd_Xd dX_range' Pd_range' inj_onD)

(*>*)

end

context ContractsWithUnilateralSubstitutesAndIRCAndLAD
begin

lemma Lemma_1:
  assumes "allocation Y"
  assumes III: "\<forall>d\<in>ds''. \<exists>y\<in>Y. y \<in> AboveS (Pd d) (dX (cop ds) d)"
  shows "cop ds = Contracts.cop (Pd_shuffle_to_top ds'' Y) Ch ds"
using finite[of ds''] subset_refl
proof(induct ds'' rule: finite_subset_induct')
  case empty show ?case by (simp add: Pd_shuffle_to_top_simps)
next
  case (insert d ds')
  from insert
  interpret Pds': ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh "Pd_shuffle_to_top ds' Y" Ch
    using %invisible Pd_shuffle_to_top_linear[OF \<open>allocation Y\<close>] Pd_shuffle_to_top_range Ch_range Ch_singular Ch_unilateral_substitutes Ch_irc Ch_lad
    by unfold_locales simp_all
  let ?Z = "CH (Pds'.fp_cop_F ds)"
  note IH = \<open>cop ds = ?Z\<close>
  let ?Pd_shuffle_to_top = "Pd_shuffle_to_top (insert d ds') Y"
  from insert interpret Pdds': ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh ?Pd_shuffle_to_top Ch
    using %invisible Pd_shuffle_to_top_linear[OF \<open>allocation Y\<close>] Pd_shuffle_to_top_range Ch_range Ch_singular Ch_unilateral_substitutes Ch_irc Ch_lad
    by unfold_locales (simp_all add: Pd_shuffle_to_top_simps(1)[symmetric])
  \<comment> \<open>\citet[Lemma~1, for a single doctor]{HatfieldKojima:2010}\<close>
  have XXX: "?Z = CH (Pdds'.fp_cop_F ds)"
  proof(rule Pdds'.doctor_optimal_match_unique[OF Pdds'.doctor_optimal_matchI Pdds'.fp_cop_F_doctor_optimal_match])
    show "Pdds'.stable_on ds ?Z"
    proof(rule Pdds'.stable_onI)
      show "Pdds'.individually_rational_on ds ?Z"
      proof(rule Pdds'.individually_rational_onI)
        show "Pdds'.CD_on ds ?Z = ?Z" (is "?lhs = ?rhs")
        proof(rule set_elem_equalityI)
          fix x assume "x \<in> ?rhs"
          with \<open>allocation Y\<close> IH Pds'.Theorem_1[of ds] \<open>d \<notin> ds'\<close> show "x \<in> ?lhs"
            by (clarsimp simp: Pds'.stable_on_Xd Pdds'.mem_CD_on_Cd Pdds'.Cd_greatest greatest_def
                               Pd_shuffle_to_top_Field[OF \<open>allocation Y\<close>],
                simp add: Pd_shuffle_to_top_simps shuffle_to_top_def dX_def Set.Ball_def,
                metis stable_on_range'[OF Theorem_1[of ds]] inj_on_contraD[OF Pds'.fp_cop_F_allocation[of ds]]
                      fp_cop_F_worst[of _ ds] Pd_range' Pds'.CH_range')
        qed (meson IntE Pdds'.CD_on_range')
        show "CH ?Z = ?Z" by (simp add: CH_irc_idem)
      qed
      show "Pdds'.stable_no_blocking_on ds ?Z"
      proof(rule Pdds'.stable_no_blocking_onI2)
        fix h X'' assume Pbo: "Pdds'.blocking_on ds ?Z h X''"
        have "Pds'.blocking_on ds ?Z h X''"
        proof(rule Pds'.blocking_onI)
          fix x assume "x \<in> X''"
          note Pbos = Pdds'.blocking_on_allocation[OF \<open>Pdds'.blocking_on ds ?Z h X''\<close>]
                      Pdds'.blocking_on_CD_on'[OF \<open>Pdds'.blocking_on ds ?Z h X''\<close> \<open>x \<in> X''\<close>]
                      Pdds'.blocking_on_Cd[OF \<open>Pdds'.blocking_on ds ?Z h X''\<close>, where d="Xd x"]
          show "x \<in> Pds'.CD_on ds (?Z \<union> X'')"
          proof(cases "Xd x = d")
            case True
            from \<open>allocation Y\<close> III \<open>d \<in> ds''\<close> \<open>Xd x = d\<close>
            have "dX Y (Xd x) \<subseteq> Field (Pd (Xd x))"
                by clarsimp (metis AboveS_Pd_Xd AboveS_Field dX_range' inj_on_eq_iff)
            moreover with \<open>allocation Y\<close> \<open>d \<notin> ds'\<close>
                          Pdds'.blocking_on_Field[OF \<open>Pdds'.blocking_on ds ?Z h X''\<close>, where d=d] \<open>Xd x = d\<close>
            have "dX X'' (Xd x) \<subseteq> Field (Pd (Xd x))"
              by (force simp: Pd_shuffle_to_top_simps shuffle_to_top_Field)
            moreover note \<open>allocation Y\<close> bspec[OF III[unfolded IH] \<open>d \<in> ds''\<close>] \<open>d \<notin> ds'\<close> \<open>x \<in> X''\<close> \<open>Xd x = d\<close>
                          Pds'.stable_on_allocation[OF Pds'.Theorem_1] Pbos
            ultimately show ?thesis
              by (clarsimp simp: Pdds'.mem_CD_on_Cd Pds'.mem_CD_on_Cd Pds'.Cd_Above Pdds'.Cd_Above
                                 Int_Un_distrib2 Pd_shuffle_to_top_Field)
                 (clarsimp simp: Pd_shuffle_to_top_simps dX_singular dX_Int_Field_Pd;
                  fastforce simp: Above_def AboveS_def Pd_refl shuffle_to_top_def dX_def intro: FieldI1 dest: Pd_range' iff: inj_on_eq_iff)
         next
            case False
            from Pbos \<open>Xd x \<noteq> d\<close>
            show ?thesis
              by (simp add: Pdds'.mem_CD_on_Cd Pds'.mem_CD_on_Cd Pds'.Cd_greatest Pdds'.Cd_greatest)
                 (simp add: Pd_shuffle_to_top_simps)
          qed
        qed (use \<open>Pdds'.blocking_on ds ?Z h X''\<close> in \<open>simp_all add: Pdds'.blocking_on_def\<close>)
        with Pds'.Theorem_1[of ds] show False by (simp add: Pds'.blocking_on_imp_not_stable)
      qed
    qed
  next
    fix W w assume "Pdds'.stable_on ds W" "w \<in> W"
      from III \<open>d \<in> ds''\<close> IH
      obtain y where Y: "y \<in> Y" "y \<in> AboveS (Pd d) (dX (Pds'.cop ds) d)" "Xd y = d"
        by (metis AboveS_Pd_Xd)
      show "\<exists>z\<in>Pds'.cop ds. (w, z) \<in> Pd_shuffle_to_top (insert d ds') Y (Xd w)"
      proof(cases "y \<in> W")
        case True note \<open>y \<in> W\<close>
        from \<open>d \<notin> ds'\<close> \<open>Pdds'.stable_on ds W\<close> Y \<open>y \<in> W\<close>
        interpret Pdds': ContractsWithUnilateralSubstitutesAndIRCAndLADAndTruePrefs
                           Xd Xh "Pd_shuffle_to_top (insert d ds') Y" Ch y W ds "Pd_shuffle_to_top ds' Y"
          using %invisible Pds'.Pd_linear Pds'.Pd_range Pd_shuffle_to_top_simps Pd_range' unfolding AboveS_def
          by unfold_locales auto
        from \<open>d \<notin> ds'\<close> Y Pdds'.Theorem_11_fp_cop_F have False
          using Pds'.stable_on_allocation[OF Pds'.Theorem_1[of ds]] Pd_linear Pd_range'
          unfolding order_on_defs antisym_def AboveS_def dX_def
          by (clarsimp simp: Pd_shuffle_to_top_simps) (blast dest: Pd_Xd)
        then show ?thesis ..
      next
        case False note \<open>y \<notin> W\<close>
        show ?thesis
        proof (cases "Pds'.stable_on ds W")
          case True note \<open>Pds'.stable_on ds W\<close>
          with \<open>allocation Y\<close> \<open>d \<notin> ds'\<close> Y \<open>w \<in> W\<close> \<open>y \<notin> W\<close> show ?thesis
            using Pds'.Theorem_5[OF \<open>Pds'.stable_on ds W\<close> \<open>w \<in> W\<close>]
            by (auto 0 2 simp: Pd_shuffle_to_top_simps shuffle_to_top_def dX_def AboveS_def dest: Pd_range' inj_onD)
        next
          case False note \<open>\<not>Pds'.stable_on ds W\<close>
          then show ?thesis
          proof(cases rule: Pds'.not_stable_on_cases)
            case not_individually_rational
            note Psos = Pdds'.stable_on_allocation[OF \<open>Pdds'.stable_on ds W\<close>]
                        Pdds'.stable_on_CH[OF \<open>Pdds'.stable_on ds W\<close>]
                        Pdds'.stable_on_Xd[OF \<open>Pdds'.stable_on ds W\<close>]
            have "x \<in> Pds'.Cd (Xd x) W" if "x \<in> W" for x
            proof(cases "Xd x = d")
              case True
              with \<open>allocation Y\<close> \<open>allocation W\<close> Y(1,3) \<open>y \<notin> W\<close>
                   Pdds'.stable_on_range'[OF \<open>Pdds'.stable_on ds W\<close> \<open>x \<in> W\<close>] \<open>x \<in> W\<close>
              show ?thesis by (force simp: Pd_shuffle_to_top_Field dest: dX_range' inj_onD intro: Pds'.Cd_single)
            next
              case False
              with \<open>allocation Y\<close> \<open>allocation W\<close> Pdds'.stable_on_range'[OF \<open>Pdds'.stable_on ds W\<close> \<open>x \<in> W\<close>] \<open>x \<in> W\<close>
              show ?thesis by (auto simp: Pd_shuffle_to_top_Field intro!: Pds'.Cd_single)
            qed
            with not_individually_rational \<open>Pdds'.CH W = W\<close> Psos(3) show ?thesis
              unfolding Pds'.individually_rational_on_def by (auto simp: Pds'.mem_CD_on_Cd dest: Pds'.Cd_range')
        next
          case not_no_blocking
          then obtain h X'' where Pbo: "Pds'.blocking_on ds W h X''"
            unfolding Pds'.stable_no_blocking_on_def by blast
          have "Pdds'.blocking_on ds W h X''"
          proof(rule Pdds'.blocking_onI)
            fix x assume "x \<in> X''"
            note Pbos = Pds'.blocking_on_allocation[OF \<open>Pds'.blocking_on ds W h X''\<close>]
                        Pds'.blocking_on_CD_on'[OF \<open>Pds'.blocking_on ds W h X''\<close> \<open>x \<in> X''\<close>]
                        Pds'.blocking_on_Field[OF \<open>Pds'.blocking_on ds W h X''\<close>, where d=d]
            show "x \<in> Pdds'.CD_on ds (W \<union> X'')"
            proof(cases "Xd x = d")
              case True
              from \<open>allocation Y\<close> III \<open>d \<in> ds''\<close>  \<open>Xd x = d\<close>
              have "dX Y (Xd x) \<subseteq> Field (Pd (Xd x))"
                by clarsimp (metis AboveS_Pd_Xd AboveS_Field dX_range' inj_on_eq_iff)
              moreover with \<open>d \<notin> ds'\<close> \<open>Xd x = d\<close> Pbos
              have "dX X'' (Xd x) \<subseteq> Field (Pd (Xd x))"
                by (clarsimp simp: Pd_shuffle_to_top_simps)
              moreover note \<open>allocation Y\<close> \<open>d \<notin> ds'\<close> \<open>y \<notin> W\<close> \<open>Xd y = d\<close> \<open>x \<in> X''\<close> Pbos
              ultimately show ?thesis
                by (clarsimp simp: Pdds'.mem_CD_on_Cd Pds'.mem_CD_on_Cd Pds'.Cd_Above Pdds'.Cd_Above
                                   Int_Un_distrib2)
                   (clarsimp simp: Pd_shuffle_to_top_simps shuffle_to_top_Field dX_singular dX_Int_Field_Pd Un_absorb2,
                    force simp: \<open>y \<in> Y\<close> shuffle_to_top_def dX_def Above_def dest: inj_onD intro: FieldI1)
            next
              case False
              from Pbos \<open>Xd x \<noteq> d\<close> show ?thesis
                by (simp add: Pdds'.mem_CD_on_Cd Pds'.mem_CD_on_Cd Pds'.Cd_greatest Pdds'.Cd_greatest)
                   (simp add: Pd_shuffle_to_top_simps)
            qed
          qed (use \<open>Pds'.blocking_on ds W h X''\<close> in \<open>simp_all add: Pds'.blocking_on_def\<close>)
          with \<open>Pdds'.stable_on ds W\<close> have False by (simp add: Pdds'.blocking_on_imp_not_stable)
          then show ?thesis ..
        qed
      qed
    qed
  qed
  from \<open>?Z = CH (Pdds'.fp_cop_F ds)\<close> IH show "cop ds = Pdds'.cop ds" by simp
qed

text\<open>

The top-level theorem states that the COP is group strategy proof. To
account for the quantification over preferences, we directly use the
raw constants from the @{const "Contracts"} locale.

\<close>

theorem fp_cop_F_group_strategy_proof:
  shows "group_strategy_proof ds Contracts.cop"
        (is "group_strategy_proof _ ?\<phi>")
proof(rule group_strategy_proofI)
  fix Pd Pds' Ch ds'
  assume XXX: "mechanism_domain Pd Ch" "mechanism_domain (override_on Pd Pds' ds') Ch"
     and YYY: "ds' \<subseteq> ds" "ds' \<noteq> {}"
     and ZZZ: "\<forall>d\<in>ds'. \<exists>y\<in>?\<phi> (override_on Pd Pds' ds') Ch ds. y \<in> AboveS (Pd d) (dX (?\<phi> Pd Ch ds) d)"
  from XXX(1) interpret TruePref: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh Pd Ch .
  from XXX(2) interpret
    ManiPref: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh "override_on Pd Pds' ds'" Ch .
  let ?Y = "ManiPref.cop ds"
  let ?Z = "TruePref.cop ds"
  let ?Pd_shuffle_to_top = "TruePref.Pd_shuffle_to_top ds' ?Y"
  interpret ManiPref': ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh ?Pd_shuffle_to_top Ch
    using TruePref.Ch_unilateral_substitutes TruePref.Ch_irc TruePref.Ch_lad TruePref.Ch_range TruePref.Ch_singular
          TruePref.Pd_shuffle_to_top_linear ManiPref.stable_on_allocation[OF ManiPref.Theorem_1[of ds]]
          TruePref.Pd_shuffle_to_top_range ManiPref.dX_range
    by unfold_locales simp_all
  let ?Y' = "ManiPref'.cop ds"
  have "ManiPref'.stable_on ds ?Y"
  proof(rule ManiPref'.stable_onI)
    show "ManiPref'.individually_rational_on ds ?Y"
    proof(rule ManiPref'.individually_rational_onI)
      show "ManiPref'.CD_on ds ?Y = ?Y" (is "?lhs = ?rhs")
      proof(rule set_elem_equalityI)
        fix x assume "x \<in> ?rhs"
        then have "Xd x \<in> ds \<and> (Xd x \<notin> ds' \<longrightarrow> x \<in> Field (Pd (Xd x)))"
          by (metis ManiPref.fp_cop_F_range_inv' TruePref.CH_range' override_on_apply_notin)
        with ManiPref.Theorem_1[of ds] \<open>x \<in> ?rhs\<close> show "x \<in> ?lhs"
          by (fastforce dest: ManiPref.stable_on_allocation
                    simp: ManiPref'.Cd_single ManiPref'.mem_CD_on_Cd TruePref.Pd_shuffle_to_top_Field dX_def)
      qed (meson IntE ManiPref'.CD_on_range')
      show "ManiPref'.CH ?Y = ?Y" by (simp add: ManiPref'.CH_irc_idem)
    qed
    show "ManiPref'.stable_no_blocking_on ds ?Y"
    proof(rule ManiPref'.stable_no_blocking_onI2)
      fix h X'' assume "ManiPref'.blocking_on ds ?Y h X''"
      have "ManiPref.blocking_on ds ?Y h X''"
      proof(rule ManiPref.blocking_onI)
        fix x assume "x \<in> X''"
        note Pbos = ManiPref'.blocking_on_Field[OF \<open>ManiPref'.blocking_on ds ?Y h X''\<close>, where d="Xd x"]
                    ManiPref'.blocking_on_allocation[OF \<open>ManiPref'.blocking_on ds ?Y h X''\<close>]
                    ManiPref'.blocking_on_CD_on'[OF \<open>ManiPref'.blocking_on ds ?Y h X''\<close> \<open>x \<in> X''\<close>]
                    ManiPref'.blocking_on_Cd[OF \<open>ManiPref'.blocking_on ds ?Y h X''\<close>, where d="Xd x"]
        show "x \<in> ManiPref.CD_on ds (?Y \<union> X'')"
        proof(cases "Xd x \<in> ds'")
          case True
          from ManiPref.fp_cop_F_allocation[of ds] \<open>x \<in> X''\<close> \<open>Xd x \<in> ds'\<close> Pbos bspec[OF ZZZ \<open>Xd x \<in> ds'\<close>]
          have "dX X'' (Xd x) \<subseteq> Field (Pds' (Xd x))"
            by (clarsimp simp: dX_singular ManiPref'.mem_CD_on_Cd ManiPref'.Cd_Above TruePref.Pd_shuffle_to_top_Field)
               (fastforce simp: TruePref.Pd_shuffle_to_top_simps dX_singular dest: TruePref.AboveS_Pd_Xd
                          dest: ManiPref.fp_cop_F_range_inv' ManiPref.CH_range' TruePref.Above_shuffle_to_top)
          moreover from ManiPref.stable_on_range'[OF ManiPref.Theorem_1] \<open>Xd x \<in> ds'\<close>
          have "dX ?Y (Xd x) \<subseteq> Field (Pds' (Xd x))"
            by (metis dX_range' override_on_apply_in subsetI)
          moreover note bspec[OF ZZZ \<open>Xd x \<in> ds'\<close>] \<open>x \<in> X''\<close> \<open>Xd x \<in> ds'\<close> Pbos
          ultimately show ?thesis
            using ManiPref.Pd_linear'[of "Xd x"] ManiPref.fp_cop_F_allocation[of ds]
                  ManiPref'.fp_cop_F_allocation[of ds]
            by (clarsimp simp: ManiPref'.mem_CD_on_Cd ManiPref'.Cd_Above_dX ManiPref.mem_CD_on_Cd
                               ManiPref.Cd_Above_dX dX_union dX_singular
                               TruePref.Pd_shuffle_to_top_Field TruePref.AboveS_Pd_Xd)
               (force simp: TruePref.Pd_shuffle_to_top_simps insert_absorb elim: Above_Linear_singleton
                     dest!: TruePref.Above_shuffle_to_top)
        next
          case False
          with Pbos show ?thesis
            by (fastforce simp: ManiPref'.mem_CD_on_Cd ManiPref'.Cd_greatest ManiPref.mem_CD_on_Cd
                                ManiPref.Cd_greatest TruePref.Pd_shuffle_to_top_simps)
        qed
      qed (use \<open>ManiPref'.blocking_on ds ?Y h X''\<close> in \<open>simp_all add: ManiPref'.blocking_on_def\<close>)
      with ManiPref.Theorem_1[of ds] show False by (simp add: ManiPref.blocking_on_imp_not_stable)
    qed
  qed
  with ManiPref'.stable_on_allocation have "{x \<in> ?Y. Xd x \<in> ds'} \<subseteq> {x \<in> ?Y'. Xd x \<in> ds'}"
    by (force dest: ManiPref'.Theorem_5[of ds]
              simp: TruePref.Pd_shuffle_to_top_simps TruePref.shuffle_to_top_def dX_def dest: inj_onD)
  moreover
  from ManiPref.stable_on_allocation[OF ManiPref.Theorem_1] ZZZ
  have "?Z = ?Y'" by (rule TruePref.Lemma_1)
  moreover note YYY ZZZ
  ultimately show False
    unfolding AboveS_def dX_def by (fastforce simp: ex_in_conv[symmetric] dest: TruePref.Pd_range')
qed

end

text (in ContractsWithSubstitutes) \<open>

Again, this result does not directly apply to @{term "gfp_F"} due to
the mechanism domain hypothesis.

Finally, \<^citet>\<open>\<open>Corollary~2\<close> in "HatfieldKojima:2010"\<close> (respectively,
\<^citet>\<open>\<open>Corollary~1\<close> in "HatfieldKojima:2009"\<close>) assert that the COP (@{const
"gfp_F"}) is ``weakly Pareto optimal'', i.e., that there is no @{const
"individually_rational"} allocation that every doctor strictly prefers
to the doctor-optimal match.

\<close>

context ContractsWithUnilateralSubstitutesAndIRCAndLAD
begin

theorem Corollary_2:
  assumes "ds \<noteq> {}"
  shows "\<not>(\<exists>Y. individually_rational_on ds Y
        \<and> (\<forall>d\<in>ds. \<exists>y\<in>Y. y \<in> AboveS (Pd d) (dX (cop ds) d)))"
proof(unfold individually_rational_on_def, safe)
  fix Y assume "CD_on ds Y = Y" "CH Y = Y"
           and Z: "\<forall>d\<in>ds. \<exists>y\<in>Y. y \<in> AboveS (Pd d) (dX (cop ds) d)"
  from \<open>CD_on ds Y = Y\<close> have "allocation Y" by (metis CD_on_inj_on_Xd)
  from \<open>CD_on ds Y = Y\<close>
  interpret Y: ContractsWithUnilateralSubstitutesAndIRCAndLAD Xd Xh "Pd_singletons_for_ds Y ds" Ch
    using Ch_unilateral_substitutes Ch_irc Ch_lad Ch_range Ch_singular Pd_singletons_for_ds_range
          Pd_singletons_for_ds_linear[OF CD_on_inj_on_Xd]
    by unfold_locales (simp_all, metis)
  from Y.fp_cop_F_doctor_optimal_match Y.doctor_optimal_matchI
  have "CH (Y.fp_cop_F ds) = Y"
  proof(rule Y.doctor_optimal_match_unique)
    show "Y.stable_on ds Y"
    proof(rule Y.stable_onI)
      show "Y.individually_rational_on ds Y"
      proof(rule Y.individually_rational_onI)
        from \<open>CD_on ds Y = Y\<close> CD_on_Xd[where A=Y and ds=ds] show "Y.CD_on ds Y = Y"
          unfolding Y.CD_on_def CD_on_def
          by (force simp: Y.Cd_greatest Cd_greatest greatest_def Pd_singletons_for_ds_simps dX_def)
        from \<open>CH Y = Y\<close> show "Y.CH Y = Y" .
      qed
      show "Y.stable_no_blocking_on ds Y"
        by (rule Y.stable_no_blocking_onI,
            drule subset_trans[OF _ Y.CD_on_range],
            clarsimp simp: Pd_singletons_for_ds_def dX_def Un_absorb1 subset_eq sup_commute)
    qed
  next
    fix x X assume "x \<in> X" "Y.stable_on ds X"
    with Y.Theorem_5[of ds X x] Pd_singletons_for_ds_linear[OF \<open>allocation Y\<close>]
    show "\<exists>y\<in>Y. (x, y) \<in> Pd_singletons_for_ds Y ds (Xd x)"
      by (fastforce simp: Pd_singletons_for_ds_simps Y.stable_on_Xd dX_def)
  qed
  from Z \<open>CH (Y.fp_cop_F ds) = Y\<close> show False
    using group_strategy_proofD[OF
      fp_cop_F_group_strategy_proof
      ContractsWithUnilateralSubstitutesAndIRCAndLAD_axioms subset_refl
      \<open>ds \<noteq> {}\<close>
      Y.ContractsWithUnilateralSubstitutesAndIRCAndLAD_axioms[unfolded Pd_singletons_for_ds_def]]
    unfolding Pd_singletons_for_ds_def by force
qed

end

text\<open>

\<^citet>\<open>\<open>\S4.4\<close> in "RothSotomayor:1990"\<close> discuss how the non-proposing agents
can strategise to improve their outcomes in one-to-one matches.

\<close>
(*<*)

end
(*>*)


(*  Title:       Isabelle Collections Library
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
header {* \isaheader{Set Implementation by non-distinct Lists} *}
theory ListSetImpl_NotDist
imports
  "../spec/SetSpec"
  "../gen_algo/SetGA"
  (*"../common/ListAdd"*)
begin
text_raw {*\label{thy:ListSetImpl_NotDist}*}

(*@impl Set
  @type 'a lsnd
  @abbrv lsnd
  Sets implemented by lists that may contain duplicate elements.
  Insertion is quick, but other operations are less performant than on
  lists with distinct elements.
*)

type_synonym
  'a lsnd = "'a list"

subsection "Definitions"

definition lsnd_\<alpha> :: "'a lsnd \<Rightarrow> 'a set" where "lsnd_\<alpha> == set"
abbreviation (input) lsnd_invar
  :: "'a lsnd \<Rightarrow> bool" where "lsnd_invar == (\<lambda>_. True)"
definition lsnd_empty :: "unit \<Rightarrow> 'a lsnd" where "lsnd_empty == (\<lambda>_::unit. [])"
definition lsnd_memb :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> bool" where "lsnd_memb x l == List.member l x"
definition lsnd_ins :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_ins x l == x#l"
definition lsnd_ins_dj :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_ins_dj x l == x#l"

definition lsnd_delete :: "'a \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd" where "lsnd_delete x l == remove_rev x l"

definition lsnd_iteratei :: "'a lsnd \<Rightarrow> ('a,'\<sigma>) set_iterator"
where "lsnd_iteratei l = foldli (remdups l)"

definition lsnd_isEmpty :: "'a lsnd \<Rightarrow> bool" where "lsnd_isEmpty s == s=[]"

definition lsnd_union :: "'a lsnd \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd"
  where "lsnd_union s1 s2 == revg s1 s2"
definition lsnd_union_dj :: "'a lsnd \<Rightarrow> 'a lsnd \<Rightarrow> 'a lsnd"
  where "lsnd_union_dj s1 s2 == revg s1 s2" -- "Union of disjoint sets"

definition lsnd_to_list :: "'a lsnd \<Rightarrow> 'a list" where "lsnd_to_list == remdups"
definition list_to_lsnd :: "'a list \<Rightarrow> 'a lsnd" where "list_to_lsnd == id"

subsection "Correctness"
lemmas lsnd_defs =
  lsnd_\<alpha>_def
  lsnd_empty_def
  lsnd_memb_def
  lsnd_ins_def
  lsnd_ins_dj_def
  lsnd_delete_def
  lsnd_iteratei_def
  lsnd_isEmpty_def
  lsnd_union_def
  lsnd_union_dj_def
  lsnd_to_list_def
  list_to_lsnd_def

lemma lsnd_empty_impl: "set_empty lsnd_\<alpha> lsnd_invar lsnd_empty"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_memb_impl: "set_memb lsnd_\<alpha> lsnd_invar lsnd_memb"
by (unfold_locales)(auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_impl: "set_ins lsnd_\<alpha> lsnd_invar lsnd_ins"
by (unfold_locales) (auto simp add: lsnd_defs in_set_member)

lemma lsnd_ins_dj_impl: "set_ins_dj lsnd_\<alpha> lsnd_invar lsnd_ins_dj"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_delete_impl: "set_delete lsnd_\<alpha> lsnd_invar lsnd_delete"
by (unfold_locales) (auto simp add: lsnd_delete_def lsnd_\<alpha>_def remove_rev_alt_def)

lemma lsnd_\<alpha>_finite[simp, intro!]: "finite (lsnd_\<alpha> l)"
  by (auto simp add: lsnd_defs)

lemma lsnd_is_finite_set: "finite_set lsnd_\<alpha> lsnd_invar"
by (unfold_locales) (auto simp add: lsnd_defs)

lemma lsnd_iteratei_impl: "poly_set_iteratei lsnd_\<alpha> lsnd_invar lsnd_iteratei"
proof
  fix l :: "'a list"
  show "finite (lsnd_\<alpha> l)"
    unfolding lsnd_\<alpha>_def by simp

  show "set_iterator (lsnd_iteratei l) (lsnd_\<alpha> l)"
    apply (rule set_iterator_I [of "remdups l"])
    apply (simp_all add: lsnd_\<alpha>_def lsnd_iteratei_def)
  done
qed

lemma lsnd_isEmpty_impl: "set_isEmpty lsnd_\<alpha> lsnd_invar lsnd_isEmpty"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_impl: "set_union lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_union"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_union_dj_impl: "set_union_dj lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_\<alpha> lsnd_invar lsnd_union_dj"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma lsnd_to_list_impl: "set_to_list lsnd_\<alpha> lsnd_invar lsnd_to_list"
by(unfold_locales)(auto simp add: lsnd_defs)

lemma list_to_lsnd_impl: "list_to_set lsnd_\<alpha> lsnd_invar list_to_lsnd"
by(unfold_locales)(auto simp add: lsnd_defs)

definition lsnd_basic_ops :: "('x,'x lsnd) set_basic_ops"
  where [icf_rec_def]: "lsnd_basic_ops \<equiv> \<lparr>
    bset_op_\<alpha> = lsnd_\<alpha>,
    bset_op_invar = lsnd_invar,
    bset_op_empty = lsnd_empty,
    bset_op_memb = lsnd_memb,
    bset_op_ins = lsnd_ins,
    bset_op_ins_dj = lsnd_ins_dj,
    bset_op_delete = lsnd_delete,
    bset_op_list_it = lsnd_iteratei
  \<rparr>"

setup Locale_Code.open_block
interpretation lsnd_basic!: StdBasicSet lsnd_basic_ops
  apply (rule StdBasicSet.intro)
  apply (simp_all add: icf_rec_unf)
  apply (rule lsnd_empty_impl lsnd_memb_impl lsnd_ins_impl lsnd_ins_dj_impl
    lsnd_delete_impl lsnd_iteratei_impl)+
  done
setup Locale_Code.close_block

definition [icf_rec_def]: "lsnd_ops \<equiv> lsnd_basic.dflt_ops \<lparr>
  set_op_isEmpty := lsnd_isEmpty,
  set_op_union := lsnd_union,
  set_op_union_dj := lsnd_union_dj,
  set_op_to_list := lsnd_to_list,
  set_op_from_list := list_to_lsnd
  \<rparr>"

setup Locale_Code.open_block
interpretation lsnd!: StdSetDefs lsnd_ops .
interpretation lsnd!: StdSet lsnd_ops
proof -
  interpret aux: StdSet lsnd_basic.dflt_ops
    by (rule lsnd_basic.dflt_ops_impl)

  show "StdSet lsnd_ops"
    unfolding lsnd_ops_def
    apply (rule StdSet_intro)
    apply icf_locales
    apply (simp_all add: icf_rec_unf
      lsnd_isEmpty_impl lsnd_union_impl lsnd_union_dj_impl lsnd_to_list_impl
      list_to_lsnd_impl
    )
    done
qed
interpretation lsnd!: StdSet_no_invar lsnd_ops
  by unfold_locales (simp add: icf_rec_unf)
setup Locale_Code.close_block

setup {* ICF_Tools.revert_abbrevs "lsnd"*}

lemma pi_lsnd[proper_it]:
  "proper_it' lsnd_iteratei lsnd_iteratei"
  apply (rule proper_it'I)
  unfolding lsnd_iteratei_def
  by (intro icf_proper_iteratorI)

interpretation pi_lsnd: proper_it_loc lsnd_iteratei lsnd_iteratei
  apply unfold_locales by (rule pi_lsnd)

definition test_codegen where "test_codegen \<equiv> (
  lsnd.empty,
  lsnd.memb,
  lsnd.ins,
  lsnd.delete,
  lsnd.list_it,
  lsnd.sng,
  lsnd.isEmpty,
  lsnd.isSng,
  lsnd.ball,
  lsnd.bex,
  lsnd.size,
  lsnd.size_abort,
  lsnd.union,
  lsnd.union_dj,
  lsnd.diff,
  lsnd.filter,
  lsnd.inter,
  lsnd.subset,
  lsnd.equal,
  lsnd.disjoint,
  lsnd.disjoint_witness,
  lsnd.sel,
  lsnd.to_list,
  lsnd.from_list
)"

export_code test_codegen in SML

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
header {* \isaheader{Deprecated: Data Refinement for the While-Combinator} *}
theory DatRef
imports
  Main
  "~~/src/HOL/Library/While_Combinator"
begin
text_raw {*\label{thy:DatRef}*}

text {*
  Note that this theory is deprecated. For new developments, the refinement
  framework (Refine-Monadic entry of the AFP) should be used.
*}

text {*
  In this theory, a data refinement framework for
  non-deterministic while-loops is developed. The refinement is based on
  showing simulation w.r.t. an abstraction function.
  The case of deterministic while-loops is explicitely handled, to
  support proper code-generation using the While-Combinator.

  Note that this theory is deprecated. For new developments, the refinement
  framework (Refine-Monadic entry of the AFP) should be used.
  *}

(* TODO-LIST and ideas
  - Model nondeterministic algorithms by their step relation, and show refinement stuff for this (more general) model (c.f. dpn-pre^* formalization)
    Then, the nondeterministic while-loop would be a special case.

*)

text {*
  A nondeterministic while-algorithm is described by a set of states, a
  continuation condition, a step relation, a set of possible initial
  states and an invariant.
  *}

  -- "Encapsulates a while-algorithm and its invariant "
record 'S while_algo =
  -- "Termination condition"
  wa_cond :: "'S set"
  -- "Step relation (nondeterministic)"
  wa_step :: "('S \<times> 'S) set"
  -- "Initial state (nondeterministic)"
  wa_initial :: "'S set"
  -- "Invariant"
  wa_invar :: "'S set"

text {*
  A while-algorithm is called {\em well-defined} iff the invariant holds for
  all reachable states and the accessible part of the step-relation is
  well-founded.
*}
  -- {* Conditions that must hold for a well-defined while-algorithm *}
locale while_algo =
  fixes WA :: "'S while_algo"

  -- "A step must preserve the invariant"
  assumes step_invar:
    "\<lbrakk> s\<in>wa_invar WA; s\<in>wa_cond WA; (s,s')\<in>wa_step WA \<rbrakk> \<Longrightarrow> s'\<in>wa_invar WA"
  -- "Initial states must satisfy the invariant"
  assumes initial_invar: "wa_initial WA \<subseteq> wa_invar WA"
  -- "The accessible part of the step relation must be well-founded"
  assumes step_wf:
    "wf { (s',s). s\<in>wa_invar WA \<and> s\<in>wa_cond WA \<and> (s,s')\<in>wa_step WA }"

text {*
  Next, a refinement relation for while-algorithms is defined.
  Note that the involved while-algorithms are not required to
  be well-defined. Later, some lemmas to transfer well-definedness
  along refinement relations are shown.

  Refinement involves a concrete algorithm, an abstract algorithm and an
  abstraction function. In essence, a refinement establishes a simulation
  of the concrete algorithm by the abstract algorithm w.r.t. the abstraction
  function.
*}

locale wa_refine =
  -- "Concrete algorithm"
  fixes WAC :: "'C while_algo"
  -- "Abstract algorithm"
  fixes WAA :: "'A while_algo"

  -- "Abstraction function"
  fixes \<alpha> :: "'C \<Rightarrow> 'A"

  -- "Condition implemented correctly: The concrete condition must be stronger
      than the abstract one. Intuitively, this ensures that the concrete loop
      will not run longer than the abstract one that it is simulated by."
  assumes cond_abs: "\<lbrakk> s\<in>wa_invar WAC; s\<in>wa_cond WAC \<rbrakk> \<Longrightarrow> \<alpha> s \<in> wa_cond WAA"

  -- "Step implemented correctly: The abstract step relation must simulate the
      concrete step relation"
  assumes step_abs: "\<lbrakk> s\<in>wa_invar WAC; s\<in>wa_cond WAC; (s,s')\<in>wa_step WAC \<rbrakk>
                      \<Longrightarrow> (\<alpha> s, \<alpha> s')\<in>wa_step WAA"
  -- "Initial states implemented correctly: The abstractions of the concrete
      initial states must be abstract initial states."
  assumes initial_abs: "\<alpha> ` wa_initial WAC \<subseteq> wa_initial WAA"
  -- {* Invariant implemented correctly: The concrete invariant must be stronger
        then the abstract invariant.
        Note that, usually, the concrete invariant will be of the
        form @{term "I_add \<inter> {s. \<alpha> s \<in> wa_invar WAA}"}, where @{term I_add} are
        the additional invariants added by the concrete algorithm.
     *}
  assumes invar_abs: "\<alpha> ` wa_invar WAC \<subseteq> wa_invar WAA"
begin

  lemma initial_abs': "s\<in>wa_initial WAC \<Longrightarrow> \<alpha> s \<in> wa_initial WAA"
    using initial_abs by auto

  lemma invar_abs': "s\<in>wa_invar WAC \<Longrightarrow> \<alpha> s \<in> wa_invar WAA"
    using invar_abs by auto

end

-- {*
  Given a concrete while-algorithm and a well-defined abstract
  while-algorithm, this lemma shows refinement and
  well-definedness of the concrete while-algorithm.

  Assuming well-definedness of the abstract algorithm and refinement,
  some proof-obligations for well-definedness of the concrete algorithm can be
  discharged automatically.

  For this purpose, the invariant is split into a concrete and an abstract
  part. The abstract part claims that the abstraction of a state satisfies
  the abstract invariant. The concrete part makes some additional claims
  about a valid concrete state. Then, after having shown refinement, the
  assumptions that the abstract part of the invariant is preserved, can
  be discharged automatically.
*}
lemma wa_refine_intro:
  fixes condc :: "'C set" and
        stepc :: "('C\<times>'C) set" and
        initialc :: "'C set" and
        invar_addc :: "'C set"
  fixes WAA :: "'A while_algo"
  fixes \<alpha> :: "'C \<Rightarrow> 'A"
  assumes "while_algo WAA"

  -- "The concrete step preserves the concrete part of the invariant"
  assumes step_invarc:
    "!!s s'. \<lbrakk> s\<in>invar_addc; s\<in>condc; \<alpha> s \<in> wa_invar WAA; (s,s')\<in>stepc \<rbrakk>
              \<Longrightarrow> s'\<in>invar_addc"
  -- "The concrete initial states satisfy the concrete part of the invariant"
  assumes initial_invarc: "initialc \<subseteq> invar_addc"

  -- "Condition implemented correctly"
  assumes cond_abs:
    "!!s. \<lbrakk> s\<in>invar_addc; \<alpha> s \<in> wa_invar WAA; s\<in>condc \<rbrakk> \<Longrightarrow> \<alpha> s \<in> wa_cond WAA"
  -- "Step implemented correctly"
  assumes step_abs:
    "!!s s'. \<lbrakk> s\<in>invar_addc; s\<in>condc; \<alpha> s \<in> wa_invar WAA; (s,s')\<in>stepc \<rbrakk>
             \<Longrightarrow> (\<alpha> s, \<alpha> s')\<in>wa_step WAA"
  -- "Initial states implemented correctly"
  assumes initial_abs: "\<alpha> ` initialc \<subseteq> wa_initial WAA"

  -- "Concrete while-algorithm: The invariant is separated into a concrete and
      an abstract part"
  defines "WAC == \<lparr>
   wa_cond=condc,
   wa_step=stepc,
   wa_initial=initialc,
   wa_invar=(invar_addc \<inter> {s. \<alpha> s\<in> wa_invar WAA}) \<rparr>"

  shows
    "while_algo WAC \<and>
     wa_refine WAC WAA \<alpha>" (is "?T1 \<and> ?T2")
proof
  interpret waa: while_algo WAA by fact
  show G1: "?T1"
    apply (unfold_locales)
    apply (simp_all add: WAC_def)
    apply safe
    apply (blast intro!: step_invarc)

    apply (frule (3) step_abs)
    apply (frule (2) cond_abs)
    apply (erule (2) waa.step_invar)

    apply (erule set_rev_mp[OF _ initial_invarc])

    apply (insert initial_abs waa.initial_invar) [1]
    apply blast

    apply (rule_tac
      r="inv_image { (s',s). s\<in>wa_invar WAA
                     \<and> s\<in>wa_cond WAA
                     \<and> (s,s')\<in>wa_step WAA } \<alpha>"
      in wf_subset)
    apply (simp add: waa.step_wf)
    apply (auto simp add: cond_abs step_abs) [1]
    done
  show ?T2
    apply (unfold_locales)
    apply (auto simp add: cond_abs step_abs initial_abs WAC_def)
    done
qed

  -- {* After refinement has been shown, this lemma transfers
        the well-definedness property up the refinement chain.
        Like in @{thm [source] wa_refine_intro}, some proof-obligations can
        be discharged by assuming refinement and well-definedness of the
        abstract algorithm.
    *}
lemma (in wa_refine) wa_intro:
  -- "Concrete part of the invariant"
  fixes addi :: "'C set"
  -- "The abstract algorithm is well-defined"
  assumes "while_algo WAA"
  -- "The invariant can be split into concrete and abstract part"
  assumes icf: "wa_invar WAC = addi \<inter> {s. \<alpha> s \<in> wa_invar WAA}"

  -- "The step-relation preserves the concrete part of the invariant"
  assumes step_addi:
    "!!s s'. \<lbrakk> s\<in>addi; s\<in>wa_cond WAC; \<alpha> s \<in> wa_invar WAA;
               (s,s')\<in>wa_step WAC
             \<rbrakk> \<Longrightarrow> s'\<in>addi"

  -- "The initial states satisfy the concrete part of the invariant"
  assumes initial_addi: "wa_initial WAC \<subseteq> addi"

  shows
    "while_algo WAC"
proof -
  interpret waa: while_algo WAA by fact
  show ?thesis
    apply (unfold_locales)
    apply (subst icf)
    apply safe
    apply (simp only: icf)
    apply safe
    apply (blast intro!: step_addi)

    apply (frule (2) step_abs)
    apply (frule (1) cond_abs)
    apply (simp only: icf)
    apply clarify
    apply (erule (2) waa.step_invar)

    apply (simp add: icf)
    apply (rule conjI)
    apply (erule set_rev_mp[OF _ initial_addi])
    apply (insert initial_abs waa.initial_invar) [1]
    apply blast

    apply (rule_tac
      r="inv_image { (s',s). s\<in>wa_invar WAA
                    \<and> s\<in>wa_cond WAA
                    \<and> (s,s')\<in>wa_step WAA } \<alpha>"
      in wf_subset)
    apply (simp add: waa.step_wf)
    apply (auto simp add: cond_abs step_abs icf) [1]
    done
qed

text {*
  A special case of refinement occurs, if the concrete condition implements the
  abstract condition precisely. In this case, the concrete algorithm will run
  as long as the abstract one that it is simulated by. This allows to
  transfer properties of the result from the abstract algorithm to the
  concrete one.
*}

-- "Precise refinement"
locale wa_precise_refine = wa_refine +
  constrains \<alpha> :: "'C \<Rightarrow> 'A"
  assumes cond_precise:
    "\<forall>s. s\<in>wa_invar WAC \<and> \<alpha> s\<in>wa_cond WAA \<longrightarrow> s\<in>wa_cond WAC"
begin
  -- "Transfer correctness property"
  lemma transfer_correctness:
    assumes A: "\<forall>s. s\<in>wa_invar WAA \<and> s\<notin>wa_cond WAA \<longrightarrow> P s"
    shows "\<forall>sc. sc\<in>wa_invar WAC \<and> sc\<notin>wa_cond WAC \<longrightarrow> P (\<alpha> sc)"
    using A cond_abs invar_abs cond_precise by blast
end

text {* Refinement as well as precise refinement is reflexive and transitive *}

lemma wa_ref_refl: "wa_refine WA WA id"
  by (unfold_locales) auto

lemma wa_pref_refl: "wa_precise_refine WA WA id"
  by (unfold_locales) auto

lemma wa_ref_trans:
  assumes "wa_refine WC WB \<alpha>1"
  assumes "wa_refine WB WA \<alpha>2"
  shows "wa_refine WC WA (\<alpha>2\<circ>\<alpha>1)"
proof -
  interpret r1: wa_refine WC WB \<alpha>1 by fact
  interpret r2: wa_refine WB WA \<alpha>2 by fact

  show ?thesis (* Cool, everything by auto! *)
    apply unfold_locales
    apply (auto simp add:
      r1.invar_abs' r2.invar_abs'
      r1.cond_abs r2.cond_abs
      r1.step_abs r2.step_abs
      r1.initial_abs' r2.initial_abs')
    done
qed

lemma wa_pref_trans:
  assumes "wa_precise_refine WC WB \<alpha>1"
  assumes "wa_precise_refine WB WA \<alpha>2"
  shows "wa_precise_refine WC WA (\<alpha>2\<circ>\<alpha>1)"
proof -
  interpret r1: wa_precise_refine WC WB \<alpha>1 by fact
  interpret r2: wa_precise_refine WB WA \<alpha>2 by fact

  show ?thesis
    apply intro_locales
    apply (rule wa_ref_trans)
    apply (unfold_locales)
    apply (auto simp add: r1.invar_abs' r2.invar_abs'
                          r1.cond_precise r2.cond_precise)
    done
qed

text {*
  A well-defined while-algorithm is {\em deterministic}, iff
  the step relation is a function and there is just one
  initial state. Such an algorithm is suitable for direct implementation
  by the while-combinator.

  For deterministic while-algorithm, an own record is defined, as well as a
  function that maps it to the corresponding record for non-deterministic
  while algorithms. This makes sense as the step-relation may then be modeled
  as a function, and the initial state may be modeled as a single state rather
  than a (singleton) set of states.
*}

record 'S det_while_algo =
  -- "Termination condition"
  dwa_cond :: "'S \<Rightarrow> bool"
  -- "Step function"
  dwa_step :: "'S \<Rightarrow> 'S"
  -- "Initial state"
  dwa_initial :: "'S"
  -- "Invariant"
  dwa_invar :: "'S set"

  -- "Maps the record for deterministic while-algo to the corresponding record for
      the non-deterministic one"
definition "det_wa_wa DWA == \<lparr>
  wa_cond={s. dwa_cond DWA s},
  wa_step={(s,dwa_step DWA s) | s. True},
  wa_initial={dwa_initial DWA},
  wa_invar = dwa_invar DWA\<rparr>"

  -- "Conditions for a deterministic while-algorithm"
locale det_while_algo =
  fixes WA :: "'S det_while_algo"
  -- "The step preserves the invariant"
  assumes step_invar:
    "\<lbrakk> s\<in>dwa_invar WA; dwa_cond WA s \<rbrakk> \<Longrightarrow> dwa_step WA s \<in> dwa_invar WA"
  -- "The initial state satisfies the invariant"
  assumes initial_invar: "dwa_initial WA \<in> dwa_invar WA"
  -- "The relation made up by the step-function is well-founded."
  assumes step_wf:
    "wf { (dwa_step WA s,s) | s. s\<in>dwa_invar WA \<and> dwa_cond WA s }"

begin
  lemma is_while_algo: "while_algo (det_wa_wa WA)"
    apply (unfold_locales)
    apply (auto simp add: det_wa_wa_def step_invar initial_invar)
    apply (insert step_wf)
    apply (erule_tac P=wf in back_subst)
    apply auto
    done

end

lemma det_while_algo_intro:
  assumes "while_algo (det_wa_wa DWA)"
  shows "det_while_algo DWA"
proof -
  interpret while_algo "(det_wa_wa DWA)" by fact

  show ?thesis using step_invar initial_invar step_wf
    apply (unfold_locales)
    apply (unfold det_wa_wa_def)
    apply auto
    apply (erule_tac P=wf in back_subst)
    apply auto
    done

qed

-- "A deterministic while-algorithm is well-defined, if and only if the
    corresponding non-deterministic while-algorithm is well-defined"
theorem dwa_is_wa:
  "while_algo (det_wa_wa DWA) \<longleftrightarrow> det_while_algo DWA"
  using det_while_algo_intro det_while_algo.is_while_algo by auto

definition (in det_while_algo)
  "loop == (while (dwa_cond WA) (dwa_step WA) (dwa_initial WA))"

-- "Proof rule for deterministic while loops"
lemma (in det_while_algo) while_proof:
  assumes inv_imp: "\<And>s. \<lbrakk>s\<in>dwa_invar WA; \<not> dwa_cond WA s\<rbrakk> \<Longrightarrow> Q s"
  shows "Q loop"
  apply (unfold loop_def)
  apply (rule_tac P="\<lambda>x. x\<in>dwa_invar WA" and
                  r="{ (dwa_step WA s,s) | s. s\<in>dwa_invar WA \<and> dwa_cond WA s }"
                  in while_rule)
  apply (simp_all add: step_invar initial_invar step_wf inv_imp)
  done

  -- "This version is useful when using transferred correctness lemmas"
lemma (in det_while_algo) while_proof':
  assumes inv_imp:
    "\<forall>s. s\<in>wa_invar (det_wa_wa WA) \<and> s\<notin>wa_cond (det_wa_wa WA) \<longrightarrow> Q s"
  shows "Q loop"
  using inv_imp
  apply (simp add: det_wa_wa_def)
  apply (blast intro: while_proof)
  done

lemma (in det_while_algo) loop_invar:
  "loop \<in> dwa_invar WA"
  by (rule while_proof) simp

end


theory CSTC_Poly
  imports "../TSTSC_Poly" CNF_SAT_To_Clique
begin

subsection\<open>The reduction from \<open>CNF_Sat\<close> to \<open>Clique\<close> is polynomial\<close>

subsubsection\<open>Definitions\<close>

definition "max_size_clauses xs = card (\<Union> (set xs))"

definition "add_edges_cstc F S =
  SPECT [ S \<union> {{(l1, i), (l2, j)} | l1 l2 i j.
      i < length F \<and> j < length F \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j \<and> \<not> conflict l1 l2 \<and> i \<noteq> j}
       \<mapsto> max_size_clauses F * max_size_clauses F * length F * length F]"

definition "add_nodes_cstc F V =
  SPECT [ V \<union>  {(l1, i) | l1 i. i < length F \<and>   l1 \<in> F ! i}
       \<mapsto> max_size_clauses F * length F]"

definition cnf_sat_to_clique_alg ::
  "'a lit set list \<Rightarrow> (('a lit \<times> nat) set set \<times> ('a lit \<times> nat) set  \<times> nat) nrest" where
  "cnf_sat_to_clique_alg = (\<lambda>F. do {
      b \<leftarrow> SPECT [ finite (\<Union> (set F)) \<mapsto> 1];
      if b then
        do {
          l \<leftarrow> mop_list_length F;
          S \<leftarrow> mop_set_empty_set;
          S \<leftarrow> add_edges_cstc F S;
          V \<leftarrow> mop_set_empty_set;
          V \<leftarrow> add_nodes_cstc F V;
          RETURNT ( S, V, l)
        }
      else RETURNT ( {}, {}, 1 )
    })"

definition "number_clauses_CNF_SAT xs = length xs"
definition "size_CNF_SAT xs = number_clauses_CNF_SAT xs * max_size_clauses xs"
definition "cnf_sat_to_clique_time n = 4 + n * n  + n"
  (*where n is number of clauses times maximum length of the clauses*)
definition "size_Clique = (\<lambda>(E,V,k). card E + card V)"
definition "cnf_sat_to_clique_space n  = n * n + n"

subsubsection\<open>Auxiliary proofs\<close>

lemma brr2:
  shows "{{f l1, g l2} |l1 l2.  h l1 l2 \<and> l1 \<in> X \<and> l2 \<in> Y}
  \<subseteq> (\<Union>x \<in> X. \<Union>y \<in> Y. {{f x, g y}})"
  using brr by auto

lemma upperbounding_card_m:
  "\<forall>x\<in>X. card x \<le> m \<and> finite x \<Longrightarrow> x\<in>X \<Longrightarrow> y\<in>X \<Longrightarrow>
        card {{f l1, g l2} |l1 l2. h l1 l2 \<and> l1 \<in> x \<and> l2 \<in> y } \<le> m*m"
  apply(rule order.trans)
   apply(rule card_mono) defer
    apply(rule brr2)
   apply(rule order.trans) apply(rule card_Un)
  subgoal by auto
   apply(rule order.trans) apply(rule sum_image_le)
  subgoal using aaa by auto
    apply simp  apply(rule order.trans)
    apply(rule sum_mono[where g="\<lambda>_. m"]) apply simp
    apply(rule order.trans) apply(rule card_Un)
  subgoal apply (rule finite_imageI) using aaa by auto
    apply(rule order.trans) apply(rule sum_image_le)
  subgoal by auto
     apply simp apply simp apply(simp)
  apply(rule finite_Union)
   apply (rule finite_imageI) by auto

lemma card_x_smaller_card_union:
  assumes "x \<in> set xs" "finite (\<Union> (set xs))"
  shows "card x \<le> card (\<Union> (set xs))"
proof -
  have "x \<subseteq> \<Union> (set xs)"
    using \<open>x\<in>set xs\<close>  by auto
  then show ?thesis
    using assms by (simp add: card_mono)
qed

lemma upperbounding_card_union: assumes "\<forall>x\<in>X. card x \<le> card (\<Union> X) \<and> finite x" "x\<in>X" "y\<in>X"
  shows "card {{f l1, g l2} |l1 l2. h l1 l2 \<and> l1 \<in> x \<and> l2 \<in> y } \<le> card (\<Union> X) * card (\<Union> X)"
  using assms by(auto simp add: upperbounding_card_m )

lemma upperbounding_card_union2:
  assumes "finite (\<Union> X)" "x\<in>X" "y\<in>X"
  shows "card {{f l1, g l2} |l1 l2. \<not> h l1 l2 \<and> l1 \<in> x \<and> l2 \<in> y } \<le> card (\<Union> X) * card (\<Union> X)"
proof -
  from assms have 1: "\<forall>x\<in>X. finite x"
    apply(auto)
    by (simp add: Sup_upper rev_finite_subset)
  then have 2: "\<forall>x \<in>X. card x \<le> card (\<Union> X)"
    using card_x_smaller_card_union assms
    by (simp add: Sup_upper card_mono)
  from 1 2 assms
  show ?thesis
    by(auto simp add: upperbounding_card_union)
qed

lemma upperbounding_card_union3:
  assumes "finite (\<Union> (set F))" "i < length F" "j<length F"
  shows "card {{(l1, i), (l2, j)} |l1 l2.  i \<noteq> j \<and> \<not> h l1 l2 \<and> l1 \<in> F!i  \<and> l2 \<in> F!j}
    \<le> card (\<Union> (set F)) * card (\<Union> (set F))"
proof -
  obtain X where "X = F!i"
    by auto
  then have 1: "X \<in> set F"
    using assms
    by(auto)
  obtain Y where "Y = F!j"
    by auto
  then have 2: "Y \<in> set F"
    using assms
    by(auto)
  then have "{{(l1, i), (l2, j)} |l1 l2.  i \<noteq> j \<and> \<not> h l1 l2 \<and> l1 \<in> F!i  \<and> l2 \<in> F!j} =
    {{(l1, i), (l2, j)} |l1 l2.  i \<noteq> j \<and> \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}"
    using \<open>X = _\<close> \<open>Y=_\<close>
    by(auto)
  then have 3: "card {{(l1, i), (l2, j)} |l1 l2.  i \<noteq> j \<and> \<not> h l1 l2 \<and> l1 \<in> F!i  \<and> l2 \<in> F!j} =
    card {{(l1, i), (l2, j)} |l1 l2.  i \<noteq> j \<and> \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}"
    by(auto)
  have 4: "{{(l1, i), (l2, j)} |l1 l2.  i \<noteq> j \<and> \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}
    \<subseteq> {{(l1, i), (l2, j)} |l1 l2. \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}"
    by blast
  let ?S = "((\<Union> (set F)) \<times> {0..<length F})\<times> ((\<Union> (set F)) \<times> {0..<length F})"
  have "finite {{(l1, i), (l2, j)} |l1 l2. \<not> h l1 l2 \<and> l1 \<in> F!i  \<and> l2 \<in> F!j}"
    using assms
    by (fastforce intro: finite_surj[where A = "?S"])
  then have "finite {{(l1, i), (l2, j)} |l1 l2. \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}"
    using \<open>X = _\<close> \<open>Y=_\<close>
    by(auto)
  then have 5: "card {{(l1, i), (l2, j)} |l1 l2.  i \<noteq> j \<and> \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}
      \<le> card {{(l1, i), (l2, j)} |l1 l2. \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}"
    by (simp add: "4" card_mono)
  have "card {{(l1, i), (l2, j)} |l1 l2. \<not> h l1 l2 \<and> l1 \<in> X  \<and> l2 \<in> Y}
      \<le> card (\<Union> (set F)) * card (\<Union> (set F))" using 1 2 4 assms
    by(auto simp add:upperbounding_card_union2)
  then show ?thesis
    using 1 2 3 4 5
    by(auto)
qed

lemma card_clauses_samller: "x \<in> set xs \<and> finite (\<Union> (set xs)) \<Longrightarrow> card x \<le> max_size_clauses xs"
  by(auto simp add: max_size_clauses_def card_x_smaller_card_union)

lemma card_V:
  assumes "finite (\<Union> (set p))"
  shows "card {(l1, i). i < length p \<and> l1 \<in> p ! i} \<le> length p * card (\<Union> (set p))"
proof -
  let ?S = "((\<Union> (set p)) \<times> {0..<length p})"
  let ?V = " {(l1, i). i < length p \<and> l1 \<in> p ! i}"
  have 1: "card ?S \<le> (card (\<Union> (set p))) * length p"
    by (simp add: card_cartesian_product)
  moreover have "?V \<subseteq> ?S"
    by force
  ultimately show ?thesis
    by (metis (no_types, lifting) assms card_mono dual_order.trans finite_SigmaI
        finite_atLeastLessThan mult.commute)
qed

lemma card_E2:
  assumes "finite (\<Union> (set F))"
  shows "card {{(l1, i), (l2, j)} |l1 l2 i j. i < length F \<and> j < length F
      \<and> i \<noteq> j \<and> \<not> conflict l1 l2 \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j}
            \<le> length F * card (\<Union> (set F)) * length F * card (\<Union> (set F))"
  apply(subst paf2)
  apply(subst paf)
  apply(rule order.trans) apply(rule card_Un) apply simp
  apply(rule order.trans)
   apply(rule sum_image_le) apply simp apply simp
  apply(rule order.trans)
   apply(rule sum_mono[where g="\<lambda>_. card (\<Union> (set F))* card (\<Union> (set F))  * length F"])
  subgoal apply simp
    apply(rule order.trans) apply(rule card_Un) apply simp
    apply(rule order.trans)
     apply(rule sum_image_le) apply simp apply simp
    apply(rule order.trans)
     apply(rule sum_mono[where g="\<lambda>_. card (\<Union> (set F)) * card (\<Union> (set F))"])
    subgoal
      apply simp using assms upperbounding_card_union3 by(auto)
    apply simp done
  subgoal apply simp done
  done

lemma card_E3:
  assumes "finite (\<Union> (set F))"
  shows "card {{(l1, i), (l2, j)} |l1 l2 i j. i < length F \<and> j < length F
    \<and> i \<noteq> j \<and> \<not> conflict l1 l2 \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j}
            \<le> length F * card (\<Union> (set F)) * (length F * card (\<Union> (set F)))"
proof -
  have "card {{(l1, i), (l2, j)} |l1 l2 i j. i < length F \<and> j < length F
    \<and> i \<noteq> j \<and> \<not> conflict l1 l2 \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j}
    \<le> length F * card (\<Union> (set F)) * length F * card (\<Union> (set F))" using assms by(rule card_E2)
  then have "card {{(l1, i), (l2, j)} |l1 l2 i j. i < length F \<and> j < length F
    \<and> i \<noteq> j \<and> \<not> conflict l1 l2 \<and> l1 \<in> F ! i \<and> l2 \<in> F ! j}
    \<le> length F * card (\<Union> (set F)) * (length F * card (\<Union> (set F)))"  by(auto)
  then show ?thesis .
qed

subsubsection\<open>Main proofs\<close>

lemma cnf_sat_to_clique_size: "size_Clique (cnf_sat_to_clique p)
  \<le> cnf_sat_to_clique_space (size_CNF_SAT p)"
  by(auto intro: add_mono
      simp: size_Clique_def cnf_sat_to_clique_def cnf_sat_to_clique_space_def
        size_CNF_SAT_def number_clauses_CNF_SAT_def max_size_clauses_def card_E3 card_V)

lemma cnf_sat_to_clique_refines:
  "cnf_sat_to_clique_alg F \<le>
   SPEC (\<lambda>y. y = cnf_sat_to_clique F) (\<lambda>_. cnf_sat_to_clique_time (size_CNF_SAT F))"
  unfolding SPEC_def cnf_sat_to_clique_alg_def cnf_sat_to_clique_def
    mop_list_length_def mop_set_empty_set_def add_edges_cstc_def
    add_nodes_cstc_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: T_SPEC )
  by(auto simp: cnf_sat_to_clique_time_def number_clauses_CNF_SAT_def
      max_size_clauses_def one_enat_def size_CNF_SAT_def)

theorem cnf_sat_to_clique_ispolyred:
  "ispolyred cnf_sat_to_clique_alg cnf_sat clique size_CNF_SAT size_Clique"
  unfolding ispolyred_def
  apply(rule exI[where x=cnf_sat_to_clique])
  apply(rule exI[where x=cnf_sat_to_clique_time])
  apply(rule exI[where x=cnf_sat_to_clique_space])
  apply(safe)
  subgoal using cnf_sat_to_clique_refines by blast
  subgoal using cnf_sat_to_clique_size  by blast
  subgoal unfolding poly_def cnf_sat_to_clique_time_def apply(rule exI[where x=2]) by auto
  subgoal unfolding poly_def cnf_sat_to_clique_space_def apply(rule exI[where x=2]) by auto
  subgoal using is_reduction_cnf_sat_to_clique .
  done

end