(*  Title:      HOL/Library/Ramsey.thy
    Author:     Tom Ridge. Full finite version by L C Paulson.
*)

section \<open>Ramsey's Theorem\<close>

theory Ramsey
  imports Infinite_Set FuncSet
begin

subsection \<open>Preliminary definitions\<close>

subsubsection \<open>The $n$-element subsets of a set $A$\<close>

definition nsets :: "['a set, nat] \<Rightarrow> 'a set set" ("([_]\<^bsup>_\<^esup>)" [0,999] 999)
  where "nsets A n \<equiv> {N. N \<subseteq> A \<and> finite N \<and> card N = n}"

lemma nsets_mono: "A \<subseteq> B \<Longrightarrow> nsets A n \<subseteq> nsets B n"
  by (auto simp: nsets_def)

lemma nsets_Pi_contra: "A' \<subseteq> A \<Longrightarrow> Pi ([A]\<^bsup>n\<^esup>) B \<subseteq> Pi ([A']\<^bsup>n\<^esup>) B"
  by (auto simp: nsets_def)

lemma nsets_2_eq: "nsets A 2 = (\<Union>x\<in>A. \<Union>y\<in>A - {x}. {{x, y}})"
  by (auto simp: nsets_def card_2_iff)

lemma nsets_doubleton_2_eq [simp]: "[{x, y}]\<^bsup>2\<^esup> = (if x=y then {} else {{x, y}})"
  by (auto simp: nsets_2_eq)

lemma doubleton_in_nsets_2 [simp]: "{x,y} \<in> [A]\<^bsup>2\<^esup> \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> x \<noteq> y"
  by (auto simp: nsets_2_eq Set.doubleton_eq_iff)

lemma nsets_3_eq: "nsets A 3 = (\<Union>x\<in>A. \<Union>y\<in>A - {x}. \<Union>z\<in>A - {x,y}. {{x,y,z}})"
  by (simp add: eval_nat_numeral nsets_def card_Suc_eq) blast

lemma nsets_4_eq: "[A]\<^bsup>4\<^esup> = (\<Union>u\<in>A. \<Union>x\<in>A - {u}. \<Union>y\<in>A - {u,x}. \<Union>z\<in>A - {u,x,y}. {{u,x,y,z}})"
     (is "_ = ?rhs")
proof
  show "[A]\<^bsup>4\<^esup> \<subseteq> ?rhs"
    by (clarsimp simp add: nsets_def eval_nat_numeral card_Suc_eq) blast
  show "?rhs \<subseteq> [A]\<^bsup>4\<^esup>"
    apply (clarsimp simp add: nsets_def eval_nat_numeral card_Suc_eq)
    by (metis insert_iff singletonD)
qed

lemma nsets_disjoint_2:
  "X \<inter> Y = {} \<Longrightarrow> [X \<union> Y]\<^bsup>2\<^esup> = [X]\<^bsup>2\<^esup> \<union> [Y]\<^bsup>2\<^esup> \<union> (\<Union>x\<in>X. \<Union>y\<in>Y. {{x,y}})"
  by (fastforce simp: nsets_2_eq Set.doubleton_eq_iff)

lemma ordered_nsets_2_eq:
  fixes A :: "'a::linorder set"
  shows "nsets A 2 = {{x,y} | x y. x \<in> A \<and> y \<in> A \<and> x<y}"
     (is "_ = ?rhs")
proof
  show "nsets A 2 \<subseteq> ?rhs"
    unfolding numeral_nat
    apply (clarsimp simp add: nsets_def card_Suc_eq Set.doubleton_eq_iff not_less)
    by (metis antisym)
  show "?rhs \<subseteq> nsets A 2"
    unfolding numeral_nat by (auto simp: nsets_def card_Suc_eq)
qed

lemma ordered_nsets_3_eq:
  fixes A :: "'a::linorder set"
  shows "nsets A 3 = {{x,y,z} | x y z. x \<in> A \<and> y \<in> A \<and> z \<in> A \<and> x<y \<and> y<z}"
     (is "_ = ?rhs")
proof
  show "nsets A 3 \<subseteq> ?rhs"
    apply (clarsimp simp add: nsets_def card_Suc_eq eval_nat_numeral)
    by (metis insert_commute linorder_cases)
  show "?rhs \<subseteq> nsets A 3"
    apply (clarsimp simp add: nsets_def card_Suc_eq eval_nat_numeral)
  by (metis empty_iff insert_iff not_less_iff_gr_or_eq)
qed

lemma ordered_nsets_4_eq:
  fixes A :: "'a::linorder set"
  shows "[A]\<^bsup>4\<^esup> = {U. \<exists>u x y z. U = {u,x,y,z} \<and> u \<in> A \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A \<and> u < x \<and> x < y \<and> y < z}"
    (is "_ = Collect ?RHS")
proof -
  { fix U
    assume "U \<in> [A]\<^bsup>4\<^esup>"
    then obtain l where "strict_sorted l" "List.set l = U" "length l = 4" "U \<subseteq> A"
      by (simp add: nsets_def) (metis finite_set_strict_sorted)
    then have "?RHS U"
      unfolding numeral_nat length_Suc_conv by auto blast }
  moreover
  have "Collect ?RHS \<subseteq> [A]\<^bsup>4\<^esup>"
    apply (clarsimp simp add: nsets_def eval_nat_numeral)
    apply (subst card_insert_disjoint, auto)+
    done
  ultimately show ?thesis
    by auto
qed

lemma ordered_nsets_5_eq:
  fixes A :: "'a::linorder set"
  shows "[A]\<^bsup>5\<^esup> = {U. \<exists>u v x y z. U = {u,v,x,y,z} \<and> u \<in> A \<and> v \<in> A \<and> x \<in> A \<and> y \<in> A \<and> z \<in> A \<and> u < v \<and> v < x \<and> x < y \<and> y < z}"
    (is "_ = Collect ?RHS")
proof -
  { fix U
  assume "U \<in> [A]\<^bsup>5\<^esup>"
  then obtain l where "strict_sorted l" "List.set l = U" "length l = 5" "U \<subseteq> A"
    apply (simp add: nsets_def)
    by (metis finite_set_strict_sorted)
  then have "?RHS U"
    unfolding numeral_nat length_Suc_conv by auto blast }
  moreover
  have "Collect ?RHS \<subseteq> [A]\<^bsup>5\<^esup>"
    apply (clarsimp simp add: nsets_def eval_nat_numeral)
    apply (subst card_insert_disjoint, auto)+
    done
  ultimately show ?thesis
    by auto
qed

lemma binomial_eq_nsets: "n choose k = card (nsets {0..<n} k)"
  apply (simp add: binomial_def nsets_def)
  by (meson subset_eq_atLeast0_lessThan_finite)

lemma nsets_eq_empty_iff: "nsets A r = {} \<longleftrightarrow> finite A \<and> card A < r"
  unfolding nsets_def
proof (intro iffI conjI)
  assume that: "{N. N \<subseteq> A \<and> finite N \<and> card N = r} = {}"
  show "finite A"
    using infinite_arbitrarily_large that by auto
  then have "\<not> r \<le> card A"
    using that by (simp add: set_eq_iff) (metis obtain_subset_with_card_n)
  then show "card A < r"
    using not_less by blast
next
  show "{N. N \<subseteq> A \<and> finite N \<and> card N = r} = {}"
    if "finite A \<and> card A < r"
    using that card_mono leD by auto
qed

lemma nsets_eq_empty: "\<lbrakk>finite A; card A < r\<rbrakk> \<Longrightarrow> nsets A r = {}"
  by (simp add: nsets_eq_empty_iff)

lemma nsets_empty_iff: "nsets {} r = (if r=0 then {{}} else {})"
  by (auto simp: nsets_def)

lemma nsets_singleton_iff: "nsets {a} r = (if r=0 then {{}} else if r=1 then {{a}} else {})"
  by (auto simp: nsets_def card_gt_0_iff subset_singleton_iff)

lemma nsets_self [simp]: "nsets {..<m} m = {{..<m}}"
  unfolding nsets_def
  apply auto
  by (metis add.left_neutral lessThan_atLeast0 lessThan_iff subset_card_intvl_is_intvl)

lemma nsets_zero [simp]: "nsets A 0 = {{}}"
  by (auto simp: nsets_def)

lemma nsets_one: "nsets A (Suc 0) = (\<lambda>x. {x}) ` A"
  using card_eq_SucD by (force simp: nsets_def)

lemma inj_on_nsets:
  assumes "inj_on f A"
  shows "inj_on (\<lambda>X. f ` X) ([A]\<^bsup>n\<^esup>)"
  using assms unfolding nsets_def
  by (metis (no_types, lifting) inj_on_inverseI inv_into_image_cancel mem_Collect_eq)

lemma bij_betw_nsets:
  assumes "bij_betw f A B"
  shows "bij_betw (\<lambda>X. f ` X) ([A]\<^bsup>n\<^esup>) ([B]\<^bsup>n\<^esup>)"
proof -
  have "(`) f ` [A]\<^bsup>n\<^esup> = [f ` A]\<^bsup>n\<^esup>"
    using assms
    apply (auto simp: nsets_def bij_betw_def image_iff card_image inj_on_subset)
    by (metis card_image inj_on_finite order_refl subset_image_inj)
  with assms show ?thesis
    by (auto simp: bij_betw_def inj_on_nsets)
qed

lemma nset_image_obtains:
  assumes "X \<in> [f`A]\<^bsup>k\<^esup>" "inj_on f A"
  obtains Y where "Y \<in> [A]\<^bsup>k\<^esup>" "X = f ` Y"
  using assms
  apply (clarsimp simp add: nsets_def subset_image_iff)
  by (metis card_image finite_imageD inj_on_subset)

lemma nsets_image_funcset:
  assumes "g \<in> S \<rightarrow> T" and "inj_on g S"
  shows "(\<lambda>X. g ` X) \<in> [S]\<^bsup>k\<^esup> \<rightarrow> [T]\<^bsup>k\<^esup>"
    using assms
    by (fastforce simp add: nsets_def card_image inj_on_subset subset_iff simp flip: image_subset_iff_funcset)

lemma nsets_compose_image_funcset:
  assumes f: "f \<in> [T]\<^bsup>k\<^esup> \<rightarrow> D" and "g \<in> S \<rightarrow> T" and "inj_on g S"
  shows "f \<circ> (\<lambda>X. g ` X) \<in> [S]\<^bsup>k\<^esup> \<rightarrow> D"
proof -
  have "(\<lambda>X. g ` X) \<in> [S]\<^bsup>k\<^esup> \<rightarrow> [T]\<^bsup>k\<^esup>"
    using assms by (simp add: nsets_image_funcset)
  then show ?thesis
    using f by fastforce
qed

subsubsection \<open>Partition predicates\<close>

definition partn :: "'a set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'b set \<Rightarrow> bool"
  where "partn \<beta> \<alpha> \<gamma> \<delta> \<equiv> \<forall>f \<in> nsets \<beta> \<gamma>  \<rightarrow>  \<delta>. \<exists>H \<in> nsets \<beta> \<alpha>. \<exists>\<xi>\<in>\<delta>. f ` (nsets H \<gamma>) \<subseteq> {\<xi>}"

definition partn_lst :: "'a set \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
  where "partn_lst \<beta> \<alpha> \<gamma> \<equiv> \<forall>f \<in> nsets \<beta> \<gamma>  \<rightarrow>  {..<length \<alpha>}.
              \<exists>i < length \<alpha>. \<exists>H \<in> nsets \<beta> (\<alpha>!i). f ` (nsets H \<gamma>) \<subseteq> {i}"

lemma partn_lst_greater_resource:
  fixes M::nat
  assumes M: "partn_lst {..<M} \<alpha> \<gamma>" and "M \<le> N"
  shows "partn_lst {..<N} \<alpha> \<gamma>"
proof (clarsimp simp: partn_lst_def)
  fix f
  assume "f \<in> nsets {..<N} \<gamma> \<rightarrow> {..<length \<alpha>}"
  then have "f \<in> nsets {..<M} \<gamma> \<rightarrow> {..<length \<alpha>}"
    by (meson Pi_anti_mono \<open>M \<le> N\<close> lessThan_subset_iff nsets_mono subsetD)
  then obtain i H where i: "i < length \<alpha>" and H: "H \<in> nsets {..<M} (\<alpha> ! i)" and subi: "f ` nsets H \<gamma> \<subseteq> {i}"
    using M partn_lst_def by blast
  have "H \<in> nsets {..<N} (\<alpha> ! i)"
    using \<open>M \<le> N\<close> H by (auto simp: nsets_def subset_iff)
  then show "\<exists>i<length \<alpha>. \<exists>H\<in>nsets {..<N} (\<alpha> ! i). f ` nsets H \<gamma> \<subseteq> {i}"
    using i subi by blast
qed

lemma partn_lst_fewer_colours:
  assumes major: "partn_lst \<beta> (n#\<alpha>) \<gamma>" and "n \<ge> \<gamma>"
  shows "partn_lst \<beta> \<alpha> \<gamma>"
