section \<open>Ordinal Partitions\<close>

text \<open>Material from Jean A. Larson,
     A short proof of a partition theorem for the ordinal $\omega^\omega$.
     \emph{Annals of Mathematical Logic}, 6:129--145, 1973.
Also from ``Partition Relations'' by A. Hajnal and J. A. Larson,
in \emph{Handbook of Set Theory}, edited by Matthew Foreman and Akihiro Kanamori
(Springer, 2010).\<close>

theory Partitions
  imports Library_Additions "ZFC_in_HOL.ZFC_Typeclasses" "ZFC_in_HOL.Cantor_NF"

begin

abbreviation tp :: "V set \<Rightarrow> V"
  where "tp A \<equiv> ordertype A VWF"

subsection \<open>Ordinal Partitions: Definitions\<close>

definition partn_lst :: "[('a \<times> 'a) set, 'a set, V list, nat] \<Rightarrow> bool"
  where "partn_lst r B \<alpha> n \<equiv> \<forall>f \<in> [B]\<^bsup>n\<^esup>  \<rightarrow>  {..<length \<alpha>}.
              \<exists>i < length \<alpha>. \<exists>H. H \<subseteq> B \<and> ordertype H r = (\<alpha>!i) \<and> f ` (nsets H n) \<subseteq> {i}"

abbreviation partn_lst_VWF :: "V \<Rightarrow> V list \<Rightarrow> nat \<Rightarrow> bool"
  where "partn_lst_VWF \<beta> \<equiv> partn_lst VWF (elts \<beta>)"

lemma partn_lst_E:
  assumes "partn_lst r B \<alpha> n" "f \<in> nsets B n \<rightarrow>  {..<l}" "l = length \<alpha>"
  obtains i H where "i < l" "H \<subseteq> B"
                     "ordertype H r = \<alpha>!i" "f ` (nsets H n) \<subseteq> {i}"
  using assms by (auto simp: partn_lst_def)

lemma partn_lst_VWF_nontriv:
  assumes "partn_lst_VWF \<beta> \<alpha> n" "l = length \<alpha>" "Ord \<beta>" "l > 0"
  obtains i where "i < l" "\<alpha>!i \<le> \<beta>"
proof -
  have "{..<l} \<noteq> {}"
    by (simp add: \<open>l > 0\<close> lessThan_empty_iff)
  then obtain f where  "f \<in> nsets (elts \<beta>) n  \<rightarrow>  {..<l}"
    by (meson Pi_eq_empty equals0I)
  then obtain i H where "i < l" "H \<subseteq> elts \<beta>" and eq: "tp H = \<alpha>!i"
    using assms by (metis partn_lst_E)
  then have "\<alpha>!i \<le> \<beta>"
    by (metis \<open>H \<subseteq> elts \<beta>\<close> \<open>Ord \<beta>\<close> eq ordertype_le_Ord)
  then show thesis
    using \<open>i < l\<close> that by auto
qed

lemma partn_lst_triv0:
  assumes "\<alpha>!i = 0" "i < length \<alpha>" "n \<noteq> 0"
  shows "partn_lst r B \<alpha> n"
  by (metis partn_lst_def assms bot_least image_empty nsets_empty_iff ordertype_empty)

lemma partn_lst_triv1:
  assumes "\<alpha>!i \<le> 1" "i < length \<alpha>" "n > 1" "B \<noteq> {}" "wf r"
  shows "partn_lst r B \<alpha> n"
  unfolding partn_lst_def
proof clarsimp
  obtain \<gamma> where "\<gamma> \<in> B" "\<alpha> \<noteq> []"
    using assms mem_0_Ord by fastforce
  have 01: "\<alpha>!i = 0 \<or> \<alpha>!i = 1"
    using assms by (fastforce simp: one_V_def)
  fix f
  assume f: "f \<in> [B]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>}"
  with assms have "ordertype {\<gamma>} r = 1 \<and> f ` [{\<gamma>}]\<^bsup>n\<^esup> \<subseteq> {i}"
                  "ordertype {} r = 0 \<and> f ` [{}]\<^bsup>n\<^esup> \<subseteq> {i}"
    by (auto simp: one_V_def ordertype_insert nsets_eq_empty)
  with assms 01 show "\<exists>i<length \<alpha>. \<exists>H\<subseteq>B. ordertype H r = \<alpha> ! i \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {i}"
    using \<open>\<gamma> \<in> B\<close> by auto
qed

lemma partn_lst_two_swap:
  assumes "partn_lst r B [x,y] n" shows "partn_lst r B [y,x] n"
