(*  Title:      HOL/Algebra/Congruence.thy
    Author:     Clemens Ballarin, started 3 January 2008
    with thanks to Paulo Emílio de Vilhena
*)

theory Congruence
  imports
    Main
    "HOL-Library.FuncSet"
begin

section \<open>Objects\<close>

subsection \<open>Structure with Carrier Set.\<close>

record 'a partial_object =
  carrier :: "'a set"

lemma funcset_carrier:
  "\<lbrakk> f \<in> carrier X \<rightarrow> carrier Y; x \<in> carrier X \<rbrakk> \<Longrightarrow> f x \<in> carrier Y"
  by (fact funcset_mem)

lemma funcset_carrier':
  "\<lbrakk> f \<in> carrier A \<rightarrow> carrier A; x \<in> carrier A \<rbrakk> \<Longrightarrow> f x \<in> carrier A"
  by (fact funcset_mem)

subsection \<open>Structure with Carrier and Equivalence Relation \<open>eq\<close>\<close>

record 'a eq_object = "'a partial_object" +
  eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl ".=\<index>" 50)

definition
  elem :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> bool" (infixl ".\<in>\<index>" 50)
  where "x .\<in>\<^bsub>S\<^esub> A \<longleftrightarrow> (\<exists>y \<in> A. x .=\<^bsub>S\<^esub> y)"

definition
  set_eq :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "{.=}\<index>" 50)
  where "A {.=}\<^bsub>S\<^esub> B \<longleftrightarrow> ((\<forall>x \<in> A. x .\<in>\<^bsub>S\<^esub> B) \<and> (\<forall>x \<in> B. x .\<in>\<^bsub>S\<^esub> A))"

definition
  eq_class_of :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set" ("class'_of\<index>")
  where "class_of\<^bsub>S\<^esub> x = {y \<in> carrier S. x .=\<^bsub>S\<^esub> y}"

definition
  eq_classes :: "_ \<Rightarrow> ('a set) set" ("classes\<index>")
  where "classes\<^bsub>S\<^esub> = {class_of\<^bsub>S\<^esub> x | x. x \<in> carrier S}"

definition
  eq_closure_of :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set" ("closure'_of\<index>")
  where "closure_of\<^bsub>S\<^esub> A = {y \<in> carrier S. y .\<in>\<^bsub>S\<^esub> A}"

definition
  eq_is_closed :: "_ \<Rightarrow> 'a set \<Rightarrow> bool" ("is'_closed\<index>")
  where "is_closed\<^bsub>S\<^esub> A \<longleftrightarrow> A \<subseteq> carrier S \<and> closure_of\<^bsub>S\<^esub> A = A"

abbreviation
  not_eq :: "_ \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl ".\<noteq>\<index>" 50)
  where "x .\<noteq>\<^bsub>S\<^esub> y \<equiv> \<not>(x .=\<^bsub>S\<^esub> y)"

abbreviation
  not_elem :: "_ \<Rightarrow> 'a \<Rightarrow> 'a set \<Rightarrow> bool" (infixl ".\<notin>\<index>" 50)
  where "x .\<notin>\<^bsub>S\<^esub> A \<equiv> \<not>(x .\<in>\<^bsub>S\<^esub> A)"

abbreviation
  set_not_eq :: "_ \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "{.\<noteq>}\<index>" 50)
  where "A {.\<noteq>}\<^bsub>S\<^esub> B \<equiv> \<not>(A {.=}\<^bsub>S\<^esub> B)"

locale equivalence =
  fixes S (structure)
  assumes refl [simp, intro]: "x \<in> carrier S \<Longrightarrow> x .= x"
    and sym [sym]: "\<lbrakk> x .= y; x \<in> carrier S; y \<in> carrier S \<rbrakk> \<Longrightarrow> y .= x"
    and trans [trans]:
      "\<lbrakk> x .= y; y .= z; x \<in> carrier S; y \<in> carrier S; z \<in> carrier S \<rbrakk> \<Longrightarrow> x .= z"

lemma equivalenceI:
  fixes P :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and E :: "'a set"
  assumes refl: "\<And>x.     \<lbrakk> x \<in> E \<rbrakk> \<Longrightarrow> P x x"
    and    sym: "\<And>x y.   \<lbrakk> x \<in> E; y \<in> E \<rbrakk> \<Longrightarrow> P x y \<Longrightarrow> P y x"
    and  trans: "\<And>x y z. \<lbrakk> x \<in> E; y \<in> E; z \<in> E \<rbrakk> \<Longrightarrow> P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
  shows "equivalence \<lparr> carrier = E, eq = P \<rparr>"
  unfolding equivalence_def using assms
  by (metis eq_object.select_convs(1) partial_object.select_convs(1))

locale partition =
  fixes A :: "'a set" and B :: "('a set) set"
  assumes unique_class: "\<And>a. a \<in> A \<Longrightarrow> \<exists>!b \<in> B. a \<in> b"
    and incl: "\<And>b. b \<in> B \<Longrightarrow> b \<subseteq> A"

lemma equivalence_subset:
  assumes "equivalence L" "A \<subseteq> carrier L"
  shows "equivalence (L\<lparr> carrier := A \<rparr>)"
proof -
  interpret L: equivalence L
    by (simp add: assms)
  show ?thesis
    by (unfold_locales, simp_all add: L.sym assms rev_subsetD, meson L.trans assms(2) contra_subsetD)
qed

(* Lemmas by Stephan Hohe *)

lemma elemI:
  fixes R (structure)
  assumes "a' \<in> A" "a .= a'"
  shows "a .\<in> A"
  unfolding elem_def using assms by auto

lemma (in equivalence) elem_exact:
  assumes "a \<in> carrier S" "a \<in> A"
  shows "a .\<in> A"
  unfolding elem_def using assms by auto

lemma elemE:
  fixes S (structure)
  assumes "a .\<in> A"
    and "\<And>a'. \<lbrakk>a' \<in> A; a .= a'\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms unfolding elem_def by auto

lemma (in equivalence) elem_cong_l [trans]:
  assumes "a \<in> carrier S"  "a' \<in> carrier S" "A \<subseteq> carrier S"
    and "a' .= a" "a .\<in> A"
  shows "a' .\<in> A"
  using assms by (meson elem_def trans subsetCE)

lemma (in equivalence) elem_subsetD:
  assumes "A \<subseteq> B" "a .\<in> A"
  shows "a .\<in> B"
  using assms by (fast intro: elemI elim: elemE dest: subsetD)

lemma (in equivalence) mem_imp_elem [simp, intro]:
  assumes "x \<in> carrier S"
  shows "x \<in> A \<Longrightarrow> x .\<in> A"
  using assms unfolding elem_def by blast

lemma set_eqI:
  fixes R (structure)
  assumes "\<And>a. a \<in> A \<Longrightarrow> a .\<in> B"
    and   "\<And>b. b \<in> B \<Longrightarrow> b .\<in> A"
  shows "A {.=} B"
  using assms unfolding set_eq_def by auto

lemma set_eqI2:
  fixes R (structure)
  assumes "\<And>a. a \<in> A \<Longrightarrow> \<exists>b \<in> B. a .= b"
    and   "\<And>b. b \<in> B \<Longrightarrow> \<exists>a \<in> A. b .= a"
  shows "A {.=} B"
  using assms by (simp add: set_eqI elem_def)

lemma set_eqD1:
  fixes R (structure)
  assumes "A {.=} A'" and "a \<in> A"
  shows "\<exists>a'\<in>A'. a .= a'"
  using assms by (simp add: set_eq_def elem_def)