proof (clarsimp simp: partn_lst_def)
  fix f :: "'a set \<Rightarrow> nat"
  assume f: "f \<in> [\<beta>]\<^bsup>\<gamma>\<^esup> \<rightarrow> {..<length \<alpha>}"
  then obtain i H where i: "i < Suc (length \<alpha>)"
      and H: "H \<in> [\<beta>]\<^bsup>((n # \<alpha>) ! i)\<^esup>"
      and hom: "\<forall>x\<in>[H]\<^bsup>\<gamma>\<^esup>. Suc (f x) = i"
    using \<open>n \<ge> \<gamma>\<close> major [unfolded partn_lst_def, rule_format, of "Suc o f"]
    by (fastforce simp: image_subset_iff nsets_eq_empty_iff)
  show "\<exists>i<length \<alpha>. \<exists>H\<in>nsets \<beta> (\<alpha> ! i). f ` [H]\<^bsup>\<gamma>\<^esup> \<subseteq> {i}"
  proof (cases i)
    case 0
    then have "[H]\<^bsup>\<gamma>\<^esup> = {}"
      using hom by blast
    then show ?thesis
      using 0 H \<open>n \<ge> \<gamma>\<close>
      by (simp add: nsets_eq_empty_iff) (simp add: nsets_def)
  next
    case (Suc i')
    then show ?thesis
      using i H hom by auto
  qed
qed

lemma partn_lst_eq_partn: "partn_lst {..<n} [m,m] 2 = partn {..<n} m 2 {..<2::nat}"
  apply (simp add: partn_lst_def partn_def numeral_2_eq_2)
  by (metis less_2_cases numeral_2_eq_2 lessThan_iff nth_Cons_0 nth_Cons_Suc)

subsection \<open>Finite versions of Ramsey's theorem\<close>

text \<open>
  To distinguish the finite and infinite ones, lower and upper case
  names are used.
\<close>

subsubsection \<open>Trivial cases\<close>

text \<open>Vacuous, since we are dealing with 0-sets!\<close>
lemma ramsey0: "\<exists>N::nat. partn_lst {..<N} [q1,q2] 0"
  by (force simp: partn_lst_def ex_in_conv less_Suc_eq nsets_eq_empty_iff)

text \<open>Just the pigeon hole principle, since we are dealing with 1-sets\<close>
lemma ramsey1: "\<exists>N::nat. partn_lst {..<N} [q0,q1] 1"
proof -
  have "\<exists>i<Suc (Suc 0). \<exists>H\<in>nsets {..<Suc (q0 + q1)} ([q0, q1] ! i). f ` nsets H (Suc 0) \<subseteq> {i}"
    if "f \<in> nsets {..<Suc (q0 + q1)} (Suc 0) \<rightarrow> {..<Suc (Suc 0)}" for f
  proof -
    define A where "A \<equiv> \<lambda>i. {q. q \<le> q0+q1 \<and> f {q} = i}"
    have "A 0 \<union> A 1 = {..q0 + q1}"
      using that by (auto simp: A_def PiE_iff nsets_one lessThan_Suc_atMost le_Suc_eq)
    moreover have "A 0 \<inter> A 1 = {}"
      by (auto simp: A_def)
    ultimately have "q0 + q1 \<le> card (A 0) + card (A 1)"
      by (metis card_Un_le card_atMost eq_imp_le le_SucI le_trans)
    then consider "card (A 0) \<ge> q0" | "card (A 1) \<ge> q1"
      by linarith
    then obtain i where "i < Suc (Suc 0)" "card (A i) \<ge> [q0, q1] ! i"
      by (metis One_nat_def lessI nth_Cons_0 nth_Cons_Suc zero_less_Suc)
    then obtain B where "B \<subseteq> A i" "card B = [q0, q1] ! i" "finite B"
      by (meson obtain_subset_with_card_n)
    then have "B \<in> nsets {..<Suc (q0 + q1)} ([q0, q1] ! i) \<and> f ` nsets B (Suc 0) \<subseteq> {i}"
      by (auto simp: A_def nsets_def card_1_singleton_iff)
    then show ?thesis
      using \<open>i < Suc (Suc 0)\<close> by auto
  qed
  then show ?thesis
    by (clarsimp simp: partn_lst_def) blast
qed

subsubsection \<open>Ramsey's theorem with two colours and arbitrary exponents (hypergraph version)\<close>

proposition ramsey2_full: "\<exists>N::nat. partn_lst {..<N} [q1,q2] r"
proof (induction r arbitrary: q1 q2)
  case 0
  then show ?case
    by (simp add: ramsey0)
next
  case (Suc r)
  note outer = this
  show ?case
  proof (cases "r = 0")
    case True
    then show ?thesis
      using ramsey1 by auto
  next
    case False
    then have "r > 0"
      by simp
    show ?thesis
      using Suc.prems
    proof (induct k \<equiv> "q1 + q2" arbitrary: q1 q2)
      case 0
      show ?case
      proof
        show "partn_lst {..<1::nat} [q1, q2] (Suc r)"
          using nsets_empty_iff subset_insert 0
          by (fastforce simp: partn_lst_def funcset_to_empty_iff nsets_eq_empty image_subset_iff)
      qed
    next
      case (Suc k)
      consider "q1 = 0 \<or> q2 = 0" | "q1 \<noteq> 0" "q2 \<noteq> 0" by auto
      then show ?case
      proof cases
        case 1
        then have "partn_lst {..< Suc 0} [q1, q2] (Suc r)"
          unfolding partn_lst_def using \<open>r > 0\<close>
          by (fastforce simp add: nsets_empty_iff nsets_singleton_iff lessThan_Suc)
        then show ?thesis by blast
      next
        case 2
        with Suc have "k = (q1 - 1) + q2" "k = q1 + (q2 - 1)" by auto
        then obtain p1 p2::nat where  p1: "partn_lst {..<p1} [q1-1,q2] (Suc r)" and p2: "partn_lst {..<p2} [q1,q2-1] (Suc r)"
          using Suc.hyps by blast
        then obtain p::nat where p: "partn_lst {..<p} [p1,p2] r"
          using outer Suc.prems by auto
        show ?thesis
        proof (intro exI conjI)
          have "\<exists>i<Suc (Suc 0). \<exists>H\<in>nsets {..p} ([q1,q2] ! i). f ` nsets H (Suc r) \<subseteq> {i}"
            if f: "f \<in> nsets {..p} (Suc r) \<rightarrow> {..<Suc (Suc 0)}" for f
          proof -
            define g where "g \<equiv> \<lambda>R. f (insert p R)"
            have "f (insert p i) \<in> {..<Suc (Suc 0)}" if "i \<in> nsets {..<p} r" for i
              using that card_insert_if by (fastforce simp: nsets_def intro!: Pi_mem [OF f])
            then have g: "g \<in> nsets {..<p} r \<rightarrow> {..<Suc (Suc 0)}"
              by (force simp: g_def PiE_iff)
            then obtain i U where i: "i < Suc (Suc 0)" and gi: "g ` nsets U r \<subseteq> {i}"
              and U: "U \<in> nsets {..<p} ([p1, p2] ! i)"
              using p by (auto simp: partn_lst_def)
            then have Usub: "U \<subseteq> {..<p}"
              by (auto simp: nsets_def)
            consider (izero) "i = 0" | (ione) "i = Suc 0"
              using i by linarith
            then show ?thesis
            proof cases
              case izero
              then have "U \<in> nsets {..<p} p1"
                using U by simp
              then obtain u where u: "bij_betw u {..<p1} U"
                using ex_bij_betw_nat_finite lessThan_atLeast0 by (fastforce simp add: nsets_def)
              have u_nsets: "u ` X \<in> nsets {..p} n" if "X \<in> nsets {..<p1} n" for X n
              proof -
                have "inj_on u X"
                  using u that bij_betw_imp_inj_on inj_on_subset by (force simp: nsets_def)
                then show ?thesis
                  using Usub u that bij_betwE
                  by (fastforce simp add: nsets_def card_image)
              qed
              define h where "h \<equiv> \<lambda>R. f (u ` R)"
              have "h \<in> nsets {..<p1} (Suc r) \<rightarrow> {..<Suc (Suc 0)}"
                unfolding h_def using f u_nsets by auto
              then obtain j V where j: "j <Suc (Suc 0)" and hj: "h ` nsets V (Suc r) \<subseteq> {j}"
                and V: "V \<in> nsets {..<p1} ([q1 - Suc 0, q2] ! j)"
                using p1 by (auto simp: partn_lst_def)
              then have Vsub: "V \<subseteq> {..<p1}"
                by (auto simp: nsets_def)
              have invinv_eq: "u ` inv_into {..<p1} u ` X = X" if "X \<subseteq> u ` {..<p1}" for X
                by (simp add: image_inv_into_cancel that)
              let ?W = "insert p (u ` V)"
              consider (jzero) "j = 0" | (jone) "j = Suc 0"
                using j by linarith
              then show ?thesis
              proof cases
                case jzero
                then have "V \<in> nsets {..<p1} (q1 - Suc 0)"
                  using V by simp
                then have "u ` V \<in> nsets {..<p} (q1 - Suc 0)"
                  using u_nsets [of _ "q1 - Suc 0"] nsets_mono [OF Vsub] Usub u
                  unfolding bij_betw_def nsets_def
                  by (fastforce elim!: subsetD)
                then have inq1: "?W \<in> nsets {..p} q1"
                  unfolding nsets_def using \<open>q1 \<noteq> 0\<close> card_insert_if by fastforce
                have invu_nsets: "inv_into {..<p1} u ` X \<in> nsets V r"
                  if "X \<in> nsets (u ` V) r" for X r
                proof -
                  have "X \<subseteq> u ` V \<and> finite X \<and> card X = r"
                    using nsets_def that by auto
                  then have [simp]: "card (inv_into {..<p1} u ` X) = card X"
                    by (meson Vsub bij_betw_def bij_betw_inv_into card_image image_mono inj_on_subset u)
                  show ?thesis
                    using that u Vsub by (fastforce simp: nsets_def bij_betw_def)
                qed
                have "f X = i" if X: "X \<in> nsets ?W (Suc r)" for X
                proof (cases "p \<in> X")
                  case True
                  then have Xp: "X - {p} \<in> nsets (u ` V) r"
                    using X by (auto simp: nsets_def)
                  moreover have "u ` V \<subseteq> U"
                    using Vsub bij_betwE u by blast
                  ultimately have "X - {p} \<in> nsets U r"
                    by (meson in_mono nsets_mono)
                  then have "g (X - {p}) = i"
                    using gi by blast
                  have "f X = i"
                    using gi True \<open>X - {p} \<in> nsets U r\<close> insert_Diff
                    by (fastforce simp add: g_def image_subset_iff)
                  then show ?thesis
                    by (simp add: \<open>f X = i\<close> \<open>g (X - {p}) = i\<close>)
                next
                  case False
                  then have Xim: "X \<in> nsets (u ` V) (Suc r)"
                    using X by (auto simp: nsets_def subset_insert)
                  then have "u ` inv_into {..<p1} u ` X = X"
                    using Vsub bij_betw_imp_inj_on u
                    by (fastforce simp: nsets_def image_mono invinv_eq subset_trans)
                  then show ?thesis
                    using izero jzero hj Xim invu_nsets unfolding h_def
                    by (fastforce simp add: image_subset_iff)
                qed
                moreover have "insert p (u ` V) \<in> nsets {..p} q1"
                  by (simp add: izero inq1)
                ultimately show ?thesis
                  by (metis izero image_subsetI insertI1 nth_Cons_0 zero_less_Suc)
              next
                case jone
                then have "u ` V \<in> nsets {..p} q2"
                  using V u_nsets by auto
                moreover have "f ` nsets (u ` V) (Suc r) \<subseteq> {j}"
                  using hj
                  by (force simp add: h_def image_subset_iff nsets_def subset_image_inj card_image dest: finite_imageD)
                ultimately show ?thesis
                  using jone not_less_eq by fastforce
              qed
            next
              case ione
              then have "U \<in> nsets {..<p} p2"
                using U by simp
              then obtain u where u: "bij_betw u {..<p2} U"
                using ex_bij_betw_nat_finite lessThan_atLeast0 by (fastforce simp add: nsets_def)
              have u_nsets: "u ` X \<in> nsets {..p} n" if "X \<in> nsets {..<p2} n" for X n
              proof -
                have "inj_on u X"
                  using u that bij_betw_imp_inj_on inj_on_subset by (force simp: nsets_def)
                then show ?thesis
                  using Usub u that bij_betwE
                  by (fastforce simp add: nsets_def card_image)
              qed
              define h where "h \<equiv> \<lambda>R. f (u ` R)"
              have "h \<in> nsets {..<p2} (Suc r) \<rightarrow> {..<Suc (Suc 0)}"
                unfolding h_def using f u_nsets by auto
              then obtain j V where j: "j <Suc (Suc 0)" and hj: "h ` nsets V (Suc r) \<subseteq> {j}"
                and V: "V \<in> nsets {..<p2} ([q1, q2 - Suc 0] ! j)"
                using p2 by (auto simp: partn_lst_def)
              then have Vsub: "V \<subseteq> {..<p2}"
                by (auto simp: nsets_def)
              have invinv_eq: "u ` inv_into {..<p2} u ` X = X" if "X \<subseteq> u ` {..<p2}" for X
                by (simp add: image_inv_into_cancel that)
              let ?W = "insert p (u ` V)"
              consider (jzero) "j = 0" | (jone) "j = Suc 0"
                using j by linarith
              then show ?thesis
              proof cases
                case jone
                then have "V \<in> nsets {..<p2} (q2 - Suc 0)"
                  using V by simp
                then have "u ` V \<in> nsets {..<p} (q2 - Suc 0)"
                  using u_nsets [of _ "q2 - Suc 0"] nsets_mono [OF Vsub] Usub u
                  unfolding bij_betw_def nsets_def
                  by (fastforce elim!: subsetD)
                then have inq1: "?W \<in> nsets {..p} q2"
                  unfolding nsets_def using \<open>q2 \<noteq> 0\<close> card_insert_if by fastforce
                have invu_nsets: "inv_into {..<p2} u ` X \<in> nsets V r"
                  if "X \<in> nsets (u ` V) r" for X r
                proof -
                  have "X \<subseteq> u ` V \<and> finite X \<and> card X = r"
                    using nsets_def that by auto
                  then have [simp]: "card (inv_into {..<p2} u ` X) = card X"
                    by (meson Vsub bij_betw_def bij_betw_inv_into card_image image_mono inj_on_subset u)
                  show ?thesis
                    using that u Vsub by (fastforce simp: nsets_def bij_betw_def)
                qed
                have "f X = i" if X: "X \<in> nsets ?W (Suc r)" for X
                proof (cases "p \<in> X")
                  case True
                  then have Xp: "X - {p} \<in> nsets (u ` V) r"
                    using X by (auto simp: nsets_def)
                  moreover have "u ` V \<subseteq> U"
                    using Vsub bij_betwE u by blast
                  ultimately have "X - {p} \<in> nsets U r"
                    by (meson in_mono nsets_mono)
                  then have "g (X - {p}) = i"
                    using gi by blast
                  have "f X = i"
                    using gi True \<open>X - {p} \<in> nsets U r\<close> insert_Diff
                    by (fastforce simp add: g_def image_subset_iff)
                  then show ?thesis
                    by (simp add: \<open>f X = i\<close> \<open>g (X - {p}) = i\<close>)
                next
                  case False
                  then have Xim: "X \<in> nsets (u ` V) (Suc r)"
                    using X by (auto simp: nsets_def subset_insert)
                  then have "u ` inv_into {..<p2} u ` X = X"
                    using Vsub bij_betw_imp_inj_on u
                    by (fastforce simp: nsets_def image_mono invinv_eq subset_trans)
                  then show ?thesis
                    using ione jone hj Xim invu_nsets unfolding h_def
                    by (fastforce simp add: image_subset_iff)
                qed
                moreover have "insert p (u ` V) \<in> nsets {..p} q2"
                  by (simp add: ione inq1)
                ultimately show ?thesis
                  by (metis ione image_subsetI insertI1 lessI nth_Cons_0 nth_Cons_Suc)
              next
                case jzero
                then have "u ` V \<in> nsets {..p} q1"
                  using V u_nsets by auto
                moreover have "f ` nsets (u ` V) (Suc r) \<subseteq> {j}"
                  using hj
                  apply (clarsimp simp add: h_def image_subset_iff nsets_def)
                  by (metis Zero_not_Suc card_eq_0_iff card_image subset_image_inj)
                ultimately show ?thesis
                  using jzero not_less_eq by fastforce
              qed
            qed
          qed
          then show "partn_lst {..<Suc p} [q1,q2] (Suc r)"
            using lessThan_Suc lessThan_Suc_atMost by (auto simp: partn_lst_def insert_commute)
        qed
      qed
    qed
  qed
qed

subsubsection \<open>Full Ramsey's theorem with multiple colours and arbitrary exponents\<close>

theorem ramsey_full: "\<exists>N::nat. partn_lst {..<N} qs r"
proof (induction k \<equiv> "length qs" arbitrary: qs)
  case 0
  then show ?case
    by (rule_tac x=" r" in exI) (simp add: partn_lst_def)
next
  case (Suc k)
  note IH = this
  show ?case
  proof (cases k)
    case 0
    with Suc obtain q where "qs = [q]"
      by (metis length_0_conv length_Suc_conv)
    then show ?thesis
      by (rule_tac x=q in exI) (auto simp: partn_lst_def funcset_to_empty_iff)
  next
    case (Suc k')
    then obtain q1 q2 l where qs: "qs = q1#q2#l"
      by (metis Suc.hyps(2) length_Suc_conv)
    then obtain q::nat where q: "partn_lst {..<q} [q1,q2] r"
      using ramsey2_full by blast
    then obtain p::nat where p: "partn_lst {..<p} (q#l) r"
      using IH \<open>qs = q1 # q2 # l\<close> by fastforce
    have keq: "Suc (length l) = k"
      using IH qs by auto
    show ?thesis
    proof (intro exI conjI)
      show "partn_lst {..<p} qs r"
      proof (auto simp: partn_lst_def)
        fix f
        assume f: "f \<in> nsets {..<p} r \<rightarrow> {..<length qs}"
        define g where "g \<equiv> \<lambda>X. if f X < Suc (Suc 0) then 0 else f X - Suc 0"
        have "g \<in> nsets {..<p} r \<rightarrow> {..<k}"
          unfolding g_def using f Suc IH
          by (auto simp: Pi_def not_less)
        then obtain i U where i: "i < k" and gi: "g ` nsets U r \<subseteq> {i}"
                and U: "U \<in> nsets {..<p} ((q#l) ! i)"
          using p keq by (auto simp: partn_lst_def)
        show "\<exists>i<length qs. \<exists>H\<in>nsets {..<p} (qs ! i). f ` nsets H r \<subseteq> {i}"
        proof (cases "i = 0")
          case True
          then have "U \<in> nsets {..<p} q" and f01: "f ` nsets U r \<subseteq> {0, Suc 0}"
            using U gi unfolding g_def by (auto simp: image_subset_iff)
          then obtain u where u: "bij_betw u {..<q} U"
            using ex_bij_betw_nat_finite lessThan_atLeast0 by (fastforce simp add: nsets_def)
          then have Usub: "U \<subseteq> {..<p}"
            by (smt \<open>U \<in> nsets {..<p} q\<close> mem_Collect_eq nsets_def)
          have u_nsets: "u ` X \<in> nsets {..<p} n" if "X \<in> nsets {..<q} n" for X n
          proof -
            have "inj_on u X"
              using u that bij_betw_imp_inj_on inj_on_subset
              by (force simp: nsets_def)
            then show ?thesis
              using Usub u that bij_betwE
              by (fastforce simp add: nsets_def card_image)
          qed
          define h where "h \<equiv> \<lambda>X. f (u ` X)"
          have "f (u ` X) < Suc (Suc 0)" if "X \<in> nsets {..<q} r" for X
          proof -
            have "u ` X \<in> nsets U r"
              using u u_nsets that by (auto simp: nsets_def bij_betwE subset_eq)
            then show ?thesis
              using f01 by auto
          qed
          then have "h \<in> nsets {..<q} r \<rightarrow> {..<Suc (Suc 0)}"
            unfolding h_def by blast
          then obtain j V where j: "j < Suc (Suc 0)" and hj: "h ` nsets V r \<subseteq> {j}"
            and V: "V \<in> nsets {..<q} ([q1,q2] ! j)"
            using q by (auto simp: partn_lst_def)
          show ?thesis
          proof (intro exI conjI bexI)
            show "j < length qs"
              using Suc Suc.hyps(2) j by linarith
            have "nsets (u ` V) r \<subseteq> (\<lambda>x. (u ` x)) ` nsets V r"
              apply (clarsimp simp add: nsets_def image_iff)
              by (metis card_eq_0_iff card_image image_is_empty subset_image_inj)
            then have "f ` nsets (u ` V) r \<subseteq> h ` nsets V r"
              by (auto simp: h_def)
            then show "f ` nsets (u ` V) r \<subseteq> {j}"
              using hj by auto
            show "(u ` V) \<in> nsets {..<p} (qs ! j)"
              using V j less_2_cases numeral_2_eq_2 qs u_nsets by fastforce
          qed
        next
          case False
          show ?thesis
          proof (intro exI conjI bexI)
            show "Suc i < length qs"
              using Suc.hyps(2) i by auto
            show "f ` nsets U r \<subseteq> {Suc i}"
              using i gi False
              apply (auto simp: g_def image_subset_iff)
              by (metis Suc_lessD Suc_pred g_def gi image_subset_iff not_less_eq singleton_iff)
            show "U \<in> nsets {..<p} (qs ! (Suc i))"
              using False U qs by auto
          qed
        qed
      qed
    qed
  qed
qed

subsubsection \<open>Simple graph version\<close>

text \<open>This is the most basic version in terms of cliques and independent
  sets, i.e. the version for graphs and 2 colours.
\<close>

definition "clique V E \<longleftrightarrow> (\<forall>v\<in>V. \<forall>w\<in>V. v \<noteq> w \<longrightarrow> {v, w} \<in> E)"
definition "indep V E \<longleftrightarrow> (\<forall>v\<in>V. \<forall>w\<in>V. v \<noteq> w \<longrightarrow> {v, w} \<notin> E)"

lemma ramsey2:
  "\<exists>r\<ge>1. \<forall>(V::'a set) (E::'a set set). finite V \<and> card V \<ge> r \<longrightarrow>
    (\<exists>R \<subseteq> V. card R = m \<and> clique R E \<or> card R = n \<and> indep R E)"
proof -
  obtain N where "N \<ge> Suc 0" and N: "partn_lst {..<N} [m,n] 2"
    using ramsey2_full nat_le_linear partn_lst_greater_resource by blast
  have "\<exists>R\<subseteq>V. card R = m \<and> clique R E \<or> card R = n \<and> indep R E"
    if "finite V" "N \<le> card V" for V :: "'a set" and E :: "'a set set"
  proof -
    from that
    obtain v where u: "inj_on v {..<N}" "v ` {..<N} \<subseteq> V"
      by (metis card_le_inj card_lessThan finite_lessThan)
    define f where "f \<equiv> \<lambda>e. if v ` e \<in> E then 0 else Suc 0"
    have f: "f \<in> nsets {..<N} 2 \<rightarrow> {..<Suc (Suc 0)}"
      by (simp add: f_def)
    then obtain i U where i: "i < 2" and gi: "f ` nsets U 2 \<subseteq> {i}"
      and U: "U \<in> nsets {..<N} ([m,n] ! i)"
      using N numeral_2_eq_2 by (auto simp: partn_lst_def)
    show ?thesis
    proof (intro exI conjI)
      show "v ` U \<subseteq> V"
        using U u by (auto simp: image_subset_iff nsets_def)
      show "card (v ` U) = m \<and> clique (v ` U) E \<or> card (v ` U) = n \<and> indep (v ` U) E"
        using i unfolding numeral_2_eq_2
          using gi U u
          apply (simp add: image_subset_iff nsets_2_eq clique_def indep_def less_Suc_eq)
          apply (auto simp: f_def nsets_def card_image inj_on_subset split: if_split_asm)
          done
    qed
  qed
  then show ?thesis
    using \<open>Suc 0 \<le> N\<close> by auto
qed

subsection \<open>Preliminaries\<close>

subsubsection \<open>``Axiom'' of Dependent Choice\<close>

primrec choice :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> 'a"
  where \<comment> \<open>An integer-indexed chain of choices\<close>
    choice_0: "choice P r 0 = (SOME x. P x)"
  | choice_Suc: "choice P r (Suc n) = (SOME y. P y \<and> (choice P r n, y) \<in> r)"

lemma choice_n:
  assumes P0: "P x0"
    and Pstep: "\<And>x. P x \<Longrightarrow> \<exists>y. P y \<and> (x, y) \<in> r"
  shows "P (choice P r n)"
proof (induct n)
  case 0
  show ?case by (force intro: someI P0)
next
  case Suc
  then show ?case by (auto intro: someI2_ex [OF Pstep])
qed

lemma dependent_choice:
  assumes trans: "trans r"
    and P0: "P x0"
    and Pstep: "\<And>x. P x \<Longrightarrow> \<exists>y. P y \<and> (x, y) \<in> r"
  obtains f :: "nat \<Rightarrow> 'a" where "\<And>n. P (f n)" and "\<And>n m. n < m \<Longrightarrow> (f n, f m) \<in> r"
proof
  fix n
  show "P (choice P r n)"
    by (blast intro: choice_n [OF P0 Pstep])
next
  fix n m :: nat
  assume "n < m"
  from Pstep [OF choice_n [OF P0 Pstep]] have "(choice P r k, choice P r (Suc k)) \<in> r" for k
    by (auto intro: someI2_ex)
  then show "(choice P r n, choice P r m) \<in> r"
    by (auto intro: less_Suc_induct [OF \<open>n < m\<close>] transD [OF trans])
qed

subsubsection \<open>Partition functions\<close>

definition part_fn :: "nat \<Rightarrow> nat \<Rightarrow> 'a set \<Rightarrow> ('a set \<Rightarrow> nat) \<Rightarrow> bool"
  \<comment> \<open>the function \<^term>\<open>f\<close> partitions the \<^term>\<open>r\<close>-subsets of the typically
      infinite set \<^term>\<open>Y\<close> into \<^term>\<open>s\<close> distinct categories.\<close>
  where "part_fn r s Y f \<longleftrightarrow> (f \<in> nsets Y r \<rightarrow> {..<s})"

text \<open>For induction, we decrease the value of \<^term>\<open>r\<close> in partitions.\<close>
lemma part_fn_Suc_imp_part_fn:
  "\<lbrakk>infinite Y; part_fn (Suc r) s Y f; y \<in> Y\<rbrakk> \<Longrightarrow> part_fn r s (Y - {y}) (\<lambda>u. f (insert y u))"
  by (simp add: part_fn_def nsets_def Pi_def subset_Diff_insert)

lemma part_fn_subset: "part_fn r s YY f \<Longrightarrow> Y \<subseteq> YY \<Longrightarrow> part_fn r s Y f"
  unfolding part_fn_def nsets_def by blast

subsection \<open>Ramsey's Theorem: Infinitary Version\<close>

lemma Ramsey_induction:
  fixes s r :: nat
    and YY :: "'a set"
    and f :: "'a set \<Rightarrow> nat"
  assumes "infinite YY" "part_fn r s YY f"
  shows "\<exists>Y' t'. Y' \<subseteq> YY \<and> infinite Y' \<and> t' < s \<and> (\<forall>X. X \<subseteq> Y' \<and> finite X \<and> card X = r \<longrightarrow> f X = t')"
  using assms
proof (induct r arbitrary: YY f)
  case 0
  then show ?case
    by (auto simp add: part_fn_def card_eq_0_iff cong: conj_cong)
next
  case (Suc r)
  show ?case
  proof -
    from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY"
      by blast
    let ?ramr = "{((y, Y, t), (y', Y', t')). y' \<in> Y \<and> Y' \<subseteq> Y}"
    let ?propr = "\<lambda>(y, Y, t).
                 y \<in> YY \<and> y \<notin> Y \<and> Y \<subseteq> YY \<and> infinite Y \<and> t < s
                 \<and> (\<forall>X. X\<subseteq>Y \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert y) X = t)"
    from Suc.prems have infYY': "infinite (YY - {yy})" by auto
    from Suc.prems have partf': "part_fn r s (YY - {yy}) (f \<circ> insert yy)"
      by (simp add: o_def part_fn_Suc_imp_part_fn yy)
    have transr: "trans ?ramr" by (force simp add: trans_def)
    from Suc.hyps [OF infYY' partf']
    obtain Y0 and t0 where "Y0 \<subseteq> YY - {yy}" "infinite Y0" "t0 < s"
      "X \<subseteq> Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0" for X
      by blast
    with yy have propr0: "?propr(yy, Y0, t0)" by blast
    have proprstep: "\<exists>y. ?propr y \<and> (x, y) \<in> ?ramr" if x: "?propr x" for x
    proof (cases x)
      case (fields yx Yx tx)
      with x obtain yx' where yx': "yx' \<in> Yx"
        by (blast dest: infinite_imp_nonempty)
      from fields x have infYx': "infinite (Yx - {yx'})" by auto
      with fields x yx' Suc.prems have partfx': "part_fn r s (Yx - {yx'}) (f \<circ> insert yx')"
        by (simp add: o_def part_fn_Suc_imp_part_fn part_fn_subset [where YY=YY and Y=Yx])
      from Suc.hyps [OF infYx' partfx'] obtain Y' and t'
        where Y': "Y' \<subseteq> Yx - {yx'}" "infinite Y'" "t' < s"
          "X \<subseteq> Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'" for X
        by blast
      from fields x Y' yx' have "?propr (yx', Y', t') \<and> (x, (yx', Y', t')) \<in> ?ramr"
        by blast
      then show ?thesis ..
    qed
    from dependent_choice [OF transr propr0 proprstep]
    obtain g where pg: "?propr (g n)" and rg: "n < m \<Longrightarrow> (g n, g m) \<in> ?ramr" for n m :: nat
      by blast
    let ?gy = "fst \<circ> g"
    let ?gt = "snd \<circ> snd \<circ> g"
    have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
    proof (intro exI subsetI)
      fix x
      assume "x \<in> range ?gt"
      then obtain n where "x = ?gt n" ..
      with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
    qed
    from rangeg have "finite (range ?gt)"
      by (simp add: finite_nat_iff_bounded)
    then obtain s' and n' where s': "s' = ?gt n'" and infeqs': "infinite {n. ?gt n = s'}"
      by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: infinite_UNIV_nat)
    with pg [of n'] have less': "s'<s" by (cases "g n'") auto
    have inj_gy: "inj ?gy"
    proof (rule linorder_injI)
      fix m m' :: nat
      assume "m < m'"
      from rg [OF this] pg [of m] show "?gy m \<noteq> ?gy m'"
        by (cases "g m", cases "g m'") auto
    qed
    show ?thesis
    proof (intro exI conjI)
      from pg show "?gy ` {n. ?gt n = s'} \<subseteq> YY"
        by (auto simp add: Let_def split_beta)
      from infeqs' show "infinite (?gy ` {n. ?gt n = s'})"
        by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD)
      show "s' < s" by (rule less')
      show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} \<and> finite X \<and> card X = Suc r \<longrightarrow> f X = s'"
      proof -
        have "f X = s'"
          if X: "X \<subseteq> ?gy ` {n. ?gt n = s'}"
          and cardX: "finite X" "card X = Suc r"
          for X
        proof -
          from X obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA"
            by (auto simp add: subset_image_iff)
          with cardX have "AA \<noteq> {}" by auto
          then have AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex)
          show ?thesis
          proof (cases "g (LEAST x. x \<in> AA)")
            case (fields ya Ya ta)
            with AAleast Xeq have ya: "ya \<in> X" by (force intro!: rev_image_eqI)
            then have "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
            also have "\<dots> = ta"
            proof -
              have *: "X - {ya} \<subseteq> Ya"
              proof
                fix x assume x: "x \<in> X - {ya}"
                then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA"
                  by (auto simp add: Xeq)
                with fields x have "a' \<noteq> (LEAST x. x \<in> AA)" by auto
                with Least_le [of "\<lambda>x. x \<in> AA", OF a'] have "(LEAST x. x \<in> AA) < a'"
                  by arith
                from xeq fields rg [OF this] show "x \<in> Ya" by auto
              qed
              have "card (X - {ya}) = r"
                by (simp add: cardX ya)
              with pg [of "LEAST x. x \<in> AA"] fields cardX * show ?thesis
                by (auto simp del: insert_Diff_single)
            qed
            also from AA AAleast fields have "\<dots> = s'" by auto
            finally show ?thesis .
          qed
        qed
        then show ?thesis by blast
      qed
    qed
  qed
qed

theorem Ramsey:
  fixes s r :: nat
    and Z :: "'a set"
    and f :: "'a set \<Rightarrow> nat"
  shows
   "\<lbrakk>infinite Z;
      \<forall>X. X \<subseteq> Z \<and> finite X \<and> card X = r \<longrightarrow> f X < s\<rbrakk>
    \<Longrightarrow> \<exists>Y t. Y \<subseteq> Z \<and> infinite Y \<and> t < s
            \<and> (\<forall>X. X \<subseteq> Y \<and> finite X \<and> card X = r \<longrightarrow> f X = t)"
  by (blast intro: Ramsey_induction [unfolded part_fn_def nsets_def])

corollary Ramsey2:
  fixes s :: nat
    and Z :: "'a set"
    and f :: "'a set \<Rightarrow> nat"
  assumes infZ: "infinite Z"
    and part: "\<forall>x\<in>Z. \<forall>y\<in>Z. x \<noteq> y \<longrightarrow> f {x, y} < s"
  shows "\<exists>Y t. Y \<subseteq> Z \<and> infinite Y \<and> t < s \<and> (\<forall>x\<in>Y. \<forall>y\<in>Y. x\<noteq>y \<longrightarrow> f {x, y} = t)"
proof -
  from part have part2: "\<forall>X. X \<subseteq> Z \<and> finite X \<and> card X = 2 \<longrightarrow> f X < s"
    by (fastforce simp add: eval_nat_numeral card_Suc_eq)
  obtain Y t where *:
    "Y \<subseteq> Z" "infinite Y" "t < s" "(\<forall>X. X \<subseteq> Y \<and> finite X \<and> card X = 2 \<longrightarrow> f X = t)"
    by (insert Ramsey [OF infZ part2]) auto
  then have "\<forall>x\<in>Y. \<forall>y\<in>Y. x \<noteq> y \<longrightarrow> f {x, y} = t" by auto
  with * show ?thesis by iprover
qed

corollary Ramsey_nsets:
  fixes f :: "'a set \<Rightarrow> nat"
  assumes "infinite Z" "f ` nsets Z r \<subseteq> {..<s}"
  obtains Y t where "Y \<subseteq> Z" "infinite Y" "t < s" "f ` nsets Y r \<subseteq> {t}"
  using Ramsey [of Z r f s] assms by (auto simp: nsets_def image_subset_iff)

subsection \<open>Disjunctive Well-Foundedness\<close>

text \<open>
  An application of Ramsey's theorem to program termination. See
  @{cite "Podelski-Rybalchenko"}.
\<close>

definition disj_wf :: "('a \<times> 'a) set \<Rightarrow> bool"
  where "disj_wf r \<longleftrightarrow> (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf (T i)) \<and> r = (\<Union>i<n. T i))"

definition transition_idx :: "(nat \<Rightarrow> 'a) \<Rightarrow> (nat \<Rightarrow> ('a \<times> 'a) set) \<Rightarrow> nat set \<Rightarrow> nat"
  where "transition_idx s T A = (LEAST k. \<exists>i j. A = {i, j} \<and> i < j \<and> (s j, s i) \<in> T k)"

lemma transition_idx_less:
  assumes "i < j" "(s j, s i) \<in> T k" "k < n"
  shows "transition_idx s T {i, j} < n"
proof -
  from assms(1,2) have "transition_idx s T {i, j} \<le> k"
    by (simp add: transition_idx_def, blast intro: Least_le)
  with assms(3) show ?thesis by simp
qed

lemma transition_idx_in:
  assumes "i < j" "(s j, s i) \<in> T k"
  shows "(s j, s i) \<in> T (transition_idx s T {i, j})"
  using assms
  by (simp add: transition_idx_def doubleton_eq_iff conj_disj_distribR cong: conj_cong) (erule LeastI)

text \<open>To be equal to the union of some well-founded relations is equivalent
  to being the subset of such a union.\<close>
lemma disj_wf: "disj_wf r \<longleftrightarrow> (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) \<and> r \<subseteq> (\<Union>i<n. T i))"
proof -
  have *: "\<And>T n. \<lbrakk>\<forall>i<n. wf (T i); r \<subseteq> \<Union> (T ` {..<n})\<rbrakk>
           \<Longrightarrow> (\<forall>i<n. wf (T i \<inter> r)) \<and> r = (\<Union>i<n. T i \<inter> r)"
    by (force simp add: wf_Int1)
  show ?thesis
    unfolding disj_wf_def by auto (metis "*")
qed

theorem trans_disj_wf_implies_wf:
  assumes "trans r"
    and "disj_wf r"
  shows "wf r"
proof (simp only: wf_iff_no_infinite_down_chain, rule notI)
  assume "\<exists>s. \<forall>i. (s (Suc i), s i) \<in> r"
  then obtain s where sSuc: "\<forall>i. (s (Suc i), s i) \<in> r" ..
  from \<open>disj_wf r\<close> obtain T and n :: nat where wfT: "\<forall>k<n. wf(T k)" and r: "r = (\<Union>k<n. T k)"
    by (auto simp add: disj_wf_def)
  have s_in_T: "\<exists>k. (s j, s i) \<in> T k \<and> k<n" if "i < j" for i j
  proof -
    from \<open>i < j\<close> have "(s j, s i) \<in> r"
    proof (induct rule: less_Suc_induct)
      case 1
      then show ?case by (simp add: sSuc)
    next
      case 2
      with \<open>trans r\<close> show ?case
        unfolding trans_def by blast
    qed
    then show ?thesis by (auto simp add: r)
  qed
  have "i < j \<Longrightarrow> transition_idx s T {i, j} < n" for i j
    using s_in_T transition_idx_less by blast
  then have trless: "i \<noteq> j \<Longrightarrow> transition_idx s T {i, j} < n" for i j
    by (metis doubleton_eq_iff less_linear)
  have "\<exists>K k. K \<subseteq> UNIV \<and> infinite K \<and> k < n \<and>
      (\<forall>i\<in>K. \<forall>j\<in>K. i \<noteq> j \<longrightarrow> transition_idx s T {i, j} = k)"
    by (rule Ramsey2) (auto intro: trless infinite_UNIV_nat)
  then obtain K and k where infK: "infinite K" and "k < n"
    and allk: "\<forall>i\<in>K. \<forall>j\<in>K. i \<noteq> j \<longrightarrow> transition_idx s T {i, j} = k"
    by auto
  have "(s (enumerate K (Suc m)), s (enumerate K m)) \<in> T k" for m :: nat
  proof -
    let ?j = "enumerate K (Suc m)"
    let ?i = "enumerate K m"
    have ij: "?i < ?j" by (simp add: enumerate_step infK)
    have "?j \<in> K" "?i \<in> K" by (simp_all add: enumerate_in_set infK)
    with ij have k: "k = transition_idx s T {?i, ?j}" by (simp add: allk)
    from s_in_T [OF ij] obtain k' where "(s ?j, s ?i) \<in> T k'" "k'<n" by blast
    then show "(s ?j, s ?i) \<in> T k" by (simp add: k transition_idx_in ij)
  qed
  then have "\<not> wf (T k)"
    by (meson wf_iff_no_infinite_down_chain)
  with wfT \<open>k < n\<close> show False by blast
qed

end


header {* Robbins Conjecture *}

theory Robbins_Conjecture
imports Main
begin

text {* The document gives a formalization of the proof of the Robbins
        conjecture, following A. Mann, \emph{A Complete Proof of the
        Robbins Conjecture}, 2003, DOI 10.1.1.6.7838 *}

section {* Axiom Systems *}

text {* The following presents several axiom systems that shall be under study.

        The first axiom sets common systems that underly all of
        the systems we shall be looking at.

        The second system is a reformulation of Boolean algebra.  We shall
        follow pages 7--8 in S. Koppelberg. \emph{General Theory of Boolean
        Algebras}, Volume 1 of \emph{Handbook of Boolean Algebras}. North
        Holland, 1989. Note that our formulation deviates slightly from this,
        as we only provide one distribution axiom, as the dual is redundant.

        The third system is Huntington's algebra and the fourth system is
        Robbins' algebra.

        Apart from the common system, all of these systems are demonstrated
        to be equivalent to the library formulation of Boolean algebra, under
        appropriate interpretation. *}

subsection {* Common Algebras *}

class common_algebra = uminus +
  fixes inf :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 70)
  fixes sup :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>" 65)
  fixes bot :: "'a" ("\<bottom>")
  fixes top :: "'a" ("\<top>")
  assumes sup_assoc: "x \<squnion> (y \<squnion> z) = (x \<squnion> y) \<squnion> z"
  assumes sup_comm: "x \<squnion> y = y \<squnion> x"