proof -
  { fix f :: "'a set \<Rightarrow> nat"
    assume f: "f \<in> [B]\<^bsup>n\<^esup> \<rightarrow> {..<2}"
    then have f': "(\<lambda>i. 1 - i) \<circ> f \<in> [B]\<^bsup>n\<^esup> \<rightarrow> {..<2}"
      by (auto simp: Pi_def)
    obtain i H where "i<2" "H \<subseteq> B" "ordertype H r = ([x,y]!i)" "((\<lambda>i. 1 - i) \<circ> f) ` (nsets H n) \<subseteq> {i}"
      by (auto intro: partn_lst_E [OF assms f'])
    moreover have "f x = Suc 0" if "Suc 0 \<le> f x" "x\<in>[H]\<^bsup>n\<^esup>" for x
      using f that \<open>H \<subseteq> B\<close> nsets_mono  by (fastforce simp: Pi_iff)
    ultimately have "ordertype H r = [y,x] ! (1-i) \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {1-i}"
      by (force simp: eval_nat_numeral less_Suc_eq)
    then have "\<exists>i H. i<2 \<and> H\<subseteq>B \<and> ordertype H r = [y,x] ! i \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {i}"
      by (metis Suc_1 \<open>H \<subseteq> B\<close> diff_less_Suc) }
  then show ?thesis
    by (auto simp: partn_lst_def eval_nat_numeral)
qed

lemma partn_lst_greater_resource:
  assumes M: "partn_lst r B \<alpha> n" and "B \<subseteq> C"
  shows "partn_lst r C \<alpha> n"
proof (clarsimp simp: partn_lst_def)
  fix f
  assume "f \<in> [C]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>}"
  then have "f \<in> [B]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>}"
    by (metis \<open>B \<subseteq> C\<close> part_fn_def part_fn_subset)
  then obtain i H where "i < length \<alpha>"
                   and "H \<subseteq> B" "ordertype H r = (\<alpha>!i)"
                   and "f ` nsets H n \<subseteq> {i}"
    using M partn_lst_def by metis
  then show "\<exists>i<length \<alpha>. \<exists>H\<subseteq>C. ordertype H r = \<alpha> ! i \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {i}"
    using \<open>B \<subseteq> C\<close> by blast
qed

lemma partn_lst_less:
  assumes M: "partn_lst r B \<alpha> n" and eq: "length \<alpha>' = length \<alpha>" and "List.set \<alpha>' \<subseteq> ON"
    and le: "\<And>i. i < length \<alpha> \<Longrightarrow> \<alpha>'!i \<le> \<alpha>!i "
    and r: "wf r" "trans r" "total_on B r" and "small B"
  shows "partn_lst r B \<alpha>' n"
proof (clarsimp simp: partn_lst_def)
  fix f
  assume "f \<in> [B]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>'}"
  then obtain i H where "i < length \<alpha>"
                   and "H \<subseteq> B" "small H" and H: "ordertype H r = (\<alpha>!i)"
                   and fi: "f ` nsets H n \<subseteq> {i}"
    using assms by (auto simp: partn_lst_def smaller_than_small)
  then have bij: "bij_betw (ordermap H r) H (elts (\<alpha>!i))"
    using ordermap_bij [of r H] r
    by (smt \<open>small B\<close> in_mono smaller_than_small total_on_def)
  define H' where "H' = inv_into H (ordermap H r) ` (elts (\<alpha>'!i))"
  have "H' \<subseteq> H"
    using bij \<open>i < length \<alpha>\<close> bij_betw_imp_surj_on le
    by (force simp: H'_def image_subset_iff intro: inv_into_into)
  moreover have ot: "ordertype H' r = (\<alpha>'!i)"
  proof (subst ordertype_eq_iff)
    show "Ord (\<alpha>' ! i)"
      using assms by (simp add: \<open>i < length \<alpha>\<close> subset_eq)
    show "small H'"
      by (simp add: H'_def)
    show "\<exists>f. bij_betw f H' (elts (\<alpha>' ! i)) \<and> (\<forall>x\<in>H'. \<forall>y\<in>H'. (f x < f y) = ((x, y) \<in> r))"
    proof (intro exI conjI ballI)
      show "bij_betw (ordermap H r) H' (elts (\<alpha>' ! i))"
        using \<open>H' \<subseteq> H\<close>
        by (metis H'_def \<open>i < length \<alpha>\<close> bij bij_betw_inv_into_RIGHT bij_betw_subset le less_eq_V_def)
      show "(ordermap H r x < ordermap H r y) = ((x, y) \<in> r)"
        if "x \<in> H'" "y \<in> H'" for x y
      proof (intro iffI ordermap_mono_less)
        assume "ordermap H r x < ordermap H r y"
        then show "(x, y) \<in> r"
          by (metis \<open>H \<subseteq> B\<close> \<open>small H\<close> \<open>H' \<subseteq> H\<close> leD ordermap_mono_le r subsetD that total_on_def)
      qed (use assms that \<open>H' \<subseteq> H\<close> \<open>small H\<close> in auto)
    qed
    show "total_on H' r"
      using r by (meson \<open>H \<subseteq> B\<close> \<open>H' \<subseteq> H\<close> subsetD total_on_def)
  qed (use r in auto)
  ultimately show "\<exists>i<length \<alpha>'. \<exists>H\<subseteq>B. ordertype H r = \<alpha>' ! i \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {i}"
    using \<open>H \<subseteq> B\<close> \<open>i < length \<alpha>\<close> fi assms
    by (metis image_mono nsets_mono subset_trans)
qed

text \<open>Holds because no $n$-sets exist!\<close>
lemma partn_lst_VWF_degenerate:
  assumes "k < n"
  shows "partn_lst_VWF \<omega> (ord_of_nat k # \<alpha>s) n"
proof (clarsimp simp: partn_lst_def)
  fix f :: "V set \<Rightarrow> nat"
  have "[elts (ord_of_nat k)]\<^bsup>n\<^esup> = {}"
    by (simp add: nsets_eq_empty assms finite_Ord_omega)
  then have "f ` [elts (ord_of_nat k)]\<^bsup>n\<^esup> \<subseteq> {0}"
    by auto
  then show "\<exists>i < Suc (length \<alpha>s). \<exists>H\<subseteq>elts \<omega>. tp H = (ord_of_nat k # \<alpha>s) ! i \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {i}"
    using assms ordertype_eq_Ord [of "ord_of_nat k"] elts_ord_of_nat less_Suc_eq_0_disj
    by fastforce
qed

lemma partn_lst_VWF_\<omega>_2:
  assumes "Ord \<alpha>"
  shows "partn_lst_VWF (\<omega> \<up> (1+\<alpha>)) [2, \<omega> \<up> (1+\<alpha>)] 2" (is  "partn_lst_VWF ?\<beta> _ _")
proof (clarsimp simp: partn_lst_def)
  fix f
  assume f: "f \<in> [elts ?\<beta>]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
  show "\<exists>i<Suc (Suc 0). \<exists>H\<subseteq>elts ?\<beta>. tp H = [2, ?\<beta>] ! i \<and> f ` [H]\<^bsup>2\<^esup> \<subseteq> {i}"
  proof (cases "\<exists>x \<in> elts ?\<beta>. \<exists>y \<in> elts ?\<beta>. x \<noteq> y \<and> f{x,y} = 0")
    case True
    then obtain x y where "x \<in> elts ?\<beta>" "y \<in> elts ?\<beta>" "x \<noteq> y" "f {x, y} = 0"
      by auto
    then have "{x,y} \<subseteq> elts ?\<beta>" "tp {x,y} = 2" "f ` [{x, y}]\<^bsup>2\<^esup> \<subseteq> {0}"
      by auto (simp add: eval_nat_numeral ordertype_VWF_finite_nat)
    with \<open>x \<noteq> y\<close> show ?thesis
      by (metis nth_Cons_0 zero_less_Suc)
  next
    case False
    with f have "\<forall>x\<in>elts ?\<beta>. \<forall>y\<in>elts ?\<beta>. x \<noteq> y \<longrightarrow> f {x, y} = 1"
      unfolding Pi_iff using lessThan_Suc by force
    then have "tp (elts ?\<beta>) = ?\<beta>" "f ` [elts ?\<beta>]\<^bsup>2\<^esup> \<subseteq> {Suc 0}"
      by (auto simp: assms nsets_2_eq)
    then show ?thesis
      by (metis lessI nth_Cons_0 nth_Cons_Suc subsetI)
  qed
qed

subsection \<open>Relating partition properties on @{term VWF} to the general case\<close>

text \<open>Two very similar proofs here!\<close>

lemma partn_lst_imp_partn_lst_VWF_eq:
  assumes part: "partn_lst r U \<alpha> n" and \<beta>: "ordertype U r = \<beta>" and "small U"
    and r: "wf r" "trans r" "total_on U r"
  shows "partn_lst_VWF \<beta> \<alpha> n"
  unfolding partn_lst_def
proof clarsimp
  fix f
  assume f: "f \<in> [elts \<beta>]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>}"
  define cv where "cv \<equiv> \<lambda>X. ordermap U r ` X"
  have bij: "bij_betw (ordermap U r) U (elts \<beta>)"
    using ordermap_bij [of "r" U] assms by blast
  then have bij_cv: "bij_betw cv ([U]\<^bsup>n\<^esup>) ([elts \<beta>]\<^bsup>n\<^esup>)"
    using bij_betw_nsets cv_def by blast
  then have func: "f \<circ> cv \<in> [U]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>}" and "inj_on (ordermap U r) U"
    using bij bij_betw_def bij_betw_apply f by fastforce+
  then have cv_part: "\<lbrakk>\<forall>x\<in>[X]\<^bsup>n\<^esup>. f (cv x) = i; X \<subseteq> U; a \<in> [cv X]\<^bsup>n\<^esup>\<rbrakk> \<Longrightarrow> f a = i" for a X i n
    by (force simp: cv_def nsets_def subset_image_iff inj_on_subset finite_image_iff card_image)
  have ot_eq [simp]: "tp (cv X) = ordertype X r" if "X \<subseteq> U" for X
    unfolding cv_def
    by (meson \<open>small U\<close> ordertype_image_ordermap r that total_on_subset)
  obtain X i where "X \<subseteq> U" and X: "ordertype X r = \<alpha>!i" "(f \<circ> cv) ` [X]\<^bsup>n\<^esup> \<subseteq> {i}"
    and "i < length \<alpha>"
    using part func by (auto simp: partn_lst_def)
  show "\<exists>i < length \<alpha>. \<exists>H\<subseteq>elts \<beta>. tp H = \<alpha>!i \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {i}"
  proof (intro exI conjI)
    show "i < length \<alpha>"
      by (simp add: \<open>i < length \<alpha>\<close>)
    show "cv X \<subseteq> elts \<beta>"
      using \<open>X \<subseteq> U\<close> bij bij_betw_imp_surj_on cv_def by blast
    show "tp (cv X) = \<alpha> ! i"
      by (simp add: X(1) \<open>X \<subseteq> U\<close>)
    show "f ` [cv X]\<^bsup>n\<^esup> \<subseteq> {i}"
      using X \<open>X \<subseteq> U\<close> cv_part unfolding image_subset_iff cv_def
      by (metis comp_apply insertCI singletonD)
  qed
qed

lemma partn_lst_imp_partn_lst_VWF:
  assumes part: "partn_lst r U \<alpha> n" and \<beta>: "ordertype U r \<le> \<beta>" "small U"
    and r: "wf r" "trans r" "total_on U r"
  shows "partn_lst_VWF \<beta> \<alpha> n"
  by (metis assms less_eq_V_def partn_lst_imp_partn_lst_VWF_eq partn_lst_greater_resource)

lemma partn_lst_VWF_imp_partn_lst_eq:
  assumes part: "partn_lst_VWF \<beta> \<alpha> n" and \<beta>: "ordertype U r = \<beta>" "small U"
    and r: "wf r" "trans r" "total_on U r"
  shows "partn_lst r U \<alpha> n"
  unfolding partn_lst_def
proof clarsimp
  fix f
  assume f: "f \<in> [U]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>}"
  define cv where "cv \<equiv> \<lambda>X. inv_into U (ordermap U r) ` X"
  have bij: "bij_betw (ordermap U r) U (elts \<beta>)"
    using ordermap_bij [of "r" U] assms by blast
  then have bij_cv: "bij_betw cv ([elts \<beta>]\<^bsup>n\<^esup>) ([U]\<^bsup>n\<^esup>)"
    using bij_betw_nsets bij_betw_inv_into unfolding cv_def by blast
  then have func: "f \<circ> cv \<in> [elts \<beta>]\<^bsup>n\<^esup> \<rightarrow> {..<length \<alpha>}"
    using bij_betw_apply f by fastforce
  have "inj_on (ordermap U r) U"
    using bij bij_betw_def by blast
  then have cv_part: "\<lbrakk>\<forall>x\<in>[X]\<^bsup>n\<^esup>. f (cv x) = i; X \<subseteq> elts \<beta>; a \<in> [cv X]\<^bsup>n\<^esup>\<rbrakk> \<Longrightarrow> f a = i" for a X i n
    by (metis bij bij_betw_imp_surj_on cv_def inj_on_inv_into nset_image_obtains)
  have ot_eq [simp]: "ordertype (cv X) r = tp X" if "X \<subseteq> elts \<beta>" for X
    unfolding cv_def
  proof (rule ordertype_inc_eq)
    show "small X"
      using down that by auto
    show "(inv_into U (ordermap U r) x, inv_into U (ordermap U r) y) \<in> r"
      if "x \<in> X" "y \<in> X" and "(x,y) \<in> VWF" for x y
    proof -
      have xy: "x \<in> ordermap U r ` U" "y \<in> ordermap U r ` U"
        using \<open>X \<subseteq> elts \<beta>\<close> \<open>x \<in> X\<close> \<open>y \<in> X\<close> bij bij_betw_imp_surj_on by blast+
      then have eq: "ordermap U r (inv_into U (ordermap U r) x) = x" "ordermap U r (inv_into U (ordermap U r) y) = y"
        by (meson f_inv_into_f)+
      then have "y \<notin> elts x"
        by (metis (no_types) VWF_non_refl mem_imp_VWF that(3) trans_VWF trans_def)
      with r show ?thesis
        by (metis (no_types) VWF_non_refl xy eq assms(3) inv_into_into ordermap_mono that(3) total_on_def)
    qed
  qed (use r in auto)
  obtain X i where "X \<subseteq> elts \<beta>" and X: "tp X = \<alpha>!i" "(f \<circ> cv) ` [X]\<^bsup>n\<^esup> \<subseteq> {i}"
    and "i < length \<alpha>"
    using part func by (auto simp: partn_lst_def)
  show "\<exists>i < length \<alpha>. \<exists>H\<subseteq>U. ordertype H r = \<alpha>!i \<and> f ` [H]\<^bsup>n\<^esup> \<subseteq> {i}"
  proof (intro exI conjI)
    show "i < length \<alpha>"
      by (simp add: \<open>i < length \<alpha>\<close>)
    show "cv X \<subseteq> U"
      using \<open>X \<subseteq> elts \<beta>\<close> bij bij_betw_imp_surj_on bij_betw_inv_into cv_def by blast
    show "ordertype (cv X) r = \<alpha> ! i"
      by (simp add: X(1) \<open>X \<subseteq> elts \<beta>\<close>)
    show "f ` [cv X]\<^bsup>n\<^esup> \<subseteq> {i}"
      using X \<open>X \<subseteq> elts \<beta>\<close> cv_part unfolding image_subset_iff cv_def
      by (metis comp_apply insertCI singletonD)
  qed
qed

corollary partn_lst_VWF_imp_partn_lst:
  assumes "partn_lst_VWF \<beta> \<alpha> n" and \<beta>: "ordertype U r \<ge> \<beta>" "small U"
          "wf r" "trans r" "total_on U r"
  shows "partn_lst r U \<alpha> n"
  by (metis assms less_eq_V_def partn_lst_VWF_imp_partn_lst_eq partn_lst_greater_resource)

subsection \<open>Simple consequences of the definitions\<close>

text \<open>A restatement of the infinite Ramsey theorem using partition notation\<close>
lemma Ramsey_partn: "partn_lst_VWF \<omega> [\<omega>,\<omega>] 2"
proof (clarsimp simp: partn_lst_def)
  fix f
  assume "f \<in> [elts \<omega>]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
  then have *: "\<forall>x\<in>elts \<omega>. \<forall>y\<in>elts \<omega>. x \<noteq> y \<longrightarrow> f {x, y} < 2"
    by (auto simp: nsets_def eval_nat_numeral)
  obtain H i where H: "H \<subseteq> elts \<omega>" and "infinite H"
    and t: "i < Suc (Suc 0)"
    and teq: "\<forall>x\<in>H. \<forall>y\<in>H. x \<noteq> y \<longrightarrow> f {x, y} = i"
    using Ramsey2 [OF infinite_\<omega> *] by (auto simp: eval_nat_numeral)
  then have "tp H = [\<omega>, \<omega>] ! i"
    using less_2_cases eval_nat_numeral ordertype_infinite_\<omega> by force
  moreover have "f ` {N. N \<subseteq> H \<and> finite N \<and> card N = 2} \<subseteq> {i}"
    by (force simp: teq card_2_iff)
  ultimately have "f ` [H]\<^bsup>2\<^esup> \<subseteq> {i}"
    by (metis (no_types) nsets_def numeral_2_eq_2)
  then show "\<exists>i<Suc (Suc 0). \<exists>H\<subseteq>elts \<omega>. tp H = [\<omega>,\<omega>] ! i \<and> f ` [H]\<^bsup>2\<^esup> \<subseteq> {i}"
    using H \<open>tp H = [\<omega>, \<omega>] ! i\<close> t by blast
qed

text \<open>This is the counterexample sketched in Hajnal and Larson, section 9.1.\<close>
proposition omega_basic_counterexample:
  assumes "Ord \<alpha>"
  shows "\<not> partn_lst_VWF \<alpha> [succ (vcard \<alpha>), \<omega>] 2"
proof -
  obtain \<pi> where fun\<pi>: "\<pi> \<in> elts \<alpha> \<rightarrow> elts (vcard \<alpha>)" and inj\<pi>: "inj_on \<pi> (elts \<alpha>)"
    using inj_into_vcard by auto
  have Ord\<pi>: "Ord (\<pi> x)" if "x \<in> elts \<alpha>" for x
    using Ord_in_Ord fun\<pi> that by fastforce
  define f where "f A \<equiv> @i::nat. \<exists>x y. A = {x,y} \<and> x < y \<and> (\<pi> x < \<pi> y \<and> i=0 \<or> \<pi> y < \<pi> x \<and> i=1)" for A
  have f_Pi: "f \<in> [elts \<alpha>]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
  proof
    fix A
    assume "A \<in> [elts \<alpha>]\<^bsup>2\<^esup>"
    then obtain x y where xy: "x \<in> elts \<alpha>" "y \<in> elts \<alpha>" "x < y" and A: "A = {x,y}"
      apply (clarsimp simp: nsets_2_eq)
      by (metis Ord_in_Ord Ord_linear_lt assms insert_commute)
    consider "\<pi> x < \<pi> y" | "\<pi> y < \<pi> x"
      by (metis Ord\<pi> Ord_linear_lt inj\<pi> inj_onD less_imp_not_eq2 xy)
    then show "f A \<in> {..<Suc (Suc 0)}"
      by (metis A One_nat_def lessI lessThan_iff zero_less_Suc \<open>x < y\<close> A exE_some [OF _ f_def])
  qed
  have fiff: "\<pi> x < \<pi> y \<and> i=0 \<or> \<pi> y < \<pi> x \<and> i=1"
    if f: "f {x,y} = i" and xy: "x \<in> elts \<alpha>" "y \<in> elts \<alpha>" "x<y" for x y i
  proof -
    consider "\<pi> x < \<pi> y" | "\<pi> y < \<pi> x"
      using xy by (metis Ord\<pi> Ord_linear_lt inj\<pi> inj_onD less_V_def)
    then show ?thesis
    proof cases
      case 1
      then have "f{x,y} = 0"
        using \<open>x<y\<close> by (force simp: f_def Set.doubleton_eq_iff)
    then show ?thesis
      using "1" f by auto
    next
      case 2
      then have "f{x,y} = 1"
      using \<open>x<y\<close> by (force simp: f_def Set.doubleton_eq_iff)
    then show ?thesis
      using "2" f by auto
    qed
  qed
  have False
    if eq: "tp H = succ (vcard \<alpha>)" and H: "H \<subseteq> elts \<alpha>"
    and 0: "\<And>A. A \<in> [H]\<^bsup>2\<^esup> \<Longrightarrow> f A = 0" for H
  proof -
    have [simp]: "small H"
      using H down by auto
    have OH: "Ord x" if "x \<in> H" for x
      using H Ord_in_Ord \<open>Ord \<alpha>\<close> that by blast
    have \<pi>: "\<pi> x < \<pi> y" if "x\<in>H" "y\<in>H" "x<y" for x y
      using 0 [of "{x,y}"] that H fiff by (fastforce simp: nsets_2_eq)
    have sub_vcard: "\<pi> ` H \<subseteq> elts (vcard \<alpha>)"
      using H fun\<pi> by auto
    have "tp H = tp (\<pi> ` H)"
    proof (rule ordertype_VWF_inc_eq [symmetric])
      show "\<pi> ` H \<subseteq> ON"
      using H Ord\<pi> by blast
    qed (auto simp: \<pi> OH subsetI)
    also have "\<dots> \<le> vcard \<alpha>"
      by (simp add: H sub_vcard assms ordertype_le_Ord)
    finally show False
      by (simp add: eq succ_le_iff)
  qed
  moreover have False
    if eq: "tp H = \<omega>" and H: "H \<subseteq> elts \<alpha>"
      and 1: "\<And>A. A \<in> [H]\<^bsup>2\<^esup> \<Longrightarrow> f A = Suc 0" for H
  proof -
    have [simp]: "small H"
      using H down by auto
    define \<eta> where "\<eta> \<equiv> inv_into H (ordermap H VWF) \<circ> ord_of_nat"
    have bij: "bij_betw (ordermap H VWF) H (elts \<omega>)"
      by (metis ordermap_bij \<open>small H\<close> eq total_on_VWF wf_VWF)
    then have "bij_betw (inv_into H (ordermap H VWF)) (elts \<omega>) H"
      by (simp add: bij_betw_inv_into)
    then have \<eta>: "bij_betw \<eta> UNIV H"
      unfolding \<eta>_def
      by (metis \<omega>_def bij_betw_comp_iff2 bij_betw_def elts_of_set inf inj_ord_of_nat order_refl)
    moreover have Ord\<eta>: "Ord (\<eta> k)" for k
      by (meson H Ord_in_Ord UNIV_I \<eta> assms bij_betw_apply subsetD)
    moreover obtain k where k: "(\<pi> (\<eta>(Suc k)), \<pi> (\<eta> k)) \<notin> VWF"
      by (meson wf_VWF wf_iff_no_infinite_down_chain)
    moreover have \<pi>: "\<pi> y < \<pi> x" if "x\<in>H" "y\<in>H" "x<y" for x y
      using 1 [of "{x,y}"] that H fiff by (fastforce simp: nsets_2_eq)
    ultimately have "\<eta> (Suc k) \<le> \<eta> k"
      by (metis H Ord\<pi> Ord_linear2 VWF_iff_Ord_less bij_betw_def rangeI subset_iff)
    then have "(\<eta> (Suc k), \<eta> k) \<in> VWF \<or> \<eta> (Suc k) = \<eta> k"
      using Ord\<eta> Ord_mem_iff_lt by auto
    then have "ordermap H VWF (\<eta> (Suc k)) \<le> ordermap H VWF (\<eta> k)"
      by (metis \<eta> \<open>small H\<close> bij_betw_imp_surj_on ordermap_mono_le rangeI trans_VWF wf_VWF)
    moreover have "ordermap H VWF (\<eta> (Suc k)) = succ (ord_of_nat k)"
      unfolding \<eta>_def using bij bij_betw_inv_into_right by force
    moreover have "ordermap H VWF (\<eta> k) = ord_of_nat k"
      using \<eta>_def bij bij_betw_inv_into_right by force
    ultimately show False
      by (simp add: less_eq_V_def)
  qed
  ultimately show ?thesis
    apply (simp add: partn_lst_def image_subset_iff)
    by (metis f_Pi less_2_cases nth_Cons_0 nth_Cons_Suc numeral_2_eq_2)
qed

subsection \<open>Specker's theorem\<close>

definition form_split :: "[nat,nat,nat,nat,nat] \<Rightarrow> bool" where
  "form_split a b c d i \<equiv> a \<le> c \<and> (i=0 \<and> a<b \<and> b<c \<and> c<d \<or>
                                    i=1 \<and> a<c \<and> c<b \<and> b<d \<or>
                                    i=2 \<and> a<c \<and> c<d \<and> d<b \<or>
                                    i=3 \<and> a=c \<and> b\<noteq>d)"

definition form :: "[(nat*nat)set, nat] \<Rightarrow> bool" where
  "form u i \<equiv> \<exists>a b c d. u = {(a,b),(c,d)} \<and> form_split a b c d i"

definition scheme :: "[(nat*nat)set] \<Rightarrow> nat set" where
  "scheme u \<equiv> fst ` u \<union> snd ` u"

definition UU :: "(nat*nat) set"
  where "UU \<equiv> {(a,b). a < b}"

lemma ordertype_UNIV_\<omega>2: "ordertype UNIV pair_less = \<omega>\<up>2"
  using ordertype_Times [of concl: UNIV UNIV less_than less_than]
  by (simp add: total_less_than pair_less_def ordertype_nat_\<omega> numeral_2_eq_2)

lemma ordertype_UU_ge_\<omega>2:  "ordertype UNIV pair_less \<le> ordertype UU pair_less"
proof (rule ordertype_inc_le)
  define \<pi> where "\<pi> \<equiv> \<lambda>(m,n). (m, Suc (m+n))"
  show "(\<pi> (x::nat \<times> nat), \<pi> y) \<in> pair_less" if "(x, y) \<in> pair_less" for x y
    using that by (auto simp: \<pi>_def pair_less_def split: prod.split)
  show "range \<pi> \<subseteq> UU"
    by (auto simp: \<pi>_def UU_def)
qed auto

lemma ordertype_UU_\<omega>2: "ordertype UU pair_less = \<omega>\<up>2"
  by (metis eq_iff ordertype_UNIV_\<omega>2 ordertype_UU_ge_\<omega>2 ordertype_mono small top_greatest trans_pair_less wf_pair_less)

text \<open>Lemma 2.3 of Jean A. Larson,
     A short proof of a partition theorem for the ordinal $\omega^\omega$.
     \emph{Annals of Mathematical Logic}, 6:129--145, 1973.\<close>
lemma lemma_2_3:
  fixes f :: "(nat \<times> nat) set \<Rightarrow> nat"
  assumes "f \<in> [UU]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
  obtains N js where "infinite N" and "\<And>k u. \<lbrakk>k < 4; u \<in> [UU]\<^bsup>2\<^esup>; form u k; scheme u \<subseteq> N\<rbrakk> \<Longrightarrow> f u = js!k"
proof -
  have f_less2: "f {p,q} < Suc (Suc 0)" if "p \<noteq> q" "p \<in> UU" "q \<in> UU" for p q
  proof -
    have "{p,q} \<in> [UU]\<^bsup>2\<^esup>"
      using that by (simp add: nsets_def)
    then show ?thesis
      using assms by (simp add: Pi_iff)
  qed
  define f0 where "f0 \<equiv> (\<lambda>A::nat set. THE x. \<exists>a b c d. A = {a,b,c,d} \<and> a<b \<and> b<c \<and> c<d \<and> x = f {(a,b),(c,d)})"
  have f0: "f0 {a,b,c,d} = f {(a,b),(c,d)}" if "a<b" "b<c" "c<d" for a b c d
    unfolding f0_def
    apply (rule theI2 [where a = "f {(a,b), (c,d)}"])
    using that by (force simp: insert_eq_iff split: if_split_asm)+
  have "f0 X < Suc (Suc 0)"
    if "finite X" and "card X = 4" for X
  proof -
    have "X \<in> [X]\<^bsup>4\<^esup>"
      using that by (auto simp: nsets_def)
    then obtain a b c d where "X = {a,b,c,d} \<and> a<b \<and> b<c \<and> c<d"
      by (auto simp: ordered_nsets_4_eq)
    then show ?thesis
      using f0 f_less2 by (auto simp: UU_def)
  qed
  then have "\<exists>N t. infinite N \<and> t < Suc (Suc 0)
            \<and> (\<forall>X. X \<subseteq> N \<and> finite X \<and> card X = 4 \<longrightarrow> f0 X = t)"
    using Ramsey [of UNIV 4 f0 2] by (simp add: eval_nat_numeral)
  then obtain N0 j0 where "infinite N0" and j0: "j0 < Suc (Suc 0)" and N0: "\<And>A. A \<in> [N0]\<^bsup>4\<^esup> \<Longrightarrow> f0 A = j0"
    by (auto simp: nsets_def)

  define f1 where "f1 \<equiv> (\<lambda>A::nat set. THE x. \<exists>a b c d. A = {a,b,c,d} \<and> a<b \<and> b<c \<and> c<d \<and> x = f {(a,c),(b,d)})"
  have f1: "f1 {a,b,c,d} = f {(a,c),(b,d)}" if "a<b" "b<c" "c<d" for a b c d
    unfolding f1_def
    apply (rule theI2 [where a = "f {(a,c), (b,d)}"])
    using that by (force simp: insert_eq_iff split: if_split_asm)+
  have "f1 X < Suc (Suc 0)"
    if "finite X" and "card X = 4" for X
  proof -
    have "X \<in> [X]\<^bsup>4\<^esup>"
      using that by (auto simp: nsets_def)
    then obtain a b c d where "X = {a,b,c,d} \<and> a<b \<and> b<c \<and> c<d"
      by (auto simp: ordered_nsets_4_eq)
    then show ?thesis
      using f1 f_less2 by (auto simp: UU_def)
  qed
  then have "\<exists>N t. N \<subseteq> N0 \<and> infinite N \<and> t < Suc (Suc 0)
            \<and> (\<forall>X. X \<subseteq> N \<and> finite X \<and> card X = 4 \<longrightarrow> f1 X = t)"
    using \<open>infinite N0\<close> Ramsey [of N0 4 f1 2] by (simp add: eval_nat_numeral)
  then obtain N1 j1 where "N1 \<subseteq> N0" "infinite N1" and j1: "j1 < Suc (Suc 0)" and N1: "\<And>A. A \<in> [N1]\<^bsup>4\<^esup> \<Longrightarrow> f1 A = j1"
    by (auto simp: nsets_def)

  define f2 where "f2 \<equiv> (\<lambda>A::nat set. THE x. \<exists>a b c d. A = {a,b,c,d} \<and> a<b \<and> b<c \<and> c<d \<and> x = f {(a,d),(b,c)})"
  have f2: "f2 {a,b,c,d} = f {(a,d),(b,c)}" if "a<b" "b<c" "c<d" for a b c d
    unfolding f2_def
    apply (rule theI2 [where a = "f {(a,d), (b,c)}"])
    using that by (force simp: insert_eq_iff split: if_split_asm)+
  have "f2 X < Suc (Suc 0)"
    if "finite X" and "card X = 4" for X
  proof -
    have "X \<in> [X]\<^bsup>4\<^esup>"
      using that by (auto simp: nsets_def)
    then obtain a b c d where "X = {a,b,c,d} \<and> a<b \<and> b<c \<and> c<d"
      by (auto simp: ordered_nsets_4_eq)
    then show ?thesis
      using f2 f_less2 by (auto simp: UU_def)
  qed
  then have "\<exists>N t. N \<subseteq> N1 \<and> infinite N \<and> t < Suc (Suc 0)
            \<and> (\<forall>X. X \<subseteq> N \<and> finite X \<and> card X = 4 \<longrightarrow> f2 X = t)"
    using \<open>infinite N1\<close> Ramsey [of N1 4 f2 2] by (simp add: eval_nat_numeral)
  then obtain N2 j2 where "N2 \<subseteq> N1" "infinite N2" and j2: "j2 < Suc (Suc 0)" and N2: "\<And>A. A \<in> [N2]\<^bsup>4\<^esup> \<Longrightarrow> f2 A = j2"
    by (auto simp: nsets_def)

  define f3 where "f3 \<equiv> (\<lambda>A::nat set. THE x. \<exists>a b c. A = {a,b,c} \<and> a<b \<and> b<c \<and> x = f {(a,b),(a,c)})"
  have f3: "f3 {a,b,c} = f {(a,b),(a,c)}" if "a<b" "b<c" for a b c
    unfolding f3_def
    apply (rule theI2 [where a = "f {(a,b), (a,c)}"])
    using that by (force simp: insert_eq_iff split: if_split_asm)+
  have f3': "f3 {a,b,c} = f {(a,b),(a,c)}" if "a<c" "c<b" for a b c
    using f3 [of a c b] that
    by (simp add: insert_commute)
  have "f3 X < Suc (Suc 0)"
    if "finite X" and "card X = 3" for X
  proof -
    have "X \<in> [X]\<^bsup>3\<^esup>"
      using that by (auto simp: nsets_def)
    then obtain a b c where "X = {a,b,c} \<and> a<b \<and> b<c"
      by (auto simp: ordered_nsets_3_eq)
    then show ?thesis
      using f3 f_less2 by (auto simp: UU_def)
  qed
  then have "\<exists>N t. N \<subseteq> N2 \<and> infinite N \<and> t < Suc (Suc 0)
            \<and> (\<forall>X. X \<subseteq> N \<and> finite X \<and> card X = 3 \<longrightarrow> f3 X = t)"
    using \<open>infinite N2\<close> Ramsey [of N2 3 f3 2] by (simp add: eval_nat_numeral)
  then obtain N3 j3 where "N3 \<subseteq> N2" "infinite N3" and j3: "j3 < Suc (Suc 0)" and N3: "\<And>A. A \<in> [N3]\<^bsup>3\<^esup> \<Longrightarrow> f3 A = j3"
    by (auto simp: nsets_def)

  show thesis
  proof
    fix k u
    assume "k < 4"
      and u: "form u k" "scheme u \<subseteq> N3"
      and UU: "u \<in> [UU]\<^bsup>2\<^esup>"
    then consider (0) "k=0" | (1) "k=1" | (2) "k=2" | (3) "k=3"
      by linarith
    then show "f u = [j0,j1,j2,j3] ! k"
    proof cases
      case 0
      have "N3 \<subseteq> N0"
        using \<open>N1 \<subseteq> N0\<close> \<open>N2 \<subseteq> N1\<close> \<open>N3 \<subseteq> N2\<close> by auto
      then show ?thesis
        using u 0
        apply (auto simp: form_def form_split_def scheme_def simp flip: f0)
        apply (force simp: nsets_def intro: N0)
        done
    next
      case 1
      have "N3 \<subseteq> N1"
        using \<open>N2 \<subseteq> N1\<close> \<open>N3 \<subseteq> N2\<close> by auto
      then show ?thesis
        using u 1
        apply (auto simp: form_def form_split_def scheme_def simp flip: f1)
        apply (force simp: nsets_def intro: N1)
        done
    next
      case 2
      then show ?thesis
        using u \<open>N3 \<subseteq> N2\<close>
        apply (auto simp: form_def form_split_def scheme_def nsets_def simp flip: f2)
        apply (force simp: nsets_def intro: N2)
        done
    next
      case 3
      { fix a b d
        assume "{(a, b), (a, d)} \<in> [UU]\<^bsup>2\<^esup>"
          and *: "a \<in> N3" "b \<in> N3" "d \<in> N3" "b \<noteq> d"
        then have "a<b" "a<d"
          by (auto simp: UU_def nsets_def)
        then have "f {(a, b), (a, d)} = j3"
          using *
          apply (auto simp: neq_iff simp flip: f3 f3')
           apply (force simp: nsets_def intro: N3)+
          done
      }
      then show ?thesis
        using u UU 3
        by (auto simp: form_def form_split_def scheme_def)
    qed
  qed (rule \<open>infinite N3\<close>)
qed

text \<open>Lemma 2.4 of Jean A. Larson, ibid.\<close>
lemma lemma_2_4:
  assumes "infinite N" "k < 4"
  obtains M where "M \<in> [UU]\<^bsup>m\<^esup>" "\<And>u. u \<in> [M]\<^bsup>2\<^esup> \<Longrightarrow> form u k" "\<And>u. u \<in> [M]\<^bsup>2\<^esup> \<Longrightarrow> scheme u \<subseteq> N"
proof -
  obtain f:: "nat \<Rightarrow> nat" where "bij_betw f UNIV N" "strict_mono f"
    using assms by (meson bij_enumerate enumerate_mono strict_monoI)
  then have iff[simp]: "f x = f y \<longleftrightarrow> x=y" "f x < f y \<longleftrightarrow> x<y" for x y
    by (simp_all add: strict_mono_eq strict_mono_less)
  have [simp]: "f x \<in> N" for x
    using bij_betw_apply [OF \<open>bij_betw f UNIV N\<close>] by blast
  define M0 where "M0 = (\<lambda>i. (f(2*i), f(Suc(2*i)))) ` {..<m}"
  define M1 where "M1 = (\<lambda>i. (f i, f(m+i))) ` {..<m}"
  define M2 where "M2 = (\<lambda>i. (f i, f(2*m-i))) ` {..<m}"
  define M3 where "M3 = (\<lambda>i. (f 0, f (Suc i))) ` {..<m}"
  consider (0) "k=0" | (1) "k=1" | (2) "k=2" | (3) "k=3"
    using assms by linarith
  then show thesis
  proof cases
    case 0
    show ?thesis
    proof
      have "inj_on (\<lambda>i. (f (2 * i), f (Suc (2 * i)))) {..<m}"
        by (auto simp: inj_on_def)
      then show "M0 \<in> [UU]\<^bsup>m\<^esup>"
        by (simp add: M0_def nsets_def card_image UU_def image_subset_iff)
    next
      fix u
      assume u: "(u::(nat \<times> nat) set) \<in> [M0]\<^bsup>2\<^esup>"
      then obtain x y where "u = {x,y}" "x \<noteq> y" "x \<in> M0" "y \<in> M0"
        by (auto simp: nsets_2_eq)
      then obtain i j where "i<j" "j<m" and ueq: "u = {(f(2*i), f(Suc(2*i))), (f(2*j), f(Suc(2*j)))}"
        apply (clarsimp simp: M0_def)
        apply (metis (full_types) insert_commute less_linear)+
        done
      moreover have "f (2 * i) \<le> f (2 * j)"
        by (simp add: \<open>i<j\<close> less_imp_le_nat)
      ultimately show "form u k"
        apply (simp add: 0 form_def form_split_def nsets_def)
        apply (rule_tac x="f (2 * i)" in exI)
        apply (rule_tac x="f (Suc (2 * i))" in exI)
        apply (rule_tac x="f (2 * j)" in exI)
        apply (rule_tac x="f (Suc (2 * j))" in exI)
        apply auto
        done
      show "scheme u \<subseteq> N"
        using ueq by (auto simp: scheme_def)
    qed
  next
    case 1
    show ?thesis
    proof
      have "inj_on (\<lambda>i. (f i, f(m+i))) {..<m}"
        by (auto simp: inj_on_def)
      then show "M1 \<in> [UU]\<^bsup>m\<^esup>"
        by (simp add: M1_def nsets_def card_image UU_def image_subset_iff)
    next
      fix u
      assume u: "(u::(nat \<times> nat) set) \<in> [M1]\<^bsup>2\<^esup>"
      then obtain x y where "u = {x,y}" "x \<noteq> y" "x \<in> M1" "y \<in> M1"
        by (auto simp: nsets_2_eq)
      then obtain i j where "i<j" "j<m" and ueq: "u = {(f i, f(m+i)), (f j, f(m+j))}"
        apply (auto simp: M1_def)
        apply (metis (full_types) insert_commute less_linear)+
        done
      then show "form u k"
        apply (simp add: 1 form_def form_split_def nsets_def)
        by (metis iff(2) nat_add_left_cancel_less nat_less_le trans_less_add1)
      show "scheme u \<subseteq> N"
        using ueq by (auto simp: scheme_def)
    qed
  next
    case 2
    show ?thesis
    proof
      have "inj_on (\<lambda>i. (f i, f(2*m-i))) {..<m}"
        by (auto simp: inj_on_def)
      then show "M2 \<in> [UU]\<^bsup>m\<^esup>"
        by (auto simp: M2_def nsets_def card_image UU_def image_subset_iff)
    next
      fix u
      assume u: "(u::(nat \<times> nat) set) \<in> [M2]\<^bsup>2\<^esup>"
      then obtain x y where "u = {x,y}" "x \<noteq> y" "x \<in> M2" "y \<in> M2"
        by (auto simp: nsets_2_eq)
      then obtain i j where "i<j" "j<m" and ueq: "u = {(f i, f(2*m-i)), (f j, f(2*m-j))}"
        apply (auto simp: M2_def)
        apply (metis (full_types) insert_commute less_linear)+
        done
      then show "form u k"
        apply (simp add: 2 form_def form_split_def nsets_def)
        apply (rule_tac x="f i" in exI)
        apply (rule_tac x="f (2 * m - i)" in exI)
        apply (rule_tac x="f j" in exI)
        apply (rule_tac x="f (2 * m - j)" in exI)
        apply (auto simp: less_imp_le_nat)
        done
      show "scheme u \<subseteq> N"
        using ueq by (auto simp: scheme_def)
    qed
  next
    case 3
    show ?thesis
    proof
      have "inj_on (\<lambda>i. (f 0, f (Suc i))) {..<m}"
        by (auto simp: inj_on_def)
      then show "M3 \<in> [UU]\<^bsup>m\<^esup>"
        by (auto simp: M3_def nsets_def card_image UU_def image_subset_iff)
    next
      fix u
      assume u: "(u::(nat \<times> nat) set) \<in> [M3]\<^bsup>2\<^esup>"
      then obtain x y where "u = {x,y}" "x \<noteq> y" "x \<in> M3" "y \<in> M3"
        by (auto simp: nsets_2_eq)
      then obtain i j where "i<j" "j<m" and ueq: "u = {(f 0, f(Suc i)), (f 0, f(Suc j))}"
        apply (auto simp: M3_def)
        apply (metis (full_types) insert_commute less_linear)+
        done
      then show "form u k"
        by (fastforce simp: 3 form_def form_split_def nsets_def)
      show "scheme u \<subseteq> N"
        using ueq by (auto simp: scheme_def)
    qed
  qed
qed

text \<open>Lemma 2.5 of Jean A. Larson, ibid.\<close>

text \<open>Theorem 2.1 of Jean A. Larson, ibid.\<close>
lemma Specker_aux:
  assumes "\<alpha> \<in> elts \<omega>"
  shows "partn_lst pair_less UU [\<omega>\<up>2,\<alpha>] 2"
  unfolding partn_lst_def
proof clarsimp
  fix f
  assume f: "f \<in> [UU]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
  let ?P0 = "\<exists>X \<subseteq> UU. ordertype X pair_less = \<omega>\<up>2 \<and> f ` [X]\<^bsup>2\<^esup> \<subseteq> {0}"
  let ?P1 = "\<exists>M \<subseteq> UU. ordertype M pair_less = \<alpha> \<and> f ` [M]\<^bsup>2\<^esup> \<subseteq> {1}"
  have \<dagger>: "?P0 \<or> ?P1"
  proof (rule disjCI)
    assume "\<not> ?P1"
    then have not1: "\<And>M. \<lbrakk>M \<subseteq> UU; ordertype M pair_less = \<alpha>\<rbrakk> \<Longrightarrow> \<exists>x\<in>[M]\<^bsup>2\<^esup>. f x \<noteq> Suc 0"
      by auto
    obtain m where m: "\<alpha> = ord_of_nat m"
      using assms elts_\<omega> by auto
    then have f_eq_0: "M \<in> [UU]\<^bsup>m\<^esup> \<Longrightarrow> \<exists>x\<in>[M]\<^bsup>2\<^esup>. f x = 0" for M
      using not1 [of M] finite_ordertype_eq_card [of M pair_less m] f
      apply (clarsimp simp: nsets_def eval_nat_numeral Pi_def)
      by (meson less_Suc0 not_less_less_Suc_eq subset_trans)
    obtain N js where "infinite N" and N: "\<And>k u. \<lbrakk>k < 4; u \<in> [UU]\<^bsup>2\<^esup>; form u k; scheme u \<subseteq> N\<rbrakk> \<Longrightarrow> f u = js!k"
      using f lemma_2_3 by blast
    obtain M0 where M0: "M0 \<in> [UU]\<^bsup>m\<^esup>" "\<And>u. u \<in> [M0]\<^bsup>2\<^esup> \<Longrightarrow> form u 0" "\<And>u. u \<in> [M0]\<^bsup>2\<^esup> \<Longrightarrow> scheme u \<subseteq> N"
      by (rule lemma_2_4 [OF \<open>infinite N\<close>]) auto
    obtain M1 where M1: "M1 \<in> [UU]\<^bsup>m\<^esup>" "\<And>u. u \<in> [M1]\<^bsup>2\<^esup> \<Longrightarrow> form u 1" "\<And>u. u \<in> [M1]\<^bsup>2\<^esup> \<Longrightarrow> scheme u \<subseteq> N"
      by (rule lemma_2_4 [OF \<open>infinite N\<close>]) auto
    obtain M2 where M2: "M2 \<in> [UU]\<^bsup>m\<^esup>" "\<And>u. u \<in> [M2]\<^bsup>2\<^esup> \<Longrightarrow> form u 2" "\<And>u. u \<in> [M2]\<^bsup>2\<^esup> \<Longrightarrow> scheme u \<subseteq> N"
      by (rule lemma_2_4 [OF \<open>infinite N\<close>]) auto
    obtain M3 where M3: "M3 \<in> [UU]\<^bsup>m\<^esup>" "\<And>u. u \<in> [M3]\<^bsup>2\<^esup> \<Longrightarrow> form u 3" "\<And>u. u \<in> [M3]\<^bsup>2\<^esup> \<Longrightarrow> scheme u \<subseteq> N"
      by (rule lemma_2_4 [OF \<open>infinite N\<close>]) auto
    have "js!0 = 0"
      using N [of 0 ] M0 f_eq_0 [of M0] by (force simp: nsets_def eval_nat_numeral)
    moreover have "js!1 = 0"
      using N [of 1] M1 f_eq_0 [of M1] by (force simp: nsets_def eval_nat_numeral)
    moreover have "js!2 = 0"
      using N [of 2 ] M2 f_eq_0 [of M2] by (force simp: nsets_def eval_nat_numeral)
    moreover have "js!3 = 0"
      using N [of 3 ] M3 f_eq_0 [of M3] by (force simp: nsets_def eval_nat_numeral)
    ultimately have js0: "js!k = 0" if "k < 4" for k
      using that by (auto simp: eval_nat_numeral less_Suc_eq)
    obtain X where "X \<subseteq> UU" and otX: "ordertype X pair_less = \<omega>\<up>2"
      and X: "\<And>u. u \<in> [X]\<^bsup>2\<^esup> \<Longrightarrow> (\<exists>k<4. form u k) \<and> scheme u \<subseteq> N"
      using \<open>infinite N\<close> lemma_2_5 by auto
    moreover have "f ` [X]\<^bsup>2\<^esup> \<subseteq> {0}"
    proof (clarsimp simp: image_subset_iff)
      fix u
      assume u: "u \<in> [X]\<^bsup>2\<^esup>"
      then have u_UU2: "u \<in> [UU]\<^bsup>2\<^esup>"
        using \<open>X \<subseteq> UU\<close> nsets_mono by blast
      show "f u = 0"
        using X u N [OF _ u_UU2] js0 by auto
    qed
    ultimately show "\<exists>X \<subseteq> UU. ordertype X pair_less = \<omega>\<up>2 \<and> f ` [X]\<^bsup>2\<^esup> \<subseteq> {0}"
      by blast
  qed
  then show "\<exists>i<Suc (Suc 0). \<exists>H\<subseteq>UU. ordertype H pair_less = [\<omega>\<up>2, \<alpha>] ! i \<and> f ` [H]\<^bsup>2\<^esup> \<subseteq> {i}"
    by (metis One_nat_def lessI nth_Cons_0 nth_Cons_Suc zero_less_Suc)
qed

theorem Specker: "\<alpha> \<in> elts \<omega> \<Longrightarrow> partn_lst_VWF (\<omega>\<up>2) [\<omega>\<up>2,\<alpha>] 2"
  using partn_lst_imp_partn_lst_VWF_eq [OF Specker_aux] ordertype_UU_\<omega>2 wf_pair_less by blast

end


theory ImpCtl
  imports "../Semantics/Gensyn_Sem" "../Mergeable/MergeableAList"
          "../Mergeable/Mergeable" "../Mergeable/MergeableInstances"
          "../Lifting/LiftUtils" "../Lifting/LiftInstances" "PrintCalcSeq"
begin

(* conditional/boolean expressions *)
datatype cond_syn' =
  Seqz
  | Sltz
  | Sgtz
  | Sskip_cond

type_synonym cond_state' = "bool * int"

definition cond_sem :: "cond_syn' \<Rightarrow> cond_state' \<Rightarrow> cond_state'" where
"cond_sem x s =
  (case s of (b, i) \<Rightarrow>
    (case x of
      Seqz \<Rightarrow> ((i = 0), i)
      | Sltz \<Rightarrow> ((i < 0), i)
      | Sgtz \<Rightarrow> ((i > 0), i)
      | Sskip_cond \<Rightarrow> s))"

(* Imp control
- IF
- WHILE
- SKIP
*)

datatype syn' =
  Sif
  | Sskip
  | Swhile

type_synonym state' = "(gensyn_skel * unit gs_result * dir) * bool"

definition imp_ctl_sem :: "syn' \<Rightarrow> state' \<Rightarrow> state'" where
"imp_ctl_sem x st =
  (case st of ((sk, GRPath cp, d), b) \<Rightarrow>
    (case x of
      Sskip \<Rightarrow> st
      | Sif \<Rightarrow>
        (case d of
         Down \<Rightarrow> ((sk, GRPath (cp @ [0]), Down), b)
         | Up xcp \<Rightarrow>
                 (case get_suffix cp xcp of
                    Some (xcph#xcpt) \<Rightarrow>
                      (case xcph of
                          0 \<Rightarrow> \<comment> \<open>condition\<close>
                            (if b
                             then ((sk, GRPath (cp @ [1]), Down), b)
                             else ((sk, GRPath (cp @ [2]), Down), b))
                          | _ \<Rightarrow> \<comment> \<open> then/else \<close>
                              (case gensyn_cp_parent sk cp of
                                None \<Rightarrow> ((sk, GRDone, Up cp), b)
                                | Some cp' \<Rightarrow> ((sk, GRPath cp', Up cp), b)))))
        | Swhile \<Rightarrow>
          (case d of
           Down \<Rightarrow> ((sk, GRPath (cp @ [0]), Down), b)
           | Up xcp \<Rightarrow>
                 (case get_suffix cp xcp of
                    Some (xcph#xcpt) \<Rightarrow>
                      (case xcph of
                          0 \<Rightarrow> \<comment> \<open>condition\<close>
                            (if b
                             then ((sk, GRPath (cp @ [1]), Down), b)
                             else (case gensyn_cp_parent sk cp of
                                     None \<Rightarrow> ((sk, GRDone, Up cp), b)
                                     | Some cp' \<Rightarrow> ((sk, GRPath cp', Up cp), b)))
                          | _ \<Rightarrow> \<comment> \<open> loop body\<close>
                              ((sk, GRPath cp, Down), b))))))"