lemma set_eqD2:
  fixes R (structure)
  assumes "A {.=} A'" and "a' \<in> A'"
  shows "\<exists>a\<in>A. a' .= a"
  using assms by (simp add: set_eq_def elem_def)

lemma set_eqE:
  fixes R (structure)
  assumes "A {.=} B"
    and "\<lbrakk> \<forall>a \<in> A. a .\<in> B; \<forall>b \<in> B. b .\<in> A \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms unfolding set_eq_def by blast

lemma set_eqE2:
  fixes R (structure)
  assumes "A {.=} B"
    and "\<lbrakk> \<forall>a \<in> A. \<exists>b \<in> B. a .= b; \<forall>b \<in> B. \<exists>a \<in> A. b .= a \<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms unfolding set_eq_def by (simp add: elem_def)

lemma set_eqE':
  fixes R (structure)
  assumes "A {.=} B" "a \<in> A" "b \<in> B"
    and "\<And>a' b'. \<lbrakk> a' \<in> A; b' \<in> B \<rbrakk> \<Longrightarrow> b .= a' \<Longrightarrow>  a .= b' \<Longrightarrow> P"
  shows "P"
  using assms by (meson set_eqE2)

lemma (in equivalence) eq_elem_cong_r [trans]:
  assumes "A \<subseteq> carrier S" "A' \<subseteq> carrier S" "A {.=} A'"
  shows "\<lbrakk> a \<in> carrier S \<rbrakk> \<Longrightarrow> a .\<in> A \<Longrightarrow> a .\<in> A'"
  using assms by (meson elemE elem_cong_l set_eqE subset_eq)

lemma (in equivalence) set_eq_sym [sym]:
  assumes "A \<subseteq> carrier S" "B \<subseteq> carrier S"
  shows "A {.=} B \<Longrightarrow> B {.=} A"
  using assms unfolding set_eq_def elem_def by auto

lemma (in equivalence) equal_set_eq_trans [trans]:
  "\<lbrakk> A = B; B {.=} C \<rbrakk> \<Longrightarrow> A {.=} C"
  by simp

lemma (in equivalence) set_eq_equal_trans [trans]:
  "\<lbrakk> A {.=} B; B = C \<rbrakk> \<Longrightarrow> A {.=} C"
  by simp

lemma (in equivalence) set_eq_trans_aux:
  assumes "A \<subseteq> carrier S" "B \<subseteq> carrier S" "C \<subseteq> carrier S"
    and "A {.=} B" "B {.=} C"
  shows "\<And>a. a \<in> A \<Longrightarrow> a .\<in> C"
  using assms by (simp add: eq_elem_cong_r subset_iff)

corollary (in equivalence) set_eq_trans [trans]:
  assumes "A \<subseteq> carrier S" "B \<subseteq> carrier S" "C \<subseteq> carrier S"
    and "A {.=} B" " B {.=} C"
  shows "A {.=} C"
proof (intro set_eqI)
  show "\<And>a. a \<in> A \<Longrightarrow> a .\<in> C" using set_eq_trans_aux assms by blast
next
  show "\<And>b. b \<in> C \<Longrightarrow> b .\<in> A" using set_eq_trans_aux set_eq_sym assms by blast
qed

lemma (in equivalence) is_closedI:
  assumes closed: "\<And>x y. \<lbrakk>x .= y; x \<in> A; y \<in> carrier S\<rbrakk> \<Longrightarrow> y \<in> A"
    and S: "A \<subseteq> carrier S"
  shows "is_closed A"
  unfolding eq_is_closed_def eq_closure_of_def elem_def
  using S
  by (blast dest: closed sym)

lemma (in equivalence) closure_of_eq:
  assumes "A \<subseteq> carrier S" "x \<in> closure_of A"
  shows "\<lbrakk> x' \<in> carrier S; x .= x' \<rbrakk> \<Longrightarrow> x' \<in> closure_of A"
  using assms elem_cong_l sym unfolding eq_closure_of_def by blast

lemma (in equivalence) is_closed_eq [dest]:
  assumes "is_closed A" "x \<in> A"
  shows "\<lbrakk> x .= x'; x' \<in> carrier S \<rbrakk> \<Longrightarrow> x' \<in> A"
  using assms closure_of_eq [where A = A] unfolding eq_is_closed_def by simp

corollary (in equivalence) is_closed_eq_rev [dest]:
  assumes "is_closed A" "x' \<in> A"
  shows "\<lbrakk> x .= x'; x \<in> carrier S \<rbrakk> \<Longrightarrow> x \<in> A"
  using sym is_closed_eq assms by (meson contra_subsetD eq_is_closed_def)

lemma closure_of_closed [simp, intro]:
  fixes S (structure)
  shows "closure_of A \<subseteq> carrier S"
  unfolding eq_closure_of_def by auto

lemma closure_of_memI:
  fixes S (structure)
  assumes "a .\<in> A" "a \<in> carrier S"
  shows "a \<in> closure_of A"
  by (simp add: assms eq_closure_of_def)

lemma closure_ofI2:
  fixes S (structure)
  assumes "a .= a'" and "a' \<in> A" and "a \<in> carrier S"
  shows "a \<in> closure_of A"
  by (meson assms closure_of_memI elem_def)

lemma closure_of_memE:
  fixes S (structure)
  assumes "a \<in> closure_of A"
    and "\<lbrakk>a \<in> carrier S; a .\<in> A\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using eq_closure_of_def assms by fastforce

lemma closure_ofE2:
  fixes S (structure)
  assumes "a \<in> closure_of A"
    and "\<And>a'. \<lbrakk>a \<in> carrier S; a' \<in> A; a .= a'\<rbrakk> \<Longrightarrow> P"
  shows "P"
  using assms by (meson closure_of_memE elemE)

lemma (in partition) equivalence_from_partition: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  "equivalence \<lparr> carrier = A, eq = (\<lambda>x y. y \<in> (THE b. b \<in> B \<and> x \<in> b))\<rparr>"
    unfolding partition_def equivalence_def