context common_algebra begin

definition less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50) where
   "x \<sqsubseteq> y = (x \<squnion> y = y)"
definition less :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubset>" 50) where
   "x \<sqsubset> y = (x \<sqsubseteq> y \<and> \<not> y \<sqsubseteq> x)"
definition minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "-" 65) where
   "minus x y = (x \<sqinter> - y)"

(* We shall need some object in order to define falsum and verum *)
definition secret_object1 :: "'a" ("\<iota>") where
  "\<iota> = (SOME x. True)"

end

class ext_common_algebra = common_algebra +
  assumes inf_eq: "x \<sqinter> y = -(- x \<squnion> - y)"
  assumes top_eq: "\<top> = \<iota> \<squnion> - \<iota>"
  assumes bot_eq: "\<bottom> = -(\<iota> \<squnion> - \<iota>)"

subsection {* Boolean Algebra *}

class boolean_algebra_II =
  common_algebra +
  assumes inf_comm: "x \<sqinter> y = y \<sqinter> x"
  assumes inf_assoc: "x \<sqinter> (y \<sqinter> z) = (x \<sqinter> y) \<sqinter> z"
  assumes sup_absorb: "x \<squnion> (x \<sqinter> y) = x"
  assumes inf_absorb: "x \<sqinter> (x \<squnion> y) = x"
  assumes sup_inf_distrib1: "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
  assumes sup_compl: "x \<squnion> - x = \<top>"
  assumes inf_compl: "x \<sqinter> - x = \<bottom>"