datatype syn =
  Spc PrintCalcSeq.syn
  | Simp syn'
  | Scond cond_syn'

type_synonym state =
  "Seq.state * (bool md_triv option md_prio * PrintCalc.state)"

definition imp_trans :: "syn \<Rightarrow> syn'" where
"imp_trans s =
  (case s of
    Simp s' \<Rightarrow> s'
    | _ \<Rightarrow> Sskip)"

definition printcalc_trans :: "syn \<Rightarrow> PrintCalcSeq.syn" where
"printcalc_trans s =
  (case s of
    Spc x \<Rightarrow> x
    | _ \<Rightarrow> Inl (Seq.Sskip))" (* NB choice of which sskip is arbitrary here *)

definition cond_trans :: "syn \<Rightarrow> cond_syn'" where
"cond_trans s =
  (case s of
    Scond x \<Rightarrow> x
    | _ \<Rightarrow> Sskip_cond)"
(*
definition printcalcseq_sem_l :: "syn \<Rightarrow> state \<Rightarrow> state" where
"printcalcseq_sem_l =
  lift_map_s printcalc_trans
     (prod_l id_l (snd_l id_l))
     (pcomp print_calc_seq_lc)"
*)
definition imp_prio :: "(syn' \<Rightarrow> nat)" where
"imp_prio x =
(case x of
    Sskip \<Rightarrow> 0
    | _ \<Rightarrow> 2)"

