diff --git a/thys/Ordinal_Partitions/Erdos_Milner.thy b/thys/Ordinal_Partitions/Erdos_Milner.thy
new file mode 100644
--- /dev/null
+++ b/thys/Ordinal_Partitions/Erdos_Milner.thy
@@ -0,0 +1,1349 @@
+theory Erdos_Milner
+  imports Partitions
+
+begin
+
+subsection \<open>Erdős-Milner theorem\<close>
+
+text \<open>P. Erdős and E. C. Milner, A Theorem in the Partition Calculus.
+Canadian Math. Bull. 15:4 (1972), 501-505.
+Corrigendum, Canadian Math. Bull. 17:2 (1974), 305.\<close>
+
+text \<open>The paper defines strong types as satisfying the criteria below.
+      It remarks that ordinals satisfy those criteria. Here is a (too complicated) proof.\<close>
+proposition strong_ordertype_eq:
+  assumes D: "D \<subseteq> elts \<beta>" and "Ord \<beta>"
+  obtains L where "\<Union>(List.set L) = D" "\<And>X. X \<in> List.set L \<Longrightarrow> indecomposable (tp X)"
+    and "\<And>M. \<lbrakk>M \<subseteq> D; \<And>X. X \<in> List.set L \<Longrightarrow> tp (M \<inter> X) \<ge> tp X\<rbrakk> \<Longrightarrow> tp M = tp D"
+proof -
+  define \<phi> where "\<phi> \<equiv> inv_into D (ordermap D VWF)"
+  then have bij_\<phi>: "bij_betw \<phi> (elts (tp D)) D"
+    using D bij_betw_inv_into down ordermap_bij by blast
+  have \<phi>_cancel_left: "\<And>d. d \<in> D \<Longrightarrow> \<phi> (ordermap D VWF d) = d"
+    by (metis D \<phi>_def bij_betw_inv_into_left down_raw ordermap_bij small_iff_range total_on_VWF wf_VWF)
+  have \<phi>_cancel_right: "\<And>\<gamma>. \<gamma> \<in> elts (tp D) \<Longrightarrow> ordermap D VWF (\<phi> \<gamma>) = \<gamma>"
+    by (metis \<phi>_def f_inv_into_f ordermap_surj subsetD)
+  have "small D" "D \<subseteq> ON"
+    using assms down elts_subset_ON [of \<beta>] by auto
+  then have \<phi>_less_iff: "\<And>\<gamma> \<delta>. \<lbrakk>\<gamma> \<in> elts (tp D); \<delta> \<in> elts (tp D)\<rbrakk> \<Longrightarrow> \<phi> \<gamma> < \<phi> \<delta> \<longleftrightarrow> \<gamma> < \<delta>"
+    using ordermap_mono_less [of _ _ VWF D] bij_betw_apply [OF bij_\<phi>] VWF_iff_Ord_less \<phi>_cancel_right trans_VWF wf_VWF
+    by (metis ON_imp_Ord Ord_linear2 less_V_def order.asym)
+  obtain \<alpha>s where "List.set \<alpha>s \<subseteq> ON" and "\<omega>_dec \<alpha>s" and tpD_eq: "tp D = \<omega>_sum \<alpha>s"
+    using Ord_ordertype \<omega>_nf_exists by blast                \<comment> \<open>Cantor normal form of the ordertype\<close>
+  have ord [simp]: "Ord (\<alpha>s ! k)" "Ord (\<omega>_sum (take k \<alpha>s))" if "k < length \<alpha>s" for k
+    using that \<open>list.set \<alpha>s \<subseteq> ON\<close>
+    by (auto simp: dual_order.trans set_take_subset elim: ON_imp_Ord)
+  define E where "E \<equiv> \<lambda>k. lift (\<omega>_sum (take k \<alpha>s)) (\<omega>\<up>(\<alpha>s!k))"
+  define L where "L \<equiv> map (\<lambda>k. \<phi> ` (elts (E k))) [0..<length \<alpha>s]"
+  have [simp]: "length L = length \<alpha>s"
+    by (simp add: L_def)
+  have in_elts_E_less: "x' < x"
+    if "x' \<in> elts (E k')" "x \<in> elts (E k)" "k'<k" "k < length \<alpha>s" for k k' x' x
+                                      \<comment> \<open>The ordinals have been partitioned into disjoint intervals\<close>
+  proof -
+    have ord\<omega>: "Ord (\<omega> \<up> \<alpha>s ! k')"
+      using that by auto
+    from that id_take_nth_drop [of k' "take k \<alpha>s"]
+    obtain l where "take k \<alpha>s = take k' \<alpha>s @ (\<alpha>s!k') # l"
+      by (simp add: min_def)
+    then show ?thesis
+      using that  by (auto simp: E_def lift_def add.assoc dest!: OrdmemD [OF ord\<omega>] intro: less_le_trans)
+  qed
+  have elts_E: "elts (E k) \<subseteq> elts (\<omega>_sum \<alpha>s)"
+    if "k < length \<alpha>s" for k
+  proof -
+    have "\<omega> \<up> (\<alpha>s!k) \<le> \<omega>_sum (drop k \<alpha>s)"
+      by (metis that Cons_nth_drop_Suc \<omega>_sum_Cons add_le_cancel_left0)
+    then have "(+) (\<omega>_sum (take k \<alpha>s)) ` elts (\<omega> \<up> (\<alpha>s!k)) \<subseteq> elts (\<omega>_sum (take k \<alpha>s) + \<omega>_sum (drop k \<alpha>s))"
+      by blast
+    also have "\<dots> = elts (\<omega>_sum \<alpha>s)"
+      using \<omega>_sum_take_drop by auto
+    finally show ?thesis
+      by (simp add: lift_def E_def)
+  qed
+  have \<omega>_sum_in_tpD: "\<omega>_sum (take k \<alpha>s) + \<gamma> \<in> elts (tp D)"
+    if "\<gamma> \<in> elts (\<omega> \<up> \<alpha>s!k)" "k < length \<alpha>s" for \<gamma> k
+    using elts_E lift_def that tpD_eq by (auto simp: E_def)
+  have Ord_\<phi>: "Ord (\<phi> (\<omega>_sum (take k \<alpha>s) + \<gamma>))"
+    if "\<gamma> \<in> elts (\<omega> \<up> \<alpha>s!k)" "k < length \<alpha>s" for \<gamma> k
+    using \<omega>_sum_in_tpD \<open>D \<subseteq> ON\<close> bij_\<phi> bij_betw_imp_surj_on that by fastforce
+  define \<pi> where "\<pi> \<equiv> \<lambda>k. ((\<lambda>y. odiff y (\<omega>_sum (take k \<alpha>s))) \<circ> ordermap D VWF)"
+      \<comment> \<open>mapping the segments of @{term D} into some power of @{term \<omega>}\<close>
+  have bij_\<pi>: "bij_betw (\<pi> k) (\<phi> ` elts (E k)) (elts (\<omega> \<up> (\<alpha>s!k)))"
+    if "k < length \<alpha>s" for k
+    using that by (auto simp: bij_betw_def \<pi>_def E_def inj_on_def lift_def image_comp \<omega>_sum_in_tpD \<phi>_cancel_right that)
+  have \<pi>_iff: "\<pi> k x < \<pi> k y \<longleftrightarrow> (x,y) \<in> VWF"
+    if "x \<in> \<phi> ` elts (E k)" "y \<in> \<phi> ` elts (E k)" "k < length \<alpha>s" for k x y
+    using that
+    by (auto simp: \<pi>_def E_def lift_def \<omega>_sum_in_tpD \<phi>_cancel_right Ord_\<phi> \<phi>_less_iff)
+  have tp_E_eq [simp]: "tp (\<phi> ` elts (E k)) = \<omega>\<up>(\<alpha>s!k)"
+    if k: "k < length \<alpha>s" for k
+    using ordertype_eq_iff \<pi>_iff bij_\<pi> that
+    by (meson Ord_\<omega> Ord_oexp ord(1) ordertype_VWF_eq_iff replacement small_elts)
+  have tp_L_eq [simp]: "tp (L!k) = \<omega>\<up>(\<alpha>s!k)"
+    if "k < length \<alpha>s" for k
+    by (simp add: L_def that)
+  have UL_eq_D: "\<Union> (list.set L) = D"
+  proof (rule antisym)
+    show "\<Union> (list.set L) \<subseteq> D"
+      by (force simp: L_def tpD_eq bij_betw_apply [OF bij_\<phi>] dest: elts_E)
+    show "D \<subseteq> \<Union> (list.set L)"
+    proof
+      fix \<delta>
+      assume "\<delta> \<in> D"
+      then have "ordermap D VWF \<delta> \<in> elts (\<omega>_sum \<alpha>s)"
+        by (metis \<open>small D\<close> ordermap_in_ordertype tpD_eq)
+      then show "\<delta> \<in> \<Union> (list.set L)"
+        using \<open>\<delta> \<in> D\<close> \<phi>_cancel_left in_elts_\<omega>_sum
+        by (fastforce simp: L_def E_def image_iff lift_def)
+    qed
+  qed
+  show thesis
+  proof
+    show "indecomposable (tp X)" if "X \<in> list.set L" for X
+      using that by (auto simp: L_def indecomposable_\<omega>_power)
+  next
+    fix M
+    assume "M \<subseteq> D" and *: "\<And>X. X \<in> list.set L \<Longrightarrow> tp X \<le> tp (M \<inter> X)"
+    show "tp M = tp D"
+    proof (rule antisym)
+      show "tp M \<le> tp D"
+        by (simp add: \<open>M \<subseteq> D\<close> \<open>small D\<close> ordertype_VWF_mono)
+      define \<sigma> where "\<sigma> \<equiv> \<lambda>X. inv_into (M \<inter> X) (ordermap (M \<inter> X) VWF)"
+                              \<comment> \<open>The bijection from an @{term \<omega>}-power into the appropriate segment of @{term M}\<close>
+      have bij_\<sigma>: "bij_betw (\<sigma> X) (elts (tp (M \<inter> X))) (M \<inter> X)" for X
+        unfolding \<sigma>_def
+        by (metis (no_types) \<open>M \<subseteq> D\<close> \<open>small D\<close> bij_betw_inv_into inf_le1 ordermap_bij subset_iff_less_eq_V total_on_VWF wf_VWF)
+      have Ord_\<sigma>: "Ord (\<sigma> X \<alpha>)" if "\<alpha> \<in> elts (tp (M \<inter> X))" for \<alpha> X
+        using \<open>D \<subseteq> ON\<close> \<open>M \<subseteq> D\<close> bij_betw_apply [OF bij_\<sigma>] that by blast
+      have \<sigma>_cancel_right: "\<And>\<gamma> X. \<gamma> \<in> elts (tp (M \<inter> X)) \<Longrightarrow> ordermap (M \<inter> X) VWF (\<sigma> X \<gamma>) = \<gamma>"
+        by (metis \<sigma>_def f_inv_into_f ordermap_surj subsetD)
+      have smM: "small (M \<inter> X)" for X
+        by (meson \<open>M \<subseteq> D\<close> \<open>small D\<close> inf_le1 subset_iff_less_eq_V)
+      then have \<sigma>_less: "\<And>X \<gamma> \<delta>. \<lbrakk>\<gamma> < \<delta>; \<gamma> \<in> elts (tp (M \<inter> X)); \<delta> \<in> elts (tp (M \<inter> X))\<rbrakk>
+                          \<Longrightarrow> \<sigma> X \<gamma> < \<sigma> X \<delta>"
+        using ordermap_mono_less bij_betw_apply [OF bij_\<sigma>] VWF_iff_Ord_less \<sigma>_cancel_right trans_VWF wf_VWF
+        by (metis Ord_\<sigma> Ord_linear_lt less_imp_not_less ordermap_mono_less)
+      have "\<exists>k < length \<alpha>s. \<gamma> \<in> elts (E k)" if \<gamma>: "\<gamma> \<in> elts (tp D)" for \<gamma>
+      proof -
+        obtain X where "X \<in> set L" and X: "\<phi> \<gamma> \<in> X"
+          by (metis UL_eq_D \<gamma> Union_iff \<phi>_def in_mono inv_into_into ordermap_surj)
+        then have "\<exists>k < length \<alpha>s. \<gamma> \<in> elts (E k) \<and> X = \<phi> ` elts (E k)"
+          apply (clarsimp simp: L_def)
+          by (metis \<gamma> \<phi>_cancel_right elts_E in_mono tpD_eq)
+        then show ?thesis
+          by blast
+      qed
+      then obtain K where K: "\<And>\<gamma>. \<gamma> \<in> elts (tp D) \<Longrightarrow> K \<gamma> < length \<alpha>s \<and> \<gamma> \<in> elts (E (K \<gamma>))"
+        by metis  \<comment> \<open>The index from @{term "tp D"} to the appropriate segment number\<close>
+      define \<psi> where "\<psi> \<equiv> \<lambda>d. \<sigma> (L ! K (ordermap D VWF d)) (\<pi> (K (ordermap D VWF d)) d)"
+      show "tp D \<le> tp M"
+      proof (rule ordertype_inc_le)
+        show "small D" "small M"
+          using \<open>M \<subseteq> D\<close> \<open>small D\<close> subset_iff_less_eq_V by auto
+      next
+        fix d' d
+        assume xy: "d' \<in> D" "d \<in> D" and "(d',d) \<in> VWF"
+        then have "d' < d"
+          using ON_imp_Ord \<open>D \<subseteq> ON\<close> by auto
+        define \<gamma>' where "\<gamma>' \<equiv> ordermap D VWF d'"
+        define \<gamma> where "\<gamma> \<equiv> ordermap D VWF d"
+        have len': "K \<gamma>' < length \<alpha>s" and elts': "\<gamma>' \<in> elts (E (K \<gamma>'))"
+            and len: "K \<gamma> < length \<alpha>s" and elts: "\<gamma> \<in> elts (E (K \<gamma>))"
+          using K \<open>d' \<in> D\<close> \<open>d \<in> D\<close> by (auto simp: \<gamma>'_def \<gamma>_def \<open>small D\<close> ordermap_in_ordertype)
+        have **: "\<And>X w. \<lbrakk>X \<in> list.set L; w \<in> elts (tp X)\<rbrakk> \<Longrightarrow> w \<in> elts (tp (M \<inter> X))"
+          using "*" by blast
+        have Ord_\<sigma>L: "Ord (\<sigma> (L!k) (\<pi> k d))" if "d \<in> \<phi> ` elts (E k)" "k < length \<alpha>s" for k d
+          by (metis "**" Ord_\<sigma> \<open>length L = length \<alpha>s\<close> bij_\<pi> bij_betw_imp_surj_on imageI nth_mem that tp_L_eq)
+        have "\<gamma>' < \<gamma>"
+          by (metis \<gamma>'_def \<gamma>_def \<open>d' < d\<close> \<open>small D\<close> \<phi>_cancel_left \<phi>_less_iff ordermap_in_ordertype xy)
+        then have "K \<gamma>' \<le> K \<gamma>"
+          using elts' elts by (meson in_elts_E_less leI len' less_asym)
+        then consider (less) "K \<gamma>' < K \<gamma>" | (equal) "K \<gamma>' = K \<gamma>"
+          by linarith
+        then have "\<sigma> (L ! K \<gamma>') (\<pi> (K \<gamma>') d') < \<sigma> (L ! K \<gamma>) (\<pi> (K \<gamma>) d)"
+        proof cases
+          case less
+          obtain \<dagger>: "\<sigma> (L ! K \<gamma>') (\<pi> (K \<gamma>') d') \<in> M \<inter> L ! K \<gamma>'" "\<sigma> (L ! K \<gamma>) (\<pi> (K \<gamma>) d) \<in> M \<inter> L ! K \<gamma>"
+            using elts' elts len' len
+            unfolding \<gamma>'_def \<gamma>_def
+            by (metis "**" \<open>length L = length \<alpha>s\<close> \<phi>_cancel_left bij_\<pi> bij_\<sigma> bij_betw_imp_surj_on imageI nth_mem tp_L_eq xy)
+          then have "ordermap D VWF (\<sigma> (L ! K \<gamma>') (\<pi> (K \<gamma>') d')) \<in> elts (E (K \<gamma>'))" "ordermap D VWF (\<sigma> (L ! K \<gamma>) (\<pi> (K \<gamma>) d)) \<in> elts (E (K \<gamma>))"
+            using len' len elts_E tpD_eq
+            by (fastforce simp: L_def \<gamma>'_def \<gamma>_def \<phi>_cancel_right)+
+          then have "ordermap D VWF (\<sigma> (L ! K \<gamma>') (\<pi> (K \<gamma>') d')) < ordermap D VWF (\<sigma> (L ! K \<gamma>) (\<pi> (K \<gamma>) d))"
+            using in_elts_E_less len less by blast
+          moreover have "\<sigma> (L ! K \<gamma>') (\<pi> (K \<gamma>') d') \<in> D" "\<sigma> (L ! K \<gamma>) (\<pi> (K \<gamma>) d) \<in> D"
+            using \<open>M \<subseteq> D\<close> \<dagger> by auto
+          ultimately show ?thesis
+            by (metis \<open>small D\<close> \<phi>_cancel_left \<phi>_less_iff ordermap_in_ordertype)
+        next
+          case equal
+          show ?thesis
+            unfolding equal
+          proof (rule \<sigma>_less)
+            show "\<pi> (K \<gamma>) d' < \<pi> (K \<gamma>) d"
+              by (metis equal \<gamma>'_def \<gamma>_def \<open>(d', d) \<in> VWF\<close> \<phi>_cancel_left \<pi>_iff elts elts' imageI len xy)
+            have "\<pi> (K \<gamma>) d' \<in> elts (tp (L ! K \<gamma>))" "\<pi> (K \<gamma>) d \<in> elts (tp (L ! K \<gamma>))"
+              using equal \<phi>_cancel_left \<gamma>'_def elts' len' \<gamma>_def elts len xy
+              by (force intro: bij_betw_apply [OF bij_\<pi>])+
+            then show "\<pi> (K \<gamma>) d' \<in> elts (tp (M \<inter> L ! K \<gamma>))" "\<pi> (K \<gamma>) d \<in> elts (tp (M \<inter> L ! K \<gamma>))"
+              by (simp_all add: "**" len)
+          qed
+        qed
+        moreover have "Ord (\<sigma> (L ! K \<gamma>') (\<pi> (K \<gamma>') d'))"
+          using Ord_\<sigma>L \<gamma>'_def \<phi>_cancel_left elts' len' xy(1) by fastforce
+        moreover have "Ord (\<sigma> (L ! K \<gamma>) (\<pi> (K \<gamma>) d))"
+          using Ord_\<sigma>L \<gamma>_def \<phi>_cancel_left elts len xy by fastforce
+        ultimately show "(\<psi> d', \<psi> d) \<in> VWF"
+          by (simp add: \<psi>_def \<gamma>'_def \<gamma>_def)
+      next
+        show "\<psi> ` D \<subseteq> M"
+        proof (clarsimp simp: \<psi>_def)
+          fix d
+          assume "d \<in> D"
+          define \<gamma> where "\<gamma> \<equiv> ordermap D VWF d"
+          have len: "K \<gamma> < length \<alpha>s" and elts: "\<gamma> \<in> elts (E (K \<gamma>))"
+            using K \<open>d \<in> D\<close> by (auto simp: \<gamma>_def \<open>small D\<close> ordermap_in_ordertype)
+          have "\<pi> (K \<gamma>) d \<in> elts (tp (L! (K \<gamma>)))"
+            using bij_\<pi> [OF len] \<open>d \<in> D\<close>
+            apply (simp add: L_def len)
+            by (metis \<gamma>_def \<phi>_cancel_left bij_betw_imp_surj_on elts imageI)
+          then have "\<sigma> (L! (K \<gamma>)) (\<pi> (K \<gamma>) d) \<in> M \<inter> (L! (K \<gamma>))"
+            using smM bij_betw_imp_surj_on [OF ordermap_bij] \<open>length L = length \<alpha>s\<close>
+            unfolding \<sigma>_def
+            by (metis (no_types) "*" inv_into_into len nth_mem vsubsetD total_on_VWF wf_VWF)
+          then show "\<sigma> (L ! K (ordermap D VWF d)) (\<pi> (K (ordermap D VWF d)) d) \<in> M"
+            using \<gamma>_def by blast
+        qed
+      qed auto
+    qed
+  qed (simp add: UL_eq_D)
+qed
+
+
+text \<open>The ``remark'' of Erdős and E. C. Milner, Canad. Math. Bull. Vol. 17 (2), 1974\<close>
+
+proposition indecomposable_imp_Ex_less_sets:
+  assumes indec: "indecomposable \<alpha>" and "\<alpha> > 1" "Ord \<beta>" and A: "tp A = \<alpha>" "A \<subseteq> elts (\<alpha>*\<beta>)"
+    and "x \<in> A" and A1: "tp A1 = \<alpha>" "A1 \<subseteq> A"
+  obtains A2 where "tp A2 = \<alpha>" "A2 \<subseteq> A1" "less_sets {x} A2"
+proof -
+  have "Ord \<alpha>"
+    using indec indecomposable_imp_Ord by blast
+  have "Limit \<alpha>"
+    by (simp add: assms indecomposable_imp_Limit)
+  have "small A"
+    by (meson A small_elts smaller_than_small)
+  define \<phi> where "\<phi> \<equiv> inv_into A (ordermap A VWF)"
+  then have bij_\<phi>: "bij_betw \<phi> (elts \<alpha>) A"
+    using A bij_betw_inv_into down ordermap_bij by blast
+  have bij_om: "bij_betw (ordermap A VWF) A (elts \<alpha>)"
+    using A down ordermap_bij by blast
+  define \<gamma> where "\<gamma> \<equiv> ordermap A VWF x"
+  have \<gamma>: "\<gamma> \<in> elts \<alpha>"
+    unfolding \<gamma>_def using A \<open>x \<in> A\<close> down by auto
+  then have "Ord \<gamma>"
+    using Ord_in_Ord \<open>Ord \<alpha>\<close> by blast
+  have "A \<subseteq> ON"
+    by (meson Ord_mult \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> A dual_order.trans elts_subset_ON)
+  define B where "B \<equiv> \<phi> ` (elts (succ \<gamma>))"
+  show thesis
+  proof
+    have "small A1"
+      by (meson \<open>small A\<close> A1 smaller_than_small)
+    then have "tp (A1 - B) \<le> tp A1"
+      unfolding B_def by (auto intro!: ordertype_VWF_mono del: vsubsetI)
+    moreover have "tp (A1 - B) \<ge> \<alpha>"
+    proof -
+      have "\<not> (\<alpha> \<le> tp B)"
+        unfolding B_def
+      proof (subst ordertype_VWF_inc_eq)
+        show "elts (succ  \<gamma>) \<subseteq> ON"
+          by (auto simp: \<gamma>_def ordertype_VWF_inc_eq intro: Ord_in_Ord)
+        have "elts (succ  \<gamma>) \<subseteq> elts \<alpha>"
+          using Ord_trans \<gamma> \<open>Ord \<alpha>\<close> by auto
+        then show "\<phi> ` elts (succ  \<gamma>) \<subseteq> ON"
+          using \<open>A \<subseteq> ON\<close> bij_\<phi> bij_betw_imp_surj_on by blast
+        show "\<phi> u < \<phi> v"
+          if "u \<in> elts (succ  \<gamma>)" and "v \<in> elts (succ  \<gamma>)" and "u < v" for u v
+        proof -
+          have "succ \<gamma> \<in> elts \<alpha>"
+            using \<gamma> Limit_def \<open>Limit \<alpha>\<close> by blast
+          then have "u \<in> elts \<alpha>" "v \<in> elts \<alpha>"
+            using Ord_trans \<open>Ord \<alpha>\<close> that by blast+
+          then show ?thesis
+            using that \<open>Limit \<alpha>\<close> \<open>small A\<close> A bij_betwE [OF bij_\<phi>]
+            by (metis ON_imp_Ord Ord_linear2 \<open>A \<subseteq> ON\<close> \<phi>_def inv_ordermap_VWF_mono_le leD)
+        qed
+        show "\<not> \<alpha> \<le> tp (elts (succ  \<gamma>))"
+        proof (subst ordertype_eq_Ord)
+          show "\<not> \<alpha> \<le> succ \<gamma>"
+            by (meson \<gamma> \<open>Limit \<alpha>\<close> less_eq_V_def mem_not_refl subsetD succ_in_Limit_iff)
+        qed (use \<open>Ord \<gamma>\<close> in blast)
+      qed auto
+      then show ?thesis
+        using indecomposable_ordertype_ge [OF indec, of A1 B] \<open>small A1\<close> A1
+        by (auto simp: B_def)
+    qed
+    ultimately show "tp (A1 - B) = \<alpha>"
+      using A1 by blast
+    show "less_sets {x} (A1 - B)"
+    proof (clarsimp simp: less_sets_def B_def simp del: elts_succ)
+      fix y
+      assume "y \<in> A1" and y: "y \<notin> \<phi> ` elts (succ \<gamma>)"
+      obtain "Ord x" "Ord y"
+        using \<open>A \<subseteq> ON\<close> \<open>x \<in> A\<close> \<open>y \<in> A1\<close> A1 by auto
+      have "y \<in> \<phi> ` elts (succ \<gamma>)" if "y \<in> elts (succ x)"
+      proof -
+        have "ordermap A VWF y \<in> elts (ZFC_in_HOL.succ (ordermap A VWF x))"
+          using A1
+          by (metis insert_iff ordermap_mono subset_iff that wf_VWF OrdmemD VWF_iff_Ord_less \<open>Ord x\<close> \<open>Ord y\<close> \<open>small A\<close> \<open>y \<in> A1\<close> elts_succ)
+        then show ?thesis
+          using that A1 unfolding \<gamma>_def
+          by (metis \<open>y \<in> A1\<close> \<phi>_def bij_betw_inv_into_left bij_om imageI subsetD)
+      qed
+      then show "x < y"
+        by (meson Ord_linear2 Ord_mem_iff_lt Ord_succ \<open>Ord x\<close> \<open>Ord y\<close> y succ_le_iff)
+    qed
+  qed auto
+qed
+
+
+text \<open>the main theorem, from which they derive the headline result\<close>
+theorem Erdos_Milner_aux:
+  fixes k::nat and \<gamma>::V
+  assumes part: "partn_lst_VWF \<alpha> [ord_of_nat k, \<gamma>] 2"
+    and indec: "indecomposable \<alpha>" and "k > 1" "Ord \<gamma>" and \<beta>: "\<beta> \<in> elts \<omega>1"
+  shows "partn_lst_VWF (\<alpha>*\<beta>) [ord_of_nat (2*k), min \<gamma> (\<omega>*\<beta>)] 2"
+proof (cases "\<alpha>=1 \<or> \<beta>=0")
+  case True
+  have "Ord \<beta>"
+    using Ord_\<omega>1 Ord_in_Ord \<beta> by blast
+  show ?thesis
+  proof (cases "\<beta>=0")
+    case True
+    moreover have "min \<gamma> 0 = 0"
+      by (simp add: min_def)
+    ultimately show ?thesis
+      by (simp add: partn_lst_triv0 [where i=1])
+  next
+    case False
+    then have "\<alpha>=1"
+      using True by blast
+    then obtain i where "i < Suc (Suc 0)" "[ord_of_nat k, \<gamma>] ! i \<le> \<alpha>"
+      using partn_lst_VWF_nontriv [OF part] by auto
+    then have "\<gamma> \<le> 1"
+      using \<open>\<alpha>=1\<close> \<open>k > 1\<close> by (fastforce simp: less_Suc_eq)
+    then have "min \<gamma> (\<omega>*\<beta>) \<le> 1"
+      by (metis Ord_1 Ord_\<omega> Ord_linear_le Ord_mult \<open>Ord \<beta>\<close> min_def order_trans)
+    moreover have "elts \<beta> \<noteq> {}"
+      using False by auto
+    ultimately show ?thesis
+      by (auto simp: True \<open>Ord \<beta>\<close> \<open>\<beta>\<noteq>0\<close> \<open>\<alpha>=1\<close> intro!: partn_lst_triv1 [where i=1])
+  qed
+next
+  case False
+  then have "\<alpha> \<noteq> 1" "\<beta> \<noteq> 0"
+    by auto
+  then have "0 \<in> elts \<beta>"
+    using Ord_\<omega>1 Ord_in_Ord \<beta> mem_0_Ord by blast
+  show ?thesis
+  proof (cases "\<alpha>=0")
+    case True
+    have \<dagger>: "[ord_of_nat (2 * k), 0] ! 1 = 0"
+      by simp
+    show ?thesis
+      using True assms
+      by (force simp: partn_lst_def nsets_empty_iff simp flip: numeral_2_eq_2 dest!: less_2_cases intro: \<dagger>)
+  next
+    case False
+    then have "\<alpha> \<ge> \<omega>"
+      using indec \<open>\<alpha> \<noteq> 1\<close>
+      by (metis Ord_\<omega> indecomposable_is_\<omega>_power le_oexp oexp_0_right)
+    then have "\<alpha> > 1"
+      using \<omega>_gt1 dual_order.strict_trans1 by blast
+    show ?thesis
+      unfolding partn_lst_def
+    proof clarsimp
+      fix f
+      assume "f \<in> [elts (\<alpha>*\<beta>)]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
+      then have f: "f \<in> [elts (\<alpha>*\<beta>)]\<^bsup>2\<^esup> \<rightarrow> {..<2::nat}"
+        by (simp add: eval_nat_numeral)
+      obtain ord [iff]: "Ord \<alpha>" "Ord \<beta>" "Ord (\<alpha>*\<beta>)"
+        using Ord_\<omega>1 Ord_in_Ord \<beta> indec indecomposable_imp_Ord Ord_mult by blast
+      have *: False
+        if i [rule_format]: "\<forall>H. tp H = ord_of_nat (2*k) \<longrightarrow> H \<subseteq> elts (\<alpha>*\<beta>) \<longrightarrow> \<not> f ` [H]\<^bsup>2\<^esup> \<subseteq> {0}"
+          and ii [rule_format]: "\<forall>H. tp H = \<gamma> \<longrightarrow> H \<subseteq> elts (\<alpha>*\<beta>) \<longrightarrow> \<not> f ` [H]\<^bsup>2\<^esup> \<subseteq> {1}"
+          and iii [rule_format]: "\<forall>H. tp H = (\<omega>*\<beta>) \<longrightarrow> H \<subseteq> elts (\<alpha>*\<beta>) \<longrightarrow> \<not> f ` [H]\<^bsup>2\<^esup> \<subseteq> {1}"
+      proof -
+        have Ak0: "\<exists>X \<in> [A]\<^bsup>k\<^esup>. f ` [X]\<^bsup>2\<^esup> \<subseteq> {0}" \<comment>\<open>remark (8) about @{term"A \<subseteq> S"}\<close>
+          if A_\<alpha>\<beta>: "A \<subseteq> elts (\<alpha>*\<beta>)" and ot: "tp A \<ge> \<alpha>" for A
+        proof -
+          let ?g = "inv_into A (ordermap A VWF)"
+          have "small A"
+            using down that by auto
+          then have inj_g: "inj_on ?g (elts \<alpha>)"
+            by (meson inj_on_inv_into less_eq_V_def ordermap_surj ot subset_trans)
+          have Aless: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; x < y\<rbrakk> \<Longrightarrow> (x,y) \<in> VWF"
+            by (meson Ord_in_Ord VWF_iff_Ord_less \<open>Ord(\<alpha>*\<beta>)\<close> subsetD that(1))
+          then have om_A_less: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; x < y\<rbrakk> \<Longrightarrow> ordermap A VWF x < ordermap A VWF y"
+            by (auto simp: \<open>small A\<close> ordermap_mono_less)
+          have \<alpha>_sub: "elts \<alpha> \<subseteq> ordermap A VWF ` A"
+            by (metis \<open>small A\<close> elts_of_set less_eq_V_def ordertype_def ot replacement)
+          have g_less: "?g x < ?g y" if "x < y" "x \<in> elts \<alpha>" "y \<in> elts \<alpha>" for x y
+          proof -
+            have "?g x \<in> A" "?g y \<in> A"
+              using that by (meson \<alpha>_sub inv_into_into subsetD)+
+            moreover have "x \<in> ordermap A VWF ` A" "y \<in> ordermap A VWF ` A"
+              using \<alpha>_sub that by blast+
+            moreover have "A \<subseteq> ON"
+              using A_\<alpha>\<beta> elts_subset_ON \<open>Ord(\<alpha>*\<beta>)\<close> by blast
+            ultimately show ?thesis
+              by (metis ON_imp_Ord Ord_linear_lt f_inv_into_f less_not_sym om_A_less \<open>x < y\<close>)
+          qed
+          have "?g \<in> elts \<alpha> \<rightarrow> elts (\<alpha> * \<beta>)"
+            by (meson A_\<alpha>\<beta> Pi_I' \<alpha>_sub inv_into_into subset_eq)
+          then have fg: "f \<circ> (\<lambda>X. ?g ` X) \<in> [elts \<alpha>]\<^bsup>2\<^esup> \<rightarrow> {..<2}"
+            by (rule nsets_compose_image_funcset [OF f _ inj_g])
+          obtain i H where "i < 2" "H \<subseteq> elts \<alpha>"
+            and ot_eq: "tp H = [k,\<gamma>]!i" "(f \<circ> (\<lambda>X. ?g ` X)) ` (nsets H 2) \<subseteq> {i}"
+            using ii partn_lst_E [OF part fg] by (auto simp: eval_nat_numeral)
+          then consider (0) "i=0" | (1) "i=1"
+            by linarith
+          then show ?thesis
+          proof cases
+            case 0
+            then have "f ` [inv_into A (ordermap A VWF) ` H]\<^bsup>2\<^esup> \<subseteq> {0}"
+              using ot_eq \<open>H \<subseteq> elts \<alpha>\<close> \<alpha>_sub by (auto simp: nsets_def [of _ k] inj_on_inv_into elim!: nset_image_obtains)
+            moreover have "finite H \<and> card H = k"
+              using 0 ot_eq \<open>H \<subseteq> elts \<alpha>\<close> down by (simp add: finite_ordertype_eq_card)
+            then have "inv_into A (ordermap A VWF) ` H \<in> [A]\<^bsup>k\<^esup>"
+              using \<open>H \<subseteq> elts \<alpha>\<close> \<alpha>_sub by (auto simp: nsets_def [of _ k] card_image inj_on_inv_into inv_into_into)
+            ultimately show ?thesis
+              by blast
+          next
+            case 1
+            have gH: "?g ` H \<subseteq> elts (\<alpha> * \<beta>)"
+              by (metis A_\<alpha>\<beta> \<alpha>_sub \<open>H \<subseteq> elts \<alpha>\<close> image_subsetI inv_into_into subset_eq)
+            have [simp]: "tp (?g ` H) = tp H"
+            proof (rule ordertype_VWF_inc_eq)
+              show "?g ` H \<subseteq> ON"
+                using elts_subset_ON gH ord(3) by auto
+              show "?g x < inv_into A (ordermap A VWF) y" if "x \<in> H" "y \<in> H" "x < y" for x y
+                using that \<open>H \<subseteq> elts \<alpha>\<close> g_less by blast
+            qed (use \<open>H \<subseteq> elts \<alpha>\<close> elts_subset_ON ord down in auto)
+            show ?thesis
+              using ii [of "?g ` H"] ot_eq 1
+              apply (auto simp: gH elim!: nset_image_obtains)
+              apply (meson \<open>H \<subseteq> elts \<alpha>\<close> inj_g bij_betw_def inj_on_subset)
+              done
+          qed
+        qed
+        define K where "K \<equiv> \<lambda>i x. {y \<in> elts (\<alpha>*\<beta>). x \<noteq> y \<and> f{x,y} = i}"
+        have small_K: "small (K i x)" for i x
+          by (simp add: K_def)
+        define KI where "KI \<equiv> \<lambda>i X. (\<Inter>x\<in>X. K i x)"
+        have KI_disj_self: "X \<inter> KI i X = {}" for i X
+          by (auto simp: KI_def K_def)
+        define M where "M \<equiv> \<lambda>D \<AA> x. {\<nu>::V. \<nu> \<in> D \<and> tp (K 1 x \<inter> \<AA> \<nu>) \<ge> \<alpha>}"
+        have M_sub_D: "M D \<AA> x \<subseteq> D" for D \<AA> x
+          by (auto simp: M_def)
+        have small_M [simp]: "small (M D \<AA> x)" if "small D" for D \<AA> x
+          by (simp add: M_def that)
+        have 9: "tp {x \<in> A. tp (M D \<AA> x) \<ge> tp D} \<ge> \<alpha>" (is "ordertype ?AD _ \<ge> \<alpha>")
+          if inD: "indecomposable (tp D)" and D: "D \<subseteq> elts \<beta>" and A: "A \<subseteq> elts (\<alpha>*\<beta>)" and tpA: "tp A = \<alpha>"
+            and \<AA>: "\<AA> \<in> D \<rightarrow> {X. X \<subseteq> elts (\<alpha>*\<beta>) \<and> tp X = \<alpha>}"  for D A \<AA>
+            \<comment>\<open>remark (9), assuming an indecomposable order type\<close>
+        proof (rule ccontr)
+          define A' where "A' \<equiv> {x \<in> A. \<not> tp (M D \<AA> x) \<ge> tp D}"
+          have small [iff]: "small A" "small D"
+            using A D down by (auto simp: M_def)
+          have small_\<AA>: "small (\<AA> \<delta>)" if "\<delta> \<in> D" for \<delta>
+            using that \<AA> by (auto simp: Pi_iff subset_iff_less_eq_V)
+          assume not_\<alpha>_le: "\<not> \<alpha> \<le> tp {x \<in> A. tp (M D \<AA> x) \<ge> tp D}"
+          moreover
+          obtain "small A" "small A'" "A' \<subseteq> A" and A'_sub: "A' \<subseteq> elts (\<alpha> * \<beta>)"
+            using A'_def A down by auto
+          moreover have "A' = A - ?AD"
+            by (force simp: A'_def)
+          ultimately have A'_ge: "tp A' \<ge> \<alpha>"
+            by (metis (no_types, lifting) dual_order.refl indec indecomposable_ordertype_eq mem_Collect_eq subsetI tpA)
+          obtain X where "X \<subseteq> A'" "finite X" "card X = k" and fX0: "f ` [X]\<^bsup>2\<^esup> \<subseteq> {0}"
+            using Ak0 [OF A'_sub A'_ge] by (auto simp: nsets_def [of _ k])
+          then have \<ddagger>: "\<not> tp (M D \<AA> x) \<ge> tp D" if "x \<in> X" for x
+            using that by (auto simp: A'_def)
+          obtain x where "x \<in> X"
+            using \<open>card X = k\<close> \<open>k>1\<close> by fastforce
+          have "\<not> D \<subseteq> (\<Union> x\<in>X. M D \<AA> x)"
+          proof
+            assume not: "D \<subseteq> (\<Union>x\<in>X. M D \<AA> x)"
+            have "\<exists>X\<in>M D \<AA> ` X. tp D \<le> tp X"
+            proof (rule indecomposable_ordertype_finite_ge [OF inD])
+              show "M D \<AA> ` X \<noteq> {}"
+                using A'_def A'_ge not not_\<alpha>_le by auto
+              show "small (\<Union> (M D \<AA> ` X))"
+                using \<open>finite X\<close> by (simp add: finite_imp_small)
+            qed (use \<open>finite X\<close> not in auto)
+            then show False
+              by (simp add: \<ddagger>)
+          qed
+          then obtain \<nu> where "\<nu> \<in> D" and \<nu>: "\<nu> \<notin> (\<Union> x\<in>X. M D \<AA> x)"
+            by blast
+          define \<A> where "\<A> \<equiv> {KI 0 X \<inter> \<AA> \<nu>, \<Union>x\<in>X. K 1 x \<inter> \<AA> \<nu>, X \<inter> \<AA> \<nu>}"
+          have \<alpha>\<beta>: "X \<subseteq> elts (\<alpha>*\<beta>)" "\<AA> \<nu> \<subseteq> elts (\<alpha>*\<beta>)"
+            using A'_sub \<open>X \<subseteq> A'\<close> \<AA> \<open>\<nu> \<in> D\<close> by auto
+          then have "KI 0 X \<union> (\<Union>x\<in>X. K 1 x) \<union> X = elts (\<alpha>*\<beta>)"
+            using \<open>x \<in> X\<close> f by (force simp: K_def KI_def Pi_iff less_2_cases_iff)
+          with \<alpha>\<beta> have \<AA>\<nu>_\<A>: "finite \<A>" "\<AA> \<nu> \<subseteq> \<Union>\<A>"
+            by (auto simp: \<A>_def)
+          then have "\<not> tp (K 1 x \<inter> \<AA> \<nu>) \<ge> \<alpha>" if "x \<in> X" for x
+            using that \<open>\<nu> \<in> D\<close> \<nu> \<open>k > 1\<close> \<open>card X = k\<close> by (fastforce simp: M_def)
+          moreover have sm_K1: "small (\<Union>x\<in>X. K 1 x \<inter> \<AA> \<nu>)"
+            by (meson Finite_V Int_lower2 \<open>\<nu> \<in> D\<close> \<open>finite X\<close> small_\<AA> small_UN smaller_than_small)
+          ultimately have not1: "\<not> tp (\<Union>x\<in>X. K 1 x \<inter> \<AA> \<nu>) \<ge> \<alpha>"
+            using \<open>finite X\<close> \<open>x \<in> X\<close> indecomposable_ordertype_finite_ge [OF indec, of "(\<lambda>x. K 1 x \<inter> \<AA> \<nu>) ` X"] by blast
+          moreover have "\<not> tp (X \<inter> \<AA> \<nu>) \<ge> \<alpha>"
+            using \<open>finite X\<close> \<open>\<alpha> \<ge> \<omega>\<close>
+            by (meson finite_Int mem_not_refl ordertype_VWF_\<omega> vsubsetD)
+          moreover have "\<alpha> \<le> tp (\<AA> \<nu>)"
+            using \<AA> \<open>\<nu> \<in> D\<close> small_\<AA> by fastforce+
+          moreover have "small (\<Union> \<A>)"
+            using \<open>\<nu> \<in> D\<close> small_\<AA> by (fastforce simp: \<A>_def intro: smaller_than_small sm_K1)
+          ultimately have K0\<AA>_ge: "tp (KI 0 X \<inter> \<AA> \<nu>) \<ge> \<alpha>"
+            using indecomposable_ordertype_finite_ge [OF indec \<AA>\<nu>_\<A>] by (auto simp: \<A>_def)
+          have \<AA>\<nu>: "\<AA> \<nu> \<subseteq> elts (\<alpha> * \<beta>)" "tp (\<AA> \<nu>) = \<alpha>"
+            using \<open>\<nu> \<in> D\<close> \<AA> by blast+
+          then obtain Y where Ysub: "Y \<subseteq> KI 0 X \<inter> \<AA> \<nu>" and "finite Y" "card Y = k" and fY0: "f ` [Y]\<^bsup>2\<^esup> \<subseteq> {0}"
+            using Ak0 [OF _ K0\<AA>_ge] by (auto simp: nsets_def [of _ k])
+          have \<dagger>: "X \<inter> Y = {}"
+            using Ysub KI_disj_self by blast
+          then have "card (X \<union> Y) = 2*k"
+            by (simp add: \<open>card X = k\<close> \<open>card Y = k\<close> \<open>finite X\<close> \<open>finite Y\<close> card_Un_disjoint)
+          moreover have "X \<union> Y \<subseteq> elts (\<alpha> * \<beta>)"
+            using A'_sub \<open>X \<subseteq> A'\<close> \<AA>\<nu>(1) \<open>Y \<subseteq> KI 0 X \<inter> \<AA> \<nu>\<close> by auto
+          moreover have "f ` [X \<union> Y]\<^bsup>2\<^esup> \<subseteq> {0}"
+            using fX0 fY0 Ysub by (auto simp: \<dagger> nsets_disjoint_2 image_Un image_UN KI_def K_def)
+          ultimately show False
+            using i \<open>finite X\<close> \<open>finite Y\<close> ordertype_VWF_finite_nat by auto
+        qed
+        have IX: "tp {x \<in> A. tp (M D \<AA> x) \<ge> tp D} \<ge> \<alpha>"
+          if D: "D \<subseteq> elts \<beta>" and A: "A \<subseteq> elts (\<alpha>*\<beta>)" and tpA: "tp A = \<alpha>"
+            and \<AA>: "\<AA> \<in> D \<rightarrow> {X. X \<subseteq> elts (\<alpha>*\<beta>) \<and> tp X = \<alpha>}" for D A \<AA>
+            \<comment>\<open>remark (9) for any order type\<close>
+        proof -
+          obtain L where UL: "\<Union>(List.set L) \<subseteq> D"
+            and indL: "\<And>X. X \<in> List.set L \<Longrightarrow> indecomposable (tp X)"
+            and eqL: "\<And>M. \<lbrakk>M \<subseteq> D; \<And>X. X \<in> List.set L \<Longrightarrow> tp (M \<inter> X) \<ge> tp X\<rbrakk> \<Longrightarrow> tp M = tp D"
+            using ord by (metis strong_ordertype_eq D order_refl)
+          obtain A'' where A'': "A'' \<subseteq> A" "tp A'' \<ge> \<alpha>"
+            and "\<And>x X. \<lbrakk>x \<in> A''; X \<in> List.set L\<rbrakk> \<Longrightarrow> tp (M D \<AA> x \<inter> X) \<ge> tp X"
+            using UL indL
+          proof (induction L arbitrary: thesis)
+            case (Cons X L)
+            then obtain A'' where A'': "A'' \<subseteq> A" "tp A'' \<ge> \<alpha>" and "X \<subseteq> D"
+              and ge_X: "\<And>x X. \<lbrakk>x \<in> A''; X \<in> List.set L\<rbrakk> \<Longrightarrow> tp (M D \<AA> x \<inter> X) \<ge> tp X" by auto
+            then have tp_A'': "tp A'' = \<alpha>"
+              by (metis A antisym down ordertype_VWF_mono tpA)
+            have ge_\<alpha>: "tp {x \<in> A''. tp (M X \<AA> x) \<ge> tp X} \<ge> \<alpha>"
+              by (rule 9) (use A A'' tp_A'' Cons.prems \<open>D \<subseteq> elts \<beta>\<close> \<open>X \<subseteq> D\<close> \<AA> in auto)
+            let ?A = "{x \<in> A''. tp (M D \<AA> x \<inter> X) \<ge> tp X}"
+            have M_eq: "M D \<AA> x \<inter> X = M X \<AA> x" if "x \<in> A''" for x
+              using that \<open>X \<subseteq> D\<close> by (auto simp: M_def)
+            show thesis
+            proof (rule Cons.prems)
+              show "\<alpha> \<le> tp ?A"
+                using ge_\<alpha> by (simp add: M_eq cong: conj_cong)
+              show "tp Y \<le> tp (M D \<AA> x \<inter> Y)" if "x \<in> ?A" "Y \<in> list.set (X # L)" for x Y
+                using that ge_X by force
+            qed (use A'' in auto)
+          qed (use tpA in auto)
+          then have tp_M_ge: "tp (M D \<AA> x) \<ge> tp D" if "x \<in> A''" for x
+            using eqL that by (auto simp: M_def)
+          have "\<alpha> \<le> tp A''"
+            by (simp add: A'')
+          also have "\<dots> \<le> tp {x \<in> A''. tp (M D \<AA> x) \<ge> tp D}"
+            by (metis (mono_tags, lifting) tp_M_ge eq_iff mem_Collect_eq subsetI)
+          also have "\<dots> \<le> tp {x \<in> A. tp D \<le> tp (M D \<AA> x)}"
+            by (rule ordertype_mono) (use A'' A down in auto)
+          finally show ?thesis .
+        qed
+        have [simp]: "tp {0} = 1"
+          using ordertype_eq_Ord by fastforce
+        have IX': "tp {x \<in> A'. tp (K 1 x \<inter> A) \<ge> \<alpha>} \<ge> \<alpha>"
+          if A: "A \<subseteq> elts (\<alpha>*\<beta>)" "tp A = \<alpha>" and A': "A' \<subseteq> elts (\<alpha>*\<beta>)" "tp A' = \<alpha>" for A A'
+        proof -
+          have \<ddagger>: "\<alpha> \<le> tp (K 1 t \<inter> A)" if "t \<in> A'" "1 \<le> tp {\<nu>. \<nu> = 0 \<and> \<alpha> \<le> tp (K 1 t \<inter> A)}" for t
+            using that
+            by (metis Collect_empty_eq less_eq_V_0_iff ordertype_empty zero_neq_one)
+          have "tp {x \<in> A'. 1 \<le> tp {\<nu>. \<nu> = 0 \<and> \<alpha> \<le> tp (K 1 x \<inter> A)}}
+                  \<le> tp {x \<in> A'. \<alpha> \<le> tp (K 1 x \<inter> A)}"
+            by (rule ordertype_mono) (use "\<ddagger>" A' in \<open>auto simp: down\<close>)
+          then show ?thesis
+            using IX [of "{0}" A' "\<lambda>x. A"] that \<open>0 \<in> elts \<beta>\<close>
+            by (simp add: M_def cong: conj_cong)
+        qed
+
+        have 10: "\<exists>x0 \<in> A. \<exists>g \<in> elts \<beta> \<rightarrow> elts \<beta>. strict_mono_on g (elts \<beta>) \<and> (\<forall>\<nu> \<in> F. g \<nu> = \<nu>)
+                                      \<and> (\<forall>\<nu> \<in> elts \<beta>. tp (K 1 x0 \<inter> \<AA> (g \<nu>)) \<ge> \<alpha>)"
+          if F: "finite F" "F \<subseteq> elts \<beta>"
+            and A: "A \<subseteq> elts (\<alpha>*\<beta>)" "tp A = \<alpha>"
+            and \<AA>: "\<AA> \<in> elts \<beta> \<rightarrow> {X. X \<subseteq> elts (\<alpha> * \<beta>) \<and> tp X = \<alpha>}"
+          for F A \<AA>
+        proof -
+          define p where "p \<equiv> card F"
+          have "\<beta> \<notin> F"
+            using that by auto
+          then obtain \<iota> :: "nat \<Rightarrow> V" where bij\<iota>: "bij_betw \<iota> {..p} (insert \<beta> F)" and mon\<iota>: "strict_mono_on \<iota> {..p}"
+            using ZFC_Cardinals.ex_bij_betw_strict_mono_card [of "insert \<beta> F"] elts_subset_ON \<open>Ord \<beta>\<close> F
+            by (simp add: p_def lessThan_Suc_atMost) blast
+          have less_\<iota>_I: "\<iota> k < \<iota> l" if "k < l" "l \<le> p" for k l
+            using mon\<iota> that by (auto simp: strict_mono_on_def)
+          then have less_\<iota>_D: "k < l" if "\<iota> k < \<iota> l" "k \<le> p" for k l
+            by (metis less_asym linorder_neqE_nat that)
+          have Ord_\<iota>: "Ord (\<iota> k)" if "k \<le> p" for k
+            by (metis (no_types, lifting) ON_imp_Ord atMost_iff insert_subset mem_Collect_eq order_trans  \<open>F \<subseteq> elts \<beta>\<close> bij\<iota> bij_betwE elts_subset_ON \<open>Ord \<beta>\<close> that)
+          have le_\<iota>0 [simp]: "\<And>j. j \<le> p \<Longrightarrow> \<iota> 0 \<le> \<iota> j"
+            by (metis eq_refl leI le_0_eq less_\<iota>_I less_imp_le)
+          have le_\<iota>: "\<iota> i \<le> \<iota> (j - Suc 0)" if "i < j" "j \<le> p" for i j
+          proof (cases i)
+            case 0 then show ?thesis
+              using le_\<iota>0 that by auto
+          next
+            case (Suc i') then show ?thesis
+              by (metis (no_types, hide_lams) Suc_pred le_less less_Suc_eq less_Suc_eq_0_disj less_\<iota>_I not_less_eq that)
+          qed
+
+          have [simp]: "\<iota> p = \<beta>"
+          proof -
+            obtain k where k: "\<iota> k = \<beta>" "k \<le> p"
+              by (meson atMost_iff bij\<iota> bij_betw_iff_bijections insertI1)
+            then have "k = p \<or> k < p"
+              by linarith
+            then show ?thesis
+              using bij\<iota> ord k that(2)
+              by (metis OrdmemD atMost_iff bij_betw_iff_bijections insert_iff leD less_\<iota>_D order_refl subsetD)
+          qed
+
+          have F_imp_Ex: "\<exists>k < p. \<xi> = \<iota> k" if "\<xi> \<in> F" for \<xi>
+          proof -
+            obtain k where k: "k \<le> p" "\<xi> = \<iota> k"
+              by (metis \<open>\<xi> \<in> F\<close> atMost_iff bij\<iota> bij_betw_def imageE insert_iff)
+            then have "k \<noteq> p"
+              using that F by auto
+            with k show ?thesis
+              using le_neq_implies_less by blast
+          qed
+          have F_imp_ge: "\<xi> \<ge> \<iota> 0" if "\<xi> \<in> F" for \<xi>
+            using F_imp_Ex [OF that] by (metis dual_order.order_iff_strict le0 less_\<iota>_I)
+          define D where "D \<equiv> \<lambda>k. (if k=0 then {..<\<iota> 0} else {\<iota> (k-1)<..<\<iota> k}) \<inter> elts \<beta>"
+          have D\<beta>: "D k \<subseteq> elts \<beta>" for k
+            by (auto simp: D_def)
+          then have small_D [simp]: "small (D k)" for k
+            by (meson down)
+          have M_Int_D: "M (elts \<beta>) \<AA> x \<inter> D k = M (D k) \<AA> x" if "k \<le> p" for x k
+            using D\<beta> by (auto simp: M_def)
+          have \<iota>_le_if_D: "\<iota> k \<le> \<mu>" if "\<mu> \<in> D (Suc k)" for \<mu> k
+            using that
+            by (simp add: D_def order.order_iff_strict split: if_split_asm)
+          have "disjnt (D i) (D j)" if "i < j" "j \<le> p" for i j
+          proof (cases j)
+            case (Suc j')
+            then show ?thesis
+              using that
+              apply (auto simp: disjnt_def D_def)
+              using not_less_eq by (blast intro: less_\<iota>_D less_trans Suc_leD)+
+          qed (use that in auto)
+          then have disjnt_DD: "disjnt (D i) (D j)" if "i \<noteq> j" "i \<le> p" "j \<le> p" for i j
+            using disjnt_sym nat_neq_iff that by auto
+          have UN_D_eq: "(\<Union>l \<le> k. D l) = {..<\<iota> k} \<inter> (elts \<beta> - F)" if "k \<le> p" for k
+            using that
+          proof (induction k)
+            case 0
+            then show ?case
+              by (auto simp: D_def F_imp_ge leD)
+          next
+            case (Suc k)
+            have "D (Suc k) \<union> {..<\<iota> k} \<inter> (elts \<beta> - F) = {..<\<iota> (Suc k)} \<inter> (elts \<beta> - F)"
+              (is "?lhs = ?rhs")
+            proof
+              show "?lhs \<subseteq> ?rhs"
+                using Suc.prems
+                by (auto simp: D_def if_split_mem2 intro: less_\<iota>_I less_trans dest!: less_\<iota>_D F_imp_Ex)
+              have "\<And>x. \<lbrakk>x < \<iota> (Suc k); x \<in> elts \<beta>; x \<notin> F; \<iota> k \<le> x\<rbrakk> \<Longrightarrow> \<iota> k < x"
+                using Suc.prems \<open>F \<subseteq> elts \<beta>\<close> bij\<iota> le_imp_less_or_eq
+                by (fastforce simp: bij_betw_iff_bijections)
+              then show "?rhs \<subseteq> ?lhs"
+                using Suc.prems by (auto simp: D_def Ord_not_less Ord_in_Ord [OF \<open>Ord \<beta>\<close>] Ord_\<iota> if_split_mem2)
+            qed
+            then
+            show ?case
+              using Suc by (simp add: atMost_Suc)
+          qed
+          have \<beta>_decomp: "elts \<beta> = F \<union> (\<Union>k \<le> p. D k)"
+            using \<open>F \<subseteq> elts \<beta>\<close> OrdmemD [OF \<open>Ord \<beta>\<close>] by (auto simp: UN_D_eq)
+          define \<beta>idx where "\<beta>idx \<equiv> \<lambda>\<nu>. @k. \<nu> \<in> D k \<and> k \<le> p"
+          have \<beta>idx: "\<nu> \<in> D (\<beta>idx \<nu>) \<and> \<beta>idx \<nu> \<le> p" if "\<nu> \<in> elts \<beta> - F" for \<nu>
+            using that by (force simp: \<beta>idx_def \<beta>_decomp intro: someI_ex del: conjI)
+          have any_imp_\<beta>idx: "k = \<beta>idx \<nu>" if "\<nu> \<in> D k" "k \<le> p" for k \<nu>
+          proof (rule ccontr)
+            assume non: "k \<noteq> \<beta>idx \<nu>"
+            have "\<nu> \<notin> F"
+              using that UN_D_eq by auto
+            then show False
+              using disjnt_DD [OF non] by (metis D\<beta> Diff_iff \<beta>idx disjnt_iff subsetD that)
+          qed
+          have "\<exists>A'. A' \<subseteq> A \<and> tp A' = \<alpha> \<and> (\<forall>x \<in> A'. F \<subseteq> M (elts \<beta>) \<AA> x)"
+            using F
+          proof induction
+            case (insert \<nu> F)
+            then obtain A' where "A' \<subseteq> A" and A': "A' \<subseteq> elts (\<alpha>*\<beta>)" "tp A' = \<alpha>" and FN: "\<And>x. x \<in> A' \<Longrightarrow> F \<subseteq> M (elts \<beta>) \<AA> x"
+              using A(1) by auto
+            define A'' where "A'' \<equiv> {x \<in> A'. \<alpha> \<le> tp (K 1 x \<inter> \<AA> \<nu>)}"
+            have "\<nu> \<in> elts \<beta>" "F \<subseteq> elts \<beta>"
+              using insert by auto
+            note ordertype_eq_Ord [OF \<open>Ord \<beta>\<close>, simp]
+            show ?case
+            proof (intro exI conjI)
+              show "A'' \<subseteq> A"
+                using \<open>A' \<subseteq> A\<close> by (auto simp: A''_def)
+              have "tp A'' \<le> \<alpha>"
+                using \<open>A'' \<subseteq> A\<close> down ordertype_VWF_mono A by blast
+              moreover have "\<AA> \<nu> \<subseteq> elts (\<alpha>*\<beta>)" "tp (\<AA> \<nu>) = \<alpha>"
+                using \<AA> \<open>\<nu> \<in> elts \<beta>\<close> by auto
+              then have "\<alpha> \<le> tp A''"
+                using IX' [OF _ _ A'] by (simp add: A''_def)
+              ultimately show "tp A'' = \<alpha>"
+                by (rule antisym)
+              have "\<nu> \<in> M (elts \<beta>) \<AA> x" "F \<subseteq> M (elts \<beta>) \<AA> x"
+                if "x \<in> A''" for x
+              proof -
+                show "F \<subseteq> M (elts \<beta>) \<AA> x"
+                  using A''_def FN that by blast
+                show "\<nu> \<in> M (elts \<beta>) \<AA> x"
+                  using \<open>\<nu> \<in> elts \<beta>\<close> that by (simp add: M_def A''_def)
+              qed
+              then show "\<forall>x\<in>A''. insert \<nu> F \<subseteq> M (elts \<beta>) \<AA> x"
+                by blast
+            qed
+          qed (use A in auto)
+          then obtain A' where A': "A' \<subseteq> A" "tp A' = \<alpha>" and FN: "\<And>x. x \<in> A' \<Longrightarrow> F \<subseteq> M (elts \<beta>) \<AA> x"
+            by metis
+          have False
+            if *: "\<And>x0 g. \<lbrakk>x0 \<in> A; g \<in> elts \<beta> \<rightarrow> elts \<beta>; strict_mono_on g (elts \<beta>)\<rbrakk>
+                   \<Longrightarrow> (\<exists>\<nu>\<in>F. g \<nu> \<noteq> \<nu>) \<or> (\<exists>\<nu>\<in>elts \<beta>. tp (K 1 x0 \<inter> \<AA> (g \<nu>)) < \<alpha>)"
+          proof -
+            { fix x       \<comment> \<open>construction of the monotone map @{term g} mentioned above\<close>
+              assume "x \<in> A'"
+              with A' have "x \<in> A" by blast
+              have "\<exists>k. k \<le> p \<and> tp (M (D k) \<AA> x) < tp (D k)" (is "?P")
+              proof (rule ccontr)
+                assume "\<not> ?P"
+                then have le: "tp (D k) \<le> tp (M (D k) \<AA> x)" if "k \<le> p" for k
+                  by (meson Ord_linear2 Ord_ordertype that)
+                have "\<exists>f\<in>D k \<rightarrow> M (D k) \<AA> x. inj_on f (D k) \<and> (strict_mono_on f (D k))"
+                     if "k \<le> p" for k
+                  using le [OF that] that VWF_iff_Ord_less
+                  apply (clarsimp simp: ordertype_le_ordertype strict_mono_on_def)
+                  by (metis (full_types) D\<beta> M_sub_D Ord_in_Ord PiE VWF_iff_Ord_less ord(2) subsetD)
+                then obtain h where fun_h: "\<And>k. k \<le> p \<Longrightarrow> h k \<in> D k \<rightarrow> M (D k) \<AA> x"
+                  and inj_h: "\<And>k. k \<le> p \<Longrightarrow> inj_on (h k) (D k)"
+                  and mono_h: "\<And>k x y. k \<le> p \<Longrightarrow> strict_mono_on (h k) (D k)"
+                  by metis
+                then have fun_hD: "\<And>k. k \<le> p \<Longrightarrow> h k \<in> D k \<rightarrow> D k"
+                  by (auto simp: M_def)
+                have h_increasing: "\<nu> \<le> h k \<nu>"
+                  if "k \<le> p" and \<nu>: "\<nu> \<in> D k" for k \<nu>
+                proof (rule Ord_mono_imp_increasing)
+                  show "h k \<in> D k \<rightarrow> D k"
+                    by (simp add: fun_hD that(1))
+                  show "D k \<subseteq> ON"
+                    using D\<beta> elts_subset_ON ord(2) by blast
+                qed (auto simp: that mono_h)
+                define g where "g \<equiv> \<lambda>\<nu>. if \<nu> \<in> F then \<nu> else h (\<beta>idx \<nu>) \<nu>"
+                have [simp]: "g \<nu> = \<nu>" if "\<nu> \<in> F" for \<nu>
+                  using that by (auto simp: g_def)
+                have fun_g: "g \<in> elts \<beta> \<rightarrow> elts \<beta>"
+                proof (rule Pi_I)
+                  fix x assume "x \<in> elts \<beta>"
+                  then have "x \<in> D (\<beta>idx x)" "\<beta>idx x \<le> p" if "x \<notin> F"
+                    using that by (auto simp: \<beta>idx)
+                  then show "g x \<in> elts \<beta>"
+                    using fun_h  D\<beta> M_sub_D \<open>x \<in> elts \<beta>\<close>
+                    by (simp add: g_def) blast
+                qed
+                have h_in_D: "h (\<beta>idx \<nu>) \<nu> \<in> D (\<beta>idx \<nu>)" if "\<nu> \<notin> F" "\<nu> \<in> elts \<beta>" for \<nu>
+                  using \<beta>idx fun_hD that by fastforce
+                have 1: "\<iota> k < h (\<beta>idx \<nu>) \<nu>"
+                  if "k < p" and \<nu>: "\<nu> \<notin> F" "\<nu> \<in> elts \<beta>" and "\<iota> k < \<nu>" for k \<nu>
+                  using that h_in_D [OF \<nu>] \<beta>idx
+                  by (fastforce simp: D_def dest: h_increasing split: if_split_asm)
+                moreover have 2: "h (\<beta>idx \<mu>) \<mu> < \<iota> k"
+                  if \<mu>: "\<mu> \<notin> F" "\<mu> \<in> elts \<beta>" and "k < p" "\<mu> < \<iota> k" for \<mu> k
+                proof -
+                  have "\<beta>idx \<mu> \<le> k"
+                  proof (rule ccontr)
+                    assume "\<not> \<beta>idx \<mu> \<le> k"
+                    then have "k < \<beta>idx \<mu>"
+                      by linarith
+                    then show False
+                      using \<iota>_le_if_D \<beta>idx
+                      by (metis Diff_iff Suc_pred le0 leD le_\<iota> le_less_trans \<mu> \<open>\<mu> < \<iota> k\<close>)
+                  qed
+                  then show ?thesis
+                    using that h_in_D [OF \<mu>]
+                    apply (simp add: D_def split: if_split_asm)
+                     apply (metis (no_types) dual_order.order_iff_strict le0 less_\<iota>_I less_trans)
+                    by (metis (no_types) dual_order.order_iff_strict less_\<iota>_I less_trans)
+                qed
+                moreover have "h (\<beta>idx \<mu>) \<mu> < h (\<beta>idx \<nu>) \<nu>"
+                  if \<mu>: "\<mu> \<notin> F" "\<mu> \<in> elts \<beta>" and \<nu>: "\<nu> \<notin> F" "\<nu> \<in> elts \<beta>" and "\<mu> < \<nu>" for \<mu> \<nu>
+                proof -
+                  have le: "\<beta>idx \<mu> \<le> \<beta>idx \<nu>" if "\<iota> (\<beta>idx \<mu> - Suc 0) < h (\<beta>idx \<mu>) \<mu>" "h (\<beta>idx \<nu>) \<nu> < \<iota> (\<beta>idx \<nu>)"
+                    by (metis 2 that Diff_iff \<beta>idx \<mu> \<nu> \<open>\<mu> < \<nu>\<close> dual_order.strict_implies_order dual_order.strict_trans1 h_increasing leI le_\<iota> less_asym)
+                  have "h 0 \<mu> < h 0 \<nu>" if "\<beta>idx \<mu> = 0" "\<beta>idx \<nu> = 0"
+                    using that mono_h unfolding strict_mono_on_def
+                    by (metis Diff_iff \<beta>idx \<mu> \<nu> \<open>\<mu> < \<nu>\<close>)
+                  moreover have "h 0 \<mu> < h (\<beta>idx \<nu>) \<nu>"
+                    if "0 < \<beta>idx \<nu>" "h 0 \<mu> < \<iota> 0" and "\<iota> (\<beta>idx \<nu> - Suc 0) < h (\<beta>idx \<nu>) \<nu>"
+                    by (meson DiffI \<beta>idx \<nu> le_\<iota> le_less_trans less_le_not_le that)
+                  moreover have "\<beta>idx \<nu> \<noteq> 0"
+                    if "0 < \<beta>idx \<mu>" "h 0 \<nu> < \<iota> 0" "\<iota> (\<beta>idx \<mu> - Suc 0) < h (\<beta>idx \<mu>) \<mu>"
+                    using le le_0_eq that by fastforce
+                  moreover have "h (\<beta>idx \<mu>) \<mu> < h (\<beta>idx \<nu>) \<nu>"
+                    if "\<iota> (\<beta>idx \<mu> - Suc 0) < h (\<beta>idx \<mu>) \<mu>" "h (\<beta>idx \<nu>) \<nu> < \<iota> (\<beta>idx \<nu>)"
+                       "h (\<beta>idx \<mu>) \<mu> < \<iota> (\<beta>idx \<mu>)" "\<iota> (\<beta>idx \<nu> - Suc 0) < h (\<beta>idx \<nu>) \<nu>"
+                    using mono_h unfolding strict_mono_on_def
+                      by (metis le Diff_iff \<beta>idx \<mu> \<nu> \<open>\<mu> < \<nu>\<close> le_\<iota> le_less le_less_trans that)
+                  ultimately show  ?thesis
+                    using h_in_D [OF \<mu>] h_in_D [OF \<nu>] by (simp add: D_def split: if_split_asm)
+                qed
+                ultimately have sm_g: "strict_mono_on g (elts \<beta>)"
+                  by (auto simp: g_def strict_mono_on_def dest!: F_imp_Ex)
+                show False
+                  using * [OF \<open>x \<in> A\<close> fun_g sm_g]
+                proof safe
+                  fix \<nu>
+                  assume "\<nu> \<in> elts \<beta>" and \<nu>: "tp (K 1 x \<inter> \<AA> (g \<nu>)) < \<alpha>"
+                  have FM: "F \<subseteq> M (elts \<beta>) \<AA> x"
+                    by (meson FN \<open>x \<in> A'\<close>)
+                  have False if "tp (K (Suc 0) x \<inter> \<AA> \<nu>) < \<alpha>" "\<nu> \<in> F"
+                    using that FM by (auto simp: M_def)
+                  moreover have False if "tp (K (Suc 0) x \<inter> \<AA> (g \<nu>)) < \<alpha>" "\<nu> \<in> D k" "k \<le> p" "\<nu> \<notin> F" for k
+                  proof -
+                    have "h (\<beta>idx \<nu>) \<nu> \<in> M (D (\<beta>idx \<nu>)) \<AA> x"
+                      using fun_h \<beta>idx \<open>\<nu> \<in> elts \<beta>\<close> \<open>\<nu> \<notin> F\<close> by auto
+                    then show False
+                      using that by (simp add: M_def g_def leD)
+                  qed
+                  ultimately show False
+                    using \<open>\<nu> \<in> elts \<beta>\<close> \<nu> by (force simp: \<beta>_decomp)
+                qed auto
+              qed
+              then have "\<exists>l. l \<le> p \<and> tp (M (elts \<beta>) \<AA> x \<inter> D l) < tp (D l)"
+                using M_Int_D by auto
+            }
+            then obtain l where lp: "\<And>x. x \<in> A'\<Longrightarrow> l x \<le> p"
+              and lless: "\<And>x. x \<in> A'\<Longrightarrow> tp (M (elts \<beta>) \<AA> x \<inter> D (l x)) < tp (D (l x))"
+              by metis
+            obtain A'' L where "A'' \<subseteq> A'" and A'': "A'' \<subseteq> elts (\<alpha> * \<beta>)" "tp A'' = \<alpha>" and lL: "\<And>x. x \<in> A'' \<Longrightarrow> l x = L"
+            proof -
+              have eq: "A' = (\<Union>i\<le>p. {x \<in> A'. l x = i})"
+                using lp by auto
+              have "\<exists>X\<in>(\<lambda>i. {x \<in> A'. l x = i}) ` {..p}. \<alpha> \<le> tp X"
+              proof (rule indecomposable_ordertype_finite_ge [OF indec])
+                show "small (\<Union>i\<le>p. {x \<in> A'. l x = i})"
+                  by (metis A'(1) A(1) eq down smaller_than_small)
+              qed (use A' eq in auto)
+              then show thesis
+              proof
+                fix A''
+                assume A'': "A'' \<in> (\<lambda>i. {x \<in> A'. l x = i}) ` {..p}" and "\<alpha> \<le> tp A''"
+                then obtain L where L: "\<And>x. x \<in> A'' \<Longrightarrow> l x = L"
+                  by auto
+                have "A'' \<subseteq> A'"
+                  using A'' by force
+                then have "tp A'' \<le> tp A'"
+                  by (meson A' A down order_trans ordertype_VWF_mono)
+                with \<open>\<alpha> \<le> tp A''\<close> have "tp A'' = \<alpha>"
+                  using A'(2) by auto
+                moreover have "A'' \<subseteq> elts (\<alpha> * \<beta>)"
+                  using A' A \<open>A'' \<subseteq> A'\<close> by auto
+                ultimately show thesis
+                  using L that [OF \<open>A'' \<subseteq> A'\<close>] by blast
+              qed
+            qed
+            have \<AA>D: "\<AA> \<in> D L \<rightarrow> {X. X \<subseteq> elts (\<alpha> * \<beta>) \<and> tp X = \<alpha>}"
+              using \<AA> D\<beta> by blast
+            have "M (elts \<beta>) \<AA> x \<inter> D L = M (D L) \<AA> x" for x
+              using D\<beta> by (auto simp: M_def)
+            then have "tp (M (D L) \<AA> x) < tp (D L)" if "x \<in> A''" for x
+              using lless that \<open>A'' \<subseteq> A'\<close> lL by force
+            then have \<dagger>: "{x \<in> A''. tp (D L) \<le> tp (M (D L) \<AA> x)} = {}"
+              using leD by blast
+            have "\<alpha> \<le> tp {x \<in> A''. tp (D L) \<le> tp (M (D L) \<AA> x)}"
+              using IX [OF D\<beta> A'' \<AA>D] by simp
+            then show False
+              using \<open>\<alpha> \<noteq> 0\<close> by (simp add: \<dagger>)
+          qed
+          then show ?thesis
+            by (meson Ord_linear2 Ord_ordertype \<open>Ord \<alpha>\<close>)
+        qed
+        let ?U = "UNIV :: nat set"
+        define \<mu> where "\<mu> \<equiv> fst \<circ> from_nat_into (elts \<beta> \<times> ?U)"
+        define q where "q \<equiv> to_nat_on (elts \<beta> \<times> ?U)"
+        have co_\<beta>U: "countable (elts \<beta> \<times> ?U)"
+          by (simp add: \<beta> less_\<omega>1_imp_countable)
+        moreover have "elts \<beta> \<times> ?U \<noteq> {}"
+          using \<open>0 \<in> elts \<beta>\<close> by blast
+        ultimately have "range (from_nat_into (elts \<beta> \<times> ?U)) = (elts \<beta> \<times> ?U)"
+          by (metis range_from_nat_into)
+        then have \<mu>_in_\<beta> [simp]: "\<mu> i \<in> elts \<beta>" for i
+          by (metis SigmaE \<mu>_def comp_apply fst_conv range_eqI)
+
+        then have Ord_\<mu> [simp]: "Ord (\<mu> i)" for i
+          using Ord_in_Ord by blast
+
+        have inf_\<beta>U: "infinite (elts \<beta> \<times> ?U)"
+          using \<open>0 \<in> elts \<beta>\<close> finite_cartesian_productD2 by auto
+
+        have 11 [simp]: "\<mu> (q (\<nu>,n)) = \<nu>" if "\<nu> \<in> elts \<beta>" for \<nu> n
+          by (simp add: \<mu>_def q_def that co_\<beta>U)
+        have range_\<mu> [simp]: "range \<mu> = elts \<beta>"
+          by (auto simp: image_iff) (metis 11)
+        have [simp]: "KI i {} = UNIV" "KI i (insert a X) = K i a \<inter> KI i X" for i a X
+          by (auto simp: KI_def)
+        define \<Phi> where "\<Phi> \<equiv> \<lambda>n::nat. \<lambda>\<AA> x. (\<forall>\<nu> \<in> elts \<beta>. \<AA> \<nu> \<subseteq> elts (\<alpha>*\<beta>) \<and> tp (\<AA> \<nu>) = \<alpha>) \<and> x ` {..<n} \<subseteq> elts (\<alpha>*\<beta>)
+                                         \<and> (\<Union>\<nu> \<in> elts \<beta>. \<AA> \<nu>) \<subseteq> KI 1 (x ` {..<n}) \<and> strict_mono_sets (elts \<beta>) \<AA>"
+        define \<Psi> where "\<Psi> \<equiv> \<lambda>n::nat. \<lambda>g \<AA> \<AA>' xn. g \<in> elts \<beta> \<rightarrow> elts \<beta> \<and> strict_mono_on g (elts \<beta>) \<and> (\<forall>i\<le>n. g (\<mu> i) = \<mu> i)
+                  \<and> (\<forall>\<nu> \<in> elts \<beta>. \<AA>' \<nu> \<subseteq> K 1 xn \<inter> \<AA> (g \<nu>))
+                  \<and> less_sets {xn} (\<AA>' (\<mu> n)) \<and> xn \<in> \<AA> (\<mu> n)"
+        let ?\<AA>0 = "\<lambda>\<nu>. plus (\<alpha> * \<nu>) ` elts \<alpha>"
+        have base: "\<Phi> 0 ?\<AA>0 x" for x
+          by (auto simp: \<Phi>_def add_mult_less add_mult_less_add_mult ordertype_image_plus strict_mono_sets_def less_sets_def)
+        have step: "Ex (\<lambda>(g,\<AA>',xn). \<Psi> n g \<AA> \<AA>' xn \<and> \<Phi> (Suc n) \<AA>' (x(n:=xn)))" if "\<Phi> n \<AA> x" for n \<AA> x
+        proof -
+          have \<AA>: "\<And>\<nu>. \<nu> \<in> elts \<beta> \<Longrightarrow> \<AA> \<nu> \<subseteq> elts (\<alpha> * \<beta>) \<and> tp (\<AA> \<nu>) = \<alpha>"
+            and x: "x ` {..<n} \<subseteq> elts (\<alpha> * \<beta>)"
+            and sub: "\<Union> (\<AA> ` elts \<beta>) \<subseteq> KI (Suc 0) (x ` {..<n})"
+            and sm: "strict_mono_sets (elts \<beta>) \<AA>"
+            using that by (auto simp: \<Phi>_def)
+          have \<mu>\<beta>: "\<mu> ` {..n} \<subseteq> elts \<beta>" and \<AA>sub: "\<AA> (\<mu> n) \<subseteq> elts (\<alpha> * \<beta>)"
+            by (auto simp: \<AA>)
+          have \<AA>fun: "\<AA> \<in> elts \<beta> \<rightarrow> {X. X \<subseteq> elts (\<alpha> * \<beta>) \<and> tp X = \<alpha>}"
+            by (simp add: \<AA>)
+          then obtain xn g where xn: "xn \<in> \<AA> (\<mu> n)" and g: "g \<in> elts \<beta> \<rightarrow> elts \<beta>"
+            and sm_g: "strict_mono_on g (elts \<beta>)" and g_\<mu>: "\<forall>\<nu> \<in> \<mu>`{..n}. g \<nu> = \<nu>"
+            and g_\<alpha>: "\<forall>\<nu> \<in> elts \<beta>. \<alpha> \<le> tp (K 1 xn \<inter> \<AA> (g \<nu>))"
+            using 10 [OF _ \<mu>\<beta> \<AA>sub _ \<AA>fun] by (auto simp: \<AA>)
+          have tp1: "tp (K 1 xn \<inter> \<AA> (g \<nu>)) = \<alpha>" if "\<nu> \<in> elts \<beta>" for \<nu>
+          proof (rule antisym)
+            have "tp (K 1 xn \<inter> \<AA> (g \<nu>)) \<le> tp (\<AA> (g \<nu>))"
+            proof (rule ordertype_VWF_mono)
+              show "small (\<AA> (g \<nu>))"
+                by (metis PiE \<AA> down g that)
+            qed auto
+            also have "\<dots> = \<alpha>"
+              using \<AA> g that by force
+            finally show "tp (K 1 xn \<inter> \<AA> (g \<nu>)) \<le> \<alpha>" .
+          qed (use that g_\<alpha> in auto)
+          have tp2: "tp (\<AA> (\<mu> n)) = \<alpha>"
+            by (auto simp: \<AA>)
+          obtain A2 where A2: "tp A2 = \<alpha>" "A2 \<subseteq> K 1 xn \<inter> \<AA> (\<mu> n)" "less_sets {xn} A2"
+            using indecomposable_imp_Ex_less_sets [OF indec \<open>\<alpha> > 1\<close> \<open>Ord \<beta>\<close> tp2]
+            by (metis \<AA>sub \<mu>_in_\<beta> atMost_iff image_eqI inf_le2 le_refl xn tp1 g_\<mu>)
+          then have A2_sub: "A2 \<subseteq> \<AA> (\<mu> n)" by simp
+          let ?\<AA> = "\<lambda>\<nu>. if \<nu> = \<mu> n then A2 else K 1 xn \<inter> \<AA> (g \<nu>)"
+          have [simp]: "({..<Suc n} \<inter> {x. x \<noteq> n}) = ({..<n})"
+            by auto
+          have "K (Suc 0) xn \<inter> (\<Union>x\<in>elts \<beta> \<inter> {\<nu>. \<nu> \<noteq> \<mu> n}. \<AA> (g x)) \<subseteq> KI (Suc 0) (x ` {..<n})"
+            using sub g by (auto simp: KI_def)
+          moreover have "A2 \<subseteq> KI (Suc 0) (x ` {..<n})" "A2 \<subseteq> elts (\<alpha> * \<beta>)"
+            using \<AA>sub sub A2 by fastforce+
+          moreover have "xn \<in> elts (\<alpha> * \<beta>)"
+            using \<AA>sub xn by blast
+         moreover have "strict_mono_sets (elts \<beta>) ?\<AA>"
+            using sm sm_g g g_\<mu> A2_sub
+            unfolding strict_mono_sets_def strict_mono_on_def less_sets_def Pi_iff subset_iff Ball_def Bex_def image_iff
+            by (simp (no_asm_use) add: if_split_mem2) (smt order_refl)
+          ultimately have "\<Phi> (Suc n) ?\<AA> (x(n := xn))"
+            using tp1 x A2 by (auto simp: \<Phi>_def K_def)
+          with A2 show ?thesis
+            by (rule_tac x="(g,?\<AA>,xn)" in exI) (simp add: \<Psi>_def g sm_g g_\<mu> xn)
+        qed
+        define G where "G \<equiv> \<lambda>n \<AA> x. @(g,\<AA>',x'). \<exists>xn. \<Psi> n g \<AA> \<AA>' xn \<and> x' = (x(n:=xn)) \<and> \<Phi> (Suc n) \<AA>' x'"
+        have G\<Phi>: "(\<lambda>(g,\<AA>',x'). \<Phi> (Suc n) \<AA>' x') (G n \<AA> x)"
+          and G\<Psi>: "(\<lambda>(g,\<AA>',x'). \<Psi> n g \<AA> \<AA>' (x' n)) (G n \<AA> x)"  if "\<Phi> n \<AA> x" for n \<AA> x
+          using step [OF that] by (force simp: G_def dest: some_eq_imp)+
+        define H where "H \<equiv> rec_nat (id,?\<AA>0,undefined) (\<lambda>n (g0,\<AA>,x0). G n \<AA> x0)"
+        have H_Suc: "H (Suc n) = (case H n of (g0, xa, xb) \<Rightarrow> G n xa xb)" for n
+          by (simp add: H_def)
+        have "(\<lambda>(g,\<AA>,x). \<Phi> n \<AA> x) (H n)" for n
+        proof (induction n)
+          case 0 show ?case
+            by (simp add: H_def base)
+        next
+          case (Suc n) then show ?case
+            using G\<Phi> by (fastforce simp: H_Suc)
+        qed
+        then have H_imp_\<Phi>: "\<Phi> n \<AA> x" if "H n = (g,\<AA>,x)" for g \<AA> x n
+          by (metis case_prodD that)
+        then have H_imp_\<Psi>: "(\<lambda>(g,\<AA>',x'). let (g0,\<AA>,x) = H n in \<Psi> n g \<AA> \<AA>' (x' n)) (H (Suc n))" for n
+          using G\<Psi> by (fastforce simp: H_Suc split: prod.split)
+        define g where "g \<equiv> \<lambda>n. (\<lambda>(g,\<AA>,x). g) (H (Suc n))"
+        have g: "g n \<in> elts \<beta> \<rightarrow> elts \<beta>" and sm_g: "strict_mono_on (g n) (elts \<beta>)"
+                 and 13: "\<And>i. i\<le>n \<Longrightarrow> g n (\<mu> i) = \<mu> i" for n
+            using H_imp_\<Psi> [of n] by (auto simp: g_def \<Psi>_def)
+        define \<AA> where "\<AA> \<equiv> \<lambda>n. (\<lambda>(g,\<AA>,x). \<AA>) (H n)"
+        define x where "x \<equiv> \<lambda>n. (\<lambda>(g,\<AA>,x). x n) (H (Suc n))"
+        have 14: "\<AA> (Suc n) \<nu> \<subseteq> K 1 (x n) \<inter> \<AA> n (g n \<nu>)" if "\<nu> \<in> elts \<beta>" for \<nu> n
+          using H_imp_\<Psi> [of n] that by (force simp: \<Psi>_def \<AA>_def x_def g_def)
+        then have x14: "\<AA> (Suc n) \<nu> \<subseteq> \<AA> n (g n \<nu>)" if "\<nu> \<in> elts \<beta>" for \<nu> n
+          using that by blast
+        have 15: "x n \<in> \<AA> n (\<mu> n)" and 16: "less_sets {x n} (\<AA> (Suc n) (\<mu> n))" for n
+          using H_imp_\<Psi> [of n] by (force simp: \<Psi>_def \<AA>_def x_def)+
+        have \<AA>_\<alpha>\<beta>: "\<AA> n \<nu> \<subseteq> elts (\<alpha> * \<beta>)" if "\<nu> \<in> elts \<beta>" for \<nu> n
+          using H_imp_\<Phi> [of n] that by (auto simp: \<Phi>_def \<AA>_def split: prod.split)
+        have 12: "strict_mono_sets (elts \<beta>) (\<AA> n)" for n
+          using H_imp_\<Phi> [of n] that by (auto simp: \<Phi>_def \<AA>_def split: prod.split)
+        have tp_\<AA>: "tp (\<AA> n \<nu>) = \<alpha>" if "\<nu> \<in> elts \<beta>" for \<nu> n
+          using H_imp_\<Phi> [of n] that by (auto simp: \<Phi>_def \<AA>_def split: prod.split)
+        let ?Z = "range x"
+        have S_dec: "\<Union> (\<AA> (m+k) ` elts \<beta>) \<subseteq> \<Union> (\<AA> m ` elts \<beta>)" for k m
+          by (induction k) (use 14 g in \<open>fastforce+\<close>)
+        have "x n \<in> K 1 (x m)" if "m<n" for m n
+        proof -
+          have "x n \<in> (\<Union>\<nu> \<in> elts \<beta>. \<AA> n \<nu>)"
+            by (meson "15" UN_I \<mu>_in_\<beta>)
+          also have "\<dots> \<subseteq> (\<Union>\<nu> \<in> elts \<beta>. \<AA> (Suc m) \<nu>)"
+            using S_dec [of "Suc m"] less_iff_Suc_add that by auto
+          also have "\<dots> \<subseteq> K 1 (x m)"
+            using 14 by auto
+          finally show ?thesis .
+        qed
+        then have "f{x m, x n} = 1" if "m<n" for m n
+          using that by (auto simp: K_def)
+        then have Z_K1: "f ` [?Z]\<^bsup>2\<^esup> \<subseteq> {1}"
+          by (clarsimp simp: nsets_2_eq) (metis insert_commute less_linear)
+        moreover have Z_sub: "?Z \<subseteq> elts (\<alpha> * \<beta>)"
+          using "15" \<AA>_\<alpha>\<beta> \<mu>_in_\<beta> by blast
+        moreover have "tp ?Z \<ge> \<omega> * \<beta>"
+        proof -
+          define \<gg> where "\<gg> \<equiv> \<lambda>i j x. wfrec (measure (\<lambda>k. j-k)) (\<lambda>\<gg> k. if k<j then g k (\<gg> (Suc k)) else x) i"
+          have \<gg>: "\<gg> i j x = (if i<j then g i (\<gg> (Suc i) j x) else x)" for i j x
+            by (simp add: \<gg>_def wfrec cut_apply)
+          have 17: "\<gg> k j (\<mu> i) = \<mu> i" if "i \<le> k" for i j k
+            using wf_measure [of "\<lambda>k. j-k"] that
+            by (induction k rule: wf_induct_rule) (simp add: "13" \<gg> le_imp_less_Suc)
+          have \<gg>_in_\<beta>: "\<gg> i j \<nu>  \<in> elts \<beta>" if "\<nu> \<in> elts \<beta>" for i j \<nu>
+            using wf_measure [of "\<lambda>k. j-k"] that
+          proof (induction i rule: wf_induct_rule)
+            case (less i)
+            with g show ?case by (force simp: \<gg> [of i])
+          qed
+          then have \<gg>_fun: "\<gg> i j \<in> elts \<beta> \<rightarrow> elts \<beta>" for i j
+            by simp
+          have sm_\<gg>: "strict_mono_on (\<gg> i j) (elts \<beta>)" for i j
+            using wf_measure [of "\<lambda>k. j-k"]
+          proof (induction i rule: wf_induct_rule)
+            case (less i)
+            with sm_g show ?case
+              by (auto simp: \<gg> [of i] strict_mono_on_def \<gg>_in_\<beta>)
+          qed
+          have *: "\<AA> j (\<mu> j) \<subseteq> \<AA> i (\<gg> i j (\<mu> j))" if "i < j" for i j
+            using wf_measure [of "\<lambda>k. j-k"] that
+          proof (induction i rule: wf_induct_rule)
+            case (less i)
+            then have "j - Suc i < j - i"
+              by (metis (no_types) Suc_diff_Suc lessI)
+            with less \<gg>_in_\<beta> show ?case
+              by (simp add: \<gg> [of i]) (metis 17 Suc_lessI \<mu>_in_\<beta> order_refl order_trans x14)
+          qed
+          have le: "\<gg> i j (\<mu> j) \<le> \<mu> i \<longleftrightarrow> \<mu> j \<le> \<mu> i" for i j
+            using sm_\<gg> unfolding strict_mono_on_def
+            by (metis "17" Ord_in_Ord Ord_linear2 \<mu>_in_\<beta> leD le_refl less_V_def \<open>Ord \<beta>\<close>)
+          then have less: "\<gg> i j (\<mu> j) < \<mu> i \<longleftrightarrow> \<mu> j < \<mu> i" for i j
+            by (metis (no_types, lifting) "17" \<mu>_in_\<beta> less_V_def order_refl sm_\<gg> strict_mono_on_def)
+          have eq: "\<gg> i j (\<mu> j) = \<mu> i \<longleftrightarrow> \<mu> j = \<mu> i" for i j
+            by (metis eq_refl le less less_le)
+          have 18: "less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n)) \<longleftrightarrow> \<mu> m < \<mu> n" for m n
+          proof (cases n m rule: linorder_cases)
+            case less
+            show ?thesis
+            proof (intro iffI)
+              assume "less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))"
+              moreover
+              have "\<not> less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))" if "\<mu> n = \<mu> m"
+                by (metis "*" "15" eq less less_V_def less_sets_def less_sets_weaken2 that)
+              moreover
+              have "\<not> less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))" if "\<mu> n < \<mu> m"
+                using that 12 15 * [OF less]
+                apply (clarsimp simp: less_sets_def strict_mono_sets_def)
+                by (metis Ord_in_Ord Ord_linear2 \<gg>_in_\<beta> \<mu>_in_\<beta> \<open>Ord \<beta>\<close> le leD less_asym subsetD)
+              ultimately show "\<mu> m < \<mu> n"
+                by (meson Ord_in_Ord Ord_linear_lt \<mu>_in_\<beta> \<open>Ord \<beta>\<close>)
+            next
+              assume "\<mu> m < \<mu> n"
+              then have "less_sets (\<AA> n (\<gg> n m (\<mu> m))) (\<AA> n (\<mu> n))"
+                by (metis "12" \<gg>_in_\<beta> \<mu>_in_\<beta> eq le less_V_def strict_mono_sets_def)
+              then show "less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))"
+                by (meson *[OF less] less_sets_weaken1)
+          qed
+          next
+            case equal
+            with 15 show ?thesis by auto
+          next
+            case greater
+            show ?thesis
+            proof (intro iffI)
+              assume "less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))"
+              moreover
+              have "\<not> less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))" if "\<mu> n = \<mu> m"
+                by (metis "*" "15" disjnt_iff eq greater in_mono less_sets_imp_disjnt that)
+              moreover
+              have "\<not> less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))" if "\<mu> n < \<mu> m"
+                using that 12 15 * [OF greater]
+                apply (clarsimp simp: less_sets_def strict_mono_sets_def)
+                by (meson \<gg>_in_\<beta> \<mu>_in_\<beta> in_mono less less_asym)
+              ultimately show "\<mu> m < \<mu> n"
+                by (meson Ord_\<mu> Ord_linear_lt)
+            next
+              assume "\<mu> m < \<mu> n"
+              then have "less_sets (\<AA> m (\<mu> m)) (\<AA> m (\<gg> m n (\<mu> n)))"
+                by (meson 12 Ord_in_Ord Ord_linear2 \<gg>_in_\<beta> \<mu>_in_\<beta> le leD ord(2) strict_mono_sets_def)
+              then show "less_sets (\<AA> m (\<mu> m)) (\<AA> n (\<mu> n))"
+                by (meson "*" greater less_sets_weaken2)
+            qed
+          qed
+          have \<AA>_increasing_\<mu>: "\<AA> n (\<mu> n) \<subseteq> \<AA> m (\<mu> m)" if "m \<le> n" "\<mu> m = \<mu> n" for m n
+            by (metis "*" "17" dual_order.order_iff_strict that)
+          moreover have INF: "infinite {n. n \<ge> m \<and> \<mu> m = \<mu> n}" for m
+          proof -
+            have "infinite (range (\<lambda>n. q (\<mu> m, n)))"
+              unfolding q_def
+              using to_nat_on_infinite [OF co_\<beta>U inf_\<beta>U] finite_image_iff
+              by (simp add: finite_image_iff inj_on_def)
+            moreover have "(range (\<lambda>n. q (\<mu> m, n))) \<subseteq> {n. \<mu> m = \<mu> n}"
+              using 11 [of "\<mu> m"] by auto
+            ultimately have "infinite {n. \<mu> m = \<mu> n}"
+              using finite_subset by auto
+            then have "infinite ({n. \<mu> m = \<mu> n} - {..<m})"
+              by simp
+            then show ?thesis
+              by (auto simp: finite_nat_set_iff_bounded Bex_def not_less)
+          qed
+          let ?eqv = "\<lambda>m. {n. m \<le> n \<and> \<mu> m = \<mu> n}"
+          have sm_x: "strict_mono_on x (?eqv m)" for m
+          proof (clarsimp simp: strict_mono_on_def)
+            fix n p
+            assume "m \<le> n" "\<mu> p = \<mu> n" "\<mu> m = \<mu> n" "n < p"
+            with 16 [of n] show "x n < x p"
+              by (simp add: less_sets_def) (metis "*" "15" "17" Suc_lessI le_SucI subsetD)
+          qed
+          then have inj_x: "inj_on x (?eqv m)" for m
+            using strict_mono_on_imp_inj_on by blast
+          define ZA where "ZA \<equiv> \<lambda>m. ?Z \<inter> \<AA> m (\<mu> m)"
+          have small_ZA [simp]: "small (ZA m)" for m
+            by (metis ZA_def inf_le1 small_image_nat smaller_than_small)
+          have 19: "tp (ZA m) \<ge> \<omega>" for m
+          proof -
+            have "x ` {n. m \<le> n \<and> \<mu> m = \<mu> n} \<subseteq> ZA m"
+              unfolding ZA_def using "15" \<AA>_increasing_\<mu> by blast
+            then have "infinite (ZA m)"
+              using INF [of m] finite_image_iff [OF inj_x] by (meson finite_subset)
+            then show ?thesis
+              by (simp add: ordertype_infinite_ge_\<omega>)
+          qed
+          have "\<exists>f \<in> elts \<omega> \<rightarrow> ZA m. strict_mono_on f (elts \<omega>)" for m
+          proof -
+            obtain Z where "Z \<subseteq> ZA m" "tp Z = \<omega>"
+              by (meson 19 Ord_\<omega> le_ordertype_obtains_subset small_ZA)
+            moreover have "ZA m \<subseteq> ON"
+              using Ord_in_Ord \<AA>_\<alpha>\<beta> \<mu>_in_\<beta> unfolding ZA_def by blast
+            ultimately show ?thesis
+              by (metis strict_mono_on_ordertype Pi_mono small_ZA smaller_than_small subset_iff)
+          qed
+          then obtain \<phi> where \<phi>: "\<And>m. \<phi> m \<in> elts \<omega> \<rightarrow> ZA m"
+                         and sm_\<phi>: "\<And>m. strict_mono_on (\<phi> m) (elts \<omega>)"
+            by metis
+          have "Ex(\<lambda>(m,\<nu>). \<nu> \<in> elts \<beta> \<and> \<gamma> = \<omega> * \<nu> + ord_of_nat m)" if "\<gamma> \<in> elts (\<omega> * \<beta>)" for \<gamma>
+            using that by (auto simp: mult [of \<omega> \<beta>] lift_def elts_\<omega>)
+          then obtain split where split: "\<And>\<gamma>. \<gamma> \<in> elts (\<omega> * \<beta>) \<Longrightarrow>
+             (\<lambda>(m,\<nu>). \<nu> \<in> elts \<beta> \<and> \<gamma> = \<omega> * \<nu> + ord_of_nat m)(split \<gamma>)"
+            by meson
+          have split_eq [simp]: "split (\<omega> * \<nu> + ord_of_nat m) = (m,\<nu>)" if "\<nu> \<in> elts \<beta>" for \<nu> m
+          proof -
+            have [simp]: "\<omega> * \<nu> + ord_of_nat m = \<omega> * \<xi> + ord_of_nat n \<longleftrightarrow> \<xi> = \<nu> \<and> n = m" if "\<xi> \<in> elts \<beta>" for \<xi> n
+              by (metis Ord_\<omega> that Ord_mem_iff_less_TC mult_cancellation_lemma ord_of_nat_\<omega> ord_of_nat_inject)
+            show ?thesis
+              using split [of "\<omega>*\<nu> + m"] that by (auto simp: mult [of \<omega> \<beta>] lift_def cong: conj_cong)
+          qed
+          define \<pi> where "\<pi> \<equiv> \<lambda>\<gamma>. (\<lambda>(m,\<nu>). \<phi> (q(\<nu>,0)) m)(split \<gamma>)"
+          have \<pi>_Pi: "\<pi> \<in> elts (\<omega> * \<beta>) \<rightarrow> (\<Union>m. ZA m)"
+            using \<phi> by (fastforce simp: \<pi>_def mult [of \<omega> \<beta>] lift_def elts_\<omega>)
+          moreover have "(\<Union>m. ZA m) \<subseteq> ON"
+            unfolding ZA_def using \<AA>_\<alpha>\<beta> \<mu>_in_\<beta> elts_subset_ON by blast
+          ultimately have Ord_\<pi>_Pi: "\<pi> \<in> elts (\<omega> * \<beta>) \<rightarrow> ON"
+            by fastforce
+          show "tp ?Z \<ge> \<omega> * \<beta>"
+          proof -
+            have \<dagger>: "(\<Union>m. ZA m) = ?Z"
+              using "15" by (force simp: ZA_def)
+            moreover
+            have "tp (elts (\<omega> * \<beta>)) \<le> tp (\<Union>m. ZA m)"
+            proof (rule ordertype_inc_le)
+              show "\<pi> ` elts (\<omega> * \<beta>) \<subseteq> (\<Union>m. ZA m)"
+                using \<pi>_Pi by blast
+            next
+              fix u v
+              assume x: "u \<in> elts (\<omega> * \<beta>)" and y: "v \<in> elts (\<omega> * \<beta>)" and "(u,v) \<in> VWF"
+              then have "u<v"
+                by (meson Ord_\<omega> Ord_in_Ord Ord_mult VWF_iff_Ord_less ord(2))
+              moreover
+              obtain m \<nu> n \<xi> where ueq: "u = \<omega> * \<nu> + ord_of_nat m" and \<nu>: "\<nu> \<in> elts \<beta>"
+                             and veq: "v = \<omega> * \<xi> + ord_of_nat n" and \<xi>: "\<xi> \<in> elts \<beta>"
+                using x y by (auto simp:  mult [of \<omega> \<beta>] lift_def elts_\<omega>)
+              ultimately have "\<nu> \<le> \<xi>"
+                by (meson Ord_\<omega> Ord_in_Ord Ord_linear2 \<open>Ord \<beta>\<close> add_mult_less_add_mult less_asym ord_of_nat_\<omega>)
+              consider (eq) "\<nu> = \<xi>" | (lt) "\<nu> < \<xi>"
+                using \<open>\<nu> \<le> \<xi>\<close> le_neq_trans by blast
+              then have "\<pi> u < \<pi> v"
+              proof cases
+                case eq
+                then have "m < n"
+                  using ueq veq \<open>u<v\<close> by simp
+                then have "\<phi> (q (\<xi>, 0)) m < \<phi> (q (\<xi>, 0)) n"
+                  using sm_\<phi> strict_mono_onD by blast
+                then show ?thesis
+                  using eq ueq veq \<nu> \<open>m < n\<close> by (simp add: \<pi>_def)
+              next
+                case lt
+                have "\<phi> (q(\<nu>,0)) m \<in> \<AA> (q(\<nu>,0)) (\<mu>(q(\<nu>,0)))" "\<phi> (q (\<xi>,0)) n \<in> \<AA> (q(\<xi>,0)) (\<mu>(q(\<xi>,0)))"
+                  using \<phi> unfolding ZA_def by blast+
+                then show ?thesis
+                  using lt ueq veq \<nu> \<xi> 18 [of "q(\<nu>,0)" "q(\<xi>,0)"]
+                  by (simp add: \<pi>_def less_sets_def)
+              qed
+              then show "(\<pi> u, \<pi> v) \<in> VWF"
+                using \<pi>_Pi
+                by (metis Ord_\<pi>_Pi PiE VWF_iff_Ord_less x y mem_Collect_eq)
+            qed (use \<dagger> in auto)
+            ultimately show ?thesis by simp
+          qed
+        qed
+        then obtain Z where "Z \<subseteq> ?Z" "tp Z = \<omega> * \<beta>"
+          by (meson Ord_\<omega> Ord_mult ord Z_sub down le_ordertype_obtains_subset)
+        ultimately show False
+          using iii [of Z] by (meson dual_order.trans image_mono nsets_mono)
+      qed
+      have False
+        if 0: "\<forall>H. tp H = ord_of_nat (2*k) \<longrightarrow> H \<subseteq> elts (\<alpha>*\<beta>) \<longrightarrow> \<not> f ` [H]\<^bsup>2\<^esup> \<subseteq> {0}"
+          and 1: "\<forall>H. tp H = min \<gamma> (\<omega> * \<beta>) \<longrightarrow> H \<subseteq> elts (\<alpha>*\<beta>) \<longrightarrow> \<not> f ` [H]\<^bsup>2\<^esup> \<subseteq> {1}"
+      proof (cases "\<omega>*\<beta> \<le> \<gamma>")
+        case True
+        then have \<dagger>: "\<exists>H'\<subseteq>H. tp H' = \<omega> * \<beta>" if "tp H = \<gamma>" "small H" for H
+          by (metis Ord_\<omega> Ord_\<omega>1 Ord_in_Ord Ord_mult \<beta> le_ordertype_obtains_subset that)
+        have [simp]: "min \<gamma> (\<omega>*\<beta>) = \<omega>*\<beta>"
+          by (simp add: min_absorb2 that True)
+        then show ?thesis
+          using * [OF 0] 1 True
+          by simp (meson \<dagger> down image_mono nsets_mono subset_trans)
+      next
+        case False
+        then have \<dagger>: "\<exists>H'\<subseteq>H. tp H' = \<gamma>" if "tp H = \<omega> * \<beta>" "small H" for H
+          by (metis Ord_linear_le Ord_ordertype \<open>Ord \<gamma>\<close> le_ordertype_obtains_subset that)
+        then have "\<gamma> \<le> \<omega>*\<beta>"
+          by (meson Ord_\<omega> Ord_\<omega>1 Ord_in_Ord Ord_linear_le Ord_mult \<beta> \<open>Ord \<gamma>\<close> False)
+        then have [simp]: "min \<gamma> (\<omega>*\<beta>) = \<gamma>"
+          by (simp add: min_absorb1)
+        then show ?thesis
+          using * [OF 0] 1 False
+          by simp (meson \<dagger> down image_mono nsets_mono subset_trans)
+      qed
+      then show "\<exists>i<Suc (Suc 0). \<exists>H\<subseteq>elts (\<alpha>*\<beta>). tp H = [ord_of_nat (2*k), min \<gamma> (\<omega>*\<beta>)] ! i \<and> f ` [H]\<^bsup>2\<^esup> \<subseteq> {i}"
+        by force
+    qed
+  qed
+qed
+
+
+theorem Erdos_Milner:
+  assumes \<nu>: "\<nu> \<in> elts \<omega>1"
+  shows "partn_lst_VWF (\<omega>\<up>(1 + \<nu> * ord_of_nat n)) [ord_of_nat (2^n), \<omega>\<up>(1+\<nu>)] 2"
+proof (induction n)
+  case 0
+  then show ?case
+    using partn_lst_VWF_degenerate [of 1 2] by simp
+next
+  case (Suc n)
+  have "Ord \<nu>"
+    using Ord_\<omega>1 Ord_in_Ord assms by blast
+  have "1+\<nu> \<le> \<nu>+1"
+    by (simp add: \<open>Ord \<nu>\<close> one_V_def plus_Ord_le)
+  then have [simp]: "min (\<omega> \<up> (1 + \<nu>)) (\<omega> * \<omega> \<up> \<nu>) = \<omega> \<up> (1+\<nu>)"
+    by (simp add: \<open>Ord \<nu>\<close> oexp_add min_def)
+  have ind: "indecomposable (\<omega> \<up> (1 + \<nu> * ord_of_nat n))"
+    by (simp add: \<open>Ord \<nu>\<close> indecomposable_\<omega>_power)
+  show ?case
+  proof (cases "n = 0")
+    case True
+    then show ?thesis
+      using partn_lst_VWF_\<omega>_2 \<open>Ord \<nu>\<close> one_V_def by auto
+  next
+    case False
+    then have "Suc 0 < 2 ^ n"
+      using less_2_cases not_less_eq by fastforce
+    then have "partn_lst_VWF (\<omega> \<up> (1 + \<nu> * n) * \<omega> \<up> \<nu>) [ord_of_nat (2 * 2 ^ n), \<omega> \<up> (1 + \<nu>)] 2"
+      using Erdos_Milner_aux [OF Suc ind, where \<beta> = "\<omega>\<up>\<nu>"] \<open>Ord \<nu>\<close> \<nu>
+      by (auto simp: countable_oexp)
+    then show ?thesis
+      using \<open>Ord \<nu>\<close> by (simp add: mult_succ mult.assoc oexp_add)
+  qed
+qed
+
+
+corollary remark_3: "partn_lst_VWF (\<omega>\<up>(Suc(4*k))) [4, \<omega>\<up>(Suc(2*k))] 2"
+  using Erdos_Milner [of "2*k" 2]
+  apply (simp flip: ord_of_nat_mult ord_of_nat.simps)
+  by (simp add: one_V_def)
+
+
+text \<open>Theorem 3.2 of Jean A. Larson, ibid.\<close>
+corollary Theorem_3_2:
+  fixes k n::nat
+  shows "partn_lst_VWF (\<omega>\<up>(n*k)) [\<omega>\<up>n, ord_of_nat k] 2"
+proof (cases "n=0 \<or> k=0")
+  case True
+  then show ?thesis
+    by (auto intro: partn_lst_triv0 [where i=1] partn_lst_triv1 [where i=0] simp add:)
+next
+  case False
+  then have "n > 0" "k > 0"
+    by auto
+  have PV: "partn_lst_VWF (\<omega> \<up> (1 + ord_of_nat (n-1) * ord_of_nat (k-1))) [ord_of_nat (2 ^ (k-1)), \<omega> \<up> (1 + ord_of_nat (n-1))] 2"
+    using Erdos_Milner [of "ord_of_nat (n-1)" "k-1"] Ord_\<omega>1 Ord_mem_iff_lt less_imp_le by blast
+  have "k+n \<le> Suc (Suc(k-1) * Suc(n-1))"
+    by simp
+  also have "\<dots> \<le> Suc (k * n)"
+    using False by auto
+  finally have "1 + (n - 1) * (k - 1) \<le> (n*k)"
+    using False by (auto simp: algebra_simps)
+  then have "(1 + ord_of_nat (n - 1) * ord_of_nat (k - 1)) \<le> ord_of_nat(n*k)"
+    by (metis (mono_tags, lifting) One_nat_def one_V_def ord_of_nat.simps ord_of_nat_add ord_of_nat_mono_iff ord_of_nat_mult)
+  then have x: "\<omega> \<up> (1 + ord_of_nat (n - 1) * ord_of_nat (k - 1)) \<le> \<omega>\<up>(n*k)"
+    by (simp add: oexp_mono_le)
+  then have "partn_lst_VWF (\<omega>\<up>(n*k)) [ord_of_nat (2 ^ (k-1)), \<omega> \<up> (1 + ord_of_nat (n-1))] 2"
+    using Partitions.partn_lst_greater_resource PV x by blast
+  then have "partn_lst_VWF (\<omega>\<up>(n*k)) [\<omega> \<up> (1 + ord_of_nat (n-1)), ord_of_nat (2 ^ (k-1))] 2"
+    using partn_lst_two_swap by blast
+  moreover have "(1 + ord_of_nat (n-1)) = ord_of_nat n"
+    using ord_of_minus_1 [OF \<open>n > 0\<close>]
+    by (simp add: one_V_def)
+  ultimately have "partn_lst_VWF (\<omega>\<up>(n*k)) [\<omega> \<up> n, ord_of_nat (2 ^ (k-1))] 2"
+    by simp
+  then show ?thesis
+    using power_gt_expt [of 2 "k-1"]
+    by (force simp: less_Suc_eq intro: partn_lst_less)
+qed
+
+end
diff --git a/thys/Ordinal_Partitions/Library_Additions.thy b/thys/Ordinal_Partitions/Library_Additions.thy
new file mode 100644
--- /dev/null
+++ b/thys/Ordinal_Partitions/Library_Additions.thy
@@ -0,0 +1,1177 @@
+section \<open>Library additions\<close>
+
+theory Library_Additions
+  imports "ZFC_in_HOL.Ordinal_Exp" "HOL-Library.Ramsey" "Nash_Williams.Nash_Williams"
+
+begin
+
+subsection \<open>Already in the development version\<close>
+
+declare \<omega>_gt0 [simp]
+
+lemma irrefl_less_than: "irrefl less_than"
+  using irrefl_def by blast
+
+lemma total_on_less_than [simp]: "total_on A less_than"
+  using total_on_def by force+
+
+lemma takeWhile_eq_Nil_iff: "takeWhile P xs = [] \<longleftrightarrow> xs = [] \<or> \<not>P (hd xs)"
+by (cases xs) auto
+
+lemma lenlex_append1:
+  assumes len: "(us,xs) \<in> lenlex R" and eq: "length vs = length ys" 
+  shows "(us @ vs, xs @ ys) \<in> lenlex R"
+  using len
+proof (induction us)
+  case Nil
+  then show ?case 
+    by (simp add: lenlex_def eq)
+next
+  case (Cons u us)
+  with lex_append_rightI show ?case
+    by (fastforce simp add: lenlex_def eq)
+qed
+
+lemma lenlex_append2 [simp]:
+  assumes "irrefl R"
+  shows "(us @ xs, us @ ys) \<in> lenlex R \<longleftrightarrow> (xs, ys) \<in> lenlex R"
+proof (induction us)
+  case Nil
+  then show ?case 
+    by (simp add: lenlex_def)
+next
+  case (Cons u us)
+  with assms show ?case
+    by (auto simp: lenlex_def irrefl_def)
+qed
+
+lemma hd_concat: "\<lbrakk>xs \<noteq> []; hd xs \<noteq> []\<rbrakk> \<Longrightarrow> hd (concat xs) = hd (hd xs)"
+  by (metis concat.simps(2) hd_Cons_tl hd_append2)
+
+lemma sorted_list_of_set_lessThan_Suc [simp]: 
+  "sorted_list_of_set {..<Suc k} = sorted_list_of_set {..<k} @ [k]"
+proof -
+  have "sorted_wrt (<) (sorted_list_of_set {..<k} @ [k])"
+    unfolding sorted_wrt_append  by (auto simp flip: strict_sorted_sorted_wrt)
+  then show ?thesis
+    by (simp add: lessThan_atLeast0)
+qed
+
+lemma finite_enumerate_in_set: "\<lbrakk>finite S; n < card S\<rbrakk> \<Longrightarrow> enumerate S n \<in> S"
+proof (induction n arbitrary: S)
+  case 0
+  then show ?case
+    by (metis all_not_in_conv card_empty enumerate.simps(1) not_less0 wellorder_Least_lemma(1))
+next
+  case (Suc n)
+  show ?case
+    using Suc.prems Suc.IH [of "S - {LEAST n. n \<in> S}"]
+    apply (simp add: enumerate.simps)
+    by (metis Diff_empty Diff_insert0 Suc_lessD card.remove less_Suc_eq)
+qed
+
+lemma finite_enumerate_step: "\<lbrakk>finite S; Suc n < card S\<rbrakk> \<Longrightarrow> enumerate S n < enumerate S (Suc n)"
+proof (induction n arbitrary: S)
+  case 0
+  then have "enumerate S 0 \<le> enumerate S (Suc 0)"
+    by (simp add: Least_le enumerate.simps(1) finite_enumerate_in_set)
+  moreover have "enumerate (S - {enumerate S 0}) 0 \<in> S - {enumerate S 0}"
+    by (metis 0 Suc_lessD Suc_less_eq card_Suc_Diff1 enumerate_in_set finite_enumerate_in_set)
+  then have "enumerate S 0 \<noteq> enumerate (S - {enumerate S 0}) 0"
+    by auto
+  ultimately show ?case
+    by (simp add: enumerate_Suc')
+next
+  case (Suc n)
+  then show ?case
+    by (simp add: enumerate_Suc' finite_enumerate_in_set)
+qed
+
+lemma finite_enumerate_mono: "\<lbrakk>m < n; finite S; n < card S\<rbrakk> \<Longrightarrow> enumerate S m < enumerate S n"
+  by (induct m n rule: less_Suc_induct) (auto intro: finite_enumerate_step)
+
+lemma finite_enumerate_Suc'':
+  fixes S :: "'a::wellorder set"
+  assumes "finite S" "Suc n < card S"
+  shows "enumerate S (Suc n) = (LEAST s. s \<in> S \<and> enumerate S n < s)"
+  using assms
+proof (induction n arbitrary: S)
+  case 0
+  then have "\<forall>s \<in> S. enumerate S 0 \<le> s"
+    by (auto simp: enumerate.simps intro: Least_le)
+  then show ?case
+    unfolding enumerate_Suc' enumerate_0[of "S - {enumerate S 0}"]
+    by (metis Diff_iff dual_order.strict_iff_order singletonD singletonI)
+next
+  case (Suc n S)
+  then have "Suc n < card (S - {enumerate S 0})"
+    using Suc.prems(2) finite_enumerate_in_set by force
+  then show ?case
+    apply (subst (1 2) enumerate_Suc')
+    apply (simp add: Suc)
+    apply (intro arg_cong[where f = Least] HOL.ext)
+    using finite_enumerate_mono[OF zero_less_Suc \<open>finite S\<close>, of n] Suc.prems
+    by (auto simp flip: enumerate_Suc')
+qed
+
+lemma finite_enumerate_initial_segment:
+  fixes S :: "'a::wellorder set"
+  assumes "finite S" and n: "n < card (S \<inter> {..<s})"
+  shows "enumerate (S \<inter> {..<s}) n = enumerate S n"
+  using n
+proof (induction n)
+  case 0
+  have "(LEAST n. n \<in> S \<and> n < s) = (LEAST n. n \<in> S)"
+  proof (rule Least_equality)
+    have "\<exists>t. t \<in> S \<and> t < s"
+      by (metis "0" card_gt_0_iff disjoint_iff_not_equal lessThan_iff)
+    then show "(LEAST n. n \<in> S) \<in> S \<and> (LEAST n. n \<in> S) < s"
+      by (meson LeastI Least_le le_less_trans)
+  qed (simp add: Least_le)
+  then show ?case
+    by (auto simp: enumerate_0)
+next
+  case (Suc n)
+  then have less_card: "Suc n < card S"
+    by (meson assms(1) card_mono inf_sup_ord(1) leD le_less_linear order.trans)
+  obtain T where T: "T \<in> {s \<in> S. enumerate S n < s}"
+    by (metis Infinite_Set.enumerate_step enumerate_in_set finite_enumerate_in_set finite_enumerate_step less_card mem_Collect_eq)
+  have "(LEAST x. x \<in> S \<and> x < s \<and> enumerate S n < x) = (LEAST x. x \<in> S \<and> enumerate S n < x)"
+       (is "_ = ?r")
+  proof (intro Least_equality conjI)
+    show "?r \<in> S"
+      by (metis (mono_tags, lifting) LeastI mem_Collect_eq T)
+    have "\<not> s \<le> ?r"
+      using not_less_Least [of _ "\<lambda>x. x \<in> S \<and> enumerate S n < x"] Suc assms
+      by (metis (mono_tags, lifting) Int_Collect Suc_lessD finite_Int finite_enumerate_in_set finite_enumerate_step lessThan_def less_le_trans)
+    then show "?r < s"
+      by auto
+    show "enumerate S n < ?r"
+      by (metis (no_types, lifting) LeastI mem_Collect_eq T)
+  qed (auto simp: Least_le)
+  then show ?case
+    using Suc assms by (simp add: finite_enumerate_Suc'' less_card)
+qed
+
+lemma finite_enumerate_Ex:
+  fixes S :: "'a::wellorder set"
+  assumes S: "finite S"
+    and s: "s \<in> S"
+  shows "\<exists>n<card S. enumerate S n = s"
+  using s S
+proof (induction s arbitrary: S rule: less_induct)
+  case (less s)
+  show ?case
+  proof (cases "\<exists>y\<in>S. y < s")
+    case True
+    let ?T = "S \<inter> {..<s}"
+    have "finite ?T"
+      using less.prems(2) by blast
+    have TS: "card ?T < card S"
+      using less.prems by (blast intro: psubset_card_mono [OF \<open>finite S\<close>])
+    from True have y: "\<And>x. Max ?T < x \<longleftrightarrow> (\<forall>s'\<in>S. s' < s \<longrightarrow> s' < x)"
+      by (subst Max_less_iff) (auto simp: \<open>finite ?T\<close>)
+    then have y_in: "Max ?T \<in> {s'\<in>S. s' < s}"
+      using Max_in \<open>finite ?T\<close> by fastforce
+    with less.IH[of "Max ?T" ?T] obtain n where n: "enumerate ?T n = Max ?T" "n < card ?T"
+      using \<open>finite ?T\<close> by blast
+    then have "Suc n < card S"
+      using TS less_trans_Suc by blast
+    with S n have "enumerate S (Suc n) = s"
+      by (subst finite_enumerate_Suc'') (auto simp: y finite_enumerate_initial_segment less finite_enumerate_Suc'' intro!: Least_equality)
+    then show ?thesis
+      using \<open>Suc n < card S\<close> by blast
+  next
+    case False
+    then have "\<forall>t\<in>S. s \<le> t" by auto
+    moreover have "0 < card S"
+      using card_0_eq less.prems by blast
+    ultimately show ?thesis
+      using \<open>s \<in> S\<close>
+      by (auto intro!: exI[of _ 0] Least_equality simp: enumerate_0)
+  qed
+qed
+
+lemma finite_bij_enumerate:
+  fixes S :: "'a::wellorder set"
+  assumes S: "finite S"
+  shows "bij_betw (enumerate S) {..<card S} S"
+proof -
+  have "\<And>n m. \<lbrakk>n \<noteq> m; n < card S; m < card S\<rbrakk> \<Longrightarrow> enumerate S n \<noteq> enumerate S m"
+    using finite_enumerate_mono[OF _ \<open>finite S\<close>] by (auto simp: neq_iff)
+  then have "inj_on (enumerate S) {..<card S}"
+    by (auto simp: inj_on_def)
+  moreover have "\<forall>s \<in> S. \<exists>i<card S. enumerate S i = s"
+    using finite_enumerate_Ex[OF S] by auto
+  moreover note \<open>finite S\<close>
+  ultimately show ?thesis
+    unfolding bij_betw_def by (auto intro: finite_enumerate_in_set)
+qed
+
+lemma length_sorted_list_of_set [simp]: "length (sorted_list_of_set A) = card A"
+proof (cases "finite A")
+  case True
+  then show ?thesis 
+    by(metis distinct_card distinct_sorted_list_of_set set_sorted_list_of_set)
+qed auto
+
+lemmas sorted_list_of_set = set_sorted_list_of_set sorted_sorted_list_of_set distinct_sorted_list_of_set
+
+lemma strict_sorted_equal:
+  assumes "strict_sorted xs"
+      and "strict_sorted ys"
+      and "set ys = set xs"
+    shows "ys = xs"
+  using assms
+proof (induction xs arbitrary: ys)
+  case (Cons x xs)
+  show ?case
+  proof (cases ys)
+    case Nil
+    then show ?thesis
+      using Cons.prems by auto 
+  next
+    case (Cons y ys')
+    then have "xs = ys'"
+      by (metis Cons.prems list.inject sorted_distinct_set_unique strict_sorted_iff)
+    moreover have "x = y"
+      using Cons.prems \<open>xs = ys'\<close> local.Cons by fastforce
+    ultimately show ?thesis
+      using local.Cons by blast
+  qed
+qed auto
+
+lemma sorted_list_of_set_inject:
+  assumes "sorted_list_of_set A = sorted_list_of_set B" "finite A" "finite B" 
+  shows "A = B"
+  using assms set_sorted_list_of_set by fastforce
+
+lemma sorted_list_of_set_unique:
+  assumes "finite A"
+  shows "strict_sorted l \<and> set l = A \<and> length l = card A \<longleftrightarrow> sorted_list_of_set A = l"
+  using assms strict_sorted_equal by force
+
+lemma iso_iff2: "iso r r' f \<longleftrightarrow>
+                 bij_betw f (Field r) (Field r') \<and> 
+                 (\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a, b) \<in> r \<longleftrightarrow> (f a, f b) \<in> r')"
+    (is "?lhs = ?rhs")
+proof
+  assume L: ?lhs
+  then have "bij_betw f (Field r) (Field r')" and emb: "embed r r' f"
+    by (auto simp: bij_betw_def iso_def)
+  then obtain g where g: "\<And>x. x \<in> Field r \<Longrightarrow> g (f x) = x"
+    by (auto simp: bij_betw_iff_bijections)
+  moreover
+  have "(a, b) \<in> r" if "a \<in> Field r" "b \<in> Field r" "(f a, f b) \<in> r'" for a b 
+    using that emb g g [OF FieldI1] \<comment>\<open>yes it's weird\<close>
+    by (force simp: embed_def under_def bij_betw_iff_bijections)
+  ultimately show ?rhs
+    using L by (auto simp: compat_def iso_def dest: embed_compat)
+next
+  assume R: ?rhs
+  then show ?lhs
+    apply (clarsimp simp add: iso_def embed_def under_def bij_betw_iff_bijections)
+    apply (rule_tac x=g in exI)
+    apply (fastforce simp add: intro: FieldI1)+
+    done
+qed
+
+lemma sorted_list_of_set_atMost_Suc [simp]:
+  "sorted_list_of_set {..Suc k} = sorted_list_of_set {..k} @ [Suc k]"
+  using lessThan_Suc_atMost sorted_list_of_set_lessThan_Suc by fastforce
+
+lemma sorted_list_of_set_greaterThanLessThan:
+  assumes "Suc i < j" 
+    shows "sorted_list_of_set {i<..<j} = Suc i # sorted_list_of_set {Suc i<..<j}"
+proof -
+  have "{i<..<j} = insert (Suc i) {Suc i<..<j}"
+    using assms by auto
+  then show ?thesis
+    by (metis assms atLeastSucLessThan_greaterThanLessThan sorted_list_of_set_range upt_conv_Cons)
+qed
+
+lemma sorted_list_of_set_greaterThanAtMost:
+  assumes "Suc i \<le> j" 
+    shows "sorted_list_of_set {i<..j} = Suc i # sorted_list_of_set {Suc i<..j}"
+  using sorted_list_of_set_greaterThanLessThan [of i "Suc j"]
+  by (metis assms greaterThanAtMost_def greaterThanLessThan_eq le_imp_less_Suc lessThan_Suc_atMost)
+
+lemma nth_sorted_list_of_set_greaterThanLessThan: 
+  "n < j - Suc i \<Longrightarrow> sorted_list_of_set {i<..<j} ! n = Suc (i+n)"
+  by (induction n arbitrary: i) (auto simp: sorted_list_of_set_greaterThanLessThan)
+
+lemma nth_sorted_list_of_set_greaterThanAtMost: 
+  "n < j - i \<Longrightarrow> sorted_list_of_set {i<..j} ! n = Suc (i+n)"
+  using nth_sorted_list_of_set_greaterThanLessThan [of n "Suc j" i]
+  by (simp add: greaterThanAtMost_def greaterThanLessThan_eq lessThan_Suc_atMost)
+
+lemma inv_into_ordermap: "\<alpha> \<in> elts (ordertype A r) \<Longrightarrow> inv_into A (ordermap A r) \<alpha> \<in> A"
+  by (meson in_mono inv_into_into ordermap_surj)
+
+lemma elts_multE:
+  assumes "z \<in> elts (x * y)" 
+  obtains u v where "u \<in> elts x" "v \<in> elts y" "z = x*v + u" 
+  using mult [of x y] lift_def assms by auto
+
+lemma Ord_add_mult_iff:
+  assumes "\<beta> \<in> elts \<gamma>" "\<beta>' \<in> elts \<gamma>" "Ord \<alpha>" "Ord \<alpha>'" "Ord \<gamma>"
+  shows "\<gamma> * \<alpha> + \<beta> \<in> elts (\<gamma> * \<alpha>' + \<beta>') \<longleftrightarrow> \<alpha> \<in> elts \<alpha>' \<or> \<alpha> = \<alpha>' \<and> \<beta> \<in> elts \<beta>'" (is "?lhs \<longleftrightarrow> ?rhs")
+proof
+  assume L: ?lhs
+  show ?rhs
+  proof (cases "\<alpha> \<in> elts \<alpha>'")
+    case False
+    with assms have "\<alpha> = \<alpha>'"
+      by (meson L Ord_linear Ord_mult Ord_trans add_mult_less not_add_mem_right)
+    then show ?thesis
+      using L less_V_def by auto
+  qed auto
+next
+  assume R: ?rhs
+  then show ?lhs
+  proof
+    assume "\<alpha> \<in> elts \<alpha>'"
+    then obtain \<delta> where "\<alpha>' = \<alpha>+\<delta>"
+      by (metis OrdmemD assms(3) assms(4) le_Ord_diff less_V_def)
+    show ?lhs 
+      using assms
+      by (meson \<open>\<alpha> \<in> elts \<alpha>'\<close> add_le_cancel_left0 add_mult_less vsubsetD)
+  next
+    assume "\<alpha> = \<alpha>' \<and> \<beta> \<in> elts \<beta>'"
+    then show ?lhs
+      using less_V_def by auto
+  qed
+qed
+
+lemma small_Times [simp]:
+  assumes "small A" "small B" 
+  shows "small (A \<times> B)"
+proof -
+  obtain f a g b where "inj_on f A" "inj_on g B" and f: "f ` A = elts a" and g: "g ` B = elts b"
+    using assms by (auto simp: small_def)
+  define h where "h \<equiv> \<lambda>(x,y). \<langle>f x, g y\<rangle>"
+  show ?thesis
+    unfolding small_def
+  proof (intro exI conjI)
+    show "inj_on h (A \<times> B)"
+      using \<open>inj_on f A\<close> \<open>inj_on g B\<close> by (simp add: h_def inj_on_def)
+    have "h ` (A \<times> B) = elts (vtimes a b)"
+      using f g by (fastforce simp: h_def image_iff split: prod.split)
+    then show "h ` (A \<times> B) \<in> range elts"
+      by blast
+  qed
+qed
+
+lemma ordertype_Times:
+  assumes "small A" "small B" and r: "wf r" "trans r" "total_on A r" and s: "wf s" "trans s" "total_on B s"
+  shows "ordertype (A\<times>B) (r <*lex*> s) = ordertype B s * ordertype A r" (is "_ = ?\<beta> * ?\<alpha>")
+proof (subst ordertype_eq_iff)
+  show "Ord (?\<beta> * ?\<alpha>)"
+    by (intro wf_Ord_ordertype Ord_mult r s; simp)
+  define f where "f \<equiv> \<lambda>(x,y). ?\<beta> * ordermap A r x + (ordermap B s y)"
+  show "\<exists>f. bij_betw f (A \<times> B) (elts (?\<beta> * ?\<alpha>)) \<and> (\<forall>x\<in>A \<times> B. \<forall>y\<in>A \<times> B. (f x < f y) = ((x, y) \<in> (r <*lex*> s)))"
+    unfolding bij_betw_def
+  proof (intro exI conjI strip)
+    show "inj_on f (A \<times> B)"
+    proof (clarsimp simp: f_def inj_on_def)
+      fix x y x' y'
+      assume "x \<in> A" "y \<in> B" "x' \<in> A" "y' \<in> B"
+        and eq: "?\<beta> * ordermap A r x + ordermap B s y = ?\<beta> * ordermap A r x' + ordermap B s y'"
+      have "ordermap A r x = ordermap A r x' \<and>
+            ordermap B s y = ordermap B s y'"
+      proof (rule mult_cancellation_lemma [OF eq])
+        show "ordermap B s y \<sqsubset> ?\<beta>"
+          using ordermap_in_ordertype [OF \<open>y \<in> B\<close>, of s] less_TC_iff \<open>small B\<close> by blast 
+        show "ordermap B s y' \<sqsubset> ?\<beta>"
+          using ordermap_in_ordertype [OF \<open>y' \<in> B\<close>, of s] less_TC_iff \<open>small B\<close> by blast 
+      qed
+      then show "x = x' \<and> y = y'"
+        using \<open>x \<in> A\<close> \<open>x' \<in> A\<close> \<open>y \<in> B\<close> \<open>y' \<in> B\<close> r s \<open>small A\<close> \<open>small B\<close> by auto
+    qed
+    show "f ` (A \<times> B) = elts (?\<beta> * ?\<alpha>)" (is "?lhs = ?rhs")
+    proof 
+      show "f ` (A \<times> B) \<subseteq> elts (?\<beta> * ?\<alpha>)"
+        apply (auto simp: f_def add_mult_less ordermap_in_ordertype wf_Ord_ordertype r s)
+        by (simp add: add_mult_less assms ordermap_in_ordertype wf_Ord_ordertype)
+      show "elts (?\<beta> * ?\<alpha>) \<subseteq> f ` (A \<times> B)"
+      proof (clarsimp simp: f_def image_iff elim!: elts_multE split: prod.split)
+        fix u v
+        assume u: "u \<in> elts (?\<beta>)" and v: "v \<in> elts ?\<alpha>"
+        have "inv_into B (ordermap B s) u \<in> B"
+          by (simp add: inv_into_ordermap u)
+        moreover have "inv_into A (ordermap A r) v \<in> A"
+          by (simp add: inv_into_ordermap v)
+        ultimately show "\<exists>x\<in>A. \<exists>y\<in>B. ?\<beta> * v + u = ?\<beta> * ordermap A r x + ordermap B s y"
+          by (metis \<open>small A\<close> \<open>small B\<close> bij_betw_inv_into_right ordermap_bij r(1) r(3) s(1) s(3) u v)
+      qed
+    qed
+  next
+    fix p q
+    assume "p \<in> A \<times> B" and "q \<in> A \<times> B"
+    then obtain u v x y where \<section>: "p = (u,v)" "u \<in> A" "v \<in> B" "q = (x,y)" "x \<in> A" "y \<in> B"
+      by blast
+    show "((f p) < f q) = ((p, q) \<in> (r <*lex*> s))"
+    proof
+      assume "f p < f q"
+      with \<section> assms have "(u, x) \<in> r \<or> u=x \<and> (v, y) \<in> s"
+        apply (simp add: f_def)
+        by (metis Ord_add Ord_add_mult_iff Ord_mem_iff_lt Ord_mult Ord_ordermap converse_ordermap_mono 
+            ordermap_eq_iff ordermap_in_ordertype wf_Ord_ordertype)
+      then show "(p,q) \<in> (r <*lex*> s)"
+        by (simp add: \<section>)
+    next
+      assume "(p,q) \<in> (r <*lex*> s)"
+      then have "(u, x) \<in> r \<or> u = x \<and> (v, y) \<in> s"
+        by (simp add: \<section>)
+      then show "f p < f q"
+      proof
+        assume ux: "(u, x) \<in> r"
+        have oo: "\<And>x. Ord (ordermap A r x)" "\<And>y. Ord (ordermap B s y)" 
+          by (simp_all add: r s)
+        show "f p < f q"
+        proof (clarsimp simp: f_def split: prod.split)
+          fix a b a' b'
+          assume "p = (a, b)" and "q = (a', b')"
+          then have "?\<beta> * ordermap A r a + ordermap B s b < ?\<beta> * ordermap A r a'"
+            using ux assms \<section>
+            by (metis Ord_mult Ord_ordermap OrdmemD Pair_inject add_mult_less ordermap_in_ordertype ordermap_mono wf_Ord_ordertype)
+          also have "\<dots> \<le> ?\<beta> * ordermap A r a' + ordermap B s b'"
+            by simp
+          finally show "?\<beta> * ordermap A r a + ordermap B s b < ?\<beta> * ordermap A r a' + ordermap B s b'" .
+        qed
+      next
+        assume "u = x \<and> (v, y) \<in> s"
+        then show "f p < f q"
+          using \<section> assms by (fastforce simp: f_def split: prod.split intro: ordermap_mono_less)
+      qed 
+    qed
+  qed 
+qed (use assms small_Times in auto)
+
+lemma ordertype_nat_\<omega>:
+  assumes "infinite N" shows "ordertype N less_than = \<omega>"
+proof -
+  have "small N"
+    by (meson inj_on_def ord_of_nat_inject small_def small_iff_range small_image_nat_V)
+  have "ordertype (ord_of_nat ` N) VWF = \<omega>"
+    by (force simp: assms finite_image_iff inj_on_def intro: ordertype_infinite_\<omega>)
+  moreover have "ordertype (ord_of_nat ` N) VWF = ordertype N less_than"
+    using total_on_def by (fastforce intro!: ordertype_inc_eq \<open>small N\<close>)
+  ultimately show ?thesis
+    by simp
+qed
+lemma infinite_infinite_partition:
+  assumes "infinite A"
+  obtains C :: "nat \<Rightarrow> 'a set" 
+    where "pairwise (\<lambda>i j. disjnt (C i) (C j)) UNIV" "(\<Union>i. C i) \<subseteq> A" "\<And>i. infinite (C i)"
+proof -
+  obtain f :: "nat\<Rightarrow>'a" where "range f \<subseteq> A" "inj f"
+    using assms infinite_countable_subset by blast
+  let ?C = "\<lambda>i. range (\<lambda>j. f (prod_encode (i,j)))"
+  show thesis
+  proof
+    show "pairwise (\<lambda>i j. disjnt (?C i) (?C j)) UNIV"
+      by (auto simp: pairwise_def disjnt_def inj_on_eq_iff [OF \<open>inj f\<close>] inj_on_eq_iff [OF inj_prod_encode, of _ UNIV])
+    show "(\<Union>i. ?C i) \<subseteq> A"
+      using \<open>range f \<subseteq> A\<close> by blast
+    have "infinite (range (\<lambda>j. f (prod_encode (i, j))))" for i
+      by (rule range_inj_infinite) (meson Pair_inject \<open>inj f\<close> inj_def prod_encode_eq)
+    then show "\<And>i. infinite (?C i)"
+      using that by auto
+  qed
+qed
+
+text \<open>This is already installed in the development AFP entry\<close>
+lemma mult_cancellation_half:
+  assumes "a*x + r \<le> a*y + s" "r \<sqsubset> a" "s \<sqsubset> a"
+  shows "x \<le> y"
+proof -
+  have "x \<le> y" if "Ord \<alpha>" "x \<in> elts (Vset \<alpha>)" "y \<in> elts (Vset \<alpha>)" for \<alpha>
+    using that assms
+  proof (induction \<alpha> arbitrary: x y r s rule: Ord_induct3)
+    case 0
+    then show ?case
+      by auto
+  next
+    case (succ k)
+    show ?case
+    proof
+      fix u
+      assume u: "u \<in> elts x"
+      have u_k: "u \<in> elts (Vset k)"
+        using Vset_succ succ.hyps succ.prems(1) u by auto
+      obtain r' where "r' \<in> elts a" "r \<sqsubseteq> r'"
+        using less_TC_iff succ.prems(4) by blast
+      have "a*u + r' \<in> elts (lift (a*u) a)"
+        by (simp add: \<open>r' \<in> elts a\<close> lift_def)
+      also have "\<dots> \<le> elts (a*x)"
+        using u by (force simp: mult [of _ x])
+      also have "\<dots> \<le> elts (a*y + s)"
+        using plus_eq_lift succ.prems(3) by auto
+      also have "\<dots> = elts (a*y) \<union> elts (lift (a*y) s)"
+        by (simp add: plus_eq_lift)
+      finally have "a * u + r' \<in> elts (a * y) \<union> elts (lift (a * y) s)" .
+      then show "u \<in> elts y"
+      proof
+        assume *: "a * u + r' \<in> elts (a * y)"
+        show "u \<in> elts y"
+        proof -
+          obtain v e where v: "v \<in> elts y" "e \<in> elts a" "a * u + r' = a * v + e"
+            using * by (auto simp: mult [of _ y] lift_def)
+          then have v_k: "v \<in> elts (Vset k)"
+            using Vset_succ_TC less_TC_iff succ.prems(2) by blast
+          then show ?thesis
+            by (metis \<open>r' \<in> elts a\<close> antisym le_TC_refl less_TC_iff order_refl succ.IH u_k v)
+        qed
+      next
+        assume "a * u + r' \<in> elts (lift (a * y) s)"
+        then obtain t where "t \<in> elts s" and t: "a * u + r' = a * y + t"
+          using lift_def by auto
+        have noteq: "a*y \<noteq> a*u"
+        proof
+          assume "a*y = a*u"
+          then have "lift (a*y) a = lift (a*u) a"
+            by metis
+          also have "\<dots> \<le> a*x"
+            unfolding mult [of _ x] using \<open>u \<in> elts x\<close> by (auto intro: cSUP_upper)
+          also have "\<dots> \<le> a*y \<squnion> lift (a*y) s"
+            using \<open>elts (a * x) \<subseteq> elts (a * y + s)\<close> plus_eq_lift by auto
+          finally have "lift (a*y) a \<le> a*y \<squnion> lift (a*y) s" .
+          then have "lift (a*y) a \<le> lift (a*y) s"
+            using add_le_cancel_left less_TC_imp_not_le plus_eq_lift \<open>s \<sqsubset> a\<close> by auto
+          then have "a \<le> s"
+            by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib)
+          then show False
+            using \<open>s \<sqsubset> a\<close> less_TC_imp_not_le by auto
+        qed
+        consider "a * u \<unlhd> a * y" | "a * y \<unlhd> a * u"
+          using t comparable vle_comparable_def by blast
+        then have "False"
+        proof cases
+          case 1
+          then obtain c where "a*y = a*u + c"
+            by (metis vle_def)
+          then have "c+t = r'"
+            by (metis add_right_cancel add.assoc t)
+          then have "c \<sqsubset> a"
+            using \<open>r' \<in> elts a\<close> less_TC_iff vle2 vle_def by force
+          moreover have "c \<noteq> 0"
+            using \<open>a * y = a * u + c\<close> noteq by auto
+          ultimately show ?thesis
+            using \<open>a * y = a * u + c\<close> mult_eq_imp_0 by blast
+        next
+          case 2
+          then obtain c where "a*u = a*y + c"
+            by (metis vle_def)
+          then have "c+r' = t"
+            by (metis add_right_cancel add.assoc t)
+          then have "c \<sqsubset> a"
+            by (metis \<open>t \<in> elts s\<close> less_TC_iff less_TC_trans \<open>s \<sqsubset> a\<close> vle2 vle_def)
+          moreover have "c \<noteq> 0"
+            using \<open>a * u = a * y + c\<close> noteq by auto
+          ultimately show ?thesis
+            using \<open>a * u = a * y + c\<close> mult_eq_imp_0 by blast
+        qed
+        then show "u \<in> elts y" ..
+      qed
+    qed
+  next
+    case (Limit k)
+    obtain i j where k: "i \<in> elts k" "j \<in> elts k"
+      and x: "x \<in> elts (Vset i)" and y: "y \<in> elts (Vset j)"
+      using that Limit by (auto simp: Limit_Vfrom_eq)
+    show ?case
+    proof (rule Limit.IH [of "i \<squnion> j"])
+      show "i \<squnion> j \<in> elts k"
+        by (meson k x y Limit.hyps Limit_def Ord_in_Ord Ord_mem_iff_lt Ord_sup union_less_iff)
+      show "x \<in> elts (Vset (i \<squnion> j))" "y \<in> elts (Vset (i \<squnion> j))"
+        using x y by (auto simp: Vfrom_sup)
+      show "a * x + r \<le> a * y + s"
+        by (simp add: Limit.prems)
+    qed (auto simp: Limit.prems)
+  qed
+  then show ?thesis
+    by (metis two_in_Vset Ord_rank Ord_VsetI rank_lt)
+qed
+
+corollary mult_cancellation_less:
+  assumes lt: "a*x + r < a*y + s" and "r \<sqsubset> a" "s \<sqsubset> a"
+  obtains "x < y" | "x = y" "r < s"
+proof -
+  have "x \<le> y"
+    by (meson assms dual_order.strict_implies_order mult_cancellation_half)
+  then consider "x < y" | "x = y"
+    using less_V_def by blast
+  with lt that show ?thesis by blast
+qed
+
+subsection \<open>For HOL\<close>
+
+lemma enumerate_mono_iff [simp]:
+  "infinite S \<Longrightarrow> enumerate S m < enumerate S n \<longleftrightarrow> m < n"
+  by (metis enumerate_mono less_asym less_linear)
+
+lemma finite_enumerate_mono_iff [simp]:
+  "\<lbrakk>finite S; m < card S; n < card S\<rbrakk> \<Longrightarrow> enumerate S m < enumerate S n \<longleftrightarrow> m < n"
+  by (metis finite_enumerate_mono less_asym less_linear)
+
+lemma finite_enumerate_Diff_singleton:
+  fixes S :: "'a::wellorder set"
+  assumes "finite S" and i: "i < card S" "enumerate S i < x"
+  shows "enumerate (S - {x}) i = enumerate S i"
+  using i
+proof (induction i)
+  case 0
+  have "(LEAST i. i \<in> S \<and> i\<noteq>x) = (LEAST i. i \<in> S)"
+  proof (rule Least_equality)
+    have "\<exists>t. t \<in> S \<and> t\<noteq>x"
+      using 0 \<open>finite S\<close> finite_enumerate_in_set by blast
+    then show "(LEAST i. i \<in> S) \<in> S \<and> (LEAST i. i \<in> S) \<noteq> x"
+      by (metis "0.prems"(2) LeastI enumerate_0 not_less_Least)
+  qed (simp add: Least_le)
+  then show ?case
+    by (auto simp: enumerate_0)
+next
+  case (Suc i)
+  then have x: "enumerate S i < x"
+    by (meson enumerate_step finite_enumerate_step less_trans)
+  have cardSx: "Suc i < card (S - {x})" and "i < card S"
+    using Suc \<open>finite S\<close> card_Diff_singleton_if finite_enumerate_Ex by fastforce+
+  have "(LEAST s. s \<in> S \<and> s\<noteq>x \<and> enumerate (S - {x}) i < s) = (LEAST s. s \<in> S \<and> enumerate S i < s)"
+       (is "_ = ?r")
+  proof (intro Least_equality conjI)
+    show "?r \<in> S"
+      by (metis (lifting) LeastI Suc.prems(1) assms(1) finite_enumerate_in_set finite_enumerate_step)
+    show "?r \<noteq> x"
+      using Suc.prems not_less_Least [of _ "\<lambda>t. t \<in> S \<and> enumerate S i < t"] 
+       \<open>finite S\<close> finite_enumerate_in_set finite_enumerate_step by blast
+    show "enumerate (S - {x}) i < ?r"
+      by (metis (full_types) Suc.IH Suc.prems(1) \<open>i < card S\<close> enumerate_Suc'' enumerate_step finite_enumerate_Suc'' finite_enumerate_step x)
+    show "\<And>y. y \<in> S \<and> y \<noteq> x \<and> enumerate (S - {x}) i < y \<Longrightarrow> ?r \<le> y"
+      by (simp add: Least_le Suc.IH \<open>i < card S\<close> x)
+  qed
+  then show ?case
+    using Suc assms by (simp add: finite_enumerate_Suc'' cardSx)
+qed
+
+
+
+lemma lexl_not_refl [simp]: "irrefl r \<Longrightarrow> (x,x) \<notin> lex r"
+  by (meson irrefl_def lex_take_index)
+
+lemma hd_lex: "\<lbrakk>hd ms < hd ns; length ms = length ns; ns \<noteq> []\<rbrakk> \<Longrightarrow> (ms, ns) \<in> lex less_than"
+  by (metis hd_Cons_tl length_0_conv less_than_iff lexord_cons_cons lexord_lex)
+
+
+lemma finite_enum_subset:
+  assumes "\<And>i. i < card X \<Longrightarrow> enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X \<le> card Y"
+  shows "X \<subseteq> Y"
+  by (metis assms finite_enumerate_Ex finite_enumerate_in_set less_le_trans subsetI)
+
+lemma finite_enum_ext:
+  assumes "\<And>i. i < card X \<Longrightarrow> enumerate X i = enumerate Y i" and "finite X" "finite Y" "card X = card Y"
+  shows "X = Y"
+  by (intro antisym finite_enum_subset) (auto simp: assms)
+
+thm card_Un_disjoint
+lemma card_Un_disjnt: "\<lbrakk>finite A; finite B; disjnt A B\<rbrakk> \<Longrightarrow> card (A \<union> B) = card A + card B"
+  by (simp add: card_Un_disjoint disjnt_def)
+
+
+lemma sorted_list_of_set_nonempty:
+  assumes "finite I" "I \<noteq> {}"
+  shows "sorted_list_of_set I = Min I # sorted_list_of_set (I - {Min I})"
+  using assms by (auto simp: less_le simp flip: sorted_list_of_set_unique intro: Min_in)
+lemma strict_sorted_imp_sorted: "strict_sorted xs \<Longrightarrow> sorted xs"
+  by (auto simp: strict_sorted_iff)
+
+lemma sorted_hd_le:
+  assumes "sorted xs" "x \<in> list.set xs"
+  shows "hd xs \<le> x"
+  using assms by (induction xs) (auto simp: less_imp_le)
+
+lemma sorted_le_last:
+  assumes "sorted xs" "x \<in> list.set xs"
+  shows "x \<le> last xs"
+  using assms by (induction xs) (auto simp: less_imp_le)
+
+lemma hd_list_of:
+  assumes "finite A" "A \<noteq> {}"
+  shows "hd (sorted_list_of_set A) = Min A" 
+proof (rule antisym)
+  have "Min A \<in> A"
+    by (simp add: assms)
+  then show "hd (sorted_list_of_set A) \<le> Min A"
+    by (simp add: sorted_hd_le \<open>finite A\<close>)
+next
+  show "Min A \<le> hd (sorted_list_of_set A)"
+    by (metis Min_le assms hd_in_set set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff)
+qed
+
+lemma sorted_hd_le_last:
+  assumes "sorted xs" "xs \<noteq> []"
+  shows "hd xs \<le> last xs"
+  using assms by (simp add: sorted_hd_le)
+
+lemma sorted_list_of_set_set_of [simp]: "strict_sorted l \<Longrightarrow> sorted_list_of_set (list.set l) = l"
+  by (simp add: strict_sorted_equal)
+
+lemma finite_Inf_in:
+  fixes A :: "'a::complete_lattice set"
+  assumes "finite A" "A\<noteq>{}" and inf: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> inf x y \<in> A"
+  shows "Inf A \<in> A"
+proof -
+  have "Inf B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
+    using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
+  by (induction B) (use inf in \<open>force+\<close>)
+  then show ?thesis
+    by (simp add: assms)
+qed
+
+lemma finite_Sup_in:
+  fixes A :: "'a::complete_lattice set"
+  assumes "finite A" "A\<noteq>{}" and sup: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> sup x y \<in> A"
+  shows "Sup A \<in> A"
+proof -
+  have "Sup B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
+    using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
+  by (induction B) (use sup in \<open>force+\<close>)
+  then show ?thesis
+    by (simp add: assms)
+qed
+
+lemma range_strict_mono_ext:
+  fixes f::"nat \<Rightarrow> 'a::linorder"
+  assumes eq: "range f = range g"
+      and sm: "strict_mono f" "strict_mono g"
+    shows "f = g"
+proof
+  fix n
+  show "f n = g n"
+  proof (induction n rule: less_induct)
+    case (less n)
+    obtain x y where xy: "f n = g y" "f x = g n"
+      by (metis eq imageE rangeI)
+    then have "n = y"
+      by (metis (no_types) less.IH neq_iff sm strict_mono_less xy)
+    then show ?case using xy by auto
+  qed
+qed
+
+(*METIS NOT ALLOWED!*)
+
+lemma iso_trans:
+  assumes "trans r" "iso r r' f" shows "trans r'"
+  using assms unfolding trans_def iso_iff2 bij_betw_iff_bijections 
+  by (metis (full_types) FieldI1 FieldI2)
+
+lemma iso_Total:
+  assumes "Total r" "iso r r' f" shows "Total r'"
+  using assms unfolding total_on_def iso_iff2 bij_betw_iff_bijections by metis
+
+lemma iso_wf:
+  assumes "wf r" "iso r r' f" shows "wf r'"
+proof -
+  have bij: "bij_betw f (Field r) (Field r')"
+    and iff: "(\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a, b) \<in> r \<longleftrightarrow> (f a, f b) \<in> r')"
+    using assms by (auto simp: iso_iff2)
+  show ?thesis
+  proof (rule wfI_min)
+    fix x::'b and Q
+    assume "x \<in> Q"
+    let ?Q = "inv_into (Field r) f ` Q"
+    obtain z where "z \<in> ?Q" "\<And>x y. \<lbrakk>(y, z) \<in> r; x \<in> Q\<rbrakk> \<Longrightarrow> y \<noteq> inv_into (Field r) f x"
+      by (metis \<open>x \<in> Q\<close> \<open>wf r\<close> image_eqI wfE_min)
+    with bij show "\<exists>z\<in>Q. \<forall>y. (y, z) \<in> r' \<longrightarrow> y \<notin> Q"
+      by (metis (no_types, lifting) FieldI2 bij_betw_imp_surj_on f_inv_into_f iff inv_into_into)
+  qed
+qed
+
+
+subsection \<open>Also in the Nash-Williams development\<close>
+text \<open>FIXME: these contain duplicates and need consolidation\<close>
+
+lemma less_setsD: "\<lbrakk>less_sets A B; a \<in> A; b \<in> B\<rbrakk> \<Longrightarrow> a < b"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_irrefl [simp]: "less_sets A A \<longleftrightarrow> A = {}"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_trans: "\<lbrakk>less_sets A B; less_sets B C; B \<noteq> {}\<rbrakk> \<Longrightarrow> less_sets A C"
+  unfolding less_sets_def using less_trans by blast
+
+lemma less_sets_weaken1: "\<lbrakk>less_sets A' B; A \<subseteq> A'\<rbrakk> \<Longrightarrow> less_sets A B"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_weaken2: "\<lbrakk>less_sets A B'; B \<subseteq> B'\<rbrakk> \<Longrightarrow> less_sets A B"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_imp_disjnt: "less_sets A B \<Longrightarrow> disjnt A B"
+  by (auto simp: less_sets_def disjnt_def)
+
+lemma less_sets_Un1: "less_sets (A \<union> A') B \<longleftrightarrow> less_sets A B \<and> less_sets A' B"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_Un2: "less_sets A (B \<union> B') \<longleftrightarrow> less_sets A B \<and> less_sets A B'"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_UN1: "less_sets (\<Union>\<A>) B \<longleftrightarrow> (\<forall>A\<in>\<A>. less_sets A B)"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_UN2: "less_sets A (\<Union> \<B>) \<longleftrightarrow> (\<forall>B\<in>\<B>. less_sets A B)"
+  by (auto simp: less_sets_def)
+
+lemma strict_sorted_imp_less_sets:
+  "strict_sorted (as @ bs) \<Longrightarrow> less_sets (list.set as) (list.set bs)"
+  by (simp add: less_sets_def sorted_wrt_append strict_sorted_sorted_wrt)
+
+subsection \<open>Other material\<close>
+
+definition strict_mono_sets :: "['a::order set, 'a::order \<Rightarrow> 'b::order set] \<Rightarrow> bool" where
+  "strict_mono_sets A f \<equiv> \<forall>x\<in>A. \<forall>y\<in>A. x < y \<longrightarrow> less_sets (f x) (f y)"
+
+lemma strict_mono_setsD:
+  assumes "strict_mono_sets A f" "x < y" "x \<in> A" "y \<in> A"
+  shows "less_sets (f x) (f y)"
+  using assms by (auto simp: strict_mono_sets_def)
+
+lemma strict_mono_on_o: "\<lbrakk>strict_mono_on r A; strict_mono_on s B; s ` B \<subseteq> A\<rbrakk> \<Longrightarrow> strict_mono_on (r \<circ> s) B"
+  by (auto simp: image_subset_iff strict_mono_on_def)
+
+lemma strict_mono_sets_imp_disjoint:
+  fixes A :: "'a::linorder set"
+  assumes "strict_mono_sets A f"
+  shows "pairwise (\<lambda>x y. disjnt (f x) (f y)) A"
+  using assms unfolding strict_mono_sets_def pairwise_def
+  by (meson antisym_conv3 disjnt_sym less_sets_imp_disjnt)
+
+lemma strict_mono_sets_subset:
+  assumes "strict_mono_sets B f" "A \<subseteq> B"
+  shows "strict_mono_sets A f"
+  using assms by (auto simp: strict_mono_sets_def)
+
+lemma strict_mono_less_sets_Min:
+  assumes "strict_mono_sets I f" "finite I" "I \<noteq> {}"
+  shows "less_sets (f (Min I)) (\<Union> (f ` (I - {Min I})))"
+  using assms by (simp add: strict_mono_sets_def less_sets_UN2 dual_order.strict_iff_order)
+
+lemma pair_less_iff1 [simp]: "((x,y), (x,z)) \<in> pair_less \<longleftrightarrow> y<z"
+  by (simp add: pair_less_def)
+
+lemma infinite_finite_Inter:
+  assumes "finite \<A>" "\<A>\<noteq>{}" "\<And>A. A \<in> \<A> \<Longrightarrow> infinite A"
+    and "\<And>A B. \<lbrakk>A \<in> \<A>; B \<in> \<A>\<rbrakk> \<Longrightarrow> A \<inter> B \<in> \<A>"
+  shows "infinite (\<Inter>\<A>)"
+  by (simp add: assms finite_Inf_in)
+
+lemma atLeast_less_sets: "\<lbrakk>less_sets A {x}; B \<subseteq> {x..}\<rbrakk> \<Longrightarrow> less_sets A B"
+  by (force simp: less_sets_def subset_iff)
+
+
+
+subsection \<open>The list-of function\<close>
+
+(*NOT THE FOLLOWING*)
+
+lemma sorted_list_of_set_insert:
+  assumes "finite A" "less_sets {a} A"
+  shows "sorted_list_of_set (insert a A) = a # sorted_list_of_set A"
+proof -
+  have "strict_sorted (a # sorted_list_of_set A)"
+    using assms less_setsD by auto
+  moreover have "list.set (a # sorted_list_of_set A) = insert a A"
+    using assms by force
+  moreover have "length (a # sorted_list_of_set A) = card (insert a A)"
+    using assms card_insert_if less_setsD by fastforce
+  ultimately show ?thesis
+    by (metis assms(1) finite_insert sorted_list_of_set_unique)
+qed
+
+lemma sorted_list_of_set_Un:
+  assumes AB: "less_sets A B" and fin: "finite A" "finite B"
+  shows "sorted_list_of_set (A \<union> B) = sorted_list_of_set A @ sorted_list_of_set B"
+proof -
+  have "strict_sorted (sorted_list_of_set A @ sorted_list_of_set B)"
+    using AB unfolding less_sets_def
+    by (metis fin set_sorted_list_of_set sorted_wrt_append strict_sorted_list_of_set strict_sorted_sorted_wrt)
+  moreover have "card A + card B = card (A \<union> B)"
+    using less_sets_imp_disjnt [OF AB]
+    by (simp add: assms card_Un_disjoint disjnt_def)
+  ultimately show ?thesis
+    by (simp add: assms strict_sorted_equal)
+qed
+
+lemma sorted_list_of_set_UN_lessThan:
+  fixes k::nat
+  assumes sm: "strict_mono_sets {..<k} A" and "\<And>i. i < k \<Longrightarrow> finite (A i)"
+  shows "sorted_list_of_set (\<Union>i<k. A i) = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..<k}))"
+  using assms
+proof (induction k)
+  case 0
+  then show ?case
+    by auto
+next
+  case (Suc k)
+  have ls: "less_sets (\<Union> (A ` {..<k})) (A k)"
+    using sm Suc.prems(1) strict_mono_setsD by (force simp: less_sets_UN1)
+  have "sorted_list_of_set (\<Union> (A ` {..<Suc k})) = sorted_list_of_set (\<Union> (A ` {..<k}) \<union> A k)"
+    by (simp add: Un_commute lessThan_Suc)
+  also have "\<dots> = sorted_list_of_set (\<Union> (A ` {..<k})) @ sorted_list_of_set (A k)"
+    by (rule sorted_list_of_set_Un) (auto simp: Suc.prems ls)
+  also have "\<dots> = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..<k})) @ sorted_list_of_set (A k)"
+    using Suc strict_mono_sets_def by fastforce
+  also have "\<dots> = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..<Suc k}))"
+    using strict_mono_sets_def by fastforce
+  finally show ?case .
+qed
+
+lemma sorted_list_of_set_UN_atMost:
+  fixes k::nat
+  assumes "strict_mono_sets {..k} A" and "\<And>i. i \<le> k \<Longrightarrow> finite (A i)"
+  shows "sorted_list_of_set (\<Union>i\<le>k. A i) = concat (map (sorted_list_of_set \<circ> A) (sorted_list_of_set {..k}))"
+  by (metis assms lessThan_Suc_atMost less_Suc_eq_le sorted_list_of_set_UN_lessThan)
+
+
+
+subsection \<open>Ramsey\<close>
+
+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)
+
+subsection \<open>Misc additions to the ZF libraries\<close>
+
+
+lemma oexp_\<omega>_Limit: "Limit \<beta> \<Longrightarrow> \<omega>\<up>\<beta> = (SUP \<xi> \<in> elts \<beta>. \<omega>\<up>\<xi>)"
+  by (simp add: oexp_Limit)
+
+
+lemma oexp_mult_commute:
+  fixes j::nat
+  shows "Ord \<alpha> \<Longrightarrow> (\<alpha> \<up> j) * \<alpha> = \<alpha> * (\<alpha> \<up> j)"
+  by (metis Ord_1 Ord_ord_of_nat oexp_1_right oexp_add oexp_succ one_V_def ord_of_nat_\<omega> succ_0_plus_eq)
+
+lemma iso_imp_ordertype_eq_ordertype:
+  assumes iso: "iso r r' f"
+    and "wf r"
+    and "Total r"
+    and "trans r"
+    and sm: "small (Field r)"
+  shows "ordertype (Field r) r = ordertype (Field r') r'"
+proof (subst ordertype_eq_ordertype)
+  show "small (Field r')"
+    by (metis iso sm iso_Field replacement)
+  show "\<exists>f. bij_betw f (Field r) (Field r') \<and> (\<forall>x\<in>Field r. \<forall>y\<in>Field r. ((f x, f y) \<in> r') = ((x, y) \<in> r))"
+    using assms(1) iso_iff2 by blast
+qed (use assms iso_wf iso_Total iso_trans in auto)
+
+proposition ordertype_eq_ordertype_iso:
+  assumes r: "wf r" "total_on A r" "trans r" and "small A" and FA: "Field r = A"
+  assumes s: "wf s" "total_on B s" "trans s" and "small B" and FB: "Field s = B"
+  shows "ordertype A r = ordertype B s \<longleftrightarrow> (\<exists>f. iso r s f)"
+    (is "?lhs = ?rhs")
+proof
+  assume L: ?lhs
+  then obtain f where "bij_betw f A B" "\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r"
+    using assms ordertype_eq_ordertype by blast
+  then show ?rhs
+    using FA FB iso_iff2 by blast
+next
+  assume ?rhs
+  then show ?lhs
+    using FA FB \<open>small A\<close> iso_imp_ordertype_eq_ordertype r by blast
+qed
+
+lemma total_on_imp_Total_Restr: "total_on A r \<Longrightarrow> Total (Restr r A)"
+  by (auto simp: Field_def total_on_def)
+
+lemma Limit_ordertype_imp_Field_Restr:
+  assumes Lim: "Limit (ordertype A r)" and r: "wf r" "total_on A r" and "small A"
+  shows "Field (Restr r A) = A"
+proof -
+  have "\<exists>y\<in>A. (x,y) \<in> r" if "x \<in> A" for x
+  proof -
+    let ?oy = "succ (ordermap A r x)"
+    have \<section>: "?oy \<in> elts (ordertype A r)"
+      by (simp add: Lim \<open>small A\<close> ordermap_in_ordertype succ_in_Limit_iff that)
+    then have A: "inv_into A (ordermap A r) ?oy \<in> A"
+      by (simp add: inv_into_ordermap)
+    moreover have "(x, inv_into A (ordermap A r) ?oy) \<in> r"
+    proof -
+      have "ordermap A r x \<in> elts (ordermap A r (inv_into A (ordermap A r) ?oy))"
+        by (metis "\<section>" elts_succ f_inv_into_f insert_iff ordermap_surj subsetD)
+      then show ?thesis
+        by (metis \<open>small A\<close> A converse_ordermap_mono r that)
+    qed
+    ultimately show ?thesis ..
+  qed
+  then have "A \<subseteq> Field (Restr r A)"
+    by (auto simp: Field_def)
+  then show ?thesis
+    by (simp add: Field_Restr_subset subset_antisym)
+qed
+
+lemma ordertype_Field_Restr:
+  assumes "wf r" "total_on A r" "trans r" "small A" "Field (Restr r A) = A"
+  shows "ordertype (Field (Restr r A)) (Restr r A) = ordertype A r"
+  using assms by (force simp: ordertype_eq_ordertype wf_Restr total_on_def trans_Restr)
+
+proposition ordertype_eq_ordertype_iso_Restr:
+  assumes r: "wf r" "total_on A r" "trans r" and "small A" and FA: "Field (Restr r A) = A"
+  assumes s: "wf s" "total_on B s" "trans s" and "small B" and FB: "Field (Restr s B) = B"
+  shows "ordertype A r = ordertype B s \<longleftrightarrow> (\<exists>f. iso (Restr r A) (Restr s B) f)"
+    (is "?lhs = ?rhs")
+proof
+  assume L: ?lhs
+  then obtain f where "bij_betw f A B" "\<forall>x \<in> A. \<forall>y \<in> A. (f x, f y) \<in> s \<longleftrightarrow> (x,y) \<in> r"
+    using assms ordertype_eq_ordertype by blast
+  then show ?rhs
+    using FA FB bij_betwE unfolding iso_iff2 by fastforce
+next
+  assume ?rhs
+  moreover
+  have "ordertype (Field (Restr r A)) (Restr r A) = ordertype A r"
+    using FA \<open>small A\<close> ordertype_Field_Restr r by blast
+  moreover
+  have "ordertype (Field (Restr s B)) (Restr s B) = ordertype B s"
+    using FB \<open>small B\<close> ordertype_Field_Restr s by blast
+  ultimately show ?lhs
+    using iso_imp_ordertype_eq_ordertype FA FB \<open>small A\<close> r
+    by (fastforce intro: total_on_imp_Total_Restr trans_Restr wf_Int1)
+qed
+
+subsection \<open>Monotonic enumeration of a countably infinite set\<close>
+
+abbreviation "enum \<equiv> enumerate"
+
+text \<open>Could be generalised to infinite countable sets of any type\<close>
+lemma nat_infinite_iff:
+  fixes N :: "nat set"
+  shows "infinite N \<longleftrightarrow> (\<exists>f::nat\<Rightarrow>nat. N = range f \<and> strict_mono f)"
+proof safe
+  assume "infinite N"
+  then show "\<exists>f. N = range (f::nat \<Rightarrow> nat) \<and> strict_mono f"
+    by (metis bij_betw_imp_surj_on bij_enumerate enumerate_mono strict_mono_def)
+next
+  fix f :: "nat \<Rightarrow> nat"
+  assume "strict_mono f" and "N = range f" and "finite (range f)"
+  then show False
+    using range_inj_infinite strict_mono_imp_inj_on by blast
+qed
+
+lemma enum_works:
+  fixes N :: "nat set"
+  assumes "infinite N"
+  shows "N = range (enum N) \<and> strict_mono (enum N)"
+  by (metis assms bij_betw_imp_surj_on bij_enumerate enumerate_mono strict_monoI)
+
+lemma range_enum: "range (enum N) = N" and strict_mono_enum: "strict_mono (enum N)"
+  if "infinite N" for N :: "nat set"
+  using enum_works [OF that] by auto
+
+lemma enum_0_eq_Inf:
+  fixes N :: "nat set"
+  assumes "infinite N"
+  shows "enum N 0 = Inf N"
+proof -
+  have "enum N 0 \<in> N"
+    using assms range_enum by auto
+  moreover have "\<And>x. x \<in> N \<Longrightarrow> enum N 0 \<le> x"
+    by (metis (mono_tags, hide_lams) assms imageE le0 less_mono_imp_le_mono range_enum strict_monoD strict_mono_enum)
+  ultimately show ?thesis
+    by (metis cInf_eq_minimum)
+qed
+
+lemma enum_works_finite:
+  fixes N :: "nat set"
+  assumes "finite N"
+  shows "N = enum N ` {..<card N} \<and> strict_mono_on (enum N) {..<card N}"
+  using assms
+  by (metis bij_betw_imp_surj_on finite_bij_enumerate finite_enumerate_mono lessThan_iff strict_mono_onI)
+
+lemma enum_obtain_index_finite:
+  fixes N :: "nat set"
+  assumes "x \<in> N" "finite N" 
+  obtains i where "i < card N" "x = enum N i"
+  by (metis \<open>x \<in> N\<close> \<open>finite N\<close> enum_works_finite imageE lessThan_iff)
+
+lemma enum_0_eq_Inf_finite:
+  fixes N :: "nat set"
+  assumes "finite N" "N \<noteq> {}"
+  shows "enum N 0 = Inf N"
+proof -
+  have "enum N 0 \<in> N"
+    by (metis Nat.neq0_conv assms empty_is_image enum_works_finite image_eqI lessThan_empty_iff lessThan_iff)
+  moreover have "enum N 0 \<le> x" if "x \<in> N" for x
+  proof -
+    obtain i where "i < card N" "x = enum N i"
+      by (metis \<open>x \<in> N\<close> \<open>finite N\<close> enum_obtain_index_finite)
+    with assms show ?thesis
+      by (metis Nat.neq0_conv finite_enumerate_mono less_or_eq_imp_le)
+  qed
+  ultimately show ?thesis
+    by (metis cInf_eq_minimum)
+qed
+
+lemma greaterThan_less_enum:
+  fixes N :: "nat set"
+  assumes "N \<subseteq> {x<..}" "infinite N"
+  shows "x < enum N i"
+  using assms range_enum by fastforce
+
+lemma atLeast_le_enum:
+  fixes N :: "nat set"
+  assumes "N \<subseteq> {x..}" "infinite N"
+  shows "x \<le> enum N i"
+  using assms range_enum by fastforce
+
+lemma less_sets_empty1 [simp]: "less_sets {} A" and less_sets_empty2 [simp]: "less_sets A {}"
+  by (simp_all add: less_sets_def)
+
+lemma less_sets_singleton1 [simp]: "less_sets {a} A \<longleftrightarrow> (\<forall>x\<in>A. a < x)" 
+  and less_sets_singleton2 [simp]: "less_sets A {a} \<longleftrightarrow> (\<forall>x\<in>A. x < a)"
+  by (simp_all add: less_sets_def)
+
+lemma less_sets_atMost [simp]: "less_sets {..a} A \<longleftrightarrow> (\<forall>x\<in>A. a < x)" 
+  and less_sets_alLeast [simp]: "less_sets A {a..} \<longleftrightarrow> (\<forall>x\<in>A. x < a)"
+  by (auto simp: less_sets_def)
+
+lemma less_sets_imp_strict_mono_sets:
+  assumes "\<And>i. less_sets (A i) (A (Suc i))" "\<And>i. i>0 \<Longrightarrow> A i \<noteq> {}"
+  shows "strict_mono_sets UNIV A"
+proof (clarsimp simp: strict_mono_sets_def)
+  fix i j::nat
+  assume "i < j"
+  then show "less_sets (A i) (A j)"
+  proof (induction "j-i" arbitrary: i j)
+    case (Suc x)
+    then show ?case
+      by (metis Suc_diff_Suc Suc_inject Suc_mono assms less_Suc_eq less_sets_trans zero_less_Suc)
+  qed auto
+qed
+
+lemma less_sets_Suc_Max:  
+  assumes "finite A"
+  shows "less_sets A {Suc (Max A)..}"
+proof (cases "A = {}")
+  case False
+  then show ?thesis
+    by (simp add: assms less_Suc_eq_le)
+qed auto
+
+lemma infinite_nat_greaterThan:
+  fixes m::nat
+  assumes "infinite N"
+  shows "infinite (N \<inter> {m<..})"
+proof -
+  have "N \<subseteq> -{m<..} \<union> (N \<inter> {m<..})"
+    by blast
+  moreover have "finite (-{m<..})"
+    by simp
+  ultimately show ?thesis
+    using assms finite_subset by blast
+qed
+
+end
+
+    
+
diff --git a/thys/Ordinal_Partitions/Omega_Omega.thy b/thys/Ordinal_Partitions/Omega_Omega.thy
new file mode 100644
--- /dev/null
+++ b/thys/Ordinal_Partitions/Omega_Omega.thy
@@ -0,0 +1,4670 @@
+section \<open>An ordinal partition theorem by Jean A. Larson\<close>
+
+text \<open>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>
+
+theory Omega_Omega
+  imports "HOL-Library.Product_Lexorder" Erdos_Milner
+
+begin
+
+abbreviation "list_of \<equiv> sorted_list_of_set"
+
+subsection \<open>Cantor normal form for ordinals below @{term "\<omega>\<up>\<omega>"}\<close>
+
+text \<open>Unlike @{term Cantor_sum}, there is no list of ordinal exponents,
+which are instead taken as consecutive. We obtain an order-isomorphism between @{term "\<omega>\<up>\<omega>"}
+and increasing lists of natural numbers (ordered lexicographically).\<close>
+
+fun omega_sum_aux  where
+  Nil: "omega_sum_aux 0 _ = 0"
+| Suc: "omega_sum_aux (Suc n) [] = 0"
+| Cons: "omega_sum_aux (Suc n) (m#ms) = (\<omega>\<up>n) * (ord_of_nat m) + omega_sum_aux n ms"
+
+abbreviation omega_sum where "omega_sum ms \<equiv> omega_sum_aux (length ms) ms"
+
+text \<open>A normal expansion has no leading zeroes\<close>
+primrec normal:: "nat list \<Rightarrow> bool" where
+  normal_0: "normal [] = True"
+| normal_Suc: "normal (m#ms) = (m > 0)"
+
+lemma omega_sum_0_iff [simp]: "normal ns \<Longrightarrow> omega_sum ns = 0 \<longleftrightarrow> ns = []"
+  by (induction ns) auto
+
+lemma Ord_omega_sum_aux [simp]: "Ord (omega_sum_aux k ms)"
+  by (induction rule: omega_sum_aux.induct) auto
+
+lemma Ord_omega_sum: "Ord (omega_sum ms)"
+  by simp
+
+lemma omega_sum_less_\<omega>\<omega> [intro]: "omega_sum ms < \<omega>\<up>\<omega>"
+proof (induction ms)
+  case Nil
+  then show ?case
+    by (auto simp: zero_less_Limit)
+next
+  case (Cons m ms)
+  have "\<omega> \<up> (length ms) * ord_of_nat m \<in> elts (\<omega> \<up> Suc (length ms))"
+    using Ord_mem_iff_lt by auto
+  then have "\<omega>\<up>(length ms) * ord_of_nat m \<in> elts (\<omega>\<up>\<omega>)"
+    using Ord_ord_of_nat oexp_mono_le omega_nonzero ord_of_nat_le_omega by blast
+  with Cons show ?case
+    by (auto simp: mult_succ OrdmemD oexp_less indecomposableD indecomposable_\<omega>_power)
+qed
+
+lemma omega_sum_aux_less: "omega_sum_aux k ms < \<omega> \<up> k"
+proof (induction rule: omega_sum_aux.induct)
+  case (3 n m ms)
+  have " \<omega>\<up>n * ord_of_nat m + \<omega>\<up>n < \<omega>\<up>n * \<omega>"
+    by (metis Ord_ord_of_nat \<omega>_power_succ_gtr mult_succ oexp_succ ord_of_nat.simps(2))
+  with 3 show ?case
+    using dual_order.strict_trans by force
+qed auto
+
+lemma omega_sum_less: "omega_sum ms < \<omega> \<up> (length ms)"
+  by (rule omega_sum_aux_less)
+
+lemma omega_sum_ge: "m \<noteq> 0 \<Longrightarrow> \<omega> \<up> (length ms) \<le> omega_sum (m#ms)"
+  apply clarsimp
+  by (metis Ord_ord_of_nat add_le_cancel_left0 le_mult Nat.neq0_conv ord_of_eq_0_iff vsubsetD)
+
+lemma omega_sum_length_less:
+  assumes "length ms < length ns" "normal ns"
+  shows "omega_sum ms < omega_sum ns"
+proof (cases ns)
+  case Nil
+  then show ?thesis
+    using assms by auto
+next
+  case (Cons n ns')
+  have "\<omega> \<up> length ms \<le> \<omega> \<up> length ns'"
+    using assms local.Cons by (simp add: oexp_mono_le)
+  then have "\<not> omega_sum (n#ns') \<le> omega_sum ms"
+    using omega_sum_ge [of n ns'] omega_sum_less [of ms] \<open>normal ns\<close> local.Cons by auto
+  then show ?thesis
+    by (metis Ord_linear2 Ord_omega_sum local.Cons)
+qed
+
+lemma omega_sum_length_leD:
+  assumes "omega_sum ms \<le> omega_sum ns" "normal ms"
+  shows "length ms \<le> length ns"
+  by (meson assms leD leI omega_sum_length_less)
+
+
+lemma omega_sum_less_eqlen_iff_cases [simp]:
+  assumes "length ms = length ns"
+   shows "omega_sum (m#ms) < omega_sum (n#ns)
+          \<longleftrightarrow> m<n \<or> m=n \<and> omega_sum ms < omega_sum ns"
+  (is "?lhs = ?rhs")
+proof
+  assume L: ?lhs
+  have "\<not> Suc n < Suc m"
+    using omega_sum_less [of ms] omega_sum_less [of ns] L assms mult_nat_less_add_less by fastforce
+  then have "m\<le>n"
+    by auto
+  with L assms show ?rhs
+    by auto
+next
+  assume ?rhs
+  then show ?lhs
+    by (auto simp: mult_nat_less_add_less omega_sum_aux_less assms)
+qed
+
+lemma omega_sum_lex_less_iff_cases:
+   "((length ms, omega_sum (m#ms)), (length ns, omega_sum (n#ns))) \<in> less_than <*lex*> VWF
+   \<longleftrightarrow> length ms < length ns
+            \<or> length ms = length ns \<and> m<n
+            \<or> m=n \<and> ((length ms, omega_sum ms), (length ns, omega_sum ns)) \<in> less_than <*lex*> VWF"
+  using omega_sum_less_eqlen_iff_cases by force
+
+lemma omega_sum_less_iff_cases:
+  assumes "m > 0" "n > 0"
+  shows "omega_sum (m#ms) < omega_sum (n#ns)
+          \<longleftrightarrow> length ms < length ns
+            \<or> length ms = length ns \<and> m<n
+            \<or> length ms = length ns \<and> m=n \<and> omega_sum ms < omega_sum ns"
+    (is "?lhs = ?rhs")
+proof
+  assume L: ?lhs
+  then have "length ms \<le> length ns"
+    using omega_sum_length_leD [OF less_imp_le [OF L]] by (simp add: \<open>m > 0\<close>)
+  moreover have "m\<le>n" if "length ms = length ns"
+    using L omega_sum_less_eqlen_iff_cases that by auto
+  ultimately show ?rhs
+    using L by auto
+next
+  assume ?rhs
+  moreover
+  have "omega_sum (m # ms) < omega_sum (n # ns)"
+    if "length ms < length ns"
+    using that by (metis Suc_mono \<open>n > 0\<close> length_Cons normal_Suc omega_sum_length_less)
+  ultimately show ?lhs
+    using omega_sum_less_eqlen_iff_cases by force
+qed
+
+lemma omega_sum_less_iff:
+  "((length ms, omega_sum ms), (length ns, omega_sum ns)) \<in> less_than <*lex*> VWF
+   \<longleftrightarrow> (ms,ns) \<in> lenlex less_than"
+proof (induction ms arbitrary: ns)
+  case Nil
+  then show ?case
+    by auto
+next
+  case (Cons m ms)
+  then show ?case
+  proof (induction ns)
+    case (Cons n ns')
+    show ?case
+      using omega_sum_lex_less_iff_cases [of ms m ns' n] Cons.prems
+      by (simp add: Cons_lenlex_iff lenlex_length order.not_eq_order_implies_strict nat_less_le)
+  qed auto
+qed
+
+lemma eq_omega_sum_less_iff:
+  assumes "length ms = length ns"
+  shows "(omega_sum ms, omega_sum ns) \<in> VWF \<longleftrightarrow> (ms,ns) \<in> lenlex less_than"
+  by (metis assms in_lex_prod less_not_refl less_than_iff omega_sum_less_iff)
+
+lemma eq_omega_sum_eq_iff:
+  assumes "length ms = length ns"
+  shows "omega_sum ms = omega_sum ns \<longleftrightarrow> ms=ns"
+proof
+  assume "omega_sum ms = omega_sum ns"
+  then have "(omega_sum ms, omega_sum ns) \<notin> VWF" "(omega_sum ns, omega_sum ms) \<notin> VWF"
+    by auto
+  then obtain "(ms,ns) \<notin> lenlex less_than" "(ns,ms) \<notin> lenlex less_than"
+    using assms eq_omega_sum_less_iff by metis
+  moreover have "total (lenlex less_than)"
+    by (simp add: total_lenlex total_less_than)
+  ultimately show "ms=ns"
+    by (meson UNIV_I total_on_def)
+qed auto
+
+lemma inj_omega_sum: "inj_on omega_sum {l. length l = n}"
+  unfolding inj_on_def using eq_omega_sum_eq_iff by fastforce
+
+lemma Ex_omega_sum: "\<gamma> \<in> elts (\<omega>\<up>n) \<Longrightarrow> \<exists>ns. \<gamma> = omega_sum ns \<and> length ns = n"
+proof (induction n arbitrary: \<gamma>)
+  case 0
+  then show ?case
+    by (rule_tac x="[]" in exI) auto
+next
+  case (Suc n)
+  then obtain k::nat where k: "\<gamma> \<in> elts (\<omega> \<up> n * k)"
+       and kmin: "\<And>k'. k'<k \<Longrightarrow> \<gamma> \<notin> elts (\<omega> \<up> n * k')"
+    by (metis Ord_ord_of_nat elts_mult_\<omega>E oexp_succ ord_of_nat.simps(2))
+  show ?case
+  proof (cases k)
+    case (Suc k')
+    then obtain \<delta> where \<delta>: "\<gamma> = (\<omega> \<up> n * k') + \<delta>"
+      by (metis lessI mult_succ ord_of_nat.simps(2) k kmin mem_plus_V_E)
+    then have \<delta>in: "\<delta> \<in> elts (\<omega> \<up> n)"
+      using Suc k mult_succ by auto
+    then obtain ns where ns: "\<delta> = omega_sum ns" and len: "length ns = n"
+      using Suc.IH by auto
+    moreover have "omega_sum ns < \<omega>\<up>n"
+      using OrdmemD ns \<delta>in by auto
+    ultimately show ?thesis
+      by (rule_tac x="k'#ns" in exI) (simp add: \<delta>)
+  qed (use k in auto)
+qed
+
+lemma omega_sum_drop [simp]: "omega_sum (dropWhile (\<lambda>n. n=0) ns) = omega_sum ns"
+  by (induction ns) auto
+
+lemma normal_drop [simp]: "normal (dropWhile (\<lambda>n. n=0) ns)"
+  by (induction ns) auto
+
+lemma omega_sum_\<omega>\<omega>:
+  assumes "\<gamma> \<in> elts (\<omega>\<up>\<omega>)"
+  obtains ns where "\<gamma> = omega_sum ns" "normal ns"
+proof -
+  obtain ms where "\<gamma> = omega_sum ms"
+    using assms Ex_omega_sum by (auto simp: oexp_Limit elts_\<omega>)
+  show thesis
+  proof
+    show "\<gamma> = omega_sum (dropWhile (\<lambda>n. n=0) ms)"
+      by (simp add: \<open>\<gamma> = omega_sum ms\<close>)
+    show "normal (dropWhile (\<lambda>n. n=0) ms)"
+      by auto
+  qed
+qed
+
+definition Cantor_\<omega>\<omega> :: "V \<Rightarrow> nat list"
+  where "Cantor_\<omega>\<omega> \<equiv> \<lambda>x. @ns. x = omega_sum ns \<and> normal ns"
+
+lemma
+  assumes "\<gamma> \<in> elts (\<omega>\<up>\<omega>)"
+  shows Cantor_\<omega>\<omega>: "omega_sum (Cantor_\<omega>\<omega> \<gamma>) = \<gamma>"
+    and normal_Cantor_\<omega>\<omega>: "normal (Cantor_\<omega>\<omega> \<gamma>)"
+  by (metis (mono_tags, lifting) Cantor_\<omega>\<omega>_def assms omega_sum_\<omega>\<omega> someI)+
+
+
+subsection \<open>Larson's set $W(n)$\<close>
+
+definition WW :: "nat list set"
+  where "WW \<equiv> {l. strict_sorted l}"
+
+fun into_WW :: "nat \<Rightarrow> nat list \<Rightarrow> nat list" where
+  "into_WW k [] = []"
+| "into_WW k (n#ns) = (k+n) # into_WW (Suc (k+n)) ns"
+
+fun from_WW :: "nat \<Rightarrow> nat list \<Rightarrow> nat list" where
+  "from_WW k [] = []"
+| "from_WW k (n#ns) = (n - k) # from_WW (Suc n) ns"
+
+lemma from_into_WW [simp]: "from_WW k (into_WW k ns) = ns"
+  by (induction ns arbitrary: k) auto
+
+lemma inj_into_WW: "inj (into_WW k)"
+  by (metis from_into_WW injI)
+
+lemma into_from_WW_aux:
+  "\<lbrakk>strict_sorted ns; \<forall>n\<in>list.set ns. k \<le> n\<rbrakk> \<Longrightarrow> into_WW k (from_WW k ns) = ns"
+  by (induction ns arbitrary: k) (auto simp: Suc_leI)
+
+lemma into_from_WW [simp]: "strict_sorted ns \<Longrightarrow> into_WW 0 (from_WW 0 ns) = ns"
+  by (simp add: into_from_WW_aux)
+
+lemma into_WW_imp_ge: "y \<in> List.set (into_WW x ns) \<Longrightarrow> x \<le> y"
+  by (induction ns arbitrary: x) fastforce+
+
+lemma strict_sorted_into_WW: "strict_sorted (into_WW x ns)"
+  by (induction ns arbitrary: x) (auto simp: dest: into_WW_imp_ge)
+
+lemma length_into_WW: "length (into_WW x ns) = length ns"
+  by (induction ns arbitrary: x) auto
+
+lemma WW_eq_range_into: "WW = range (into_WW 0)"
+  by (metis (mono_tags, hide_lams) WW_def equalityI image_subset_iff into_from_WW mem_Collect_eq rangeI strict_sorted_into_WW subset_iff)
+
+lemma into_WW_lenlex_iff: "(into_WW k ms, into_WW k ns) \<in> lenlex less_than \<longleftrightarrow> (ms, ns) \<in> lenlex less_than"
+proof (induction ms arbitrary: ns k)
+  case Nil
+  then show ?case
+    by simp (metis length_0_conv length_into_WW)
+next
+  case (Cons m ms)
+  then show ?case
+    by (induction ns) (auto simp: Cons_lenlex_iff length_into_WW)
+qed
+
+lemma wf_llt [simp]: "wf (lenlex less_than)"
+  by blast
+
+lemma trans_llt [simp]: "trans (lenlex less_than)"
+  by blast
+
+lemma total_llt [simp]: "total_on A (lenlex less_than)"
+  by (meson UNIV_I total_lenlex total_less_than total_on_def)
+
+lemma omega_sum_1_less:
+  assumes "(ms,ns) \<in> lenlex less_than" shows "omega_sum (1#ms) < omega_sum (1#ns)"
+proof -
+  have "omega_sum (1#ms) < omega_sum (1#ns)" if "length ms < length ns"
+    using omega_sum_less_iff_cases that zero_less_one by blast
+  then show ?thesis
+    using assms by (auto simp: mult_succ simp flip: omega_sum_less_iff)
+qed
+
+lemma ordertype_WW_1: "ordertype WW (lenlex less_than) \<le> ordertype UNIV (lenlex less_than)"
+  by (rule ordertype_mono) auto
+
+lemma ordertype_WW_2: "ordertype UNIV (lenlex less_than) \<le> \<omega>\<up>\<omega>"
+proof (rule ordertype_inc_le_Ord)
+  show "range (\<lambda>ms. omega_sum (1#ms)) \<subseteq> elts (\<omega>\<up>\<omega>)"
+    by (meson Ord_\<omega> Ord_mem_iff_lt Ord_oexp Ord_omega_sum image_subset_iff omega_sum_less_\<omega>\<omega>)
+qed (use omega_sum_1_less in auto)
+
+lemma ordertype_WW_3: "\<omega>\<up>\<omega> \<le> ordertype WW (lenlex less_than)"
+proof -
+  define \<pi> where "\<pi> \<equiv> into_WW 0 \<circ> Cantor_\<omega>\<omega>"
+  have \<omega>\<omega>: "\<omega>\<up>\<omega> = tp (elts (\<omega>\<up>\<omega>))"
+    by simp
+  also have "\<dots> \<le> ordertype WW (lenlex less_than)"
+  proof (rule ordertype_inc_le)
+    fix \<alpha> \<beta>
+    assume \<alpha>: "\<alpha> \<in> elts (\<omega>\<up>\<omega>)" and \<beta>: "\<beta> \<in> elts (\<omega>\<up>\<omega>)" and "(\<alpha>, \<beta>) \<in> VWF"
+    then obtain *: "Ord \<alpha>" "Ord \<beta>" "\<alpha><\<beta>"
+      by (metis Ord_in_Ord Ord_ordertype VWF_iff_Ord_less \<omega>\<omega>)
+    then have "length (Cantor_\<omega>\<omega> \<alpha>) \<le> length (Cantor_\<omega>\<omega> \<beta>)"
+      using \<alpha> \<beta> by (simp add: Cantor_\<omega>\<omega> normal_Cantor_\<omega>\<omega> omega_sum_length_leD)
+    with \<alpha> \<beta> * have "(Cantor_\<omega>\<omega> \<alpha>, Cantor_\<omega>\<omega> \<beta>) \<in> lenlex less_than"
+      by (auto simp: Cantor_\<omega>\<omega> simp flip: omega_sum_less_iff)
+    then show "(\<pi> \<alpha>, \<pi> \<beta>) \<in> lenlex less_than"
+      by (simp add: \<pi>_def into_WW_lenlex_iff)
+  next
+    show "\<pi> ` elts (\<omega>\<up>\<omega>) \<subseteq> WW"
+      by (auto simp: \<pi>_def WW_def strict_sorted_into_WW)
+  qed auto
+  finally show "\<omega>\<up>\<omega> \<le> ordertype WW (lenlex less_than)" .
+qed
+
+lemma ordertype_WW: "ordertype WW (lenlex less_than) = \<omega>\<up>\<omega>"
+  and ordertype_UNIV_\<omega>\<omega>: "ordertype UNIV (lenlex less_than) = \<omega>\<up>\<omega>"
+  using ordertype_WW_1 ordertype_WW_2 ordertype_WW_3 by auto
+
+
+lemma ordertype_\<omega>\<omega>:
+  fixes F :: "nat \<Rightarrow> nat list set"
+  assumes "\<And>j::nat. ordertype (F j) (lenlex less_than) = \<omega>\<up>j"
+  shows "ordertype (\<Union>j. F j) (lenlex less_than) = \<omega>\<up>\<omega>"
+proof (rule antisym)
+  show "ordertype (\<Union> (range F)) (lenlex less_than) \<le> \<omega> \<up> \<omega>"
+    by (metis ordertype_UNIV_\<omega>\<omega> ordertype_mono small top_greatest trans_llt wf_llt)
+  have "\<And>n. \<omega> \<up> ord_of_nat n \<le> ordertype (\<Union> (range F)) (lenlex less_than)"
+    by (metis TC_small Union_upper assms ordertype_mono rangeI trans_llt wf_llt)
+  then show "\<omega> \<up> \<omega> \<le> ordertype (\<Union> (range F)) (lenlex less_than)"
+    by (auto simp: oexp_\<omega>_Limit ZFC_in_HOL.SUP_le_iff elts_\<omega>)
+qed
+
+
+
+definition WW_seg :: "nat \<Rightarrow> nat list set"
+  where "WW_seg n \<equiv> {l \<in> WW. length l = n}"
+
+lemma WW_seg_subset_WW: "WW_seg n \<subseteq> WW"
+  by (auto simp: WW_seg_def)
+
+lemma WW_eq_UN_WW_seg: "WW = (\<Union> n. WW_seg n)"
+  by (auto simp: WW_seg_def)
+
+lemma ordertype_list_seg: "ordertype {l. length l = n} (lenlex less_than) = \<omega>\<up>n"
+proof -
+  have "bij_betw omega_sum {l. length l = n} (elts (\<omega>\<up>n))"
+    unfolding WW_seg_def bij_betw_def
+    by (auto simp: inj_omega_sum Ord_mem_iff_lt omega_sum_less dest: Ex_omega_sum)
+  then show ?thesis
+    by (force simp: ordertype_eq_iff simp flip: eq_omega_sum_less_iff)
+qed
+
+lemma ordertype_WW_seg: "ordertype (WW_seg n) (lenlex less_than) = \<omega>\<up>n"
+  (is "ordertype ?W ?R = \<omega>\<up>n")
+proof -
+  have "ordertype {l. length l = n} ?R = ordertype ?W ?R"
+  proof (subst ordertype_eq_ordertype)
+    show "\<exists>f. bij_betw f {l. length l = n} ?W \<and> (\<forall>x\<in>{l. length l = n}. \<forall>y\<in>{l. length l = n}. ((f x, f y) \<in> lenlex less_than) = ((x, y) \<in> lenlex less_than))"
+    proof (intro exI conjI)
+      have "inj_on (into_WW 0) {l. length l = n}"
+        by (metis from_into_WW inj_onI)
+      then show "bij_betw (into_WW 0) {l. length l = n} ?W"
+        by (auto simp: bij_betw_def WW_seg_def WW_eq_range_into length_into_WW)
+    qed (simp add: into_WW_lenlex_iff)
+  qed auto
+  then show ?thesis
+    using ordertype_list_seg by auto
+qed
+
+
+subsection \<open>Definitions required for the lemmas\<close>
+
+subsubsection \<open>Larson's "$<$"-relation on ordered lists\<close>
+
+instantiation list :: (ord)ord
+begin
+
+definition "xs < ys \<equiv> xs \<noteq> [] \<and> ys \<noteq> [] \<longrightarrow> last xs < hd ys" for xs ys :: "'a list"
+definition "xs \<le> ys \<equiv> xs < ys \<or> xs = ys" for xs ys :: "'a list"
+
+instance
+  by standard
+
+end
+
+lemma less_Nil [simp]: "xs < []" "[] < xs"
+  by (auto simp: less_list_def)
+
+lemma less_sets_imp_list_less:
+  assumes "less_sets (list.set xs) (list.set ys)"
+  shows "xs < ys"
+  by (metis assms last_in_set less_list_def less_sets_def list.set_sel(1))
+
+lemma less_sets_imp_sorted_list_of_set:
+  assumes "less_sets A B" "finite A" "finite B"
+  shows "list_of A < list_of B"
+  by (simp add: assms less_sets_imp_list_less)
+
+lemma sorted_list_of_set_imp_less_sets:
+  assumes "xs < ys" "sorted xs" "sorted ys"
+  shows "less_sets (list.set xs) (list.set ys)"
+  using assms sorted_hd_le sorted_le_last
+  by (force simp: less_list_def less_sets_def intro: order.trans)
+
+lemma less_list_iff_less_sets:
+  assumes "sorted xs" "sorted ys"
+  shows "xs < ys \<longleftrightarrow> less_sets (list.set xs) (list.set ys)"
+  using assms sorted_hd_le sorted_le_last
+  by (force simp: less_list_def less_sets_def intro: order.trans)
+
+lemma sorted_trans:
+  assumes "xs < ys" "ys < zs" "sorted ys" "ys \<noteq> []" shows "xs < zs"
+  using assms unfolding less_list_def
+  by (metis dual_order.strict_trans last_in_set leD neqE sorted_hd_le)
+
+lemma strict_sorted_imp_append_less:
+  assumes "strict_sorted (xs @ ys)"
+  shows "xs < ys"
+  using assms by (simp add: less_list_def sorted_wrt_append strict_sorted_sorted_wrt)
+
+lemma strict_sorted_append_iff:
+  "strict_sorted (xs @ ys) \<longleftrightarrow> xs < ys \<and> strict_sorted xs \<and> strict_sorted ys" (is "?lhs = ?rhs")
+proof
+  assume ?lhs then show ?rhs
+    by (auto simp: sorted_wrt_append strict_sorted_sorted_wrt less_list_def)
+next
+  assume R: ?rhs
+  then have "\<And>x y. \<lbrakk>x \<in> list.set xs; y \<in> list.set ys\<rbrakk> \<Longrightarrow> x < y"
+    using less_setsD sorted_list_of_set_imp_less_sets strict_sorted_imp_sorted by blast
+  with R show ?lhs
+    by (auto simp: sorted_wrt_append strict_sorted_sorted_wrt)
+qed
+
+lemma singleton_less_list_iff: "sorted xs \<Longrightarrow> [n] < xs \<longleftrightarrow> {..n} \<inter> list.set xs = {}"
+  apply (simp add: less_list_def set_eq_iff)
+  by (metis empty_iff less_le_trans list.set(1) list.set_sel(1) not_le sorted_hd_le)
+
+lemma less_last_iff: "xs@[x] < ys \<longleftrightarrow> [x] < ys"
+  by (simp add: less_list_def)
+
+lemma less_Cons_iff: "NO_MATCH [] ys \<Longrightarrow> xs < y#ys \<longleftrightarrow> xs < [y]"
+  by (simp add: less_list_def)
+
+lemma less_hd_imp_less: "xs < [hd ys] \<Longrightarrow> xs < ys"
+  by (simp add: less_list_def)
+
+lemma last_less_imp_less: "[last xs] < ys \<Longrightarrow> xs < ys"
+  by (simp add: less_list_def)
+
+lemma strict_sorted_concat_I:
+  assumes
+    "\<And>x. x \<in> list.set xs \<Longrightarrow> strict_sorted x"
+    "\<And>n. Suc n < length xs \<Longrightarrow> xs!n < xs!Suc n"
+  assumes "xs \<in> lists (- {[]})"
+  shows "strict_sorted (concat xs)"
+  using assms
+proof (induction xs)
+  case (Cons x xs)
+  then have "x < concat xs"
+    apply (simp add: less_list_def)
+    by (metis Compl_iff hd_concat insertI1 length_greater_0_conv length_pos_if_in_set list.sel(1) lists.cases nth_Cons_0)
+  with Cons show ?case
+    by (force simp: strict_sorted_append_iff)
+qed auto
+
+
+subsection \<open>Nash Williams for lists\<close>
+
+subsubsection \<open>Thin sets of lists\<close>
+
+inductive initial_segment :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
+  where "initial_segment xs (xs@ys)"
+
+definition thin where "thin A \<equiv> \<not> (\<exists>x y. x \<in> A \<and> y \<in> A \<and> x \<noteq> y \<and> initial_segment x y)"
+
+lemma initial_segment_ne:
+  assumes "initial_segment xs ys" "xs \<noteq> []"
+  shows "ys \<noteq> [] \<and> hd ys = hd xs"
+  using assms by (auto elim!: initial_segment.cases)
+
+lemma take_initial_segment:
+  assumes "initial_segment xs ys" "k \<le> length xs"
+  shows "take k xs = take k ys"
+  by (metis append_eq_conv_conj assms initial_segment.cases min_def take_take)
+
+lemma initial_segment_length_eq:
+  assumes "initial_segment xs ys" "length xs = length ys"
+  shows "xs = ys"
+  using assms initial_segment.cases by fastforce
+
+lemma initial_segment_Nil [simp]: "initial_segment [] ys"
+  by (simp add: initial_segment.simps)
+
+lemma initial_segment_Cons [simp]: "initial_segment (x#xs) (y#ys) \<longleftrightarrow> x=y \<and> initial_segment xs ys"
+  by (metis append_Cons initial_segment.simps list.inject)
+
+lemma init_segment_iff_initial_segment:
+  assumes "strict_sorted xs" "strict_sorted ys"
+  shows "init_segment (list.set xs) (list.set ys) \<longleftrightarrow> initial_segment xs ys" (is "?lhs = ?rhs")
+proof
+  assume ?lhs
+  then obtain S' where S': "list.set ys = list.set xs \<union> S'" "less_sets (list.set xs) S'"
+    by (auto simp: init_segment_def)
+  then have "finite S'"
+    by (metis List.finite_set finite_Un)
+  have "ys = xs @ list_of S'"
+    using S' \<open>strict_sorted xs\<close>
+  proof (induction xs)
+    case Nil
+    with \<open>strict_sorted ys\<close> show ?case
+      by auto
+  next
+    case (Cons a xs)
+    with \<open>finite S'\<close> have "ys = a # xs @ list_of S'"
+      by (metis List.finite_set \<open>finite S'\<close> append_Cons assms(2) sorted_list_of_set_Un sorted_list_of_set_set_of)
+    then show ?case
+      by (auto simp: Cons)
+  qed
+  then show ?rhs
+    using initial_segment.intros by blast
+next
+  assume ?rhs
+  then show ?lhs
+  proof cases
+    case (1 ys)
+    with assms(2) show ?thesis
+      using sorted_list_of_set_imp_less_sets strict_sorted_imp_sorted
+      by (auto simp: init_segment_def strict_sorted_append_iff)
+  qed
+qed
+
+theorem Nash_Williams_WW:
+  fixes h :: "nat list \<Rightarrow> nat"
+  assumes "infinite M" and h: "h ` {l \<in> A. List.set l \<subseteq> M} \<subseteq> {..<2}" and "thin A" "A \<subseteq> WW"
+  obtains i N where "i < 2" "infinite N" "N \<subseteq> M" "h ` {l \<in> A. List.set l \<subseteq> N} \<subseteq> {i}"
+proof -
+  define AM where "AM \<equiv> {l \<in> A. List.set l \<subseteq> M}"
+  have "thin_set (list.set ` A)"
+    using \<open>thin A\<close> \<open>A \<subseteq> WW\<close> unfolding thin_def thin_set_def WW_def
+    by (auto simp: subset_iff init_segment_iff_initial_segment)
+  then have "thin_set (list.set ` AM)"
+    by (simp add: AM_def image_subset_iff thin_set_def)
+  then have "Ramsey (list.set ` AM) 2"
+    using Nash_Williams_2 by metis
+  moreover have "(h \<circ> list_of) ` list.set ` AM \<subseteq> {..<2}"
+    unfolding AM_def
+  proof clarsimp
+    fix l
+    assume "l \<in> A" "list.set l \<subseteq> M"
+    then have "strict_sorted l"
+      using WW_def \<open>A \<subseteq> WW\<close> by blast
+    then show "h (list_of (list.set l)) < 2"
+      using h \<open>l \<in> A\<close> \<open>list.set l \<subseteq> M\<close> by auto
+  qed
+  ultimately obtain N i where N: "N \<subseteq> M" "infinite N" "i<2"
+    and "\<And>j. \<lbrakk>j<2; i\<noteq>j\<rbrakk> \<Longrightarrow> (h \<circ> list_of) -` {j} \<inter> (list.set ` AM) \<inter> Pow N = {}"
+    unfolding Ramsey_def by (metis \<open>infinite M\<close>)
+  then have N_disjoint: "(h \<circ> list_of) -` {1-i} \<inter> (list.set ` AM) \<inter> Pow N = {}"
+    by (metis One_nat_def diff_less_Suc not_less_eq numeral_2_eq_2 zero_less_diff)
+  have "h ` {l \<in> A. list.set l \<subseteq> N} \<subseteq> {i}"
+  proof clarify
+    fix l
+    assume "l \<in> A" and "list.set l \<subseteq> N"
+    then have "h l < 2"
+      using h \<open>N \<subseteq> M\<close> by force
+    with \<open>i<2\<close> have "h l \<noteq> Suc 0 - i \<Longrightarrow> h l = i"
+      by (auto simp: eval_nat_numeral less_Suc_eq)
+    moreover have "strict_sorted l"
+      using \<open>A \<subseteq> WW\<close> \<open>l \<in> A\<close> unfolding WW_def by blast
+    moreover have "h (list_of (list.set l)) = 1 - i \<longrightarrow> \<not> (list.set l \<subseteq> N)"
+      using N_disjoint \<open>N \<subseteq> M\<close> \<open>l \<in> A\<close> by (auto simp: AM_def)
+    ultimately
+    show "h l = i"
+      using N \<open>N \<subseteq> M\<close> \<open>l \<in> A\<close> \<open>list.set l \<subseteq> N\<close>
+      by (auto simp: vimage_def set_eq_iff AM_def WW_def subset_iff)
+  qed
+  then show thesis
+    using that \<open>i<2\<close> N by auto
+qed
+
+subsection \<open>Specialised functions on lists\<close>
+
+lemma mem_lists_non_Nil: "xss \<in> lists (- {[]}) \<longleftrightarrow> (\<forall>x \<in> list.set xss. x \<noteq> [])"
+  by auto
+
+fun acc_lengths :: "nat \<Rightarrow> 'a list list \<Rightarrow> nat list"
+  where "acc_lengths acc [] = []"
+      | "acc_lengths acc (l#ls) = (acc + length l) # acc_lengths (acc + length l) ls"
+
+lemma length_acc_lengths [simp]: "length (acc_lengths acc ls) = length ls"
+  by (induction ls arbitrary: acc) auto
+
+lemma acc_lengths_eq_Nil_iff [simp]: "acc_lengths acc ls = [] \<longleftrightarrow> ls = []"
+  by (metis length_0_conv length_acc_lengths)
+
+lemma set_acc_lengths:
+  assumes "ls \<in> lists (- {[]})" shows "list.set (acc_lengths acc ls) \<subseteq> {acc<..}"
+  using assms by (induction ls rule: acc_lengths.induct) fastforce+
+
+lemma hd_acc_lengths [simp]: "hd (acc_lengths acc (l#ls)) = acc + length l"
+  by simp
+
+lemma last_acc_lengths [simp]:
+  "ls \<noteq> [] \<Longrightarrow> last (acc_lengths acc ls) = acc + sum_list (map length ls)"
+by (induction acc ls rule: acc_lengths.induct) auto
+
+lemma nth_acc_lengths [simp]:
+  "\<lbrakk>ls \<noteq> []; k < length ls\<rbrakk> \<Longrightarrow> acc_lengths acc ls ! k = acc + sum_list (map length (take (Suc k) ls))"
+  by (induction acc ls arbitrary: k rule: acc_lengths.induct) (fastforce simp: less_Suc_eq nth_Cons')+
+
+lemma acc_lengths_plus: "acc_lengths (m+n) as = map ((+)m) (acc_lengths n as)"
+  by (induction n as arbitrary: m rule: acc_lengths.induct) (auto simp: add.assoc)
+
+lemma acc_lengths_shift: "NO_MATCH 0 acc \<Longrightarrow> acc_lengths acc as = map ((+)acc) (acc_lengths 0 as)"
+  by (metis acc_lengths_plus add.comm_neutral)
+
+lemma length_concat_acc_lengths:
+  "ls \<noteq> [] \<Longrightarrow> k + length (concat ls) \<in> list.set (acc_lengths k ls)"
+  by (metis acc_lengths_eq_Nil_iff last_acc_lengths last_in_set length_concat)
+
+lemma strict_sorted_acc_lengths:
+  assumes "ls \<in> lists (- {[]})" shows "strict_sorted (acc_lengths acc ls)"
+  using assms
+proof (induction ls rule: acc_lengths.induct)
+  case (2 acc l ls)
+  then have "strict_sorted (acc_lengths (acc + length l) ls)"
+    using "2" by auto
+  then show ?case
+    using set_acc_lengths "2.prems" by auto
+qed auto
+
+lemma acc_lengths_append:
+  "acc_lengths acc (xs @ ys)
+   = acc_lengths acc xs @ acc_lengths (acc + sum_list (map length xs)) ys"
+by (induction acc xs rule: acc_lengths.induct) (auto simp: add.assoc)
+
+
+declare acc_lengths.simps [simp del]
+
+lemma length_concat_ge:
+  assumes "as \<in> lists (- {[]})"
+  shows "length (concat as) \<ge> length as"
+  using assms
+proof (induction as)
+  case (Cons a as)
+  then have "length a \<ge> Suc 0" "\<And>l. l \<in> list.set as \<Longrightarrow> length l \<ge> Suc 0"
+    by (auto simp: Suc_leI)
+  then show ?case
+    using Cons.IH by force
+qed auto
+
+
+fun interact :: "'a list list \<Rightarrow> 'a list list \<Rightarrow> 'a list"
+  where
+  "interact [] ys = concat ys"
+| "interact xs [] = concat xs"
+| "interact (x#xs) (y#ys) = x @ y @ interact xs ys"
+
+lemma (in monoid_add) length_interact:
+  "length (interact xs ys) = sum_list (map length xs) + sum_list (map length ys)"
+  by (induction rule: interact.induct) (auto simp: length_concat)
+
+lemma length_interact_ge:
+  assumes "xs \<in> lists (- {[]})" "ys \<in> lists (- {[]})"
+  shows "length (interact xs ys) \<ge> length xs + length ys"
+  by (metis mem_lists_non_Nil add_mono assms length_concat length_concat_ge length_interact)
+
+lemma set_interact [simp]:
+  shows "list.set (interact xs ys) = list.set (concat xs) \<union> list.set (concat ys)"
+by (induction rule: interact.induct) auto
+
+lemma interact_eq_Nil_iff [simp]:
+  assumes "xs \<in> lists (- {[]})" "ys \<in> lists (- {[]})"
+  shows "interact xs ys = [] \<longleftrightarrow> xs=[] \<and> ys=[]"
+  using length_interact_ge [OF assms]  by fastforce
+
+lemma interact_sing [simp]: "interact [x] ys = x @ concat ys"
+  by (metis (no_types) concat.simps(2) interact.simps neq_Nil_conv)
+
+lemma hd_interact: "\<lbrakk>xs \<noteq> []; hd xs \<noteq> []\<rbrakk> \<Longrightarrow> hd (interact xs ys) = hd (hd xs)"
+  by (metis concat.simps(2) hd_append2 interact.simps(2) interact.simps(3) list.exhaust list.sel(1))
+
+lemma acc_lengths_concat_injective:
+  assumes "concat as' = concat as" "acc_lengths n as' = acc_lengths n as"
+  shows "as' = as"
+  using assms
+proof (induction as arbitrary: n as')
+  case Nil
+  then show ?case
+    by (metis acc_lengths_eq_Nil_iff)
+next
+  case (Cons a as)
+  then obtain a' bs where "as' = a'#bs"
+    by (metis Suc_length_conv length_acc_lengths)
+  with Cons show ?case
+    by (simp add: acc_lengths.simps)
+qed
+
+lemma acc_lengths_interact_injective:
+  assumes "interact as' bs' = interact as bs" "acc_lengths a as' = acc_lengths a as" "acc_lengths b bs' = acc_lengths b bs"
+  shows "as' = as \<and> bs' = bs"
+  using assms
+proof (induction as bs arbitrary: a b as' bs' rule: interact.induct)
+  case (1 cs)
+  then have "as' = []"
+    by (metis acc_lengths_eq_Nil_iff)
+  with 1 show ?case
+    using acc_lengths_concat_injective by auto
+next
+  case (2 c cs)
+  then show ?case
+    by (metis acc_lengths_concat_injective acc_lengths_eq_Nil_iff interact.simps(2) list.exhaust)
+next
+  case (3 x xs y ys)
+  then obtain a' us b' vs where "as' = a'#us" "bs' = b'#vs"
+    by (metis length_Suc_conv length_acc_lengths)
+  with 3 show ?case
+    by (auto simp: acc_lengths.simps)
+qed
+
+
+lemma strict_sorted_interact_I:
+  assumes "length ys \<le> length xs" "length xs \<le> Suc (length ys)"
+    "\<And>x. x \<in> list.set xs \<Longrightarrow> strict_sorted x"
+    "\<And>y. y \<in> list.set ys \<Longrightarrow> strict_sorted y"
+    "\<And>n. n < length ys \<Longrightarrow> xs!n < ys!n"
+    "\<And>n. Suc n < length xs \<Longrightarrow> ys!n < xs!Suc n"
+  assumes "xs \<in> lists (- {[]})" "ys \<in> lists (- {[]})"
+  shows "strict_sorted (interact xs ys)"
+  using assms
+proof (induction rule: interact.induct)
+  case (3 x xs y ys)
+  then have "x < y"
+    by force+
+  moreover have "strict_sorted (interact xs ys)"
+    using 3 by simp (metis Suc_less_eq nth_Cons_Suc)
+  moreover have "y < interact xs ys"
+  proof (clarsimp simp add: less_list_def)
+    assume "y \<noteq> []" and ne: "interact xs ys \<noteq> []"
+    then show "last y < hd (interact xs ys)"
+      using 3
+      apply simp
+      by (metis dual_order.strict_trans1 hd_interact length_greater_0_conv less_list_def list.sel(1) lists.simps mem_lists_non_Nil nth_Cons' nth_mem)
+  qed
+  ultimately show ?case
+    using 3 by (simp add: strict_sorted_append_iff less_list_def)
+qed auto
+
+
+subsection \<open>Forms and interactions\<close>
+
+subsubsection \<open>Forms\<close>
+
+inductive Form_Body :: "[nat, nat, nat list, nat list, nat list] \<Rightarrow> bool"
+  where "Form_Body ka kb xs ys zs"
+  if "length xs < length ys" "xs = concat (a#as)" "ys = concat (b#bs)"
+          "a#as \<in> lists (- {[]})" "b#bs \<in> lists (- {[]})"
+          "length (a#as) = ka" "length (b#bs) = kb"
+          "c = acc_lengths 0 (a#as)"
+          "d = acc_lengths 0 (b#bs)"
+          "zs = concat [c, a, d, b] @ interact as bs"
+          "strict_sorted zs"
+
+
+inductive Form :: "[nat, nat list set] \<Rightarrow> bool"
+  where "Form 0 {xs,ys}" if "length xs = length ys" "xs \<noteq> ys"
+      | "Form (2*k-1) {xs,ys}" if "Form_Body k k xs ys zs" "k > 0"
+      | "Form (2*k)   {xs,ys}" if "Form_Body (Suc k) k xs ys zs" "k > 0"
+
+inductive_cases Form_0_cases_raw: "Form 0 u"
+
+lemma Form_elim_upair:
+  assumes "Form l U"
+  obtains xs ys where "xs \<noteq> ys" "U = {xs,ys}" "length xs \<le> length ys"
+  using assms
+  by (elim Form.cases Form_Body.cases; metis dual_order.order_iff_strict less_not_refl)
+
+
+lemma Form_Body_WW:
+  assumes "Form_Body ka kb xs ys zs"
+  shows "zs \<in> WW"
+  by (rule Form_Body.cases [OF assms]) (auto simp: WW_def)
+
+lemma Form_Body_nonempty:
+  assumes "Form_Body ka kb xs ys zs"
+  shows "length zs > 0"
+  by (rule Form_Body.cases [OF assms]) auto
+
+lemma Form_Body_length:
+  assumes "Form_Body ka kb xs ys zs"
+  shows "length xs < length ys"
+  using Form_Body.cases assms by blast
+
+lemma form_cases:
+  fixes l::nat
+  obtains (zero) "l = 0" | (odd) k where "l = 2*k-1" "k > 0" | (even) k where "l = 2*k" "k > 0"
+proof -
+  have "l = 0 \<or> (\<exists>k. l = 2*k-1 \<and> k > 0) \<or> (\<exists>k. l = 2*k \<and> k > 0)"
+    by presburger
+  then show thesis
+    using even odd zero by blast
+qed
+
+lemma odd_eq_iffs: "2 * k - Suc 0 = 2 * k' - Suc 0 \<longleftrightarrow> k = k' \<or> k=0 \<and> k'=0"
+                   "2 * k - Suc 0 = 2 * k' \<longleftrightarrow> k=0 \<and> k'=0"
+                   "2 * k = 2 * k' - Suc 0 \<longleftrightarrow> k=0 \<and> k'=0"
+  by presburger+
+
+subsubsection \<open>Interactions\<close>
+
+lemma interact:
+  assumes "Form l U" "l>0"
+  obtains k xs ys zs where "l = 2*k-1" "U = {xs,ys}" "Form_Body k k xs ys zs" "k > 0"
+  | k xs ys zs where "l = 2*k" "U = {xs,ys}" "Form_Body (Suc k) k xs ys zs" "k > 0"
+  by (rule Form.cases [OF \<open>Form l U\<close>]) (use \<open>l>0\<close> in \<open>force+\<close>)
+
+
+definition inter_scheme :: "nat \<Rightarrow> nat list set \<Rightarrow> nat list"
+  where "inter_scheme l U \<equiv> @zs. \<exists>k xs ys. l > 0
+                    \<and> (l = 2*k-1 \<and> U = {xs,ys} \<and> Form_Body k k xs ys zs
+                     \<or> l = 2*k \<and> U = {xs,ys} \<and> Form_Body (Suc k) k xs ys zs)"
+
+
+lemma inter_scheme:
+  assumes "Form l U" "l>0"
+  obtains (odd) k xs ys where "l = 2*k-1" "U = {xs,ys}" "Form_Body k k xs ys (inter_scheme l U)"
+        | (even) k xs ys where "l = 2*k" "U = {xs,ys}" "Form_Body (Suc k) k xs ys (inter_scheme l U)"
+  using form_cases [of l]
+proof cases
+  case zero
+  with \<open>l > 0\<close> show ?thesis
+    by auto
+next
+  case (odd k)
+  show ?thesis
+    using interact [OF assms]
+  proof cases
+    case (1 k' xs ys zs)
+    show ?thesis
+    proof (rule that(1))
+      have "\<not> Form_Body k k ys xs zs" for zs
+        using 1 Form_Body_length less_asym' by blast
+      then show "Form_Body k k xs ys (inter_scheme l U)"
+        using odd 1
+        by (force simp: Set.doubleton_eq_iff odd_eq_iffs inter_scheme_def conj_disj_distribR ex_disj_distrib some_eq_ex)
+    qed (use 1 odd in auto)
+  qed (use odd in presburger)
+next
+  case (even k)
+  show ?thesis
+    using interact [OF assms]
+  proof cases
+    case (2 k' xs ys zs)
+    show ?thesis
+    proof (rule that(2))
+      have "\<not> Form_Body (Suc k) k ys xs zs" for zs
+        using 2 Form_Body_length less_asym' by blast
+      then show "Form_Body (Suc k) k xs ys (inter_scheme l U)"
+        using even 2
+        by (force simp: Set.doubleton_eq_iff odd_eq_iffs inter_scheme_def conj_disj_distribR ex_disj_distrib some_eq_ex)
+    qed (use 2 even in auto)
+  qed (use even in presburger)
+qed
+
+
+lemma inter_scheme_simple:
+  assumes "Form k U" "k>0"
+  shows "inter_scheme k U \<in> WW \<and> length (inter_scheme k U) > 0"
+  using inter_scheme by (meson Form_Body_WW Form_Body_nonempty assms)
+
+lemma inter_scheme_strict_sorted:
+  assumes "Form k U" "k>0"
+  shows "strict_sorted (inter_scheme k U)"
+  using inter_scheme_simple [OF assms] by (auto simp: WW_def)
+
+subsubsection \<open>Injectivity of interactions\<close>
+
+proposition inter_scheme_injective:
+  assumes "Form l U" "Form l U'" "l > 0" and eq: "inter_scheme l U' = inter_scheme l U"
+  shows "U' = U"
+  using inter_scheme [OF \<open>Form l U\<close> \<open>l>0\<close>]
+proof cases
+  case (1 k xs ys)
+  then obtain a as b bs c d
+      where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)"
+        and len: "length (a#as) = k" "length (b#bs) = k"
+        and c: "c = acc_lengths 0 (a#as)"
+        and d: "d = acc_lengths 0 (b#bs)"
+        and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs"
+    using Form_Body.simps by auto
+  note one = 1
+  show ?thesis
+    using inter_scheme [OF \<open>Form l U'\<close> \<open>l>0\<close>]
+  proof cases
+    case (1 k' xs' ys')
+    then obtain a' as' b' bs' c' d'
+      where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')"
+        and len': "length (a'#as') = k'" "length (b'#bs') = k'"
+        and c': "c' = acc_lengths 0 (a'#as')"
+        and d': "d' = acc_lengths 0 (b'#bs')"
+        and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'"
+      using Form_Body.simps by auto
+    have [simp]: "k' = k"
+      using 1 one \<open>l>0\<close> by (simp add: odd_eq_iffs)
+    have [simp]: "length c = length c'" "length d = length d'"
+      using c c' d d' len' len by auto
+    have c_off: "c' = c" "a' @ d' @ b' @ interact as' bs' = a @ d @ b @ interact as bs"
+      using eq by (auto simp: Ueq Ueq')
+    then have len_a: "length a' = length a"
+      by (metis acc_lengths.simps(2) add.left_neutral c c' nth_Cons_0)
+    with c_off have \<section>: "a' = a" "d' = d" "b' @ interact as' bs' = b @ interact as bs"
+      by auto
+    then have "length (interact as' bs') = length (interact as bs)"
+      by (metis acc_lengths.simps(2) add_left_cancel append_eq_append_conv d d' list.inject)
+    with \<section> have "b' = b" "interact as' bs' = interact as bs"
+      by auto
+    moreover have "acc_lengths 0 as' = acc_lengths 0 as"
+      using \<open>a' = a\<close> \<open>c' = c\<close> by (simp add: c' c acc_lengths.simps acc_lengths_shift)
+    moreover have "acc_lengths 0 bs' = acc_lengths 0 bs"
+      using \<open>b' = b\<close> \<open>d' = d\<close> by (simp add: d' d acc_lengths.simps acc_lengths_shift)
+    ultimately have "as' = as \<and> bs' = bs"
+      using acc_lengths_interact_injective by blast
+    with one 1 show ?thesis
+      by (simp add: xs ys xs' ys' \<open>a' = a\<close> \<open>b' = b\<close>)
+  next
+    case (2 k' xs' ys')
+    then show ?thesis
+      using 1 \<open>l>0\<close> by (simp add: odd_eq_iffs)
+  qed
+next
+  case (2 k xs ys)
+  then obtain a as b bs c d
+      where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)"
+        and len: "length (a#as) = Suc k" "length (b#bs) = k"
+        and c: "c = acc_lengths 0 (a#as)"
+        and d: "d = acc_lengths 0 (b#bs)"
+        and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs"
+    using Form_Body.simps by auto
+  note two = 2
+  show ?thesis
+    using inter_scheme [OF \<open>Form l U'\<close> \<open>l>0\<close>]
+  proof cases
+    case (1 k' xs' ys')
+    then show ?thesis
+      using 2 \<open>l>0\<close> by (simp add: odd_eq_iffs)
+  next
+    case (2 k' xs' ys')
+    then obtain a' as' b' bs' c' d'
+      where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')"
+        and len': "length (a'#as') = Suc k'" "length (b'#bs') = k'"
+        and c': "c' = acc_lengths 0 (a'#as')"
+        and d': "d' = acc_lengths 0 (b'#bs')"
+        and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'"
+      using Form_Body.simps by auto
+    have [simp]: "k' = k"
+      using 2 two \<open>l>0\<close> by (simp add: odd_eq_iffs)
+    have [simp]: "length c = length c'" "length d = length d'"
+      using c c' d d' len' len by auto
+    have c_off: "c' = c" "a' @ d' @ b' @ interact as' bs' = a @ d @ b @ interact as bs"
+      using eq by (auto simp: Ueq Ueq')
+    then have len_a: "length a' = length a"
+      by (metis acc_lengths.simps(2) add.left_neutral c c' nth_Cons_0)
+    with c_off have \<section>: "a' = a" "d' = d" "b' @ interact as' bs' = b @ interact as bs"
+      by auto
+    then have "length (interact as' bs') = length (interact as bs)"
+      by (metis acc_lengths.simps(2) add_left_cancel append_eq_append_conv d d' list.inject)
+    with \<section> have "b' = b" "interact as' bs' = interact as bs"
+      by auto
+    moreover have "acc_lengths 0 as' = acc_lengths 0 as"
+      using \<open>a' = a\<close> \<open>c' = c\<close> by (simp add: c' c acc_lengths.simps acc_lengths_shift)
+    moreover have "acc_lengths 0 bs' = acc_lengths 0 bs"
+      using \<open>b' = b\<close> \<open>d' = d\<close> by (simp add: d' d acc_lengths.simps acc_lengths_shift)
+    ultimately have "as' = as \<and> bs' = bs"
+      using acc_lengths_interact_injective by blast
+    with two 2 show ?thesis
+      by (simp add: xs ys xs' ys' \<open>a' = a\<close> \<open>b' = b\<close>)
+  qed
+qed
+
+
+lemma strict_sorted_interact_imp_concat:
+    "strict_sorted (interact as bs) \<Longrightarrow> strict_sorted (concat as) \<and> strict_sorted (concat bs)"
+proof (induction as bs rule: interact.induct)
+  case (3 x xs y ys)
+  show ?case
+  proof (cases x)
+    case Nil
+    show ?thesis
+    proof (cases y)
+      case Nil
+      then show ?thesis
+        using "3" strict_sorted_append_iff by (auto simp: \<open>x = []\<close>)
+    next
+      case (Cons a list)
+      with Nil 3 show ?thesis
+        apply (simp add: strict_sorted_append_iff)
+        by (metis (no_types, lifting) Un_iff set_interact sorted_wrt_append strict_sorted_append_iff strict_sorted_sorted_wrt)
+    qed
+  next
+    case (Cons a list)
+    have \<section>: "sorted_wrt (<) ((a # list) @ y @ interact xs ys)"
+      by (metis (no_types) "3.prems" interact.simps(3) local.Cons strict_sorted_sorted_wrt)
+    then have "list = [] \<or> concat xs = [] \<or> last list < hd (concat xs)"
+      by (metis (full_types) Un_iff hd_in_set last_ConsR last_in_set list.simps(3) set_append set_interact sorted_wrt_append)
+    then have "list < concat xs"
+      using less_list_def by blast
+    have "list < y"
+      by (metis \<section> append.assoc last.simps less_list_def list.distinct(1) strict_sorted_append_iff strict_sorted_sorted_wrt)
+    note Cons1 = Cons
+    show ?thesis
+    proof (cases y)
+      case Nil
+      then show ?thesis
+        using 3 by (simp add: sorted_wrt_append strict_sorted_sorted_wrt)
+    next
+      case (Cons a' list')
+      have "strict_sorted (list' @ concat ys)"
+        apply (simp add: strict_sorted_sorted_wrt)
+        by (metis "3.IH" "\<section>" Un_iff append_Cons local.Cons set_interact sorted_wrt_append strict_sorted.simps(2) strict_sorted_sorted_wrt)
+      moreover have "y < concat ys"
+        by (metis "\<section>" Un_iff hd_in_set last_in_set less_list_def set_interact sorted_wrt_append)
+      ultimately show ?thesis
+        using 3 \<open>list < concat xs\<close>
+        by (auto simp: Cons1 strict_sorted_append_iff)
+    qed
+  qed
+qed auto
+
+
+
+
+lemma strict_sorted_interact_hd:
+  "\<lbrakk>strict_sorted (interact cs ds); cs \<noteq> []; ds \<noteq> []; hd cs \<noteq> []; hd ds \<noteq> []\<rbrakk>
+       \<Longrightarrow> hd (hd cs) < hd (hd ds)"
+  by (metis Nil_is_append_conv hd_append2 hd_in_set interact.simps(3) list.exhaust_sel sorted_wrt_append strict_sorted_sorted_wrt)
+
+
+text \<open>the lengths of the two lists can differ by one\<close>
+proposition interaction_scheme_unique_aux:
+  assumes eq: "concat as = concat as'" and ys': "concat bs = concat bs'"
+    and ne: "as \<in> lists (- {[]})" "bs \<in> lists (- {[]})"
+    and ss_zs: "strict_sorted (interact as bs)"
+    and "length bs \<le> length as" "length as \<le> Suc (length bs)"
+    and ne': "as' \<in> lists (- {[]})" "bs' \<in> lists (- {[]})"
+    and ss_zs': "strict_sorted (interact as' bs')"
+    and "length bs' \<le> length as'" "length as' \<le>Suc (length bs')"
+    and "length as = length as'" "length bs = length bs'"
+  shows "as = as' \<and> bs = bs'"
+  using assms
+proof (induction "length as" arbitrary: as bs as' bs')
+  case 0 then show ?case
+    by auto
+next
+  case (Suc k)
+  show ?case
+  proof (cases k)
+    case 0
+    then have "length as = Suc 0"
+      using Suc.hyps(2) by auto
+    then obtain a a' where "as = [a]" "as' = [a']"
+      by (metis \<open>length as = length as'\<close> length_0_conv length_Suc_conv)
+    with 0 show ?thesis
+      using Suc.prems
+      apply (simp add: le_Suc_eq)
+      by (metis concat.simps length_0_conv length_Suc_conv self_append_conv)
+  next
+    case (Suc k')
+    then obtain a cs b ds where eq: "as = a#cs" "bs = b#ds"
+      using Suc.prems
+      by (metis Suc.hyps(2) le0 list.exhaust list.size(3) not_less_eq_eq)
+    have "length as' \<noteq> 0"
+      using Suc.hyps(2) Suc.prems(1) Suc.prems(3) interact_eq_Nil_iff by auto
+    then obtain a' cs' b' ds' where eq': "as' = a'#cs'" "bs' = b'#ds'"
+      by (metis Suc.prems(14) eq(2) length_0_conv list.exhaust)
+    obtain k: "k = length cs" "k \<le> Suc (length ds)"
+      using eq \<open>Suc k = length as\<close> \<open>length bs \<le> length as\<close> \<open>length as \<le> Suc (length bs)\<close> by auto
+    case (Suc k')
+    obtain [simp]: "b \<noteq> []" "b' \<noteq> []" "a \<noteq> []" "a' \<noteq> []"
+      using Suc.prems by (simp add: eq eq')
+    then have "hd b' = hd b"
+      using Suc.prems(2) by (metis concat.simps(2) eq'(2) eq(2) hd_append2)
+
+    have ss_ab: "strict_sorted (concat as)" "strict_sorted (concat bs)"
+      using strict_sorted_interact_imp_concat Suc.prems(5) by blast+
+    have "a < b"
+      by (metis eq Suc.prems(5) append.assoc interact.simps(3) strict_sorted_append_iff)
+    have sw_ab: "sorted_wrt (<) (a @ b @ interact cs ds)"
+      by (metis Suc.prems(5) eq interact.simps(3) strict_sorted_sorted_wrt)
+    then have "hd b \<notin> list.set (concat cs)"
+      by (metis Un_iff \<open>b \<noteq> []\<close> list.set_sel(1) not_less_iff_gr_or_eq set_interact sorted_wrt_append)
+    have "b < concat cs"
+      using eq \<open>strict_sorted (interact as bs)\<close>
+      apply (simp add: strict_sorted_append_iff)
+      by (metis Un_iff sw_ab last_in_set less_list_def list.set_sel(1) set_interact sorted_wrt_append)
+    have "strict_sorted (a @ concat cs)"
+      using eq(1) ss_ab(1) by force
+    then have b_cs: "strict_sorted (b @ concat cs)"
+      by (metis \<open>b < concat cs\<close> strict_sorted_append_iff strict_sorted_sorted_wrt sw_ab)
+    have "list.set a = list.set (concat as) \<inter> {..< hd b}"
+    proof -
+      have "x \<in> list.set a"
+        if "x < hd b" and "l \<in> list.set cs" and "x \<in> list.set l" for x l
+        using b_cs sorted_hd_le strict_sorted_imp_sorted that by fastforce
+      then show ?thesis
+        using \<open>b \<noteq> []\<close> sw_ab by (force simp: strict_sorted_append_iff sorted_wrt_append eq)
+    qed
+    moreover
+    have ss_ab': "strict_sorted (concat as')" "strict_sorted (concat bs')"
+      using strict_sorted_interact_imp_concat Suc.prems(10) by blast+
+    have "a' < b'"
+      by (metis eq' Suc.prems(10) append.assoc interact.simps(3) strict_sorted_append_iff)
+    have sw_ab': "sorted_wrt (<) (a' @ b' @ interact cs' ds')"
+      by (metis Suc.prems(10) eq' interact.simps(3) strict_sorted_sorted_wrt)
+    then have "hd b' \<notin> list.set (concat cs')"
+      by (metis Un_iff \<open>b' \<noteq> []\<close> list.set_sel(1) not_less_iff_gr_or_eq set_interact sorted_wrt_append)
+    have "b' < concat cs'"
+      using eq' \<open>strict_sorted (interact as' bs')\<close>
+      apply (simp add: strict_sorted_append_iff)
+      by (metis Un_iff last_in_set less_list_def list.set_sel(1) set_interact sorted_wrt_append sw_ab')
+    have "strict_sorted (a' @ concat cs')"
+      using eq'(1) ss_ab'(1) by force
+    then have b_cs': "strict_sorted (b' @ concat cs')"
+      using \<open>b' < concat cs'\<close> eq'(2) ss_ab'(2) strict_sorted_append_iff by auto
+    have "list.set a' = list.set (concat as') \<inter> {..< hd b'}"
+    proof -
+      have "x \<in> list.set a'"
+        if "x < hd b'" and "l \<in> list.set cs'" and "x \<in> list.set l" for x l
+        using b_cs' sorted_hd_le strict_sorted_imp_sorted that by fastforce
+      then show ?thesis
+        using \<open>b' \<noteq> []\<close> sw_ab' by (force simp: strict_sorted_append_iff sorted_wrt_append eq')
+    qed
+    ultimately have "a=a'"
+      by (metis Suc.prems(1) \<open>hd b' = hd b\<close> sorted_wrt_append strict_sorted_equal strict_sorted_sorted_wrt sw_ab sw_ab')
+    moreover
+    have ccat_cs_cs': "concat cs = concat cs'"
+      using Suc.prems(1) \<open>a = a'\<close> eq'(1) eq(1) by fastforce
+    have "b=b'"
+    proof (cases "ds = [] \<or> ds' = []")
+      case True
+      then show ?thesis
+        using Suc.prems(14) Suc.prems(2) eq'(2) eq(2) by auto
+    next
+      case False
+      then have "ds \<noteq> []" "ds' \<noteq> []"
+        by auto
+      have "strict_sorted b"
+        by (metis Suc.prems(2) concat.simps(2) eq(2) ss_ab'(2) strict_sorted_append_iff)
+      moreover
+      have "cs \<noteq> []"
+        using k local.Suc by auto
+
+      then obtain "hd cs \<noteq> []" "hd ds \<noteq> []"
+        using Suc.prems(3) Suc.prems(4) eq list.set_sel(1)
+        by (simp add: \<open>ds \<noteq> []\<close> mem_lists_non_Nil)
+      then have "concat cs \<noteq> []"
+        using \<open>cs \<noteq> []\<close> hd_in_set by auto
+      have "hd (concat cs) < hd (concat ds)"
+        using strict_sorted_interact_hd
+        by (metis \<open>cs \<noteq> []\<close> \<open>ds \<noteq> []\<close> \<open>hd cs \<noteq> []\<close> \<open>hd ds \<noteq> []\<close> hd_concat strict_sorted_append_iff strict_sorted_sorted_wrt sw_ab)
+      then have "list.set b = list.set (concat bs) \<inter> {..< hd (concat cs)}"
+        using ss_ab
+        apply (auto simp: strict_sorted_append_iff eq)
+        apply (metis \<open>b < concat cs\<close> \<open>concat cs \<noteq> []\<close> hd_in_set sorted_wrt_append strict_sorted_append_iff strict_sorted_sorted_wrt)
+        by (metis strict_sorted_iff UN_I dual_order.strict_trans2 order.asym set_concat sorted_hd_le)
+      moreover
+      have "cs' \<noteq> []"
+        using k local.Suc \<open>concat cs \<noteq> []\<close> ccat_cs_cs' by auto
+      then obtain "hd cs' \<noteq> []" "hd ds' \<noteq> []"
+        using Suc.prems(8,9) \<open>ds' \<noteq> []\<close> eq'(1) eq'(2) list.set_sel(1) by auto
+      then have "concat cs' \<noteq> []"
+        using \<open>cs' \<noteq> []\<close> hd_in_set by auto
+      have "hd (concat cs') < hd (concat ds')"
+        using strict_sorted_interact_hd
+        by (metis \<open>cs' \<noteq> []\<close> \<open>ds' \<noteq> []\<close> \<open>hd cs' \<noteq> []\<close> \<open>hd ds' \<noteq> []\<close> hd_concat strict_sorted_append_iff strict_sorted_sorted_wrt sw_ab')
+      then have "list.set b' = list.set (concat bs') \<inter> {..< hd (concat cs')}"
+        using ss_ab'
+        apply (auto simp: strict_sorted_append_iff eq')
+         apply (meson strict_sorted_iff \<open>b' < concat cs'\<close> \<open>b' \<noteq> []\<close> \<open>concat cs' \<noteq> []\<close> dual_order.strict_trans2 less_list_def sorted_le_last)
+        by (metis strict_sorted_iff UN_I dual_order.strict_trans2 order.asym set_concat sorted_hd_le)
+
+      ultimately show "b = b'"
+        by (metis Suc.prems(2) ccat_cs_cs' strict_sorted_append_iff strict_sorted_equal strict_sorted_sorted_wrt sw_ab')
+    qed
+    moreover
+    have "cs = cs' \<and> ds = ds'"
+    proof (rule Suc.hyps)
+      show "k = length cs"
+        using eq Suc.hyps(2) by auto[1]
+      show "concat ds = concat ds'"
+        using Suc.prems(2) \<open>b = b'\<close> eq'(2) eq(2) by auto
+      show "strict_sorted (interact cs ds)"
+        using eq Suc.prems(5) strict_sorted_append_iff by auto
+      show "length ds \<le> length cs" "length cs \<le> Suc (length ds)"
+        using eq Suc.hyps(2) Suc.prems(6) k by auto
+      show "strict_sorted (interact cs' ds')"
+        using eq' Suc.prems(10) strict_sorted_append_iff by auto
+      show "length cs = length cs'"
+        using Suc.hyps(2) Suc.prems(13) eq'(1) k(1) by force
+    qed (use ccat_cs_cs' eq eq' Suc.prems in auto)
+    ultimately show ?thesis
+      by (simp add: \<open>a = a'\<close> \<open>b = b'\<close> eq eq')
+  qed
+qed
+
+
+proposition Form_Body_unique:
+  assumes "Form_Body ka kb xs ys zs" "Form_Body ka kb xs ys zs'" and "kb \<le> ka" "ka \<le> Suc kb"
+  shows "zs' = zs"
+proof -
+  obtain a as b bs c d
+      where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)"
+        and ne: "a#as \<in> lists (- {[]})" "b#bs \<in> lists (- {[]})"
+        and len: "length (a#as) = ka" "length (b#bs) = kb"
+        and c: "c = acc_lengths 0 (a#as)"
+        and d: "d = acc_lengths 0 (b#bs)"
+        and Ueq: "zs = concat [c, a, d, b] @ interact as bs"
+        and ss_zs: "strict_sorted zs"
+    using Form_Body.cases [OF assms(1)] by (metis (no_types))
+  obtain a' as' b' bs' c' d'
+      where xs': "xs = concat (a'#as')" and ys': "ys = concat (b'#bs')"
+        and ne': "a'#as' \<in> lists (- {[]})" "b'#bs' \<in> lists (- {[]})"
+        and len': "length (a'#as') = ka" "length (b'#bs') = kb"
+        and c': "c' = acc_lengths 0 (a'#as')"
+        and d': "d' = acc_lengths 0 (b'#bs')"
+        and Ueq': "zs' = concat [c', a', d', b'] @ interact as' bs'"
+        and ss_zs': "strict_sorted zs'"
+    using Form_Body.cases [OF assms(2)] by (metis (no_types))
+  have [simp]: "length c = length c'" "length d = length d'"
+    using c c' d d' len' len by auto
+  have "a < b"
+    using ss_zs apply (simp add: Ueq strict_sorted_append_iff)
+    by (metis strict_sorted_iff append.assoc d length_0_conv length_acc_lengths list.distinct(1) strict_sorted_append_iff sorted_trans)
+  have "a' < b'"
+    using ss_zs' apply (simp add: Ueq' strict_sorted_append_iff)
+    by (metis strict_sorted_iff append.assoc d' length_0_conv length_acc_lengths list.distinct(1) strict_sorted_append_iff sorted_trans)
+  have "a#as = a'#as' \<and> b#bs = b'#bs'"
+  proof (rule interaction_scheme_unique_aux)
+    show "concat (a # as) = concat (a' # as')"
+      using xs xs' by blast
+    show "concat (b # bs) = concat (b' # bs')"
+      using ys ys' by blast
+    show "a # as \<in> lists (- {[]})" "b # bs \<in> lists (- {[]})"
+      using ne by auto
+    show "strict_sorted (interact (a # as) (b # bs))"
+      using ss_zs \<open>a < b\<close> apply (simp add: Ueq strict_sorted_append_iff)
+      by (metis strict_sorted_iff append.assoc append.left_neutral strict_sorted_append_iff sorted_trans)
+    show "length (b # bs) \<le> length (a # as)" "length (b' # bs') \<le> length (a' # as')"
+      using \<open>kb \<le> ka\<close> len len' by auto
+    show "length (a # as) \<le> Suc (length (b # bs))"
+      using \<open>ka \<le> Suc kb\<close> len by linarith
+    then show "length (a' # as') \<le> Suc (length (b' # bs'))"
+      using len len' by fastforce
+    show "a' # as' \<in> lists (- {[]})" "b' # bs' \<in> lists (- {[]})"
+      using ne' by auto
+    show "strict_sorted (interact (a' # as') (b' # bs'))"
+      using ss_zs' \<open>a' < b'\<close> apply (simp add: Ueq' strict_sorted_append_iff)
+      by (metis strict_sorted_iff append.assoc append.left_neutral strict_sorted_append_iff sorted_trans)
+    show "length (a # as) = length (a' # as')"
+      using len'(1) len(1) by blast
+    show "length (b # bs) = length (b' # bs')"
+      using len'(2) len(2) by blast
+  qed
+  then show ?thesis
+    using Ueq Ueq' c c' d d' by blast
+qed
+
+
+lemma Form_Body_imp_inter_scheme:
+  assumes "Form_Body ka kb xs ys zs" and "0 < kb" "kb \<le> ka" "ka \<le> Suc kb"
+  shows "zs = inter_scheme ((ka+kb) - Suc 0) {xs,ys}"
+proof -
+  have "length xs < length ys"
+    by (meson Form_Body_length assms(1))
+  have [simp]: "a + a = b + b \<longleftrightarrow> a=b"  "a + a - Suc 0 = b + b - Suc 0 \<longleftrightarrow> a=b" for a b::nat
+    by auto
+  show ?thesis
+  proof (cases "ka = kb")
+    case True
+    show ?thesis
+      unfolding inter_scheme_def
+      apply (rule some_equality [symmetric])
+      using assms True mult_2 not_gr0 one_is_add apply fastforce
+      using assms \<open>length xs < length ys\<close>
+      apply (auto simp: True mult_2 Set.doubleton_eq_iff Form_Body_unique dest: Form_Body_length)
+      by presburger
+  next
+    case False
+    then have eq: "ka = Suc kb"
+      using assms by linarith
+    show ?thesis
+      unfolding inter_scheme_def
+      apply (rule some_equality [symmetric])
+      using assms False mult_2 one_is_add eq apply fastforce
+      using assms \<open>length xs < length ys\<close>
+       apply (auto simp: eq mult_2 Set.doubleton_eq_iff Form_Body_unique dest: Form_Body_length)
+      by presburger
+  qed
+qed
+
+
+subsection \<open>For Lemma 3.8 AND PROBABLY 3.7\<close>
+
+definition grab :: "nat set \<Rightarrow> nat \<Rightarrow> nat set \<times> nat set"
+  where "grab N n \<equiv> (N \<inter> enumerate N ` {..<n}, N \<inter> {enumerate N n..})"
+
+lemma grab_0 [simp]: "grab N 0 = ({}, N)"
+  by (fastforce simp add: grab_def enumerate_0 Least_le)
+
+lemma less_sets_grab:
+  "infinite N \<Longrightarrow> less_sets (fst (grab N n)) (snd (grab N n))"
+  by (auto simp: grab_def less_sets_def intro: enumerate_mono less_le_trans)
+
+lemma finite_grab [iff]: "finite (fst (grab N n))"
+  by (simp add: grab_def)
+
+lemma card_grab [simp]:
+  assumes "infinite N" shows "card (fst (grab N n)) = n"
+proof -
+  have "N \<inter> enumerate N ` {..<n} = enumerate N ` {..<n}"
+    using assms by (auto simp: enumerate_in_set)
+  with assms show ?thesis
+    by (simp add: card_image grab_def strict_mono_enum strict_mono_imp_inj_on)
+qed
+
+lemma fst_grab_subset: "fst (grab N n) \<subseteq> N"
+  using grab_def range_enum by fastforce
+
+lemma snd_grab_subset: "snd (grab N n) \<subseteq> N"
+  by (auto simp: grab_def)
+
+lemma grab_Un_eq:
+  assumes "infinite N" shows "fst (grab N n) \<union> snd (grab N n) = N"
+proof
+  show "N \<subseteq> fst (grab N n) \<union> snd (grab N n)"
+    unfolding grab_def
+    using assms enumerate_Ex le_less_linear strict_mono_enum strict_mono_less by fastforce
+qed (simp add: grab_def)
+
+lemma finite_grab_iff [simp]: "finite (snd (grab N n)) \<longleftrightarrow> finite N"
+  by (metis finite_grab grab_Un_eq infinite_Un infinite_super snd_grab_subset)
+
+lemma grab_eqD:
+    "\<lbrakk>grab N n = (A,M); infinite N\<rbrakk>
+    \<Longrightarrow> less_sets A M \<and> finite A \<and> card A = n \<and> infinite M \<and> A \<subseteq> N \<and> M \<subseteq> N"
+  using card_grab grab_def less_sets_grab finite_grab_iff by auto
+
+lemma less_sets_fst_grab: "less_sets A N \<Longrightarrow> less_sets A (fst (grab N n))"
+  by (simp add: fst_grab_subset less_sets_weaken2)
+
+text\<open>Possibly redundant, given @{term grab}\<close>
+definition nxt where "nxt \<equiv> \<lambda>N. \<lambda>n::nat. N \<inter> {n<..}"
+
+lemma infinite_nxtN: "infinite N \<Longrightarrow> infinite (nxt N n)"
+  by (simp add: infinite_nat_greaterThan nxt_def)
+
+lemma nxt_subset: "nxt N n \<subseteq> N"
+  unfolding nxt_def by blast
+
+lemma nxt_subset_greaterThan: "m \<le> n \<Longrightarrow> nxt N n \<subseteq> {m<..}"
+  by (auto simp: nxt_def)
+
+lemma nxt_subset_atLeast: "m \<le> n \<Longrightarrow> nxt N n \<subseteq> {m..}"
+  by (auto simp: nxt_def)
+
+lemma enum_nxt_ge: "infinite N \<Longrightarrow> a \<le> enum (nxt N a) n"
+  by (simp add: atLeast_le_enum infinite_nxtN nxt_subset_atLeast)
+
+lemma inj_enum_nxt: "infinite N \<Longrightarrow> inj_on (enum (nxt N a)) A"
+  by (simp add: infinite_nxtN strict_mono_enum strict_mono_imp_inj_on)
+
+
+subsection \<open>Larson's Lemma 3.11\<close>
+
+text \<open>Again 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.\<close>
+
+lemma lemma_3_11:
+  assumes "l > 0"
+  shows "thin (inter_scheme l ` {U. Form l U})"
+  using form_cases [of l]
+proof cases
+  case zero
+  then show ?thesis
+    using assms by auto
+next
+  case (odd k)
+  show ?thesis
+    unfolding thin_def
+  proof clarify
+    fix U U'
+    assume ne: "inter_scheme l U \<noteq> inter_scheme l U'" and init: "initial_segment (inter_scheme l U) (inter_scheme l U')"
+    assume "Form l U"
+    then obtain xs ys where "U = {xs,ys}"
+      and U: "Form_Body k k xs ys (inter_scheme l U)"
+      using inter_scheme [OF \<open>Form l U\<close> \<open>l > 0\<close>]
+      by (metis One_nat_def less_numeral_extra(3) odd odd_eq_iffs(1) odd_eq_iffs(3))
+    then obtain a as b bs c d
+      where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)"
+        and len: "length (a#as) = k" "length (b#bs) = k"
+        and c: "c = acc_lengths 0 (a#as)"
+        and d: "d = acc_lengths 0 (b#bs)"
+        and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs"
+      using Form_Body.cases by metis
+    assume "Form l U'"
+    then obtain xs' ys' where "U' = {xs',ys'}"
+      and U': "Form_Body k k xs' ys' (inter_scheme l U')"
+      using inter_scheme [OF \<open>Form l U'\<close> \<open>l > 0\<close>]
+      by (metis One_nat_def Suc_pred assms double_not_eq_Suc_double odd(1) odd_eq_iffs(1) odd_eq_iffs(3))
+    then obtain a' as' b' bs' c' d'
+      where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')"
+        and len': "length (a'#as') = k" "length (b'#bs') = k"
+        and c': "c' = acc_lengths 0 (a'#as')"
+        and d': "d' = acc_lengths 0 (b'#bs')"
+        and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'"
+      using Form_Body.cases by metis
+    have [simp]: "length bs = length as" "length bs' = length as'"
+      using len len' by auto
+    have "inter_scheme l U \<noteq> []" "inter_scheme l U' \<noteq> []"
+      using Form_Body_nonempty U U' by auto
+    define u1 where "u1 \<equiv> hd (inter_scheme l U)"
+    have u1_eq': "u1 = hd (inter_scheme l U')"
+      using \<open>inter_scheme l U \<noteq> []\<close> init u1_def initial_segment_ne by fastforce
+    have au1: "u1 = length a"
+      by (simp add: u1_def Ueq c acc_lengths.simps)
+    have au1': "u1 = length a'"
+      by (simp add: u1_eq' Ueq' c' acc_lengths.simps)
+    have len_eqk: "length c = k" "length d = k" "length c' = k" "length d' = k"
+      using c d len c' d' len' by auto
+    have take: "take (k + u1 + k) (c @ a @ d @ l) = c @ a @ d"
+                "take (k + u1 + k) (c' @ a' @ d' @ l) = c' @ a' @ d'" for l
+      by (simp_all add: len_eqk flip: au1 au1')
+    have leU: "k + u1 + k \<le> length (inter_scheme l U)"
+      by (simp add: len_eqk au1 Ueq)
+    then have "take (k + u1 + k) (inter_scheme l U) = take (k + u1 + k) (inter_scheme l U')"
+      using take_initial_segment init by blast
+    then have \<section>: "c @ a @ d = c' @ a' @ d'"
+      by (metis append.assoc Ueq Ueq' concat.simps take)
+    have "length (inter_scheme l U) = k + (c @ a @ d)!(k-1) + k + last d"
+      by (simp add: Ueq c d length_interact nth_append len_eqk flip: len)
+    moreover
+    have "length (inter_scheme l U') = k + (c' @ a' @ d')!(k-1) + k + last d'"
+      by (simp add: Ueq' c' d' length_interact nth_append len_eqk flip: len')
+    moreover have "last d = last d'"
+      using "\<section>" au1 au1' len_eqk by auto
+    ultimately have "length (inter_scheme l U) = length (inter_scheme l U')"
+      by (simp add: \<section>)
+    then show False
+      using init initial_segment_length_eq ne by blast
+  qed
+next
+  case (even k)
+  show ?thesis
+    unfolding thin_def
+  proof clarify
+    fix U U'
+    assume ne: "inter_scheme l U \<noteq> inter_scheme l U'" and init: "initial_segment (inter_scheme l U) (inter_scheme l U')"
+    assume "Form l U"
+    then obtain xs ys where "U = {xs,ys}"
+      and U: "Form_Body (Suc k) k xs ys (inter_scheme l U)"
+      using inter_scheme [OF \<open>Form l U\<close> \<open>l > 0\<close>]
+      by (metis One_nat_def Suc_1 Suc_mult_cancel1 even less_numeral_extra(3) odd_eq_iffs(3))
+    then obtain a as b bs c d
+      where xs: "xs = concat (a#as)" and ys: "ys = concat (b#bs)"
+        and len: "length (a#as) = Suc k" "length (b#bs) = k"
+        and c: "c = acc_lengths 0 (a#as)"
+        and d: "d = acc_lengths 0 (b#bs)"
+        and Ueq: "inter_scheme l U = concat [c, a, d, b] @ interact as bs"
+      using Form_Body.cases by metis
+    assume "Form l U'"
+    then obtain xs' ys' where "U' = {xs',ys'}"
+      and U': "Form_Body (Suc k) k xs' ys' (inter_scheme l U')"
+      using inter_scheme [OF \<open>Form l U'\<close> \<open>l > 0\<close>]
+      by (metis One_nat_def Suc_1 Suc_mult_cancel1 even not_gr0 odd_eq_iffs(3))
+    then obtain a' as' b' bs' c' d'
+      where xs': "xs' = concat (a'#as')" and ys': "ys' = concat (b'#bs')"
+        and len': "length (a'#as') = Suc k" "length (b'#bs') = k"
+        and c': "c' = acc_lengths 0 (a'#as')"
+        and d': "d' = acc_lengths 0 (b'#bs')"
+        and Ueq': "inter_scheme l U' = concat [c', a', d', b'] @ interact as' bs'"
+      using Form_Body.cases by metis
+    have [simp]: "length as = Suc (length bs)" "length as' = Suc (length bs')"
+      using len len' by auto
+    have "inter_scheme l U \<noteq> []" "inter_scheme l U' \<noteq> []"
+      using Form_Body_nonempty U U' by auto
+    define u1 where "u1 \<equiv> hd (inter_scheme l U)"
+    have u1_eq': "u1 = hd (inter_scheme l U')"
+      using \<open>inter_scheme l U \<noteq> []\<close> init u1_def initial_segment_ne by fastforce
+    have au1: "u1 = length a"
+      by (simp add: u1_def Ueq c acc_lengths.simps)
+    have au1': "u1 = length a'"
+      by (simp add: u1_eq' Ueq' c' acc_lengths.simps)
+    have len_eqk: "length c = Suc k" "length d = k" "length c' = Suc k" "length d' = k"
+      using c d len c' d' len' by auto
+    have take: "take (Suc k + u1 + k) (c @ a @ d @ l) = c @ a @ d"
+                "take (Suc k + u1 + k) (c' @ a' @ d' @ l) = c' @ a' @ d'" for l
+      by (simp_all add: len_eqk flip: au1 au1')
+    have leU: "Suc k + u1 + k \<le> length (inter_scheme l U)"
+      by (simp add: len_eqk au1 Ueq)
+    then have "take (Suc k + u1 + k) (inter_scheme l U) = take (Suc k + u1 + k) (inter_scheme l U')"
+      using take_initial_segment init by blast
+    then have \<section>: "c @ a @ d = c' @ a' @ d'"
+      by (metis append.assoc Ueq Ueq' concat.simps take)
+    have "length (inter_scheme l U) = Suc k + (c @ a @ d)!k + k + last d"
+      by (simp add: Ueq c d length_interact nth_append len_eqk flip: len)
+    moreover
+    have "length (inter_scheme l U') = Suc k + (c' @ a' @ d')!k + k + last d'"
+      by (simp add: Ueq' c' d' length_interact nth_append len_eqk flip: len')
+    moreover have "last d = last d'"
+      using "\<section>" au1 au1' len_eqk by auto
+    ultimately have "length (inter_scheme l U) = length (inter_scheme l U')"
+      by (simp add: \<section>)
+    then show False
+      using init initial_segment_length_eq ne by blast
+  qed
+qed
+
+
+subsection \<open>Larson's Lemma 3.6\<close>
+
+proposition lemma_3_6:
+  fixes g
+  assumes g: "g \<in> [WW]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
+  obtains N j where "infinite N"
+    and "\<And>k u. \<lbrakk>k > 0; u \<in> [WW]\<^bsup>2\<^esup>; Form k u; [enum N k] < inter_scheme k u; List.set (inter_scheme k u) \<subseteq> N\<rbrakk> \<Longrightarrow> g u = j k"
+proof -
+  define \<Phi> where "\<Phi> \<equiv> \<lambda>m::nat. \<lambda>M. infinite M \<and> m < Inf M"
+  define \<Psi> where "\<Psi> \<equiv> \<lambda>l m n::nat. \<lambda>M N j. n > m \<and> N \<subseteq> M \<and> n \<in> M \<and> (\<forall>U. Form l U \<and> U \<subseteq> WW \<and> [n] < inter_scheme l U \<and> list.set (inter_scheme l U) \<subseteq> N \<longrightarrow> g U = j)"
+  { fix l m::nat and M :: "nat set"
+    assume "l > 0" "\<Phi> m M"
+    let ?A = "inter_scheme l ` {U \<in> [WW]\<^bsup>2\<^esup>. Form l U}"
+    define h where "h \<equiv> \<lambda>zs. g (inv_into {U \<in> [WW]\<^bsup>2\<^esup>. Form l U} (inter_scheme l) zs)"
+    have "thin ?A"
+      using \<open>l > 0\<close> lemma_3_11 by (simp add: thin_def)
+    moreover
+    have "?A \<subseteq> WW"
+      using inter_scheme_simple \<open>0 < l\<close> by blast
+    moreover
+    have "h ` {l \<in> ?A. List.set l \<subseteq> M} \<subseteq> {..<2}"
+      using g inv_into_into[of concl: "{U \<in> [WW]\<^bsup>2\<^esup>. Form l U}" "inter_scheme l"]
+      by (force simp: h_def Pi_iff)
+    ultimately
+    obtain j N where "j < 2" "infinite N" "N \<subseteq> M" and hj: "h ` {l \<in> ?A. List.set l \<subseteq> N} \<subseteq> {j}"
+      using \<open>\<Phi> m M\<close> unfolding \<Phi>_def by (blast intro: Nash_Williams_WW [of M])
+    define n where "n \<equiv> Inf N"
+    have "n > m"
+      using \<open>\<Phi> m M\<close> \<open>infinite N\<close> unfolding n_def \<Phi>_def Inf_nat_def infinite_nat_iff_unbounded
+      by (metis LeastI_ex \<open>N \<subseteq> M\<close> le_less_trans not_less not_less_Least subsetD)
+    have "g U = j" if "Form l U" "U \<subseteq> WW" "[n] < inter_scheme l U" "list.set (inter_scheme l U) \<subseteq> N - {n}" for U
+    proof -
+      obtain xs ys where xys: "xs \<noteq> ys" "U = {xs,ys}"
+        using Form_elim_upair \<open>Form l U\<close> by blast
+      moreover have "inj_on (inter_scheme l) {U \<in> [WW]\<^bsup>2\<^esup>. Form l U}"
+        by (metis (mono_tags, lifting) inter_scheme_injective \<open>0 < l\<close> inj_onI mem_Collect_eq)
+      moreover have "g (inv_into {U \<in> [WW]\<^bsup>2\<^esup>. Form l U} (inter_scheme l) (inter_scheme l U)) = j"
+        using hj that xys
+        apply (simp add: h_def image_subset_iff image_iff)
+        by (metis (no_types, lifting) Diff_subset doubleton_in_nsets_2 dual_order.trans)
+      ultimately show ?thesis
+        using that by auto
+    qed
+    moreover have "n < Inf (N - {n})"
+      unfolding n_def
+      by (metis Diff_iff Inf_nat_def Inf_nat_def1 \<open>infinite N\<close> finite.emptyI infinite_remove linorder_neqE_nat not_less_Least singletonI)
+    moreover have "n \<in> M"
+      by (metis Inf_nat_def1 \<open>N \<subseteq> M\<close> \<open>infinite N\<close> finite.emptyI n_def subsetD)
+    ultimately have "\<Phi> n (N - {n}) \<and> \<Psi> l m n M (N - {n}) j"
+      using \<open>\<Phi> m M\<close> \<open>infinite N\<close> \<open>N \<subseteq> M\<close> \<open>n > m\<close> by (auto simp: \<Phi>_def \<Psi>_def)
+    then have "\<exists>n N j. \<Phi> n N \<and> \<Psi> l m n M N j"
+      by blast
+  } note * = this
+  have base: "\<Phi> 0 {0<..}"
+    unfolding \<Phi>_def by (metis infinite_Ioi Inf_nat_def1 greaterThan_iff greaterThan_non_empty)
+  have step: "Ex (\<lambda>(n,N,j). \<Phi> n N \<and> \<Psi> l m n M N j)" if "\<Phi> m M" "l > 0" for m M l
+    using * [of l m M] that by (auto simp: \<Phi>_def)
+  define G where "G \<equiv> \<lambda>l m M. @(n,N,j). \<Phi> n N \<and> \<Psi> (Suc l) m n M N j"
+  have G\<Phi>: "(\<lambda>(n,N,j). \<Phi> n N) (G l m M)" and G\<Psi>: "(\<lambda>(n,N,j). \<Psi> (Suc l) m n M N j) (G l m M)"
+    if "\<Phi> m M" for l m M
+    using step [OF that, of "Suc l"] by (force simp: G_def dest: some_eq_imp)+
+  have G_increasing: "(\<lambda>(n,N,j). n > m \<and> N \<subseteq> M \<and> n \<in> M) (G l m M)"  if "\<Phi> m M" for l m M
+    using G\<Psi> [OF that, of l] that by (simp add: \<Psi>_def split: prod.split_asm)
+  define H where "H \<equiv> rec_nat (0,{0<..},0) (\<lambda>l (m,M,j). G l m M)"
+  have H_simps: "H 0 = (0,{0<..},0)" "\<And>l. H (Suc l) = (case H l of (m,M,j) \<Rightarrow> G l m M)"
+    by (simp_all add: H_def)
+  have H\<Phi>: "(\<lambda>(n,N,j). \<Phi> n N) (H l)" for l
+  proof (induction l)
+    case 0
+    with base show ?case
+      by (auto simp: H_simps)
+  next
+    case (Suc l)
+    with G\<Phi> show ?case
+      by (force simp: H_simps split: prod.split prod.split_asm)
+  qed
+  define \<nu> where "\<nu> \<equiv> (\<lambda>l. case H l of (n,M,j) \<Rightarrow> n)"
+  have H_inc: "\<nu> l \<ge> l" for l
+  proof (induction l)
+    case 0
+    then show ?case
+      by auto
+  next
+    case (Suc l)
+    then show ?case
+      using H\<Phi> G_increasing [of "\<nu> l"]
+      apply (auto simp: H_simps \<nu>_def split: prod.split prod.split_asm)
+      by (metis (mono_tags, lifting) Suc_leI Suc_le_mono case_prod_conv dual_order.trans)
+  qed
+  let ?N = "range \<nu>"
+  define j where "j \<equiv> \<lambda>l. case H l of (n,M,j) \<Rightarrow> j"
+  have H_increasing_Suc: "(case H k of (n, N, j') \<Rightarrow> N) \<supseteq> (case H (Suc k) of (n, N, j') \<Rightarrow> insert n N)" for k
+    using H\<Phi> [of k]
+    by (force simp: H_simps split: prod.split dest: G_increasing [where l=k])
+  have H_increasing_superset: "(case H k of (n, N, j') \<Rightarrow> N) \<supseteq> (case H (n+k) of (n, N, j') \<Rightarrow> N)" for k n
+  proof (induction n arbitrary:)
+    case (Suc n)
+    then show ?case
+      using H_increasing_Suc [of "n+k"] by (auto split: prod.split_asm)
+  qed auto
+  then have H_increasing_less: "(case H k of (n, N, j') \<Rightarrow> N) \<supseteq> (case H l of (n, N, j') \<Rightarrow> insert n N)"
+    if "k<l" for k l
+    by (metis (no_types, lifting) H_increasing_Suc add.commute less_imp_Suc_add order_trans that)
+
+  have "\<nu> k < \<nu> (Suc k)" for k
+    using H\<Phi> [of k] unfolding \<nu>_def
+    by (auto simp: H_simps split: prod.split dest: G_increasing [where l=k])
+  then have strict_mono_\<nu>: "strict_mono \<nu>"
+    by (simp add: strict_mono_Suc_iff)
+  then have enum_N: "enum ?N = \<nu>"
+    by (metis enum_works nat_infinite_iff range_strict_mono_ext)
+  have **: "?N \<inter> {n<..} \<subseteq> N'" if H: "H k = (n, N', j)" for n N' k j
+  proof clarify
+    fix l
+    assume "n < \<nu> l"
+    then have False if "l \<le> k"
+      using that strict_monoD [OF strict_mono_\<nu>, of l k ] H by (force simp: \<nu>_def)
+    then have "k < l"
+      using not_less by blast
+    then obtain M j where Mj: "H l = (\<nu> l,M,j)"
+      unfolding \<nu>_def
+      by (metis (mono_tags, lifting) case_prod_conv old.prod.exhaust)
+    then show "\<nu> l \<in> N'"
+      using that H_increasing_less [OF \<open>k<l\<close>] Mj by auto
+  qed
+  show thesis
+  proof
+    show "infinite (?N::nat set)"
+      using H_inc infinite_nat_iff_unbounded_le by auto
+  next
+    fix l U
+    assume "0 < l" and U: "U \<in> [WW]\<^bsup>2\<^esup>"
+      and interU: "[enum ?N l] < inter_scheme l U" "Form l U"
+      and sub: "list.set (inter_scheme l U) \<subseteq> ?N"
+    obtain k where k: "l = Suc k"
+      using \<open>0 < l\<close> gr0_conv_Suc by blast
+    have "U \<subseteq> WW"
+      using U by (auto simp: nsets_def)
+    moreover
+    have "g U = v" if "H k = (m, M, j0)" and "G k m M = (n, N', v)"
+      for m M j0 n N' v
+    proof -
+      have n: "\<nu> (Suc k) = n"
+        using that by (simp add: \<nu>_def H_simps)
+      have "{..enum (range \<nu>) l} \<inter> list.set (inter_scheme l U) = {}"
+        using inter_scheme_strict_sorted \<open>0 < l\<close> interU singleton_less_list_iff strict_sorted_iff by blast
+      then have "list.set (inter_scheme (Suc k) U) \<subseteq> N'"
+        using that sub ** [of "Suc k" n N' v] Suc_le_eq not_less_eq_eq
+        by (fastforce simp add:  k n enum_N H_simps)
+      then show ?thesis
+        using that interU \<open>U \<subseteq> WW\<close> G\<Psi> [of m M k] H\<Phi> [of k]
+        by (auto simp: \<Psi>_def k enum_N H_simps n)
+    qed
+    ultimately show "g U = j l"
+      by (auto simp: k j_def H_simps split: prod.split)
+  qed
+qed
+
+
+subsection \<open>Larson's Lemma 3.7\<close>
+
+subsubsection \<open>Preliminaries\<close>
+
+text \<open>Analogous to @{thm [source] ordered_nsets_2_eq}, but without type classes\<close>
+lemma total_order_nsets_2_eq:
+  assumes tot: "total_on A r" and irr: "irrefl r"
+  shows "nsets A 2 = {{x,y} | x y. x \<in> A \<and> y \<in> A \<and> (x,y) \<in> r}"
+     (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 tot total_on_def)
+  show "?rhs \<subseteq> nsets A 2"
+    using irr unfolding numeral_nat by (force simp: nsets_def card_Suc_eq irrefl_def)
+qed
+
+lemma lenlex_nsets_2_eq: "nsets A 2 = {{x,y} | x y. x \<in> A \<and> y \<in> A \<and> (x,y) \<in> lenlex less_than}"
+  using total_order_nsets_2_eq by (simp add: total_order_nsets_2_eq irrefl_def)
+
+lemma sum_sorted_list_of_set_map: "finite I \<Longrightarrow> sum_list (map f (list_of I)) = sum f I"
+proof (induction "card I" arbitrary: I)
+  case 0
+  then show ?case
+    by auto
+next
+  case (Suc n I)
+  then have [simp]: "I \<noteq> {}"
+    by auto
+  moreover have "sum_list (map f (list_of (I - {Min I}))) = sum f (I - {Min I})"
+    using Suc by auto
+  ultimately show ?case
+    using Suc.prems sum.remove [of I "Min I" f]
+    by (simp add: sorted_list_of_set_nonempty Suc)
+qed
+
+
+lemma sorted_list_of_set_UN_eq_concat:
+  assumes I: "strict_mono_sets I f" "finite I" and fin: "\<And>i. finite (f i)"
+  shows "list_of (\<Union>i \<in> I. f i) = concat (map (list_of \<circ> f) (list_of I))"
+  using I
+proof (induction "card I" arbitrary: I)
+  case 0
+  then have "I={}" by auto
+  then show ?case by auto
+next
+  case (Suc n I)
+  then have "I \<noteq> {}" and Iexp: "I = insert (Min I) (I - {Min I})"
+    using Min_in Suc.hyps(2) Suc.prems(2) by fastforce+
+  have IH: "list_of (\<Union> (f ` (I - {Min I}))) = concat (map (list_of \<circ> f) (list_of (I - {Min I})))"
+    using Suc
+    by (metis DiffE Min_in \<open>I \<noteq> {}\<close> card_Diff_singleton diff_Suc_1 finite_Diff strict_mono_sets_def)
+  have "list_of (\<Union> (f ` I)) = list_of (\<Union> (f ` (insert (Min I) (I - {Min I}))))"
+    using Iexp by auto
+  also have "\<dots> = list_of (f (Min I) \<union> \<Union> (f ` (I - {Min I})))"
+    by (metis Union_image_insert)
+  also have "\<dots> = list_of (f (Min I)) @ list_of (\<Union> (f ` (I - {Min I})))"
+  proof (rule sorted_list_of_set_Un)
+    show "less_sets (f (Min I)) (\<Union> (f ` (I - {Min I})))"
+      using Suc.prems \<open>I \<noteq> {}\<close> strict_mono_less_sets_Min by blast
+    show "finite (\<Union> (f ` (I - {Min I})))"
+      by (simp add: \<open>finite I\<close> fin)
+  qed (use fin in auto)
+  also have "\<dots> = list_of (f (Min I)) @ concat (map (list_of \<circ> f) (list_of (I - {Min I})))"
+    using IH by metis
+  also have "\<dots> = concat (map (list_of \<circ> f) (list_of I))"
+    by (simp add: Suc.prems(2) \<open>I \<noteq> {}\<close> sorted_list_of_set_nonempty)
+  finally show ?case .
+qed
+
+subsubsection \<open>Lemma 3.7 of Jean A. Larson, ibid.\<close>
+
+text \<open>Possibly should be redone using grab\<close>
+proposition lemma_3_7:
+  assumes "infinite N" "l > 0"
+  obtains M where "M \<in> [WW]\<^bsup>m\<^esup>"
+                  "\<And>U. U \<in> [M]\<^bsup>2\<^esup> \<Longrightarrow> Form l U \<and> List.set (inter_scheme l U) \<subseteq> N"
+proof (cases "m < 2")
+  case True
+  obtain w where w: "w \<in> WW"
+    using WW_def strict_sorted_into_WW by auto
+  define M where "M \<equiv> if m=0 then {} else {w}"
+  have M: "M \<in> [WW]\<^bsup>m\<^esup>"
+    using True by (auto simp: M_def nsets_def w)
+  have [simp]: "[M]\<^bsup>2\<^esup> = {}"
+    using True by (auto simp: M_def nsets_def w dest: subset_singletonD)
+  show ?thesis
+    using M that by fastforce
+next
+  case False
+  then have "m \<ge> 2"
+    by auto
+  have nonz: "(enum N \<circ> Suc) i > 0" for i
+    using assms(1) le_enumerate less_le_trans by fastforce
+  note infinite_nxtN [OF \<open>infinite N\<close>, iff]
+
+  have [simp]: "{n<..<Suc n} = {}" for n
+    by auto
+
+  define DF where "DF \<equiv> \<lambda>k. rec_nat ((enum N \<circ> Suc) ` {..<Suc k}) (\<lambda>r D. enum (nxt N (enum (nxt N (Max D)) (Inf D - Suc 0))) ` {..<Suc k})"
+  have DF_simps: "DF k 0 = (enum N \<circ> Suc) ` {..<Suc k}"
+    "DF k (Suc i) = enum (nxt N (enum (nxt N (Max (DF k i))) (Inf (DF k i) - Suc 0))) ` {..<Suc k}" for i k
+    by (auto simp: DF_def)
+
+  have card_DF: "card (DF k i) = Suc k" for i k
+  proof (induction i)
+    case 0
+    have "inj_on (enum N \<circ> Suc) {..<Suc k}"
+      by (simp add: assms(1) comp_inj_on strict_mono_enum strict_mono_imp_inj_on)
+    with 0 show ?case
+      using card_image DF_simps by fastforce
+  next
+    case (Suc i)
+    then show ?case
+      by (simp add: \<open>infinite N\<close> DF_simps card_image infinite_nxtN strict_mono_enum strict_mono_imp_inj_on)
+  qed
+  have DF_ne: "DF k i \<noteq> {}" for i k
+    by (metis card_DF card_lessThan lessThan_empty_iff nat.simps(3))
+  have DF_N: "DF k i \<subseteq> N \<inter> {0<..}" for i k
+  proof (induction i)
+    case 0
+    then show ?case
+      using \<open>infinite N\<close> range_enum nonz by (auto simp: DF_simps)
+  next
+    case (Suc i)
+    then show ?case
+      unfolding DF_simps image_subset_iff
+      using infinite_nxtN [OF \<open>infinite N\<close>]
+      by (metis Int_iff enumerate_in_set greaterThan_iff not_gr0 not_less0 nxt_def)
+  qed
+  then have DF_gt0: "0 < Inf (DF k i)" for i k
+    using DF_ne Inf_nat_def1 by blast
+  have finite_DF: "finite (DF k i)" for i k
+    by (induction i) (auto simp: DF_simps)
+
+  have sm_enum_DF: "strict_mono_on (enum (DF k i)) {..k}" for k i
+    by (metis card_DF enum_works_finite finite_DF lessThan_Suc_atMost)
+
+  have DF_Suc: "less_sets (DF k i) (DF k (Suc i))" for i k
+    unfolding less_sets_def
+    by (force simp: finite_DF DF_simps
+        intro!: greaterThan_less_enum nxt_subset_greaterThan atLeast_le_enum nxt_subset_atLeast infinite_nxtN [OF \<open>infinite N\<close>])
+  have DF_DF: "less_sets (DF k i) (DF k j)" if "i<j" for i j k
+    by (meson DF_Suc DF_ne UNIV_I less_sets_imp_strict_mono_sets strict_mono_setsD that)
+  then have sm_DF: "strict_mono_sets UNIV (DF k)" for k
+    by (simp add: strict_mono_sets_def)
+
+  define AF where "AF \<equiv> \<lambda>k i. enum (nxt N (Max (DF k i))) ` {..<Inf (DF k i)}"
+  have AF_ne: "AF k i \<noteq> {}" for i k
+    by (auto simp: AF_def lessThan_empty_iff DF_gt0)
+  have finite_AF [simp]: "finite (AF k i)" for i k
+    by (simp add: AF_def)
+  have card_AF: "card (AF k i) = \<Sqinter> (DF k i)" for k i
+    by (simp add: AF_def \<open>infinite N\<close> card_image inj_enum_nxt)
+
+  have DF_AF: "less_sets (DF k i) (AF k i)" for i k
+    unfolding less_sets_def AF_def
+    by (simp add: finite_DF \<open>infinite N\<close> greaterThan_less_enum nxt_subset_greaterThan)
+
+  have AF_DF_Suc: "less_sets (AF k i) (DF k (Suc i))" for i k
+    apply (clarsimp simp: DF_simps less_sets_def AF_def)
+    using strict_monoD [OF strict_mono_enum]
+    by (metis DF_gt0 Suc_pred assms(1) dual_order.order_iff_strict greaterThan_less_enum
+        infinite_nxtN linorder_neqE_nat not_less_eq nxt_subset_greaterThan)
+
+  have AF_DF: "less_sets (AF k p) (DF k q)" if "p<q" for k p q
+    using AF_DF_Suc
+    by (metis DF_ne Suc_lessI UNIV_I less_sets_trans sm_DF strict_mono_sets_def that)
+
+  have AF_Suc: "less_sets (AF k i) (AF k (Suc i))" for i k
+    using AF_DF_Suc DF_AF DF_ne less_sets_trans by blast
+  then have sm_AF: "strict_mono_sets UNIV (AF k)" for k
+    by (simp add: AF_ne less_sets_imp_strict_mono_sets)
+
+  define del where "del \<equiv> \<lambda>k i j. enum (DF k i) j - enum (DF k i) (j - Suc 0)"
+
+  define QF where "QF k \<equiv> wfrec pair_less (\<lambda>f (j,i).
+       if j=0 then AF k i
+       else let r = (if i=0 then f (j-1,m-1) else f (j,i-1)) in
+                enum (nxt N (Suc (Max r))) ` {..< del k (if j=k then m - Suc i else i) j})"
+    for k
+  note cut_apply [simp]
+
+  have finite_QF [simp]: "finite (QF k p)" for p k
+    using wf_pair_less
+  proof (induction p rule: wf_induct_rule)
+    case (less p)
+    then show ?case
+      by (simp add: def_wfrec [OF QF_def, of k p] split: prod.split)
+  qed
+
+  have del_gt_0: "\<lbrakk>j < Suc k; 0 < j\<rbrakk> \<Longrightarrow> 0 < del k i j" for i j k
+    by (simp add: card_DF del_def finite_DF)
+
+  have QF_ne [simp]: "QF k (j,i) \<noteq> {}" if j: "j < Suc k" for j i k
+    using wf_pair_less j
+  proof (induction "(j,i)" rule: wf_induct_rule)
+    case less
+    then show ?case
+      by (auto simp: def_wfrec [OF QF_def, of k "(j,i)"] AF_ne lessThan_empty_iff del_gt_0)
+  qed
+
+  have QF_0 [simp]: "QF k (0,i) = AF k i" for i k
+    by (simp add: def_wfrec [OF QF_def])
+
+  have QF_Suc: "QF k (Suc j,0) = enum (nxt N (Suc (Max (QF k (j, m - Suc 0))))) `
+                       {..< del k (if Suc j = k then m - 1 else 0) (Suc j)}" for j k
+    apply (simp add: def_wfrec [OF QF_def, of k "(Suc j,0)"])
+    apply (simp add: pair_less_def cut_def)
+    done
+
+  have QF_Suc_Suc: "QF k (Suc j, Suc i)
+                  = enum (nxt N (Suc (Max (QF k (Suc j, i))))) ` {..< del k (if Suc j = k then m - Suc(Suc i) else Suc i) (Suc j)}"
+    for i j k
+    by (simp add: def_wfrec [OF QF_def, of k "(Suc j,Suc i)"])
+
+  have less_QF1: "less_sets (QF k (j, m - Suc 0)) (QF k (Suc j,0))" for j k
+    by (auto simp: def_wfrec [OF QF_def, of k "(Suc j,0)"] pair_lessI1 \<open>infinite N\<close> enum_nxt_ge
+        intro!: less_sets_weaken2 [OF less_sets_Suc_Max])
+
+  have less_QF2: "less_sets (QF k (j,i)) (QF k (j, Suc i))" for j i k
+    by (auto simp: def_wfrec [OF QF_def, of k "(j, Suc i)"] pair_lessI2 \<open>infinite N\<close> enum_nxt_ge
+        intro: less_sets_weaken2 [OF less_sets_Suc_Max] strict_mono_setsD [OF sm_AF])
+
+  have less_QF_same: "less_sets (QF k (j,i')) (QF k (j,i))"
+    if "i' < i" "j \<le> k" for i' i j k
+  proof (rule strict_mono_setsD [OF less_sets_imp_strict_mono_sets [of "\<lambda>i. QF k (j,i)"]])
+    show "less_sets (QF k (j, i)) (QF k (j, Suc i))" for i
+      by (simp add: less_QF2)
+    show "QF k (j, i) \<noteq> {}" if "0 < i" for i
+      using that by (simp add: \<open>j \<le> k\<close> le_imp_less_Suc)
+  qed (use that in auto)
+
+  have less_QF_step: "less_sets (QF k (j - Suc 0, i')) (QF k (j,i))"
+    if "0 < j" "j \<le> k" "i' < m" for j i' i k
+  proof -
+    have less_QF1': "less_sets (QF k (j - Suc 0, m - Suc 0)) (QF k (j,0))" if "j > 0" for j
+      by (metis less_QF1 that Suc_pred)
+    have \<section>: "less_sets (QF k (j - Suc 0, i')) (QF k (j,0))"
+    proof (cases "i' = m - Suc 0")
+      case True
+      then show ?thesis
+        using less_QF1' \<open>0 < j\<close> by blast
+    next
+      case False
+      show ?thesis
+        using False that less_sets_trans [OF less_QF_same less_QF1' QF_ne] by auto
+    qed
+    then show ?thesis
+      by (metis QF_ne less_QF_same less_Suc_eq_le less_sets_trans \<open>j \<le> k\<close> zero_less_iff_neq_zero)
+  qed
+
+  have less_QF: "less_sets (QF k (j',i')) (QF k (j,i))"
+    if j: "j' < j" "j \<le> k" and i: "i' < m" "i < m" for j' j i' i k
+    using j
+  proof (induction "j-j'" arbitrary: j)
+    case 0
+    then show ?case
+      by auto
+  next
+    case (Suc d)
+    then have eq: "d = (j - Suc 0) - j'"
+      by linarith
+    show ?case
+    proof (cases "j' < j - Suc 0")
+      case True
+      then have "less_sets (QF k (j', i')) (QF k (j - Suc 0, i))"
+        using Suc eq by auto
+      then show ?thesis
+        by (rule less_sets_trans [OF _ less_QF_step QF_ne]) (use Suc i in auto)
+    next
+      case False
+      then have "j' = j - Suc 0"
+        using \<open>j' < j\<close> by linarith
+      then show ?thesis
+        using Suc.hyps \<open>j \<le> k\<close> less_QF_step i by auto
+    qed
+  qed
+
+  have sm_QF: "strict_mono_sets ({..k} \<times> {..<m}) (QF k)" for k
+    unfolding strict_mono_sets_def
+  proof (intro strip)
+    fix p q
+    assume p: "p \<in> {..k} \<times> {..<m}" and q: "q \<in> {..k} \<times> {..<m}" and "p < q"
+    then obtain j' i' j i where \<section>: "p = (j',i')" "q = (j,i)" "i' < m" "i < m" "j' \<le> k" "j \<le> k"
+      using surj_pair [of p] surj_pair [of q] by blast
+    with \<open>p < q\<close> have "j' < j \<or> j' = j \<and> i' < i"
+      by auto
+    then show "less_sets (QF k p) (QF k q)"
+    proof (elim conjE disjE)
+      assume "j' < j"
+      show "less_sets (QF k p) (QF k q)"
+        by (simp add: \<section> \<open>j' < j\<close> less_QF that)
+    qed (use \<section> in \<open>simp add: that less_QF_same\<close>)
+  qed
+  then have sm_QF1: "strict_mono_sets {..<ka} (\<lambda>j. QF k (j,i))"
+    if "i<m" "Suc k \<ge> ka" "ka \<ge> k" for ka k i
+  proof -
+    have "{..<ka} \<subseteq> {..k}"
+      by (metis lessThan_Suc_atMost lessThan_subset_iff \<open>Suc k \<ge> ka\<close>)
+    then show ?thesis
+      by (simp add: less_QF strict_mono_sets_def subset_iff that)
+  qed
+
+  have disjoint_QF: "i'=i \<and> j'=j" if "\<not> disjnt (QF k (j', i')) (QF k (j,i))" "j' \<le> k" "j \<le> k" "i' < m" "i < m" for i' i j' j k
+    using that strict_mono_sets_imp_disjoint [OF sm_QF]
+    by (force simp: pairwise_def)
+
+  have card_QF: "card (QF k (j,i)) = (if j=0 then \<Sqinter> (DF k i) else del k (if j = k then m - Suc i else i) j)"
+    for i k j
+  proof (cases j)
+    case 0
+    then show ?thesis
+      by (simp add: AF_def card_image \<open>infinite N\<close> inj_enum_nxt)
+  next
+    case (Suc j')
+    show ?thesis
+      by (cases i; simp add: Suc QF_Suc QF_Suc_Suc card_image \<open>infinite N\<close> inj_enum_nxt)
+  qed
+  have AF_non_Nil: "list_of (AF k i) \<noteq> []" for k i
+    by (simp add: AF_ne)
+  have QF_non_Nil: "list_of (QF k (j,i)) \<noteq> []" if "j < Suc k" for i j k
+    by (simp add: that)
+
+  have AF_subset_N: "AF k i \<subseteq> N" for i k
+    unfolding AF_def image_subset_iff
+    using nxt_subset enumerate_in_set infinite_nxtN \<open>infinite N\<close> by blast
+
+  have QF_subset_N: "QF k (j,i) \<subseteq> N" for i j k
+  proof (induction j)
+    case 0
+    with AF_subset_N show ?case
+      by auto
+  next
+    case (Suc j)
+    show ?case
+      by (cases i) (use nxt_subset enumerate_in_set in \<open>(force simp: QF_Suc QF_Suc_Suc)+\<close>)
+  qed
+
+  obtain ka k where "k>0" and kka: "k \<le> ka" "ka \<le> Suc k" "l = ((ka+k) - Suc 0)"
+  proof -
+    consider (odd) k where "l = 2*k - Suc 0" "k > 0" | (even) k where "l = 2*k" "k > 0"
+      by (metis One_nat_def \<open>l > 0\<close> form_cases not_gr0)
+    then show thesis
+    proof cases
+      case odd
+      then show ?thesis
+        by (metis lessI less_or_eq_imp_le mult_2 that)
+    next
+      case even
+      then show ?thesis
+        by (metis add_Suc diff_Suc_Suc lessI less_or_eq_imp_le minus_nat.diff_0 mult_2 that)
+    qed
+  qed
+  then have "ka > 0"
+    using dual_order.strict_trans1 by blast
+  have ka_k_or_Suc: "ka = k \<or> ka = Suc k"
+    using kka by linarith
+  have lessThan_k: "{..<k} = insert 0 {0<..<k}" if "k>0" for k::nat
+    using that by auto
+  then have sorted_list_of_set_k: "list_of {..<k} = 0 # list_of {0<..<k}" if "k>0" for k::nat
+    using sorted_list_of_set_insert [of concl: 0 "{0<..<k}"] that by simp
+
+  define RF where "RF \<equiv> \<lambda>j i. if j = k then QF k (j, m - Suc i) else QF k (j,i)"
+  have RF_subset_N: "RF j i \<subseteq> N" if "i<m" for i j
+    using that QF_subset_N by (simp add: RF_def)
+  have finite_RF [simp]: "finite (RF k p)" for p k
+    by (simp add: RF_def)
+  have RF_0: "RF 0 i = AF k i" for i
+    using RF_def \<open>0 < k\<close> by auto
+  have disjoint_RF: "i'=i \<and> j'=j" if "\<not> disjnt (RF j' i') (RF j i)" "j' \<le> k" "j \<le> k" "i' < m" "i < m" for i' i j' j
+    using disjoint_QF that
+    by (auto simp: RF_def split: if_split_asm dest: disjoint_QF)
+
+  have sum_card_RF [simp]: "(\<Sum>j\<le>n. card (RF j i)) = enum (DF k i) n" if "n \<le> k" "i < m" for i n
+    using that
+  proof (induction n)
+    case 0
+    then show ?case
+      using DF_ne [of k i] finite_DF [of k i] \<open>k>0\<close>
+      by (simp add: RF_def AF_def card_image \<open>infinite N\<close> inj_enum_nxt enum_0_eq_Inf_finite)
+  next
+    case (Suc n)
+    then have "enum (DF k i) 0 \<le> enum (DF k i) n \<and> enum (DF k i) n \<le> enum (DF k i) (Suc n)"
+      using sm_enum_DF [of k i]
+      apply (simp add: strict_mono_on_def)
+      by (metis Suc_leD dual_order.order_iff_strict le0)
+    with Suc show ?case
+      by (auto simp: RF_def card_QF del_def)
+  qed
+  have DF_in_N: "enum (DF k i) j \<in> N" if "j \<le> k" for i j
+    using DF_N [of k i] card_DF finite_enumerate_in_set finite_DF that
+    by (metis inf.boundedE le_imp_less_Suc subsetD)
+  have Inf_DF_N: "\<Sqinter>(DF k p) \<in> N" for k p
+    using DF_N DF_ne Inf_nat_def1 by blast
+  have RF_in_N: "(\<Sum>j\<le>n. card (RF j i)) \<in> N" if "n \<le> k" "i < m" for i n
+    by (auto simp: DF_in_N that)
+
+  have "ka - Suc 0 \<le> k"
+    using kka(2) by linarith
+  then have sum_card_RF' [simp]:
+    "(\<Sum>j<ka. card (RF j i)) = enum (DF k i) (ka - Suc 0)" if "i < m" for i
+    using sum_card_RF [of "ka - Suc 0" i]
+    by (metis Suc_pred \<open>0 < ka\<close> lessThan_Suc_atMost that)
+
+  have enum_DF_le_iff [simp]:
+    "enum (DF k i) j \<le> enum (DF k i') j \<longleftrightarrow> i \<le> i'" (is "?lhs = _")
+    if "j \<le> k" for i' i j k
+  proof
+    show "i \<le> i'" if ?lhs
+    proof -
+      have "enum (DF k i) j \<in> DF k i"
+        by (simp add: card_DF finite_enumerate_in_set finite_DF le_imp_less_Suc \<open>j \<le> k\<close>)
+      moreover have "enum (DF k i') j \<in> DF k i'"
+        by (simp add: \<open>j \<le> k\<close> card_DF finite_enumerate_in_set finite_DF le_imp_less_Suc that)
+      ultimately have "enum (DF k i') j < enum (DF k i) j" if "i' < i"
+        using sm_DF [of k] by (meson UNIV_I less_sets_def strict_mono_setsD that)
+      then show ?thesis
+        using not_less that by blast
+    qed
+    show ?lhs if "i \<le> i'"
+      using sm_DF [of k] that \<open>j \<le> k\<close> card_DF finite_enumerate_in_set finite_DF le_eq_less_or_eq
+      by (force simp: strict_mono_sets_def less_sets_def finite_enumerate_in_set)
+  qed
+  then have enum_DF_eq_iff[simp]:
+    "enum (DF k i) j = enum (DF k i') j \<longleftrightarrow> i = i'" if "j \<le> k" for i' i j k
+    by (metis le_antisym order_refl that)
+  have enum_DF_less_iff [simp]:
+    "enum (DF k i) j < enum (DF k i') j \<longleftrightarrow> i < i'" if "j \<le> k" for i' i j k
+    by (meson enum_DF_le_iff not_less that)
+
+  have card_AF_sum: "card (AF k i) + (\<Sum>j\<in>{0<..<ka}. card (RF j i)) = enum (DF k i) (ka-1)"
+    if "i < m" for i
+    using that \<open>k > 0\<close>  \<open>k \<le> ka\<close> \<open>ka \<le> Suc k\<close>
+    by (simp add: lessThan_k RF_0 flip: sum_card_RF')
+
+  have sorted_list_of_set_iff [simp]: "list_of {0<..<k} = [] \<longleftrightarrow> k = Suc 0" if "k>0" for k::nat
+  proof -
+    have "list_of {0<..<k} = [] \<longleftrightarrow> {0<..<k} = {}"
+      by simp
+    also have "\<dots> \<longleftrightarrow> k = Suc 0"
+      using \<open>k > 0\<close> atLeastSucLessThan_greaterThanLessThan by fastforce
+    finally show ?thesis .
+  qed
+  show thesis \<comment>\<open>proof of main result\<close>
+  proof
+    have inj: "inj_on (\<lambda>i. list_of (\<Union>j<ka. RF j i)) {..<m}"
+    proof (clarsimp simp: inj_on_def)
+      fix x y
+      assume "x < m" "y < m" "list_of (\<Union>j<ka. RF j x) = list_of (\<Union>j<ka. RF j y)"
+      then have eq: "(\<Union>j<ka. RF j x) = (\<Union>j<ka. RF j y)"
+        by (simp add: sorted_list_of_set_inject)
+      show "x = y"
+      proof -
+        obtain n where n: "n \<in> RF 0 x"
+          using AF_ne QF_0 \<open>0 < k\<close> Inf_nat_def1 \<open>k \<le> ka\<close> by (force simp: RF_def)
+        with eq \<open>ka > 0\<close> obtain j' where "j' < ka" "n \<in> RF j' y"
+          by blast
+        then show ?thesis
+          using disjoint_QF [of k 0 x j'] n \<open>x < m\<close> \<open>y < m\<close> \<open>ka \<le> Suc k\<close> \<open>0 < k\<close>
+          by (force simp: RF_def disjnt_iff simp del: QF_0 split: if_split_asm)
+      qed
+    qed
+
+    define M where "M \<equiv> (\<lambda>i. list_of (\<Union>j<ka. RF j i)) ` {..<m}"
+
+    have "finite M"
+      unfolding M_def by blast
+    moreover have "card M = m"
+      by (simp add: M_def \<open>k \<le> ka\<close> card_image inj)
+    moreover have "M \<subseteq> WW"
+      by (force simp: M_def WW_def)
+    ultimately show "M \<in> [WW]\<^bsup>m\<^esup>"
+      by (simp add: nsets_def)
+
+    have sm_RF: "strict_mono_sets {..<ka} (\<lambda>j. RF j i)" if "i<m" for i
+      using sm_QF1 that kka
+      by (simp add: less_QF RF_def strict_mono_sets_def)
+
+    have RF_non_Nil: "list_of (RF j i) \<noteq> []" if "j < Suc k" for i j
+      using that by (simp add: RF_def)
+
+    have less_RF_same: "less_sets (RF j i') (RF j i)"
+      if "i' < i" "j < k" for i' i j
+      using that by (simp add: less_QF_same RF_def)
+
+    have less_RF_same_k: "less_sets (RF k i') (RF k i)" \<comment>\<open>reversed version for @{term k}\<close>
+      if "i < i'" "i' < m" for i' i
+      using that by (simp add: less_QF_same RF_def)
+
+    show "Form l U \<and> list.set (inter_scheme l U) \<subseteq> N" if "U \<in> [M]\<^bsup>2\<^esup>" for U
+    proof -
+      from that obtain x y where "U = {x,y}" "x \<in> M" "y \<in> M" and xy: "(x,y) \<in> lenlex less_than"
+        by (auto simp: lenlex_nsets_2_eq)
+      let ?R = "\<lambda>p. list_of \<circ> (\<lambda>j. RF j p)"
+      obtain p q where x: "x = list_of (\<Union>j<ka. RF j p)"
+        and y: "y = list_of (\<Union>j<ka. RF j q)" and "p < m" "q < m"
+        using \<open>x \<in> M\<close> \<open>y \<in> M\<close> by (auto simp: M_def)
+      then have pq: "p<q" "length x < length y"
+        using xy \<open>k \<le> ka\<close> \<open>ka \<le> Suc k\<close> lexl_not_refl [OF irrefl_less_than]
+        by (auto simp: lenlex_def sm_RF sorted_list_of_set_UN_lessThan length_concat sum_sorted_list_of_set_map)
+      moreover
+      have xc: "x = concat (map (?R p) (list_of {..<ka}))"
+        by (simp add: x sorted_list_of_set_UN_eq_concat \<open>k \<le> ka\<close> \<open>ka \<le> Suc k\<close> \<open>p < m\<close> sm_RF)
+      have yc: "y = concat (map (?R q) (list_of {..<ka}))"
+        by (simp add: y sorted_list_of_set_UN_eq_concat \<open>k \<le> ka\<close> \<open>ka \<le> Suc k\<close> \<open>q < m\<close> sm_RF)
+      have enum_DF_AF: "enum (DF k p) (ka - Suc 0) < hd (list_of (AF k p))" for p
+      proof (rule less_setsD [OF DF_AF])
+        show "enum (DF k p) (ka - Suc 0) \<in> DF k p"
+          using \<open>ka \<le> Suc k\<close> card_DF finite_DF by (auto simp: finite_enumerate_in_set)
+        show "hd (list_of (AF k p)) \<in> AF k p"
+          using AF_non_Nil finite_AF hd_in_set set_sorted_list_of_set by blast
+      qed
+
+      have less_RF_RF: "less_sets (RF n p) (RF n q)" if "n < k" for n
+        using that \<open>p<q\<close> by (simp add: less_RF_same)
+      have less_RF_Suc: "less_sets (RF n q) (RF (Suc n) q)" if "n < k" for n
+        using \<open>q < m\<close> that by (auto simp: RF_def less_QF)
+      have less_RF_k: "less_sets (RF k q) (RF k p)"
+        using \<open>q < m\<close> less_RF_same_k \<open>p<q\<close> by blast
+      have less_RF_k_ka: "less_sets (RF (k - Suc 0) p) (RF (ka - Suc 0) q)"
+        using ka_k_or_Suc less_RF_RF
+        by (metis One_nat_def RF_def \<open>0 < k\<close> \<open>ka - Suc 0 \<le> k\<close> \<open>p < m\<close> diff_Suc_1 diff_Suc_less less_QF_step)
+      have Inf_DF_eq_enum: "\<Sqinter> (DF k i) = enum (DF k i) 0" for k i
+        by (simp add: Inf_nat_def enumerate_0)
+
+      have Inf_DF_less: "\<Sqinter> (DF k i') < \<Sqinter> (DF k i)" if "i'<i" for i' i k
+        by (metis DF_ne enum_0_eq_Inf enum_0_eq_Inf_finite enum_DF_less_iff le0 that)
+      have AF_Inf_DF_less: "\<And>x. x \<in> AF k i \<Longrightarrow> \<Sqinter> (DF k i') < x" if "i'\<le>i" for i' i
+        using less_setsD [OF DF_AF] DF_ne that
+        by (metis Inf_DF_less Inf_nat_def1 dual_order.order_iff_strict dual_order.strict_trans)
+
+      show ?thesis
+      proof (cases "k=1")
+        case True
+        with kka consider "ka=1" | "ka=2" by linarith
+        then show ?thesis
+        proof cases
+          case 1
+          define zs where "zs = card (AF 1 p) # list_of (AF 1 p)
+                              @ card (AF 1 q) # list_of (AF 1 q)"
+          have zs: "Form_Body ka k x y zs"
+          proof (intro that exI conjI Form_Body.intros [OF \<open>length x < length y\<close>])
+            show "x = concat ([list_of (AF k p)])" "y = concat ([list_of (AF k q)])"
+              by (simp_all add: x y 1 lessThan_Suc RF_0)
+            have "less_sets (AF k p) (insert (\<Sqinter> (DF k q)) (AF k q))"
+              by (metis AF_DF DF_ne Inf_nat_def1 RF_0 \<open>0 < k\<close> insert_iff less_RF_RF less_sets_def pq(1))
+            then have "strict_sorted (list_of (AF k p) @ \<Sqinter> (DF k q) # list_of (AF k q))"
+              by (auto simp: strict_sorted_append_iff intro: less_sets_imp_list_less AF_Inf_DF_less)
+            moreover have "\<And>x. x \<in> AF k q \<Longrightarrow> \<Sqinter> (DF k p) < x"
+              by (meson AF_Inf_DF_less less_imp_le_nat \<open>p < q\<close>)
+            ultimately show "strict_sorted zs"
+              using \<open>p < q\<close> True Inf_DF_less DF_AF DF_ne
+              apply (auto simp: zs_def less_sets_def card_AF AF_Inf_DF_less)
+              by (meson Inf_nat_def1)
+          qed (auto simp: \<open>k=1\<close> \<open>ka=1\<close> acc_lengths.simps zs_def AF_ne)
+          have zs_N: "list.set zs \<subseteq> N"
+            using AF_subset_N by (auto simp: zs_def card_AF Inf_DF_N \<open>k=1\<close>)
+          show ?thesis
+          proof
+            have "l = 1"
+              using kka \<open>k=1\<close> \<open>ka=1\<close> by auto
+            have "Form (2*1-1) {x,y}"
+              using "1" Form.intros(2) True zs by fastforce
+            then show "Form l U"
+              by (simp add: \<open>U = {x,y}\<close> \<open>l = 1\<close>)
+            show "list.set (inter_scheme l U) \<subseteq> N"
+              using kka zs zs_N \<open>k=1\<close> Form_Body_imp_inter_scheme by (fastforce simp add: \<open>U = {x,y}\<close>)
+          qed
+        next
+          case 2
+          note True [simp] note 2 [simp]
+          have [simp]: "{0<..<2} = {Suc 0}"
+            by auto
+          have enum_DF1_eq: "enum (DF (Suc 0) i) (Suc 0) = card (AF (Suc 0) i) + card (RF (Suc 0) i)"
+            if "i < m" for i
+            using card_AF_sum that by simp
+          have card_RF: "card (RF (Suc 0) i) = enum (DF (Suc 0) i) (Suc 0) - enum (DF (Suc 0) i) 0" if "i < m" for i
+            using that by (auto simp: RF_def card_QF del_def)
+          have list_of_AF_RF: "list_of (AF (Suc 0) q \<union> RF (Suc 0) q) = list_of (AF (Suc 0) q) @ list_of (RF (Suc 0) q)"
+            using RF_def \<open>q < m\<close> less_QF_step by (fastforce intro!: sorted_list_of_set_Un)
+
+          define zs where "zs = card (AF 1 p) # (card (AF 1 p) + card (RF 1 p))
+                         # list_of (AF 1 p)
+                  @ (card (AF 1 q) + card (RF 1 q)) # list_of (AF 1 q) @ list_of (RF 1 q) @ list_of (RF 1 p)"
+          have zs: "Form_Body ka k x y zs"
+          proof (intro that exI conjI Form_Body.intros [OF \<open>length x < length y\<close>])
+            have "x = list_of (RF 0 p \<union> RF (Suc 0) p)"
+              by (simp add: x eval_nat_numeral lessThan_Suc RF_0 Un_commute)
+            also have "\<dots> = list_of (RF 0 p) @ list_of (RF (Suc 0) p)"
+              using RF_def True \<open>p < m\<close> less_QF_step
+              by (subst sorted_list_of_set_Un) (fastforce+)
+            finally show "x = concat ([list_of (AF 1 p),list_of (RF 1 p)])"
+              by (simp add: RF_0)
+            show "y = concat [list_of (RF 1 q \<union> AF 1 q)]"
+              by (simp add: y eval_nat_numeral lessThan_Suc RF_0)
+            show "zs = concat [[card (AF 1 p), card (AF 1 p) + card (RF 1 p)], list_of (AF 1 p),
+                              [card (AF 1 q) + card (RF 1 q)], list_of (RF 1 q \<union> AF 1 q)] @ interact [list_of (RF 1 p)] []"
+              using list_of_AF_RF by (simp add: zs_def Un_commute)
+            show "strict_sorted zs"
+            proof (simp add: \<open>p<m\<close> \<open>q<m\<close> \<open>p<q\<close> zs_def strict_sorted_append_iff, intro conjI strip)
+              show "0 < card (RF (Suc 0) p)"
+                using \<open>p<m\<close> by (simp add: card_RF card_DF finite_DF)
+              show "card (AF (Suc 0) p) < card (AF (Suc 0) q) + card (RF (Suc 0) q)"
+                using \<open>p<q\<close> \<open>q<m\<close> by (simp add: Inf_DF_less card_AF trans_less_add1)
+              show "card (AF (Suc 0) p) < x"
+                if "x \<in> AF (Suc 0) p \<union> (AF (Suc 0) q \<union> (RF (Suc 0) q \<union> RF (Suc 0) p))" for x
+                using that
+                apply (simp add: card_AF)
+                by (metis AF_ne DF_AF DF_ne less_RF_RF less_RF_Suc less_RF_k Inf_nat_def1 One_nat_def RF_0 RF_non_Nil True finite_RF lessI less_setsD less_sets_trans sorted_list_of_set_eq_Nil_iff)
+              show "card (AF (Suc 0) p) + card (RF (Suc 0) p) < card (AF (Suc 0) q) + card (RF (Suc 0) q)"
+                using \<open>p < q\<close> \<open>p < m\<close> \<open>q < m\<close> by (metis enum_DF1_eq enum_DF_less_iff le_refl)
+              show "card (AF (Suc 0) p) + card (RF (Suc 0) p) < x"
+                if "x \<in> AF (Suc 0) p \<union> (AF (Suc 0) q \<union> (RF (Suc 0) q \<union> RF (Suc 0) p))" for x
+                using that \<open>p < m\<close>
+                apply (simp add: flip: enum_DF1_eq)
+                by (metis AF_ne DF_AF less_RF_RF less_RF_Suc less_RF_k One_nat_def RF_0 RF_non_Nil Suc_mono True \<open>0 < k\<close> card_DF finite_enumerate_in_set finite_DF less_setsD less_sets_trans sorted_list_of_set_empty)
+              have "list_of (AF (Suc 0) p) < list_of {enum (DF (Suc 0) q) (Suc 0)}"
+              proof (rule less_sets_imp_sorted_list_of_set)
+                show "less_sets (AF (Suc 0) p) {enum (DF (Suc 0) q) (Suc 0)}"
+                  by (metis (no_types, lifting) AF_DF DF_ne Inf_nat_def1 \<open>q < m\<close> card_AF enum_DF1_eq less_setsD less_sets_singleton2 pq(1) trans_less_add1)
+              qed auto
+              then show "list_of (AF (Suc 0) p) < (card (AF (Suc 0) q) + card (RF (Suc 0) q)) # list_of (AF (Suc 0) q) @ list_of (RF (Suc 0) q) @ list_of (RF (Suc 0) p)"
+                using \<open>q < m\<close> by (simp add: less_list_def enum_DF1_eq)
+              show "card (AF (Suc 0) q) + card (RF (Suc 0) q) < x"
+                if "x \<in> AF (Suc 0) q \<union> (RF (Suc 0) q \<union> RF (Suc 0) p)" for x
+                using that \<open>q < m\<close>
+                apply (simp flip: enum_DF1_eq)
+                by (metis AF_ne DF_AF less_RF_Suc less_RF_k One_nat_def RF_0 RF_non_Nil True card_DF finite_enumerate_in_set finite_DF finite_RF lessI less_setsD less_sets_trans sorted_list_of_set_eq_Nil_iff)
+              have "list_of (AF (Suc 0) q) < list_of (RF (Suc 0) q)"
+              proof (rule less_sets_imp_sorted_list_of_set)
+                show "less_sets (AF (Suc 0) q) (RF (Suc 0) q)"
+                  by (metis less_RF_Suc One_nat_def RF_0 True \<open>0 < k\<close>)
+              qed auto
+              then show "list_of (AF (Suc 0) q) < list_of (RF (Suc 0) q) @ list_of (RF (Suc 0) p)"
+                using RF_non_Nil by (auto simp: less_list_def)
+              show "list_of (RF (Suc 0) q) < list_of (RF (Suc 0) p)"
+              proof (rule less_sets_imp_sorted_list_of_set)
+                show "less_sets (RF (Suc 0) q) (RF (Suc 0) p)"
+                  by (metis less_RF_k One_nat_def True)
+              qed auto
+            qed
+            show "[list_of (AF 1 p), list_of (RF 1 p)] \<in> lists (- {[]})"
+              using RF_non_Nil \<open>0 < k\<close> by (auto simp: acc_lengths.simps zs_def AF_ne)
+            show "[card (AF 1 q) + card (RF 1 q)] = acc_lengths 0 [list_of (RF 1 q \<union> AF 1 q)]"
+              using list_of_AF_RF
+              by (auto simp: acc_lengths.simps zs_def AF_ne sup_commute)
+          qed (auto simp: acc_lengths.simps zs_def AF_ne)
+          have zs_N: "list.set zs \<subseteq> N"
+            using \<open>p < m\<close> \<open>q < m\<close> DF_in_N  enum_DF1_eq [symmetric]
+            by (auto simp: zs_def card_AF AF_subset_N RF_subset_N Inf_DF_N)
+          show ?thesis
+          proof
+            have "Form (2*1) {x,y}"
+              by (metis "2" Form.simps Suc_1 True zero_less_one zs)
+            with kka show "Form l U"
+              by (simp add: \<open>U = {x,y}\<close>)
+            show "list.set (inter_scheme l U) \<subseteq> N"
+              using kka zs zs_N \<open>k=1\<close> Form_Body_imp_inter_scheme by (fastforce simp add: \<open>U = {x, y}\<close>)
+          qed
+        qed
+      next
+        case False
+        then have "k \<ge> 2" "ka \<ge> 2"
+          using kka \<open>k>0\<close> by auto
+        then have k_minus_1 [simp]: "Suc (k - Suc (Suc 0)) = k - Suc 0"
+          by auto
+
+        define PP where "PP \<equiv> map (?R p) (list_of {0<..<ka})"
+        define QQ where "QQ \<equiv> map (?R q) (list_of {0<..<k-1}) @ ([list_of (RF (k-1) q \<union> RF (ka-1) q)])"
+        let ?INT = "interact PP QQ"
+        \<comment>\<open>No separate sets A and B as in the text, but instead we treat both cases as once\<close>
+        have [simp]: "length PP = ka - 1"
+          by (simp add: PP_def)
+        have [simp]: "length QQ = k - 1"
+          using \<open>k \<ge> 2\<close> by (simp add: QQ_def)
+
+        have PP_n: "PP ! n = list_of (RF (Suc n) p)"
+          if "n < ka-1" for n
+          using that kka by (auto simp: PP_def nth_sorted_list_of_set_greaterThanLessThan)
+
+        have QQ_n: "QQ ! n = (if n < k - Suc (Suc 0) then list_of (RF (Suc n) q)
+                              else list_of (RF (k - Suc 0) q \<union> RF (ka - Suc 0) q))"
+          if "n < k-1" for n
+          using that kka by (auto simp: QQ_def nth_append nth_sorted_list_of_set_greaterThanLessThan)
+
+        have QQ_n_same: "QQ ! n = list_of (RF (Suc n) q)"
+          if "n < k - Suc 0" "k=ka" for n
+          using that kka Suc_diff_Suc
+          by (fastforce simp add: QQ_def nth_append nth_sorted_list_of_set_greaterThanLessThan)
+
+        have split_nat_interval: "{0<..<n} = insert (n - Suc 0) {0<..<n - Suc 0}" if "n \<ge> 2" for n
+          using that by auto
+        have split_list_interval: "list_of{0<..<n} = list_of{0<..<n - Suc 0} @ [n - Suc 0]" if "n \<ge> 2" for n
+        proof (intro sorted_list_of_set_unique [THEN iffD1] conjI)
+          have "list_of {0<..<n - Suc 0} < [n - Suc 0]"
+            by (auto intro: less_sets_imp_list_less)
+          then show "strict_sorted (list_of {0<..<n - Suc 0} @ [n - Suc 0])"
+            by (auto simp: strict_sorted_append_iff)
+        qed (use \<open>n \<ge> 2\<close> in auto)
+
+        have list_of_RF_Un: "list_of (RF (k - Suc 0) q \<union> RF k q) = list_of (RF (k - Suc 0) q) @ list_of (RF k q)"
+          by (metis less_RF_Suc Suc_pred \<open>0 < k\<close> diff_Suc_less finite_RF sorted_list_of_set_Un)
+
+        have card_AF_sum_QQ: "card (AF k q) + sum_list (map length QQ) = (\<Sum>j<ka. card (RF j q))"
+        proof (cases "ka = Suc k")
+          case True
+          have "RF (k - Suc 0) q \<inter> RF k q = {}"
+            using less_RF_Suc [of "k - Suc 0"] \<open>k > 0\<close> by (auto simp: less_sets_def)
+          then have "card (RF (k - Suc 0) q \<union> RF k q) = card (RF (k - Suc 0) q) + card (RF k q)"
+            by (simp add: card_Un_disjoint)
+          then show ?thesis
+            using \<open>k\<ge>2\<close> \<open>q < m\<close>
+            apply (simp add: QQ_def True flip: RF_0)
+            apply (simp add: lessThan_k split_nat_interval sum_sorted_list_of_set_map)
+            done
+        next
+          case False
+          with kka have "ka=k" by linarith
+          with \<open>k\<ge>2\<close> show ?thesis by (simp add: QQ_def lessThan_k split_nat_interval sum_sorted_list_of_set_map flip: RF_0)
+        qed
+
+        define LENS where "LENS \<equiv> \<lambda>i. acc_lengths 0 (list_of (AF k i) # map (?R i) (list_of {0<..<ka}))"
+        have LENS_subset_N: "list.set (LENS i) \<subseteq> N" if "i < m" for i
+        proof -
+          have eq: "(list_of (AF k i) # map (?R i) (list_of {0<..<ka})) = map (?R i) (list_of {..<ka})"
+            using RF_0 \<open>0 < ka\<close> sorted_list_of_set_k by auto
+          let ?f = "rec_nat [card (AF k i)] (\<lambda>n r. r @ [(\<Sum>j\<le>Suc n. card (RF j i))])"
+          have f: "acc_lengths 0 (map (?R i) (list_of {..v})) = ?f v" for v
+            by (induction v) (auto simp: RF_0 acc_lengths.simps acc_lengths_append sum_sorted_list_of_set_map)
+          have 3: "list.set (?f v) \<subseteq> N" if "v \<le> k" for v
+            using that
+          proof (induction v)
+            case 0
+            have "card (AF k i) \<in> N"
+              by (metis DF_N DF_ne Inf_nat_def1 Int_subset_iff card_AF subsetD)
+            with 0 show ?case by simp
+          next
+            case (Suc v)
+            then have "enum (DF k i) (Suc v) \<in> N"
+              by (metis DF_N Int_subset_iff card_DF finite_enumerate_in_set finite_DF in_mono le_imp_less_Suc)
+            with Suc \<open>i < m\<close> show ?case
+              by (simp del: sum.atMost_Suc)
+          qed
+          show ?thesis
+            unfolding LENS_def
+            by (metis "3" Suc_pred \<open>0 < ka\<close> \<open>ka - Suc 0 \<le> k\<close> eq f lessThan_Suc_atMost)
+        qed
+        define LENS_QQ where "LENS_QQ \<equiv> acc_lengths 0 (list_of (AF k q) # QQ)"
+        have LENS_QQ_subset: "list.set LENS_QQ \<subseteq> list.set (LENS q)"
+        proof (cases "ka = Suc k")
+          case True
+          with \<open>k \<ge> 2\<close> show ?thesis
+            unfolding QQ_def LENS_QQ_def LENS_def
+            by (auto simp: list_of_RF_Un split_list_interval acc_lengths.simps acc_lengths_append)
+        next
+          case False
+          then have "ka=k"
+            using kka by linarith
+          with \<open>k \<ge> 2\<close> show ?thesis
+            by (simp add: QQ_def LENS_QQ_def LENS_def split_list_interval)
+        qed
+        have ss_INT: "strict_sorted ?INT"
+        proof (rule strict_sorted_interact_I)
+          fix n
+          assume "n < length QQ"
+          then have n: "n < k-1"
+            by simp
+          have "n = k - Suc (Suc 0)" if "\<not> n < k - Suc (Suc 0)"
+            using n that by linarith
+          with \<open>p<q\<close> n show "PP ! n < QQ ! n"
+            using \<open>0 < k\<close> \<open>k \<le> ka\<close> \<open>ka \<le> Suc k\<close> \<open>p<q\<close> n
+            by (auto simp: PP_n QQ_n less_RF_same less_sets_imp_sorted_list_of_set less_sets_Un2 less_RF_RF less_RF_k_ka)
+        next
+          fix n
+          have V: "\<lbrakk>Suc n < ka - Suc 0\<rbrakk> \<Longrightarrow> list_of (RF (Suc n) q) < list_of (RF (Suc (Suc n)) p)" for n
+            by (smt One_nat_def RF_def Suc_leI \<open>ka - Suc 0 \<le> k\<close> \<open>q < m\<close> diff_Suc_1 finite_RF less_QF_step less_le_trans less_sets_imp_sorted_list_of_set nat_neq_iff zero_less_Suc)
+          have "less_sets (RF (k -  Suc 0) q) (RF k p)"
+            by (metis less_RF_Suc less_RF_k RF_non_Nil Suc_pred \<open>0 < k\<close> finite_RF lessI less_sets_trans sorted_list_of_set_eq_Nil_iff)
+          with kka have "less_sets (RF (k - Suc 0) q \<union> RF (ka - Suc 0) q) (RF k p)"
+            by (metis less_RF_k One_nat_def less_sets_Un1 antisym_conv2 diff_Suc_1 le_less_Suc_eq)
+          then have VI: "list_of (RF (k - Suc 0) q \<union> RF (ka - Suc 0) q) < list_of (RF k p)"
+            by (rule less_sets_imp_sorted_list_of_set) auto
+          assume "Suc n < length PP"
+          with \<open>ka \<le> Suc k\<close> VI
+          show "QQ ! n < PP ! Suc n"
+            apply (auto simp: PP_n QQ_n less_RF_same less_sets_imp_sorted_list_of_set less_sets_Un1 less_sets_Un2 less_RF_RF less_RF_k_ka V)
+            by (metis One_nat_def Suc_less_eq Suc_pred \<open>0 < k\<close> diff_Suc_1 k_minus_1 ka_k_or_Suc less_SucE)
+        next
+          show "PP \<in> lists (- {[]})"
+            using RF_non_Nil kka
+            by (clarsimp simp: PP_def) (metis RF_non_Nil less_le_trans)
+          show "QQ \<in> lists (- {[]})"
+            using RF_non_Nil kka
+            by (clarsimp simp: QQ_def) (metis RF_non_Nil Suc_pred \<open>0 < k\<close> less_SucI)
+        qed (use kka PP_def QQ_def in auto)
+        then have ss_QQ: "strict_sorted (concat QQ)"
+          using strict_sorted_interact_imp_concat by blast
+
+        obtain zs where zs: "Form_Body ka k x y zs" and zs_N: "list.set zs \<subseteq> N"
+        proof (intro that exI conjI Form_Body.intros [OF \<open>length x < length y\<close>])
+          show "x = concat (list_of (AF k p) # PP)"
+            using \<open>ka > 0\<close> by (simp add: PP_def RF_0 xc sorted_list_of_set_k)
+          let ?YR = "(map (list_of \<circ> (\<lambda>j. RF j q)) (list_of {0<..<ka}))"
+          have "concat ?YR = concat QQ"
+          proof (rule strict_sorted_equal [OF ss_QQ])
+            show "strict_sorted (concat ?YR)"
+            proof (rule strict_sorted_concat_I, simp_all)
+              fix n
+              assume "Suc n < ka - Suc 0"
+              then show "list_of (RF (list_of {0<..<ka} ! n) q) < list_of (RF (list_of {0<..<ka} ! Suc n) q)"
+                by (metis less_RF_Suc Suc_lessD \<open>ka - Suc 0 \<le> k\<close> add.left_neutral finite_RF less_le_trans less_sets_imp_sorted_list_of_set nth_sorted_list_of_set_greaterThanLessThan)
+            next
+              show "?YR \<in> lists (- {[]})"
+                using RF_non_Nil \<open>ka \<le> Suc k\<close> by (auto simp: mem_lists_non_Nil)
+            qed auto
+            show "list.set (concat ?YR) = list.set (concat QQ)"
+              using ka_k_or_Suc
+            proof
+              assume "ka = k"
+              then show "list.set (concat (map (list_of \<circ> (\<lambda>j. RF j q)) (list_of {0<..<ka}))) = list.set (concat QQ)"
+                using \<open>k\<ge>2\<close> by simp (simp add: split_nat_interval QQ_def)
+            next
+              assume "ka = Suc k"
+              then show "list.set (concat (map (list_of \<circ> (\<lambda>j. RF j q)) (list_of {0<..<ka}))) = list.set (concat QQ)"
+                using \<open>k\<ge>2\<close> by simp (auto simp: QQ_def split_nat_interval)
+            qed
+          qed
+          then show "y = concat (list_of (AF k q) # QQ)"
+            using \<open>ka > 0\<close> by (simp add: RF_0 yc sorted_list_of_set_k)
+          show "list_of (AF k p) # PP \<in> lists (- {[]})" "list_of (AF k q) # QQ \<in> lists (- {[]})"
+            using  RF_non_Nil kka by (auto simp: AF_ne PP_def QQ_def eq_commute [of "[]"])
+          show "list.set ((LENS p @ list_of (AF k p) @ LENS_QQ @ list_of (AF k q) @ ?INT)) \<subseteq> N"
+            using AF_subset_N RF_subset_N LENS_subset_N \<open>p < m\<close> \<open>q < m\<close> LENS_QQ_subset
+            by (auto simp: subset_iff PP_def QQ_def)
+          show "length (list_of (AF k p) # PP) = ka" "length (list_of (AF k q) # QQ) = k"
+            using \<open>0 < ka\<close> \<open>0 < k\<close> by auto
+          show "LENS p = acc_lengths 0 (list_of (AF k p) # PP)"
+            by (auto simp: LENS_def PP_def)
+          show "strict_sorted (LENS p @ list_of (AF k p) @ LENS_QQ @ list_of (AF k q) @ ?INT)"
+            unfolding strict_sorted_append_iff
+          proof (intro conjI ss_INT)
+            show "LENS p < list_of (AF k p) @ LENS_QQ @ list_of (AF k q) @ ?INT"
+              using AF_non_Nil [of k p] \<open>k \<le> ka\<close> \<open>ka \<le> Suc k\<close> \<open>p < m\<close> card_AF_sum enum_DF_AF
+              by (simp add: enum_DF_AF less_list_def card_AF_sum LENS_def sum_sorted_list_of_set_map)
+            show "strict_sorted (LENS p)"
+              unfolding LENS_def
+              by (rule strict_sorted_acc_lengths) (use RF_non_Nil AF_non_Nil kka in \<open>auto simp: in_lists_conv_set\<close>)
+            show "strict_sorted LENS_QQ"
+              unfolding LENS_QQ_def QQ_def
+              by (rule strict_sorted_acc_lengths) (use RF_non_Nil AF_non_Nil kka in \<open>auto simp: in_lists_conv_set\<close>)
+            have last_AF_DF: "last (list_of (AF k p)) < \<Sqinter> (DF k q)"
+              using AF_DF [OF \<open>p < q\<close>, of k] AF_non_Nil [of k p] DF_ne [of k q]
+              by (metis Inf_nat_def1 finite_AF last_in_set less_sets_def set_sorted_list_of_set)
+            then show "list_of (AF k p) < LENS_QQ @ list_of (AF k q) @ ?INT"
+              by (simp add: less_list_def card_AF LENS_QQ_def)
+            show "LENS_QQ < list_of (AF k q) @ ?INT"
+              using AF_non_Nil [of k q] \<open>q < m\<close> card_AF_sum enum_DF_AF card_AF_sum_QQ
+              by (auto simp: less_list_def AF_ne hd_append card_AF_sum LENS_QQ_def)
+            show "list_of (AF k q) < ?INT"
+            proof -
+              have "less_sets (AF k q) (RF (Suc 0) p)"
+                using \<open>0 < k\<close> \<open>p < m\<close> \<open>q < m\<close> by (simp add: RF_def less_QF flip: QF_0)
+              then have "last (list_of (AF k q)) < hd (list_of (RF (Suc 0) p))"
+              proof (rule less_setsD)
+                show "last (list_of (AF k q)) \<in> AF k q"
+                  using AF_non_Nil finite_AF last_in_set set_sorted_list_of_set by blast
+                show "hd (list_of (RF (Suc 0) p)) \<in> RF (Suc 0) p"
+                  by (metis RF_non_Nil Suc_mono \<open>0 < k\<close> finite_RF hd_in_set set_sorted_list_of_set)
+              qed
+              with \<open>k > 0\<close> \<open>ka \<ge> 2\<close> RF_non_Nil show ?thesis
+                by (simp add: hd_interact less_list_def sorted_list_of_set_greaterThanLessThan PP_def QQ_def)
+            qed
+          qed auto
+        qed (auto simp: LENS_QQ_def)
+        show ?thesis
+        proof (cases "ka = k")
+          case True
+          then have "l = 2*k - 1"
+            by (simp add: kka(3) mult_2)
+          then show ?thesis
+            by (metis Form.intros(2) Form_Body_imp_inter_scheme True \<open>0 < k\<close> \<open>U = {x, y}\<close> kka zs zs_N)
+        next
+          case False
+          then have "l = 2*k"
+            using kka by linarith
+          then show ?thesis
+            by (metis False Form.intros(3) Form_Body_imp_inter_scheme \<open>0 < k\<close> \<open>U = {x, y}\<close> antisym kka le_SucE zs zs_N)
+        qed
+      qed
+    qed
+  qed
+qed
+
+
+subsection \<open>Larson's Lemma 3.8\<close>
+
+subsubsection \<open>Primitives needed for the inductive construction of @{term b}\<close>
+
+definition IJ where "IJ \<equiv> \<lambda>k. Sigma {..k} (\<lambda>j::nat. {..<j})"
+
+lemma IJ_iff: "u \<in> IJ k \<longleftrightarrow> (\<exists>j i. u = (j,i) \<and> i<j \<and> j\<le>k)"
+  by (auto simp: IJ_def)
+
+lemma finite_IJ: "finite (IJ k)"
+  by (auto simp: IJ_def)
+
+fun prev where
+  "prev 0 0 = None"
+| "prev (Suc 0) 0 = None"
+| "prev (Suc j) 0 = Some (j, j - Suc 0)"
+| "prev j (Suc i) = Some (j,i)"
+
+lemma prev_eq_None_iff: "prev j i = None \<longleftrightarrow> j \<le> Suc 0 \<and> i = 0"
+  by (auto simp: le_Suc_eq elim: prev.elims)
+
+lemma prev_pair_less:
+  "prev j i = Some ji' \<Longrightarrow> (ji', (j,i)) \<in> pair_less"
+  by (auto simp: pair_lessI1 elim: prev.elims)
+
+lemma prev_Some_less: "\<lbrakk>prev j i = Some (j',i'); i \<le> j\<rbrakk> \<Longrightarrow> i' < j'"
+  by (auto elim: prev.elims)
+
+lemma prev_maximal:
+  "\<lbrakk>prev j i = Some (j',i'); (ji'', (j,i)) \<in> pair_less; ji'' \<in> IJ k\<rbrakk>
+   \<Longrightarrow> (ji'', (j',i')) \<in> pair_less \<or> ji'' = (j',i')"
+  by (force simp: IJ_def pair_less_def elim: prev.elims)
+
+lemma pair_less_prev:
+  assumes "(u, (j,i)) \<in> pair_less" "u \<in> IJ k"
+  shows "prev j i = Some u \<or> (\<exists>x. (u, x) \<in> pair_less \<and> prev j i = Some x)"
+proof (cases "prev j i")
+  case None
+  show ?thesis
+  proof (cases u)
+    case (Pair j' i')
+    then show ?thesis
+    using assms None by (simp add: prev_eq_None_iff pair_less_def IJ_def)
+  qed
+next
+  case (Some a)
+  then show ?thesis
+    by (metis assms prev_maximal prod.exhaust_sel)
+qed
+
+
+
+subsubsection \<open>Special primitives for the ordertype proof\<close>
+
+definition USigma :: "'a set set \<Rightarrow> ('a set \<Rightarrow> 'a set) \<Rightarrow> 'a set set"
+  where "USigma \<A> B \<equiv> \<Union>X\<in>\<A>. \<Union>y\<in>B X. {insert y X}"
+
+definition usplit
+  where "usplit f A \<equiv> f (A - {Max A}) (Max A)"
+
+lemma USigma_empty [simp]: "USigma {} B = {}"
+  by (auto simp: USigma_def)
+
+lemma USigma_iff:
+  assumes "\<And>I j. I \<in> \<I> \<Longrightarrow> less_sets I (J I) \<and> finite I"
+  shows "x \<in> USigma \<I> J \<longleftrightarrow> usplit (\<lambda>I j. I\<in>\<I> \<and> j\<in>J I \<and> x = insert j I) x"
+proof -
+  have [simp]: "\<And>I j. \<lbrakk>I \<in> \<I>; j \<in> J I\<rbrakk> \<Longrightarrow> Max (insert j I) = j"
+    by (meson Max_insert2 assms less_imp_le less_sets_def)
+  show ?thesis
+  proof -
+    have "I - {j} \<in> \<I>" if "I \<in> \<I>" "j \<in> J I" for I j
+      using that by (metis Diff_empty Diff_insert0 assms less_irrefl less_sets_def)
+    moreover have "j \<in> J (I - {j})" if "I \<in> \<I>" "j \<in> J I" for I j
+      using that by (metis Diff_empty Diff_insert0 assms less_irrefl less_setsD)
+    moreover have "\<exists>I\<in>\<I>. \<exists>j\<in>J I. x = insert j I"
+      if "x - {Max x} \<in> \<I>" and "Max x \<in> J (x - {Max x})" "x \<noteq> {}"
+      using that by (metis Max_in assms infinite_remove insert_Diff)
+    ultimately show ?thesis
+      by (auto simp: USigma_def usplit_def)
+  qed
+qed
+
+
+lemma ordertype_append_image_IJ:
+  assumes lenB [simp]: "\<And>i j. i \<in> \<I> \<Longrightarrow> j \<in> J i \<Longrightarrow> length (B j) = c"
+    and AB: "\<And>i j. i \<in> \<I> \<Longrightarrow> j \<in> J i \<Longrightarrow> A i < B j"
+    and IJ: "\<And>i. i \<in> \<I> \<Longrightarrow> less_sets i (J i) \<and> finite i"
+    and \<beta>: "\<And>i. i \<in> \<I> \<Longrightarrow> ordertype (B ` J i) (lenlex less_than) = \<beta>"
+    and A: "inj_on A \<I>"
+  shows "ordertype (usplit (\<lambda>i j. A i @ B j) ` USigma \<I> J) (lenlex less_than)
+       = \<beta> * ordertype (A ` \<I>) (lenlex less_than)"
+    (is "ordertype ?AB ?R = _ * ?\<alpha>")
+proof (cases "\<I> = {}")
+next
+  case False
+  have "Ord \<beta>"
+    using \<beta> False wf_Ord_ordertype by fastforce
+  show ?thesis
+  proof (subst ordertype_eq_iff)
+    define split where "split \<equiv> \<lambda>l::nat list. (take (length l - c) l, (drop (length l - c) l))"
+    have oB: "ordermap (B ` J i) ?R (B j) \<sqsubset> \<beta>" if \<open>i \<in> \<I>\<close> \<open>j \<in> J i\<close> for i j
+      using \<beta> less_TC_iff that by fastforce
+    then show "Ord (\<beta> * ?\<alpha>)"
+      by (intro \<open>Ord \<beta>\<close> wf_Ord_ordertype Ord_mult; simp)
+    define f where "f \<equiv> \<lambda>u. let (x,y) = split u in let i = inv_into \<I> A x in
+                        \<beta> * ordermap (A`\<I>) ?R x + ordermap (B`J i) ?R y"
+    have inv_into_IA [simp]: "inv_into \<I> A (A i) = i" if "i \<in> \<I>" for i
+      by (simp add: A that)
+    show "\<exists>f. bij_betw f ?AB (elts (\<beta> * ?\<alpha>)) \<and> (\<forall>x\<in>?AB. \<forall>y\<in>?AB. (f x < f y) = ((x, y) \<in> ?R))"
+      unfolding bij_betw_def
+    proof (intro exI conjI strip)
+      show "inj_on f ?AB"
+      proof (clarsimp simp: f_def inj_on_def split_def USigma_iff IJ usplit_def)
+        fix x y
+        assume \<section>: "\<beta> * ordermap (A ` \<I>) ?R (A (x - {Max x})) + ordermap (B ` J (x - {Max x})) ?R (B (Max x))
+                 = \<beta> * ordermap (A ` \<I>) ?R (A (y - {Max y})) + ordermap (B ` J (y - {Max y})) ?R (B (Max y))"
+          and x: "x - {Max x} \<in> \<I>"
+          and y: "y - {Max y} \<in> \<I>"
+          and mx: "Max x \<in> J (x - {Max x})"
+          and "x = insert (Max x) x"
+          and my: "Max y \<in> J (y - {Max y})"
+        have "ordermap (A`\<I>) ?R (A (x - {Max x})) = ordermap (A`\<I>) ?R (A (y - {Max y}))"
+          and B_eq: "ordermap (B ` J (x - {Max x})) ?R (B (Max x)) = ordermap (B ` J (y - {Max y})) ?R (B (Max y))"
+          using mult_cancellation_lemma [OF \<section>] oB mx my x y by blast+
+        then have "A (x - {Max x}) = A (y - {Max y})"
+          using x y by auto
+        then have "x - {Max x} = y - {Max y}"
+          by (metis x y inv_into_IA)
+        then show "A (x - {Max x}) = A (y - {Max y}) \<and> B (Max x) = B (Max y)"
+          using B_eq mx my by auto
+      qed
+      show "f ` ?AB = elts (\<beta> * ?\<alpha>)"
+      proof
+        show "f ` ?AB \<subseteq> elts (\<beta> * ?\<alpha>)"
+          using \<open>Ord \<beta>\<close>
+          apply (clarsimp simp add: f_def split_def USigma_iff IJ usplit_def)
+          by (metis Ord_mem_iff_less_TC TC_small add_mult_less image_eqI oB ordermap_in_ordertype trans_llt wf_Ord_ordertype wf_llt)
+        show "elts (\<beta> * ?\<alpha>) \<subseteq> f ` ?AB"
+        proof (clarsimp simp: f_def split_def image_iff USigma_iff IJ usplit_def Bex_def elim!: elts_multE split: prod.split)
+          fix \<gamma> \<delta>
+          assume \<delta>: "\<delta> \<in> elts \<beta>" and \<gamma>: "\<gamma> \<in> elts ?\<alpha>"
+          have "\<gamma> \<in> ordermap (A ` \<I>) (lenlex less_than) ` A ` \<I>"
+            by (meson \<gamma> ordermap_surj subset_iff)
+          then obtain i where "i \<in> \<I>" and yv: "\<gamma> = ordermap (A`\<I>) ?R (A i)"
+            by blast
+          have "\<delta> \<in> ordermap (B ` J i) (lenlex less_than) ` B ` J i"
+            by (metis (no_types) \<beta> \<delta> \<open>i \<in> \<I>\<close> in_mono ordermap_surj)
+          then obtain j where "j \<in> J i" and xu: "\<delta> = ordermap (B`J i) ?R (B j)"
+            by blast
+          then have mji: "Max (insert j i) = j"
+            by (meson IJ Max_insert2 \<open>i \<in> \<I>\<close> less_imp_le less_sets_def)
+          have [simp]: "i - {j} = i"
+            using IJ \<open>i \<in> \<I>\<close> \<open>j \<in> J i\<close> less_setsD by fastforce
+          show
+            "\<exists>l. (\<exists>K. K - {Max K} \<in> \<I> \<and> Max K \<in> J (K - {Max K}) \<and>
+                          K = insert (Max K) K \<and>
+                          l = A (K - {Max K}) @ B (Max K)) \<and> \<beta> * \<gamma> + \<delta> =
+                    \<beta> *
+                    ordermap (A ` \<I>) ?R (take (length l - c) l) +
+                    ordermap (B ` J (inv_into \<I> A (take (length l - c) l)))
+                     ?R (drop (length l - c) l)"
+          proof (intro conjI exI)
+          let ?ji = "insert j i"
+            show "A i @ B j = A (?ji - {Max ?ji}) @ B (Max ?ji)"
+              by (auto simp: mji)
+          qed (use \<open>i \<in> \<I>\<close> \<open>j \<in> J i\<close> mji xu yv in auto)
+        qed
+      qed
+    next
+      fix p q
+      assume "p \<in> ?AB" and "q \<in> ?AB"
+      then obtain x y where peq: "p = A (x - {Max x}) @ B (Max x)"
+                      and qeq: "q = A (y - {Max y}) @ B (Max y)"
+                      and x: "x - {Max x} \<in> \<I>"
+                      and y: "y - {Max y} \<in> \<I>"
+                      and mx: "Max x \<in> J (x - {Max x})"
+                      and my: "Max y \<in> J (y - {Max y})"
+        by (auto simp: USigma_iff IJ usplit_def)
+      let ?mx = "x - {Max x}"
+      let ?my = "y - {Max y}"
+      show "(f p < f q) \<longleftrightarrow> ((p, q) \<in> ?R)"
+      proof
+        assume "f p < f q"
+        then
+        consider "ordermap (A`\<I>) ?R (A (x - {Max x})) < ordermap (A`\<I>) ?R (A (y - {Max y}))"
+          | "ordermap (A`\<I>) ?R (A (x - {Max x})) = ordermap (A`\<I>) ?R (A (y - {Max y}))"
+            "ordermap (B`J (x - {Max x})) ?R (B (Max x)) < ordermap (B`J (y - {Max y})) ?R (B (Max y))"
+          using x y mx my
+          by (auto dest: mult_cancellation_less simp: f_def split_def peq qeq oB)
+        then have "(A ?mx @ B (Max x), A ?my @ B (Max y)) \<in> ?R"
+        proof cases
+          case 1
+          then have "(A ?mx, A ?my) \<in> ?R"
+            using x y
+            by (force simp: Ord_mem_iff_lt intro: converse_ordermap_mono)
+          then show ?thesis
+            using x y mx my lenB lenlex_append1 by blast
+        next
+          case 2
+          then have "A ?mx = A ?my"
+            using \<open>?my \<in> \<I>\<close> \<open>?mx \<in> \<I>\<close> by auto
+          then have eq: "?mx = ?my"
+            by (metis \<open>?my \<in> \<I>\<close> \<open>?mx \<in> \<I>\<close> inv_into_IA)
+          then have "(B (Max x), B (Max y)) \<in> ?R"
+            using mx my  2
+            by (force simp: Ord_mem_iff_lt intro: converse_ordermap_mono)
+          with 2 show ?thesis
+            by (simp add: eq irrefl_less_than)
+        qed
+        then show "(p,q) \<in> ?R"
+          by (simp add: peq qeq f_def split_def sorted_list_of_set_Un AB)
+      next
+        assume pqR: "(p,q) \<in> ?R"
+        then have \<section>: "(A ?mx @ B (Max x), A ?my @ B (Max y)) \<in> ?R"
+          using peq qeq by blast
+        then consider "(A ?mx, A ?my) \<in> ?R" | "A ?mx = A ?my \<and> (B (Max x), B (Max y)) \<in> ?R"
+        proof (cases "(A ?mx, A ?my) \<in> ?R")
+          case False
+          have False if "(A ?my, A ?mx) \<in> ?R"
+            by (metis \<open>?my \<in> \<I>\<close> \<open>?mx \<in> \<I>\<close> "\<section>" \<open>(Max y) \<in> J ?my\<close> \<open>(Max x) \<in> J ?mx\<close> lenB lenlex_append1 omega_sum_1_less order.asym that)
+          then have "A ?mx = A ?my"
+            by (meson False UNIV_I total_llt total_on_def)
+          then show ?thesis
+            using "\<section>" irrefl_less_than that(2) by auto
+        qed (use that in blast)
+        then have "\<beta> * ordermap (A`\<I>) ?R (A ?mx) + ordermap (B`J ?mx) ?R (B (Max x))
+               < \<beta> * ordermap (A`\<I>) ?R (A ?my) + ordermap (B`J ?my) ?R (B (Max y))"
+        proof cases
+          case 1
+          show ?thesis
+          proof (rule add_mult_less_add_mult)
+            show "ordermap (A`\<I>) (lenlex less_than) (A ?mx) < ordermap (A`\<I>) (lenlex less_than) (A ?my)"
+              by (simp add: "1" \<open>?my \<in> \<I>\<close> \<open>?mx \<in> \<I>\<close> ordermap_mono_less)
+            show "Ord (ordertype (A`\<I>) ?R)"
+              using wf_Ord_ordertype by blast+
+            show "ordermap (B ` J ?mx) ?R (B (Max x)) \<in> elts \<beta>"
+              using Ord_less_TC_mem \<open>Ord \<beta>\<close> \<open>?mx \<in> \<I>\<close> \<open>(Max x) \<in> J ?mx\<close> oB by blast
+            show "ordermap (B ` J ?my) ?R (B (Max y)) \<in> elts \<beta>"
+              using Ord_less_TC_mem \<open>Ord \<beta>\<close> \<open>?my \<in> \<I>\<close> \<open>(Max y) \<in> J ?my\<close> oB by blast
+          qed (use \<open>?my \<in> \<I>\<close> \<open>?mx \<in> \<I>\<close> \<open>Ord \<beta>\<close> in auto)
+        next
+          case 2
+          with \<open>?mx \<in> \<I>\<close> show ?thesis
+            using \<open>(Max y) \<in> J ?my\<close> \<open>(Max x) \<in> J ?mx\<close> ordermap_mono_less
+            by (metis (no_types, hide_lams) Kirby.add_less_cancel_left TC_small image_iff inv_into_IA trans_llt wf_llt y)
+        qed
+        then show "f p < f q"
+          using \<open>?my \<in> \<I>\<close> \<open>?mx \<in> \<I>\<close> \<open>(Max y) \<in> J ?my\<close> \<open>(Max x) \<in> J ?mx\<close>
+          by (auto simp: peq qeq f_def split_def AB)
+      qed
+    qed
+  qed auto
+qed auto
+
+
+subsubsection \<open>The final part of 3.8, where two sequences are merged\<close>
+
+definition cconcat where [simp]: "cconcat x l \<equiv> if x=[] then l else concat x#l"
+
+inductive merge :: "[nat list list,nat list list,nat list list,nat list list] \<Rightarrow> bool"
+  where Null: "merge as [] (cconcat as []) []"
+      | App: "\<lbrakk>as1 \<noteq> []; bs1 \<noteq> [];
+               concat as1 < concat bs1; concat bs1 < concat as2; merge as2 bs2 as bs\<rbrakk>
+              \<Longrightarrow> merge (as1@as2) (bs1@bs2) (cconcat as1 as) (cconcat bs1 bs)"
+
+inductive_simps Null1 [simp]: "merge [] bs us vs"
+inductive_simps Null2 [simp]: "merge as [] us vs"
+
+lemma merge_single:
+  "\<lbrakk>concat as < concat bs; concat as \<noteq> []; concat bs \<noteq> []\<rbrakk> \<Longrightarrow> merge as bs [concat as] [concat bs]"
+  using merge.App [of as bs "[]" "[]"]
+  by (fastforce simp add: less_list_def)
+
+lemma merge_length1_nonempty:
+  assumes "merge as bs us vs" "as \<in> lists (- {[]})"
+  shows "us \<in> lists (- {[]})"
+  using assms by induction (auto simp: mem_lists_non_Nil)
+
+lemma merge_length2_nonempty:
+  assumes "merge as bs us vs" "bs \<in> lists (- {[]})"
+  shows "vs \<in> lists (- {[]})"
+  using assms by induction (auto simp: mem_lists_non_Nil)
+
+lemma merge_length1_gt_0:
+  assumes "merge as bs us vs" "as \<noteq> []"
+  shows "length us > 0"
+  using assms by induction auto
+
+lemma merge_length_le:
+  assumes "merge as bs us vs"
+  shows "length vs \<le> length us"
+  using assms by induction auto
+
+lemma merge_length_le_Suc:
+  assumes "merge as bs us vs"
+  shows "length us \<le> Suc (length vs)"
+  using assms by induction auto
+
+lemma merge_length_less2:
+  assumes "merge as bs us vs"
+  shows "length vs \<le> length as"
+  using assms
+proof induction
+case (App as1 bs1 as2 bs2 as bs)
+  then show ?case
+    by simp (metis One_nat_def Suc_eq_plus1 Suc_leI add.commute add_mono length_greater_0_conv)
+qed auto
+
+lemma merge_preserves:
+  assumes "merge as bs us vs"
+  shows "concat as = concat us \<and> concat bs = concat vs"
+  using assms by induction auto
+
+lemma merge_interact:
+  assumes "merge as bs us vs" "strict_sorted (concat as)" "strict_sorted (concat bs)"
+           "bs \<in> lists (- {[]})"
+  shows "strict_sorted (interact us vs)"
+  using assms
+proof induction
+  case (App as1 bs1 as2 bs2 as bs)
+  then have "concat bs1 < concat bs" "concat bs1 < concat as" and xx: "concat bs1 \<noteq> []"
+    using merge_preserves strict_sorted_append_iff by fastforce+
+  then have "concat bs1 < interact as bs"
+    using App
+    apply (simp add: less_list_def del: concat_eq_Nil_conv)
+    by (metis (full_types) Un_iff \<open>concat bs1 < concat as\<close> \<open>concat bs1 < concat bs\<close> last_in_set list.set_sel(1) set_interact sorted_wrt_append strict_sorted_append_iff strict_sorted_interact_imp_concat strict_sorted_sorted_wrt xx)
+  with App show ?case
+    apply (simp add: strict_sorted_append_iff del: concat_eq_Nil_conv)
+    by (metis hd_append2 less_list_def xx)
+qed auto
+
+
+lemma acc_lengths_merge1:
+  assumes "merge as bs us vs"
+  shows "list.set (acc_lengths k us) \<subseteq> list.set (acc_lengths k as)"
+  using assms
+proof (induction arbitrary: k)
+  case (App as1 bs1 as2 bs2 as bs)
+  then show ?case
+    apply (simp add: acc_lengths_append acc_lengths.simps strict_sorted_append_iff length_concat_acc_lengths)
+    by (simp add: le_supI2 length_concat)
+qed (auto simp: acc_lengths.simps length_concat_acc_lengths)
+
+lemma acc_lengths_merge2:
+  assumes "merge as bs us vs"
+  shows "list.set (acc_lengths k vs) \<subseteq> list.set (acc_lengths k bs)"
+  using assms
+proof (induction arbitrary: k)
+  case (App as1 bs1 as2 bs2 as bs)
+  then show ?case
+    apply (simp add: acc_lengths_append acc_lengths.simps strict_sorted_append_iff length_concat_acc_lengths)
+    by (simp add: le_supI2 length_concat)
+qed (auto simp: acc_lengths.simps length_concat_acc_lengths)
+
+lemma length_hd_le_concat:
+  assumes "as \<noteq> []" shows "length (hd as) \<le> length (concat as)"
+  by (metis (no_types) add.commute assms concat.simps(2) le_add2 length_append list.exhaust_sel)
+
+lemma length_hd_merge2:
+  assumes "merge as bs us vs"
+  shows "length (hd bs) \<le> length (hd vs)"
+  using assms by induction (auto simp: length_hd_le_concat)
+
+lemma merge_less_sets_hd:
+  assumes "merge as bs us vs" "strict_sorted (concat as)" "strict_sorted (concat bs)" "bs \<in> lists (- {[]})"
+  shows "less_sets (list.set (hd us)) (list.set (concat vs))"
+  using assms
+proof induction
+  case (App as1 bs1 as2 bs2 as bs)
+  then have \<section>: "less_sets (list.set (concat bs1)) (list.set (concat bs2))"
+    by (force simp: dest: strict_sorted_imp_less_sets)+
+  have *: "less_sets (list.set (concat as1)) (list.set (concat bs1))"
+    using App by (metis concat_append strict_sorted_append_iff strict_sorted_imp_less_sets)
+  then have "less_sets (list.set (concat as1)) (list.set (concat bs))"
+    using App \<section> less_sets_trans merge_preserves
+    by (metis List.set_empty append_in_lists_conv le_zero_eq length_concat_ge length_greater_0_conv list.size(3) mem_lists_non_Nil)
+  with * App.hyps show ?case
+    by (fastforce simp add: less_sets_UN1 less_sets_UN2 less_sets_Un2)
+qed auto
+
+lemma set_takeWhile:
+  assumes "strict_sorted (concat as)" "as \<in> lists (- {[]})"
+  shows "list.set (takeWhile (\<lambda>x. x < y) as) = {x \<in> list.set as. x < y}"
+  using assms
+proof (induction as)
+  case (Cons a as)
+  have *: "a < y"
+    if a: "a < concat as" "strict_sorted a" "strict_sorted (concat as)" "x < y" "x \<noteq> []" "x \<in> list.set as"
+    for x
+  proof -
+    have "last x \<in> list.set (concat as)"
+      using set_concat that(5) that(6) by fastforce
+    then have "last a < hd (concat as)"
+      using Cons.prems that by (auto simp: less_list_def)
+    also have "\<dots> \<le> hd y" if "y \<noteq> []"
+      using that a
+      by (meson \<open>last x \<in> list.set (concat as)\<close> dual_order.strict_trans less_list_def not_le sorted_hd_le strict_sorted_imp_sorted)
+    finally show ?thesis
+      by (simp add: less_list_def)
+  qed
+  then show ?case
+    using Cons by (auto simp: strict_sorted_append_iff)
+qed auto
+
+proposition merge_exists:
+  assumes "strict_sorted (concat as)" "strict_sorted (concat bs)"
+          "as \<in> lists (- {[]})" "bs \<in> lists (- {[]})"
+          "hd as < hd bs" "as \<noteq> []" "bs \<noteq> []"
+  and disj: "\<And>a b. \<lbrakk>a \<in> list.set as; b \<in> list.set bs\<rbrakk> \<Longrightarrow> a<b \<or> b<a"
+shows "\<exists>us vs. merge as bs us vs"
+  using assms
+proof (induction "length as + length bs" arbitrary: as bs rule: less_induct)
+  case (less as bs)
+  obtain as1 as2 bs1 bs2
+    where A: "as1 \<noteq> []" "bs1 \<noteq> []" "concat as1 < concat bs1" "concat bs1 < concat as2"
+      and B: "as = as1@as2" "bs = bs1@bs2" and C: "bs2 = [] \<or> (as2 \<noteq> [] \<and> hd as2 < hd bs2)"
+  proof
+    define as1 where "as1 \<equiv> takeWhile (\<lambda>x. x < hd bs) as"
+    define as2 where "as2 \<equiv> dropWhile (\<lambda>x. x < hd bs) as"
+    define bs1 where "bs1 \<equiv> if as2=[] then bs else takeWhile (\<lambda>x. x < hd as2) bs"
+    define bs2 where "bs2 \<equiv> if as2=[] then [] else dropWhile (\<lambda>x. x < hd as2) bs"
+
+    have as1: "as1 = takeWhile (\<lambda>x. last x < hd (hd bs)) as"
+      using less.prems by (auto simp: as1_def less_list_def cong: takeWhile_cong)
+    have as2: "as2 = dropWhile (\<lambda>x. last x < hd (hd bs)) as"
+      using less.prems by (auto simp: as2_def less_list_def cong: dropWhile_cong)
+
+    have hd_as2: "as2 \<noteq> [] \<Longrightarrow> \<not> hd as2 < hd bs"
+      using as2_def hd_dropWhile by metis
+    have hd_bs2: "bs2 \<noteq> [] \<Longrightarrow> \<not> hd bs2 < hd as2"
+      using bs2_def hd_dropWhile by metis
+    show "as1 \<noteq> []"
+      by (simp add: as1_def less.prems takeWhile_eq_Nil_iff)
+    show "bs1 \<noteq> []"
+      by (metis as2 bs1_def hd_as2 hd_in_set less.prems(7) less.prems(8) set_dropWhileD takeWhile_eq_Nil_iff)
+    show "bs2 = [] \<or> (as2 \<noteq> [] \<and> hd as2 < hd bs2)"
+      by (metis as2_def bs2_def hd_bs2 less.prems(8) list.set_sel(1) set_dropWhileD)
+    have AB: "less_sets (list.set A) (list.set B)"
+      if "A \<in> list.set as1" "B \<in> list.set bs" for A B
+    proof -
+      have "A \<in> list.set as"
+        using that by (metis as1 set_takeWhileD)
+      then have "sorted A"
+        by (metis concat.simps(2) concat_append less.prems(1) sorted_append split_list_last strict_sorted_imp_sorted)
+      moreover have "sorted (hd bs)"
+        by (metis concat.simps(2) hd_Cons_tl less.prems(2) less.prems(7) strict_sorted_append_iff strict_sorted_imp_sorted)
+      ultimately show ?thesis
+        using that
+       apply (clarsimp simp add: as1_def less.prems set_takeWhile less_list_iff_less_sets less_sets_def)
+        by (smt UN_I dual_order.strict_trans2 hd_concat less.prems(2) less.prems(4) less.prems(7) list.set_sel(1) mem_lists_non_Nil not_le set_concat sorted_hd_le strict_sorted_imp_sorted)
+    qed
+    show "as = as1@as2"
+      by (simp add: as1_def as2_def)
+    show "bs = bs1@bs2"
+      by (simp add: bs1_def bs2_def)
+    have "less_sets (list.set (concat as1)) (list.set (concat bs1))"
+      using AB set_takeWhileD by (fastforce simp add: as1_def bs1_def less_sets_UN1 less_sets_UN2)
+    then show "concat as1 < concat bs1"
+      by (rule less_sets_imp_list_less)
+    have "less_sets (list.set (concat bs1)) (list.set (concat as2))" if "as2 \<noteq> []"
+    proof (clarsimp simp add: bs1_def less_sets_UN1 less_sets_UN2 set_takeWhile less.prems)
+      fix A B
+      assume "A \<in> list.set as2" "B \<in> list.set bs" "B < hd as2"
+      with that show "less_sets (list.set B) (list.set A)"
+        using hd_as2 less.prems(1,2)
+        apply (clarsimp simp add: less_sets_def less_list_def)
+        apply (auto simp: as2_def)
+        apply (simp flip: as2_def)
+        by (metis UN_I \<open>as = as1 @ as2\<close> concat.simps(2) concat_append dual_order.strict_trans2 hd_concat in_set_conv_decomp_last not_le set_concat sorted_hd_le sorted_le_last sorted_sorted_wrt sorted_wrt_append strict_sorted_imp_sorted that)
+    qed
+    then show "concat bs1 < concat as2"
+      by (simp add: bs1_def less_sets_imp_list_less)
+  qed
+  obtain cs ds where "merge as2 bs2 cs ds"
+  proof (cases "bs2 = []")
+    case True
+    show ?thesis
+    proof
+      show "merge as2 bs2 (cconcat as2 []) (cconcat bs2 [])"
+        by (simp add: True)
+    qed
+  next
+    have \<dagger>: "length as2 + length bs2 < length as + length bs"
+      by (simp add: A B)
+    case False
+    moreover have "strict_sorted (concat as2)" "strict_sorted (concat bs2)"
+                  "as2 \<in> lists (- {[]})" "bs2 \<in> lists (- {[]})"
+                  "\<And>a b. \<lbrakk>a \<in> list.set as2; b \<in> list.set bs2\<rbrakk> \<Longrightarrow> a < b \<or> b < a"
+      using B less.prems strict_sorted_append_iff by auto
+    ultimately show ?thesis
+      using C less.hyps [OF \<dagger>] False that by force
+  qed
+  then obtain cs where "merge (as1 @ as2) (bs1 @ bs2) (cconcat as1 cs) (cconcat bs1 ds)"
+    using A merge.App by blast
+  then show ?case
+    using B by blast
+qed
+
+subsubsection \<open>Actual proof of lemma 3.8\<close>
+
+text \<open>Lemma 3.8 of Jean A. Larson, ibid.\<close>
+proposition lemma_3_8:
+  assumes "infinite N"
+  obtains X where "X \<subseteq> WW" "ordertype X (lenlex less_than) = \<omega>\<up>\<omega>"
+            "\<And>u. u \<in> [X]\<^bsup>2\<^esup> \<Longrightarrow>
+                   \<exists>l. Form l u \<and> (l > 0 \<longrightarrow> [enum N l] < inter_scheme l u \<and> List.set (inter_scheme l u) \<subseteq> N)"
+proof -
+  let ?LL = "lenlex less_than"
+  define bf where "bf \<equiv> \<lambda>M q. wfrec pair_less (\<lambda>f (j,i).
+                                  let R = (case prev j i of None \<Rightarrow> M | Some u \<Rightarrow> snd (f u))
+                                  in grab R (q j i))"
+
+  have bf_rec: "bf M q (j,i) =
+                 (let R = (case prev j i of None \<Rightarrow> M | Some u \<Rightarrow> snd (bf M q u))
+                  in  grab R (q j i))" for M q j i
+    by (subst (1) bf_def) (simp add: Let_def wfrec bf_def cut_apply prev_pair_less cong: conj_cong split: option.split)
+
+  have infinite_bf [simp]: "infinite (snd (bf M q u)) = infinite M" for M q u
+    using wf_pair_less
+  proof (induction u rule: wf_induct_rule)
+    case (less u)
+    then show ?case
+    proof (cases u)
+      case (Pair j i)
+      with less.IH prev_pair_less show ?thesis
+        by (auto simp: bf_rec [of M q j i] split: option.split)
+    qed
+  qed
+
+  have bf_less_sets: "less_sets (fst (bf M q ij)) (snd (bf M q ij))" if "infinite M" for M q ij
+    using wf_pair_less
+  proof (induction ij rule: wf_induct_rule)
+    case (less u)
+    then show ?case
+    proof (cases u)
+      case (Pair j i)
+      with less_sets_grab show ?thesis
+        by (simp add: bf_rec [of M q j i] less.IH prev_pair_less that split: option.split)
+    qed
+  qed
+
+  have bf_subset: "fst (bf M q u) \<subseteq> M \<and> snd (bf M q u) \<subseteq> M" for M q u
+    using wf_pair_less
+  proof (induction u rule: wf_induct_rule)
+    case (less u)
+    show ?case
+    proof (cases u)
+      case (Pair j i)
+      then show ?thesis
+      apply (simp add: bf_rec [of M q j i] that split: option.split)
+        using fst_grab_subset less.IH prev_pair_less snd_grab_subset by blast
+    qed
+  qed
+
+  have card_fst_bf: "finite (fst (bf M q (j,i))) \<and> card (fst (bf M q (j,i))) = q j i" if "infinite M" for M q j i
+    by (simp add: that bf_rec [of M q j i] split: option.split)
+
+  have bf_cong: "bf M q u = bf M q' u"
+    if "snd u \<le> fst u" and eq: "\<And>y x. \<lbrakk>x\<le>y; y\<le>fst u\<rbrakk> \<Longrightarrow> q' y x = q y x" for M q q' u
+    using wf_pair_less that
+  proof (induction u rule: wf_induct_rule)
+    case (less u)
+    show ?case
+    proof (cases u)
+      case (Pair j i)
+      with less.prems show ?thesis
+      proof (clarsimp simp add: bf_rec [of M _ j i]  split: option.split)
+        fix j' i'
+        assume *: "prev j i = Some (j',i')"
+        then have **: "((j', i'), u) \<in> pair_less"
+          by (simp add: Pair prev_pair_less)
+        moreover have "i' < j'"
+          using Pair less.prems by (simp add: prev_Some_less [OF *])
+        moreover have "\<And>x y. \<lbrakk>x \<le> y; y \<le> j'\<rbrakk> \<Longrightarrow> q' y x = q y x"
+          using ** less.prems by (auto simp: pair_less_def Pair)
+        ultimately show "grab (snd (bf M q (j',i'))) (q j i) = grab (snd (bf M q' (j',i'))) (q j i)"
+          using less.IH by auto
+      qed
+    qed
+  qed
+
+  define ediff where "ediff \<equiv> \<lambda>D:: nat \<Rightarrow> nat set. \<lambda>j i. enum (D j) (Suc i) - enum (D j) i"
+  define F where "F \<equiv> \<lambda>l (dl,a0::nat set,b0::nat \<times> nat \<Rightarrow> nat set,M).
+          let (d,Md) = grab (nxt M (enum N (Suc (2 * Suc l)))) (Suc l) in
+          let (a,Ma) = grab Md (Min d) in
+          let Gb = bf Ma (ediff (dl(l := d))) in
+          let dl' = dl(l := d) in
+          (dl', a, fst \<circ> Gb, snd (Gb(l, l-1)))"
+  define DF where "DF \<equiv> rec_nat (\<lambda>i\<in>{..<0}. {}, {}, \<lambda>p. {}, N) F"
+  have DF_simps: "DF 0 = (\<lambda>i\<in>{..<0}. {}, {}, \<lambda>p. {}, N)"
+                 "DF (Suc l) = F l (DF l)" for l
+    by (auto simp: DF_def)
+  note cut_apply [simp]
+
+  have inf [rule_format]: "\<forall>dl al bl L. DF l = (dl,al,bl,L) \<longrightarrow> infinite L" for l
+    by (induction l) (auto simp: DF_simps F_def Let_def grab_eqD infinite_nxtN assms split: prod.split)
+
+  define \<Psi> where
+    "\<Psi> \<equiv> \<lambda>(dl, a, b :: nat \<times> nat \<Rightarrow> nat set, M::nat set). \<lambda>l::nat.
+           less_sets (dl l) a \<and> finite a \<and> dl l \<noteq> {} \<and> a \<noteq> {} \<and>
+           (\<forall>j\<le>l. card (dl j) = Suc j) \<and> less_sets a (\<Union>(range b)) \<and> range b \<subseteq> Collect finite \<and>
+           a \<subseteq> N \<and> \<Union>(range b) \<subseteq> N \<and> infinite M \<and> less_sets (b(l,l-1)) M \<and>
+           M \<subseteq> N"
+  have \<Psi>_DF: "\<Psi> (DF (Suc l)) l" for l
+  proof (induction l)
+    case 0
+    show ?case
+      using assms
+      apply (clarsimp simp add: bf_rec F_def DF_simps \<Psi>_def split: prod.split)
+      apply (drule grab_eqD, blast dest: grab_eqD infinite_nxtN)+
+      apply (auto simp: less_sets_UN2 less_sets_grab card_fst_bf elim!: less_sets_weaken2)
+      apply (metis Min_in card_eq_0_iff greaterThan_iff le_inf_iff less_nat_zero_code n_not_Suc_n nxt_def subsetD)
+      using nxt_subset snd_grab_subset bf_subset by blast+
+  next
+    case (Suc l)
+    then show ?case
+      using assms
+      unfolding Let_def DF_simps(2)[of "Suc l"] F_def \<Psi>_def
+      apply (clarsimp simp add: bf_rec DF_simps split: prod.split)
+      apply (drule grab_eqD, metis grab_eqD infinite_nxtN)+
+      apply (safe, simp_all add: less_sets_UN2 less_sets_grab card_fst_bf)
+             apply (meson less_sets_weaken2)
+            apply (metis (no_types, hide_lams) IntE Min_in card_empty greaterThan_iff leD not_less_eq_eq nxt_def subsetD zero_less_Suc)
+           apply (meson bf_subset less_sets_weaken2)
+          apply (meson nxt_subset subset_eq)
+         apply (meson bf_subset nxt_subset subset_eq)
+        using bf_rec infinite_bf apply force
+       using bf_less_sets bf_rec apply force
+      by (metis bf_rec bf_subset nxt_subset subsetD)
+  qed
+
+  define d where "d \<equiv> \<lambda>k. let (dk,ak,bk,M) = DF(Suc k) in dk k"
+  define a where "a \<equiv> \<lambda>k. let (dk,ak,bk,M) = DF(Suc k) in ak"
+  define b where "b \<equiv> \<lambda>k. let (dk,ak,bk,M) = DF(Suc k) in bk"
+  define M where "M \<equiv> \<lambda>k. let (dk,ak,bk,M) = DF k in M"
+
+  have infinite_M [simp]: "infinite (M k)" for k
+    by (auto simp: M_def inf split: prod.split)
+
+  have M_Suc_subset: "M (Suc k) \<subseteq> M k" for k
+    apply (clarsimp simp add: Let_def M_def F_def DF_simps split: prod.split)
+    apply (drule grab_eqD, blast dest: infinite_nxtN local.inf)+
+    using bf_subset nxt_subset by blast
+
+  have Inf_M_Suc_ge: "Inf (M k) \<le> Inf (M (Suc k))" for k
+    by (simp add: M_Suc_subset cInf_superset_mono infinite_imp_nonempty)
+
+  have Inf_M_telescoping: "{Inf (M k)..} \<subseteq> {Inf (M k')..}" if "k'\<le>k" for k k'
+    using that
+    by (induction "k-k'")(auto simp: Inf_M_Suc_ge M_Suc_subset cInf_superset_mono infinite_imp_nonempty lift_Suc_antimono_le)
+
+  have d_eq: "d k = fst (grab (nxt (M k) (enum N (Suc (2 * Suc k)))) (Suc k))" for k
+    by (simp add: d_def M_def Let_def DF_simps F_def split: prod.split)
+  then have finite_d [simp]: "finite (d k)" for k
+    by simp
+  then have d_ne [simp]: "d k \<noteq> {}" for k
+    by (metis card_empty card_grab d_eq infinite_M infinite_nxtN nat.distinct(1))
+  have a_eq: "\<exists>M. a k = fst (grab M (Min (d k))) \<and> infinite M" for k
+    apply (simp add: a_def d_def M_def Let_def DF_simps F_def split: prod.split)
+    by (metis fst_conv grab_eqD infinite_nxtN local.inf)
+  then have card_a: "card (a k) = Inf (d k)" for k
+    by (metis cInf_eq_Min card_grab d_ne finite_d)
+
+  have d_eq_dl: "d k = dl k" if "(dl,a,b,P) = DF l" "k < l" for k l dl a b P
+    using that
+    by (induction l arbitrary: dl a b P) (simp_all add: d_def DF_simps F_def Let_def split: prod.split_asm prod.split)
+
+  have card_d [simp]: "card (d k) = Suc k" for k
+    by (auto simp: d_eq infinite_nxtN)
+
+  have d_ne [simp]: "d j \<noteq> {}" and a_ne [simp]: "a j \<noteq> {}"
+    and finite_d [simp]: "finite (d j)" and finite_a [simp]: "finite (a j)" for j
+    using \<Psi>_DF [of "j"] by (auto simp: \<Psi>_def a_def d_def split: prod.split_asm)
+
+  have da: "less_sets (d k) (a k)" for k
+    using \<Psi>_DF [of "k"] by (simp add: \<Psi>_def a_def d_def split: prod.split_asm)
+
+  have ab_same: "less_sets (a k) (\<Union>(range(b k)))" for k
+    using \<Psi>_DF [of "k"]
+    by (simp add: \<Psi>_def a_def b_def M_def split: prod.split_asm)
+
+  have snd_bf_subset: "snd (bf M r (j,i)) \<subseteq> snd (bf M r (j',i'))"
+    if ji: "((j',i'), (j,i)) \<in> pair_less" "(j',i') \<in> IJ k"
+    for M r k j i j' i'
+    using wf_pair_less ji
+  proof (induction rule: wf_induct_rule [where a= "(j,i)"])
+    case (less u)
+    show ?case
+    proof (cases u)
+      case (Pair j i)
+      then consider "prev j i = Some (j', i')" | x where "((j', i'), x) \<in> pair_less" "prev j i = Some x"
+        using less.prems pair_less_prev by blast
+      then show ?thesis
+      proof cases
+        case 1
+        then show ?thesis
+          by (simp add: Pair bf_rec snd_grab_subset)
+      next
+        case 2
+        then have "snd (bf M r x) \<subseteq> snd (bf M r (j', i'))"
+          by (simp add: Pair less.IH prev_pair_less that(2))
+        moreover have "snd (bf M r u) \<subseteq> snd (bf M r x)"
+          by (simp add: 2 Pair bf_rec snd_grab_subset)
+        ultimately show ?thesis
+          by auto
+      qed
+    qed
+  qed
+
+  have less_bf: "less_sets (fst (bf M r (j',i'))) (fst (bf M r (j,i)))"
+    if ji: "((j',i'), (j,i)) \<in> pair_less" "(j',i') \<in> IJ k" and "infinite M"
+    for M r k j i j' i'
+  proof -
+    consider "prev j i = Some (j', i')" | j'' i'' where "((j', i'), (j'',i'')) \<in> pair_less" "prev j i = Some (j'',i'')"
+      by (metis pair_less_prev ji prod.exhaust_sel)
+    then show ?thesis
+    proof cases
+      case 1
+      then show ?thesis
+        using bf_less_sets bf_rec infinite_bf less_sets_fst_grab \<open>infinite M\<close> by auto
+    next
+      case 2
+      then have "less_sets (fst (bf M r (j',i'))) (snd (bf M r (j'',i'')))"
+        by (meson bf_less_sets snd_bf_subset less_sets_weaken2 that)
+      with 2 show ?thesis
+        using bf_rec infinite_bf less_sets_fst_grab \<open>infinite M\<close> by auto
+    qed
+  qed
+
+  have aM: "less_sets (a k) (M (Suc k))" for k
+    apply (clarsimp simp add: a_def M_def DF_simps F_def Let_def split: prod.split)
+    by (meson bf_subset grab_eqD infinite_nxtN less_sets_weaken2 local.inf)
+  then have "less_sets (a k) (a (Suc k))" for k
+    by (metis IntE card_d card_empty d_eq da fst_grab_subset less_sets_trans less_sets_weaken2 nat.distinct(1) nxt_def subsetI)
+  then have aa: "less_sets (a j) (a k)" if "j<k" for k j
+    by (meson UNIV_I a_ne less_sets_imp_strict_mono_sets strict_mono_sets_def that)
+  then have ab: "less_sets (a k') (b k (j,i))" if "k'\<le>k" for k k' j i
+    by (metis a_ne ab_same le_less less_sets_UN2 less_sets_trans rangeI that)
+  have db: "less_sets (d j) (b k (j,i))" if "j\<le>k" for k j i
+    by (meson a_ne ab da less_sets_trans that)
+
+  have bMkk: "less_sets (b k (k,k-1)) (M (Suc k))" for k
+    using \<Psi>_DF [of k]
+    by (simp add: \<Psi>_def b_def d_def M_def split: prod.split_asm)
+
+  have b: "\<exists>P \<subseteq> M k. infinite P \<and> (\<forall>j i. i\<le>j \<longrightarrow> j\<le>k \<longrightarrow> b k (j,i) = fst (bf P (ediff d) (j,i)))" for k
+  proof (clarsimp simp: b_def DF_simps F_def Let_def split: prod.split)
+    fix a a' d' dl bb P M' M''
+    assume gr: "grab M'' (Min d') = (a', M')" "grab (nxt P (enum N (Suc (Suc (Suc (2 * k)))))) (Suc k) = (d', M'')"
+      and DF: "DF k = (dl, a, bb, P)"
+    have deq: "d j = (if j = k then d' else dl j)" if "j\<le>k" for j
+    proof (cases "j < k")
+      case True
+      then show ?thesis
+        by (metis DF d_eq_dl less_not_refl)
+    next
+      case False
+      then show ?thesis
+        using that DF gr
+        by (auto simp: d_def DF_simps F_def Let_def split: prod.split)
+    qed
+    have "M' \<subseteq> P"
+      by (metis gr in_mono nxt_subset snd_conv snd_grab_subset subsetI)
+    also have "P \<subseteq> M k"
+      using DF by (simp add: M_def)
+    finally have "M' \<subseteq> M k" .
+    moreover have "infinite M'"
+      using DF by (metis (mono_tags) finite_grab_iff gr infinite_nxtN local.inf snd_conv)
+    moreover
+    have "ediff (dl(k := d')) j i = ediff d j i" if "j\<le>k" for j i
+      by (simp add: deq that ediff_def)
+    then have "bf M' (ediff (dl(k := d'))) (j,i)
+             = bf M' (ediff d) (j,i)" if "i \<le> j" "j\<le>k" for j i
+      using bf_cong that by fastforce
+    ultimately show "\<exists>P\<subseteq>M k. infinite P \<and>
+                           (\<forall>j i. i \<le> j \<longrightarrow> j \<le> k
+                                        \<longrightarrow> fst (bf M' (ediff (dl(k := d'))) (j,i))
+                         = fst (bf P (ediff d) (j,i)))"
+      by auto
+  qed
+
+  have card_b: "card (b k (j,i)) = enum (d j) (Suc i) - enum (d j) i" if "j\<le>k" for k j i
+    \<comment>\<open>there's a short proof of this from the previous result but it would need @{term"i\<le>j"}\<close>
+  proof (clarsimp simp: b_def DF_simps F_def Let_def split: prod.split)
+    fix dl
+      and a a' d':: "nat set"
+      and bb M M' M''
+    assume gr: "grab M'' (Min d') = (a', M')" "grab (nxt M (enum N (Suc (Suc (Suc (2 * k)))))) (Suc k) = (d',M'')"
+      and DF: "DF k = (dl, a, bb, M)"
+    have "d j = (if j = k then d' else dl j)"
+    proof (cases "j < k")
+      case True
+      then show ?thesis
+        by (metis DF d_eq_dl less_not_refl)
+    next
+      case False
+      then show ?thesis
+        using that DF gr by (auto simp: d_def DF_simps F_def Let_def split: prod.split)
+    qed
+    then show "card (fst (bf M' (ediff (dl(k := d'))) (j,i)))
+             = enum (d j) (Suc i) - enum (d j) i"
+      using DF gr card_fst_bf grab_eqD infinite_nxtN local.inf ediff_def by auto
+  qed
+
+  have card_b_pos: "card (b k (j,i)) > 0" if "i < j" "j\<le>k" for k j i
+    by (simp add: card_b that finite_enumerate_step)
+  have b_ne [simp]: "b k (j,i) \<noteq> {}" if "i < j" "j\<le>k" for k j i
+    using card_b_pos [OF that] less_imp_neq by fastforce+
+
+  have card_b_finite [simp]: "finite (b k u)" for k u
+    using \<Psi>_DF [of k] by (fastforce simp add: \<Psi>_def b_def)
+
+  have bM: "less_sets (b k (j,i)) (M (Suc k))" if "i<j" "j\<le>k" for i j k
+  proof -
+    obtain M' where "M' \<subseteq> M k" "infinite M'"
+      and bk: "\<And>j i. i\<le>j \<Longrightarrow> j\<le>k \<Longrightarrow> b k (j,i) = fst (bf M' (ediff d) (j,i))"
+      using b by (metis (no_types, lifting))
+    show ?thesis
+    proof (cases "j=k \<and> i = k-1")
+      case False
+      show ?thesis
+      proof (rule less_sets_trans [OF _ bMkk])
+        show "less_sets (b k (j,i)) (b k (k, k - 1))"
+          using that \<open>infinite M'\<close> False
+            by (force simp: bk pair_less_def IJ_def intro: less_bf)
+        show "b k (k, k - 1) \<noteq> {}"
+          using b_ne that by auto
+      qed
+    qed (use bMkk in auto)
+  qed
+
+  have b_InfM: "\<Union> (range (b k)) \<subseteq> {\<Sqinter>(M k)..}" for k
+  proof (clarsimp simp add: \<Psi>_def b_def M_def DF_simps F_def Let_def split: prod.split)
+    fix r dl :: "nat \<Rightarrow> nat set"
+      and a b and d' a' M'' M' P :: "nat set"
+      and x j' i' :: nat
+    assume gr: "grab M'' (Min d') = (a', M')"
+               "grab (nxt P (enum N (Suc (Suc (Suc (2 * k)))))) (Suc k) = (d', M'')"
+      and DF: "DF k = (dl, a, b, P)"
+      and x: "x \<in> fst (bf M' (ediff (dl(k := d'))) (j', i'))"
+    have "infinite P"
+      using DF local.inf by blast
+    then have "M' \<subseteq> P"
+      by (meson gr grab_eqD infinite_nxtN nxt_subset order.trans)
+    with bf_subset show "\<Sqinter> P \<le> (x::nat)"
+      using Inf_nat_def x le_less_linear not_less_Least by fastforce
+  qed
+
+  have b_Inf_M_Suc: "less_sets (b k (j,i)) {Inf(M (Suc k))}" if "i<j" "j\<le>k" for k j i
+    using bMkk [of k] that
+    by (metis Inf_nat_def1 bM finite.emptyI infinite_M less_setsD less_sets_singleton2)
+
+  have bb_same: "less_sets (b k (j',i')) (b k (j,i))"
+    if "((j',i'), (j,i)) \<in> pair_less" "(j',i') \<in> IJ k" for k j i j' i'
+    using that
+    unfolding b_def DF_simps F_def Let_def
+    by (auto simp: less_bf grab_eqD infinite_nxtN local.inf split: prod.split)
+
+  have bb: "less_sets (b k' (j',i')) (b k (j,i))"
+    if j: "i' < j'" "j'\<le>k'" and k: "k'<k" for i i' j j' k' k
+  proof (rule atLeast_less_sets)
+    show "less_sets (b k' (j', i')) {Inf(M (Suc k'))}"
+      using Suc_lessD b_Inf_M_Suc nat_less_le j by blast
+    have "b k (j,i) \<subseteq> {\<Sqinter>(M k)..}"
+      by (rule order_trans [OF _ b_InfM]) auto
+    also have "\<dots>  \<subseteq> {Inf(M (Suc k'))..}"
+      using Inf_M_telescoping k by auto
+    finally show "b k (j,i) \<subseteq> {Inf(M (Suc k'))..}" .
+  qed
+
+  have M_subset_N: "M k \<subseteq> N" for k
+  proof (cases k)
+    case (Suc k')
+    with \<Psi>_DF [of k'] show ?thesis
+      by (auto simp: M_def Let_def \<Psi>_def split: prod.split)
+  qed (auto simp: M_def DF_simps)
+  have a_subset_N: "a k \<subseteq> N" for k
+    using \<Psi>_DF [of k] by (simp add: a_def \<Psi>_def split: prod.split prod.split_asm)
+  have d_subset_N: "d k \<subseteq> N" for k
+    using M_subset_N [of k] d_eq fst_grab_subset nxt_subset by blast
+  have b_subset_N: "b k (j,i) \<subseteq> N" for k j i
+    using \<Psi>_DF [of k] by (force simp: b_def \<Psi>_def)
+
+  define \<K>:: "[nat,nat] \<Rightarrow> nat set set"
+    where "\<K> \<equiv> \<lambda>j0 j. nsets {j0<..} j"
+
+  have \<K>_finite: "K \<in> \<K> j0 j \<Longrightarrow> finite K" for K j0 j
+    by (simp add: \<K>_def nsets_def)
+  have \<K>_card: "K \<in> \<K> j0 j \<Longrightarrow> card K = j" for K j0 j
+    by (simp add: \<K>_def nsets_def)
+  have \<K>_enum: "j0 < enum K i" if "K \<in> \<K> j0 j" "i < card K" for K j0 j i
+    using that by (auto simp: \<K>_def nsets_def finite_enumerate_in_set subset_eq)
+  have \<K>_0 [simp]: "\<K> k 0 = {{}}" for k
+    by (auto simp: \<K>_def)
+
+  have \<K>_Suc: "\<K> j0 (Suc j) = USigma (\<K> j0 j) (\<lambda>K. {Max (insert j0 K)<..})" (is "?lhs = ?rhs")
+    for j j0
+  proof
+    show "\<K> j0 (Suc j) \<subseteq> USigma (\<K> j0 j) (\<lambda>K. {Max (insert j0 K)<..})"
+      unfolding \<K>_def nsets_def USigma_def
+    proof clarsimp
+      fix K
+      assume K: "K \<subseteq> {j0<..}" "finite K" "card K = Suc j"
+      then obtain i where "Max (insert j0 (K - {Max K})) < i" "K = insert i (K - {Max K})"
+        apply (simp add: subset_iff)
+        by (metis Diff_iff Max.coboundedI Max_in card_0_eq insert_Diff insert_iff le_neq_implies_less nat.distinct(1))
+      then  show "\<exists>L\<subseteq>{j0<..}. finite L \<and> card L = j \<and>
+                 (\<exists>i\<in>{Max (insert j0 L)<..}. K = insert i L)"
+        using K
+        by (metis Max_in card_Diff_singleton_if card_gt_0_iff diff_Suc_1 finite_Diff greaterThan_iff insert_subset zero_less_Suc)
+    qed
+    show "?rhs \<subseteq> \<K> j0 (Suc j)"
+      by (force simp:  \<K>_def nsets_def USigma_def)
+  qed
+
+  define BB where "BB \<equiv> \<lambda>j0 j K. list_of (a j0 \<union> (\<Union>i<j. b (enum K i) (j0,i)))"
+  define XX where "XX \<equiv> \<lambda>j. BB j j ` \<K> j j"
+
+  have less_list_of:  "BB j i K < list_of (b l (j,i))"
+    if K: "K \<in> \<K> j i" "\<forall>j\<in>K. j < l" and "i \<le> j" "j \<le> l" for j i K l
+    unfolding BB_def
+  proof (rule less_sets_imp_sorted_list_of_set)
+    have "\<And>i. i < card K \<Longrightarrow> less_sets (b (enum K i) (j,i)) (b l (j, card K))"
+      using that by (metis \<K>_card \<K>_enum \<K>_finite bb finite_enumerate_in_set nat_less_le less_le_trans)
+    then show "less_sets (a j \<union> (\<Union>i<i. b (enum K i) (j,i))) (b l (j,i))"
+      using that
+      unfolding \<K>_def nsets_def
+      by (auto simp: less_sets_Un1 less_sets_UN1 ab finite_enumerate_in_set subset_eq)
+  qed auto
+  have BB_Suc: "BB j0 (Suc j) K = usplit (\<lambda>L k. BB j0 j L @ list_of (b k (j0, j))) K"
+    if j: "j \<le> j0" and K: "K \<in> \<K> j0 (Suc j)" for j0 j K
+    \<comment>\<open>towards the ordertype proof\<close>
+  proof -
+    have Kj: "K \<subseteq> {j0<..}" and [simp]: "finite K" and cardK: "card K = Suc j"
+      using K by (auto simp: \<K>_def nsets_def)
+    have KMK: "K - {Max K} \<in> \<K> j0 j"
+      using that by (simp add: \<K>_Suc USigma_iff \<K>_finite less_sets_def usplit_def)
+    have "j0 < Max K"
+      by (metis Kj Max_in cardK card_gt_0_iff greaterThan_iff subsetD zero_less_Suc)
+    have MaxK: "Max K = enum K j"
+    proof (rule Max_eqI)
+      show "enum K j \<in> K"
+        by (simp add: cardK finite_enumerate_in_set)
+      show "k \<le> enum K j" if "k \<in> K" for k
+        using that K
+        by (metis \<open>finite K\<close> cardK enum_obtain_index_finite finite_enumerate_mono leI less_Suc_eq less_asym)
+    qed auto
+    have ene: "i<j \<Longrightarrow> enum (K - {enum K j}) i = enum K i" for i
+      using finite_enumerate_Diff_singleton [OF \<open>finite K\<close>] by (simp add: cardK)
+    have "BB j0 (Suc j) K = list_of ((a j0 \<union> (\<Union>x<j. b (enum K x) (j0, x))) \<union> b (enum K j) (j0, j))"
+      by (simp add: BB_def lessThan_Suc Un_ac)
+    also have "\<dots> = list_of ((a j0 \<union> (\<Union>i<j. b (enum K i) (j0, i)))) @ list_of (b (enum K j) (j0, j))"
+    proof (rule sorted_list_of_set_Un)
+      have "less_sets (b (enum K i) (j0, i)) (b (enum K j) (j0, j))" if "i<j" for i
+      proof (rule bb)
+        show "i < j0"
+          using j that by linarith
+        show "j0 \<le> enum K i"
+          using that K by (metis \<K>_enum cardK less_SucI less_imp_le_nat)
+        show "enum K i < enum K j"
+          by (simp add: cardK finite_enumerate_mono that)
+      qed
+      moreover have "less_sets (a j0) (b (enum K j) (j0, j))"
+        using MaxK \<open>j0 < Max K\<close> ab by auto
+      ultimately show "less_sets (a j0 \<union> (\<Union>x<j. b (enum K x) (j0, x))) (b (enum K j) (j0, j))"
+        by (simp add: less_sets_Un1 less_sets_UN1)
+    qed (auto simp: finite_UnI)
+    also have "\<dots> = BB j0 j (K - {Max K}) @ list_of (b (Max K) (j0, j))"
+      by (simp add: BB_def MaxK ene)
+    also have "\<dots> = usplit (\<lambda>L k. BB j0 j L @ list_of (b k (j0, j))) K"
+      by (simp add: usplit_def)
+    finally show ?thesis .
+  qed
+
+  have enum_d_0: "enum (d j) 0 = Inf (d j)" for j
+    using enum_0_eq_Inf_finite by auto
+
+  have Inf_b_less: "\<Sqinter>(b k' (j',i')) < \<Sqinter>(b k (j,i))"
+    if j: "i' < j'" "i < j" "j'\<le>k'" "j\<le>k" and k: "k'<k" for i i' j j' k' k
+    using bb [of i' j' k' k j i] that b_ne [of i' j' k'] b_ne [of i j k]
+    by (simp add: less_sets_def Inf_nat_def1)
+
+  have b_ge_k: "\<Sqinter> (b k (k, k-1)) \<ge> k-1" if "k>0" for k
+    using that
+  proof (induction k)
+    case (Suc k)
+    show ?case
+    proof (cases "k=0")
+      case False
+      have "\<Sqinter> (b k (k, k - Suc 0)) < \<Sqinter> (b (Suc k) (Suc k, k))"
+        using False Inf_b_less by auto
+      with False Suc show ?thesis
+        by simp
+    qed auto
+  qed auto
+
+  have b_ge: "\<Sqinter> (b k (j,i)) \<ge> k-1" if k: "k>0" "k \<ge> j" and "j > i" for k j i
+    using k
+  proof (induction k)
+    case (Suc k)
+    show ?case
+    proof (cases "j \<le> k")
+      case True
+      have "\<Sqinter> (b k (j,i)) < \<Sqinter> (b (Suc k) (j,i))"
+        using \<open>j > i\<close> Suc True by (force intro: Inf_b_less)
+      then show ?thesis
+        using Suc.IH True by linarith
+    next
+      case False
+      then have "j = Suc k"
+        using Suc.prems(2) by linarith
+      with \<open>i < j\<close> have "i < Suc k"
+        by fastforce
+      moreover have "\<not> \<Sqinter> (b (Suc k) (j,i)) < \<Sqinter> (b (Suc k) (j,i))"
+        by fastforce
+      ultimately have "\<not> Suc (\<Sqinter> (b (Suc k) (j,i))) < Suc k"
+        by (metis Inf_b_less \<open>j = Suc k\<close> b_ge_k diff_Suc_1 leD le_refl lessI zero_less_Suc)
+      then show ?thesis
+        by simp
+    qed
+  qed auto
+
+  have hd_b: "hd (list_of (b k (j,i))) = \<Sqinter> (b k (j,i))"
+    if "i < j" "j \<le> k" for k j i
+    using that by (simp add: hd_list_of cInf_eq_Min)
+
+  have b_disjoint_less: "b (enum K i) (j0, i) \<inter> b (enum K i') (j0, i') = {}"
+    if K: "K \<subseteq> {j0<..}" "finite K" "card K \<ge> j0" "i' < j" "i < i'" "j \<le> j0" for i i' j j0 K
+  proof (intro bb less_sets_imp_disjnt [unfolded disjnt_def])
+    show "i < j0"
+      using that by linarith
+    then show "j0 \<le> enum K i"
+      by (meson K finite_enumerate_in_set greaterThan_iff less_imp_le_nat less_le_trans subsetD)
+    show "enum K i < enum K i'"
+      using K \<open>j \<le> j0\<close> that by auto
+  qed
+
+  have b_disjoint: "b (enum K i) (j0, i) \<inter> b (enum K i') (j0, i') = {}"
+    if K: "K \<subseteq> {j0<..}" "finite K" "card K \<ge> j0" "i < j" "i' < j" "i \<noteq> i'" "j \<le> j0" for i i' j j0 K
+    using that b_disjoint_less inf_commute neq_iff by metis
+
+  have ot\<omega>: "ordertype ((\<lambda>k. list_of (b k (j,i))) ` {Max (insert j K)<..}) ?LL = \<omega>"
+             (is "?lhs = _")
+    if K: "K \<in> \<K> j i" "j > i" for j i K
+  proof -
+    have Sucj: "Suc (Max (insert j K)) \<ge> j"
+      using \<K>_finite that(1) le_Suc_eq by auto
+    let ?N = "{Inf(b k (j,i))| k. Max (insert j K) < k}"
+    have infN: "infinite ?N"
+    proof (clarsimp simp add: infinite_nat_iff_unbounded_le)
+      fix m
+      show "\<exists>n\<ge>m. \<exists>k. n = \<Sqinter> (b k (j,i)) \<and> Max (insert j K) < k"
+        using b_ge [of _ j i] \<open>j > i\<close> Sucj
+        by (metis (no_types, lifting) diff_Suc_1 le_SucI le_trans less_Suc_eq_le nat_le_linear zero_less_Suc)
+    qed
+    have [simp]: "Max (insert j K) < k \<longleftrightarrow> j < k \<and> (\<forall>a\<in>K. a < k)" for k
+      using that by (auto simp: \<K>_finite)
+    have "?lhs = ordertype ?N less_than"
+    proof (intro ordertype_eqI strip)
+      have "list_of (b k (j,i)) = list_of (b k' (j,i))"
+        if "j \<le> k" "j \<le> k'"  "hd (list_of (b k (j,i))) = hd (list_of (b k' (j,i)))"
+        for k k'
+        by (metis Inf_b_less \<open>i < j\<close> hd_b nat_less_le not_le that)
+      moreover have "\<exists>k' j' i'. hd (list_of (b k (j,i))) = \<Sqinter> (b k' (j', i')) \<and> i' < j' \<and> j' \<le> k'"
+        if "j \<le> k" for k
+        using that \<open>i < j\<close> hd_b less_imp_le_nat by blast
+      moreover have "\<exists>k'. hd (list_of (b k (j,i))) = \<Sqinter> (b k' (j,i)) \<and> j < k' \<and> (\<forall>a\<in>K. a < k')"
+         if "j < k" "\<forall>a\<in>K. a < k" for k
+        using that K hd_b less_imp_le_nat by blast
+      moreover have "\<Sqinter> (b k (j,i)) \<in> hd ` (\<lambda>k. list_of (b k (j,i))) ` {Max (insert j K)<..}"
+        if "j < k" "\<forall>a\<in>K. a < k" for k
+        using that K by (auto simp: hd_b image_iff)
+      ultimately
+      show "bij_betw hd ((\<lambda>k. list_of (b k (j,i))) ` {Max (insert j K)<..}) {\<Sqinter> (b k (j,i)) |k. Max (insert j K) < k}"
+        by (auto simp: bij_betw_def inj_on_def)
+    next
+      fix ms ns
+      assume "ms \<in> (\<lambda>k. list_of (b k (j,i))) ` {Max (insert j K)<..}"
+        and "ns \<in> (\<lambda>k. list_of (b k (j,i))) ` {Max (insert j K)<..}"
+      with that obtain k k' where
+        ms: "ms = list_of (b k (j,i))" and ns: "ns = list_of (b k' (j,i))"
+        and "j < k" "j < k'" and lt_k: "\<forall>a\<in>K. a < k" and lt_k': "\<forall>a\<in>K. a < k'"
+        by (auto simp: \<K>_finite)
+      then have len_eq [simp]: "length ns = length ms"
+        by (simp add: card_b)
+      have nz: "length ns \<noteq> 0"
+        using b_ne \<open>i < j\<close> \<open>j < k'\<close> ns by auto
+      show "(hd ms, hd ns) \<in> less_than \<longleftrightarrow> (ms, ns) \<in> ?LL"
+      proof
+        assume "(hd ms, hd ns) \<in> less_than"
+        then show "(ms, ns) \<in> ?LL"
+          using that nz
+          by (fastforce simp add: lenlex_def \<K>_finite card_b intro: hd_lex)
+      next
+        assume \<section>: "(ms, ns) \<in> ?LL"
+        then have "(list_of (b k' (j,i)), list_of (b k (j,i))) \<notin> ?LL"
+          using less_asym ms ns omega_sum_1_less by blast
+        then show "(hd ms, hd ns) \<in> less_than"
+          using \<open>j < k\<close> \<open>j < k'\<close> Inf_b_less [of i j i j] ms ns
+          by (metis Cons_lenlex_iff \<section> len_eq b_ne card_b_finite diff_Suc_1 hd_Cons_tl hd_b length_Cons less_or_eq_imp_le less_than_iff linorder_neqE_nat sorted_list_of_set_eq_Nil_iff that(2))
+      qed
+    qed auto
+    also have "\<dots> = \<omega>"
+      using infN ordertype_nat_\<omega> by blast
+    finally show ?thesis .
+  qed
+
+  have ot\<omega>j: "ordertype (BB j0 j ` \<K> j0 j) ?LL = \<omega>\<up>j" if "j \<le> j0" for j j0
+    using that
+  proof (induction j)
+    case 0
+    then show ?case
+      by (auto simp: XX_def)
+  next
+    case (Suc j)
+    then have ih: "ordertype (BB j0 j ` \<K> j0 j) ?LL = \<omega> \<up> j"
+      by simp
+    have "j \<le> j0"
+      by (simp add: Suc.prems Suc_leD)
+    have inj_BB: "inj_on (BB j0 j) ([{j0<..}]\<^bsup>j\<^esup>)"
+    proof (clarsimp simp: inj_on_def BB_def nsets_def subset_iff sorted_list_of_set_Un less_sets_UN2)
+      fix X Y
+      assume X [rule_format]: "\<forall>t. t \<in> X \<longrightarrow> j0 < t"
+        and Y [rule_format]: "\<forall>t. t \<in> Y \<longrightarrow> j0 < t"
+        and "finite X"
+        and jeq: "j = card X"
+        and "finite Y"
+        and "card Y = card X"
+        and eq: "list_of (a j0 \<union> (\<Union>i<card X. b (enum X i) (j0,i)))
+               = list_of (a j0 \<union> (\<Union>i<card X. b (enum Y i) (j0,i)))"
+      have enumX: "\<And>n. \<lbrakk>n < card X\<rbrakk> \<Longrightarrow> j0 \<le> enum X n"
+        using X \<open>finite X\<close> finite_enumerate_in_set less_imp_le_nat by blast
+      have enumY: "\<And>n. \<lbrakk>n < card X\<rbrakk> \<Longrightarrow> j0 \<le> enum Y n"
+        by (simp add: Y \<open>card Y = card X\<close> \<open>finite Y\<close> finite_enumerate_in_set less_imp_le_nat)
+      have smX: "strict_mono_sets {..<card X} (\<lambda>i. b (enum X i) (j0, i))"
+        and smY: "strict_mono_sets {..<card X} (\<lambda>i. b (enum Y i) (j0, i))"
+        using Suc.prems \<open>card Y = card X\<close> \<open>finite X\<close> \<open>finite Y\<close> bb enumX enumY jeq
+        by (auto simp: strict_mono_sets_def)
+
+      have len_eq: "length ms = length ns"
+        if "(ms, ns) \<in> list.set (zip (map (list_of \<circ> (\<lambda>i. b (enum X i) (j0,i))) (list_of {..<n}))
+                                     (map (list_of \<circ> (\<lambda>i. b (enum Y i) (j0,i))) (list_of {..<n})))"
+          "n \<le> card X"
+        for ms ns n
+        using that
+      by (induction n rule: nat.induct) (auto simp: card_b enumX enumY)
+      have "concat (map (list_of \<circ> (\<lambda>i. b (enum X i) (j0, i))) (list_of {..<card X}))
+          = concat (map (list_of \<circ> (\<lambda>i. b (enum Y i) (j0, i))) (list_of {..<card X}))"
+        using eq
+        by (simp add: sorted_list_of_set_Un less_sets_UN2 sorted_list_of_set_UN_lessThan ab enumX enumY smX smY)
+      then have map_eq: "map (list_of \<circ> (\<lambda>i. b (enum X i) (j0, i))) (list_of {..<card X})
+                       = map (list_of \<circ> (\<lambda>i. b (enum Y i) (j0, i))) (list_of {..<card X})"
+        by (rule concat_injective) (auto simp: len_eq split: prod.split)
+      have "enum X i = enum Y i" if "i < card X" for i
+      proof -
+        have "Inf (b (enum X i) (j0,i)) = Inf (b (enum Y i) (j0,i))"
+          using iffD1 [OF map_eq_conv, OF map_eq] Suc.prems that
+          by (metis (mono_tags, lifting) card_b_finite comp_apply finite_lessThan lessThan_iff set_sorted_list_of_set)
+        moreover have "Inf (b (enum X i) (j0,i)) \<in> (b (enum X i) (j0,i))"
+          "Inf (b (enum Y i) (j0,i)) \<in> (b (enum Y i) (j0,i))" "i < j0"
+          using Inf_nat_def1 Suc.prems b_ne enumX enumY jeq that by auto
+        ultimately show ?thesis
+          by (metis Inf_b_less enumX enumY leI nat_less_le that)
+      qed
+      then show "X = Y"
+        by (simp add: \<open>card Y = card X\<close> \<open>finite X\<close> \<open>finite Y\<close> finite_enum_ext)
+    qed
+    have BB_Suc': "BB j0 (Suc j) X = usplit (\<lambda>L k. BB j0 j L @ list_of (b k (j0, j))) X"
+      if "X \<in> USigma (\<K> j0 j) (\<lambda>K. {Max (insert j0 K)<..})" for X
+      using that
+      by (simp add: USigma_iff \<K>_finite less_sets_def usplit_def \<K>_Suc BB_Suc \<open>j \<le> j0\<close>)
+    have "ordertype (BB j0 (Suc j) ` \<K> j0 (Suc j)) ?LL
+        = ordertype
+           (usplit (\<lambda>L k. BB j0 j L @ list_of (b k (j0, j))) ` USigma (\<K> j0 j) (\<lambda>K. {Max (insert j0 K)<..})) ?LL"
+      by (simp add: BB_Suc' \<K>_Suc)
+    also have "\<dots> = \<omega> * ordertype (BB j0 j ` \<K> j0 j) ?LL"
+    proof (rule ordertype_append_image_IJ)
+      fix L k
+      assume "L \<in> \<K> j0 j" and "k \<in> {Max (insert j0 L)<..}"
+      then have "j0 < k" and L: "\<And>a. a \<in> L \<Longrightarrow> a < k"
+        by (simp_all add: \<K>_finite)
+      then show "BB j0 j L < list_of (b k (j0, j))"
+        by (simp add: \<open>L \<in> \<K> j0 j\<close> \<open>j \<le> j0\<close> \<K>_finite less_list_of)
+    next
+      show "inj_on (BB j0 j) (\<K> j0 j)"
+        by (simp add: \<K>_def inj_BB)
+    next
+      fix L
+      assume L: "L \<in> \<K> j0 j"
+      then show "less_sets L {Max (insert j0 L)<..} \<and> finite L"
+        by (metis \<K>_finite atLeast_Suc_greaterThan finite_insert less_sets_Suc_Max less_sets_weaken1 subset_insertI)
+      show "ordertype ((\<lambda>i. list_of (b i (j0, j))) ` {Max (insert j0 L)<..}) ?LL = \<omega>"
+        using L Suc.prems Suc_le_lessD ot\<omega> by blast
+    qed (auto simp: \<K>_finite card_b)
+    also have "\<dots> = \<omega> \<up> ord_of_nat (Suc j)"
+      by (metis ih One_nat_def Ord_\<omega> Ord_ord_of_nat oexp_1_right oexp_add one_V_def ord_of_nat.simps(1) ord_of_nat.simps(2) ord_of_nat_add plus_1_eq_Suc)
+    finally show ?case .
+  qed
+
+  define seqs where "seqs \<equiv> \<lambda>j0 j K. list_of (a j0) # (map (list_of \<circ> (\<lambda>i. b (enum K i) (j0,i))) (list_of {..<j}))"
+
+  have length_seqs [simp]: "length (seqs j0 j K) = Suc j" for j0 j K
+    by (simp add: seqs_def)
+
+  have BB_eq_concat_seqs: "BB j0 j K = concat (seqs j0 j K)"
+          and seqs_ne: "seqs j0 j K \<in> lists (- {[]})"
+      if K: "K \<in> \<K> j0 j" and "j \<le> j0" for K j j0
+  proof -
+    have j0: "\<And>i. i < card K \<Longrightarrow> j0 \<le> enum K i" and le_j0: "card K \<le> j0"
+      using finite_enumerate_in_set that unfolding \<K>_def nsets_def by fastforce+
+    show "BB j0 j K = concat (seqs j0 j K)"
+      using that unfolding BB_def \<K>_def nsets_def seqs_def
+      by (fastforce simp: j0 ab bb less_sets_UN2 sorted_list_of_set_Un
+          strict_mono_sets_def sorted_list_of_set_UN_lessThan)
+    have "b (enum K i) (j0, i) \<noteq> {}" if "i < card K" for i
+      using j0 le_j0 less_le_trans that by simp
+    moreover have "card K = j"
+      using K \<K>_card by blast
+    ultimately show "seqs j0 j K \<in> lists (- {[]})"
+      by (clarsimp simp: seqs_def) (metis card_b_finite sorted_list_of_set_eq_Nil_iff)
+  qed
+
+  have BB_decomp: "\<exists>cs. BB j0 j K = concat cs \<and> cs \<in> lists (- {[]})"
+    if K: "K \<in> \<K> j0 j" and "j \<le> j0" for K j j0
+    using BB_eq_concat_seqs seqs_ne K that(2) by blast
+
+  have a_subset_M: "a k \<subseteq> M k" for k
+    apply (clarsimp simp: a_def M_def DF_simps F_def Let_def split: prod.split_asm)
+    by (metis (no_types) fst_conv fst_grab_subset nxt_subset snd_conv snd_grab_subset subsetD)
+  have ba_Suc: "less_sets (b k (j,i)) (a (Suc k))" if "i < j" "j \<le> k" for i j k
+    by (meson a_subset_M bM less_sets_weaken2 nat_less_le that(1) that(2))
+  have ba: "less_sets (b k (j,i)) (a r)" if "i < j" "j \<le> k" "k < r" for i j k r
+    by (metis Suc_lessI a_ne aa ba_Suc less_sets_trans that)
+
+  have disjnt_ba: "disjnt (b k (j,i)) (a r)" if "i < j" "j \<le> k" for i j k r
+  proof (cases "k < r")
+    case True
+    then show ?thesis
+      by (simp add: ba less_sets_imp_disjnt that)
+  next
+    case False
+    then show ?thesis
+    proof -
+      have "less_sets (a r) (b k (j,i))"
+        by (metis False a_ne aa ab_same less_linear less_sets_UN2 less_sets_trans rangeI)
+      then show ?thesis
+        using disjnt_sym less_sets_imp_disjnt by blast
+    qed
+  qed
+
+  have bb_disjnt: "disjnt (b k (j,i)) (b l (r,q))"
+    if "q < r" "i < j" "j \<le> k" "r \<le> l" "j < r" for i j q r k l
+  proof (cases "k=l")
+    case True
+    with that show ?thesis
+      by (force simp: pair_less_def IJ_def intro: bb_same less_sets_imp_disjnt)
+  next
+    case False
+    with that show ?thesis
+      by (metis bb less_sets_imp_disjnt disjnt_sym nat_neq_iff)
+  qed
+
+  have sum_card_b: "(\<Sum>i<j. card (b (enum K i) (j0, i))) = enum (d j0) j - enum (d j0) 0"
+    if K: "K \<subseteq> {j0<..}" "finite K" "card K \<ge> j0" and "j \<le> j0" for j0 j K
+    using \<open>j \<le> j0\<close>
+  proof (induction j)
+    case 0
+    then show ?case
+      by auto
+  next
+    case (Suc j)
+    have dis: "disjnt (b (enum K j) (j0, j)) (\<Union>i<j. b (enum K i) (j0, i))"
+    proof (clarsimp simp add: b_disjoint)
+      fix i
+      assume "i < j"
+      show "disjnt (b (enum K j) (j0, j)) (b (enum K i) (j0,i))"
+        by (meson Suc.prems \<open>i < j\<close> b_disjoint_less disjnt_def disjnt_sym less_Suc_eq that)
+    qed
+    have j0_less: "j0 < enum K j"
+      by (meson Suc.prems Suc_le_lessD finite_enumerate_in_set greaterThan_iff less_le_trans subsetD K)
+    have "(\<Sum>i<Suc j. card (b (enum K i) (j0, i)))
+          = card (b (enum K j) (j0, j)) + (\<Sum>i<j. card (b (enum K i) (j0, i)))"
+      by (simp add: lessThan_Suc card_Un_disjnt [OF _ _ dis])
+    also have "\<dots> = card (b (enum K j) (j0, j)) + enum (d j0) j - enum (d j0) 0"
+      using \<open>Suc j \<le> j0\<close> by (simp add: Suc.IH split: nat_diff_split)
+    also have "\<dots> = enum (d j0) (Suc j) - enum (d j0) 0"
+      using j0_less
+      apply (simp add: card_b split: nat_diff_split)
+      by (metis Suc.prems card_d finite_d finite_enumerate_step le_imp_less_Suc less_asym)
+    finally show ?case .
+  qed
+
+  have card_UN_b: "card (\<Union>i<j. b (enum K i) (j0, i)) = enum (d j0) j - enum (d j0) 0"
+    if K: "K \<subseteq> {j0<..}" "finite K" "card K \<ge> j0" and "j \<le> j0" for j0 j K
+    using that by (simp add: card_UN_disjoint sum_card_b b_disjoint)
+
+  have len_BB: "length (BB j j K) = enum (d j) j"
+    if K: "K \<in> \<K> j j" and "j \<le> j" for j K
+  proof -
+    have dis_ab: "\<And>i. i < j \<Longrightarrow> disjnt (a j) (b (enum K i) (j,i))"
+      using K \<K>_card \<K>_enum ab less_sets_imp_disjnt nat_less_le by blast
+    show ?thesis
+      using K unfolding BB_def \<K>_def nsets_def
+      by (simp add: card_UN_b card_Un_disjnt dis_ab card_a cInf_le_finite finite_enumerate_in_set enum_0_eq_Inf_finite)
+  qed
+
+  have "less_sets (d k) (d (Suc k))" for k
+    by (metis aM a_ne d_eq da less_sets_fst_grab less_sets_trans less_sets_weaken2 nxt_subset)
+  then have dd: "less_sets (d k') (d k)" if "k' < k" for k' k
+    by (meson UNIV_I d_ne less_sets_imp_strict_mono_sets strict_mono_sets_def that)
+
+  show thesis
+  proof
+    show "(\<Union> (range XX)) \<subseteq> WW"
+      by (auto simp: XX_def BB_def WW_def)
+    show "ordertype (\<Union> (range XX)) (?LL) = \<omega> \<up> \<omega>"
+      using ot\<omega>j by (simp add: XX_def ordertype_\<omega>\<omega>)
+  next
+    fix U
+    assume U: "U \<in> [\<Union> (range XX)]\<^bsup>2\<^esup>"
+    then obtain x y where Ueq: "U = {x,y}" and len_xy: "length x \<le> length y"
+      by (auto simp: lenlex_nsets_2_eq lenlex_length)
+
+    show "\<exists>l. Form l U \<and> (0 < l \<longrightarrow> [enum N l] < inter_scheme l U \<and> list.set (inter_scheme l U) \<subseteq> N)"
+    proof (cases "length x = length y")
+      case True
+      then show ?thesis
+        using Form.intros(1) U Ueq by fastforce
+    next
+      case False
+      then have xy: "length x < length y"
+        using len_xy by auto
+      obtain j r K L where K: "K \<in> \<K> j j" and xeq: "x = BB j j K"
+        and ne: "BB j j K \<noteq> BB r r L"
+        and L: "L \<in> \<K> r r" and yeq: "y = BB r r L"
+        using U by (auto simp: Ueq XX_def)
+      then have "length x = enum (d j) j" "length y = enum (d r) r"
+        by (auto simp: len_BB)
+      then have "j < r"
+        using xy dd
+        by (metis card_d finite_enumerate_in_set finite_d lessI less_asym less_setsD linorder_neqE_nat)
+      then have aj_ar: "less_sets (a j) (a r)"
+        using aa by auto
+      have Ksub: "K \<subseteq> {j<..}" and "finite K" "card K \<ge> j"
+        using K by (auto simp: \<K>_def nsets_def)
+      have Lsub: "L \<subseteq> {r<..}" and "finite L" "card L \<ge> r"
+        using L by (auto simp: \<K>_def nsets_def)
+      have enumK: "enum K i > j" if "i < j" for i
+        using K \<K>_card \<K>_enum that by blast
+      have enumL: "enum L i > r" if "i < r" for i
+        using L \<K>_card \<K>_enum that by blast
+      have "list.set (acc_lengths w (seqs j0 j K)) \<subseteq> (+) w ` d j0"
+        if K: "K \<subseteq> {j0<..}" "finite K" "card K \<ge> j0" and "j \<le> j0" for j0 j K w
+        using \<open>j \<le> j0\<close>
+      proof (induction j arbitrary: w)
+        case 0
+        then show ?case
+          by (simp add: seqs_def acc_lengths.simps Inf_nat_def1 card_a)
+      next
+        case (Suc j)
+        let ?db = "\<Sqinter> (d j0) + ((\<Sum>i<j. card (b (enum K i) (j0,i))) + card (b (enum K j) (j0,j)))"
+        have "j0 < enum K j"
+          by (meson Suc.prems Suc_le_lessD finite_enumerate_in_set greaterThan_iff le_trans subsetD K)
+        then have "?db = enum (d j0) (Suc j)"
+          using Suc.prems
+          apply (simp add: sum_card_b card_b that enum_d_0 split: nat_diff_split)
+          by (simp add: cInf_le_finite finite_enumerate_in_set leD)
+        then have "?db \<in> d j0"
+          using Suc.prems finite_enumerate_in_set by (auto simp: finite_enumerate_in_set)
+        moreover have "list.set (acc_lengths w (seqs j0 j K)) \<subseteq> (+) w ` d j0"
+          by (simp add: Suc Suc_leD)
+        then have "list.set (acc_lengths (w + \<Sqinter> (d j0))
+                             (map (list_of \<circ> (\<lambda>i. b (enum K i) (j0,i))) (list_of {..<j})))
+                   \<subseteq> (+) w ` d j0"
+          by (simp add: seqs_def acc_lengths.simps card_a subset_insertI)
+        ultimately show ?case
+          by (simp add: seqs_def acc_lengths.simps acc_lengths_append image_iff Inf_nat_def1
+                        sum_sorted_list_of_set_map card_a)
+      qed
+      then have acc_lengths_subset_d: "list.set (acc_lengths 0 (seqs j0 j K)) \<subseteq> d j0"
+        if K: "K \<subseteq> {j0<..}" "finite K" "card K \<ge> j0" and "j \<le> j0" for j0 j K
+        by (metis image_add_0 that)
+
+      have "strict_sorted x" "strict_sorted y"
+        by (auto simp: xeq yeq BB_def)
+      have disjnt_xy: "disjnt (list.set x) (list.set y)"
+      proof -
+        have "disjnt (a j) (a r)"
+          using \<open>j < r\<close> aa less_sets_imp_disjnt by blast
+        moreover have "disjnt (b (enum K i) (j,i)) (a r)" if "i < j" for i
+          by (simp add: disjnt_ba enumK less_imp_le_nat that)
+        moreover have "disjnt (a j) (b (enum L q) (r,q))" if "q < r" for q
+          by (meson disjnt_ba disjnt_sym enumL less_imp_le_nat that)
+        moreover have "disjnt (b (enum K i) (j,i)) (b (enum L q) (r,q))" if "i < j" "q < r" for i q
+        by (meson \<open>j < r\<close> bb_disjnt enumK enumL less_imp_le that)
+      ultimately show ?thesis
+          by (simp add: xeq yeq BB_def)
+      qed
+      have "\<exists>us vs. merge (seqs j j K) (seqs r r L) us vs"
+      proof (rule merge_exists)
+        show "strict_sorted (concat (seqs j j K))"
+          using BB_eq_concat_seqs K \<open>strict_sorted x\<close> xeq by auto
+        show "strict_sorted (concat (seqs r r L))"
+          using BB_eq_concat_seqs L \<open>strict_sorted y\<close> yeq by auto
+        show "seqs j j K \<in> lists (- {[]})" "seqs r r L \<in> lists (- {[]})"
+          by (auto simp: K L seqs_ne)
+        show "hd (seqs j j K) < hd (seqs r r L)"
+          by (simp add: aj_ar less_sets_imp_list_less seqs_def)
+        show "seqs j j K \<noteq> []" "seqs r r L \<noteq> []"
+          using seqs_def by blast+
+        have less_bb: "less_sets (b (enum K i) (j,i)) (b (enum L p) (r, p))"
+          if neg: "\<not> less_sets (b (enum L p) (r, p)) (b (enum K i) (j,i))" and "i < j" "p < r"
+          for i p
+        proof (cases "enum K i" "enum L p" rule: linorder_cases)
+          case less
+          then show ?thesis
+            by (simp add: bb enumK less_imp_le_nat \<open>i < j\<close>)
+        next
+          case equal
+          then show ?thesis
+            using \<open>j < r\<close> enumK \<open>i < j\<close> by (force simp: IJ_iff pair_less_def intro: bb_same)
+        next
+          case greater
+          then show ?thesis
+            using bb enumL less_imp_le_nat neg \<open>p < r\<close> by blast
+        qed
+        show "u < v \<or> v < u"
+          if "u \<in> list.set (seqs j j K)" and "v \<in> list.set (seqs r r L)" for u v
+          using that enumK enumL
+          apply (auto simp: seqs_def aj_ar intro!: less_bb less_sets_imp_list_less)
+          apply (meson ab ba less_imp_le_nat not_le)+
+          done
+      qed
+      then obtain uus vvs where merge: "merge (seqs j j K) (seqs r r L) uus vvs"
+        by metis
+      then have "uus \<noteq> []"
+        using merge_length1_gt_0 by (auto simp: seqs_def)
+      then obtain u1 us where us: "u1#us = uus"
+        by (metis neq_Nil_conv)
+      define ku where "ku \<equiv> length (u1#us)"
+      define ps where "ps \<equiv> acc_lengths 0 (u1#us)"
+      have us_ne: "u1#us \<in> lists (- {[]})"
+        using merge_length1_nonempty seqs_ne us merge us K by auto
+      have xu_eq: "x = concat (u1#us)"
+        using BB_eq_concat_seqs K merge merge_preserves us xeq by auto
+      then have "strict_sorted u1"
+        using \<open>strict_sorted x\<close> strict_sorted_append_iff by auto
+      have u_sub: "list.set ps \<subseteq> list.set (acc_lengths 0 (seqs j j K))"
+        using acc_lengths_merge1 merge ps_def us by blast
+      have "vvs \<noteq> []"
+        using merge BB_eq_concat_seqs L merge_preserves xy yeq by auto
+      then obtain v1 vs where vs: "v1#vs = vvs"
+        by (metis neq_Nil_conv)
+      define kv where "kv \<equiv> length (v1#vs)"
+      define qs where "qs \<equiv> acc_lengths 0 (v1#vs)"
+      have vs_ne: "v1#vs \<in> lists (- {[]})"
+        using L merge merge_length2_nonempty seqs_ne vs by auto
+      have yv_eq: "y = concat (v1#vs)"
+        using BB_eq_concat_seqs L merge merge_preserves vs yeq by auto
+      then have "strict_sorted v1"
+        using \<open>strict_sorted y\<close> strict_sorted_append_iff by auto
+      have v_sub: "list.set qs \<subseteq> list.set (acc_lengths 0 (seqs r r L))"
+        using acc_lengths_merge2 merge qs_def vs by blast
+
+      have ss_concat_jj: "strict_sorted (concat (seqs j j K))"
+        using BB_eq_concat_seqs K \<open>strict_sorted x\<close> xeq by auto
+      then obtain k: "0 < kv" "kv \<le> ku" "ku \<le> Suc kv" "kv \<le> Suc j"
+        using us vs merge_length_le merge_length_le_Suc merge_length_less2 merge
+        unfolding ku_def kv_def by fastforce
+
+      define zs where "zs \<equiv> concat [ps,u1,qs,v1] @ interact us vs"
+      have ss: "strict_sorted zs"
+      proof -
+        have ssp: "strict_sorted ps"
+          unfolding ps_def by (meson strict_sorted_acc_lengths us_ne)
+        have ssq: "strict_sorted qs"
+          unfolding qs_def by (meson strict_sorted_acc_lengths vs_ne)
+
+        have "less_sets (d j) (list.set x)"
+          using da [of j] db [of j]  K \<K>_card \<K>_enum nat_less_le
+          by (auto simp: xeq BB_def less_sets_Un2 less_sets_UN2)
+        then have ac_x: "acc_lengths 0 (seqs j j K) < x"
+          by (meson Ksub \<open>finite K\<close> \<open>j \<le> card K\<close> acc_lengths_subset_d dual_order.refl less_sets_imp_list_less less_sets_weaken1)
+        then have "ps < u1"
+          by (metis K Ksub UnI1 \<K>_card \<open>finite K\<close> \<open>j \<le> card K\<close> \<open>less_sets (d j) (list.set x)\<close> acc_lengths_subset_d concat.simps(2) empty_iff empty_set hd_append2 less_list_def less_sets_imp_list_less less_sets_weaken1 list.set_sel(1) set_append u_sub xu_eq)
+
+        have "less_sets (d r) (list.set y)"
+          using da [of r] db [of r]  L \<K>_card \<K>_enum nat_less_le
+          by (auto simp: yeq BB_def less_sets_Un2 less_sets_UN2)
+        then have "acc_lengths 0 (seqs r r L) < y"
+          by (meson Lsub \<open>finite L\<close> \<open>r \<le> card L\<close> acc_lengths_subset_d dual_order.refl less_sets_imp_list_less less_sets_weaken1)
+        then have "qs < v1"
+          by (metis L Lsub UnI1 \<K>_card \<open>finite L\<close> \<open>r \<le> card L\<close> \<open>less_sets (d r) (list.set y)\<close> acc_lengths_subset_d concat.simps(2) empty_iff empty_set hd_append2 less_list_def less_sets_imp_list_less less_sets_weaken1 list.set_sel(1) set_append v_sub yv_eq)
+
+        have carda_v1: "card (a r) \<le> length v1"
+          using length_hd_merge2 [OF merge] unfolding vs [symmetric] by (simp add: seqs_def)
+        have ab_enumK: "\<And>i. i < j \<Longrightarrow> less_sets (a j) (b (enum K i) (j,i))"
+          by (meson ab enumK le_trans less_imp_le_nat)
+
+        have ab_enumL: "\<And>q. q < r \<Longrightarrow> less_sets (a j) (b (enum L q) (r,q))"
+          by (meson \<open>j < r\<close> ab enumL le_trans less_imp_le_nat)
+        then have ay: "less_sets (a j) (list.set y)"
+          by (auto simp: yeq BB_def less_sets_Un2 less_sets_UN2 aj_ar)
+
+        have disjnt_hd_last_K_y: "disjnt {hd l..last l} (list.set y)"
+          if l: "l \<in> list.set (seqs j j K)" for l
+        proof (clarsimp simp add: yeq BB_def disjnt_iff Ball_def, intro conjI strip)
+          fix u
+          assume u: "u \<le> last l" and "hd l \<le> u"
+          with l consider "u \<le> last (list_of (a j))" "hd (list_of (a j)) \<le> u"
+            | i where "i<j" "u \<le> last (list_of (b (enum K i) (j,i)))" "hd (list_of (b (enum K i) (j,i))) \<le> u"
+            by (force simp: seqs_def)
+          note l_cases = this
+          then show "u \<notin> a r"
+          proof cases
+            case 1
+            then show ?thesis
+              by (metis a_ne aj_ar finite_a last_in_set leD less_setsD set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff)
+          next
+            case 2
+            then show ?thesis
+              by (metis enumK ab ba Inf_nat_def1 b_ne card_b_finite hd_b last_in_set less_asym less_setsD not_le set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff)
+          qed
+          fix q
+          assume "q < r"
+          show "u \<notin> b (enum L q) (r,q)" using l_cases
+          proof cases
+            case 1
+            then show ?thesis
+              by (metis \<open>q < r\<close> a_ne ab_enumL finite_a last_in_set leD less_setsD set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff)
+          next
+            case 2
+            show ?thesis
+            proof (cases "enum K i = enum L q")
+              case True
+              then show ?thesis
+                using 2 bb_same [of concl: "enum L q" j i r q] \<open>j < r\<close>
+                apply (simp add: IJ_def pair_less_def less_sets_def)
+                by (metis enumK b_ne card_b_finite last_in_set leD less_imp_le_nat set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff)
+            next
+              case False
+              with 2 bb enumK enumL show ?thesis
+                unfolding less_sets_def
+                by (metis \<open>q < r\<close> b_ne card_b_finite last_in_set leD less_imp_le_nat list.set_sel(1) nat_neq_iff set_sorted_list_of_set sorted_list_of_set_eq_Nil_iff)
+            qed
+          qed
+        qed
+
+        have u1_y: "less_sets (list.set u1) (list.set y)"
+          using vs yv_eq L \<open>strict_sorted y\<close> merge merge_less_sets_hd merge_preserves seqs_ne ss_concat_jj us by fastforce
+        have u1_subset_seqs: "list.set u1 \<subseteq> list.set (concat (seqs j j K))"
+          using merge_preserves [OF merge] us by auto
+
+        have "less_sets (b k (j,i)) (d (Suc k))" if "j\<le>k" "i<j" for k j i
+          by (metis bM d_eq less_sets_fst_grab less_sets_weaken2 nxt_subset that)
+        then have bd: "less_sets (b k (j,i)) (d k')" if "j\<le>k" "i<j" "k < k'" for k k' j i
+          by (metis Suc_lessI d_ne dd less_sets_trans that)
+
+        have "less_sets (a k) (d (Suc k))" for k
+          by (metis aM d_eq less_sets_fst_grab less_sets_weaken2 nxt_subset)
+        then have ad: "less_sets (a k) (d k')" if "k<k'" for k k'
+          by (metis Suc_lessI d_ne dd less_sets_trans that)
+
+        have "u1 < y"
+          by (simp add: u1_y less_sets_imp_list_less)
+        have "n < Inf (d r)" if n: "n \<in> list.set u1" for n
+        proof -
+          obtain l where l: "l \<in> list.set (seqs j j K)" and n: "n \<in> list.set l"
+            using n u1_subset_seqs by auto
+          then consider "l = list_of (a j)" | i where "l = list_of (b (enum K i) (j,i))" "i < j"
+            by (force simp: seqs_def)
+          then show ?thesis
+          proof cases
+            case 1
+            then show ?thesis
+              by (metis Inf_nat_def1 \<open>j < r\<close> ad d_ne finite_a less_setsD n set_sorted_list_of_set)
+          next
+            case 2
+            then have "Min (b (enum K i) (j,i)) \<le> n"
+              using n by (simp add: less_list_def disjnt_iff less_sets_def)
+            also have f8: "n < hd y"
+              using less_setsD that u1_y
+              by (metis gr_implies_not0 list.set_sel(1) list.size(3) xy)
+            finally have "l < y"
+              using 2 disjnt_hd_last_K_y [OF l] u1_y
+              apply (simp add: less_list_def disjnt_iff)
+              by (metis card_b_finite hd_list_of leI less_imp_le_nat list.set_sel(1))
+            moreover have "last (list_of (b (enum K i) (j,i))) < hd (list_of (a r))"
+              using \<open>l < y\<close> L n by (auto simp:  2yeq BB_eq_concat_seqs seqs_def less_list_def)
+            then have "enum K i < r"
+              by (metis "2"(1) a_ne ab card_b_finite empty_iff finite.emptyI finite_a last_in_set leI less_asym less_setsD list.set_sel(1) n set_sorted_list_of_set)
+            moreover have "j \<le> enum K i"
+              by (simp add: "2"(2) enumK less_imp_le_nat)
+            ultimately show ?thesis
+              using 2 n bd [of j "enum K i" i r] Inf_nat_def1 less_setsD by force
+          qed
+        qed
+        then have "last u1 < Inf (d r)"
+          using \<open>uus \<noteq> []\<close> us_ne by auto
+        also have "\<dots> \<le> length v1"
+          using card_a carda_v1 by auto
+        finally have "last u1 < length v1" .
+        then have "u1 < qs"
+          by (simp add: qs_def acc_lengths.simps less_list_def)
+
+        have "strict_sorted (interact (u1#us) (v1#vs))"
+          using L \<open>strict_sorted x\<close> \<open>strict_sorted y\<close> merge merge_interact merge_preserves seqs_ne us vs xu_eq yv_eq by auto
+        then have "strict_sorted (interact us vs)" "v1 < interact us vs"
+          by (auto simp: strict_sorted_append_iff)
+        moreover have "ps < u1 @ qs @ v1 @ interact us vs"
+          using \<open>ps < u1\<close> us_ne unfolding less_list_def by auto
+        moreover have "u1 < qs @ v1 @ interact us vs"
+          by (metis \<open>u1 < qs\<close> \<open>vvs \<noteq> []\<close> acc_lengths_eq_Nil_iff hd_append less_list_def qs_def vs)
+        moreover have "qs < v1 @ interact us vs"
+          using \<open>qs < v1\<close> us_ne \<open>last u1 < length v1\<close> vs_ne by (auto simp: less_list_def)
+        ultimately show ?thesis
+          by (simp add: zs_def strict_sorted_append_iff ssp ssq \<open>strict_sorted u1\<close> \<open>strict_sorted v1\<close>)
+      qed
+      have ps_subset_d: "list.set ps \<subseteq> d j"
+          using K Ksub \<K>_card \<open>finite K\<close> acc_lengths_subset_d u_sub by blast
+      have ps_less_u1: "ps < u1"
+      proof -
+        have "hd u1 = hd x"
+          using us_ne by (auto simp: xu_eq)
+        then have "hd u1 \<in> a j"
+          by (simp add: xeq BB_eq_concat_seqs K seqs_def hd_append hd_list_of)
+        then have "less_sets (list.set ps) {hd u1}"
+          by (metis da ps_subset_d less_sets_def singletonD subset_iff)
+        then show ?thesis
+          by (metis less_hd_imp_less list.set(2) empty_set less_sets_imp_list_less)
+      qed
+      have qs_subset_d: "list.set qs \<subseteq> d r"
+        using L Lsub \<K>_card \<open>finite L\<close> acc_lengths_subset_d v_sub by blast
+      have qs_less_v1: "qs < v1"
+      proof -
+        have "hd v1 = hd y"
+          using vs_ne by (auto simp: yv_eq)
+        then have "hd v1 \<in> a r"
+          by (simp add: yeq BB_eq_concat_seqs L seqs_def hd_append hd_list_of)
+        then have "less_sets (list.set qs) {hd v1}"
+          by (metis da qs_subset_d less_sets_def singletonD subset_iff)
+        then show ?thesis
+          by (metis less_hd_imp_less list.set(2) empty_set less_sets_imp_list_less)
+      qed
+      have FB: "Form_Body ku kv x y zs"
+        unfolding Form_Body.simps
+        using ku_def kv_def ps_def qs_def ss us_ne vs_ne xu_eq xy yv_eq zs_def by blast
+      then have "zs = (inter_scheme ((ku+kv) - Suc 0) {x,y})"
+        by (simp add: Form_Body_imp_inter_scheme k)
+      obtain l where "l \<le> 2 * (Suc j)" and l: "Form l U" and zs_eq_interact: "zs = inter_scheme l {x,y}"
+      proof
+        show "ku+kv-1 \<le> 2 * (Suc j)"
+          using k by auto
+        show "Form (ku+kv-1) U"
+        proof (cases "ku=kv")
+          case True
+          then show ?thesis
+            using FB Form.simps Ueq \<open>0 < kv\<close> by (auto simp: mult_2)
+        next
+          case False
+          then have "ku = Suc kv"
+            using k by auto
+          then show ?thesis
+            using FB Form.simps Ueq \<open>0 < kv\<close> by auto
+        qed
+        show "zs = inter_scheme (ku + kv - 1) {x, y}"
+          using Form_Body_imp_inter_scheme by (simp add: FB k)
+      qed
+      then have "enum N l \<le> enum N (Suc (2 * Suc j))"
+        by (simp add: assms less_imp_le_nat)
+      also have "\<dots> < Min (d j)"
+        by (metis Min_in card_0_eq card_d d_eq finite_d fst_grab_subset greaterThan_iff in_mono le_inf_iff nxt_def old.nat.distinct(2))
+      finally have ls: "less_sets {enum N l} (d j)"
+        by simp
+      have "l > 0"
+        by (metis l False Form_0_cases_raw Set.doubleton_eq_iff Ueq gr0I)
+      show ?thesis
+        unfolding Ueq
+      proof (intro exI conjI impI)
+        have zs_subset: "list.set zs \<subseteq> list.set (acc_lengths 0 (seqs j j K)) \<union> list.set (acc_lengths 0 (seqs r r L)) \<union> list.set x \<union> list.set y"
+          using u_sub v_sub by (auto simp: zs_def xu_eq yv_eq)
+        also have "\<dots> \<subseteq> N"
+        proof (simp, intro conjI)
+          show "list.set (acc_lengths 0 (seqs j j K)) \<subseteq> N"
+            using d_subset_N Ksub \<open>finite K\<close> \<open>j \<le> card K\<close> acc_lengths_subset_d by blast
+          show "list.set (acc_lengths 0 (seqs r r L)) \<subseteq> N"
+            using d_subset_N Lsub \<open>finite L\<close> \<open>r \<le> card L\<close> acc_lengths_subset_d by blast
+          show "list.set x \<subseteq> N" "list.set y \<subseteq> N"
+            by (simp_all add: xeq yeq BB_def a_subset_N UN_least b_subset_N)
+        qed
+        finally show "list.set (inter_scheme l {x, y}) \<subseteq> N"
+          using zs_eq_interact by blast
+        have "[enum N l] < ps"
+          using ps_subset_d ls
+          by (metis empty_set less_sets_imp_list_less less_sets_weaken2 list.simps(15))
+        then show "[enum N l] < inter_scheme l {x, y}"
+          by (simp add: zs_def less_list_def ps_def flip: zs_eq_interact)
+      qed (use Ueq l in blast)
+    qed
+  qed
+qed
+
+
+
+
+subsection \<open>The main partition theorem for @{term "\<omega>\<up>\<omega>"}\<close>
+
+definition iso_ll where "iso_ll A B \<equiv> iso (lenlex less_than \<inter> (A\<times>A)) (lenlex less_than \<inter> (B\<times>B))"
+
+corollary ordertype_eq_ordertype_iso_ll:
+  assumes "Field (Restr (lenlex less_than) A) = A" "Field (Restr (lenlex less_than) B) = B"
+  shows "(ordertype A (lenlex less_than) = ordertype B (lenlex less_than))
+         \<longleftrightarrow> (\<exists>f. iso_ll A B f)"
+proof -
+  have "total_on A (lenlex less_than) \<and> total_on B (lenlex less_than)"
+    by (meson UNIV_I total_lenlex total_on_def total_on_less_than)
+  then show ?thesis
+    by (simp add: assms wf_lenlex lenlex_transI iso_ll_def ordertype_eq_ordertype_iso_Restr)
+qed
+
+theorem partition_\<omega>\<omega>_aux:
+  assumes "\<alpha> \<in> elts \<omega>"
+  shows "partn_lst (lenlex less_than) WW [\<omega>\<up>\<omega>,\<alpha>] 2" (is "partn_lst ?R WW [\<omega>\<up>\<omega>,\<alpha>] 2")
+proof (cases "\<alpha> \<le> 1")
+  case True
+  then show ?thesis
+    using strict_sorted_into_WW unfolding WW_def by (auto intro!: partn_lst_triv1[where i=1])
+next
+  case False
+  obtain m where m: "\<alpha> = ord_of_nat m"
+    using assms elts_\<omega> by auto
+  then have "m>1"
+    using False by auto
+  show ?thesis
+    unfolding partn_lst_def
+  proof clarsimp
+    fix f
+    assume f: "f \<in> [WW]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
+    let ?P0 = "\<exists>X \<subseteq> WW. ordertype X ?R = \<omega>\<up>\<omega> \<and> f ` [X]\<^bsup>2\<^esup> \<subseteq> {0}"
+    let ?P1 = "\<exists>M \<subseteq> WW. ordertype M ?R = \<alpha> \<and> f ` [M]\<^bsup>2\<^esup> \<subseteq> {1}"
+    have \<dagger>: "?P0 \<or> ?P1"
+    proof (rule disjCI)
+      assume not1: "\<not> ?P1"
+      have "\<exists>W'. ordertype W' ?R = \<omega>\<up>n \<and> f ` [W']\<^bsup>2\<^esup> \<subseteq> {0} \<and> W' \<subseteq> WW_seg (n*m)" for n::nat
+      proof -
+        have fnm: "f \<in> [WW_seg (n*m)]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
+          using f WW_seg_subset_WW [of "n*m"] by (meson in_mono nsets_Pi_contra)
+        have *: "partn_lst ?R (WW_seg (n*m)) [\<omega>\<up>n, ord_of_nat m] 2"
+          using ordertype_WW_seg [of "n*m"]
+          by (simp add: partn_lst_VWF_imp_partn_lst [OF Theorem_3_2])
+        show ?thesis
+          using partn_lst_E [OF * fnm, simplified]
+          by (metis (no_types, hide_lams) One_nat_def Suc_1 WW_seg_subset_WW order.trans less_2_cases m not1 nth_Cons' nth_Cons_Suc)
+      qed
+      then obtain W':: "nat \<Rightarrow> nat list set"
+          where otW': "\<And>n. ordertype (W' n) ?R = \<omega>\<up>n"
+          and f_W': "\<And>n. f ` [W' n]\<^bsup>2\<^esup> \<subseteq> {0}"
+          and seg_W': "\<And>n. W' n \<subseteq> WW_seg (n*m)"
+        by metis
+      define WW' where "WW' \<equiv> (\<Union>n. W' n)"
+      have "WW' \<subseteq> WW"
+        using seg_W' WW_seg_subset_WW by (force simp: WW'_def)
+      with f have f': "f \<in> [WW']\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
+        using nsets_mono by fastforce
+      have ot': "ordertype WW' ?R = \<omega>\<up>\<omega>"
+      proof (rule antisym)
+        have "ordertype WW' ?R \<le> ordertype WW ?R"
+          by (simp add: \<open>WW' \<subseteq> WW\<close> lenlex_transI ordertype_mono wf_lenlex)
+        with ordertype_WW
+        show "ordertype WW' ?R \<le> \<omega> \<up> \<omega>"
+          by simp
+        have "\<omega> \<up> n \<le> ordertype (\<Union> (range W')) ?R" for n::nat
+          by (metis TC_small UNIV_I UN_I otW' lenlex_transI ordertype_mono subsetI trans_less_than wf_lenlex wf_less_than)
+        then show "\<omega> \<up> \<omega> \<le> ordertype WW' ?R"
+          by (auto simp: elts_\<omega> oexp_Limit ZFC_in_HOL.SUP_le_iff WW'_def)
+      qed
+      have FR_WW: "Field (Restr (lenlex less_than) WW) = WW"
+        by (simp add: Limit_omega_oexp Limit_ordertype_imp_Field_Restr ordertype_WW)
+      have FR_WW': "Field (Restr (lenlex less_than) WW') = WW'"
+        by (simp add: Limit_omega_oexp Limit_ordertype_imp_Field_Restr ot')
+      have FR_W: "Field (Restr (lenlex less_than) (WW_seg n)) = WW_seg n" if "n>0" for n
+        by (simp add: Limit_omega_oexp ordertype_WW_seg that Limit_ordertype_imp_Field_Restr)
+      have FR_W': "Field (Restr (lenlex less_than) (W' n)) = W' n" if "n>0" for n
+        by (simp add: Limit_omega_oexp otW' that Limit_ordertype_imp_Field_Restr)
+      have "\<exists>h. iso_ll (WW_seg n) (W' n) h" if "n>0" for n
+      proof (subst ordertype_eq_ordertype_iso_ll [symmetric])
+        show "ordertype (WW_seg n) (lenlex less_than) = ordertype (W' n) (lenlex less_than)"
+          by (simp add: ordertype_WW_seg otW')
+      qed (auto simp: FR_W FR_W' that)
+      then obtain h_seg where h_seg: "\<And>n. n > 0 \<Longrightarrow> iso_ll (WW_seg n) (W' n) (h_seg n)"
+        by metis
+      define h where "h \<equiv> \<lambda>l. if l=[] then [] else h_seg (length l) l"
+
+      have bij_h_seg: "\<And>n. n > 0 \<Longrightarrow> bij_betw (h_seg n) (WW_seg n) (W' n)"
+        using h_seg by (simp add: iso_ll_def iso_iff2 FR_W FR_W')
+      have len_h_seg: "length (h_seg (length l) l) = length l * m"
+        if "length l > 0" "l \<in> WW" for l
+        using bij_betwE [OF bij_h_seg] seg_W' that by (simp add: WW_seg_def subset_iff)
+      have hlen: "length (h x) = length (h y) \<longleftrightarrow> length x = length y" if "x \<in> WW" "y \<in> WW" for x y
+        using that \<open>1 < m\<close> h_def len_h_seg by force
+
+      have h: "iso_ll WW WW' h"
+        unfolding iso_ll_def iso_iff2 FR_WW FR_WW'
+      proof (intro conjI strip)
+        have W'_ne: "W' n \<noteq> {}" for n
+          using otW' [of n] by auto
+        then have "[] \<in> WW'"
+          using seg_W' [of 0] by (auto simp: WW'_def WW_seg_def)
+        let ?g = "\<lambda>l. if l=[] then l else inv_into (WW_seg (length l div m)) (h_seg (length l div m)) l"
+        have h_seg_iff: "\<And>n a b. \<lbrakk>a \<in> WW_seg n; b \<in> WW_seg n; n>0\<rbrakk> \<Longrightarrow>
+                          (a, b) \<in> lenlex less_than \<longleftrightarrow>
+                          (h_seg n a, h_seg n b) \<in> lenlex less_than \<and> h_seg n a \<in> W' n \<and> h_seg n b \<in> W' n"
+          using h_seg by (auto simp: iso_ll_def iso_iff2 FR_W FR_W')
+
+        show "bij_betw h WW WW'"
+          unfolding bij_betw_iff_bijections
+        proof (intro exI conjI ballI)
+          fix l
+          assume "l \<in> WW"
+          then have l: "l \<in> WW_seg (length l)"
+            by (simp add: WW_seg_def)
+          have "h l \<in> W' (length l)"
+          proof (cases "l=[]")
+            case True
+            with seg_W' [of 0] W'_ne show ?thesis
+              by (auto simp: WW_seg_def h_def)
+          next
+            case False
+            then show ?thesis
+              using bij_betwE bij_h_seg h_def l by fastforce
+          qed
+          show "h l \<in> WW'"
+            using WW'_def \<open>h l \<in> W' (length l)\<close> by blast
+          show "?g (h l) = l"
+          proof (cases "l=[]")
+            case False
+            then have "length l > 0"
+              by auto
+            then have "h_seg (length l) l \<noteq> []"
+              using \<open>1 < m\<close> \<open>l \<in> WW\<close> len_h_seg by fastforce
+            with \<open>1 < m\<close> show ?thesis
+              apply (simp add: h_def len_h_seg \<open>l \<in> WW\<close>)
+              by (meson \<open>0 < length l\<close> bij_betw_inv_into_left bij_h_seg l)
+          qed (auto simp: h_def)
+        next
+          fix l
+          assume "l \<in> WW'"
+          then have l: "l \<in> W' (length l div m)"
+            using WW_seg_def \<open>1 < m\<close> seg_W' by (fastforce simp: WW'_def)
+          show "?g l \<in> WW"
+          proof (cases "l=[]")
+            case False
+            then have "l \<notin> W' 0"
+              using WW_seg_def seg_W' by fastforce
+            with l have "inv_into (WW_seg (length l div m)) (h_seg (length l div m)) l \<in> WW_seg (length l div m)"
+              by (metis Nat.neq0_conv bij_betwE bij_betw_inv_into bij_h_seg)
+            then show ?thesis
+              using False WW_seg_subset_WW by auto
+          qed (auto simp: WW_def)
+
+          show "h (?g l) = l"
+          proof (cases "l=[]")
+            case False
+            then have "0 < length l div m"
+              using WW_seg_def l seg_W' by fastforce
+            then have "inv_into (WW_seg (length l div m)) (h_seg (length l div m)) l \<in> WW_seg (length l div m)"
+              by (metis bij_betw_imp_surj_on bij_h_seg inv_into_into l)
+            then show ?thesis
+              using bij_h_seg [of "length l div m"] WW_seg_def \<open>0 < length l div m\<close> bij_betw_inv_into_right l
+              by (fastforce simp add: h_def)
+          qed (auto simp: h_def)
+        qed
+        fix a b
+        assume "a \<in> WW" "b \<in> WW"
+        show "(a, b) \<in> Restr (lenlex less_than) WW \<longleftrightarrow> (h a, h b) \<in> Restr (lenlex less_than) WW'"
+          (is "?lhs = ?rhs")
+        proof
+          assume L: ?lhs
+          then consider "length a < length b" | "length a = length b" "(a, b) \<in> lex less_than"
+            by (auto simp: lenlex_conv)
+          then show ?rhs
+          proof cases
+            case 1
+            then have "length (h a) < length (h b)"
+              using \<open>1 < m\<close> \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> h_def len_h_seg by auto
+            then have "(h a, h b) \<in> lenlex less_than"
+              by (auto simp: lenlex_conv)
+            then show ?thesis
+              using \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> \<open>bij_betw h WW WW'\<close> bij_betwE by fastforce
+          next
+            case 2
+            then have ab: "a \<in> WW_seg (length a)" "b \<in> WW_seg (length a)"
+              using \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> by (auto simp: WW_seg_def)
+            have "length (h a) = length (h b)"
+              using 2 \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> h_def len_h_seg by force
+            moreover have "(a, b) \<in> lenlex less_than"
+              using L by blast
+            then have "(h_seg (length a) a, h_seg (length a) b) \<in> lenlex less_than"
+              using 2 ab h_seg_iff by blast
+            ultimately show ?thesis
+              using 2 \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> \<open>bij_betw h WW WW'\<close> bij_betwE h_def by fastforce
+          qed
+        next
+          assume R: ?rhs
+          then have R': "(h a, h b) \<in> lenlex less_than"
+            by blast
+          then consider "length a < length b"
+            | "length a = length b" "(h a, h b) \<in> lex less_than"
+            using  \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> \<open>m > 1\<close>
+            by (auto simp: lenlex_conv h_def len_h_seg split: if_split_asm)
+          then show ?lhs
+          proof cases
+            case 1
+            then have "(a, b) \<in> lenlex less_than"
+              using omega_sum_less_iff by auto
+            then show ?thesis
+              by (simp add: \<open>a \<in> WW\<close> \<open>b \<in> WW\<close>)
+          next
+            case 2
+            then have ab: "a \<in> WW_seg (length a)" "b \<in> WW_seg (length a)"
+              using \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> by (auto simp: WW_seg_def)
+            then have "(a, b) \<in> lenlex less_than"
+              using bij_betwE [OF bij_h_seg] \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> R' 2
+              by (simp add: h_def h_seg_iff split: if_split_asm)
+            then show ?thesis
+              using \<open>a \<in> WW\<close> \<open>b \<in> WW\<close> by blast
+          qed
+        qed
+      qed
+
+      let ?fh = "f \<circ> image h"
+      have "bij_betw h WW WW'"
+        using h unfolding iso_ll_def iso_iff2 by (fastforce simp: FR_WW FR_WW')
+      then have fh: "?fh \<in> [WW]\<^bsup>2\<^esup> \<rightarrow> {..<Suc (Suc 0)}"
+        unfolding Pi_iff using bij_betwE f' bij_betw_nsets by fastforce
+
+      have "f{x,y} = 0" if "x \<in> WW'" "y \<in> WW'" "length x = length y" "x \<noteq> y" for x y
+      proof -
+        obtain p q where "x \<in> W' p" and "y \<in> W' q"
+          using WW'_def \<open>x \<in> WW'\<close> \<open>y \<in> WW'\<close> by blast
+        then obtain n where "{x,y} \<in> [W' n]\<^bsup>2\<^esup>"
+          using seg_W' \<open>1 < m\<close> \<open>length x = length y\<close> \<open>x \<noteq> y\<close>
+          by (auto simp: WW'_def WW_seg_def subset_iff)
+        then show "f{x,y} = 0"
+          using f_W' by blast
+      qed
+      then have fh_eq_0_eqlen: "?fh{x,y} = 0" if "x \<in> WW" "y \<in> WW" "length x = length y" "x \<noteq> y" for x y
+        using  \<open>bij_betw h WW WW'\<close>  that hlen
+        by (simp add: bij_betw_iff_bijections) metis
+      have m_f_0: "\<exists>x\<in>[M]\<^bsup>2\<^esup>. f x = 0" if "M \<subseteq> WW" "card M = m" for M
+      proof -
+        have "finite M"
+          using False m that by auto
+        with not1 [simplified, rule_format, of M] f
+        show ?thesis
+          using that \<open>1 < m\<close>
+          apply (simp add: Pi_iff image_subset_iff finite_ordertype_eq_card m)
+          by (metis less_2_cases nsets_mono numeral_2_eq_2 subset_iff)
+      qed
+      have m_fh_0: "\<exists>x\<in>[M]\<^bsup>2\<^esup>. ?fh x = 0" if "M \<subseteq> WW" "card M = m" for M
+      proof -
+        have "h ` M \<subseteq> WW"
+          using \<open>WW' \<subseteq> WW\<close> \<open>bij_betw h WW WW'\<close> bij_betwE that(1) by fastforce
+        moreover have "card (h ` M) = m"
+          by (metis \<open>bij_betw h WW WW'\<close> bij_betw_def bij_betw_subset card_image that)
+        ultimately have "\<exists>x \<in> [h ` M]\<^bsup>2\<^esup>. f x = 0"
+          by (metis m_f_0)
+        then obtain Y where "f (h ` Y) = 0" "finite Y" "card Y = 2" "Y \<subseteq> M"
+          apply (simp add: nsets_def subset_image_iff)
+          by (metis \<open>M \<subseteq> WW\<close> \<open>bij_betw h WW WW'\<close> bij_betw_def card_image card_infinite inj_on_subset zero_neq_numeral)
+        then show ?thesis
+          by (auto simp: nsets_def)
+      qed
+
+      obtain N j where "infinite N"
+        and N: "\<And>k u. \<lbrakk>k > 0; u \<in> [WW]\<^bsup>2\<^esup>; Form k u; [enum N k] < inter_scheme k u; List.set (inter_scheme k u) \<subseteq> N\<rbrakk> \<Longrightarrow> ?fh u = j k"
+        using lemma_3_6 [OF fh] by blast
+
+      have infN': "infinite (enum N ` {k<..})" for k
+        by (simp add: \<open>infinite N\<close> enum_works finite_image_iff infinite_Ioi strict_mono_imp_inj_on)
+      have j_0: "j k = 0" if "k>0" for k
+      proof -
+        obtain M where M: "M \<in> [WW]\<^bsup>m\<^esup>"
+                 and MF: "\<And>u. u \<in> [M]\<^bsup>2\<^esup> \<Longrightarrow> Form k u"
+                 and Mi: "\<And>u. u \<in> [M]\<^bsup>2\<^esup> \<Longrightarrow> List.set (inter_scheme k u) \<subseteq> enum N ` {k<..}"
+          using lemma_3_7 [OF infN' \<open>k > 0\<close>] by metis
+        obtain u where u: "u \<in> [M]\<^bsup>2\<^esup>" "?fh u = 0"
+          using m_fh_0 [of M] M [unfolded nsets_def] by force
+        moreover
+        have \<section>: "Form k u" "List.set (inter_scheme k u) \<subseteq> enum N ` {k<..}"
+          by (simp_all add: MF Mi \<open>u \<in> [M]\<^bsup>2\<^esup>\<close>)
+        moreover have "u \<in> [WW]\<^bsup>2\<^esup>"
+          using M u by (auto simp: nsets_def)
+        moreover have "enum N ` {k<..} \<subseteq> N"
+          using \<open>infinite N\<close> range_enum by auto
+        moreover
+        have "[enum N k] < inter_scheme k u"
+          using inter_scheme [of k u]  strict_mono_enum [OF \<open>infinite N\<close>] \<section>
+          apply (auto simp: less_list_def subset_image_iff subset_eq Bex_def image_iff)
+          by (metis hd_in_set strict_mono_def)
+        ultimately show ?thesis
+          using N that by auto
+      qed
+      obtain X where "X \<subseteq> WW" and otX: "ordertype X (lenlex less_than) = \<omega>\<up>\<omega>"
+            and X: "\<And>u. u \<in> [X]\<^bsup>2\<^esup> \<Longrightarrow>
+                   \<exists>l. Form l u \<and> (l > 0 \<longrightarrow> [enum N l] < inter_scheme l u \<and> List.set (inter_scheme l u) \<subseteq> N)"
+        using lemma_3_8 [OF \<open>infinite N\<close>] ot' by blast
+      have 0: "?fh ` [X]\<^bsup>2\<^esup> \<subseteq> {0}"
+      proof clarsimp
+        fix u
+        assume u: "u \<in> [X]\<^bsup>2\<^esup>"
+        obtain l where "Form l u" and l: "l > 0 \<longrightarrow> [enum N l] < inter_scheme l u \<and> List.set (inter_scheme l u) \<subseteq> N"
+          using u X by blast
+        have "?fh u = 0"
+        proof (cases "l > 0")
+          case False
+          then have "l = 0"
+            by blast
+          then show ?thesis
+            by (metis Form_0_cases_raw \<open>Form l u\<close> \<open>X \<subseteq> WW\<close> doubleton_in_nsets_2 fh_eq_0_eqlen subset_iff u)
+        next
+          case True
+          then obtain "[enum N l] < inter_scheme l u" "List.set (inter_scheme l u) \<subseteq> N" "j l = 0"
+            using Nat.neq0_conv j_0 l by blast
+          with True show ?thesis
+            using \<open>X \<subseteq> WW\<close> N inter_scheme \<open>Form l u\<close> doubleton_in_nsets_2 u by (auto simp: nsets_def)
+        qed
+        then show "f (h ` u) = 0"
+          by auto
+      qed
+      show ?P0
+      proof (intro exI conjI)
+        show "h ` X \<subseteq> WW"
+          using \<open>WW' \<subseteq> WW\<close> \<open>X \<subseteq> WW\<close> \<open>bij_betw h WW WW'\<close> bij_betw_imp_surj_on by fastforce
+        show "ordertype (h ` X) (lenlex less_than) = \<omega> \<up> \<omega>"
+        proof (subst ordertype_inc_eq)
+          show "(h x, h y) \<in> lenlex less_than"
+            if "x \<in> X" "y \<in> X" "(x, y) \<in> lenlex less_than" for x y
+            using that h \<open>X \<subseteq> WW\<close> by (auto simp: FR_WW FR_WW' iso_iff2 iso_ll_def)
+        qed (use otX in auto)
+        show "f ` [h ` X]\<^bsup>2\<^esup> \<subseteq> {0}"
+        proof (clarsimp simp: image_subset_iff nsets_def)
+          fix Y
+          assume "Y \<subseteq> h ` X" and "finite Y" and "card Y = 2"
+          have "inv_into WW h ` Y \<subseteq> X"
+            using \<open>X \<subseteq> WW\<close> \<open>Y \<subseteq> h ` X\<close> \<open>bij_betw h WW WW'\<close> bij_betw_inv_into_LEFT by blast
+          moreover have "finite (inv_into WW h ` Y)"
+            using \<open>finite Y\<close> by blast
+          moreover have "card (inv_into WW h ` Y) = 2"
+            by (metis \<open>X \<subseteq> WW\<close> \<open>Y \<subseteq> h ` X\<close> \<open>card Y = 2\<close> card_image inj_on_inv_into subset_image_iff subset_trans)
+          ultimately have "f (h ` inv_into WW h ` Y) = 0"
+            using 0 by (auto simp: image_subset_iff nsets_def)
+          then show "f Y = 0"
+            by (metis \<open>X \<subseteq> WW\<close> \<open>Y \<subseteq> h ` X\<close> image_inv_into_cancel image_mono order_trans)
+        qed
+      qed
+    qed
+    then show "\<exists>i<Suc (Suc 0). \<exists>H\<subseteq>WW. ordertype H ?R = [\<omega>\<up>\<omega>, \<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
+qed
+
+text \<open>Theorem 3.1 of Jean A. Larson, ibid.\<close>
+theorem partition_\<omega>\<omega>: "\<alpha> \<in> elts \<omega> \<Longrightarrow> partn_lst_VWF (\<omega>\<up>\<omega>) [\<omega>\<up>\<omega>,\<alpha>] 2"
+  using partn_lst_imp_partn_lst_VWF_eq [OF partition_\<omega>\<omega>_aux] ordertype_WW by auto
+
+end
diff --git a/thys/Ordinal_Partitions/Partitions.thy b/thys/Ordinal_Partitions/Partitions.thy
new file mode 100644
--- /dev/null
+++ b/thys/Ordinal_Partitions/Partitions.thy
@@ -0,0 +1,938 @@
+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> nsets B n  \<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]
+    by (smt assms(8) in_mono r(1) r(3) 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> assms(8) calculation in_mono leD ordermap_mono_le r smaller_than_small 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>" "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
+  proof (rule ordertype_inc_eq)
+    fix u v
+    assume "u \<in> X" "v \<in> X" and "(u,v) \<in> r"
+    with that have "ordermap U r u < ordermap U r v"
+      by (simp add: assms ordermap_mono_less subset_eq)
+    then show "(ordermap U r u, ordermap U r v) \<in> VWF"
+      by (simp add: r)
+  next
+    show "total_on X r"
+      using that r by (auto simp: total_on_def)
+    show "small X"
+      by (meson \<open>small U\<close> smaller_than_small that)
+  qed (use assms in auto)
+  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
+    apply ( simp add: cv_def nsets_def subset_image_iff inj_on_subset finite_image_iff card_image)
+    by (metis bij bij_betw_def card_image inj_on_finite inj_on_inv_into subset_eq)
+  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)
+      then show ?thesis
+        by (metis (no_types) VWF_non_refl xy eq assms(3) inv_into_into ordermap_mono r(1) r(3) 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)
+    have Ord\<eta>: "Ord (\<eta> k)" for k
+      by (meson H Ord_in_Ord UNIV_I \<eta> assms bij_betw_apply subsetD)
+    obtain k where k: "((\<pi> \<circ> \<eta>)(Suc k), (\<pi> \<circ> \<eta>) k) \<notin> VWF"
+      using wf_VWF wf_iff_no_infinite_down_chain by blast
+    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)
+    have False if "\<eta> (Suc k) \<le> \<eta> k"
+    proof -
+      have "(\<eta> (Suc k), \<eta> k) \<in> VWF \<or> \<eta> (Suc k) = \<eta> k"
+        using that 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"
+        apply (simp add: \<eta>_def)
+        by (meson bij bij_betw_inv_into_right ord_of_nat_\<omega>)
+      ultimately have "succ (ord_of_nat k) \<le> ord_of_nat k"
+        by simp
+      then show False
+        by (simp add: less_eq_V_def)
+    qed
+    then have "\<eta> k < \<eta> (Suc k)"
+      by (metis Ord\<eta> Ord_linear_lt dual_order.strict_implies_order eq_refl)
+    then have "(\<pi> \<circ> \<eta>)(Suc k) < (\<pi> \<circ> \<eta>)k"
+      using \<pi> \<eta> bij_betw_apply by force
+    then show False
+      using k
+      apply (simp add: subset_iff)
+      by (metis H Ord\<pi> UNIV_I VWF_iff_Ord_less \<eta> bij_betw_imp_surj_on image_subset_iff)
+  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>
+lemma lemma_2_5:
+  assumes "infinite N"
+  obtains X where "X \<subseteq> UU" "ordertype X pair_less = \<omega>\<up>2"
+            "\<And>u. u \<in> [X]\<^bsup>2\<^esup> \<Longrightarrow> (\<exists>k<4. form u k) \<and> scheme u \<subseteq> N"
+proof -
+  obtain C
+    where dis: "pairwise (\<lambda>i j. disjnt (C i) (C j)) UNIV"
+      and N: "(\<Union>i. C i) \<subseteq> N" and infC: "\<And>i::nat. infinite (C i)"
+    using assms infinite_infinite_partition by blast
+  then have "\<exists>\<phi>::nat \<Rightarrow> nat. inj \<phi> \<and> range \<phi> = C i \<and> strict_mono \<phi>" for i
+    by (metis bij_betw_imp_inj_on bij_betw_imp_surj_on bij_enumerate enumerate_mono infC strict_mono_def)
+  then obtain \<phi>:: "[nat,nat] \<Rightarrow> nat"
+      where \<phi>: "\<And>i. inj (\<phi> i) \<and> range (\<phi> i) = C i \<and> strict_mono (\<phi> i)"
+    by metis
+  then have \<pi>_in_C [simp]: "\<phi> i j \<in> C i' \<longleftrightarrow> i'=i" for i i' j
+    using dis by (fastforce simp: pairwise_def disjnt_def)
+  have less_iff [simp]: "\<phi> i j' < \<phi> i j \<longleftrightarrow> j' < j" for i j' j
+    by (simp add: \<phi> strict_mono_less)
+  let ?a = "\<phi> 0"
+  define X where "X \<equiv> {(?a i, b) | i b. ?a i < b \<and> b \<in> C (Suc i)}"
+  show thesis
+  proof
+    show "X \<subseteq> UU"
+      by (auto simp: X_def UU_def)
+    show "ordertype X pair_less = \<omega>\<up>2"
+    proof (rule antisym)
+      have "ordertype X pair_less \<le> ordertype UU pair_less"
+        by (simp add: \<open>X \<subseteq> UU\<close> ordertype_mono)
+      then show "ordertype X pair_less \<le> \<omega>\<up>2"
+        using ordertype_UU_\<omega>2 by auto
+      define \<pi> where "\<pi> \<equiv> \<lambda>(i,j::nat). (?a i, \<phi> (Suc i) (?a j))"
+      have "\<And>i j. i < j \<Longrightarrow> \<phi> 0 i < \<phi> (Suc i) (\<phi> 0 j)"
+        by (meson \<phi> le_less_trans less_iff strict_mono_imp_increasing)
+      then have subX: "\<pi> ` UU \<subseteq> X"
+        by (auto simp: UU_def \<pi>_def X_def)
+      then have "ordertype (\<pi> ` UU) pair_less \<le> ordertype X pair_less"
+        by (simp add: ordertype_mono)
+      moreover have "ordertype (\<pi> ` UU) pair_less = ordertype UU pair_less"
+      proof (rule ordertype_inc_eq)
+        show "(\<pi> x, \<pi> y) \<in> pair_less"
+          if "x \<in> UU" "y \<in> UU" and "(x, y) \<in> pair_less" for x y
+          using that by (auto simp: UU_def \<pi>_def pair_less_def)
+      qed auto
+      ultimately show "\<omega>\<up>2 \<le> ordertype X pair_less"
+        using ordertype_UU_\<omega>2 by simp
+    qed
+  next
+    fix U
+    assume "U \<in> [X]\<^bsup>2\<^esup>"
+    then obtain a b c d where Ueq: "U = {(a,b),(c,d)}" and ne: "(a,b) \<noteq> (c,d)" and inX: "(a,b) \<in> X" "(c,d) \<in> X" and "a \<le> c"
+      apply (auto simp: nsets_def subset_iff eval_nat_numeral card_Suc_eq Set.doubleton_eq_iff)
+       apply (metis  nat_le_linear)+
+      done
+    show "(\<exists>k<4. form U k) \<and> scheme U \<subseteq> N"
+    proof
+      show "scheme U \<subseteq> N"
+        using inX N \<phi> by (fastforce simp: scheme_def Ueq X_def)
+    next
+      consider "a < c" | "a = c \<and> b \<noteq> d"
+        using \<open>a \<le> c\<close> ne nat_less_le by blast
+      then show "\<exists>k<4. form U k"
+      proof cases
+        case 1
+        have *: "a < b"  "b \<noteq> c" "c < d"
+          using inX by (auto simp: X_def)
+        moreover have "\<lbrakk>a < c; c < b; \<not> d < b\<rbrakk> \<Longrightarrow> b < d"
+          using inX apply (clarsimp simp: X_def not_less)
+          by (metis \<phi> \<pi>_in_C imageE nat.inject nat_less_le)
+        ultimately consider (k0) "a<b \<and> b<c \<and> c<d" | (k1) "a<c \<and> c<b \<and> b<d" | (k2) "a<c \<and> c<d \<and> d<b"
+          using 1 less_linear by blast
+        then show ?thesis
+        proof cases
+          case k0
+          then have "form U 0"
+            unfolding form_def form_split_def using Ueq \<open>a \<le> c\<close> by blast
+          then show ?thesis by force
+        next
+          case k1
+          then have "form U 1"
+            unfolding form_def form_split_def using Ueq \<open>a \<le> c\<close> by blast
+          then show ?thesis by force
+        next
+          case k2
+          then have "form U 2"
+            unfolding form_def form_split_def using Ueq \<open>a \<le> c\<close> by blast
+          then show ?thesis by force
+        qed
+      next
+        case 2
+        then have "form_split a b c d 3"
+          by (auto simp: form_split_def)
+        then show ?thesis
+          using Ueq form_def leI by force
+      qed
+    qed
+  qed
+qed
+
+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}"
+  proof 
+    show "?P0 \<Longrightarrow> ?thesis"
+      by (metis nth_Cons_0 numeral_2_eq_2 pos2)
+    show "?P1 \<Longrightarrow> ?thesis"
+      by (metis One_nat_def lessI nth_Cons_0 nth_Cons_Suc)
+  qed
+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
diff --git a/thys/Ordinal_Partitions/ROOT b/thys/Ordinal_Partitions/ROOT
new file mode 100644
--- /dev/null
+++ b/thys/Ordinal_Partitions/ROOT
@@ -0,0 +1,12 @@
+chapter AFP
+
+session Ordinal_Partitions (AFP) = HOL +
+  options [timeout = 600]
+  sessions
+    "HOL-Library" "ZFC_in_HOL" "Nash_Williams"
+  theories
+    Omega_Omega
+  document_files
+    "root.tex"
+    "root.bib"
+
diff --git a/thys/Ordinal_Partitions/document/root.bib b/thys/Ordinal_Partitions/document/root.bib
new file mode 100644
--- /dev/null
+++ b/thys/Ordinal_Partitions/document/root.bib
@@ -0,0 +1,51 @@
+%% This BibTeX bibliography file was created using BibDesk.
+%% http://bibdesk.sourceforge.net/
+
+
+%% Created for Larry Paulson at 2020-08-03 15:23:09 +0100 
+
+
+%% Saved with string encoding Unicode (UTF-8) 
+
+
+
+@article{erdos-theorem-partition-corr,
+	Author = {Paul Erd{\"o}s and E. C. Milner},
+	Date-Added = {2020-08-03 15:20:59 +0100},
+	Date-Modified = {2020-08-03 15:23:08 +0100},
+	Doi = {10.4153/CMB-1974-062-6},
+	Journal = {Canadian Mathematical Bulletin},
+	Month = jun,
+	Number = {2},
+	Pages = {305},
+	Title = {A Theorem in the Partition Calculus Corrigendum},
+	Volume = {17},
+	Year = {1974},
+	Bdsk-Url-1 = {https://doi.org/10.4153/CMB-1972-088-1}}
+
+@article{erdos-theorem-partition,
+	Author = {Paul Erd{\"o}s and E. C. Milner},
+	Date-Added = {2020-08-02 14:51:07 +0100},
+	Date-Modified = {2020-08-02 14:53:46 +0100},
+	Doi = {10.4153/CMB-1972-088-1},
+	Journal = {Canadian Mathematical Bulletin},
+	Month = dec,
+	Number = {4},
+	Pages = {501-505},
+	Title = {A Theorem in the Partition Calculus},
+	Volume = {15},
+	Year = {1972}}
+
+@article{larson-short-proof,
+	Author = {Jean A. Larson},
+	Date-Added = {2020-08-02 14:49:21 +0100},
+	Date-Modified = {2020-08-02 14:49:21 +0100},
+	Doi = {10.1016/0003-4843(73)90006-5},
+	Journal = {Annals of Mathematical Logic},
+	Month = dec,
+	Number = {2},
+	Pages = {129-145},
+	Title = {A Short Proof of a Partition Theorem for the Ordinal $\omega^\omega$},
+	Volume = {6},
+	Year = {1973},
+	Bdsk-Url-1 = {https://doi.org/10.1016/0003-4843(73)90006-5}}
diff --git a/thys/Ordinal_Partitions/document/root.tex b/thys/Ordinal_Partitions/document/root.tex
new file mode 100644
--- /dev/null
+++ b/thys/Ordinal_Partitions/document/root.tex
@@ -0,0 +1,40 @@
+\documentclass[11pt,a4paper]{article}
+\usepackage{isabelle,isabellesym}
+\usepackage{amssymb}
+\usepackage{stmaryrd}
+
+% this should be the last package used
+\usepackage{pdfsetup}
+
+% urls in roman style, theory text in math-similar italics
+\urlstyle{rm}
+\isabellestyle{it}
+
+\begin{document}
+
+\title{A Partition Theorem for the Ordinal $\omega^\omega$}
+\author{Lawrence C. Paulson}
+\maketitle
+
+\begin{abstract}
+The theory of partition relations concerns generalisations of Ramsey's theorem.
+For any ordinal $\alpha$, write $\alpha \to (\alpha, m)^2$ if for each function~$f$ from unordered pairs of elements of~$\alpha$ into $\{0,1\}$, either there is a subset $X\subseteq \alpha$ order-isomorphic to $\alpha$ such that $f\{x,y\}=0$ for all $\{x,y\}\subseteq X$, or there is an $m$ element set $Y\subseteq \alpha$ such that $f\{x,y\}=1$ for all $\{x,y\}\subseteq Y$. (In both cases, with $\{x,y\}$ we require $x\not=y$.)
+In particular, the infinite Ramsey theorem can be written in this notation as $\omega \to (\omega, \omega)^2$, or if we restrict~$m$ to the positive integers as above, then $\omega \to (\omega, m)^2$ for all~$m$ \cite{larson-short-proof}.
+
+This entry formalises Larson's proof of $\omega^\omega \to (\omega^\omega, m)^2$ along with a similar proof of a result due to Specker: $\omega^2 \to (\omega^2, m)^2$. Also proved is a necessary result by Erd{\H o}s and Milner~\cite{erdos-theorem-partition,erdos-theorem-partition-corr}: $\omega^{1+\alpha\cdot n} \to (\omega^{1+\alpha}, 2^n)^2$.
+
+These examples demonstrate the use of Isabelle/HOL to formalise advanced results that combine ZF set theory with basic concepts like lists and natural numbers.
+\end{abstract}
+
+\tableofcontents
+
+% include generated text of all theories
+\input{session}
+
+\section{Acknowledgements}
+The author was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178) funded by the European Research Council. Many thanks to Mirna D\v{z}amonja (who suggested the project) and Angeliki Koutsoukou-Argyraki for assistance at tricky moments.
+
+\bibliographystyle{abbrv}
+\bibliography{root}
+
+\end{document}
diff --git a/thys/ROOTS b/thys/ROOTS
--- a/thys/ROOTS
+++ b/thys/ROOTS
@@ -1,549 +1,550 @@
 ADS_Functor
 AODV
 Attack_Trees
 Auto2_HOL
 Auto2_Imperative_HOL
 AVL-Trees
 AWN
 Abortable_Linearizable_Modules
 Abs_Int_ITP2012
 Abstract-Hoare-Logics
 Abstract-Rewriting
 Abstract_Completeness
 Abstract_Soundness
 Adaptive_State_Counting
 Affine_Arithmetic
 Aggregation_Algebras
 Akra_Bazzi
 Algebraic_Numbers
 Algebraic_VCs
 Allen_Calculus
 Amicable_Numbers
 Amortized_Complexity
 AnselmGod
 Applicative_Lifting
 Approximation_Algorithms
 Architectural_Design_Patterns
 Aristotles_Assertoric_Syllogistic
 Arith_Prog_Rel_Primes
 ArrowImpossibilityGS
 AutoFocus-Stream
 Automated_Stateful_Protocol_Verification
 Automatic_Refinement
 AxiomaticCategoryTheory
 BDD
 BNF_Operations
 Banach_Steinhaus
 Bell_Numbers_Spivey
 Berlekamp_Zassenhaus
 Bernoulli
 Bertrands_Postulate
 Bicategory
 BinarySearchTree
 Binding_Syntax_Theory
 Binomial-Heaps
 Binomial-Queues
 BNF_CC
 Bondy
 Boolean_Expression_Checkers
 Bounded_Deducibility_Security
 Buchi_Complementation
 Budan_Fourier
 Buffons_Needle
 Buildings
 BytecodeLogicJmlTypes
 C2KA_DistributedSystems
 CAVA_Automata
 CAVA_LTL_Modelchecker
 CCS
 CISC-Kernel
 CRDT
 CYK
 CakeML
 CakeML_Codegen
 Call_Arity
 Card_Equiv_Relations
 Card_Multisets
 Card_Number_Partitions
 Card_Partitions
 Cartan_FP
 Case_Labeling
 Catalan_Numbers
 Category
 Category2
 Category3
 Cauchy
 Cayley_Hamilton
 Certification_Monads
 Chandy_Lamport
 Chord_Segments
 Circus
 Clean
 ClockSynchInst
 Closest_Pair_Points
 CofGroups
 Coinductive
 Coinductive_Languages
 Collections
 Comparison_Sort_Lower_Bound
 Compiling-Exceptions-Correctly
 Completeness
 Complete_Non_Orders
 Complex_Geometry
 Complx
 ComponentDependencies
 ConcurrentGC
 ConcurrentIMP
 Concurrent_Ref_Alg
 Concurrent_Revisions
 Consensus_Refined
 Constructive_Cryptography
 Constructor_Funs
 Containers
 CoreC++
 Core_DOM
 Count_Complex_Roots
 CryptHOL
 CryptoBasedCompositionalProperties
 DFS_Framework
 DPT-SAT-Solver
 DataRefinementIBP
 Datatype_Order_Generator
 Decl_Sem_Fun_PL
 Decreasing-Diagrams
 Decreasing-Diagrams-II
 Deep_Learning
 Density_Compiler
 Dependent_SIFUM_Refinement
 Dependent_SIFUM_Type_Systems
 Depth-First-Search
 Derangements
 Deriving
 Descartes_Sign_Rule
 Dict_Construction
 Differential_Dynamic_Logic
 Differential_Game_Logic
 Dijkstra_Shortest_Path
 Diophantine_Eqns_Lin_Hom
 Dirichlet_L
 Dirichlet_Series
 Discrete_Summation
 DiscretePricing
 DiskPaxos
 DynamicArchitectures
 Dynamic_Tables
 E_Transcendental
 Echelon_Form
 EdmondsKarp_Maxflow
 Efficient-Mergesort
 Elliptic_Curves_Group_Law
 Encodability_Process_Calculi
 Epistemic_Logic
 Ergodic_Theory
 Error_Function
 Euler_MacLaurin
 Euler_Partition
 Example-Submission
 Factored_Transition_System_Bounding
 Farkas
 FFT
 FLP
 FOL-Fitting
 FOL_Harrison
 FOL_Seq_Calc1
 Falling_Factorial_Sum
 FeatherweightJava
 Featherweight_OCL
 Fermat3_4
 FileRefinement
 FinFun
 Finger-Trees
 Finite_Automata_HF
 First_Order_Terms
 First_Welfare_Theorem
 Fishburn_Impossibility
 Fisher_Yates
 Flow_Networks
 Floyd_Warshall
 Flyspeck-Tame
 FocusStreamsCaseStudies
 Forcing
 Formal_SSA
 Formula_Derivatives
 Fourier
 Free-Boolean-Algebra
 Free-Groups
 FunWithFunctions
 FunWithTilings
 Functional-Automata
 Functional_Ordered_Resolution_Prover
 Furstenberg_Topology
 GPU_Kernel_PL
 Gabow_SCC
 Game_Based_Crypto
 Gauss-Jordan-Elim-Fun
 Gauss_Jordan
 Gauss_Sums
 Gaussian_Integers
 GenClock
 General-Triangle
 Generalized_Counting_Sort
 Generic_Deriving
 Generic_Join
 GewirthPGCProof
 Girth_Chromatic
 GoedelGod
 Goodstein_Lambda
 GraphMarkingIBP
 Graph_Saturation
 Graph_Theory
 Green
 Groebner_Bases
 Groebner_Macaulay
 Gromov_Hyperbolicity
 Group-Ring-Module
 HOL-CSP
 HOLCF-Prelude
 HRB-Slicing
 Heard_Of
 Hello_World
 HereditarilyFinite
 Hermite
 Hidden_Markov_Models
 Higher_Order_Terms
 Hoare_Time
 HotelKeyCards
 Huffman
 Hybrid_Logic
 Hybrid_Multi_Lane_Spatial_Logic
 Hybrid_Systems_VCs
 HyperCTL
 IEEE_Floating_Point
 IMAP-CRDT
 IMO2019
 IMP2
 IMP2_Binary_Heap
 IP_Addresses
 Imperative_Insertion_Sort
 Impossible_Geometry
 Incompleteness
 Incredible_Proof_Machine
 Inductive_Confidentiality
 InfPathElimination
 InformationFlowSlicing
 InformationFlowSlicing_Inter
 Integration
 Interval_Arithmetic_Word32
 Iptables_Semantics
 Irrational_Series_Erdos_Straus
 Irrationality_J_Hancl
 Isabelle_C
 Isabelle_Meta_Model
 Jacobson_Basic_Algebra
 Jinja
 JinjaThreads
 JiveDataStoreModel
 Jordan_Hoelder
 Jordan_Normal_Form
 KAD
 KAT_and_DRA
 KBPs
 KD_Tree
 Key_Agreement_Strong_Adversaries
 Kleene_Algebra
 Knot_Theory
 Knuth_Bendix_Order
 Knuth_Morris_Pratt
 Koenigsberg_Friendship
 Kruskal
 Kuratowski_Closure_Complement
 LLL_Basis_Reduction
 LLL_Factorization
 LOFT
 LTL
 LTL_to_DRA
 LTL_to_GBA
 LTL_Master_Theorem
 LTL_Normal_Form
 Lam-ml-Normalization
 LambdaAuth
 LambdaMu
 Lambda_Free_KBOs
 Lambda_Free_RPOs
 Lambert_W
 Landau_Symbols
 Laplace_Transform
 Latin_Square
 LatticeProperties
 Lambda_Free_EPO
 Launchbury
 Lazy-Lists-II
 Lazy_Case
 Lehmer
 Lifting_Definition_Option
 LightweightJava
 LinearQuantifierElim
 Linear_Inequalities
 Linear_Programming
 Linear_Recurrences
 Liouville_Numbers
 List-Index
 List-Infinite
 List_Interleaving
 List_Inversions
 List_Update
 LocalLexing
 Localization_Ring
 Locally-Nameless-Sigma
 Lowe_Ontological_Argument
 Lower_Semicontinuous
 Lp
 Lucas_Theorem
 MFMC_Countable
 MSO_Regex_Equivalence
 Markov_Models
 Marriage
 Mason_Stothers
 Matrices_for_ODEs
 Matrix
 Matrix_Tensor
 Matroids
 Max-Card-Matching
 Median_Of_Medians_Selection
 Menger
 Mersenne_Primes
 MFODL_Monitor_Optimized
 MFOTL_Monitor
 MiniML
 Minimal_SSA
 Minkowskis_Theorem
 Minsky_Machines
 Modal_Logics_for_NTS
 Modular_Assembly_Kit_Security
 Monad_Memo_DP
 Monad_Normalisation
 MonoBoolTranAlgebra
 MonoidalCategory
 Monomorphic_Monad
 MuchAdoAboutTwo
 Multirelations
 Multi_Party_Computation
 Myhill-Nerode
 Name_Carrying_Type_Inference
 Nash_Williams
 Nat-Interval-Logic
 Native_Word
 Nested_Multisets_Ordinals
 Network_Security_Policy_Verification
 Neumann_Morgenstern_Utility
 No_FTL_observers
 Nominal2
 Noninterference_CSP
 Noninterference_Concurrent_Composition
 Noninterference_Generic_Unwinding
 Noninterference_Inductive_Unwinding
 Noninterference_Ipurge_Unwinding
 Noninterference_Sequential_Composition
 NormByEval
 Nullstellensatz
 Octonions
 Open_Induction
 OpSets
 Optics
 Optimal_BST
 Orbit_Stabiliser
 Order_Lattice_Props
 Ordered_Resolution_Prover
 Ordinal
+Ordinal_Partitions
 Ordinals_and_Cardinals
 Ordinary_Differential_Equations
 PCF
 PLM
 Pell
 POPLmark-deBruijn
 PSemigroupsConvolution
 Pairing_Heap
 Paraconsistency
 Parity_Game
 Partial_Function_MR
 Partial_Order_Reduction
 Password_Authentication_Protocol
 Perfect-Number-Thm
 Perron_Frobenius
 Pi_Calculus
 Pi_Transcendental
 Planarity_Certificates
 Polynomial_Factorization
 Polynomial_Interpolation
 Polynomials
 Poincare_Bendixson
 Poincare_Disc
 Pop_Refinement
 Posix-Lexing
 Possibilistic_Noninterference
 Power_Sum_Polynomials
 Pratt_Certificate
 Presburger-Automata
 Prim_Dijkstra_Simple
 Prime_Distribution_Elementary
 Prime_Harmonic_Series
 Prime_Number_Theorem
 Priority_Queue_Braun
 Priority_Search_Trees
 Probabilistic_Noninterference
 Probabilistic_Prime_Tests
 Probabilistic_System_Zoo
 Probabilistic_Timed_Automata
 Probabilistic_While
 Projective_Geometry
 Program-Conflict-Analysis
 Promela
 Proof_Strategy_Language
 PropResPI
 Propositional_Proof_Systems
 Prpu_Maxflow
 PseudoHoops
 Psi_Calculi
 Ptolemys_Theorem
 QHLProver
 QR_Decomposition
 Quantales
 Quaternions
 Quick_Sort_Cost
 RIPEMD-160-SPARK
 ROBDD
 RSAPSS
 Ramsey-Infinite
 Random_BSTs
 Randomised_BSTs
 Random_Graph_Subgraph_Threshold
 Randomised_Social_Choice
 Rank_Nullity_Theorem
 Real_Impl
 Recursion-Addition
 Recursion-Theory-I
 Refine_Imperative_HOL
 Refine_Monadic
 RefinementReactive
 Regex_Equivalence
 Regular-Sets
 Regular_Algebras
 Relation_Algebra
 Relational-Incorrectness-Logic
 Relational_Paths
 Rep_Fin_Groups
 Residuated_Lattices
 Resolution_FOL
 Rewriting_Z
 Ribbon_Proofs
 Robbins-Conjecture
 Root_Balanced_Tree
 Routing
 Roy_Floyd_Warshall
 SATSolverVerification
 SDS_Impossibility
 SIFPL
 SIFUM_Type_Systems
 SPARCv8
 Safe_Distance
 Safe_OCL
 Saturation_Framework
 Secondary_Sylow
 Security_Protocol_Refinement
 Selection_Heap_Sort
 SenSocialChoice
 Separata
 Separation_Algebra
 Separation_Logic_Imperative_HOL
 SequentInvertibility
 Shivers-CFA
 ShortestPath
 Show
 Sigma_Commit_Crypto
 Signature_Groebner
 Simpl
 Simple_Firewall
 Simplex
 Skew_Heap
 Skip_Lists
 Slicing
 Sliding_Window_Algorithm
 Smith_Normal_Form
 Smooth_Manifolds
 Sort_Encodings
 Source_Coding_Theorem
 Special_Function_Bounds
 Splay_Tree
 Sqrt_Babylonian
 Stable_Matching
 Statecharts
 Stateful_Protocol_Composition_and_Typing
 Stellar_Quorums
 Stern_Brocot
 Stewart_Apollonius
 Stirling_Formula
 Stochastic_Matrices
 Stone_Algebras
 Stone_Kleene_Relation_Algebras
 Stone_Relation_Algebras
 Store_Buffer_Reduction
 Stream-Fusion
 Stream_Fusion_Code
 Strong_Security
 Sturm_Sequences
 Sturm_Tarski
 Stuttering_Equivalence
 Subresultants
 Subset_Boolean_Algebras
 SumSquares
 SuperCalc
 Surprise_Paradox
 Symmetric_Polynomials
 Szpilrajn
 TESL_Language
 TLA
 Tail_Recursive_Functions
 Tarskis_Geometry
 Taylor_Models
 Timed_Automata
 Topology
 TortoiseHare
 Transcendence_Series_Hancl_Rucki
 Transformer_Semantics
 Transition_Systems_and_Automata
 Transitive-Closure
 Transitive-Closure-II
 Treaps
 Tree-Automata
 Tree_Decomposition
 Triangle
 Trie
 Twelvefold_Way
 Tycon
 Types_Tableaus_and_Goedels_God
 Universal_Turing_Machine
 UPF
 UPF_Firewall
 UpDown_Scheme
 UTP
 Valuation
 VectorSpace
 VeriComp
 Verified-Prover
 VerifyThis2018
 VerifyThis2019
 Vickrey_Clarke_Groves
 VolpanoSmith
 WHATandWHERE_Security
 WebAssembly
 Weight_Balanced_Trees
 Well_Quasi_Orders
 Winding_Number_Eval
 WOOT_Strong_Eventual_Consistency
 Word_Lib
 WorkerWrapper
 XML
 Zeta_Function
 Zeta_3_Irrational
 ZFC_in_HOL
 pGCL