subsection {* Huntington's Algebra *}

class huntington_algebra = ext_common_algebra +
  assumes huntington: "- (-x \<squnion> -y) \<squnion> - (-x \<squnion>  y) = x"

subsection {* Robbins' Algebra *}

class robbins_algebra = ext_common_algebra +
  assumes robbins: "- (- (x \<squnion> y) \<squnion> - (x \<squnion> -y)) = x"

section {* Equivalence *}

text {* With our axiom systems defined, we turn to providing equivalence
        results between them.

        We shall begin by illustrating equivalence for our formulation and
        the library formulation of Boolean algebra. *}

subsection {* Boolean Algebra *}

text {* The following provides the canonical definitions for order and
        relative complementation for Boolean algebras.  These are necessary
        since the Boolean algebras presented in the Isabelle/HOL library have
        a lot of structure, while our formulation is considerably simpler.

       Since our formulation of Boolean algebras is considerably simple, it is
       easy to show that the library instantiates our axioms. *}

context boolean_algebra_II begin

lemma boolean_II_is_boolean:
   "class.boolean_algebra minus uminus (op \<sqinter>) (op \<sqsubseteq>) (op \<sqsubset>) (op \<squnion>) \<bottom> \<top>"
apply unfold_locales
apply (metis inf_absorb inf_assoc inf_comm inf_compl
             less_def less_eq_def minus_def
             sup_absorb sup_assoc sup_comm
             sup_compl sup_inf_distrib1
             sup_absorb inf_comm)+
done

end

context boolean_algebra begin

lemma boolean_is_boolean_II:
  "class.boolean_algebra_II uminus inf sup bot top"
apply unfold_locales
apply (metis sup_assoc sup_commute sup_inf_absorb sup_compl_top
             inf_assoc inf_commute inf_sup_absorb inf_compl_bot
             sup_inf_distrib1)+
done

end

subsection {* Huntington Algebra *}

text {* We shall illustrate here that all Boolean algebra using our
        formulation are Huntington algebras, and illustrate that every
        Huntington algebra may be interpreted as a Boolean algebra.

        Since the Isabelle/HOL library has good automation, it is convenient
        to first show that the library instances Huntington algebras to exploit
        previous results, and then use our previously derived correspondence. *}

context boolean_algebra begin
lemma boolean_is_huntington:
  "class.huntington_algebra uminus inf sup bot top"
apply unfold_locales
apply (metis double_compl inf_sup_distrib1 inf_top_right
             compl_inf inf_commute inf_compl_bot
             compl_sup sup_commute sup_compl_top
             sup_compl_top sup_assoc)+
done

end

context boolean_algebra_II begin

lemma boolean_II_is_huntington:
  "class.huntington_algebra uminus (op \<sqinter>) (op \<squnion>) \<bottom> \<top>"
proof -
  interpret boolean:
    boolean_algebra minus uminus "op \<sqinter>" "op \<sqsubseteq>" "op \<sqsubset>" "op \<squnion>" \<bottom> \<top>
      by (fact boolean_II_is_boolean)
  show ?thesis by (simp add: boolean.boolean_is_huntington)
qed

end

context huntington_algebra begin

lemma huntington_id: "x \<squnion> -x = -x \<squnion> -(-x)"
proof -
  from huntington have
  "x \<squnion> -x = -(-x \<squnion> -(-(-x))) \<squnion> -(-x \<squnion> -(-x)) \<squnion>
             (-(-(-x) \<squnion> -(-(-x))) \<squnion> -(-(-x) \<squnion> -(-x)))"
    by simp
  also from sup_comm have
  "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> -(-(-x) \<squnion> -(-(-x))) \<squnion>
        (-(-(-x) \<squnion> -x) \<squnion> -(-(-(-x)) \<squnion> -x))"
    by simp
  also from sup_assoc have
  "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion>
        (-(-(-x) \<squnion> -(-(-x))) \<squnion> -(-(-x) \<squnion> -x)) \<squnion>
       -(-(-(-x)) \<squnion> -x)"
    by simp
  also from sup_comm have
  "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion>
        (-(-(-x) \<squnion> -x) \<squnion> -(-(-x) \<squnion> -(-(-x)))) \<squnion>
       -(-(-(-x)) \<squnion> -x)"
    by simp
  also from sup_assoc have
  "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> -(-(-x) \<squnion> -x) \<squnion>
        (-(-(-x) \<squnion> -(-(-x))) \<squnion> -(-(-(-x)) \<squnion> -x))"
    by simp
  also from sup_comm have
  "\<dots> = -(-(-x) \<squnion> -(-x)) \<squnion> -(-(-x) \<squnion> -x) \<squnion>
        (-(-(-(-x)) \<squnion> -(-x)) \<squnion> -(-(-(-x)) \<squnion> -x))"
    by simp
  also from huntington have
  "\<dots> = -x \<squnion> -(-x)"
    by simp
  finally show ?thesis by simp
qed

lemma dbl_neg: "- (-x) = x"
apply (metis huntington huntington_id sup_comm)
done

lemma towards_sup_compl: "x \<squnion> -x = y \<squnion> -y"
proof -
   from huntington have
  "x \<squnion> -x = -(-x \<squnion> -(-y)) \<squnion> -(-x \<squnion> -y) \<squnion> (-(-(-x) \<squnion> -(-y)) \<squnion> -(-(-x) \<squnion> -y))"
     by simp
   also from sup_comm have
  "\<dots> = -(-(-y) \<squnion> -x) \<squnion> -(-y \<squnion> -x) \<squnion> (-(-y \<squnion> -(-x)) \<squnion> -(-(-y) \<squnion> -(-x)))"
     by simp
   also from sup_assoc have
  "\<dots> = -(-(-y) \<squnion> -x) \<squnion> (-(-y \<squnion> -x) \<squnion> -(-y \<squnion> -(-x))) \<squnion> -(-(-y) \<squnion> -(-x))"
     by simp
   also from sup_comm have
  "\<dots> = -(-y \<squnion> -(-x)) \<squnion> -(-y \<squnion> -x) \<squnion> -(-(-y) \<squnion> -x) \<squnion> -(-(-y) \<squnion> -(-x))"
     by simp
   also from sup_assoc have
  "\<dots> = -(-y \<squnion> -(-x)) \<squnion> -(-y \<squnion> -x) \<squnion> (-(-(-y) \<squnion> -x) \<squnion> -(-(-y) \<squnion> -(-x)))"
     by simp
   also from sup_comm have
  "\<dots> = -(-y \<squnion> -(-x)) \<squnion> -(-y \<squnion> -x) \<squnion> (-(-(-y) \<squnion> -(-x)) \<squnion> -(-(-y) \<squnion> -x))"
     by simp
   also from huntington have
  "y \<squnion> -y = \<dots>" by simp
   finally show ?thesis by simp
qed

lemma sup_compl: "x \<squnion> -x = \<top>"
by (simp add: top_eq towards_sup_compl)

lemma towards_inf_compl: "x \<sqinter> -x = y \<sqinter> -y"
by (metis dbl_neg inf_eq sup_comm sup_compl)

lemma inf_compl: "x \<sqinter> -x = \<bottom>"
by (metis dbl_neg sup_comm bot_eq towards_inf_compl inf_eq)

lemma towards_idem: "\<bottom> = \<bottom> \<squnion> \<bottom>"
by (metis dbl_neg huntington inf_compl inf_eq sup_assoc sup_comm sup_compl)

lemma sup_ident: "x \<squnion> \<bottom> = x"
by (metis dbl_neg huntington inf_compl inf_eq sup_assoc
          sup_comm sup_compl towards_idem)

lemma inf_ident: "x \<sqinter> \<top> = x"
by (metis dbl_neg inf_compl inf_eq sup_ident sup_comm sup_compl)

lemma sup_idem: "x \<squnion> x = x"
by (metis dbl_neg huntington inf_compl inf_eq sup_ident sup_comm sup_compl)

lemma inf_idem: "x \<sqinter> x = x"
by (metis dbl_neg inf_eq sup_idem)

lemma sup_nil: "x \<squnion> \<top> = \<top>"
by (metis sup_idem sup_assoc sup_comm sup_compl)

lemma inf_nil: "x \<sqinter> \<bottom> = \<bottom>"
by (metis dbl_neg inf_compl inf_eq sup_nil sup_comm sup_compl)

lemma sup_absorb: "x \<squnion> x \<sqinter> y = x"
by (metis huntington inf_eq sup_idem sup_assoc sup_comm)

lemma inf_absorb: "x \<sqinter> (x \<squnion> y) = x"
by (metis dbl_neg inf_eq sup_absorb)

lemma partition: "x \<sqinter> y \<squnion> x \<sqinter> -y = x"
by (metis dbl_neg huntington inf_eq sup_comm)

lemma demorgans1: "-(x \<sqinter> y) = -x \<squnion> -y"
by (metis dbl_neg inf_eq)

lemma demorgans2: "-(x \<squnion> y) = -x \<sqinter> -y"
by (metis dbl_neg inf_eq)

lemma inf_comm: "x \<sqinter> y = y \<sqinter> x"
by (metis inf_eq sup_comm)

lemma inf_assoc: "x \<sqinter> (y \<sqinter> z) = x \<sqinter> y \<sqinter> z"
by (metis dbl_neg inf_eq sup_assoc)

lemma inf_sup_distrib1: "x \<sqinter> (y \<squnion> z) = (x \<sqinter> y) \<squnion> (x \<sqinter> z)"
proof -
  from partition have
  "x \<sqinter> (y \<squnion> z) = x \<sqinter> (y \<squnion> z) \<sqinter> y \<squnion> x \<sqinter> (y \<squnion> z) \<sqinter> -y" ..
  also from inf_assoc have
  "\<dots> = x \<sqinter> ((y \<squnion> z) \<sqinter> y) \<squnion> x \<sqinter> (y \<squnion> z) \<sqinter> -y" by simp
  also from inf_comm have
  "\<dots> = x \<sqinter> (y \<sqinter> (y \<squnion> z)) \<squnion> x \<sqinter> (y \<squnion> z) \<sqinter> -y" by simp
  also from inf_absorb have
  "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> (y \<squnion> z) \<sqinter> -y)" by simp
  also from partition have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       ((x \<sqinter> (y \<squnion> z) \<sqinter> -y \<sqinter> z) \<squnion> (x \<sqinter> (y \<squnion> z) \<sqinter> -y \<sqinter> -z))" by simp
  also from inf_assoc have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> (x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> -z))))" by simp
  also from demorgans2 have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> (x \<sqinter> ((y \<squnion> z) \<sqinter> -(y \<squnion> z))))" by simp
  also from inf_compl have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> (x \<sqinter> \<bottom>))" by simp
  also from inf_nil have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> \<bottom>)" by simp
  also from sup_idem have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       ((x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z))) \<squnion> \<bottom>)" by simp
  also from sup_ident have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       (x \<sqinter> ((y \<squnion> z) \<sqinter> (-y \<sqinter> z)))" by simp
  also from inf_comm have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       (x \<sqinter> ((-y \<sqinter> z) \<sqinter> (y \<squnion> z)))" by simp
  also from sup_comm have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       (x \<sqinter> ((-y \<sqinter> z) \<sqinter> (z \<squnion> y)))" by simp
  also from inf_assoc have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> (y \<sqinter> z)) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion>
       (x \<sqinter> (-y \<sqinter> (z \<sqinter> (z \<squnion> y))))" by simp
  also from inf_absorb have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> (y \<sqinter> z)) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> (x \<sqinter> (-y \<sqinter> z))"
     by simp
  also from inf_comm have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> (z \<sqinter> y)) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> (x \<sqinter> (z \<sqinter> -y))"
     by simp
  also from sup_assoc have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> ((x \<sqinter> (z \<sqinter> y)) \<squnion> (x \<sqinter> y \<sqinter> -z))) \<squnion> (x \<sqinter> (z \<sqinter> -y))"
     by simp
  also from sup_comm have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> ((x \<sqinter> y \<sqinter> -z) \<squnion> (x \<sqinter> (z \<sqinter> y)))) \<squnion> (x \<sqinter> (z \<sqinter> -y))"
     by simp
  also from sup_assoc have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> ((x \<sqinter> (z \<sqinter> y)) \<squnion> (x \<sqinter> (z \<sqinter> -y)))"
     by simp
  also from inf_assoc have
  "\<dots> = ((x \<sqinter> y \<sqinter> z) \<squnion> (x \<sqinter> y \<sqinter> -z)) \<squnion> ((x \<sqinter> z \<sqinter> y) \<squnion> (x \<sqinter> z \<sqinter> -y))" by simp
  also from partition have "\<dots> = (x \<sqinter> y) \<squnion> (x \<sqinter> z)" by simp
  finally show ?thesis by simp