definition imp_sem_l :: "syn \<Rightarrow> state \<Rightarrow> state" where
"imp_sem_l =
  lift_map_s imp_trans
    (schem_lift (SP (SP NA (SP NB NC)) ND)
                (SP (SP (SO NA) (SP (SPRC imp_prio (SO NB)) (SPRC imp_prio (SO NC))))
                  (SP (SPRK (SO ND)) NX)))
    imp_ctl_sem"
(*
definition cond_sem_l :: "syn \<Rightarrow> state \<Rightarrow> state" where
"cond_sem_l =
  l_map_s cond_trans
    (schem_lift (SP NA NB)
                 (SP NX (SP (SPRI (SOT NA)) (SP (SPRK (SOT NB)) NX))))
  cond_sem"
*)
(*
definition pcs_cond_lc :: "(syn, state) langcomp" where
"pcs_cond_lc =
  \<lparr> Sem1 = printcalcseq_sem_l
  , Sem2 = cond_sem_l \<rparr>"

definition imp_lc :: "(syn, state) langcomp" where
"imp_lc =
  \<lparr> Sem1 = (pcomp pcs_cond_lc)
  , Sem2 = imp_sem_l \<rparr>"

definition sem_final :: "(syn, state) x_sem'" where
"sem_final =
  l_map_s id
    (schem_lift NA
      (SFAN (l_reverse
                (schem_lift (SP NA NB) (SP (SP (SOT NA) (SP (SPRK (SOT NB)) NX)) NX)))
          NA))
    (pcomp imp_lc)"

definition gsx :: "syn gensyn \<Rightarrow> childpath \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> state option" where
"gsx =
  gensyn_sem_exec (xsem sem_final)"

definition testprog :: "syn gensyn" where
"testprog = G (Spc (Inl Sseq))
              [ G (Spc (Inr (Sreset 0))) []
              , G (Simp Sif)
                  [ G (Scond Seqz) []
                  , G (Spc (Inr (Sadd 1))) []
                  , G (Spc (Inr (Sadd 2))) [] ]]"

definition initial :: "state" where
"initial =
  (  ( Some (mdt (gs_sk testprog))
     , (mdp 0 (Some (mdt (GRPath []))))
     , mdp 0 (Some (mdt Down)))
  , (mdp 0 (Some (mdt False)))
  , (mdp 0 (Some (mdt 2)), (mdp 0 (Some (mdt [])))))"

definition testprog' :: "syn gensyn" where
"testprog' = G (Spc (Inl Sseq)) [G (Spc (Inr (Sreset 0))) []]"

definition initial' :: "state" where
"initial' =
  (  ( Some (mdt (gs_sk testprog'))
     , (mdp 0 (Some (mdt (GRPath []))))
     , mdp 0 (Some (mdt Down)))
  , (mdp 0 (Some (mdt False)))
  , (mdp 0 (Some (mdt 2)), (mdp 0 (Some (mdt [])))))"

value [simp] "(pcomp imp_lc) (Spc (Inl Sseq)) initial'"

value "gsx testprog' [] initial' 20"

value "gsx testprog [] initial 900"

value "gensyn_cp_parent (G () []) []"

definition testprog2 :: "syn gensyn" where
"testprog2 = G (Spc (Inl Sseq))
            [G (Spc (Inr (Sreset 8))) []
            , G (Simp (Swhile))
                [ G (Scond Sgtz) []
                ,  G (Spc (Inr (Ssub 3))) []]]"

value "gsx testprog2 [] initial 900"

declare [[show_types = false]]
(*
lemma what:
  fixes x
  assumes H : "gsx testprog' [] initial' 3 = x"
  shows False using H
  apply(simp add:gsx_def xsem_def testprog'_def initial'_def sem_final_def
        prod_fan_l_def l_reverse_def fst_l_def prod_l_def option_l_def triv_l_def
        l_map_s_def pcomp_def imp_lc_def imp_sem_l_def pcs_cond_lc_def
        printcalcseq_sem_l_def printcalc_trans_def
        print_calc_seq_lc_def imp_ctl_sem_def
        prio_l_keep_def prio_l_inc2_def prio_l_inc_def prio_l_zero_def
        prio_l_def prio_l_const_def
        prod_l_def fst_l_def snd_l_def
        PrintCalcSeq.seq_sem_l_def Seq.seq_sem_l_def
        print_calc_sem_l_def cond_sem_l_def
        print_calc_lc_def
        print_sem_l_def calc_sem_l_def
        imp_trans_def print_trans_def calc_trans_def cond_trans_def seq_trans_def
        )
*)
*)
end


(*  Title:       Hamming_Stream.thy
    Author:      Andreas Lochbihler, ETH Zurich
*)

section {* The Hamming stream defined as a least fixpoint *}

theory Hamming_Stream imports
  "../Coinductive_List"
  "HOL-Computational_Algebra.Primes"
begin

lemma infinity_inf_enat [simp]:
  fixes n :: enat
  shows "\<infinity> \<sqinter> n = n" "n \<sqinter> \<infinity> = n"
by(simp_all add: inf_enat_def)

lemma eSuc_inf_eSuc [simp]: "eSuc n \<sqinter> eSuc m = eSuc (n \<sqinter> m)"
by(simp add: inf_enat_def)

lemma if_pull2: "(if b then f x x' else f y y') = f (if b then x else y) (if b then x' else y')"
by simp

context ord begin

primcorec lmerge :: "'a llist \<Rightarrow> 'a llist \<Rightarrow> 'a llist"
where
  "lmerge xs ys =
   (case xs of LNil \<Rightarrow> LNil | LCons x xs' \<Rightarrow>
    case ys of LNil \<Rightarrow> LNil | LCons y ys' \<Rightarrow>
    if lhd xs < lhd ys then LCons x (lmerge xs' ys)
    else LCons y (if lhd ys < lhd xs then lmerge xs ys' else lmerge xs' ys'))"

lemma lnull_lmerge [simp]: "lnull (lmerge xs ys) \<longleftrightarrow> (lnull xs \<or> lnull ys)"
by(simp add: lmerge_def)

lemma lmerge_eq_LNil_iff: "lmerge xs ys = LNil \<longleftrightarrow> (xs = LNil \<or> ys = LNil)"
using lnull_lmerge unfolding lnull_def .

lemma lhd_lmerge: "\<lbrakk> \<not> lnull xs; \<not> lnull ys \<rbrakk> \<Longrightarrow> lhd (lmerge xs ys) = (if lhd xs < lhd ys then lhd xs else lhd ys)"
by(auto split: llist.split)

lemma ltl_lmerge:
  "\<lbrakk> \<not> lnull xs; \<not> lnull ys \<rbrakk> \<Longrightarrow>
  ltl (lmerge xs ys) =
  (if lhd xs < lhd ys then lmerge (ltl xs) ys
   else if lhd ys < lhd xs then lmerge xs (ltl ys)
   else lmerge (ltl xs) (ltl ys))"
by(auto split: llist.split)

declare lmerge.sel [simp del]

lemma lprefix_lmergeI:
  "\<lbrakk> lprefix xs xs'; lprefix ys ys' \<rbrakk>
  \<Longrightarrow> lprefix (lmerge xs ys) (lmerge xs' ys')"
by(coinduction arbitrary: xs xs' ys ys')(fastforce simp add: lhd_lmerge ltl_lmerge dest: lprefix_lhdD lprefix_lnullD simp add: not_lnull_conv split: if_split_asm)

lemma in_lset_lmergeD: "x \<in> lset (lmerge xs ys) \<Longrightarrow> x \<in> lset xs \<or> x \<in> lset ys"
by(induct zs\<equiv>"lmerge xs ys" arbitrary: xs ys rule: llist_set_induct)(auto simp add: lhd_lmerge ltl_lmerge split: if_split_asm dest: in_lset_ltlD)

lemma lset_lmerge: "lset (lmerge xs ys) \<subseteq> lset xs \<union> lset ys"
by(auto dest: in_lset_lmergeD)

lemma lfinite_lmergeD: "lfinite (lmerge xs ys) \<Longrightarrow> lfinite xs \<or> lfinite ys"
by(induct zs\<equiv>"lmerge xs ys" arbitrary: xs ys rule: lfinite_induct)(fastforce simp add: ltl_lmerge if_pull2 split: if_split_asm)+

lemma fixes F
  defines "F \<equiv> \<lambda>lmerge (xs, ys). case xs of LNil \<Rightarrow> LNil | LCons x xs' \<Rightarrow> case ys of LNil \<Rightarrow> LNil | LCons y ys' \<Rightarrow> (if x < y then LCons x (curry lmerge xs' ys) else if y < x then LCons y (curry lmerge xs ys') else LCons y (curry lmerge xs' ys'))"
  shows lmerge_conv_fixp: "lmerge \<equiv> curry (ccpo.fixp (fun_lub lSup) (fun_ord lprefix) F)" (is "?lhs \<equiv> ?rhs")
  and lmerge_mono: "mono_llist (\<lambda>lmerge. F lmerge xs)" (is "?mono xs")
proof(intro eq_reflection ext)
  show mono: "\<And>xs. ?mono xs" unfolding F_def by(tactic {* Partial_Function.mono_tac @{context} 1 *})
  fix xs ys
  show "lmerge xs ys = ?rhs xs ys"
  proof(coinduction arbitrary: xs ys)
    case Eq_llist thus ?case
      by(subst (1 3 4) llist.mono_body_fixp[OF mono])(auto simp add: F_def lmerge_simps split: llist.split)
  qed
qed

lemma monotone_lmerge: "monotone (rel_prod lprefix lprefix) lprefix (case_prod lmerge)"
apply(rule llist.fixp_preserves_mono2[OF lmerge_mono lmerge_conv_fixp])
apply(erule conjE|rule allI conjI cont_intro|simp|erule allE, erule llist.mono2mono)+
done

lemma mono2mono_lmerge1 [THEN llist.mono2mono, cont_intro, simp]:
  shows monotone_lmerge1: "monotone lprefix lprefix (\<lambda>xs. lmerge xs ys)"
by(simp add: monotone_lmerge[simplified])

lemma mono2mono_lmerge2 [THEN llist.mono2mono, cont_intro, simp]:
  shows monotone_lmerge2: "monotone lprefix lprefix (\<lambda>ys. lmerge xs ys)"
by(simp add: monotone_lmerge[simplified])

lemma mcont_lmerge: "mcont (prod_lub lSup lSup) (rel_prod lprefix lprefix) lSup lprefix (case_prod lmerge)"
apply(rule llist.fixp_preserves_mcont2[OF lmerge_mono lmerge_conv_fixp])
apply(erule conjE|rule allI conjI cont_intro|simp|erule allE, erule llist.mcont2mcont)+
done

lemma mcont2mcont_lmerge1 [THEN llist.mcont2mcont, cont_intro, simp]:
  shows mcont_lmerge1: "mcont lSup lprefix lSup lprefix (\<lambda>xs. lmerge xs ys)"
by(simp add: mcont_lmerge[simplified])

lemma mcont2mcont_lmerge2 [THEN llist.mcont2mcont, cont_intro, simp]:
  shows mcont_lmerge2: "mcont lSup lprefix lSup lprefix (\<lambda>ys. lmerge xs ys)"
by(simp add: mcont_lmerge[simplified])

lemma lfinite_lmergeI [simp]: "\<lbrakk> lfinite xs; lfinite ys \<rbrakk> \<Longrightarrow> lfinite (lmerge xs ys)"
proof(induction arbitrary: ys rule: lfinite_induct)
  case (LCons xs)
  from LCons.prems LCons.hyps LCons.IH
  show ?case by induct(clarsimp simp add: not_lnull_conv lmerge_simps)+
qed simp

lemma linfinite_lmerge [simp]: "\<lbrakk> \<not> lfinite xs; \<not> lfinite ys \<rbrakk> \<Longrightarrow> \<not> lfinite (lmerge xs ys)"
by(auto dest: lfinite_lmergeD)

lemma llength_lmerge_above: "llength xs \<sqinter> llength ys \<le> llength (lmerge xs ys)"
proof(induction xs arbitrary: ys)
  case (LCons x xs)
  show ?case
  proof(induct ys)
    case LCons thus ?case using LCons.IH
      by(fastforce simp add: bot_enat_def[symmetric] lmerge_simps le_infI1 le_infI2 intro: order_trans[rotated])
  qed(simp_all add: bot_enat_def[symmetric])
qed(simp_all add: bot_enat_def[symmetric])

end

context linorder begin

lemma in_lset_lmergeI1:
  "\<lbrakk> x \<in> lset xs; lsorted xs; \<not> lfinite ys; \<exists>y\<in>lset ys. x \<le> y \<rbrakk>
  \<Longrightarrow> x \<in> lset (lmerge xs ys)"
proof(induction arbitrary: ys rule: lset_induct)
  case (find xs)
  then obtain y where "y \<in> lset ys" "x \<le> y" by blast
  thus ?case by induct(auto simp add: lmerge_simps not_less)
next
  case (step x' xs)
  then obtain y where "y \<in> lset ys" "x \<le> y" by blast
  moreover from `lsorted (LCons x' xs)` `x \<in> lset xs` `x \<noteq> x'`
  have "x' < x" "lsorted xs" by(auto simp add: lsorted_LCons)
  ultimately show ?case using `\<not> lfinite ys`
    by induct(auto 4 3 simp add: lmerge_simps `x \<noteq> x'` not_less intro: step.IH dest: in_lset_lmergeD)
qed

lemma in_lset_lmergeI2:
  "\<lbrakk> x \<in> lset ys; lsorted ys; \<not> lfinite xs; \<exists>y\<in>lset xs. x \<le> y \<rbrakk>
  \<Longrightarrow> x \<in> lset (lmerge xs ys)"
proof(induction arbitrary: xs rule: lset_induct)
  case (find ys)
  then obtain y where "y \<in> lset xs" "x \<le> y" by blast
  thus ?case by induct(auto simp add: lmerge_simps not_less)
next
  case (step x' ys)
  then obtain y where "y \<in> lset xs" "x \<le> y" by blast
  moreover from `lsorted (LCons x' ys)` `x \<in> lset ys` `x \<noteq> x'`
  have "x' < x" "lsorted ys" by(auto simp add: lsorted_LCons)
  ultimately show ?case using `\<not> lfinite xs`
    by induct(auto 4 3 simp add: lmerge_simps `x \<noteq> x'` not_less intro: step.IH dest: in_lset_lmergeD)
qed

lemma lsorted_lmerge: "\<lbrakk> lsorted xs; lsorted ys \<rbrakk> \<Longrightarrow> lsorted (lmerge xs ys)"
proof(coinduction arbitrary: xs ys)
  case (lsorted xs ys)
  have ?lhd using lsorted
    by(auto 4 3 simp add: not_lnull_conv lsorted_LCons lhd_lmerge ltl_lmerge dest!: in_lset_lmergeD)
  moreover have ?ltl using lsorted by(auto simp add: ltl_lmerge intro: lsorted_ltlI)
  ultimately show ?case ..
qed

lemma ldistinct_lmerge:
  "\<lbrakk> lsorted xs; lsorted ys; ldistinct xs; ldistinct ys \<rbrakk>
  \<Longrightarrow> ldistinct (lmerge xs ys)"
by(coinduction arbitrary: xs ys)(auto 4 3 simp add: lhd_lmerge ltl_lmerge not_lnull_conv lsorted_LCons not_less dest!: in_lset_lmergeD dest: antisym)

end

partial_function (llist) hamming' :: "unit \<Rightarrow> nat llist"
where
  "hamming' _ =
   LCons 1 (lmerge (lmap (op * 2) (hamming' ())) (lmerge (lmap (op * 3) (hamming' ())) (lmap (op * 5) (hamming' ()))))"

definition hamming :: "nat llist"
where "hamming = hamming' ()"

lemma lnull_hamming [simp]: "\<not> lnull hamming"
unfolding hamming_def by(subst hamming'.simps) simp

lemma hamming_eq_LNil_iff [simp]: "hamming = LNil \<longleftrightarrow> False"
using lnull_hamming unfolding lnull_def by simp

lemma lhd_hamming [simp]: "lhd hamming = 1"
unfolding hamming_def by(subst hamming'.simps) simp

lemma ltl_hamming [simp]:
  "ltl hamming = lmerge (lmap (op * 2) hamming) (lmerge (lmap (op * 3) hamming) (lmap (op * 5) hamming))"
unfolding hamming_def by(subst hamming'.simps) simp

lemma hamming_unfold:
  "hamming = LCons 1 (lmerge (lmap (op * 2) hamming) (lmerge (lmap (op * 3) hamming) (lmap (op * 5) hamming)))"
by(rule llist.expand) simp_all

definition smooth :: "nat \<Rightarrow> bool"
where "smooth n \<longleftrightarrow> (\<forall>p. prime p \<longrightarrow> p dvd n \<longrightarrow> p \<le> 5)"

lemma smooth_0 [simp]: "\<not> smooth 0"
by(auto simp add: smooth_def intro: exI[where x=7])

lemma smooth_Suc0 [simp]: "smooth (Suc 0)"
by(auto simp add: smooth_def)

lemma smooth_gt0: "smooth n \<Longrightarrow> n > 0"
by(cases n) simp_all

lemma smooth_ge_Suc0: "smooth n \<Longrightarrow> n \<ge> Suc 0"
by(cases n) simp_all

lemma prime_nat_dvdD: "prime p \<Longrightarrow> (n :: nat) dvd p \<Longrightarrow> n = 1 \<or> n = p"
unfolding prime_nat_iff by simp

lemma smooth_times [simp]: "smooth (x * y) \<longleftrightarrow> smooth x \<and> smooth y"
by(auto simp add: smooth_def prime_dvd_mult_iff)

lemma smooth3 [simp]: "smooth 3"
by(auto simp add: smooth_def dest: prime_nat_dvdD[of 3, simplified])

lemma smooth5 [simp]: "smooth 5"
by(auto simp add: smooth_def dest: prime_nat_dvdD[of 5, simplified])

lemma hamming_in_smooth: "lset hamming \<subseteq> {n. smooth n}"
unfolding hamming_def by(induct rule: hamming'.fixp_induct)(auto 6 6 dest: in_lset_lmergeD)

lemma lfinite_hamming [simp]: "\<not> lfinite hamming"
proof
  assume "lfinite hamming"
  then obtain n where n: "llength hamming = enat n" unfolding lfinite_conv_llength_enat by fastforce
  have "llength (lmap (op * 3) hamming) \<sqinter> llength (lmap (op * 5) hamming) \<le> llength (lmerge (lmap (op * 3) hamming) (lmap (op * 5) hamming))"
    by(rule llength_lmerge_above)
  hence "llength hamming \<le> \<dots>" by simp
  moreover have "llength (lmap (op * 2) hamming) \<sqinter> \<dots> \<le>
    llength (lmerge (lmap (op * 2) hamming) (lmerge (lmap (op * 3) hamming) (lmap (op * 5) hamming)))"
    by(rule llength_lmerge_above)
  ultimately have "llength hamming \<le> \<dots>" by(simp add: inf.absorb1)
  also from n have "\<dots> < enat n"
    by(subst (asm) hamming_unfold)(cases n, auto simp add: zero_enat_def[symmetric] eSuc_enat[symmetric])
  finally show False unfolding n by simp
qed

lemma lsorted_hamming [simp]: "lsorted hamming"
  and ldistinct_hamming [simp]: "ldistinct hamming"
proof -
  have "lsorted hamming \<and> ldistinct hamming \<and> lset hamming \<subseteq> {1..}"
    unfolding hamming_def
    by(induct rule: hamming'.fixp_induct)(auto 6 6 simp add: lsorted_LCons dest: in_lset_lmergeD intro: smooth_ge_Suc0 lsorted_lmerge lsorted_lmap monotoneI ldistinct_lmerge inj_onI)
  thus "lsorted hamming" "ldistinct hamming" by simp_all
qed

lemma smooth_hamming:
  assumes "smooth n"
  shows "n \<in> lset hamming"
using assms
proof(induction n rule: less_induct)
  have [simp]:
    "monotone op \<le> op \<le> (op * 2 :: nat \<Rightarrow> nat)"
    "monotone op \<le> op \<le> (op * 3 :: nat \<Rightarrow> nat)"
    "monotone op \<le> op \<le> (op * 5 :: nat \<Rightarrow> nat)"
    by(simp_all add: monotone_def)

  case (less n)
  show ?case
  proof(cases "n > 1")
    case False
    moreover from `smooth n` have "n \<noteq> 0" by(rule contrapos_pn) simp
    ultimately have "n = 1" by(simp)
    thus ?thesis by(subst hamming_unfold) simp
  next
    case True
    hence "\<exists>p. prime p \<and> p dvd n" by(metis less_numeral_extra(4) prime_factor_nat)
    with `smooth n` obtain p where "prime p" "p dvd n" "p \<le> 5" by(auto simp add: smooth_def)
    from `p dvd n` obtain n' where n: "n = p * n'" by(auto simp add: dvd_def)
    with `smooth n` `prime p` have "smooth n'" by(simp add: smooth_def)
    with `prime p` n have "n' < n" by(simp add: smooth_gt0 prime_gt_Suc_0_nat)
    hence n': "n' \<in> lset hamming" using `smooth n'` by(rule less.IH)

    from \<open>p \<le> 5\<close> have "p = 0 \<or> p = 1 \<or> p = 2 \<or> p = 3 \<or> p = 4 \<or> p = 5"
      by presburger
    with `prime p` have "p = 2 \<or> p = 3 \<or> p = 5" by auto
    thus ?thesis
    proof(elim disjE)
      assume "p = 2"
      with n n' show ?thesis
        by(subst hamming_unfold)(simp_all add: in_lset_lmergeI1 not_less lsorted_lmap bexI[where x="n'"] bexI[where x="3*n'"])
    next
      assume "p = 3"
      moreover with n `smooth n'` have "2 * n' < n" by(simp add: smooth_gt0)
      hence "2 * n' \<in> lset hamming" by(rule less.IH)(simp add: `smooth n'`)
      ultimately show ?thesis using n n'
        by(subst hamming_unfold)(auto 4 4 simp add: not_less lsorted_lmap lsorted_lmerge intro: in_lset_lmergeI1 in_lset_lmergeI2 bexI[where x="4*n'"] bexI[where x="5*n'"])
    next
      assume "p = 5"
      moreover with n `smooth n'` have "2 * (2 * n') < n" by(simp add: smooth_gt0)
      hence "2 * (2 * n') \<in> lset hamming" by(rule less.IH)(simp only: smooth_times smooth2 `smooth n'` simp_thms)
      moreover from `p = 5` n `smooth n'` have "3 * n' < n" by(simp add: smooth_gt0)
      hence "3 * n' \<in> lset hamming" by(rule less.IH)(simp add: `smooth n'`)
      ultimately show ?thesis using n n'
        by(subst hamming_unfold)(auto 4 4 simp add: lsorted_lmap lsorted_lmerge intro: in_lset_lmergeI2 bexI[where x="9*n'"] bexI[where x="8 * n'"])
    qed
  qed
qed

corollary hamming_smooth: "lset hamming = {n. smooth n}"
using hamming_in_smooth by(blast intro: smooth_hamming)

lemma hamming_THE:
  "(THE xs. lsorted xs \<and> ldistinct xs \<and> lset xs = {n. smooth n}) = hamming"
by(rule the_equality)(simp_all add: hamming_smooth lsorted_ldistinct_lset_unique)

end


(* Sebastian Reiche and Christoph Benzmüller, 2021 *)
theory PAL_experiments imports PAL_definitions

begin
 (* Parameter settings *)
 nitpick_params[user_axioms=true, format=4, show_all]
 declare [[smt_solver=cvc4,smt_oracle]]

 (*Some useful lemmata *)
 lemma trans_tc: "transitive (tc R)" unfolding Defs by metis
 lemma trans_inv_tc: "transitive (inverse_rel (tc R))" unfolding Defs by metis
 lemma sub_rel_tc: "symmetric R \<longrightarrow> (sub_rel R (inverse_rel (tc R)))" unfolding Defs by smt
 lemma sub_rel_tc_tc: "symmetric R \<longrightarrow> (sub_rel (tc R) (inverse_rel (tc R)))"
   using sub_rel_def sub_rel_tc tc_def trans_inv_tc by fastforce
 lemma symm_tc: "symmetric R \<longrightarrow> symmetric (tc R)"
   using inverse_rel_def sub_rel_def sub_rel_tc_tc symmetric_def by auto

 (* System K: is implied by the semantical embedding *)
 lemma tautologies: "\<^bold>\<lfloor>\<^bold>\<top>\<^bold>\<rfloor>" by auto
 lemma axiom_K: "\<A> i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i (\<phi> \<^bold>\<rightarrow> \<psi>)) \<^bold>\<rightarrow> ((\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i \<psi>))\<^bold>\<rfloor>" by auto
 lemma modusponens: assumes 1: "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<^bold>\<rfloor>" and 2: "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>\<psi>\<^bold>\<rfloor>" using 1 2 by auto
 lemma necessitation: assumes 1: "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<A> i \<Longrightarrow> \<^bold>\<lfloor>\<^bold>K\<^sub>i \<phi>\<^bold>\<rfloor>" using 1 by auto
 (* More axioms: implied by the semantical embedding  *)
 lemma axiom_T: "reflexive i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> \<phi>\<^bold>\<rfloor>" using reflexive_def by auto
 lemma axiom_4: "transitive i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<^bold>K\<^sub>i \<phi>))\<^bold>\<rfloor>" using transitive_def by meson
 lemma axiom_5: "euclidean i \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>\<not>\<^bold>K\<^sub>i \<phi>) \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<^bold>\<not>\<^bold>K\<^sub>i \<phi>))\<^bold>\<rfloor>" using euclidean_def by meson
 (*Reduction axioms: implied by the semantical embedding *)
 lemma atomic_permanence: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<^sup>Ap) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> \<^sup>Ap)\<^bold>\<rfloor>" by auto
 lemma conjunction: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<psi> \<^bold>\<and> \<chi>)) \<^bold>\<rightarrow> ((\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>) \<^bold>\<and> (\<^bold>[\<^bold>!\<phi>\<^bold>]\<chi>))\<^bold>\<rfloor>" by auto
 lemma part_func: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<^bold>\<not>\<psi>) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>))\<^bold>\<rfloor>" by auto
 lemma action_knowledge: "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>K\<^sub>i \<psi>)) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>K\<^sub>i (\<phi> \<^bold>\<rightarrow> (\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>))))\<^bold>\<rfloor>" by auto
 lemma "\<^bold>\<lfloor>(\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<psi>\<^bold>\<rparr>)) \<^bold>\<leftrightarrow> (\<phi> \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<phi>\<^bold>\<and>(\<^bold>[\<^bold>!\<phi>\<^bold>]\<chi>)\<^bold>|\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi>\<^bold>\<rparr>))\<^bold>\<rfloor>"
   by (smt (z3) intersection_rel_def sub_rel_def tc_def transitive_def)

 (* Axiom schemes for RCK: implied by the semantical embedding *)
 lemma \<C>_normality: "\<^bold>\<lfloor>\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rightarrow>\<psi>\<^bold>\<rparr> \<^bold>\<rightarrow>(\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr> \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<psi>\<^bold>\<rparr>)\<^bold>\<rfloor>" unfolding Defs by blast

 lemma mix_axiom1: "\<^bold>\<lfloor>\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr> \<^bold>\<rightarrow> \<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))\<^bold>\<rfloor>" unfolding Defs by smt

 lemma mix_axiom2': "A = (\<lambda>x. False) \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
   unfolding Defs by (metis (full_types))
 lemma mix_axiom2'': "A = (\<lambda>x. True) \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
   unfolding Defs by (metis (full_types)) (* takes long *)
 lemma mix_axiom2''': "A = (\<lambda>x. x = a) \<and> S5Agent a \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer finds proof, but reconstruction times✕out *) oops
 lemma mix_axiom2'''':
   "A = (\<lambda>x. x = a \<or> x = b) \<and> S5Agent a  \<and> S5Agent b \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer and nitpick timeout *) oops
 lemma mix_axiom2_general: "\<^bold>\<lfloor>(\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))) \<^bold>\<rightarrow> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>\<^bold>\<rfloor>"
   unfolding Defs  (* timeout *) oops

 lemma induction_axiom':
   "A = (\<lambda>x. False) \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   unfolding Defs by (metis (full_types))
 lemma induction_axiom'':
   "A = (\<lambda>x. True) \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer finds proof, but reconstruction times✕out *) oops
 lemma induction_axiom''':
   "A = (\<lambda>x. x = a)  \<and> S5Agent a  \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer finds proof, but reconstruction times✕out *) oops
 lemma induction_axiom'''':
   "A = (\<lambda>x. x = a \<or> x = b) \<and> S5Agent a  \<and> S5Agent b
         \<Longrightarrow> \<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer and nitpick timeout *) oops
 lemma induction_axiom_general: "\<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   unfolding Defs (* sledgehammer and nitpick timeout *) oops

 (* To ensure completeness we may also simply postulate axiom schemata in the LogiKEy approach *)
 axiomatization where
  mix_axiom_general: "\<^bold>\<lfloor>\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr> \<^bold>\<rightarrow> \<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> (\<phi> \<^bold>\<and> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)))\<^bold>\<rfloor>" and
  induction_axiom_general: "\<^bold>\<lfloor>((\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>)) \<^bold>\<and> \<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi> \<^bold>\<rightarrow> (\<^bold>E\<^sub>A(\<chi> \<^bold>\<rightarrow> \<phi>))\<^bold>\<rparr>) \<^bold>\<rightarrow> (\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"

 (* Necessitation rules: implied by the semantical embedding *)
 lemma announcement_nec: assumes "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<psi>\<^bold>]\<phi>\<^bold>\<rfloor>" by (simp add: assms)
 lemma rkc_necessitation: assumes "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor>" shows "\<^bold>\<lfloor>(\<^bold>C\<^sub>A\<^bold>\<lparr>\<chi>\<^bold>|\<phi>\<^bold>\<rparr>)\<^bold>\<rfloor>"
   by (smt assms intersection_rel_def sub_rel_def tc_def transitive_def)

 (* Checking for consistency (again) *)
 lemma True nitpick[satisfy,user_axioms] oops (* model found *)
 lemma False sledgehammer oops (* provers time out, i.e. fail to prove falsity *)

 (* Further axioms: implied for atomic formulas, but not implied in general *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>a \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" by simp
 lemma "\<^bold>\<lfloor>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "\<^bold>\<lfloor>(\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" by blast
 lemma "\<^bold>\<lfloor>(\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" using reflexive_def by auto
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<^sup>Ap) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<^sup>Ap\<^bold>](\<^sup>Ap \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<^sup>Ap)\<^bold>\<rfloor>" using  reflexive_def by auto
 lemma "S5Agent r \<Longrightarrow> \<^bold>\<lfloor>(\<^bold>K\<^sub>r \<phi>) \<^bold>\<rightarrow> \<^bold>\<not>\<^bold>[\<^bold>!\<phi>\<^bold>](\<phi> \<^bold>\<and> \<^bold>\<not>\<^bold>K\<^sub>r \<phi>)\<^bold>\<rfloor>" nitpick oops (* countermodel found *)

 (* Further checks on the atomic versus general validity. *)
 lemma "\<^bold>\<lfloor>p \<^bold>\<leftrightarrow> q\<^bold>\<rfloor> \<Longrightarrow> \<forall>W v. (p W v \<longleftrightarrow> q W v)" unfolding Defs nitpick oops (* countermodel *)
 lemma "\<forall>W v. (p W v \<longleftrightarrow> q W v) \<Longrightarrow> \<^bold>\<lfloor>p \<^bold>\<leftrightarrow> q\<^bold>\<rfloor>" unfolding Defs by simp
 lemma "\<^bold>\<lfloor>\<^sup>Ap \<^bold>\<leftrightarrow> \<^sup>Aq\<^bold>\<rfloor> \<Longrightarrow> \<forall>v. (p v \<longleftrightarrow> q v)" unfolding Defs by simp
 lemma "\<forall>v. (p v \<longleftrightarrow> q v) \<Longrightarrow> \<^bold>\<lfloor>\<^sup>Ap \<^bold>\<leftrightarrow> \<^sup>Aq\<^bold>\<rfloor>" unfolding Defs by simp

 (* Concrete models can be defined and studied. *)
 lemma assumes "W = (\<lambda>x. x = w1 \<or> x = w2 \<or> x = w3)"
               "w1 \<noteq> w2" "w1 \<noteq> w3" "w2 \<noteq> w3"
               "p W w1" "p W w2" "\<not>(p W w3)"
               "a w1 w1" "a w1 w2" "a w2 w1"
               "a w2 w2" "\<not>(a w1 w3)" "\<not>(a w3 w1)"
               "\<not>(a w2 w3)" "\<not>(a w3 w2)" "a w3 w3"
               "b w1 w1" "\<not>(b w1 w2)" "\<not>(b w2 w1)"
               "b w2 w2" "\<not>(b w1 w3)" "\<not>(b w3 w1)"
               "b w2 w3" "b w3 w2" "b w3 w3"
         shows "((p \<^bold>\<and> (\<^bold>K\<^sub>a p) \<^bold>\<and> (\<^bold>K\<^sub>b p)) \<^bold>\<and> \<^bold>\<not>(\<^bold>K\<^sub>a (\<^bold>K\<^sub>b p))) W w1"
   unfolding Defs
     nitpick[satisfy, atoms=w1 w2 w3] (* model *)
     using assms(1) assms(5) assms(6) assms(7)
           assms(9) assms(12) assms(21) assms(23) by blast (* proof *)
end