proof (auto)
  let ?f = "\<lambda>x. THE b. b \<in> B \<and> x \<in> b"
  show "\<And>x. x \<in> A \<Longrightarrow> x \<in> ?f x"
    using unique_class by (metis (mono_tags, lifting) theI')
  show "\<And>x y. \<lbrakk> x \<in> A; y \<in> A \<rbrakk> \<Longrightarrow> y \<in> ?f x \<Longrightarrow> x \<in> ?f y"
    using unique_class by (metis (mono_tags, lifting) the_equality)
  show "\<And>x y z. \<lbrakk> x \<in> A; y \<in> A; z \<in> A \<rbrakk> \<Longrightarrow> y \<in> ?f x \<Longrightarrow> z \<in> ?f y \<Longrightarrow> z \<in> ?f x"
    using unique_class by (metis (mono_tags, lifting) the_equality)
qed

lemma (in partition) partition_coverture: "\<Union>B = A" \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  by (meson Sup_le_iff UnionI unique_class incl subsetI subset_antisym)

lemma (in partition) disjoint_union: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "b1 \<in> B" "b2 \<in> B"
    and "b1 \<inter> b2 \<noteq> {}"
  shows "b1 = b2"
proof (rule ccontr)
  assume "b1 \<noteq> b2"
  obtain a where "a \<in> A" "a \<in> b1" "a \<in> b2"
    using assms(2-3) incl by blast
  thus False using unique_class \<open>b1 \<noteq> b2\<close> assms(1) assms(2) by blast
qed

lemma partitionI: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  fixes A :: "'a set" and B :: "('a set) set"
  assumes "\<Union>B = A"
    and "\<And>b1 b2. \<lbrakk> b1 \<in> B; b2 \<in> B \<rbrakk> \<Longrightarrow> b1 \<inter> b2 \<noteq> {} \<Longrightarrow> b1 = b2"
  shows "partition A B"
proof
  show "\<And>a. a \<in> A \<Longrightarrow> \<exists>!b. b \<in> B \<and> a \<in> b"
  proof (rule ccontr)
    fix a assume "a \<in> A" "\<nexists>!b. b \<in> B \<and> a \<in> b"
    then obtain b1 b2 where "b1 \<in> B" "a \<in> b1"
                        and "b2 \<in> B" "a \<in> b2" "b1 \<noteq> b2" using assms(1) by blast
    thus False using assms(2) by blast
  qed
next
  show "\<And>b. b \<in> B \<Longrightarrow> b \<subseteq> A" using assms(1) by blast
qed

lemma (in partition) remove_elem: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "b \<in> B"
  shows "partition (A - b) (B - {b})"
proof
  show "\<And>a. a \<in> A - b \<Longrightarrow> \<exists>!b'. b' \<in> B - {b} \<and> a \<in> b'"
    using unique_class by fastforce
next
  show "\<And>b'. b' \<in> B - {b} \<Longrightarrow> b' \<subseteq> A - b"
    using assms unique_class incl partition_axioms partition_coverture by fastforce
qed

lemma disjoint_sum: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  "\<lbrakk> finite B; finite A; partition A B\<rbrakk> \<Longrightarrow> (\<Sum>b\<in>B. \<Sum>a\<in>b. f a) = (\<Sum>a\<in>A. f a)"
proof (induct arbitrary: A set: finite)
  case empty thus ?case using partition.unique_class by fastforce
next
  case (insert b B')
  have "(\<Sum>b\<in>(insert b B'). \<Sum>a\<in>b. f a) = (\<Sum>a\<in>b. f a) + (\<Sum>b\<in>B'. \<Sum>a\<in>b. f a)"
    by (simp add: insert.hyps(1) insert.hyps(2))
  also have "... = (\<Sum>a\<in>b. f a) + (\<Sum>a\<in>(A - b). f a)"
    using partition.remove_elem[of A "insert b B'" b] insert.hyps insert.prems
    by (metis Diff_insert_absorb finite_Diff insert_iff)
  finally show "(\<Sum>b\<in>(insert b B'). \<Sum>a\<in>b. f a) = (\<Sum>a\<in>A. f a)"
    using partition.remove_elem[of A "insert b B'" b] insert.prems
    by (metis add.commute insert_iff partition.incl sum.subset_diff)
qed

lemma (in partition) disjoint_sum: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "finite A"
  shows "(\<Sum>b\<in>B. \<Sum>a\<in>b. f a) = (\<Sum>a\<in>A. f a)"
proof -
  have "finite B"
    by (simp add: assms finite_UnionD partition_coverture)
  thus ?thesis using disjoint_sum assms partition_axioms by blast
qed

lemma (in equivalence) set_eq_insert_aux: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "A \<subseteq> carrier S"
    and "x \<in> carrier S" "x' \<in> carrier S" "x .= x'"
    and "y \<in> insert x A"
  shows "y .\<in> insert x' A"
  by (metis assms(1) assms(4) assms(5) contra_subsetD elemI elem_exact insert_iff)

corollary (in equivalence) set_eq_insert: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes "A \<subseteq> carrier S"
    and "x \<in> carrier S" "x' \<in> carrier S" "x .= x'"
  shows "insert x A {.=} insert x' A"
  by (meson set_eqI assms set_eq_insert_aux sym equivalence_axioms)

lemma (in equivalence) set_eq_pairI: \<^marker>\<open>contributor \<open>Paulo Emílio de Vilhena\<close>\<close>
  assumes xx': "x .= x'"
    and carr: "x \<in> carrier S" "x' \<in> carrier S" "y \<in> carrier S"
  shows "{x, y} {.=} {x', y}"
  using assms set_eq_insert by simp

lemma (in equivalence) closure_inclusion:
  assumes "A \<subseteq> B"
  shows "closure_of A \<subseteq> closure_of B"
  unfolding eq_closure_of_def using assms elem_subsetD by auto

lemma (in equivalence) classes_small:
  assumes "is_closed B"
    and "A \<subseteq> B"
  shows "closure_of A \<subseteq> B"
  by (metis assms closure_inclusion eq_is_closed_def)

lemma (in equivalence) classes_eq:
  assumes "A \<subseteq> carrier S"
  shows "A {.=} closure_of A"
  using assms by (blast intro: set_eqI elem_exact closure_of_memI elim: closure_of_memE)

lemma (in equivalence) complete_classes:
  assumes "is_closed A"
  shows "A = closure_of A"
  using assms by (simp add: eq_is_closed_def)

lemma (in equivalence) closure_idem_weak:
  "closure_of (closure_of A) {.=} closure_of A"
  by (simp add: classes_eq set_eq_sym)

lemma (in equivalence) closure_idem_strong:
  assumes "A \<subseteq> carrier S"
  shows "closure_of (closure_of A) = closure_of A"
  using assms closure_of_eq complete_classes is_closedI by auto

lemma (in equivalence) classes_consistent:
  assumes "A \<subseteq> carrier S"
  shows "is_closed (closure_of A)"
  using closure_idem_strong by (simp add: assms eq_is_closed_def)

lemma (in equivalence) classes_coverture:
  "\<Union>classes = carrier S"
proof
  show "\<Union>classes \<subseteq> carrier S"
    unfolding eq_classes_def eq_class_of_def by blast
next
  show "carrier S \<subseteq> \<Union>classes" unfolding eq_classes_def eq_class_of_def
  proof
    fix x assume "x \<in> carrier S"
    hence "x \<in> {y \<in> carrier S. x .= y}" using refl by simp
    thus "x \<in> \<Union>{{y \<in> carrier S. x .= y} |x. x \<in> carrier S}" by blast
  qed
qed

lemma (in equivalence) disjoint_union:
  assumes "class1 \<in> classes" "class2 \<in> classes"
    and "class1 \<inter> class2 \<noteq> {}"
    shows "class1 = class2"
proof -
  obtain x y where x: "x \<in> carrier S" "class1 = class_of x"
               and y: "y \<in> carrier S" "class2 = class_of y"
    using assms(1-2) unfolding eq_classes_def by blast
  obtain z   where z: "z \<in> carrier S" "z \<in> class1 \<inter> class2"
    using assms classes_coverture by fastforce
  hence "x .= z \<and> y .= z" using x y unfolding eq_class_of_def by blast
  hence "x .= y" using x y z trans sym by meson
  hence "class_of x = class_of y"
    unfolding eq_class_of_def using local.sym trans x y by blast
  thus ?thesis using x y by simp
qed

lemma (in equivalence) partition_from_equivalence:
  "partition (carrier S) classes"
proof (intro partitionI)
  show "\<Union>classes = carrier S" using classes_coverture by simp
next
  show "\<And>class1 class2. \<lbrakk> class1 \<in> classes; class2 \<in> classes \<rbrakk> \<Longrightarrow>
                          class1 \<inter> class2 \<noteq> {} \<Longrightarrow> class1 = class2"
    using disjoint_union by simp
qed

lemma (in equivalence) disjoint_sum:
  assumes "finite (carrier S)"
  shows "(\<Sum>c\<in>classes. \<Sum>x\<in>c. f x) = (\<Sum>x\<in>(carrier S). f x)"
proof -
  have "finite classes"
    unfolding eq_classes_def using assms by auto
  thus ?thesis using disjoint_sum assms partition_from_equivalence by blast
qed

end


subsection \<open>IMO 2018 SL - C4\<close>

theory IMO_2018_SL_C4
  imports Main "HOL-Library.Permutation"
begin

definition antipascal :: "(nat \<Rightarrow> nat \<Rightarrow> int) \<Rightarrow> nat \<Rightarrow> bool" where
   "antipascal f n \<longleftrightarrow> (\<forall> r < n. \<forall> c \<le> r. f r c = abs (f (r+1) c - f (r+1) (c+1)))"

definition triangle :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) set" where
  "triangle r0 c0 n = {(r, c) | r c :: nat. r0 \<le> r \<and> r < r0 + n \<and> c0 \<le> c \<and> c \<le> c0 + r - r0}"
(*
lemma triangle_finite [simp]:
  shows "finite (triangle r0 c0 n)"
  sorry

lemma triangle_card:
  shows "card (triangle r0 c0 n) = n * (n+1) div 2"
  sorry
*)
fun uncurry where
   "uncurry f (a, b) = f a b"
(*
lemma gauss:
  fixes n :: nat
  shows "sum_list [1..<n] = n * (n - 1) div 2"
  sorry

lemma sum_list_insort [simp]:
  fixes x :: nat and xs :: "nat list"
  shows "sum_list (insort x xs) = x + sum_list xs"
  sorry

lemma sum_list_sort [simp]:
  fixes xs :: "nat list"
  shows "sum_list (sort xs) = sum_list xs"
  sorry

lemma sorted_distinct_strict_increase:
  assumes "sorted (xs @ [x])" "distinct (xs @ [x])" "\<forall> x \<in> set (xs @ [x]). x > a"
  shows "x > a + length xs"
  sorry

lemma sum_list_sorted_distinct_lb:
  assumes "\<forall> x \<in> set xs. x > a" "distinct xs" "sorted xs"
  shows "sum_list xs \<ge> length xs * (2 * a + length xs + 1) div 2"
  sorry

lemma sum_list_distinct_lb:
  assumes "\<forall> x \<in> set xs. f x > a" "distinct (map f xs)"
  shows "(\<Sum> x \<leftarrow> xs. f x) \<ge> length xs * (2 * a + length xs + 1) div 2"
  sorry

lemma consecutive_nats_sorted:
  assumes "sorted xs" "length xs = n" "distinct xs" "sum_list xs \<le> n * (n + 1) div 2" "\<forall> x \<in> set xs. x > 0"
  shows "xs = [1..<n+1]"
  sorry

lemma consecutive_nats:
  assumes "length xs = n" "distinct xs" "sum_list xs \<le> n * (n + 1) div 2" "\<forall> x \<in> set xs. x > 0"
  shows "set xs = {1..<n+1}"
  sorry

lemma sum_list_cong:
  assumes "\<forall> x \<in> set xs. f x = g x"
  shows "(\<Sum> x \<leftarrow> xs. f x) = (\<Sum> x \<leftarrow> xs. g x)"
  sorry

lemma sum_list_last:
  assumes "a \<le> b"
  shows "(\<Sum> x \<leftarrow> [a..<b+1]. f x) = (\<Sum> x \<leftarrow> [a..<b]. f x) + f b"
  sorry

lemma sum_list_nat:
  assumes "\<forall> x \<in> set xs. f x \<ge> 0"
  shows "(\<Sum> x \<leftarrow> xs. nat (f x)) = (nat (\<Sum> x \<leftarrow> xs. f x))"
  using assms
  sorry
*)
theorem IMO2018SL_C4:
  "\<nexists> f. antipascal f 2018 \<and>
   (uncurry f) ` triangle 0 0 2018  = {1..<2018*(2018 + 1) div 2 + 1}"
  sorry

end


theory HSemUpd
  imports "HeapToEnv" "DistinctVars-Nominal"  "HOLCF-Fix-Join-Nominal" "FMap-Utils"
begin

subsubsection {* A locale for heap semantics, abstract in the expression semantics *}

text {*
This theory follows closely the theory @{text HSem}, but uses right-sided updates of envrionments
instead of least upper bounds.
*}

locale has_ESem =
  fixes ESem :: "'exp::pt \<Rightarrow> 'var::{cont_pt,at_base} f\<rightharpoonup> 'value \<Rightarrow> 'value::{pure_cpo,Nonempty_Meet_cpo,pcpo}" ("\<lbrakk> _ \<rbrakk>\<^bsub>_\<^esub>"  [60,60] 60)
begin

definition HSem :: "('var \<times> 'exp) list \<Rightarrow> 'var f\<rightharpoonup> 'value \<Rightarrow> 'var f\<rightharpoonup> 'value" ("\<lbrace>_\<rbrace>_"  [60,60] 60)
  where
  "\<lbrace>h\<rbrace>\<rho> =
    (if (\<forall> e \<in> snd `set h. cont (ESem e))
     then  fix_on' (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. \<rho> f++ heapToEnv h (\<lambda> e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))
     else (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>))"