qed

lemma sup_inf_distrib1:
  "x \<squnion> (y \<sqinter> z) = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
proof -
  from dbl_neg have
  "x \<squnion> (y \<sqinter> z) = -(-(-(-x) \<squnion> (y \<sqinter> z)))" by simp
  also from inf_eq have
  "\<dots> = -(-x \<sqinter> (-y \<squnion> -z))" by simp
  also from inf_sup_distrib1 have
  "\<dots> = -((-x \<sqinter> -y) \<squnion> (-x \<sqinter> -z))" by simp
  also from demorgans2 have
  "\<dots> = -(-x \<sqinter> -y) \<sqinter> -(-x \<sqinter> -z)" by simp
  also from demorgans1 have
  "\<dots> = (-(-x) \<squnion> -(-y)) \<sqinter> (-(-x) \<squnion> -(-z))" by simp
  also from dbl_neg have
  "\<dots> = (x \<squnion> y) \<sqinter> (x \<squnion> z)" by simp
  finally show ?thesis by simp
qed

lemma huntington_is_boolean:
   "class.boolean_algebra minus uminus (op \<sqinter>) (op \<sqsubseteq>) (op \<sqsubset>) (op \<squnion>) \<bottom> \<top>"
proof -
  interpret boolean_II:
    boolean_algebra_II uminus "op \<sqinter>" "op \<squnion>" \<bottom> \<top>
      by (fact huntington_is_boolean_II)
  show ?thesis by (simp add: boolean_II.boolean_II_is_boolean)
qed
end

subsection {* Robbins' Algebra *}

context boolean_algebra begin
lemma boolean_is_robbins:
  "class.robbins_algebra uminus inf sup bot top"
apply unfold_locales
apply (metis sup_assoc sup_commute compl_inf double_compl sup_compl_top
             inf_compl_bot diff_eq sup_bot_right sup_inf_distrib1)+
done
end

context boolean_algebra_II begin
lemma boolean_II_is_robbins:
  "class.robbins_algebra uminus inf sup bot top"
proof -
  interpret boolean:
    boolean_algebra minus uminus "op \<sqinter>" "op \<sqsubseteq>" "op \<sqsubset>" "op \<squnion>" \<bottom> \<top>
      by (fact boolean_II_is_boolean)
  show ?thesis by (simp add: boolean.boolean_is_robbins)
qed
end

context huntington_algebra begin
lemma huntington_is_robbins:
  "class.robbins_algebra uminus inf sup bot top"
proof -
  interpret boolean:
    boolean_algebra minus uminus "op \<sqinter>" "op \<sqsubseteq>" "op \<sqsubset>" "op \<squnion>" \<bottom> \<top>
      by (fact huntington_is_boolean)
  show ?thesis by (simp add: boolean.boolean_is_robbins)
qed
end

text {* Before diving into the proof that the Robbins algebra is Boolean,
        we shall present some shorthand machinery *}

context common_algebra begin

(* Iteration Machinery/Shorthand *)

primrec copyp :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<otimes>" 80)
where
  copyp_0:   "0 \<otimes> x = x"
| copyp_Suc: "(Suc k) \<otimes> x = (k \<otimes> x) \<squnion> x"

no_notation
  Product_Type.Times (infixr "\<times>" 80)

primrec copy :: "nat \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<times>" 85)
where
  "0 \<times> x = x"
| "(Suc k) \<times> x = k \<otimes> x"

(* Theorems for translating shorthand into syntax *)

lemma one:  "1 \<times> x = x"
proof -
  have       "1 = Suc(0)" by arith
  hence      "1 \<times> x = Suc(0) \<times> x" by metis
  also have  "\<dots> = x" by simp
  finally show ?thesis by simp
qed

lemma two:  "2 \<times> x = x \<squnion> x"
proof -
  have       "2 = Suc(Suc(0))" by arith
  hence      "2 \<times> x = Suc(Suc(0)) \<times> x" by metis
  also have  "\<dots> = x \<squnion> x" by simp
  finally show ?thesis by simp
qed

lemma three:  "3 \<times> x = x \<squnion> x \<squnion> x"
proof -
   have       "3 = Suc(Suc(Suc(0)))" by arith
   hence      "3 \<times> x = Suc(Suc(Suc(0))) \<times> x" by metis
   also have  "\<dots> = x \<squnion> x \<squnion> x" by simp
   finally show ?thesis by simp
qed

lemma four:  "4 \<times> x = x \<squnion> x \<squnion> x \<squnion> x"
proof -
  have       "4 = Suc(Suc(Suc(Suc(0))))" by arith
  hence      "4 \<times> x = Suc(Suc(Suc(Suc(0)))) \<times> x" by metis
  also have  "\<dots> = x \<squnion> x \<squnion> x \<squnion> x" by simp
  finally show ?thesis by simp
qed

lemma five:  "5 \<times> x = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x"
proof -
  have       "5 = Suc(Suc(Suc(Suc(Suc(0)))))" by arith
  hence      "5 \<times> x = Suc(Suc(Suc(Suc(Suc(0))))) \<times> x" by metis
  also have  "\<dots> = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x" by simp
  finally show ?thesis by simp
qed

lemma six:  "6 \<times> x = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x \<squnion> x"
proof -
  have       "6 = Suc(Suc(Suc(Suc(Suc(Suc(0))))))" by arith
  hence      "6 \<times> x = Suc(Suc(Suc(Suc(Suc(Suc(0)))))) \<times> x" by metis
  also have  "\<dots> = x \<squnion> x \<squnion> x \<squnion> x \<squnion> x \<squnion> x" by simp
  finally show ?thesis by simp
qed

(* Distribution Laws *)

lemma copyp_distrib: "k \<otimes> (x \<squnion> y) = (k \<otimes> x) \<squnion> (k \<otimes> y)"
proof (induct k)
  case 0 show ?case by simp
  case Suc thus ?case by (simp, metis sup_assoc sup_comm)
qed

corollary copy_distrib: "k \<times> (x \<squnion> y) = (k \<times> x) \<squnion> (k \<times> y)"
by (induct k, (simp add: sup_assoc sup_comm copyp_distrib)+)

lemma copyp_arith: "(k + l + 1) \<otimes> x = (k \<otimes> x) \<squnion> (l \<otimes> x)"
proof (induct l)
  case 0 have "k + 0 + 1 = Suc(k)" by arith
    thus ?case by simp
  case (Suc l) note ind_hyp = this
    have "k + Suc(l) + 1 = Suc(k + l + 1)" by arith+
    hence "(k + Suc(l) + 1) \<otimes> x = (k + l + 1) \<otimes> x \<squnion> x" by (simp add: ind_hyp)
    also from ind_hyp have
          "\<dots> = (k \<otimes> x) \<squnion> (l \<otimes> x) \<squnion> x" by simp
    also note sup_assoc
    finally show ?case by simp
qed

lemma copy_arith:
   assumes "k \<noteq> 0" and "l \<noteq> 0"
     shows "(k + l) \<times> x = (k \<times> x) \<squnion> (l \<times> x)"
using assms
proof -
  from assms have "\<exists> k'. Suc(k') = k"
              and "\<exists> l'. Suc(l') = l" by arith+
  from this obtain k' l' where A: "Suc(k') = k"
                           and B: "Suc(l') = l" by fast+
  from this have A1: "k \<times> x = k' \<otimes> x"
             and B1: "l \<times> x = l' \<otimes> x" by fastforce+
  from A B have "k + l = Suc(k' + l' + 1)" by arith
  hence "(k + l) \<times> x = (k' + l' + 1) \<otimes> x" by simp
  also from copyp_arith have
        "\<dots> = k' \<otimes> x \<squnion> l' \<otimes> x" by fast
  also from A1 B1 have
        "\<dots> = k \<times> x \<squnion> l \<times> x" by fastforce
  finally show ?thesis by simp
qed

end