lemma HSem_def'':
  assumes "\<And> e. e \<in> snd ` set h \<Longrightarrow> cont (ESem e)"
  shows "\<lbrace>h\<rbrace>\<rho> = fix_on' (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. \<rho> f++ heapToEnv h (\<lambda> e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))"
  unfolding HSem_def using assms by metis

lemma fix_on_cond_HSem':
  assumes cont: "\<And> e. e \<in> snd ` set h \<Longrightarrow> cont (ESem e)"
  shows "fix_on_cond {x. f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<sqsubseteq> x}
          (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda>\<rho>'. \<rho> f++ heapToEnv h (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))"
  apply (rule fix_on_condI)
  apply (rule subpcpo_cone_above)
  apply (rule bottom_of_cone_above)
  apply (rule closed_onI, simp)
  apply (rule cont_onI)
  apply (rule contE[OF fmap_add_cont2cont[OF cont_const cont2cont_heapToEnv[OF assms]] chain_on_is_chain])
    apply assumption+
  done

subsubsection {* Continuity *}

lemma HSem_monofun'':
  assumes cont: "\<And> e. e \<in> snd ` set h \<Longrightarrow> cont (ESem e)"
  assumes "\<rho> \<sqsubseteq> \<rho>'"
  shows "\<lbrace>h\<rbrace>\<rho> \<sqsubseteq> \<lbrace>h\<rbrace>\<rho>'"
  apply (subst (1 2) HSem_def'')
  apply (erule cont)
  apply (rule fix_on_mono2[OF fix_on_cond_HSem'[OF cont] fix_on_cond_HSem'[OF cont]])
    apply assumption+
  apply (metis assms(2) below.r_refl fmap_below_dom)
  apply (rule fmap_add_mono[OF `\<rho> \<sqsubseteq> \<rho>'`])
  by (rule cont2monofunE[OF cont2cont_heapToEnv[OF cont]])

lemma HSem_cont'':
  assumes cont: "\<And> e. e \<in> snd ` set h \<Longrightarrow> cont (ESem e)"
  assumes "chain Y"
  shows "\<lbrace>h\<rbrace>(\<Squnion> i. Y  i) = (\<Squnion> i. \<lbrace>h\<rbrace>(Y i))"
proof-
  have fdoms:"\<And> i. fdom (Y i) = fdom (\<Squnion> i. Y i)" (is "\<And> _ .(_ = ?d)") by (metis chain_fdom `chain Y`)
  show ?thesis
    apply (subst (1 2) HSem_def'')
    apply (erule cont)+
    unfolding fdoms
    proof (rule fix_on_cont[OF `chain Y`, where S = "{x . f\<emptyset>\<^bsub>[fdom (\<Squnion> i. Y i) \<union> heapVars h]\<^esub> \<sqsubseteq> x}"])
      show "cont (\<lambda>a b. a f++ heapToEnv h (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>b\<^esub>))"
        by (rule cont2cont_lambda[OF fmap_add_cont1])
      fix i
        from fix_on_cond_HSem'[OF cont, where \<rho> = "Y i", unfolded fdoms]
        show "fix_on_cond {x. f\<emptyset>\<^bsub>[fdom (\<Squnion> i. Y i) \<union> heapVars h]\<^esub> \<sqsubseteq> x}
               (f\<emptyset>\<^bsub>[fdom (Lub Y) \<union> heapVars h]\<^esub>) (\<lambda>a. Y i f++ heapToEnv h (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>a\<^esub>))"
           by metis
    qed
qed
end

locale has_cont_ESem = has_ESem +
  assumes ESem_cont: "\<And> e. cont (ESem e)"
begin

  lemma HSem_def':
    shows "\<lbrace>h\<rbrace>\<rho> = fix_on' (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda> \<rho>'. \<rho> f++ heapToEnv h (\<lambda> e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))"
    unfolding HSem_def using ESem_cont by metis

  lemma fix_on_cond_HSem:
    shows "fix_on_cond {x. f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub> \<sqsubseteq> x}
            (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (\<lambda>\<rho>'. \<rho> f++ heapToEnv h (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))"
    apply (rule fix_on_cond_HSem') using ESem_cont by metis

subsubsection {* Induction and other lemmas about @{term HSem} *}

  lemma HSem_ind:
    assumes "adm P"
    assumes "P (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>)"
    assumes step: "\<And> y. fdom y = fdom \<rho> \<union> heapVars h \<Longrightarrow>
          P y \<Longrightarrow>  P (\<rho> f++ (heapToEnv h (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>y\<^esub>)))"
    shows "P (\<lbrace>h\<rbrace>\<rho>)"
    unfolding HSem_def'
    apply (rule fix_on_ind[OF fix_on_cond_HSem])
    apply (rule adm_is_adm_on[OF `adm P`])
    apply fact
    apply (rule step)
    apply simp
    apply assumption
    done

  lemma parallel_HSem_ind:
    assumes "adm (\<lambda>\<rho>'. P (fst \<rho>') (snd \<rho>'))"
    assumes "P (f\<emptyset>\<^bsub>[fdom \<rho> \<union> heapVars h]\<^esub>) (f\<emptyset>\<^bsub>[fdom \<rho>2 \<union> heapVars h2]\<^esub>)"
    assumes step: "\<And>y z. fdom y = fdom \<rho> \<union> heapVars h \<Longrightarrow>
            fdom z = fdom \<rho>2 \<union> heapVars h2 \<Longrightarrow>
            P y z \<Longrightarrow>
            P (\<rho> f++ (heapToEnv h (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>y\<^esub>))) (\<rho>2 f++ (heapToEnv h2 (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>z\<^esub>)))"
    shows "P (\<lbrace>h\<rbrace>\<rho>) (\<lbrace>h2\<rbrace>\<rho>2)"
    unfolding HSem_def'
    apply (rule parallel_fix_on_ind[OF fix_on_cond_HSem fix_on_cond_HSem])
    apply (rule adm_is_adm_on[OF `adm _`])
    apply fact
    apply (rule step)
    apply simp+
    done

  lemma HSem_eq:
    shows "\<lbrace>h\<rbrace>\<rho> = \<rho> f++ (heapToEnv h (\<lambda>e. \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>h\<rbrace>\<rho>\<^esub>))"
    unfolding HSem_def'
    by (rule fix_on_eq[OF fix_on_cond_HSem])

  lemma the_lookup_HSem_other:
    assumes "y \<notin> heapVars h"
    shows "(\<lbrace>h\<rbrace>\<rho>) f! y = \<rho> f! y"
    apply (subst HSem_eq)
    using assms by simp

  lemma the_lookup_HSem_heap:
    assumes "y \<in> heapVars h"
    shows "(\<lbrace>h\<rbrace>\<rho>) f! y = \<lbrakk> the (map_of h y) \<rbrakk>\<^bsub>\<lbrace>h\<rbrace>\<rho>\<^esub>"
    apply (subst HSem_eq)
    using assms by (simp add: lookupHeapToEnv)

  lemma fdom_HSem[simp]:
    "fdom (\<lbrace>h\<rbrace>\<rho>) = fdom \<rho> \<union> heapVars h"
    by (subst HSem_eq, simp)

  lemma fmap_restr_fmap_addI:"finite S \<Longrightarrow> fdom \<rho>1 - fdom \<rho>2 \<subseteq> S \<Longrightarrow> fmap_restr S \<rho>1 f++ \<rho>2 = \<rho>1 f++ \<rho>2"
    apply (rule fmap_eqI)
    apply auto[1]
    apply auto
    by (metis lookup_fmap_add1 lookup_fmap_add2 lookup_fmap_restr)

  lemma HSem_restr:
    "\<lbrace>h\<rbrace>(fmap_restr (fdom \<rho> - heapVars h) \<rho>) = \<lbrace>h\<rbrace>\<rho>"
    apply (rule parallel_HSem_ind)
    apply simp
    apply auto
    apply (subst fmap_restr_fmap_addI)
    apply simp_all
    done

  lemma HSem_reorder:
    assumes "distinctVars \<Gamma>"
    assumes "distinctVars \<Delta>"
    assumes "set \<Gamma> = set \<Delta>"
    shows "\<lbrace>\<Gamma>\<rbrace>\<rho> = \<lbrace>\<Delta>\<rbrace>\<rho>"
  by (simp add: HSem_def' heapToEnv_reorder[OF assms] assms(3) heapVars_def)

  lemma HSem_reorder_head:
    assumes "x \<noteq> y"
    shows "\<lbrace>(x,e1)#(y,e2)#\<Gamma>\<rbrace>\<rho> = \<lbrace>(y,e2)#(x,e1)#\<Gamma>\<rbrace>\<rho>"
  proof-
    have "set ((x,e1)#(y,e2)#\<Gamma>) = set ((y,e2)#(x,e1)#\<Gamma>)"
      by auto
    thus ?thesis
      unfolding HSem_def  heapToEnv_reorder_head[OF assms]
      by (simp add: heapVars_def)
  qed

  lemma HSem_reorder_head_append:
    assumes "x \<notin> heapVars \<Gamma>"
    shows "\<lbrace>(x,e)#\<Gamma>@\<Delta>\<rbrace>\<rho> = \<lbrace>\<Gamma> @ ((x,e)#\<Delta>)\<rbrace>\<rho>"
  proof-
    have "set ((x,e)#\<Gamma>@\<Delta>) = set (\<Gamma> @ ((x,e)#\<Delta>))" by auto
    thus ?thesis
      unfolding HSem_def  heapToEnv_reorder_head_append[OF assms]
      by (simp add: )
  qed

  lemma fmap_restr_HSem_noop:
    assumes "heapVars \<Gamma> \<inter> fdom \<rho> = {}"
    shows "fmap_restr (fdom \<rho>) (\<lbrace>\<Gamma>\<rbrace>\<rho>) = \<rho>"
    apply (rule fmap_eqI)
    using assms apply auto[1]
    using assms apply auto[1]
    apply (subst the_lookup_HSem_other)
    apply auto
    done

  lemma HSem_disjoint_less:
    assumes "heapVars \<Gamma> \<inter> fdom \<rho> = {}"
    shows "\<rho> \<le> \<lbrace>\<Gamma>\<rbrace>\<rho>"
    using assms
  by (metis fmap_less_restrict fmap_restr_HSem_noop)

  lemma HSem_Nil[simp]: "\<lbrace>[]\<rbrace>\<rho> = \<rho>"
    by (subst HSem_eq, simp)

subsubsection {* Iterative definition of the heap semantics *}

  lemma iterative_HSem:
    assumes "x \<notin> heapVars \<Gamma>"
    shows "\<lbrace>(x,e) # \<Gamma>\<rbrace>\<rho> =
         fix_on' (f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub>)
            (\<lambda> \<rho>'. (\<rho> f++ fmap_restr (heapVars \<Gamma>) (\<lbrace>\<Gamma>\<rbrace>\<rho>'))( x f\<mapsto> \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))"
  proof-
    interpret iterative
      where e1 =  "\<lambda> \<rho>'. heapToEnv \<Gamma> (\<lambda> e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>)"
      and e2 = "\<lambda> \<rho>'. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>"
      and S = "heapVars \<Gamma>"
      and x = x
      and D =  "insert x (fdom \<rho> \<union> heapVars \<Gamma>) "
      apply -
      apply unfold_locales
      using assms
      by (simp_all add: ESem_cont)

    have "\<lbrace>(x,e) # \<Gamma>\<rbrace>\<rho> = fix_on' b L"
      by (simp add: HSem_def' fmap_add_upd)
    also have "\<dots> = fix_on' b R"
      by (rule iterative_fmap_add)
    also have "\<dots> = fix_on' (f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub>)
            (\<lambda> \<rho>'. (\<rho> f++ fmap_restr (heapVars \<Gamma>) (\<lbrace>\<Gamma>\<rbrace>\<rho>'))( x f\<mapsto> \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))"
      apply (rule fix_on_cong[OF condR])
      apply (simp add: HSem_def')
      apply (drule sym)
      by simp
    finally show ?thesis.
  qed

  lemma iterative_HSem'_cond:
    assumes "x \<notin> heapVars \<Gamma>"
    shows "fix_on_cond {\<rho>'. f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub> \<sqsubseteq> \<rho>'}
             (f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub>)
             (\<lambda> \<rho>'. (\<rho> f++ fmap_restr (heapVars \<Gamma>) (\<lbrace>\<Gamma>\<rbrace>\<rho>'))( x f\<mapsto> \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>'\<^esub>))"
  proof-
    interpret iterative
      where e1 =  "\<lambda> \<rho>'. heapToEnv \<Gamma> (\<lambda> e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>)"
      and e2 = "\<lambda> \<rho>'. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>"
      and S = "heapVars \<Gamma>"
      and x = x
      and D =  "insert x (fdom \<rho> \<union> heapVars \<Gamma>) "
      apply -
      apply unfold_locales
      using assms
      by (simp_all add: ESem_cont)

    show ?thesis
      apply (rule fix_on_cond_cong[OF condR'])
      apply (simp add: HSem_def')
      apply (drule sym)
      by simp
  qed

  lemma iterative_HSem':
    assumes "x \<notin> heapVars \<Gamma>"
    shows "fix_on' (f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub>)
            (\<lambda> \<rho>'. (\<rho> f++ fmap_restr (heapVars \<Gamma>) (\<lbrace>\<Gamma>\<rbrace>\<rho>'))( x f\<mapsto> \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>))
       = fix_on' (f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub>)
            (\<lambda> \<rho>'. (\<rho> f++ fmap_restr (heapVars \<Gamma>) (\<lbrace>\<Gamma>\<rbrace>\<rho>'))( x f\<mapsto> \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>'\<^esub>))"
  proof-
    interpret iterative
      where e1 =  "\<lambda> \<rho>'. heapToEnv \<Gamma> (\<lambda> e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>)"
      and e2 = "\<lambda> \<rho>'. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>"
      and S = "heapVars \<Gamma>"
      and x = x
      and D =  "insert x (fdom \<rho> \<union> heapVars \<Gamma>) "
      apply -
      apply unfold_locales
      using assms
      by (simp_all add: ESem_cont)

    have "fix_on' (f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub>)
            (\<lambda> \<rho>'. (\<rho> f++ fmap_restr (heapVars \<Gamma>) (\<lbrace>\<Gamma>\<rbrace>\<rho>'))( x f\<mapsto> \<lbrakk>e\<rbrakk>\<^bsub>\<rho>'\<^esub>)) =
          fix_on' b R"
      apply (rule fix_on_cong[symmetric, OF condR])
      apply (simp add: HSem_def')
      apply (drule sym)
      by simp
    also have "\<dots> = fix_on' b L"
      by (rule iterative_fmap_add[symmetric])
    also have "\<dots> = fix_on' b R'"
      by (rule iterative_fmap_add')
    also have "\<dots> = fix_on' (f\<emptyset>\<^bsub>[insert x (fdom \<rho> \<union> heapVars \<Gamma>)]\<^esub>)
            (\<lambda> \<rho>'. (\<rho> f++ fmap_restr (heapVars \<Gamma>) (\<lbrace>\<Gamma>\<rbrace>\<rho>'))( x f\<mapsto> \<lbrakk>e\<rbrakk>\<^bsub>\<lbrace>\<Gamma>\<rbrace>\<rho>'\<^esub>))"
      apply (rule fix_on_cong[OF condR'])
      apply (simp add: HSem_def')
      apply (drule sym)
      by simp
    finally
    show ?thesis.
  qed

end

lemma HSem_cong[fundef_cong]:
  "\<lbrakk> (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> ESem1 e = ESem2 e); env1 = env2 ; heap1 = heap2  \<rbrakk>
      \<Longrightarrow> has_ESem.HSem ESem1 heap1 env1 = has_ESem.HSem  ESem2 heap2 env2"
  unfolding has_ESem.HSem_def
  by (auto cong:heapToEnv_cong)

subsubsection {* Equivariance *}

lemma HSem_eqvt[eqvt]:
  "\<pi> \<bullet> has_ESem.HSem ESem h \<rho> = has_ESem.HSem (\<pi> \<bullet> ESem) (\<pi> \<bullet> h) (\<pi> \<bullet> \<rho>)"
proof(cases "\<forall> e \<in> snd ` set h.  cont (ESem e)")
case True
  from permute_boolI[OF this, where p = \<pi>]
  have True_permuted: "\<forall> e \<in> snd ` set (\<pi> \<bullet> h). cont ((\<pi> \<bullet> ESem) e)"
    by perm_simp

  show ?thesis
   unfolding has_ESem.HSem_def if_P[OF True]  if_P[OF True_permuted]
   apply (subst fix_on_eqvt[OF has_ESem.fix_on_cond_HSem'])
   apply (metis True)
   apply perm_simp
   apply rule
   done
next
case False
  from permute_boolI[OF this, where p = \<pi>]
  have False_permuted: "\<not> (\<forall> e \<in> snd ` set (\<pi> \<bullet> h). cont ((\<pi> \<bullet> ESem) e))"
    by perm_simp
  show ?thesis
   unfolding has_ESem.HSem_def if_not_P[OF False]  if_not_P[OF False_permuted]
   apply perm_simp
   apply rule
   done
qed
end


(* Author:     Andreas Lochbihler, ETH Zurich
   Author:     Joshua Schneider, ETH Zurich
*)

subsection \<open>Pointwise arithmetic on streams\<close>

theory Stream_Algebra
imports Applicative_Stream
begin

instantiation stream :: (zero) zero begin
definition [applicative_unfold]: "0 = sconst 0"
instance ..
end

instantiation stream :: (one) one begin
definition [applicative_unfold]: "1 = sconst 1"
instance ..
end

instantiation stream :: (plus) plus begin
interpretation applicative_syntax .
definition [applicative_unfold]: "x + y = pure op + \<diamondop> x \<diamondop> (y :: 'a stream)"
instance ..
end

instantiation stream :: (minus) minus begin
interpretation applicative_syntax .
definition [applicative_unfold]: "x - y = pure op - \<diamondop> x \<diamondop> (y :: 'a stream)"
instance ..
end

instantiation stream :: (uminus) uminus begin
interpretation applicative_syntax .
definition [applicative_unfold stream]: "uminus = (op \<diamondop> (pure uminus) :: 'a stream \<Rightarrow> 'a stream)"
instance ..
end

instantiation stream :: (times) times begin
interpretation applicative_syntax .
definition [applicative_unfold]: "x * y = pure op * \<diamondop> x \<diamondop> (y :: 'a stream)"
instance ..
end

instance stream :: (Rings.dvd) Rings.dvd ..

instantiation stream :: ("Divides.div") "Divides.div" begin
interpretation applicative_syntax .
definition [applicative_unfold]: "x div y = pure op div \<diamondop> x \<diamondop> (y :: 'a stream)"
definition [applicative_unfold]: "x mod y = pure op mod \<diamondop> x \<diamondop> (y :: 'a stream)"
instance ..
end

instance stream :: (semigroup_add) semigroup_add
using add.assoc by intro_classes applicative_lifting

instance stream :: (ab_semigroup_add) ab_semigroup_add
using add.commute by intro_classes applicative_lifting

instance stream :: (semigroup_mult) semigroup_mult
using mult.assoc by intro_classes applicative_lifting

instance stream :: (ab_semigroup_mult) ab_semigroup_mult
using mult.commute by intro_classes applicative_lifting

instance stream :: (monoid_add) monoid_add
by intro_classes (applicative_lifting, simp)+

instance stream :: (comm_monoid_add) comm_monoid_add
by intro_classes (applicative_lifting, simp)

instance stream :: (comm_monoid_diff) comm_monoid_diff
by intro_classes (applicative_lifting, simp add: diff_diff_add)+

instance stream :: (monoid_mult) monoid_mult
by intro_classes (applicative_lifting, simp)+

instance stream :: (comm_monoid_mult) comm_monoid_mult
by intro_classes (applicative_lifting, simp)

(*
  Lifted properties which are more complex than plain equations are not handled by the
  applicative lifting tool.
*)

lemma plus_stream_shd: "shd (x + y) = shd x + shd y"
unfolding plus_stream_def by simp

lemma plus_stream_stl: "stl (x + y) = stl x + stl y"
unfolding plus_stream_def by simp

instance stream :: (cancel_semigroup_add) cancel_semigroup_add
proof
  fix a b c :: "'a stream"
  assume "a + b = a + c"
  thus "b = c" proof (coinduction arbitrary: a b c)
    case (Eq_stream a b c)
    hence "shd (a + b) = shd (a + c)" "stl (a + b) = stl (a + c)" by simp_all
    thus ?case by (auto simp add: plus_stream_shd plus_stream_stl)
  qed
next
  fix a b c :: "'a stream"
  assume "b + a = c + a"
  thus "b = c" proof (coinduction arbitrary: a b c)
    case (Eq_stream a b c)
    hence "shd (b + a) = shd (c + a)" "stl (b + a) = stl (c + a)" by simp_all
    thus ?case by (auto simp add: plus_stream_shd plus_stream_stl)
  qed
qed

instance stream :: (cancel_ab_semigroup_add) cancel_ab_semigroup_add
by intro_classes (applicative_lifting, simp add: diff_diff_eq)+

instance stream :: (cancel_comm_monoid_add) cancel_comm_monoid_add ..

instance stream :: (group_add) group_add
by intro_classes (applicative_lifting, simp)+

instance stream :: (ab_group_add) ab_group_add
by intro_classes simp_all

instance stream :: (semiring) semiring
by intro_classes (applicative_lifting, simp add: ring_distribs)+

instance stream :: (mult_zero) mult_zero
by intro_classes (applicative_lifting, simp)+

instance stream :: (semiring_0) semiring_0 ..

instance stream :: (semiring_0_cancel) semiring_0_cancel ..

instance stream :: (comm_semiring) comm_semiring
by intro_classes(rule distrib_right)

instance stream :: (comm_semiring_0) comm_semiring_0 ..

instance stream :: (comm_semiring_0_cancel) comm_semiring_0_cancel ..

lemma pure_stream_inject [simp]: "sconst x = sconst y \<longleftrightarrow> x = y"
proof
  assume "sconst x = sconst y"
  hence "shd (sconst x) = shd (sconst y)" by simp
  thus "x = y" by simp
qed auto

instance stream :: (zero_neq_one) zero_neq_one
by intro_classes (applicative_unfold stream)

instance stream :: (semiring_1) semiring_1 ..

instance stream :: (comm_semiring_1) comm_semiring_1 ..

instance stream :: (semiring_1_cancel) semiring_1_cancel ..

instance stream :: (comm_semiring_1_cancel) comm_semiring_1_cancel
by(intro_classes; applicative_lifting, rule right_diff_distrib')

instance stream :: (ring) ring ..

instance stream :: (comm_ring) comm_ring ..

instance stream :: (ring_1) ring_1 ..

instance stream :: (comm_ring_1) comm_ring_1 ..

instance stream :: (numeral) numeral ..

instance stream :: (neg_numeral) neg_numeral ..

instance stream :: (semiring_numeral) semiring_numeral ..

lemma of_nat_stream [applicative_unfold]: "of_nat n = sconst (of_nat n)"
proof (induction n)
  case 0 show ?case by (simp add: zero_stream_def del: id_apply)
next
  case (Suc n)
  have "1 + pure (of_nat n) = pure (1 + of_nat n)" by applicative_nf rule
  with Suc.IH show ?case by (simp del: id_apply)
qed

instance stream :: (semiring_char_0) semiring_char_0
by intro_classes (simp add: inj_on_def of_nat_stream)

lemma pure_stream_numeral [applicative_unfold]: "numeral n = pure (numeral n)"
by(induction n)(simp_all only: numeral.simps one_stream_def plus_stream_def ap_stream_homo)

instance stream :: (ring_char_0) ring_char_0 ..

end


theory Intercala
imports Main
begin

section {* Ejemplo de función recursiva no primitiva recursiva *}

text {* (intercala x ys) es la lista obtenida intercalando x entre los
  elementos de ys. Por ejemplo,
     intercala a [x,y,z] = [x, a, y, a, z]" by simp
*}
fun intercala :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "intercala a []       = []"
| "intercala a [x]      = [x]"
| "intercala a (x#y#zs) = x # a # intercala a (y#zs)"

value "intercala a [x,y,z]"
lemma "intercala a [x,y,z] = [x, a, y, a, z]" by simp

end


(*<*)
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{HatfieldMilgrom:2005}: 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[\S4.2]{RothSotomayor:1990} for a discussion about the
impossibility of a mechanism being strategy-proof for all agents.)

\citet[{\S}III(B)]{HatfieldMilgrom:2005} 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[Lemma~1]{HatfieldKojima:2009} (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[Theorem~10]{HatfieldMilgrom:2005} (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[Theorem~11]{HatfieldMilgrom:2005} 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, hide_lams) 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[Theorem~12]{HatfieldMilgrom:2005}, which demonstrates
the almost-necessity of LAD for truth revelation to be the dominant
strategy for doctors.

\<close>

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

text \<open>

\citet[Theorem~7]{HatfieldKojima:2010} assert that the COP is group
strategy-proof, which we define below. We begin by focusing on a
single agent \citep{HatfieldKojima:2009}: \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{HatfieldKojima:2009,HatfieldKojima:2010}:
\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[\S3]{HatfieldKojima:2009} for discussion, and also
\citet[Chapter~4]{RothSotomayor:1990}; 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[Lemma~1, for a single
doctor]{HatfieldKojima:2010} 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[Corollary~2]{HatfieldKojima:2010} (respectively,
\citet[Corollary~1]{HatfieldKojima:2009}) 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[\S4.4]{RothSotomayor:1990} discuss how the non-proposing agents
can strategise to improve their outcomes in one-to-one matches.

\<close>
(*<*)

end
(*>*)


(*<*)
theory How_to_Prove_it
imports Complex_Main
begin
(*>*)
text\<open>
\chapter{\<^theory>\<open>Main\<close>}

\section{Natural numbers}

%Tobias Nipkow
\paragraph{Induction rules}~\\
In addition to structural induction there is the induction rule
@{thm[source] less_induct}:
\begin{quote}
@{thm less_induct}
\end{quote}
This is often called ``complete induction''. It is applied like this:
\begin{quote}
(\<open>induction n rule: less_induct\<close>)
\end{quote}
In fact, it is not restricted to \<^typ>\<open>nat\<close> but works for any wellfounded
order \<open><\<close>.

There are many more special induction rules. You can find all of them
via the Find button (in Isabelle/jedit) with the following search criteria:
\begin{quote}
\texttt{name: Nat name: induct}
\end{quote}

\paragraph{How to convert numerals into \<^const>\<open>Suc\<close> terms}~\\
Solution: simplify with the lemma @{thm[source] numeral_eq_Suc}.

\noindent
Example:
\<close>

lemma fixes x :: int shows "x ^ 3 = x * x * x"
by (simp add: numeral_eq_Suc)

text\<open>This is a typical situation: function ``\<open>^\<close>'' is defined
by pattern matching on \<^const>\<open>Suc\<close> but is applied to a numeral.

Note: simplification with @{thm[source] numeral_eq_Suc} will convert all numerals.
One can be more specific with the lemmas @{thm [source] numeral_2_eq_2}
(@{thm numeral_2_eq_2}) and @{thm[source] numeral_3_eq_3} (@{thm numeral_3_eq_3}).

\section{Lists}

%Tobias Nipkow
\paragraph{Induction rules}~\\
In addition to structural induction there are a few more induction rules
that come in handy at times:
\begin{itemize}
\item
Structural induction where the new element is appended to the end
of the list (@{thm[source] rev_induct}):

@{thm rev_induct}

\item Induction on the length of a list (@{thm [source] length_induct}):

@{thm length_induct}

\item Simultaneous induction on two lists of the same length (@{thm [source] list_induct2}):

@{thm[display,margin=60] list_induct2}

\end{itemize}

%Tobias Nipkow
\section{Algebraic simplification}

On the numeric types \<^typ>\<open>nat\<close>, \<^typ>\<open>int\<close> and \<^typ>\<open>real\<close>,
proof method \<open>simp\<close> and friends can deal with a limited amount of linear
arithmetic (no multiplication except by numerals) and method \<open>arith\<close> can
handle full linear arithmetic (on \<^typ>\<open>nat\<close>, \<^typ>\<open>int\<close> including quantifiers).
But what to do when proper multiplication is involved?
At this point it can be helpful to simplify with the lemma list
@{thm [source] algebra_simps}. Examples:
\<close>

lemma fixes x :: int
  shows "(x + y) * (y - z) = (y - z) * x + y * (y-z)"
by(simp add: algebra_simps)

lemma fixes x :: "'a :: comm_ring"
  shows "(x + y) * (y - z) = (y - z) * x + y * (y-z)"
by(simp add: algebra_simps)

text\<open>
Rewriting with @{thm[source] algebra_simps} has the following effect:
terms are rewritten into a normal form by multiplying out,
rearranging sums and products into some canonical order.
In the above lemma the normal form will be something like
\<^term>\<open>x*y + y*y - x*z - y*z\<close>.
This works for concrete types like \<^typ>\<open>int\<close> as well as for classes like
\<^class>\<open>comm_ring\<close> (commutative rings). For some classes (e.g.\ \<^class>\<open>ring\<close>
and \<^class>\<open>comm_ring\<close>) this yields a decision procedure for equality.

Additional function and predicate symbols are not a problem either:
\<close>

lemma fixes f :: "int \<Rightarrow> int" shows "2 * f(x*y) - f(y*x) < f(y*x) + 1"
by(simp add: algebra_simps)

text\<open>Here @{thm[source]algebra_simps} merely has the effect of rewriting
\<^term>\<open>y*x\<close> to \<^term>\<open>x*y\<close> (or the other way around). This yields
a problem of the form \<^prop>\<open>2*t - t < t + (1::int)\<close> and we are back in the
realm of linear arithmetic.

Because @{thm[source]algebra_simps} multiplies out, terms can explode.
If one merely wants to bring sums or products into a canonical order
it suffices to rewrite with @{thm [source] ac_simps}:\<close>

lemma fixes f :: "int \<Rightarrow> int" shows "f(x*y*z) - f(z*x*y) = 0"
by(simp add: ac_simps)

text\<open>The lemmas @{thm[source]algebra_simps} take care of addition, subtraction
and multiplication (algebraic structures up to rings) but ignore division (fields).
The lemmas @{thm[source]field_simps} also deal with division:
\<close>

lemma fixes x :: real shows "x+z \<noteq> 0 \<Longrightarrow> 1 + y/(x+z) = (x+y+z)/(x+z)"
by(simp add: field_simps)

text\<open>Warning: @{thm[source]field_simps} can blow up your terms
beyond recognition.\<close>

(*<*)
end
(*>*)


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_nicomachus_theorem
imports "../../Test_Base"
begin

(*fun did not finish the proof*)
function sum :: "int => int" where
"sum x = (if (x = 0) then 0 else (sum (x - 1)) + x)"
by pat_completeness auto

(*fun did not finish the proof*)
function cubes :: "int => int" where
"cubes x =
   (if (x = 0) then 0 else (cubes (x - 1)) + ((x * x) * x))"
  by pat_completeness auto

theorem property0 :
  "((cubes n) = ((sum n) * (sum n)))"
  oops

end