text {* The theorem asserting all Robbins algebras are Boolean
       comes in 6 movements.

       First: The Winker identity is proved.

       Second: Idempotence for a particular object is proved.
       Note that falsum is defined in terms of this object.

       Third: An identity law for falsum is derived.

       Fourth: Idempotence for supremum is derived.

       Fifth: The double negation law is proven

       Sixth: Robbin's algebras are proven to be Huntington Algebras. *}

context robbins_algebra begin

definition secret_object2 :: "'a" ("\<alpha>") where
  "\<alpha> = -(-(\<iota> \<squnion> \<iota> \<squnion> \<iota>) \<squnion> \<iota>)"
definition secret_object3 :: "'a" ("\<beta>") where
  "\<beta> = \<iota> \<squnion> \<iota>"
definition secret_object4 :: "'a" ("\<delta>") where
  "\<delta> = \<beta> \<squnion> (-(\<alpha> \<squnion> -\<beta>) \<squnion> -(\<alpha> \<squnion> -\<beta>))"
definition secret_object5 :: "'a" ("\<gamma>") where
  "\<gamma> = \<delta> \<squnion> -(\<delta> \<squnion> -\<delta>)"
definition winker_object :: "'a" ("\<rho>") where
  "\<rho> = \<gamma> \<squnion> \<gamma> \<squnion> \<gamma>"
definition fake_bot :: "'a" ("\<bottom>\<bottom>") where
  "\<bottom>\<bottom> = -(\<rho> \<squnion> -\<rho>)"

(* Towards Winker's Identity *)

(* These lemmas are due to Alan Mann *)

lemma robbins2: "y = -(-(-x \<squnion> y) \<squnion> -(x \<squnion> y))"
  by (metis robbins sup_comm)

lemma mann0: "-(x \<squnion> y) = -(-(-(x \<squnion> y) \<squnion> -x \<squnion> y) \<squnion> y)"
  by (metis robbins sup_comm sup_assoc)

lemma mann1: "-(-x \<squnion> y) = -(-(-(-x \<squnion> y) \<squnion> x \<squnion> y) \<squnion> y)"
  by (metis robbins sup_comm sup_assoc)

lemma mann2: "y = -(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y))"
  by (metis mann1 robbins sup_comm sup_assoc)

lemma mann3: "z = -(-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> z) \<squnion> -(y \<squnion> z))"
proof -
  let ?w = "-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y)"
  from robbins[where x="z" and y="?w"] sup_comm mann2
  have "z = -(-(y \<squnion> z) \<squnion> -(?w \<squnion> z))" by metis
  thus ?thesis by (metis sup_comm)
qed

lemma mann4: "-(y \<squnion> z) =
  -(-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> -(y \<squnion> z) \<squnion> z) \<squnion> z)"
proof -
 from robbins2[where x="-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> z"
                 and y="-(y \<squnion> z)"]
      mann3[where x="x" and y="y" and z="z"]
 have "-(y \<squnion> z) =
       -(z \<squnion> -(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion> -(-x \<squnion> y) \<squnion> z \<squnion> -(y \<squnion> z)))"
   by metis
 with sup_comm sup_assoc show ?thesis by metis
qed

lemma mann5: "u =
-(-(-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion>
      -(-x \<squnion> y) \<squnion> - (y \<squnion> z) \<squnion> z) \<squnion> z \<squnion> u) \<squnion>
  -(-(y \<squnion> z) \<squnion> u))"
using robbins2[where x="-(-(-(-x \<squnion> y) \<squnion> x \<squnion> y \<squnion> y) \<squnion>
                          -(-x \<squnion> y) \<squnion> -(y \<squnion> z) \<squnion> z) \<squnion> z"
                 and y="u"]
      mann4[where x=x and y=y and z=z]
      sup_comm
by metis

lemma mann6:
"-(- 3\<times>x \<squnion> x) = -(-(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x) \<squnion> -(-(- 3\<times>x \<squnion> x) \<squnion> 5\<times>x))"
proof -
  have "3+2=(5::nat)" and "3\<noteq>(0::nat)" and "2\<noteq>(0::nat)" by arith+
  with copy_arith have \<heartsuit>: "3\<times>x \<squnion> 2\<times>x = 5\<times>x" by metis
  let ?p = "-(- 3\<times>x \<squnion> x)"
  { fix q
    from sup_comm have
    "-(q \<squnion> 5\<times>x) = -(5\<times>x \<squnion> q)" by metis
    also from \<heartsuit> mann0[where x="3\<times>x" and y="q \<squnion> 2\<times>x"] sup_assoc sup_comm have
    "\<dots> = -(-(-(3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))"
      by metis
    also from sup_assoc have
    "\<dots> = -(-(-((3\<times>x \<squnion> q) \<squnion> 2\<times>x) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
    also from sup_comm have
    "\<dots> = -(-(-((q \<squnion> 3\<times>x) \<squnion> 2\<times>x) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
    also from sup_assoc have
    "\<dots> = -(-(-(q \<squnion> (3\<times>x \<squnion> 2\<times>x)) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
    also from \<heartsuit> have
    "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> - 3\<times>x \<squnion> (q \<squnion> 2\<times>x)) \<squnion> (q \<squnion> 2\<times>x))" by metis
    also from sup_assoc have
    "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> (- 3\<times>x \<squnion> q) \<squnion> 2\<times>x) \<squnion> (q \<squnion> 2\<times>x))" by metis
    also from sup_comm have
    "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> (q \<squnion> - 3\<times>x) \<squnion> 2\<times>x) \<squnion> (2\<times>x \<squnion> q))" by metis
    also from sup_assoc have
    "\<dots> = -(-(-(q \<squnion> 5\<times>x) \<squnion> q \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> q)" by metis
    finally have
    "-(q \<squnion> 5\<times>x) = -(-(-(q \<squnion> 5\<times>x) \<squnion> q \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> q)" by simp
  } hence \<spadesuit>:
    "-(?p \<squnion> 5\<times>x) = -(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p)"
    by simp

  from mann5[where x="3\<times>x" and y="x" and z="2\<times>x" and u="?p"]
       sup_assoc three[where x=x] five[where x=x] have
  "?p =
   -(-(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> -(x \<squnion> 2\<times>x) \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p) \<squnion>
     -(-(x \<squnion> 2\<times>x) \<squnion> ?p))" by metis
  also from sup_comm have
  "\<dots> =
   -(-(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> -(2\<times>x \<squnion> x) \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p) \<squnion>
     -(-(2\<times>x \<squnion> x) \<squnion> ?p))" by metis
  also from two[where x=x] three[where x=x] have
  "\<dots> =
   -(-(-(-(?p \<squnion> 5\<times>x) \<squnion> ?p \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> 2\<times>x \<squnion> ?p) \<squnion>
     -(- 3\<times>x \<squnion> ?p))" by metis
  also from \<spadesuit> have "\<dots> = -(-(?p \<squnion> 5\<times>x) \<squnion> -(- 3\<times>x \<squnion> ?p))" by simp
  also from sup_comm have "\<dots> = -(-(?p \<squnion> 5\<times>x) \<squnion> -(?p \<squnion> - 3\<times>x))" by simp
  also from sup_comm have "\<dots> = -(-(?p \<squnion> - 3\<times>x) \<squnion> -(?p \<squnion> 5\<times>x))" by simp
  finally show ?thesis .
qed

lemma mann7:
"- 3\<times>x = -(-(- 3\<times>x \<squnion> x) \<squnion> 5\<times>x)"
proof -
  let ?p = "-(- 3\<times>x \<squnion> x)"
  let ?q = "?p \<squnion> - 3\<times>x"
  let ?r = "-(?p \<squnion> 5\<times>x)"
  from robbins2[where x="?q"
                  and y="?r"]
       mann6[where x=x]
  have "?r = - (?p \<squnion> - (?q \<squnion> ?r))" by simp
  also from sup_comm have "\<dots> = - (- (?q \<squnion> ?r) \<squnion> ?p)" by simp
  also from sup_comm have "\<dots> = - (- (?r \<squnion> ?q) \<squnion> ?p)" by simp
  finally have \<spadesuit>: "?r = - (- (?r \<squnion> ?q) \<squnion> ?p)" .
  from mann3[where x="3\<times>x" and y="x" and z="- 3\<times>x"]
       sup_comm have
       "- 3\<times>x = -(-(-(?p \<squnion> 3\<times>x \<squnion> x \<squnion> x) \<squnion> ?p \<squnion> - 3\<times>x) \<squnion> ?p)" by metis
  also from sup_assoc have
       "\<dots> = -(-(-(?p \<squnion> (3\<times>x \<squnion> x \<squnion> x)) \<squnion> ?q) \<squnion> ?p)" by metis
  also from three[where x=x] five[where x=x] have
       "\<dots> = -(-(?r \<squnion> ?q) \<squnion> ?p)" by metis
  finally have "- 3\<times>x = -(-(?r \<squnion> ?q) \<squnion> ?p)" by metis
  with \<spadesuit> show ?thesis by simp
qed

lemma mann8:
"-(- 3\<times>x \<squnion> x) \<squnion> 2\<times>x = -(-(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x \<squnion> 2\<times>x) \<squnion> - 3\<times>x)"
(is "?lhs = ?rhs")
proof -
  let ?p = "-(- 3\<times>x \<squnion> x)"
  let ?q = "?p \<squnion> 2\<times>x"
  let ?r = "3\<times>x"
  have "3+2=(5::nat)" and "3\<noteq>(0::nat)" and "2\<noteq>(0::nat)" by arith+
  with copy_arith have \<heartsuit>: "3\<times>x \<squnion> 2\<times>x = 5\<times>x" by metis
  from robbins2[where x="?r" and y="?q"] and sup_assoc
  have "?q = -(-(- 3\<times>x \<squnion> ?q) \<squnion> -(3\<times>x \<squnion> ?p \<squnion> 2\<times>x))" by metis
  also from sup_comm have
       "\<dots> = -(-(?q \<squnion> - 3\<times>x) \<squnion> -(?p \<squnion> 3\<times>x \<squnion> 2\<times>x))" by metis
  also from \<heartsuit> sup_assoc have
       "\<dots> = -(-(?q \<squnion> - 3\<times>x) \<squnion> -(?p \<squnion> 5\<times>x))" by metis
  also from mann7[where x=x] have
       "\<dots> = -(-(?q \<squnion> - 3\<times>x) \<squnion> - 3\<times>x)" by metis
  also from sup_assoc have
       "\<dots> = -(-(?p \<squnion> (2\<times>x  \<squnion> - 3\<times>x)) \<squnion> - 3\<times>x)" by metis
  also from sup_comm have
       "\<dots> = -(-(?p \<squnion> (- 3\<times>x  \<squnion> 2\<times>x)) \<squnion> - 3\<times>x)" by metis
  also from sup_assoc have
       "\<dots> = ?rhs" by metis
  finally show ?thesis by simp
qed

lemma mann9: "x = -(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x )"
proof -
  let ?p = "-(- 3\<times>x \<squnion> x)"
  let ?q = "?p \<squnion> 4\<times>x"
  have "4+1=(5::nat)" and "1\<noteq>(0::nat)" and "4\<noteq>(0::nat)" by arith+
  with copy_arith one have \<heartsuit>: "4\<times>x \<squnion> x = 5\<times>x" by metis
  with sup_assoc robbins2[where y=x and x="?q"]
  have "x = -(-(-?q \<squnion> x) \<squnion> -(?p \<squnion> 5\<times>x))" by metis
  with mann7 have "x = -(-(-?q \<squnion> x) \<squnion> - 3\<times>x)" by metis
  moreover
  have "3+1=(4::nat)" and "1\<noteq>(0::nat)" and "3\<noteq>(0::nat)" by arith+
  with copy_arith one have \<spadesuit>: "3\<times>x \<squnion> x = 4\<times>x" by metis
  with mann1[where x="3\<times>x" and y="x"] sup_assoc have
  "-(-?q \<squnion> x) = ?p" by metis
  ultimately show ?thesis by simp
qed

lemma mann10: "y = -(-(-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x \<squnion> y) \<squnion> -(x \<squnion> y))"
using robbins2[where x="-(- 3\<times>x \<squnion> x) \<squnion> - 3\<times>x" and y=y]
      mann9[where x=x]
      sup_comm
by metis

theorem mann: "2\<times>x = -(- 3\<times>x \<squnion> x) \<squnion> 2\<times>x"
using mann10[where x=x and y="2\<times>x"]
      mann8[where x=x]
      two[where x=x] three[where x=x] sup_comm
by metis

corollary winkerr: "\<alpha> \<squnion> \<beta> = \<beta>"
using mann secret_object2_def secret_object3_def two three
by metis

corollary winker: "\<beta> \<squnion> \<alpha> = \<beta>"
  by (metis winkerr sup_comm)

corollary multi_winkerp: "\<beta> \<squnion> k \<otimes> \<alpha> = \<beta>"
  by (induct k, (simp add: winker sup_comm sup_assoc)+)

corollary multi_winker: "\<beta> \<squnion> k \<times> \<alpha> = \<beta>"
  by (induct k, (simp add: multi_winkerp winker sup_comm sup_assoc)+)

(* Towards Idempotence *)

lemma less_eq_introp:
"-(x \<squnion> -(y \<squnion> z)) = -(x \<squnion> y \<squnion> -z) \<Longrightarrow> y \<sqsubseteq> x"
  by (metis robbins sup_assoc less_eq_def
            sup_comm[where x=x and y=y])

corollary less_eq_intro:
"-(x \<squnion> -(y \<squnion> z)) = -(x \<squnion> y \<squnion> -z) \<Longrightarrow> x \<squnion> y = x"
  by (metis less_eq_introp less_eq_def sup_comm)

lemma eq_intro:
"-(x \<squnion> -(y \<squnion> z)) = -(y \<squnion> -(x \<squnion> z)) \<Longrightarrow> x = y"
  by (metis robbins sup_assoc sup_comm)

lemma copyp0:
   assumes "-(x \<squnion> -y) = z"
     shows "-(x \<squnion> -(y \<squnion> k \<otimes> (x \<squnion> z))) = z"
using assms
proof (induct k)
  case 0 show ?case
     by (simp, metis assms robbins sup_assoc sup_comm)
  case Suc note ind_hyp = this
  show ?case
     by (simp, metis ind_hyp robbins sup_assoc sup_comm)
qed

lemma copyp1:
   assumes "-(-(x \<squnion> -y) \<squnion> -y) = x"
     shows "-(y \<squnion> k \<otimes> (x \<squnion> -(x \<squnion> -y))) = -y"
using assms
proof -
  let ?z = "-(x \<squnion> - y)"
  let ?ky = "y \<squnion> k \<otimes> (x \<squnion> ?z)"
  have "-(x \<squnion> -?ky) = ?z" by (simp add: copyp0)
  hence "-(-?ky \<squnion> -(-y \<squnion> ?z)) = ?z" by (metis assms sup_comm)
  also have "-(?z \<squnion> -?ky) = x" by (metis assms copyp0 sup_comm)
  hence "?z = -(-y \<squnion> -(-?ky \<squnion> ?z))" by (metis sup_comm)
  finally show ?thesis by (metis eq_intro)
qed

corollary copyp2:
   assumes "-(x \<squnion> y) = -y"
     shows "-(y \<squnion> k \<otimes> (x \<squnion> -(x \<squnion> -y))) = -y"
   by (metis assms robbins sup_comm copyp1)

lemma two_threep:
   assumes "-(2 \<times> x \<squnion> y) = -y"
       and "-(3 \<times> x \<squnion> y) = -y"
     shows "2 \<times> x \<squnion> y = 3 \<times> x \<squnion> y"
using assms
proof -
  from assms two three have
     A: "-(x \<squnion> x \<squnion> y) = -y" and
     B: "-(x \<squnion> x \<squnion> x \<squnion> y) = -y"  by simp+
  with sup_assoc
       copyp2[where x="x" and y="x \<squnion> x \<squnion> y" and k="0"]
  have "-(x \<squnion> x \<squnion> y \<squnion> x \<squnion> -(x \<squnion> -y)) = -y" by simp
  moreover
  from sup_comm sup_assoc A B
       copyp2[where x="x \<squnion> x" and y="y" and k="0"]
  have "-(y \<squnion> x \<squnion> x \<squnion> -(x \<squnion> x \<squnion> -y)) = -y" by fastforce
  with sup_comm sup_assoc
  have "-(x \<squnion> x \<squnion> y \<squnion> -(x \<squnion> (x \<squnion> -y))) = -y" by metis
  ultimately have
    "-(x \<squnion> x \<squnion> y \<squnion> -(x \<squnion> (x \<squnion> -y))) = -(x \<squnion> x \<squnion> y \<squnion> x \<squnion> -(x \<squnion> -y))" by simp
  with less_eq_intro have "x \<squnion> x \<squnion> y = x \<squnion> x \<squnion> y \<squnion> x" by metis
  with sup_comm sup_assoc two three show ?thesis by metis
qed

lemma two_three:
   assumes "-(x \<squnion> y) = -y \<or> -(-(x \<squnion> -y) \<squnion> -y) = x"
     shows "y \<squnion> 2 \<times> (x \<squnion> -(x \<squnion> -y)) = y \<squnion> 3 \<times> (x \<squnion> -(x \<squnion> -y))"
           (is "y \<squnion> ?z2 = y \<squnion> ?z3")
using assms
proof
    assume "-(x \<squnion> y) = -y"
      with copyp2[where k="Suc(0)"]
           copyp2[where k="Suc(Suc(0))"]
           two three
      have "-(y \<squnion> ?z2) = -y" and "-(y \<squnion> ?z3) = -y" by simp+
      with two_threep sup_comm show ?thesis by metis
  next
    assume "-(-(x \<squnion> -y) \<squnion> -y) = x"
      with copyp1[where k="Suc(0)"]
           copyp1[where k="Suc(Suc(0))"]
           two three
      have "-(y \<squnion> ?z2) = -y" and "-(y \<squnion> ?z3) = -y" by simp+
      with two_threep sup_comm show ?thesis by metis
qed

lemma sup_idem: "\<rho> \<squnion> \<rho> = \<rho>"
proof -
    from winkerr two
         copyp2[where x="\<alpha>" and y="\<beta>" and k="Suc(0)"] have
    "-\<beta> = -(\<beta> \<squnion> 2 \<times> (\<alpha> \<squnion> -(\<alpha> \<squnion> -\<beta>)))" by simp
    also from copy_distrib sup_assoc have
    "\<dots> = -(\<beta> \<squnion> 2 \<times> \<alpha> \<squnion> 2 \<times> (-(\<alpha> \<squnion> -\<beta>)))" by simp
    also from sup_assoc secret_object4_def two
              multi_winker[where k="2"] have
    "\<dots> = -\<delta>" by metis
    finally have "-\<beta> = -\<delta>" by simp
    with secret_object4_def sup_assoc three have
    "\<delta> \<squnion> -(\<alpha> \<squnion> -\<delta>) = \<beta> \<squnion> 3 \<times> (-(\<alpha> \<squnion> -\<beta>))" by simp
    also from copy_distrib[where k="3"]
              multi_winker[where k="3"]
              sup_assoc have
    "\<dots> = \<beta> \<squnion> 3 \<times> (\<alpha> \<squnion> -(\<alpha> \<squnion> -\<beta>))" by metis
    also from winker sup_comm two_three[where x="\<alpha>" and y="\<beta>"] have
    "\<dots> = \<beta> \<squnion> 2 \<times> (\<alpha> \<squnion> -(\<alpha> \<squnion> -\<beta>))" by fastforce
    also from copy_distrib[where k="2"]
              multi_winker[where k="2"]
              sup_assoc two secret_object4_def have
    "\<dots> = \<delta>" by metis
    finally have \<heartsuit>: "\<delta> \<squnion> -(\<alpha> \<squnion> -\<delta>) = \<delta>" by simp
    from secret_object4_def winkerr sup_assoc have
          "\<alpha> \<squnion> \<delta> = \<delta>" by metis
    hence "\<delta> \<squnion> \<alpha> = \<delta>" by (metis sup_comm)
    hence "-(-(\<delta> \<squnion> -\<delta>) \<squnion> -\<delta>) = -(-(\<delta> \<squnion> (\<alpha> \<squnion> -\<delta>)) \<squnion> -\<delta>)" by (metis sup_assoc)
    also from \<heartsuit> have
          "\<dots> = -(-(\<delta> \<squnion> (\<alpha> \<squnion> -\<delta>)) \<squnion> -(\<delta> \<squnion> -(\<alpha> \<squnion> -\<delta>)))" by metis
    also from robbins have
          "\<dots> = \<delta>" by metis
    finally have "-(-(\<delta> \<squnion> -\<delta>) \<squnion> -\<delta>) = \<delta>" by simp
    with two_three[where x="\<delta>" and y="\<delta>"]
         secret_object5_def sup_comm
    have "3 \<times> \<gamma> \<squnion> \<delta> = 2 \<times> \<gamma> \<squnion> \<delta>" by fastforce
    with secret_object5_def sup_assoc sup_comm have
         "3 \<times> \<gamma> \<squnion> \<gamma> = 2 \<times> \<gamma> \<squnion> \<gamma>" by fastforce
    with two three four five six have
         "6 \<times> \<gamma> = 3 \<times> \<gamma>" by simp
    moreover have "3 + 3 = (6::nat)" and "3 \<noteq> (0::nat)" by arith+
    moreover note copy_arith[where k="3" and l="3" and x="\<gamma>"]
                  winker_object_def three
    ultimately show ?thesis by simp
qed

(* Idempotence implies the identity law *)

lemma sup_ident: "x \<squnion> \<bottom>\<bottom> = x"
proof -
  have I: "\<rho> = -(-\<rho> \<squnion> \<bottom>\<bottom>)"
    by (metis fake_bot_def inf_eq robbins sup_comm sup_idem)

  { fix x have "x = -(-(x \<squnion> -\<rho> \<squnion> \<bottom>\<bottom>) \<squnion> -(x \<squnion> \<rho>))"
    by (metis I robbins sup_assoc) }
  note II = this

  have III: "-\<rho> = -(-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>) \<squnion> \<rho>)"
    by (metis robbins[where x="-\<rho>" and y="\<rho> \<squnion> -\<rho>"]
              I sup_comm fake_bot_def)
  hence "\<rho> = -(-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>) \<squnion> -\<rho>)"
    by (metis robbins[where x="\<rho>" and y="\<rho> \<squnion> -\<rho> \<squnion> -\<rho>"]
              sup_comm[where x="\<rho>" and y="-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>)"]
              sup_assoc sup_idem)
  hence "-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>) = \<bottom>\<bottom>"
    by (metis robbins[where x="-(\<rho> \<squnion> -\<rho> \<squnion> -\<rho>)" and y="\<rho>"]
              III sup_comm fake_bot_def)
  hence "-\<rho> = -(\<rho> \<squnion> \<bottom>\<bottom>)"
    by (metis III sup_comm)
  hence "\<rho> = -(-(\<rho> \<squnion> \<bottom>\<bottom>) \<squnion> -(\<rho> \<squnion> \<bottom>\<bottom> \<squnion> -\<rho>))"
    by (metis II sup_idem sup_comm sup_assoc)
  moreover have "\<rho> \<squnion> \<bottom>\<bottom> = -(-(\<rho> \<squnion> \<bottom>\<bottom>) \<squnion> -(\<rho> \<squnion> \<bottom>\<bottom> \<squnion> -\<rho>))"
    by (metis robbins[where x="\<rho> \<squnion> \<bottom>\<bottom>" and y="\<rho>"]
              sup_comm[where y="\<rho>"]
              sup_assoc sup_idem)
  ultimately have "\<rho> = \<rho> \<squnion> \<bottom>\<bottom>" by auto
  hence "x \<squnion> \<bottom>\<bottom> = -(-(x \<squnion> \<rho>) \<squnion> -(x \<squnion> \<bottom>\<bottom> \<squnion> -\<rho>))"
    by (metis robbins[where x="x \<squnion> \<bottom>\<bottom>" and y=\<rho>]
              sup_comm[where x="\<bottom>\<bottom>" and y=\<rho>]
              sup_assoc)
  thus ?thesis by (metis sup_assoc sup_comm II)
qed

(* The identity law implies double negation *)

lemma dbl_neg: "- (-x) = x"
proof -
  { fix x have "\<bottom>\<bottom> = -(-x \<squnion> -(-x))"
      by (metis robbins sup_comm sup_ident)
  } note I = this

  { fix x have "-x = -(-(-x \<squnion> -(-(-x))))"
    by (metis I robbins sup_comm sup_ident)
  } note II = this

  { fix x have "-(-(-x)) = -(-(-x \<squnion> -(-(-x))))"
    by (metis I II robbins sup_assoc sup_comm sup_ident)
  } note III = this

  show ?thesis by (metis II III robbins)
qed

(* Double negation implies Huntington's axiom, hence Boolean*)

theorem robbins_is_huntington:
  "class.huntington_algebra uminus (op \<sqinter>) (op \<squnion>) \<bottom> \<top>"
apply unfold_locales
apply (metis dbl_neg robbins sup_comm)
done

theorem robbins_is_boolean_II:
  "class.boolean_algebra_II uminus (op \<sqinter>) (op \<squnion>) \<bottom> \<top>"
proof -
  interpret huntington:
    huntington_algebra uminus "op \<sqinter>" "op \<squnion>" \<bottom> \<top>
      by (fact robbins_is_huntington)
  show ?thesis by (simp add: huntington.huntington_is_boolean_II)
qed

theorem robbins_is_boolean:
  "class.boolean_algebra minus uminus (op \<sqinter>) (op \<sqsubseteq>) (op \<sqsubset>) (op \<squnion>) \<bottom> \<top>"
proof -
  interpret huntington:
    huntington_algebra uminus "op \<sqinter>" "op \<squnion>" \<bottom> \<top>
      by (fact robbins_is_huntington)
  show ?thesis by (simp add: huntington.huntington_is_boolean)
qed

end

no_notation secret_object1 ("\<iota>")
   and secret_object2 ("\<alpha>")
   and secret_object3 ("\<beta>")
   and secret_object4 ("\<delta>")
   and secret_object5 ("\<gamma>")
   and winker_object ("\<rho>")
   and less_eq  (infix "\<sqsubseteq>" 50)
   and less (infix "\<sqsubset>" 50)
   and inf (infixl "\<sqinter>" 70)
   and sup (infixl "\<squnion>" 65)
   and top ("\<top>")
   and bot ("\<bottom>")
   and copyp (infix "\<otimes>" 80)
   and copy (infix "\<times>" 85)

notation
  Product_Type.Times  (infixr "\<times>" 80)

end