diff --git a/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II.thy b/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II.thy
--- a/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II.thy
+++ b/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II.thy
@@ -1,962 +1,962 @@
 (*
  * Title:      Decreasing Diagrams II  
  * Author:     Bertram Felgenhauer (2015)
  * Maintainer: Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at>
  * License:    LGPL
  *)
 section \<open>Decreasing Diagrams\<close>
 
 theory Decreasing_Diagrams_II
 imports
   Decreasing_Diagrams_II_Aux
   "HOL-Cardinals.Wellorder_Extension"
   "Abstract-Rewriting.Abstract_Rewriting"
 begin
 
 subsection \<open>Greek accents\<close>
 
 datatype accent = Acute | Grave | Macron
 
 lemma UNIV_accent: "UNIV = { Acute, Grave, Macron }"
 using accent.nchotomy by blast
 
 lemma finite_accent: "finite (UNIV :: accent set)"
 by (simp add: UNIV_accent)
 
 type_synonym 'a letter = "accent \<times> 'a"
 
 definition letter_less :: "('a \<times> 'a) set \<Rightarrow> ('a letter \<times> 'a letter) set" where
   [simp]: "letter_less R = {(a,b). (snd a, snd b) \<in> R}"
 
 lemma mono_letter_less: "mono letter_less"
 by (auto simp add: mono_def)
 
 
 subsection \<open>Comparing Greek strings\<close>
 
 type_synonym 'a greek = "'a letter list"
 
 definition adj_msog :: "'a greek \<Rightarrow> 'a greek \<Rightarrow> ('a letter \<times> 'a greek) \<Rightarrow> ('a letter \<times> 'a greek)"
 where
   "adj_msog xs zs l \<equiv>
     case l of (y,ys) \<Rightarrow> (y, case fst y of Acute \<Rightarrow> ys @ zs | Grave \<Rightarrow> xs @ ys | Macron \<Rightarrow> ys)"
 
 definition ms_of_greek :: "'a greek \<Rightarrow> ('a letter \<times> 'a greek) multiset" where
   "ms_of_greek as = mset
     (map (\<lambda>(xs, y, zs) \<Rightarrow> adj_msog xs zs (y, [])) (list_splits as))"
 
 lemma adj_msog_adj_msog[simp]:
   "adj_msog xs zs (adj_msog xs' zs' y) = adj_msog (xs @ xs') (zs' @ zs) y"
 by (auto simp: adj_msog_def split: accent.splits prod.splits)
 
 lemma compose_adj_msog[simp]: "adj_msog xs zs \<circ> adj_msog xs' zs' = adj_msog (xs @ xs') (zs' @ zs)"
 by (simp add: comp_def)
 
 lemma adj_msog_single:
   "adj_msog xs zs (x,[]) = (x, (case fst x of Grave \<Rightarrow> xs | Acute \<Rightarrow> zs | Macron \<Rightarrow> []))"
 by (simp add: adj_msog_def split: accent.splits)
 
 lemma ms_of_greek_elem:
   assumes "(x,xs) \<in> set_mset (ms_of_greek ys)"
   shows "x \<in> set ys"
 using assms by (auto dest: elem_list_splits_elem simp: adj_msog_def ms_of_greek_def)
 
 lemma ms_of_greek_shorter:
   assumes "(x, t) \<in># ms_of_greek s"
   shows "length s > length t"
 using assms[unfolded ms_of_greek_def in_multiset_in_set]
 by (auto simp: elem_list_splits_length adj_msog_def split: accent.splits)
 
 lemma msog_append: "ms_of_greek (xs @ ys) = image_mset (adj_msog [] ys) (ms_of_greek xs) +
   image_mset (adj_msog xs []) (ms_of_greek ys)"
 by (auto simp: ms_of_greek_def list_splits_append multiset.map_comp comp_def prod.case_distrib)
 
 definition nest :: "('a \<times> 'a) set \<Rightarrow> ('a greek \<times> 'a greek) set \<Rightarrow> ('a greek \<times> 'a greek) set" where
   [simp]: "nest r s = {(a,b). (ms_of_greek a, ms_of_greek b) \<in> mult (letter_less r <*lex*> s)}"
 
 lemma mono_nest: "mono (nest r)"
 unfolding mono_def
 proof (intro allI impI subsetI)
   fix R S x
   assume 1: "R \<subseteq> S" and 2: "x \<in> nest r R"
   from 1 have "mult (letter_less r <*lex*> R) \<subseteq> mult (letter_less r <*lex*> S)"
   using mono_mult mono_lex2[of "letter_less r"] unfolding mono_def by blast
   with 2 show "x \<in> nest r S" by auto
 qed
 
 lemma nest_mono[mono_set]: "x \<subseteq> y \<Longrightarrow> (a,b) \<in> nest r x \<longrightarrow> (a,b) \<in> nest r y"
 using mono_nest[unfolded mono_def, rule_format, of x y r] by blast
 
 definition greek_less :: "('a \<times> 'a) set \<Rightarrow> ('a greek \<times> 'a greek) set" where
   "greek_less r = lfp (nest r)"
 
 lemma greek_less_unfold:
   "greek_less r = nest r (greek_less r)"
 using mono_nest[of r] lfp_unfold[of "nest r"] by (simp add: greek_less_def)
 
 
 subsection \<open>Preservation of strict partial orders\<close>
 
 lemma strict_order_letter_less:
   assumes "strict_order r"
   shows "strict_order (letter_less r)"
 using assms unfolding irrefl_def trans_def letter_less_def by fast
 
 lemma strict_order_nest:
   assumes r: "strict_order r" and R: "strict_order R"
   shows "strict_order (nest r R)"
 proof -
   have "strict_order (mult (letter_less r <*lex*> R))"
   using strict_order_letter_less[of r] irrefl_lex_prod[of "letter_less r" R]
     trans_lex_prod[of "letter_less r" R] strict_order_mult[of "letter_less r <*lex*> R"] assms
   by fast
   from this show "strict_order (nest r R)" unfolding nest_def trans_def irrefl_def by fast
 qed
 
 lemma strict_order_greek_less:
   assumes "strict_order r"
   shows "strict_order (greek_less r)"
 by (simp add: greek_less_def strict_order_lfp[OF mono_nest strict_order_nest[OF assms]])
 
 lemma trans_letter_less:
   assumes "trans r"
   shows "trans (letter_less r)"
 using assms unfolding trans_def letter_less_def by fast
 
 lemma trans_order_nest: "trans (nest r R)"
 using trans_mult unfolding nest_def trans_def by fast
 
 lemma trans_greek_less[simp]: "trans (greek_less r)"
 by (subst greek_less_unfold) (rule trans_order_nest)
 
 lemma mono_greek_less: "mono greek_less"
 unfolding greek_less_def mono_def
 proof (intro allI impI lfp_mono)
   fix r s :: "('a \<times> 'a) set" and R :: "('a greek \<times> 'a greek) set"
   assume "r \<subseteq> s"
   then have "letter_less r <*lex*> R \<subseteq> letter_less s <*lex*> R"
   using mono_letter_less mono_lex1 unfolding mono_def by metis
   then show "nest r R \<subseteq> nest s R" using mono_mult unfolding nest_def mono_def by blast
 qed
 
 
 subsection \<open>Involution\<close>
 
 definition inv_letter :: "'a letter \<Rightarrow> 'a letter" where
   "inv_letter l \<equiv>
     case l of (a, x) \<Rightarrow> (case a of Grave \<Rightarrow> Acute | Acute \<Rightarrow> Grave | Macron \<Rightarrow> Macron, x)"
 
 lemma inv_letter_pair[simp]:
   "inv_letter (a, x) = (case a of Grave \<Rightarrow> Acute | Acute \<Rightarrow> Grave | Macron \<Rightarrow> Macron, x)"
 by (simp add: inv_letter_def)
 
 lemma snd_inv_letter[simp]:
   "snd (inv_letter x) = snd x"
 by (simp add: inv_letter_def split: prod.splits)
 
 lemma inv_letter_invol[simp]:
   "inv_letter (inv_letter x) = x"
 by (simp add: inv_letter_def split: prod.splits accent.splits)
 
 lemma inv_letter_mono[simp]:
   assumes "(x, y) \<in> letter_less r"
   shows "(inv_letter x, inv_letter y) \<in> letter_less r"
 using assms by simp
 
 definition inv_greek :: "'a greek \<Rightarrow> 'a greek" where
   "inv_greek s = rev (map inv_letter s)"
 
 lemma inv_greek_invol[simp]:
   "inv_greek (inv_greek s) = s"
 by (simp add: inv_greek_def rev_map comp_def)
 
 lemma inv_greek_append:
   "inv_greek (s @ t) = inv_greek t @ inv_greek s"
 by (simp add: inv_greek_def)
 
 definition inv_msog :: "('a letter \<times> 'a greek) multiset \<Rightarrow> ('a letter \<times> 'a greek) multiset" where
   "inv_msog M = image_mset (\<lambda>(x, t). (inv_letter x, inv_greek t)) M"
 
 lemma inv_msog_invol[simp]:
   "inv_msog (inv_msog M) = M"
 by (simp add: inv_msog_def multiset.map_comp comp_def prod.case_distrib)
 
 lemma ms_of_greek_inv_greek:
   "ms_of_greek (inv_greek M) = inv_msog (ms_of_greek M)"
 unfolding inv_msog_def inv_greek_def ms_of_greek_def list_splits_rev list_splits_map mset_map
   multiset.map_comp mset_rev inv_letter_def adj_msog_def
 by (rule cong[OF cong[OF refl[of "image_mset"]] refl]) (auto split: accent.splits)
 
 lemma inv_greek_mono:
   assumes "trans r" and "(s, t) \<in> greek_less r"
   shows "(inv_greek s, inv_greek t) \<in> greek_less r"
 using assms(2)
 proof (induct "length s + length t" arbitrary: s t rule: less_induct)
   note * = trans_lex_prod[OF trans_letter_less[OF \<open>trans r\<close>] trans_greek_less[of r]]
   case (less s t)
   have "(inv_msog (ms_of_greek s), inv_msog (ms_of_greek t)) \<in> mult (letter_less r <*lex*> greek_less r)"
   unfolding inv_msog_def
   proof (induct rule: mult_of_image_mset[OF * *])
     case (1 x y) thus ?case
     by (auto intro: less(1) split: prod.splits dest!: ms_of_greek_shorter)
   next
     case 2 thus ?case using less(2) by (subst(asm) greek_less_unfold) simp
   qed
   thus ?case by (subst greek_less_unfold) (auto simp: ms_of_greek_inv_greek)
 qed
 
 
 subsection \<open>Monotonicity of @{term "greek_less r"}\<close>
 
 lemma greek_less_rempty[simp]:
   "(a,[]) \<in> greek_less r \<longleftrightarrow> False"
 by (subst greek_less_unfold) (auto simp: ms_of_greek_def)
 
 lemma greek_less_nonempty:
   assumes "b \<noteq> []"
   shows "(a,b) \<in> greek_less r \<longleftrightarrow> (a,b) \<in> nest r (greek_less r)"
 by (subst greek_less_unfold) simp
 
 lemma greek_less_lempty[simp]:
   "([],b) \<in> greek_less r \<longleftrightarrow> b \<noteq> []"
 proof
   assume "([],b) \<in> greek_less r"
   then show "b \<noteq> []" using greek_less_rempty by fast
 next
   assume "b \<noteq> []"
   then show "([],b) \<in> greek_less r"
   unfolding greek_less_nonempty[OF \<open>b \<noteq> []\<close>] by (simp add: ms_of_greek_def)
 qed
 
 lemma greek_less_singleton:
   "(a, b) \<in> letter_less r \<Longrightarrow> ([a], [b]) \<in> greek_less r"
 by (subst greek_less_unfold) (auto split: accent.splits simp: adj_msog_def ms_of_greek_def)
 
 lemma ms_of_greek_cons:
   "ms_of_greek (x # s) = {# adj_msog [] s (x,[]) #} + image_mset (adj_msog [x] []) (ms_of_greek s)"
 using msog_append[of "[x]" s]
 by (auto simp add: adj_msog_def ms_of_greek_def accent.splits)
 
 lemma greek_less_cons_mono:
   assumes "trans r"
   shows "(s, t) \<in> greek_less r \<Longrightarrow> (x # s, x # t) \<in> greek_less r"
 proof (induct "length s + length t" arbitrary: s t rule: less_induct)
   note * = trans_lex_prod[OF trans_letter_less[OF \<open>trans r\<close>] trans_greek_less[of r]]
   case (less s t)
   {
     fix M have "(M + image_mset (adj_msog [x] []) (ms_of_greek s),
       M + image_mset (adj_msog [x] []) (ms_of_greek t)) \<in> mult (letter_less r <*lex*> greek_less r)"
     proof (rule mult_on_union, induct rule: mult_of_image_mset[OF * *])
       case (1 x y) thus ?case unfolding adj_msog_def
       by (auto intro: less(1) split: prod.splits accent.splits dest!: ms_of_greek_shorter)
     next
       case 2 thus ?case using less(2) by (subst(asm) greek_less_unfold) simp
     qed
   }
   moreover {
     fix N have "({# adj_msog [] s (x,[]) #} + N,{# adj_msog [] t (x,[]) #} + N) \<in>
       (mult (letter_less r <*lex*> greek_less r))\<^sup>="
     by (auto simp: adj_msog_def less split: accent.splits) }
   ultimately show ?case using transD[OF trans_mult]
   by (subst greek_less_unfold) (fastforce simp: ms_of_greek_cons)
 qed
 
 lemma greek_less_app_mono2:
   assumes "trans r" and "(s, t) \<in> greek_less r"
   shows "(p @ s, p @ t) \<in> greek_less r"
 using assms by (induct p) (auto simp add: greek_less_cons_mono)
 
 lemma greek_less_app_mono1:
   assumes "trans r" and "(s, t) \<in> greek_less r"
   shows "(s @ p, t @ p) \<in> greek_less r"
 using inv_greek_mono[of r "inv_greek p @ inv_greek s" "inv_greek p @ inv_greek t"]
 by (simp add: assms inv_greek_append inv_greek_mono greek_less_app_mono2)
 
 
 subsection \<open>Well-founded-ness of @{term "greek_less r"}\<close>
 
 lemma greek_embed:
   assumes "trans r"
   shows "list_emb (\<lambda>a b. (a, b): reflcl (letter_less r)) a b \<Longrightarrow> (a, b) \<in> reflcl (greek_less r)"
 proof (induct rule: list_emb.induct)
   case (list_emb_Cons a b y) thus ?case
   using trans_greek_less[unfolded trans_def] \<open>trans r\<close>
     greek_less_app_mono1[of r "[]" "[y]" a] greek_less_app_mono2[of r a b "[y]"] by auto
 next
   case (list_emb_Cons2 x y a b) thus ?case
   using trans_greek_less[unfolded trans_def] \<open>trans r\<close> greek_less_singleton[of x y r]
     greek_less_app_mono1[of r "[x]" "[y]" a] greek_less_app_mono2[of r a b "[y]"] by auto
 qed simp
 
 lemma wqo_letter_less:
   assumes t: "trans r" and w: "wqo_on (\<lambda>a b. (a, b) \<in> r\<^sup>=) UNIV"
   shows "wqo_on (\<lambda>a b. (a, b) \<in> (letter_less r)\<^sup>=) UNIV"
-proof (rule wqo_on_hom[of _ id _ "prod_le (=) (\<lambda>a b. (a, b) \<in> r\<^sup>=)", unfolded image_id id_apply])
+proof (rule wqo_on_hom[of id _ _ "prod_le (=) (\<lambda>a b. (a, b) \<in> r\<^sup>=)", unfolded image_id id_apply])
   show "wqo_on (prod_le ((=) :: accent \<Rightarrow> accent \<Rightarrow> bool) (\<lambda>a b. (a, b) \<in> r\<^sup>=)) UNIV"
   by (rule dickson[OF finite_eq_wqo_on[OF finite_accent] w, unfolded UNIV_Times_UNIV])
 qed (insert t, auto simp: transp_on_def trans_def prod_le_def)
 
 lemma wf_greek_less:
   assumes "wf r" and "trans r"
   shows "wf (greek_less r)"
 proof -
   obtain q where "r \<subseteq> q" and "well_order q" by (metis total_well_order_extension \<open>wf r\<close>)
   define q' where "q' = q - Id"
   from \<open>well_order q\<close> have "reflcl q' = q"
   by (auto simp add: well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def
       refl_on_def q'_def)
   from \<open>well_order q\<close> have "trans q'" and "irrefl q'"
   unfolding well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def antisym_def
     trans_def irrefl_def q'_def by blast+
   from \<open>r \<subseteq> q\<close> \<open>wf r\<close> have "r \<subseteq> q'" by (auto simp add: q'_def)
   have "wqo_on (\<lambda>a b. (a,b) \<in> (greek_less q')\<^sup>=) UNIV"
-  proof (intro wqo_on_hom[of "(\<lambda>a b. (a, b) \<in> (greek_less q')\<^sup>=)" "id" UNIV
+  proof (intro wqo_on_hom[of id UNIV "(\<lambda>a b. (a, b) \<in> (greek_less q')\<^sup>=)"
          "list_emb (\<lambda>a b. (a, b) \<in> (letter_less q')\<^sup>=)", unfolded surj_id])
-    show "transp_on (\<lambda>a b. (a, b) \<in> (greek_less q')\<^sup>=) UNIV"
+    show "transp (\<lambda>a b. (a, b) \<in> (greek_less q')\<^sup>=)"
     using trans_greek_less[of q'] unfolding trans_def transp_on_def by blast
   next
     show "\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. list_emb (\<lambda>a b. (a, b) \<in> (letter_less q')\<^sup>=) x y \<longrightarrow>
           (id x, id y) \<in> (greek_less q')\<^sup>="
     using greek_embed[OF \<open>trans q'\<close>] by auto
   next
     show "wqo_on (list_emb (\<lambda>a b. (a, b) \<in> (letter_less q')\<^sup>=)) UNIV"
     using higman[OF wqo_letter_less[OF \<open>trans q'\<close>]] \<open>well_order q\<close> \<open>reflcl q' = q\<close>
     by (auto simp: well_order_implies_wqo)
   qed
   with wqo_on_imp_wfp_on[OF this] strict_order_strict[OF strict_order_greek_less]
     \<open>irrefl q'\<close> \<open>trans q'\<close>
   have "wfp_on (\<lambda>a b. (a, b) \<in> greek_less q') UNIV" by force
   then show ?thesis
   using mono_greek_less \<open>r \<subseteq> q'\<close> wf_subset unfolding wf_iff_wfp_on[symmetric] mono_def by metis
 qed
 
 
 subsection \<open>Basic Comparisons\<close>
 
 lemma pairwise_imp_mult:
   assumes "N \<noteq> {#}" and "\<forall>x \<in> set_mset M. \<exists>y \<in> set_mset N. (x, y) \<in> r"
   shows "(M, N) \<in> mult r"
 using assms one_step_implies_mult[of _ _ _ "{#}"] by auto
 
 lemma singleton_greek_less:
   assumes as: "snd ` set as \<subseteq> under r b"
   shows "(as, [(a,b)]) \<in> greek_less r"
 proof -
   {
     fix e assume "e \<in> set_mset (ms_of_greek as)"
     with as ms_of_greek_elem[of _ _ as]
     have "(e, ((a,b),[])) \<in> letter_less r <*lex*> greek_less r"
     by (cases e) (fastforce simp: adj_msog_def under_def)
   }
   moreover have "ms_of_greek [(a,b)] = {# ((a,b),[]) #}"
   by (auto simp: ms_of_greek_def adj_msog_def split: accent.splits)
   ultimately show ?thesis
   by (subst greek_less_unfold) (auto intro!: pairwise_imp_mult)
 qed
 
 lemma peak_greek_less:
   assumes as: "snd ` set as \<subseteq> under r a" and b': "b' \<in> {[(Grave,b)],[]}"
   and cs: "snd ` set cs \<subseteq> under r a \<union> under r b" and a': "a' \<in> {[(Acute,a)],[]}"
   and bs: "snd ` set bs \<subseteq> under r b"
   shows "(as @ b' @ cs @ a' @ bs, [(Acute,a),(Grave,b)]) \<in> greek_less r"
 proof -
   let ?A = "(Acute,a)" and ?B = "(Grave,b)"
   have "(ms_of_greek (as @ b' @ cs @ a' @ bs), ms_of_greek [?A,?B]) \<in> mult (letter_less r <*lex*> greek_less r)"
   proof (intro pairwise_imp_mult)
     (* we distinguish 5 cases depending on where in xs an element e originates *)
     {
       fix e assume "e \<in> set_mset (ms_of_greek as)"
       with as ms_of_greek_elem[of _ _ as]
       have "(adj_msog [] (b' @ cs @ a' @ bs) e, (?A,[?B])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def under_def)
     }
     moreover {
       fix e assume "e \<in> set_mset (ms_of_greek b')"
       with b' singleton_greek_less[OF as] ms_of_greek_elem[of _ _ b']
       have "(adj_msog as (cs @ a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
     }
     moreover {
       fix e assume "e \<in> set_mset (ms_of_greek cs)"
       with cs ms_of_greek_elem[of _ _ cs]
       have "(adj_msog (as @ b') (a' @ bs) e, (?A,[?B])) \<in> letter_less r <*lex*> greek_less r \<or>
             (adj_msog (as @ b') (a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def under_def)
     }
     moreover {
       fix e assume "e \<in> set_mset (ms_of_greek a')"
       with a' singleton_greek_less[OF bs] ms_of_greek_elem[of _ _ a']
       have "(adj_msog (as @ b' @ cs) bs e, (?A,[?B])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
     }
     moreover {
       fix e assume "e \<in> set_mset (ms_of_greek bs)"
       with bs ms_of_greek_elem[of _ _ bs]
       have "(adj_msog (as @ b' @ cs @ a') [] e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def under_def)
     }
     moreover have "ms_of_greek [?A,?B] = {# (?B,[?A]), (?A,[?B]) #}"
     by (simp add: adj_msog_def ms_of_greek_def)
     ultimately show "\<forall>x\<in>set_mset (ms_of_greek (as @ b' @ cs @ a' @ bs)).
       \<exists>y\<in>set_mset (ms_of_greek [?A,?B]). (x, y) \<in> letter_less r <*lex*> greek_less r"
     by (auto simp: msog_append) blast
   qed (auto simp: ms_of_greek_def)
   then show ?thesis by (subst greek_less_unfold) auto
 qed
 
 lemma rcliff_greek_less1:
   assumes "trans r" (* unused assumption kept for symmetry with lcliff_greek_less1 *)
   and as: "snd ` set as \<subseteq> under r a \<inter> under r b" and b': "b' \<in> {[(Grave,b)],[]}"
   and cs: "snd ` set cs \<subseteq> under r b" and a': "a' = [(Macron,a)]"
   and bs: "snd ` set bs \<subseteq> under r b"
   shows "(as @ b' @ cs @ a' @ bs, [(Macron,a),(Grave,b)]) \<in> greek_less r"
 proof -
   let ?A = "(Macron,a)" and ?B = "(Grave,b)"
   have *: "ms_of_greek [?A,?B] = {#(?B,[?A]), (?A,[])#}" "ms_of_greek [?A] = {#(?A,[])#}"
   by (simp_all add: ms_of_greek_def adj_msog_def)
   then have **: "ms_of_greek [(Macron, a), (Grave, b)] - {#((Macron, a), [])#} \<noteq> {#}"
   by (auto)
   (* we distinguish 5 cases depending on where in xs an element e originates *)
   {
     fix e assume "e \<in> set_mset (ms_of_greek as)"
     with as ms_of_greek_elem[of _ _ as]
     have "(adj_msog [] (b' @ cs @ a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
     by (cases e) (force simp: adj_msog_def under_def)
   }
   moreover {
     fix e assume "e \<in> set_mset (ms_of_greek b')"
     with b' singleton_greek_less as ms_of_greek_elem[of _ _ b']
     have "(adj_msog as (cs @ a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
     by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
   }
   moreover {
     fix e assume "e \<in> set_mset (ms_of_greek cs)"
     with cs ms_of_greek_elem[of _ _ cs]
     have "(adj_msog (as @ b') (a' @ bs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
     by (cases e) (fastforce simp: adj_msog_def under_def)
   }
   moreover {
     fix e assume "e \<in> set_mset (ms_of_greek bs)"
     with bs ms_of_greek_elem[of _ _ bs]
     have "(adj_msog (as @ b' @ cs @ a') [] e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
     by (cases e) (fastforce simp: adj_msog_def under_def)
   }
   moreover have "ms_of_greek [?A,?B] = {# (?B,[?A]), (?A,[]) #}"
   by (simp add: adj_msog_def ms_of_greek_def)
   ultimately have "\<forall>x\<in>set_mset (ms_of_greek (as @ b' @ cs @ a' @ bs) - {#(?A,[])#}).
     \<exists>y\<in>set_mset (ms_of_greek [?A,?B] - {#(?A,[])#}). (x, y) \<in> letter_less r <*lex*> greek_less r"
   unfolding msog_append by (auto simp: a' msog_append ac_simps * adj_msog_single)
   from one_step_implies_mult[OF ** this,of "{#(?A,[])#}"]
   have "(ms_of_greek (as @ b' @ cs @ a' @ bs), ms_of_greek [?A,?B]) \<in> mult (letter_less r <*lex*> greek_less r)"
   unfolding a' msog_append by (auto simp: a' ac_simps * adj_msog_single)
   then show ?thesis
   by (subst greek_less_unfold) auto
 qed
 
 lemma rcliff_greek_less2:
   assumes "trans r" (* unused assumption kept for symmetry with lcliff_greek_less2 *)
   and as: "snd ` set as \<subseteq> under r a" and b': "b' \<in> {[(Grave,b)],[]}"
   and cs: "snd ` set cs \<subseteq> under r a \<union> under r b"
   shows "(as @ b' @ cs, [(Macron,a),(Grave,b)]) \<in> greek_less r"
 proof -
   let ?A = "(Macron,a)" and ?B = "(Grave,b)"
   have "(ms_of_greek (as @ b' @ cs), ms_of_greek [?A,?B]) \<in> mult (letter_less r <*lex*> greek_less r)"
   proof (intro pairwise_imp_mult)
     (* we distinguish 3 cases depending on where in xs an element e originates *)
     {
       fix e assume "e \<in> set_mset (ms_of_greek as)"
       with as ms_of_greek_elem[of _ _ as]
       have "(adj_msog [] (b' @ cs) e, (?A,[])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def under_def)
     }
     moreover {
       fix e assume "e \<in> set_mset (ms_of_greek b')"
       with b' singleton_greek_less[OF as] ms_of_greek_elem[of _ _ b']
       have "(adj_msog as (cs) e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def ms_of_greek_def)
     }
     moreover {
       fix e assume "e \<in> set_mset (ms_of_greek cs)"
       with cs ms_of_greek_elem[of _ _ cs]
       have "(adj_msog (as @ b') [] e, (?A,[])) \<in> letter_less r <*lex*> greek_less r \<or>
             (adj_msog (as @ b') [] e, (?B,[?A])) \<in> letter_less r <*lex*> greek_less r"
       by (cases e) (fastforce simp: adj_msog_def under_def)
     }
     moreover have *: "ms_of_greek [?A,?B] = {# (?B,[?A]), (?A,[]) #}"
     by (simp add: adj_msog_def ms_of_greek_def)
     ultimately show "\<forall>x\<in>set_mset (ms_of_greek (as @ b' @ cs)).
       \<exists>y\<in>set_mset (ms_of_greek [?A,?B]). (x, y) \<in> letter_less r <*lex*> greek_less r"
     by (auto simp: msog_append adj_msog_single ac_simps *) blast
   qed (auto simp: ms_of_greek_def)
   then show ?thesis by (subst greek_less_unfold) auto
 qed
 
 lemma snd_inv_greek [simp]: "snd ` set (inv_greek as) = snd ` set as"
 by (force simp: inv_greek_def)
 
 lemma lcliff_greek_less1:
   assumes "trans r"
   and as: "snd ` set as \<subseteq> under r a" and b': "b' = [(Macron,b)]"
   and cs: "snd ` set cs \<subseteq> under r a" and a': "a' \<in> {[(Acute,a)],[]}"
   and bs: "snd ` set bs \<subseteq> under r a \<inter> under r b"
   shows "(as @ b' @ cs @ a' @ bs, [(Acute,a),(Macron,b)]) \<in> greek_less r"
 proof -
   have *: "inv_greek [(Acute,a),(Macron,b)] = [(Macron,b),(Grave,a)]" by (simp add: inv_greek_def)
   have "(inv_greek (inv_greek (as @ b' @ cs @ a' @ bs)),
    inv_greek (inv_greek ([(Acute,a),(Macron,b)]))) \<in> greek_less r"
    apply (rule inv_greek_mono[OF \<open>trans r\<close>])
    apply (unfold inv_greek_append append_assoc *)
    apply (insert assms)
    apply (rule rcliff_greek_less1, auto simp: inv_greek_def)
   done
   then show ?thesis by simp
 qed
 
 lemma lcliff_greek_less2:
   assumes "trans r"
   and cs: "snd ` set cs \<subseteq> under r a \<union> under r b" and a': "a' \<in> {[(Acute,a)],[]}"
   and bs: "snd ` set bs \<subseteq> under r b"
   shows "(cs @ a' @ bs, [(Acute,a),(Macron,b)]) \<in> greek_less r"
 proof -
   have *: "inv_greek [(Acute,a),(Macron,b)] = [(Macron,b),(Grave,a)]" by (simp add: inv_greek_def)
   have "(inv_greek (inv_greek (cs @ a' @ bs)),
     inv_greek (inv_greek ([(Acute,a),(Macron,b)]))) \<in> greek_less r"
    apply (rule inv_greek_mono[OF \<open>trans r\<close>])
    apply (unfold inv_greek_append append_assoc *)
    apply (insert assms)
    apply (rule rcliff_greek_less2, auto simp: inv_greek_def)
   done
   then show ?thesis by simp
 qed
 
 
 subsection \<open>Labeled abstract rewriting\<close>
 
 context
   fixes L R E :: "'b \<Rightarrow> 'a rel"
 begin
 
 definition lstep :: "'b letter \<Rightarrow> 'a rel" where
   [simp]: "lstep x = (case x of (a, i) \<Rightarrow> (case a of Acute \<Rightarrow> (L i)\<inverse> | Grave \<Rightarrow> R i | Macron \<Rightarrow> E i))"
 
 fun lconv :: "'b greek \<Rightarrow> 'a rel" where
   "lconv [] = Id"
 | "lconv (x # xs) = lstep x O lconv xs"
 
 lemma lconv_append[simp]:
   "lconv (xs @ ys) = lconv xs O lconv ys"
 by (induct xs) auto
 
 lemma conversion_join_or_peak_or_cliff:
   obtains (join) as bs cs where "set as \<subseteq> {Grave}" and "set bs \<subseteq> {Macron}" and "set cs \<subseteq> {Acute}"
     and "ds = as @ bs @ cs"
   | (peak) as bs where "ds = as @ ([Acute] @ [Grave]) @ bs"
   | (lcliff) as bs where "ds = as @ ([Acute] @ [Macron]) @ bs"
   | (rcliff) as bs where "ds = as @ ([Macron] @ [Grave]) @ bs"
 proof (induct ds arbitrary: thesis)
   case (Cons d ds thesis) note IH = this show ?case
   proof (rule IH(1))
     fix as bs assume "ds = as @ ([Acute] @ [Grave]) @ bs" then show ?case
     using IH(3)[of "d # as" bs] by simp
   next
     fix as bs assume "ds = as @ ([Acute] @ [Macron]) @ bs" then show ?case
     using IH(4)[of "d # as" bs] by simp
   next
     fix as bs assume "ds = as @ ([Macron] @ [Grave]) @ bs" then show ?case
     using IH(5)[of "d # as" bs] by simp
   next
     fix as bs cs assume *: "set as \<subseteq> {Grave}" "set bs \<subseteq> {Macron}" "set cs \<subseteq> {Acute}" "ds = as @ bs @ cs"
     show ?case
     proof (cases d)
       case Grave thus ?thesis using * IH(2)[of "d # as" bs cs] by simp
     next
       case Macron show ?thesis
       proof (cases as)
         case Nil thus ?thesis using * Macron IH(2)[of as "d # bs" cs] by simp
       next
         case (Cons a as) thus ?thesis using * Macron IH(5)[of "[]" "as @ bs @ cs"] by simp
       qed
     next
       case Acute show ?thesis
       proof (cases as)
         case Nil note as = this show ?thesis
         proof (cases bs)
           case Nil thus ?thesis using * as Acute IH(2)[of "[]" "[]" "d # cs"] by simp
         next
           case (Cons b bs) thus ?thesis using * as Acute IH(4)[of "[]" "bs @ cs"] by simp
         qed
       next
         case (Cons a as) thus ?thesis using * Acute IH(3)[of "[]" "as @ bs @ cs"] by simp
       qed
     qed
   qed
 qed auto
 
 lemma map_eq_append_split:
   assumes "map f xs = ys1 @ ys2"
   obtains xs1 xs2 where "ys1 = map f xs1" "ys2 = map f xs2" "xs = xs1 @ xs2"
 proof (insert assms, induct ys1 arbitrary: xs thesis)
   case (Cons y ys) note IH = this show ?case
   proof (cases xs)
     case (Cons x xs') show ?thesis
     proof (rule IH(1))
       fix xs1 xs2 assume "ys = map f xs1" "ys2 = map f xs2" "xs' = xs1 @ xs2" thus ?thesis
       using Cons IH(2)[of "x # xs1" xs2] IH(3) by simp
     next
       show "map f xs' = ys @ ys2" using Cons IH(3) by simp
     qed
   qed (insert Cons, simp)
 qed auto
 
 lemmas map_eq_append_splits = map_eq_append_split map_eq_append_split[OF sym]
 
 abbreviation "conversion' M \<equiv> ((\<Union>i \<in> M. R i) \<union> (\<Union>i \<in> M. E i) \<union> (\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"
 abbreviation "valley' M \<equiv>  (\<Union>i \<in> M. R i)\<^sup>* O (\<Union>i \<in> M. E i)\<^sup>* O ((\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"
 
 lemma conversion_to_lconv:
   assumes "(u, v) \<in> conversion' M"
   obtains xs where "snd ` set xs \<subseteq> M" and "(u, v) \<in> lconv xs"
 using assms
 proof (induct arbitrary: thesis rule: converse_rtrancl_induct)
   case base show ?case using base[of "[]"] by simp
 next
   case (step u' x)
   from step(1) obtain p where "snd p \<in> M" and "(u', x) \<in> lstep p"
   by (force split: accent.splits)
   moreover obtain xs where "snd ` set xs \<subseteq> M" "(x, v) \<in> lconv xs" by (rule step(3))
   ultimately show ?case using step(4)[of "p # xs"] by auto
 qed
 
 definition lpeak :: "'b rel \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b greek \<Rightarrow> bool" where
   "lpeak r a b xs \<longleftrightarrow> (\<exists>as b' cs a' bs. snd ` set as \<subseteq> under r a \<and> b' \<in> {[(Grave,b)],[]} \<and>
     snd ` set cs \<subseteq> under r a \<union> under r b \<and> a' \<in> {[(Acute,a)],[]} \<and>
     snd ` set bs \<subseteq> under r b \<and> xs = as @ b' @ cs @ a' @ bs)"
 
 definition lcliff :: "'b rel \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b greek \<Rightarrow> bool" where
   "lcliff r a b xs \<longleftrightarrow> (\<exists>as b' cs a' bs. snd ` set as \<subseteq> under r a \<and> b' = [(Macron,b)] \<and>
     snd ` set cs \<subseteq> under r a \<and> a' \<in> {[(Acute,a)],[]} \<and>
     snd ` set bs \<subseteq> under r a \<inter> under r b \<and> xs = as @ b' @ cs @ a' @ bs) \<or>
     (\<exists>cs a' bs. snd ` set cs \<subseteq> under r a \<union> under r b \<and> a' \<in> {[(Acute,a)],[]} \<and>
     snd ` set bs \<subseteq> under r b \<and> xs = cs @ a' @ bs)"
     
 definition rcliff :: "'b rel \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b greek \<Rightarrow> bool" where
   "rcliff r a b xs \<longleftrightarrow> (\<exists>as b' cs a' bs. snd ` set as \<subseteq> under r a \<inter> under r b \<and> b' \<in> {[(Grave,b)],[]} \<and>
     snd ` set cs \<subseteq> under r b \<and> a' = [(Macron,a)] \<and>
     snd ` set bs \<subseteq> under r b \<and> xs = as @ b' @ cs @ a' @ bs) \<or>
     (\<exists>as b' cs. snd ` set as \<subseteq> under r a \<and> b' \<in> {[(Grave,b)],[]} \<and>
     snd ` set cs \<subseteq> under r a \<union> under r b \<and> xs = as @ b' @ cs)"
 
 lemma dd_commute_modulo_conv[case_names wf trans peak lcliff rcliff]:
   assumes "wf r" and "trans r"
   and pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow> \<exists>xs. lpeak r a b xs \<and> (t, u) \<in> lconv xs"
   and lc: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> E b \<Longrightarrow> \<exists>xs. lcliff r a b xs \<and> (t, u) \<in> lconv xs"
   and rc: "\<And>a b s t u. (s, t) \<in> (E a)\<inverse> \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow> \<exists>xs. rcliff r a b xs \<and> (t, u) \<in> lconv xs"
   shows "conversion' UNIV \<subseteq> valley' UNIV"
 proof (intro subrelI)
   fix u v
   assume "(u,v) \<in> conversion' UNIV"
   then obtain xs where "(u, v) \<in> lconv xs" by (auto intro: conversion_to_lconv[of u v])
   then show "(u, v) \<in> valley' UNIV"
   proof (induct xs rule: wf_induct[of "greek_less r"])
     case 1 thus ?case using wf_greek_less[OF \<open>wf r\<close> \<open>trans r\<close>] .
   next
     case (2 xs) show ?case
     proof (rule conversion_join_or_peak_or_cliff[of "map fst xs"])
       fix as bs cs
       assume *: "set as \<subseteq> {Grave}" "set bs \<subseteq> {Macron}" "set cs \<subseteq> {Acute}" "map fst xs = as @ bs @ cs"
       then show "(u, v) \<in> valley' UNIV"
       proof (elim map_eq_append_splits)
         fix as' bs' cs' bcs'
         assume as: "set as \<subseteq> {Grave}" "as = map fst as'" and
           bs: "set bs \<subseteq> {Macron}" "bs = map fst bs'" and
           cs: "set cs \<subseteq> {Acute}" "cs = map fst cs'" and
           xs: "xs = as' @ bcs'" "bcs' = bs' @ cs'"
         from as(1)[unfolded as(2)] have as': "\<And>x y. (x,y) \<in> lconv as' \<Longrightarrow> (x,y) \<in> (\<Union>a. R a)\<^sup>*"
         proof (induct as')
           case (Cons x' xs)
           have "\<And>x y z i. (x,y) \<in> R i \<Longrightarrow> (y,z) \<in> (\<Union>a. R a)\<^sup>* \<Longrightarrow> (x,z) \<in> (\<Union>a. R a)\<^sup>*"
           by (rule rtrancl_trans) auto
           with Cons show ?case by auto
         qed simp
         from bs(1)[unfolded bs(2)] have bs': "\<And>x y. (x,y) \<in> lconv bs' \<Longrightarrow> (x,y) \<in> (\<Union>a. E a)\<^sup>*"
         proof (induct bs')
           case (Cons x' xs)
           have "\<And>x y z i. (x,y) \<in> E i \<Longrightarrow> (y,z) \<in> (\<Union>a. E a)\<^sup>* \<Longrightarrow> (x,z) \<in> (\<Union>a. E a)\<^sup>*"
           by (rule rtrancl_trans) auto 
           with Cons show ?case by auto
         qed simp
         from cs(1)[unfolded cs(2)] have cs': "\<And>x y. (x,y) \<in> lconv cs' \<Longrightarrow> (x,y) \<in> ((\<Union>a. L a)\<inverse>)\<^sup>*"
         proof (induct cs')
           case (Cons x' xs)
           have "\<And>x y z i. (x,y) \<in> (L i)\<inverse> \<Longrightarrow> (y,z) \<in> ((\<Union>a. L a)\<inverse>)\<^sup>* \<Longrightarrow> (x,z) \<in> ((\<Union>a. L a)\<inverse>)\<^sup>*"
           by (rule rtrancl_trans) auto 
           with Cons show ?case by auto
         qed simp
         from 2(2) as' bs' cs' show "(u, v) \<in> valley' UNIV"
         unfolding xs lconv_append by auto (meson relcomp.simps) 
       qed
     next
       fix as bs assume *: "map fst xs = as @ ([Acute] @ [Grave]) @ bs"
       {
         fix p a b q t' s' u'
         assume xs: "xs = p @ [(Acute,a),(Grave,b)] @ q" and p: "(u,t') \<in> lconv p"
           and a: "(s',t') \<in> L a" and b: "(s',u') \<in> R b" and q: "(u',v) \<in> lconv q"
         obtain js where lp: "lpeak r a b js" and js: "(t',u') \<in> lconv js" using pk[OF a b] by auto
         from lp have "(js, [(Acute,a),(Grave,b)]) \<in> greek_less r"
         unfolding lpeak_def using peak_greek_less[of _ r a _ b] by fastforce
         then have "(p @ js @ q, xs) \<in> greek_less r" unfolding xs
         by (intro greek_less_app_mono1 greek_less_app_mono2 \<open>trans r\<close>) auto
         moreover have "(u, v) \<in> lconv (p @ js @ q)"
         using p q js by auto
         ultimately have "(u, v) \<in> valley' UNIV" using 2(1) by blast
       }
       with * show "(u, v) \<in> valley' UNIV" using 2(2)
       by (auto elim!: map_eq_append_splits relcompEpair simp del: append.simps) simp
     next
       fix as bs assume *: "map fst xs = as @ ([Acute] @ [Macron]) @ bs"
       {
         fix p a b q t' s' u'
         assume xs: "xs = p @ [(Acute,a),(Macron,b)] @ q" and p: "(u,t') \<in> lconv p"
           and a: "(s',t') \<in> L a" and b: "(s',u') \<in> E b" and q: "(u',v) \<in> lconv q"
         obtain js where lp: "lcliff r a b js" and js: "(t',u') \<in> lconv js" using lc[OF a b] by auto
         from lp have "(js, [(Acute,a),(Macron,b)]) \<in> greek_less r"
         unfolding lcliff_def
         using lcliff_greek_less1[OF \<open>trans r\<close>, of _ a _ b] lcliff_greek_less2[OF \<open>trans r\<close>, of _ a b]
         by fastforce
         then have "(p @ js @ q, xs) \<in> greek_less r" unfolding xs
         by (intro greek_less_app_mono1 greek_less_app_mono2 \<open>trans r\<close>) auto
         moreover have "(u, v) \<in> lconv (p @ js @ q)"
         using p q js by auto
         ultimately have "(u, v) \<in> valley' UNIV" using 2(1) by blast
       }
       with * show "(u, v) \<in> valley' UNIV" using 2(2)
       by (auto elim!: map_eq_append_splits relcompEpair simp del: append.simps) simp
     next
       fix as bs assume *: "map fst xs = as @ ([Macron] @ [Grave]) @ bs"
       {
         fix p a b q t' s' u'
         assume xs: "xs = p @ [(Macron,a),(Grave,b)] @ q" and p: "(u,t') \<in> lconv p"
           and a: "(s',t') \<in> (E a)\<inverse>" and b: "(s',u') \<in> R b" and q: "(u',v) \<in> lconv q"
         obtain js where lp: "rcliff r a b js" and js: "(t',u') \<in> lconv js" using rc[OF a b] by auto
         from lp have "(js, [(Macron,a),(Grave,b)]) \<in> greek_less r"
         unfolding rcliff_def
         using rcliff_greek_less1[OF \<open>trans r\<close>, of _ a b] rcliff_greek_less2[OF \<open>trans r\<close>, of _ a _ b]
         by fastforce
         then have "(p @ js @ q, xs) \<in> greek_less r" unfolding xs
         by (intro greek_less_app_mono1 greek_less_app_mono2 \<open>trans r\<close>) auto
         moreover have "(u, v) \<in> lconv (p @ js @ q)"
         using p q js by auto
         ultimately have "(u, v) \<in> valley' UNIV" using 2(1) by blast
       }
       with * show "(u, v) \<in> valley' UNIV" using 2(2)
       by (auto elim!: map_eq_append_splits relcompEpair simp del: append.simps) simp
     qed
   qed
 qed
 
 
 section \<open>Results\<close>
 
 subsection \<open>Church-Rosser modulo\<close>
 
 text \<open>Decreasing diagrams for Church-Rosser modulo, commutation version.\<close>
 
 lemma dd_commute_modulo[case_names wf trans peak lcliff rcliff]:
   assumes "wf r" and "trans r"
   and pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow>
     (t, u) \<in> conversion' (under r a) O (R b)\<^sup>= O conversion' (under r a \<union> under r b) O
       ((L a)\<inverse>)\<^sup>= O conversion' (under r b)"
   and lc: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> E b \<Longrightarrow>
     (t, u) \<in> conversion' (under r a) O E b O conversion' (under r a) O
       ((L a)\<inverse>)\<^sup>= O conversion' (under r a \<inter> under r b) \<or>
     (t, u) \<in> conversion' (under r a \<union> under r b) O ((L a )\<inverse>)\<^sup>= O conversion' (under r b)"
   and rc: "\<And>a b s t u. (s, t) \<in> (E a)\<inverse> \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow>
     (t, u) \<in> conversion' (under r a \<inter> under r b) O (R b)\<^sup>= O conversion' (under r b) O
       E a O conversion' (under r b) \<or>
     (t, u) \<in> conversion' (under r a) O (R b)\<^sup>= O conversion' (under r a \<union> under r b)"
   shows "conversion' UNIV \<subseteq> valley' UNIV"
 proof (cases rule: dd_commute_modulo_conv[of r])
   case (peak a b s t u)
   {
     fix w x y z
     assume "(t, w) \<in> conversion' (under r a)"
     from conversion_to_lconv[OF this]
     obtain as where "snd ` set as \<subseteq> under r a" "(t, w) \<in> lconv as" by auto
     moreover assume "(w, x) \<in> (R b)\<^sup>="
     then obtain b' where "b' \<in> {[(Grave,b)],[]}" "(w, x) \<in> lconv b'" by fastforce
     moreover assume "(x, y) \<in> conversion' (under r a \<union> under r b)"
     from conversion_to_lconv[OF this]
     obtain cs where "snd ` set cs \<subseteq> under r a \<union> under r b" "(x, y) \<in> lconv cs" by auto
     moreover assume "(y, z) \<in> ((L a)\<inverse>)\<^sup>="
     then obtain a' where "a' \<in> {[(Acute,a)],[]}" "(y, z) \<in> lconv a'" by fastforce
     moreover assume "(z, u) \<in> conversion' (under r b)"
     from conversion_to_lconv[OF this]
     obtain bs where "snd ` set bs \<subseteq> under r b" "(z, u) \<in> lconv bs" by auto
     ultimately have "\<exists>xs. lpeak r a b xs \<and> (t, u) \<in> lconv xs"
     by (intro exI[of _ "as @ b' @ cs @ a' @ bs"], unfold lconv_append lpeak_def) blast
   }
   then show ?case using pk[OF peak] by blast
 next
   case (lcliff a b s t u)
   {
     fix w x y z
     assume "(t, w) \<in> conversion' (under r a)"
     from conversion_to_lconv[OF this]
     obtain as where "snd ` set as \<subseteq> under r a" "(t, w) \<in> lconv as" by auto
     moreover assume "(w, x) \<in> E b"
     then obtain b' where "b' = [(Macron,b)]" "(w, x) \<in> lconv b'" by fastforce
     moreover assume "(x, y) \<in> conversion' (under r a)"
     from conversion_to_lconv[OF this]
     obtain cs where "snd ` set cs \<subseteq> under r a" "(x, y) \<in> lconv cs" by auto
     moreover assume "(y, z) \<in> ((L a)\<inverse>)\<^sup>="
     then obtain a' where "a' \<in> {[(Acute,a)],[]}" "(y, z) \<in> lconv a'" by fastforce
     moreover assume "(z, u) \<in> conversion' (under r a \<inter> under r b)"
     from conversion_to_lconv[OF this]
     obtain bs where "snd ` set bs \<subseteq> under r a \<inter> under r b" "(z, u) \<in> lconv bs" by auto
     ultimately have "\<exists>xs. lcliff r a b xs \<and> (t, u) \<in> lconv xs"
     by (intro exI[of _ "as @ b' @ cs @ a' @ bs"], unfold lconv_append lcliff_def) blast
   }
   moreover {
     fix w x
     assume "(t, w) \<in> conversion' (under r a \<union> under r b)"
     from conversion_to_lconv[OF this]
     obtain cs where "snd ` set cs \<subseteq> under r a \<union> under r b" "(t, w) \<in> lconv cs" by auto
     moreover assume "(w, x) \<in> ((L a)\<inverse>)\<^sup>="
     then obtain a' where "a' \<in> {[(Acute,a)],[]}" "(w, x) \<in> lconv a'" by fastforce
     moreover assume "(x, u) \<in> conversion' (under r b)"
     from conversion_to_lconv[OF this]
     obtain bs where "snd ` set bs \<subseteq> under r b" "(x, u) \<in> lconv bs" by auto
     ultimately have "\<exists>xs. lcliff r a b xs \<and> (t, u) \<in> lconv xs"
     by (intro exI[of _ "cs @ a' @ bs"], unfold lconv_append lcliff_def) blast
   }
   ultimately show ?case using lc[OF lcliff] by blast
 next
   case (rcliff a b s t u)
   {
     fix w x y z
     assume "(t, w) \<in> conversion' (under r a \<inter> under r b)"
     from conversion_to_lconv[OF this]
     obtain as where "snd ` set as \<subseteq> under r a \<inter> under r b" "(t, w) \<in> lconv as" by auto
     moreover assume "(w, x) \<in> (R b)\<^sup>="
     then obtain b' where "b' \<in> {[(Grave,b)],[]}" "(w, x) \<in> lconv b'" by fastforce
     moreover assume "(x, y) \<in> conversion' (under r b)"
     from conversion_to_lconv[OF this]
     obtain cs where "snd ` set cs \<subseteq> under r b" "(x, y) \<in> lconv cs" by auto
     moreover assume "(y, z) \<in> E a"
     then obtain a' where "a' = [(Macron,a)]" "(y, z) \<in> lconv a'" by fastforce
     moreover assume "(z, u) \<in> conversion' (under r b)"
     from conversion_to_lconv[OF this]
     obtain bs where "snd ` set bs \<subseteq> under r b" "(z, u) \<in> lconv bs" by auto
     ultimately have "\<exists>xs. rcliff r a b xs \<and> (t, u) \<in> lconv xs"
     by (intro exI[of _ "as @ b' @ cs @ a' @ bs"], unfold lconv_append rcliff_def) blast
   }
   moreover {
     fix w x
     assume "(t, w) \<in> conversion' (under r a)"
     from conversion_to_lconv[OF this]
     obtain as where "snd ` set as \<subseteq> under r a" "(t, w) \<in> lconv as" by auto
     moreover assume "(w, x) \<in> (R b)\<^sup>="
     then obtain b' where "b' \<in> {[(Grave,b)],[]}" "(w, x) \<in> lconv b'" by fastforce
     moreover assume "(x, u) \<in> conversion' (under r a \<union> under r b)"
     from conversion_to_lconv[OF this]
     obtain cs where "snd ` set cs \<subseteq> under r a \<union> under r b" "(x, u) \<in> lconv cs" by auto
     ultimately have "\<exists>xs. rcliff r a b xs \<and> (t, u) \<in> lconv xs"
     by (intro exI[of _ "as @ b' @ cs"], unfold lconv_append rcliff_def) blast
   }
   ultimately show ?case using rc[OF rcliff] by blast
 qed fact+
 
 end (* context *)
 
 text \<open>Decreasing diagrams for Church-Rosser modulo.\<close>
 
 lemma dd_cr_modulo[case_names wf trans symE peak cliff]:
   assumes "wf r" and "trans r" and E: "\<And>i. sym (E i)"
   and pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> L b \<Longrightarrow>
     (t, u) \<in> conversion' L L E (under r a) O (L b)\<^sup>= O conversion' L L E (under r a \<union> under r b) O
       ((L a)\<inverse>)\<^sup>= O conversion' L L E (under r b)"
   and cl: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> E b \<Longrightarrow>
     (t, u) \<in> conversion' L L E (under r a) O E b O conversion' L L E (under r a) O
       ((L a)\<inverse>)\<^sup>= O conversion' L L E (under r a \<inter> under r b) \<or>
     (t, u) \<in> conversion' L L E (under r a \<union> under r b) O ((L a )\<inverse>)\<^sup>= O conversion' L L E (under r b)"
   shows "conversion' L L E UNIV \<subseteq> valley' L L E UNIV"
 proof (induct rule: dd_commute_modulo[of r])
   note E' = E[unfolded sym_conv_converse_eq]
   case (rcliff a b s t u) show ?case
     using cl[OF rcliff(2) rcliff(1)[unfolded E'], unfolded converse_iff[of t u,symmetric]]
     by (auto simp only: E' converse_inward) (auto simp only: ac_simps)
 qed fact+
 
 subsection \<open>Commutation and confluence\<close>
 
 abbreviation "conversion'' L R M \<equiv> ((\<Union>i \<in> M. R i) \<union> (\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"
 abbreviation "valley'' L R M \<equiv> (\<Union>i \<in> M. R i)\<^sup>* O ((\<Union>i \<in> M. L i)\<inverse>)\<^sup>*"
 
 text \<open>Decreasing diagrams for commutation.\<close>
 
 lemma dd_commute[case_names wf trans peak]:
   assumes "wf r" and "trans r"
   and pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow>
     (t, u) \<in> conversion'' L R (under r a) O (R b)\<^sup>= O conversion'' L R (under r a \<union> under r b) O
       ((L a)\<inverse>)\<^sup>= O conversion'' L R (under r b)"
   shows "commute (\<Union>i. L i) (\<Union>i. R i)"
 proof -
   have "((\<Union>i. L i)\<inverse>)\<^sup>* O (\<Union>i. R i)\<^sup>* \<subseteq> conversion'' L R UNIV" by regexp
   also have "\<dots> \<subseteq> valley'' L R UNIV"
   using dd_commute_modulo[OF assms(1,2), of L R "\<lambda>_. {}"] pk by auto
   finally show ?thesis by (simp only: commute_def)
 qed
 
 text \<open>Decreasing diagrams for confluence.\<close>
 
 lemmas dd_cr[case_names wf trans peak] =
   dd_commute[of _ L L for L, unfolded CR_iff_self_commute[symmetric]]
 
 
 subsection \<open>Extended decreasing diagrams\<close>
 
 context
   fixes r q :: "'b rel"
   assumes "wf r" and "trans r" and "trans q" and "refl q" and compat: "r O q \<subseteq> r"
 begin
 
 private abbreviation (input) down :: "('b \<Rightarrow> 'a rel) \<Rightarrow> ('b \<Rightarrow> 'a rel)" where
   "down L \<equiv> \<lambda>i. \<Union>j \<in> under q i. L j"
 
 private lemma Union_down: "(\<Union>i. down L i) = (\<Union>i. L i)"
 using \<open>refl q\<close> by (auto simp: refl_on_def under_def)
 
 text \<open>Extended decreasing diagrams for commutation.\<close>
 
 lemma edd_commute[case_names wf transr transq reflq compat peak]:
   assumes pk: "\<And>a b s t u. (s, t) \<in> L a \<Longrightarrow> (s, u) \<in> R b \<Longrightarrow>
     (t, u) \<in> conversion'' L R (under r a) O (down R b)\<^sup>= O conversion'' L R (under r a \<union> under r b) O
       ((down L a)\<inverse>)\<^sup>= O conversion'' L R (under r b)"
   shows "commute (\<Union>i. L i) (\<Union>i. R i)"
 unfolding Union_down[of L, symmetric] Union_down[of R, symmetric]
 proof (induct rule: dd_commute[of r "down L" "down R"])
   case (peak a b s t u)
   then obtain a' b' where a': "(a', a) \<in> q" "(s, t) \<in> L a'" and b': "(b', b) \<in> q" "(s, u) \<in> R b'"
   by (auto simp: under_def)
   have "\<And>a' a. (a',a) \<in> q \<Longrightarrow> under r a' \<subseteq> under r a" using compat by (auto simp: under_def)
   then have aux1: "\<And>a' a L. (a',a) \<in> q \<Longrightarrow> (\<Union>i \<in> under r a'. L i) \<subseteq> (\<Union>i \<in> under r a. L i)" by auto
   have aux2: "\<And>a' a L. (a',a) \<in> q \<Longrightarrow> down L a' \<subseteq> down L a" 
     using \<open>trans q\<close> by (auto simp: under_def trans_def)
   have aux3: "\<And>a L. (\<Union>i \<in> under r a. L i) \<subseteq> (\<Union>i \<in> under r a. down L i)"
     using \<open>refl q\<close> by (auto simp: under_def refl_on_def)
   from aux1[OF a'(1), of L] aux1[OF a'(1), of R] aux2[OF a'(1), of L]
        aux1[OF b'(1), of L] aux1[OF b'(1), of R] aux2[OF b'(1), of R]
        aux3[of L] aux3[of R]
   show ?case
   by (intro subsetD[OF _ pk[OF \<open>(s, t) \<in> L a'\<close> \<open>(s, u) \<in> R b'\<close>]], unfold UN_Un)
      (intro relcomp_mono rtrancl_mono Un_mono iffD2[OF converse_mono]; fast)
 qed fact+
 
 text \<open>Extended decreasing diagrams for confluence.\<close>
 
 lemmas edd_cr[case_names wf transr transq reflq compat peak] =
   edd_commute[of L L for L, unfolded CR_iff_self_commute[symmetric]]
 
 end (* context *)
 
 end (* Decreasing_Diagrams_II *)
diff --git a/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II_Aux.thy b/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II_Aux.thy
--- a/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II_Aux.thy
+++ b/thys/Decreasing-Diagrams-II/Decreasing_Diagrams_II_Aux.thy
@@ -1,261 +1,261 @@
 (* Title:      Decreasing Diagrams II  
    Author:     Bertram Felgenhauer (2015)
    Maintainer: Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at>
    License:    LGPL or BSD
 
 License clarification: This file is also licensed under the BSD license to facilitate reuse
 and moving snippets from here to more suitable places.
 *)
 
 section \<open>Preliminaries\<close>
 
 theory Decreasing_Diagrams_II_Aux
 imports
   Well_Quasi_Orders.Multiset_Extension
   Well_Quasi_Orders.Well_Quasi_Orders
 begin
 
 subsection \<open>Trivialities\<close>
 
 (* move to Relation.thy? *)
 abbreviation "strict_order R \<equiv> irrefl R \<and> trans R"
 
 (* move to Relation.thy? *)
 lemma strict_order_strict: "strict_order q \<Longrightarrow> strict (\<lambda>a b. (a, b) \<in> q\<^sup>=) = (\<lambda>a b. (a, b) \<in> q)"
 unfolding trans_def irrefl_def by fast
 
 (* move to Wellfounded.thy? *)
 lemma mono_lex1: "mono (\<lambda>r. lex_prod r s)"
 by (auto simp add: mono_def)
 
 (* move to Wellfounded.thy? *)
 lemma mono_lex2: "mono (lex_prod r)"
 by (auto simp add: mono_def)
 
 lemmas converse_inward = rtrancl_converse[symmetric] converse_Un converse_UNION converse_relcomp
   converse_converse converse_Id
 
 
 subsection \<open>Complete lattices and least fixed points\<close>
 
 context complete_lattice
 begin
 
 subsubsection \<open>A chain-based induction principle\<close>
 
 abbreviation set_chain :: "'a set \<Rightarrow> bool" where
   "set_chain C \<equiv> \<forall>x \<in> C. \<forall>y \<in> C. x \<le> y \<or> y \<le> x"
  
 lemma lfp_chain_induct:
   assumes mono: "mono f"
   and step: "\<And>x. P x \<Longrightarrow> P (f x)"
   and chain: "\<And>C. set_chain C \<Longrightarrow> \<forall> x \<in> C. P x \<Longrightarrow> P (Sup C)" 
   shows "P (lfp f)"
 unfolding lfp_eq_fixp[OF mono]
 proof (rule fixp_induct)
   show "monotone (\<le>) (\<le>) f" using mono unfolding order_class.mono_def monotone_def .
 next
   show "P (Sup {})" using chain[of "{}"] by simp
 next
   show "ccpo.admissible Sup (\<le>) P"
   by (auto simp add: chain ccpo.admissible_def Complete_Partial_Order.chain_def)
 qed fact
 
 
 subsubsection \<open>Preservation of transitivity, asymmetry, irreflexivity by suprema\<close>
 
 lemma trans_Sup_of_chain:
   assumes "set_chain C" and trans: "\<And>R. R \<in> C \<Longrightarrow> trans R"
   shows "trans (Sup C)"
 proof (intro transI)
   fix x y z
   assume "(x,y) \<in> Sup C" and "(y,z) \<in> Sup C"
   from \<open>(x,y) \<in> Sup C\<close> obtain R where "R \<in> C" and "(x,y) \<in> R" by blast
   from \<open>(y,z) \<in> Sup C\<close> obtain S where "S \<in> C" and "(y,z) \<in> S" by blast
   from \<open>R \<in> C\<close> and \<open>S \<in> C\<close> and \<open>set_chain C\<close> have "R \<union> S = R \<or> R \<union> S = S" by blast
   with \<open>R \<in> C\<close> and \<open>S \<in> C\<close> have "R \<union> S \<in> C" by fastforce
   with \<open>(x,y) \<in> R\<close> and \<open>(y,z) \<in> S\<close> and trans[of "R \<union> S"]
   have "(x,z) \<in> R \<union> S" unfolding trans_def by blast
   with \<open>R \<union> S \<in> C\<close> show "(x,z) \<in> \<Union>C" by blast 
 qed
 
 lemma asym_Sup_of_chain:
   assumes "set_chain C" and asym: "\<And> R. R \<in> C \<Longrightarrow> asym R"
   shows "asym (Sup C)"
 proof (intro asymI notI)
   fix a b
   assume "(a,b) \<in> Sup C" then obtain "R" where "R \<in> C" and "(a,b) \<in> R" by blast
   assume "(b,a) \<in> Sup C" then obtain "S" where "S \<in> C" and "(b,a) \<in> S" by blast
   from \<open>R \<in> C\<close> and \<open>S \<in> C\<close> and \<open>set_chain C\<close> have "R \<union> S = R \<or> R \<union> S = S" by blast
   with \<open>R \<in> C\<close> and \<open>S \<in> C\<close> have "R \<union> S \<in> C" by fastforce
   with \<open>(a,b) \<in> R\<close> and \<open>(b,a) \<in> S\<close> and asym[THEN asymD] show "False" by blast
 qed
 
 lemma strict_order_lfp:
   assumes "mono f" and "\<And>R. strict_order R \<Longrightarrow> strict_order (f R)"
   shows "strict_order (lfp f)"
 proof (intro lfp_chain_induct[of f strict_order])
   fix C :: "('b \<times> 'b) set set"
   assume "set_chain C" and "\<forall>R \<in> C. strict_order R"
   from this show "strict_order (Sup C)"
     using asym_on_iff_irrefl_on_if_trans[of _ UNIV]
     by (metis asym_Sup_of_chain trans_Sup_of_chain)
 qed fact+
 
 lemma trans_lfp:
   assumes "mono f" and "\<And>R. trans R \<Longrightarrow> trans (f R)"
   shows "trans (lfp f)"
 by (metis lfp_chain_induct[of f trans] assms trans_Sup_of_chain)
 
 end (* complete_lattice *)
 
 
 subsection \<open>Multiset extension\<close>
 
 lemma mulex_iff_mult: "mulex r M N \<longleftrightarrow> (M,N) \<in> mult {(M,N) . r M N}"
 by (auto simp add: mulex_on_def restrict_to_def mult_def mulex1_def tranclp_unfold)
 
 lemma multI:
   assumes "trans r" "M = I + K" "N = I + J" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k,j) \<in> r"
   shows "(M,N) \<in> mult r"
 using assms one_step_implies_mult by blast
 
 lemma multE:
   assumes "trans r" and "(M,N) \<in> mult r"
   obtains I J K where "M = I + K" "N = I + J" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k,j) \<in> r"
 using mult_implies_one_step[OF assms] by blast
 
 lemma mult_on_union: "(M,N) \<in> mult r \<Longrightarrow> (K + M, K + N) \<in> mult r"
 using mulex_on_union[of "\<lambda>x y. (x,y) \<in> r" UNIV] by (auto simp: mulex_iff_mult)
 
 lemma mult_on_union': "(M,N) \<in> mult r \<Longrightarrow> (M + K, N + K) \<in> mult r"
 using mulex_on_union'[of "\<lambda>x y. (x,y) \<in> r" UNIV] by (auto simp: mulex_iff_mult)
 
 lemma mult_on_add_mset: "(M,N) \<in> mult r \<Longrightarrow> (add_mset k M, add_mset k N) \<in> mult r"
 unfolding add_mset_add_single[of k M] add_mset_add_single[of k N] by (rule mult_on_union')
 
 lemma mult_empty[simp]: "(M,{#}) \<notin> mult R"
 by (metis mult_def not_less_empty trancl.cases)
 
 lemma mult_singleton[simp]: "(x, y) \<in> r \<Longrightarrow> (add_mset x M, add_mset y M) \<in> mult r"
 unfolding add_mset_add_single[of x M] add_mset_add_single[of y M]
 apply (rule mult_on_union)
 using mult1_singleton[of x y r] by (auto simp add: mult_def mult_on_union)
 
 lemma empty_mult[simp]: "({#},N) \<in> mult R \<longleftrightarrow> N \<noteq> {#}"
 using empty_mulex_on[of N UNIV "\<lambda>M N. (M,N) \<in> R"] by (auto simp add: mulex_iff_mult)
 
 lemma trans_mult: "trans (mult R)"
 unfolding mult_def by simp
 
 lemma strict_order_mult:
   assumes "irrefl R" and "trans R"
   shows "irrefl (mult R)" and "trans (mult R)"
 proof -
   show "irrefl (mult R)" unfolding irrefl_def
   proof (intro allI notI, elim multE[OF \<open>trans R\<close>])
     fix M I J K
     assume "M = I + J" "M = I + K" "J \<noteq> {#}" and *: "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> R"
     from \<open>M = I + J\<close> and \<open>M = I + K\<close> have "J = K" by simp
     have "finite (set_mset J)" by simp
     then have "set_mset J = {}" using * unfolding \<open>J = K\<close>
       by (induct rule: finite_induct)
          (simp, metis assms insert_absorb insert_iff insert_not_empty irrefl_def transD)
     then show "False" using \<open>J \<noteq> {#}\<close> by simp
   qed
 qed (simp add: trans_mult)
 
 lemma mult_of_image_mset:
   assumes "trans R" and "trans R'"
   and "\<And>x y. x \<in> set_mset N \<Longrightarrow> y \<in> set_mset M \<Longrightarrow> (x,y) \<in> R \<Longrightarrow> (f x, f y) \<in> R'"
   and "(N, M) \<in> mult R"
   shows "(image_mset f N, image_mset f M) \<in> mult R'"
 proof (insert assms(4), elim multE[OF assms(1)])
   fix I J K
   assume "N = I + K" "M = I + J" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> R"
   thus "(image_mset f N, image_mset f M) \<in> mult R'" using assms(2,3)
     by (intro multI) (auto, blast)
 qed
 
 
 subsection \<open>Incrementality of @{term mult1} and @{term mult}\<close>
 
 lemma mono_mult1: "mono mult1"
 unfolding mono_def mult1_def by blast
 
 lemma mono_mult: "mono mult"
 unfolding mono_def mult_def
 proof (intro allI impI subsetI)
   fix R S :: "'a rel" and x
   assume "R \<subseteq> S" and "x \<in> (mult1 R)\<^sup>+"
   then show "x \<in> (mult1 S)\<^sup>+"
   using mono_mult1[unfolded mono_def] trancl_mono[of x "mult1 R" "mult1 S"] by auto
 qed
 
 
 subsection \<open>Well-orders and well-quasi-orders\<close>
 
 lemma wf_iff_wfp_on:
   "wf p \<longleftrightarrow> wfp_on (\<lambda>a b. (a, b) \<in> p) UNIV"
 unfolding wfp_on_iff_inductive_on wf_def inductive_on_def by force
 
 lemma well_order_implies_wqo:
   assumes "well_order r"
   shows "wqo_on (\<lambda>a b. (a, b) \<in> r) UNIV"
 proof (intro wqo_onI almost_full_onI)
-  show "transp_on (\<lambda>a b. (a, b) \<in> r) UNIV" using assms
+  show "transp (\<lambda>a b. (a, b) \<in> r)" using assms
   by (auto simp only: well_order_on_def linear_order_on_def partial_order_on_def preorder_on_def
-    trans_def transp_on_def)
+    trans_def transp_def)
 next
   fix f :: "nat \<Rightarrow> 'a"
   show "good (\<lambda>a b. (a, b) \<in> r) f"
   using assms unfolding well_order_on_def wf_iff_wfp_on wfp_on_def not_ex not_all de_Morgan_conj
   proof (elim conjE allE exE)
     fix x assume "linear_order r" and "f x \<notin> UNIV \<or> (f (Suc x), f x) \<notin> r - Id"
     then have "(f x, f (Suc x)) \<in> r" using \<open>linear_order r\<close>
     by (force simp: linear_order_on_def Relation.total_on_def partial_order_on_def preorder_on_def
       refl_on_def)
     then show "good (\<lambda>a b. (a, b) \<in> r) f" by (auto simp: good_def)
   qed
 qed
 
 
 subsection \<open>Splitting lists into prefix, element, and suffix\<close>
 
 fun list_splits :: "'a list \<Rightarrow> ('a list \<times> 'a \<times> 'a list) list" where
   "list_splits [] = []"
 | "list_splits (x # xs) = ([], x, xs) # map (\<lambda>(xs, x', xs'). (x # xs, x', xs')) (list_splits xs)"
 
 lemma list_splits_empty[simp]:
   "list_splits xs = [] \<longleftrightarrow> xs = []"
 by (cases xs) simp_all
 
 lemma elem_list_splits_append:
   assumes "(ys, y, zs) \<in> set (list_splits xs)"
   shows "ys @ [y] @ zs = xs"
 using assms by (induct xs arbitrary: ys) auto
 
 lemma elem_list_splits_length:
   assumes "(ys, y, zs) \<in> set (list_splits xs)"
   shows "length ys < length xs" and "length zs < length xs"
 using elem_list_splits_append[OF assms] by auto
 
 lemma elem_list_splits_elem:
   assumes "(xs, y, ys) \<in> set (list_splits zs)"
   shows "y \<in> set zs"
 using elem_list_splits_append[OF assms] by force
 
 lemma list_splits_append:
   "list_splits (xs @ ys) = map (\<lambda>(xs', x', ys'). (xs', x', ys' @ ys)) (list_splits xs) @
                            map (\<lambda>(xs', x', ys'). (xs @ xs', x', ys')) (list_splits ys)"
 by (induct xs) auto
 
 lemma list_splits_rev:
   "list_splits (rev xs) = map (\<lambda>(xs, x, ys). (rev ys, x, rev xs)) (rev (list_splits xs))"
 by (induct xs) (auto simp add: list_splits_append comp_def prod.case_distrib rev_map)
 
 lemma list_splits_map:
   "list_splits (map f xs) = map (\<lambda>(xs, x, ys). (map f xs, f x, map f ys)) (list_splits xs)"
 by (induct xs) auto
 
 end (* Decreasing_Diagrams_II_Aux *)
diff --git a/thys/Groebner_Macaulay/Monomial_Module.thy b/thys/Groebner_Macaulay/Monomial_Module.thy
--- a/thys/Groebner_Macaulay/Monomial_Module.thy
+++ b/thys/Groebner_Macaulay/Monomial_Module.thy
@@ -1,553 +1,553 @@
 section \<open>Monomial Modules\<close>
 
 theory Monomial_Module
   imports Groebner_Bases.Reduced_GB
 begin
 
 text \<open>Properties of modules generated by sets of monomials, and (reduced) Gr\"obner bases thereof.\<close>
 
 subsection \<open>Sets of Monomials\<close>
 
 definition is_monomial_set :: "('a \<Rightarrow>\<^sub>0 'b::zero) set \<Rightarrow> bool"
   where "is_monomial_set A \<longleftrightarrow> (\<forall>p\<in>A. is_monomial p)"
 
 lemma is_monomial_setI: "(\<And>p. p \<in> A \<Longrightarrow> is_monomial p) \<Longrightarrow> is_monomial_set A"
   by (simp add: is_monomial_set_def)
 
 lemma is_monomial_setD: "is_monomial_set A \<Longrightarrow> p \<in> A \<Longrightarrow> is_monomial p"
   by (simp add: is_monomial_set_def)
 
 lemma is_monomial_set_subset: "is_monomial_set B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> is_monomial_set A"
   by (auto simp: is_monomial_set_def)
 
 lemma is_monomial_set_Un: "is_monomial_set (A \<union> B) \<longleftrightarrow> (is_monomial_set A \<and> is_monomial_set B)"
   by (auto simp: is_monomial_set_def)
 
 subsection \<open>Modules\<close>
 
 context term_powerprod
 begin
 
 lemma monomial_pmdl:
   assumes "is_monomial_set B" and "p \<in> pmdl B"
   shows "monomial (lookup p v) v \<in> pmdl B"
   using assms(2)
 proof (induct p rule: pmdl_induct)
   case base: module_0
   show ?case by (simp add: pmdl.span_zero)
 next
   case step: (module_plus p b c t)
   have eq: "monomial (lookup (p + monom_mult c t b) v) v =
             monomial (lookup p v) v + monomial (lookup (monom_mult c t b) v) v"
     by (simp only: single_add lookup_add)
   from assms(1) step.hyps(3) have "is_monomial b" by (rule is_monomial_setD)
   then obtain d u where b: "b = monomial d u" by (rule is_monomial_monomial)
   have "monomial (lookup (monom_mult c t b) v) v \<in> pmdl B"
   proof (simp add: b monom_mult_monomial lookup_single when_def pmdl.span_zero, intro impI)
     assume "t \<oplus> u = v"
     hence "monomial (c * d) v = monom_mult c t b" by (simp add: b monom_mult_monomial)
     also from step.hyps(3) have "\<dots> \<in> pmdl B" by (rule monom_mult_in_pmdl)
     finally show "monomial (c * d) v \<in> pmdl B" .
   qed
   with step.hyps(2) show ?case unfolding eq by (rule pmdl.span_add)
 qed
 
 lemma monomial_pmdl_field:
   assumes "is_monomial_set B" and "p \<in> pmdl B" and "v \<in> keys (p::_ \<Rightarrow>\<^sub>0 'b::field)"
   shows "monomial c v \<in> pmdl B"
 proof -
   from assms(1, 2) have "monomial (lookup p v) v \<in> pmdl B" by (rule monomial_pmdl)
   hence "monom_mult (c / lookup p v) 0 (monomial (lookup p v) v) \<in> pmdl B"
     by (rule pmdl_closed_monom_mult)
   with assms(3) show ?thesis by (simp add: monom_mult_monomial splus_zero in_keys_iff)
 qed
 
 end (* term_powerprod *)
 
 context ordered_term
 begin
 
 lemma keys_monomial_pmdl:
   assumes "is_monomial_set F" and "p \<in> pmdl F" and "t \<in> keys p"
   obtains f where "f \<in> F" and "f \<noteq> 0" and "lt f adds\<^sub>t t"
   using assms(2) assms(3)
 proof (induct arbitrary: thesis rule: pmdl_induct)
   case module_0
   from this(2) show ?case by simp
 next
   case step: (module_plus p f0 c s)
   from assms(1) step(3) have "is_monomial f0" unfolding is_monomial_set_def ..
   hence "keys f0 = {lt f0}" and "f0 \<noteq> 0" by (rule keys_monomial, rule monomial_not_0)
   from Poly_Mapping.keys_add step(6) have "t \<in> keys p \<union> keys (monom_mult c s f0)" ..
   thus ?case
   proof
     assume "t \<in> keys p"
     from step(2)[OF _ this] obtain f where "f \<in> F" and "f \<noteq> 0" and "lt f adds\<^sub>t t" by blast
     thus ?thesis by (rule step(5))
   next
     assume "t \<in> keys (monom_mult c s f0)"
     with keys_monom_mult_subset have "t \<in> (\<oplus>) s ` keys f0" ..
     hence "t = s \<oplus> lt f0" by (simp add: \<open>keys f0 = {lt f0}\<close>)
     hence "lt f0 adds\<^sub>t t" by (simp add: term_simps)
     with \<open>f0 \<in> F\<close> \<open>f0 \<noteq> 0\<close> show ?thesis by (rule step(5))
   qed
 qed
 
 lemma image_lt_monomial_lt: "lt ` monomial (1::'b::zero_neq_one) ` lt ` F = lt ` F"
   by (auto simp: lt_monomial intro!: image_eqI)
 
 subsection \<open>Reduction\<close>
 
 lemma red_setE2:
   assumes "red B p q"
   obtains b where "b \<in> B" and "b \<noteq> 0" and "red {b} p q"
 proof -
   from assms obtain b t where "b \<in> B" and "red_single p q b t" by (rule red_setE)
   from this(2) have "b \<noteq> 0" by (simp add: red_single_def)
   have "red {b} p q" by (rule red_setI, simp, fact)
   show ?thesis by (rule, fact+)
 qed
 
 lemma red_monomial_keys:
   assumes "is_monomial r" and "red {r} p q"
   shows "card (keys p) = Suc (card (keys q))"
 proof -
   from assms(2) obtain s where rs: "red_single p q r s" unfolding red_singleton ..
   hence cp0: "lookup p (s \<oplus> lt r) \<noteq> 0" and q_def0: "q = p - monom_mult (lookup p (s \<oplus> lt r) / lc r) s r"
     unfolding red_single_def by simp_all
   from assms(1) obtain c t where "c \<noteq> 0" and r_def: "r = monomial c t" by (rule is_monomial_monomial)
   have ltr: "lt r = t" unfolding r_def by (rule lt_monomial, fact)
   have lcr: "lc r = c" unfolding r_def by (rule lc_monomial)
   define u where "u = s \<oplus> t"
   from q_def0 have "q = p - monom_mult (lookup p u / c) s r" unfolding u_def ltr lcr .
   also have "... = p - monomial ((lookup p u / c) * c) u" unfolding u_def r_def monom_mult_monomial ..
   finally have q_def: "q = p - monomial (lookup p u) u" using \<open>c \<noteq> 0\<close> by simp
   from cp0 have "lookup p u \<noteq> 0" unfolding u_def ltr .
   hence "u \<in> keys p" by (simp add: in_keys_iff)
       
   have "keys q = keys p - {u}" unfolding q_def
   proof (rule, rule)
     fix x
     assume "x \<in> keys (p - monomial (lookup p u) u)"
     hence "lookup (p - monomial (lookup p u) u) x \<noteq> 0" by (simp add: in_keys_iff)
     hence a: "lookup p x - lookup (monomial (lookup p u) u) x \<noteq> 0" unfolding lookup_minus .
     hence "x \<noteq> u" unfolding lookup_single by auto
     with a have "lookup p x \<noteq> 0" unfolding lookup_single by auto
     show "x \<in> keys p - {u}"
     proof
       from \<open>lookup p x \<noteq> 0\<close> show "x \<in> keys p" by (simp add: in_keys_iff)
     next
       from \<open>x \<noteq> u\<close> show "x \<notin> {u}" by simp
     qed
   next
     show "keys p - {u} \<subseteq> keys (p - monomial (lookup p u) u)"
     proof
       fix x
       assume "x \<in> keys p - {u}"
       hence "x \<in> keys p" and "x \<noteq> u" by auto
       from \<open>x \<in> keys p\<close> have "lookup p x \<noteq> 0" by (simp add: in_keys_iff)
       with \<open>x \<noteq> u\<close> have "lookup (p - monomial (lookup p u) u) x \<noteq> 0" by (simp add: lookup_minus lookup_single)
       thus "x \<in> keys (p - monomial (lookup p u) u)" by (simp add: in_keys_iff)
     qed
   qed
       
   have "Suc (card (keys q)) = card (keys p)" unfolding \<open>keys q = keys p - {u}\<close>
     by (rule card_Suc_Diff1, rule finite_keys, fact)
   thus ?thesis by simp
 qed
 
 lemma red_monomial_monomial_setD:
   assumes "is_monomial p" and "is_monomial_set B" and "red B p q"
   shows "q = 0"
 proof -
   from assms(3) obtain b where "b \<in> B" and "b \<noteq> 0" and *: "red {b} p q" by (rule red_setE2)
   from assms(2) this(1) have "is_monomial b" by (rule is_monomial_setD)
   hence "card (keys p) = Suc (card (keys q))" using * by (rule red_monomial_keys)
   with assms(1) show ?thesis by (simp add: is_monomial_def)
 qed
 
 corollary is_red_monomial_monomial_setD:
   assumes "is_monomial p" and "is_monomial_set B" and "is_red B p"
   shows "red B p 0"
 proof -
   from assms(3) obtain q where "red B p q" by (rule is_redE)
   moreover from assms(1, 2) this have "q = 0" by (rule red_monomial_monomial_setD)
   ultimately show ?thesis by simp
 qed
 
 corollary is_red_monomial_monomial_set_in_pmdl:
   "is_monomial p \<Longrightarrow> is_monomial_set B \<Longrightarrow> is_red B p \<Longrightarrow> p \<in> pmdl B"
   by (intro red_rtranclp_0_in_pmdl r_into_rtranclp is_red_monomial_monomial_setD)
 
 corollary red_rtrancl_monomial_monomial_set_cases:
   assumes "is_monomial p" and "is_monomial_set B" and "(red B)\<^sup>*\<^sup>* p q"
   obtains "q = p" | "q = 0"
   using assms(3)
 proof (induct q arbitrary: thesis rule: rtranclp_induct)
   case base
   from refl show ?case by (rule base)
 next
   case (step y z)
   show ?case
   proof (rule step.hyps)
     assume "y = p"
     with step.hyps(2) have "red B p z" by simp
     with assms(1, 2) have "z = 0" by (rule red_monomial_monomial_setD)
     thus ?thesis by (rule step.prems)
   next
     assume "y = 0"
     from step.hyps(2) have "is_red B 0" unfolding \<open>y = 0\<close> by (rule is_redI)
     with irred_0 show ?thesis ..
   qed
 qed
 
 lemma is_red_monomial_lt:
   assumes "0 \<notin> B"
   shows "is_red (monomial (1::'b::field) ` lt ` B) = is_red B"
 proof
   fix p
   let ?B = "monomial (1::'b) ` lt ` B"
   show "is_red ?B p \<longleftrightarrow> is_red B p"
   proof
     assume "is_red ?B p"
     then obtain f v where "f \<in> ?B" and "v \<in> keys p" and adds: "lt f adds\<^sub>t v" by (rule is_red_addsE)
     from this(1) have "lt f \<in> lt ` ?B" by (rule imageI)
     also have "\<dots> = lt ` B" by (fact image_lt_monomial_lt)
     finally obtain b where "b \<in> B" and eq: "lt f = lt b" ..
     note this(1)
     moreover from this assms have "b \<noteq> 0" by blast
     moreover note \<open>v \<in> keys p\<close>
     moreover from adds have "lt b adds\<^sub>t v" by (simp only: eq)
     ultimately show "is_red B p" by (rule is_red_addsI)
   next
     assume "is_red B p"
     then obtain b v where "b \<in> B" and "v \<in> keys p" and adds: "lt b adds\<^sub>t v" by (rule is_red_addsE)
     from this(1) have "lt b \<in> lt ` B" by (rule imageI)
     also from image_lt_monomial_lt have "\<dots> = lt ` ?B" by (rule sym)
     finally obtain f where "f \<in> ?B" and eq: "lt b = lt f" ..
     note this(1)
     moreover from this have "f \<noteq> 0" by (auto simp: monomial_0_iff)
     moreover note \<open>v \<in> keys p\<close>
     moreover from adds have "lt f adds\<^sub>t v" by (simp only: eq)
     ultimately show "is_red ?B p" by (rule is_red_addsI)
   qed
 qed
 
 end (* ordered_term *)
 
 subsection \<open>Gr\"obner Bases\<close>
 
 context gd_term
 begin
 
 lemma monomial_set_is_GB:
   assumes "is_monomial_set G"
   shows "is_Groebner_basis G"
   unfolding GB_alt_1
 proof
   fix f
   assume "f \<in> pmdl G"
   thus "(red G)\<^sup>*\<^sup>* f 0"
   proof (induct f rule: poly_mapping_plus_induct)
     case 1
     show ?case ..
   next
     case (2 f c t)
     let ?f = "monomial c t + f"
     from 2(1) have "t \<in> keys (monomial c t)" by simp
     from this 2(2) have "t \<in> keys ?f" by (rule in_keys_plusI1)
     with assms \<open>?f \<in> pmdl G\<close> obtain g where "g \<in> G" and "g \<noteq> 0" and "lt g adds\<^sub>t t"
       by (rule keys_monomial_pmdl)
     from this(1) have "red G ?f f"
     proof (rule red_setI)
       from \<open>lt g adds\<^sub>t t\<close> have "component_of_term (lt g) = component_of_term t" and "lp g adds pp_of_term t"
         by (simp_all add: adds_term_def)
       from this have eq: "(pp_of_term t - lp g) \<oplus> lt g = t"
         by (simp add: adds_minus splus_def term_of_pair_pair)
       moreover from 2(2) have "lookup ?f t = c" by (simp add: lookup_add in_keys_iff)
       ultimately show "red_single (monomial c t + f) f g (pp_of_term t - lp g)"
       proof (simp add: red_single_def \<open>g \<noteq> 0\<close> \<open>t \<in> keys ?f\<close> 2(1))
         from \<open>g \<noteq> 0\<close> have "lc g \<noteq> 0" by (rule lc_not_0)
         hence "monomial c t = monom_mult (c / lc g) (pp_of_term t - lp g) (monomial (lc g) (lt g))"
           by (simp add: monom_mult_monomial eq)
         moreover from assms \<open>g \<in> G\<close> have "is_monomial g" unfolding is_monomial_set_def ..
         ultimately show "monomial c t = monom_mult (c / lc g) (pp_of_term t - lp g) g"
           by (simp only: monomial_eq_itself)
       qed
     qed
     have "f \<in> pmdl G" by (rule pmdl_closed_red, fact subset_refl, fact+)
     hence "(red G)\<^sup>*\<^sup>* f 0" by (rule 2(3))
     with \<open>red G ?f f\<close> show ?case by simp
   qed
 qed
 
 context
   fixes d
   assumes dgrad: "dickson_grading (d::'a \<Rightarrow> nat)"
 begin
 
 context
   fixes F m
   assumes fin_comps: "finite (component_of_term ` Keys F)"
     and F_sub: "F \<subseteq> dgrad_p_set d m"
     and F_monom: "is_monomial_set (F::(_ \<Rightarrow>\<^sub>0 'b::field) set)"
 begin
 
 text \<open>The proof of the following lemma could be simplified, analogous to homogeneous ideals.\<close>
 
 lemma reduced_GB_subset_monic_dgrad_p_set: "reduced_GB F \<subseteq> monic ` F"
 proof -
   from subset_refl obtain F' where "F' \<subseteq> F - {0}" and "lt ` (F - {0}) = lt ` F'" and "inj_on lt F'"
     by (rule subset_imageE_inj)
   define G where "G = {f \<in> F'. \<forall>f'\<in>F'. lt f' adds\<^sub>t lt f \<longrightarrow> f' = f}"
   have "G \<subseteq> F'" by (simp add: G_def)
   hence "G \<subseteq> F - {0}" using \<open>F' \<subseteq> F - {0}\<close> by (rule subset_trans)
   also have "\<dots> \<subseteq> F" by blast
   finally have "G \<subseteq> F" .
   have 1: thesis if "f \<in> F" and "f \<noteq> 0" and "\<And>g. g \<in> G \<Longrightarrow> lt g adds\<^sub>t lt f \<Longrightarrow> thesis" for thesis f
   proof -
     let ?K = "component_of_term ` Keys F"
     let ?A = "{t. pp_of_term t \<in> dgrad_set d m \<and> component_of_term t \<in> ?K}"
     let ?Q = "{f' \<in> F'. lt f' adds\<^sub>t lt f}"
     from dgrad fin_comps have "almost_full_on (adds\<^sub>t) ?A" by (rule Dickson_term)
-    moreover have "transp_on (adds\<^sub>t) ?A" by (auto intro: transp_onI dest: adds_term_trans)
+    moreover have "transp_on ?A (adds\<^sub>t)" by (auto intro: transp_onI dest: adds_term_trans)
     ultimately have "wfp_on (strict (adds\<^sub>t)) ?A" by (rule af_trans_imp_wf)
     moreover have "lt f \<in> lt ` ?Q"
     proof -
       from that(1, 2) have "f \<in> F - {0}" by simp
       hence "lt f \<in> lt ` (F - {0})" by (rule imageI)
       also have "\<dots> = lt ` F'" by fact
       finally have "lt f \<in> lt ` F'" .
       with adds_term_refl show ?thesis by fastforce
     qed
     moreover have "lt ` ?Q \<subseteq> ?A"
     proof
       fix s
       assume "s \<in> lt ` ?Q"
       then obtain q where "q \<in> ?Q" and s: "s = lt q" ..
       from this(1) have "q \<in> F'" by simp
       hence "q \<in> F - {0}" using \<open>F' \<subseteq> F - {0}\<close> ..
       hence "q \<in> F" and "q \<noteq> 0" by simp_all
       from this(1) F_sub have "q \<in> dgrad_p_set d m" ..
       from \<open>q \<noteq> 0\<close> have "lt q \<in> keys q" by (rule lt_in_keys)
       hence "pp_of_term (lt q) \<in> pp_of_term ` keys q" by (rule imageI)
       also from \<open>q \<in> dgrad_p_set d m\<close> have "\<dots> \<subseteq> dgrad_set d m" by (simp add: dgrad_p_set_def)
       finally have 1: "pp_of_term s \<in> dgrad_set d m" by (simp only: s)
       from \<open>lt q \<in> keys q\<close> \<open>q \<in> F\<close> have "lt q \<in> Keys F" by (rule in_KeysI)
       hence "component_of_term s \<in> ?K" unfolding s by (rule imageI)
       with 1 show "s \<in> ?A" by simp
     qed
     ultimately obtain t where "t \<in> lt ` ?Q" and t_min: "\<And>s. strict (adds\<^sub>t) s t \<Longrightarrow> s \<notin> lt ` ?Q"
       by (rule wfp_onE_min) blast
     from this(1) obtain g where "g \<in> ?Q" and t: "t = lt g" ..
     from this(1) have "g \<in> F'" and adds: "lt g adds\<^sub>t lt f" by simp_all
     show ?thesis
     proof (rule that)
       {
         fix f'
         assume "f' \<in> F'"
         assume "lt f' adds\<^sub>t lt g"
         hence "lt f' adds\<^sub>t lt f" using adds by (rule adds_term_trans)
         with \<open>f' \<in> F'\<close> have "f' \<in> ?Q" by simp
         hence "lt f' \<in> lt ` ?Q" by (rule imageI)
         with t_min have "\<not> strict (adds\<^sub>t) (lt f') (lt g)" unfolding t by blast
         with \<open>lt f' adds\<^sub>t lt g\<close> have "lt g adds\<^sub>t lt f'" by blast
         with \<open>lt f' adds\<^sub>t lt g\<close> have "lt f' = lt g" by (rule adds_term_antisym)
         with \<open>inj_on lt F'\<close> have "f' = g" using \<open>f' \<in> F'\<close> \<open>g \<in> F'\<close> by (rule inj_onD)
       }
       with \<open>g \<in> F'\<close> show "g \<in> G" by (simp add: G_def)
     qed fact
   qed
   have 2: "is_red G q" if "q \<in> pmdl F" and "q \<noteq> 0" for q
   proof -
     from that(2) have "keys q \<noteq> {}" by simp
     then obtain t where "t \<in> keys q" by blast
     with F_monom that(1) obtain f where "f \<in> F" and "f \<noteq> 0" and *: "lt f adds\<^sub>t t"
       by (rule keys_monomial_pmdl)
     from this(1, 2) obtain g where "g \<in> G" and "lt g adds\<^sub>t lt f" by (rule 1)
     from this(2) have **: "lt g adds\<^sub>t t" using * by (rule adds_term_trans)
     from \<open>g \<in> G\<close> \<open>G \<subseteq> F - {0}\<close> have "g \<in> F - {0}" ..
     hence "g \<noteq> 0" by simp
     with \<open>g \<in> G\<close> show ?thesis using \<open>t \<in> keys q\<close> ** by (rule is_red_addsI)
   qed
   from \<open>G \<subseteq> F - {0}\<close> have "G \<subseteq> F" by blast
   hence "pmdl G \<subseteq> pmdl F" by (rule pmdl.span_mono)
   note dgrad fin_comps F_sub
   moreover have "is_reduced_GB (monic ` G)" unfolding is_reduced_GB_def GB_image_monic
   proof (intro conjI image_monic_is_auto_reduced image_monic_is_monic_set)
     from dgrad show "is_Groebner_basis G"
     proof (rule isGB_I_is_red)
       from \<open>G \<subseteq> F\<close> F_sub show "G \<subseteq> dgrad_p_set d m" by (rule subset_trans)
     next
       fix f
       assume "f \<in> pmdl G"
       hence "f \<in> pmdl F" using \<open>pmdl G \<subseteq> pmdl F\<close> ..
       moreover assume "f \<noteq> 0"
       ultimately show "is_red G f" by (rule 2)
     qed
   next
     show "is_auto_reduced G" unfolding is_auto_reduced_def
     proof (intro ballI notI)
       fix g
       assume "g \<in> G"
       hence "g \<in> F" using \<open>G \<subseteq> F\<close> ..
       with F_monom have "is_monomial g" by (rule is_monomial_setD)
       hence keys_g: "keys g = {lt g}" by (rule keys_monomial)
       assume "is_red (G - {g}) g"
       then obtain g' t where "g' \<in> G - {g}" and "t \<in> keys g" and adds: "lt g' adds\<^sub>t t" by (rule is_red_addsE)
       from this(1) have "g' \<in> F'" and "g' \<noteq> g" by (simp_all add: G_def)
       from \<open>t \<in> keys g\<close> have "t = lt g" by (simp add: keys_g)
       with \<open>g \<in> G\<close> \<open>g' \<in> F'\<close> adds have "g' = g" by (simp add: G_def)
       with \<open>g' \<noteq> g\<close> show False ..
     qed
   next
     show "0 \<notin> monic ` G"
     proof
       assume "0 \<in> monic ` G"
       then obtain g where "0 = monic g" and "g \<in> G" ..
       moreover from this(2) \<open>G \<subseteq> F - {0}\<close> have "g \<noteq> 0" by blast
       ultimately show False by (simp add: monic_0_iff)
     qed
   qed
   moreover have "pmdl (monic ` G) = pmdl F" unfolding pmdl_image_monic
   proof
     show "pmdl F \<subseteq> pmdl G"
     proof (rule pmdl.span_subset_spanI, rule)
       fix f
       assume "f \<in> F"
       hence "f \<in> pmdl F" by (rule pmdl.span_base)
       note dgrad
       moreover from \<open>G \<subseteq> F\<close> F_sub have "G \<subseteq> dgrad_p_set d m" by (rule subset_trans)
       moreover note \<open>pmdl G \<subseteq> pmdl F\<close> 2 \<open>f \<in> pmdl F\<close>
       moreover from \<open>f \<in> F\<close> F_sub have "f \<in> dgrad_p_set d m" ..
       ultimately have "(red G)\<^sup>*\<^sup>* f 0" by (rule is_red_implies_0_red_dgrad_p_set)
       thus "f \<in> pmdl G" by (rule red_rtranclp_0_in_pmdl)
     qed
   qed fact
   ultimately have "reduced_GB F = monic ` G" by (rule reduced_GB_unique_dgrad_p_set)
   also from \<open>G \<subseteq> F\<close> have "\<dots> \<subseteq> monic ` F" by (rule image_mono)
   finally show ?thesis .
 qed
 
 corollary reduced_GB_is_monomial_set_dgrad_p_set: "is_monomial_set (reduced_GB F)"
 proof (rule is_monomial_setI)
   fix g
   assume "g \<in> reduced_GB F"
   also have "\<dots> \<subseteq> monic ` F" by (fact reduced_GB_subset_monic_dgrad_p_set)
   finally obtain f where "f \<in> F" and g: "g = monic f" ..
   from F_monom this(1) have "is_monomial f" by (rule is_monomial_setD)
   hence "card (keys f) = 1" by (simp only: is_monomial_def)
   hence "f \<noteq> 0" by auto
   hence "lc f \<noteq> 0" by (rule lc_not_0)
   hence "1 / lc f \<noteq> 0" by simp
   hence "keys g = (\<oplus>) 0 ` keys f" by (simp add: keys_monom_mult monic_def g)
   also from refl have "\<dots> = (\<lambda>x. x) ` keys f" by (rule image_cong) (simp only: splus_zero)
   finally show "is_monomial g" using \<open>card (keys f) = 1\<close> by (simp only: is_monomial_def image_ident)
 qed
 
 end
 
 lemma is_red_reduced_GB_monomial_dgrad_set:
   assumes "finite (component_of_term ` S)" and "pp_of_term ` S \<subseteq> dgrad_set d m"
   shows "is_red (reduced_GB (monomial 1 ` S)) = is_red (monomial (1::'b::field) ` S)"
 proof
   fix p
   let ?F = "monomial (1::'b) ` S"
   from assms(1) have 1: "finite (component_of_term ` Keys ?F)" by (simp add: Keys_def)
   moreover from assms(2) have 2: "?F \<subseteq> dgrad_p_set d m" by (auto simp: dgrad_p_set_def)
   moreover have "is_monomial_set ?F" by (auto intro!: is_monomial_setI monomial_is_monomial)
   ultimately have "reduced_GB ?F \<subseteq> monic ` ?F" by (rule reduced_GB_subset_monic_dgrad_p_set)
   also have "\<dots> = ?F" by (auto simp: monic_def intro!: image_eqI)
   finally have 3: "reduced_GB ?F \<subseteq> ?F" .
   show "is_red (reduced_GB ?F) p \<longleftrightarrow> is_red ?F p"
   proof
     assume "is_red (reduced_GB ?F) p"
     thus "is_red ?F p" using 3 by (rule is_red_subset)
   next
     assume "is_red ?F p"
     then obtain f v where "f \<in> ?F" and "v \<in> keys p" and "f \<noteq> 0" and adds1: "lt f adds\<^sub>t v"
       by (rule is_red_addsE)
     from this(1) have "f \<in> pmdl ?F" by (rule pmdl.span_base)
     from dgrad 1 2 have "is_Groebner_basis (reduced_GB ?F)" by (rule reduced_GB_is_GB_dgrad_p_set)
     moreover from \<open>f \<in> pmdl ?F\<close> dgrad 1 2 have "f \<in> pmdl (reduced_GB ?F)"
       by (simp only: reduced_GB_pmdl_dgrad_p_set)
     ultimately obtain g where "g \<in> reduced_GB ?F" and "g \<noteq> 0" and "lt g adds\<^sub>t lt f"
       using \<open>f \<noteq> 0\<close> by (rule GB_adds_lt)
     from this(3) adds1 have "lt g adds\<^sub>t v" by (rule adds_term_trans)
     with \<open>g \<in> reduced_GB ?F\<close> \<open>g \<noteq> 0\<close> \<open>v \<in> keys p\<close> show "is_red (reduced_GB ?F) p"
       by (rule is_red_addsI)
   qed
 qed
 
 corollary is_red_reduced_GB_monomial_lt_GB_dgrad_p_set:
   assumes "finite (component_of_term ` Keys G)" and "G \<subseteq> dgrad_p_set d m" and "0 \<notin> G"
   shows "is_red (reduced_GB (monomial (1::'b::field) ` lt ` G)) = is_red G"
 proof -
   let ?S = "lt ` G"
   let ?G = "monomial (1::'b) ` ?S"
   from assms(3) have "?S \<subseteq> Keys G" by (auto intro: lt_in_keys in_KeysI)
   hence "component_of_term ` ?S \<subseteq> component_of_term ` Keys G"
     and *: "pp_of_term ` ?S \<subseteq> pp_of_term ` Keys G" by (rule image_mono)+
   from this(1) have "finite (component_of_term ` ?S)" using assms(1) by (rule finite_subset)
   moreover from * have "pp_of_term ` ?S \<subseteq> dgrad_set d m"
   proof (rule subset_trans)
     from assms(2) show "pp_of_term ` Keys G \<subseteq> dgrad_set d m" by (auto simp: dgrad_p_set_def Keys_def)
   qed
   ultimately have "is_red (reduced_GB ?G) = is_red ?G" by (rule is_red_reduced_GB_monomial_dgrad_set)
   also from assms(3) have "\<dots> = is_red G" by (rule is_red_monomial_lt)
   finally show ?thesis .
 qed
 
 lemma reduced_GB_monomial_lt_reduced_GB_dgrad_p_set:
   assumes "finite (component_of_term ` Keys F)" and "F \<subseteq> dgrad_p_set d m"
   shows "reduced_GB (monomial 1 ` lt ` reduced_GB F) = monomial (1::'b::field) ` lt ` reduced_GB F"
 proof (rule reduced_GB_unique)
   let ?G = "reduced_GB F"
   let ?F = "monomial (1::'b) ` lt ` ?G"
 
   from dgrad assms have "0 \<notin> ?G" and ar: "is_auto_reduced ?G" and "finite ?G"
     by (rule reduced_GB_nonzero_dgrad_p_set, rule reduced_GB_is_auto_reduced_dgrad_p_set,
         rule finite_reduced_GB_dgrad_p_set)
   from this(3) show "finite ?F" by (intro finite_imageI)
 
   show "is_reduced_GB ?F" unfolding is_reduced_GB_def
   proof (intro conjI monomial_set_is_GB)
     show "is_monomial_set ?F" by (auto intro!: is_monomial_setI monomial_is_monomial)
   next
     show "is_monic_set ?F" by (simp add: is_monic_set_def)
   next
     show "0 \<notin> ?F" by (auto simp: monomial_0_iff)
   next
     show "is_auto_reduced ?F" unfolding is_auto_reduced_def
     proof (intro ballI notI)
       fix f
       assume "f \<in> ?F"
       then obtain g where "g \<in> ?G" and f: "f = monomial 1 (lt g)" by blast
       assume "is_red (?F - {f}) f"
       then obtain f' v where "f' \<in> ?F - {f}" and "v \<in> keys f" and "f' \<noteq> 0" and adds1: "lt f' adds\<^sub>t v"
         by (rule is_red_addsE)
       from this(1) have "f' \<in> ?F" and "f' \<noteq> f" by simp_all
       from this(1) obtain g' where "g' \<in> ?G" and f': "f' = monomial 1 (lt g')" by blast
       from \<open>v \<in> keys f\<close> have v: "v = lt g" by (simp add: f)
       from ar \<open>g \<in> ?G\<close> have "\<not> is_red (?G - {g}) g" by (rule is_auto_reducedD)
       moreover have "is_red (?G - {g}) g"
       proof (rule is_red_addsI)
         from \<open>g' \<in> ?G\<close> \<open>f' \<noteq> f\<close> show "g' \<in> ?G - {g}" by (auto simp: f f')
       next
         from \<open>g' \<in> ?G\<close> \<open>0 \<notin> ?G\<close> show "g' \<noteq> 0" by blast
       next
         from \<open>g \<in> ?G\<close> \<open>0 \<notin> ?G\<close> have "g \<noteq> 0" by blast
         thus "lt g \<in> keys g" by (rule lt_in_keys)
       next
         from adds1 show adds2: "lt g' adds\<^sub>t lt g" by (simp add: v f' lt_monomial)
       qed
       ultimately show False ..
     qed
   qed
 qed (fact refl)
 
 end
 
 end (* gd_term *)
 
 end (* theory *)
diff --git a/thys/Open_Induction/Open_Induction.thy b/thys/Open_Induction/Open_Induction.thy
--- a/thys/Open_Induction/Open_Induction.thy
+++ b/thys/Open_Induction/Open_Induction.thy
@@ -1,181 +1,181 @@
 (*  Title:      Open Induction
     Author:     Mizuhito Ogawa
                 Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>Open Induction\<close>
 
 theory Open_Induction
 imports Restricted_Predicates
 begin
 
 subsection \<open>(Greatest) Lower Bounds and Chains\<close>
 
 text \<open>
   A set \<open>B\<close> has the \emph{lower bound} \<open>x\<close> iff \<open>x\<close> is
   less than or equal to every element of \<open>B\<close>.
 \<close>
 definition "lb P B x \<longleftrightarrow> (\<forall>y\<in>B. P\<^sup>=\<^sup>= x y)"
 
 lemma lbI [Pure.intro]:
   "(\<And>y. y \<in> B \<Longrightarrow> P\<^sup>=\<^sup>= x y) \<Longrightarrow> lb P B x"
 by (auto simp: lb_def)
 
 text \<open>
   A set \<open>B\<close> has the \emph{greatest lower bound} \<open>x\<close> iff \<open>x\<close> is
   a lower bound of \<open>B\<close> \emph{and} less than or equal to every
   other lower bound of \<open>B\<close>.
 \<close>
 definition "glb P B x \<longleftrightarrow> lb P B x \<and> (\<forall>y. lb P B y \<longrightarrow> P\<^sup>=\<^sup>= y x)"
 
 lemma glbI [Pure.intro]:
   "lb P B x \<Longrightarrow> (\<And>y. lb P B y \<Longrightarrow> P\<^sup>=\<^sup>= y x) \<Longrightarrow> glb P B x"
 by (auto simp: glb_def)
 
 text \<open>Antisymmetric relations have unique glbs.\<close>
 lemma glb_unique:
   "antisymp_on A P \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> glb P B x \<Longrightarrow> glb P B y \<Longrightarrow> x = y"
 by (auto simp: glb_def antisymp_on_def)
 
 context pred_on
 begin
 
 lemma chain_glb:
-  assumes "transp_on (\<sqsubset>) A"
+  assumes "transp_on A (\<sqsubset>)"
   shows "chain C \<Longrightarrow> glb (\<sqsubset>) C x \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> y \<sqsubset> x \<Longrightarrow> chain ({y} \<union> C)"
 using assms [unfolded transp_on_def]
 unfolding chain_def glb_def lb_def
 by (cases "C = {}") blast+
 
 
 subsection \<open>Open Properties\<close>
 
 definition "open Q \<longleftrightarrow> (\<forall>C. chain C \<and> C \<noteq> {} \<and> (\<exists>x\<in>A. glb (\<sqsubset>) C x \<and> Q x) \<longrightarrow> (\<exists>y\<in>C. Q y))"
 
 lemma openI [Pure.intro]:
   "(\<And>C. chain C \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb (\<sqsubset>) C x \<and> Q x \<Longrightarrow> \<exists>y\<in>C. Q y) \<Longrightarrow> open Q"
 by (auto simp: open_def)
 
 lemma open_glb:
   "\<lbrakk>chain C; C \<noteq> {}; open Q; \<forall>x\<in>C. \<not> Q x; x \<in> A; glb (\<sqsubset>) C x\<rbrakk> \<Longrightarrow> \<not> Q x"
 by (auto simp: open_def)
 
 
 subsection \<open>Downward Completeness\<close>
 
 text \<open>
   A relation \<open>\<sqsubset>\<close> is \emph{downward-complete} iff
   every non-empty \<open>\<sqsubset>\<close>-chain has a greatest lower bound.
 \<close>
 definition "downward_complete \<longleftrightarrow> (\<forall>C. chain C \<and> C \<noteq> {} \<longrightarrow> (\<exists>x\<in>A. glb (\<sqsubset>) C x))"
 
 lemma downward_completeI [Pure.intro]:
   assumes "\<And>C. chain C \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb (\<sqsubset>) C x"
   shows "downward_complete"
 using assms by (auto simp: downward_complete_def)
 
 end
 
 abbreviation "open_on P Q A \<equiv> pred_on.open A P Q"
 abbreviation "dc_on P A \<equiv> pred_on.downward_complete A P"
 lemmas open_on_def = pred_on.open_def
   and dc_on_def = pred_on.downward_complete_def
 
 lemma dc_onI [Pure.intro]:
   assumes "\<And>C. chain_on P C A \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb P C x"
   shows "dc_on P A"
 using assms by (auto simp: dc_on_def)
 
 lemma open_onI [Pure.intro]:
   "(\<And>C. chain_on P C A \<Longrightarrow> C \<noteq> {} \<Longrightarrow> \<exists>x\<in>A. glb P C x \<and> Q x \<Longrightarrow> \<exists>y\<in>C. Q y) \<Longrightarrow> open_on P Q A"
 by (auto simp: open_on_def)
 
 lemma chain_on_reflclp:
   "chain_on P\<^sup>=\<^sup>= A C \<longleftrightarrow> chain_on P A C"
 by (auto simp: pred_on.chain_def)
 
 lemma lb_reflclp:
   "lb P\<^sup>=\<^sup>= B x \<longleftrightarrow> lb P B x"
 by (auto simp: lb_def)
 
 lemma glb_reflclp:
   "glb P\<^sup>=\<^sup>= B x \<longleftrightarrow> glb P B x"
 by (auto simp: glb_def lb_reflclp)
 
 lemma dc_on_reflclp:
   "dc_on P\<^sup>=\<^sup>= A \<longleftrightarrow> dc_on P A"
 by (auto simp: dc_on_def chain_on_reflclp glb_reflclp)
 
 
 subsection \<open>The Open Induction Principle\<close>
 
 lemma open_induct_on [consumes 4, case_names less]:
   assumes qo: "qo_on P A" and "dc_on P A" and "open_on P Q A"
     and "x \<in> A"
     and ind: "\<And>x. \<lbrakk>x \<in> A; \<And>y. \<lbrakk>y \<in> A; strict P y x\<rbrakk> \<Longrightarrow> Q y\<rbrakk> \<Longrightarrow> Q x"
   shows "Q x"
 proof (rule ccontr)
   assume "\<not> Q x"
   let ?B = "{x\<in>A. \<not> Q x}"
   have "?B \<subseteq> A" by blast
   interpret B: pred_on ?B P .
   from B.Hausdorff obtain M
     where chain: "B.chain M"
     and max: "\<And>C. B.chain C \<Longrightarrow> M \<subseteq> C \<Longrightarrow> M = C" by (auto simp: B.maxchain_def)
   then have "M \<subseteq> ?B" by (auto simp: B.chain_def)
   show False
   proof (cases "M = {}")
     assume "M = {}"
     moreover have "B.chain {x}" using \<open>x \<in> A\<close> and \<open>\<not> Q x\<close> by (simp add: B.chain_def)
     ultimately show False using max by blast
   next
     interpret A: pred_on A P .
     assume "M \<noteq> {}"
     have "A.chain M" using chain by (auto simp: A.chain_def B.chain_def)
     moreover with \<open>dc_on P A\<close> and \<open>M \<noteq> {}\<close> obtain m
       where "m \<in> A" and "glb P M m" by (auto simp: A.downward_complete_def)
     ultimately have "\<not> Q m" and "m \<in> ?B"
       using A.open_glb [OF _ \<open>M \<noteq> {}\<close> \<open>open_on P Q A\<close> _ _ \<open>glb P M m\<close>]
       and \<open>M \<subseteq> ?B\<close> by auto
     from ind [OF \<open>m \<in> A\<close>] and \<open>\<not> Q m\<close> obtain y
       where "y \<in> A" and "strict P y m" and "\<not> Q y" by blast
     then have "P y m" and "y \<in> ?B" by simp+
-    from transp_on_subset [OF \<open>?B \<subseteq> A\<close> qo_on_imp_transp_on [OF qo]]
-      have "transp_on P ?B" .
+    from transp_on_subset [OF qo_on_imp_transp_on [OF qo] \<open>?B \<subseteq> A\<close>]
+      have "transp_on ?B P" .
     from B.chain_glb [OF this chain \<open>glb P M m\<close> \<open>m \<in> ?B\<close> \<open>y \<in> ?B\<close> \<open>P y m\<close>]
       have "B.chain ({y} \<union> M)" .
     then show False
       using \<open>glb P M m\<close> and \<open>strict P y m\<close> by (cases "y \<in> M") (auto dest: max simp: glb_def lb_def)
   qed
 qed
 
 
 subsection \<open>Open Induction on Universal Domains\<close>
 
 text \<open>Open induction on quasi-orders (i.e., @{class preorder}).\<close>
 lemma (in preorder) dc_open_induct [consumes 2, case_names less]:
   assumes "dc_on (\<le>) UNIV"
     and "open_on (\<le>) Q UNIV"
     and "\<And>x. (\<And>y. y < x \<Longrightarrow> Q y) \<Longrightarrow> Q x"
   shows "Q x"
 proof -
   have "qo_on (\<le>) UNIV" by (auto simp: qo_on_def transp_on_def reflp_on_def dest: order_trans)
   from open_induct_on [OF this assms(1,2)]
     show "Q x" using assms(3) unfolding less_le_not_le by blast
 qed
 
 
 subsection \<open>Type Class of Downward Complete Orders\<close>
 
 class dcorder = preorder +
   assumes dc_on_UNIV: "dc_on (\<le>) UNIV"
 begin
 
 text \<open>Open induction on downward-complete orders.\<close>
 lemmas open_induct [consumes 1, case_names less] = dc_open_induct [OF dc_on_UNIV]
 
 end
 
 end
diff --git a/thys/Open_Induction/Restricted_Predicates.thy b/thys/Open_Induction/Restricted_Predicates.thy
--- a/thys/Open_Induction/Restricted_Predicates.thy
+++ b/thys/Open_Induction/Restricted_Predicates.thy
@@ -1,634 +1,611 @@
 (*  Title:      Well-Quasi-Orders
     Author:     Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>Binary Predicates Restricted to Elements of a Given Set\<close>
 
 theory Restricted_Predicates
 imports Main
 begin
 
 text \<open>
   A subset \<open>C\<close> of \<open>A\<close> is a \emph{chain} on \<open>A\<close> (w.r.t.\ \<open>P\<close>)
   iff for all pairs of elements of \<open>C\<close>, one is less than or equal
   to the other one.
 \<close>
 abbreviation "chain_on P C A \<equiv> pred_on.chain A P C"
 lemmas chain_on_def = pred_on.chain_def
 
 lemma chain_on_subset:
   "A \<subseteq> B \<Longrightarrow> chain_on P C A \<Longrightarrow> chain_on P C B"
 by (force simp: chain_on_def)
 
 lemma chain_on_imp_subset:
   "chain_on P C A \<Longrightarrow> C \<subseteq> A"
 by (simp add: chain_on_def)
 
 lemma subchain_on:
   assumes "C \<subseteq> D" and "chain_on P D A"
   shows "chain_on P C A"
 using assms by (auto simp: chain_on_def)
 
 definition restrict_to :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)" where
   "restrict_to P A = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> P x y)"
 
-definition transp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
-  "transp_on P A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. \<forall>z\<in>A. P x y \<and> P y z \<longrightarrow> P x z)"
-
 abbreviation "strict P \<equiv> \<lambda>x y. P x y \<and> \<not> (P y x)"
 
 abbreviation "incomparable P \<equiv> \<lambda>x y. \<not> P x y \<and> \<not> P y x"
 
 abbreviation "antichain_on P f A \<equiv> \<forall>(i::nat) j. f i \<in> A \<and> (i < j \<longrightarrow> incomparable P (f i) (f j))"
 
 lemma strict_reflclp_conv [simp]:
   "strict (P\<^sup>=\<^sup>=) = strict P" by auto
 
-lemma transp_onI [Pure.intro]:
-  "(\<And>x y z. \<lbrakk>x \<in> A; y \<in> A; z \<in> A; P x y; P y z\<rbrakk> \<Longrightarrow> P x z) \<Longrightarrow> transp_on P A"
-  unfolding transp_on_def by blast
-
 lemma reflp_on_reflclp_simp [simp]:
   assumes "reflp_on A P" and "a \<in> A" and "b \<in> A"
   shows "P\<^sup>=\<^sup>= a b = P a b"
   using assms by (auto simp: reflp_on_def)
 
 lemmas reflp_on_converse_simp = reflp_on_conversp
-
-lemma transp_on_converse:
-  "transp_on P A \<Longrightarrow> transp_on P\<inverse>\<inverse> A"
-  unfolding transp_on_def by blast
-
-lemma transp_on_converse_simp [simp]:
-  "transp_on P\<inverse>\<inverse> A \<longleftrightarrow> transp_on P A"
-  unfolding transp_on_def by blast
-
-lemma transp_on_reflclp:
-  "transp_on P A \<Longrightarrow> transp_on P\<^sup>=\<^sup>= A"
-  unfolding transp_on_def by blast
+lemmas irreflp_on_converse_simp = irreflp_on_converse
+lemmas transp_on_converse_simp = transp_on_conversep
 
 lemma transp_on_strict:
-  "transp_on P A \<Longrightarrow> transp_on (strict P) A"
+  "transp_on A P \<Longrightarrow> transp_on A (strict P)"
   unfolding transp_on_def by blast
 
-lemma transp_on_subset:
-  "A \<subseteq> B \<Longrightarrow> transp_on P B \<Longrightarrow> transp_on P A"
-  by (auto simp: transp_on_def)
-
 definition wfp_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
 where
   "wfp_on P A \<longleftrightarrow> \<not> (\<exists>f. \<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i))"
 
 definition inductive_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
   "inductive_on P A \<longleftrightarrow> (\<forall>Q. (\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y) \<longrightarrow> (\<forall>x\<in>A. Q x))"
 
 lemma inductive_onI [Pure.intro]:
   assumes "\<And>Q x. \<lbrakk>x \<in> A; (\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y)\<rbrakk> \<Longrightarrow>  Q x"
   shows "inductive_on P A"
   using assms unfolding inductive_on_def by metis
 
 text \<open>
   If @{term P} is well-founded on @{term A} then every non-empty subset @{term Q} of @{term A} has a
   minimal element @{term z} w.r.t. @{term P}, i.e., all elements that are @{term P}-smaller than
   @{term z} are not in @{term Q}.
 \<close>
 lemma wfp_on_imp_minimal:
   assumes "wfp_on P A"
   shows "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   then obtain Q x where *: "x \<in> Q" "Q \<subseteq> A"
     and "\<forall>z. \<exists>y. z \<in> Q \<longrightarrow> P y z \<and> y \<in> Q" by metis
   from choice [OF this(3)] obtain f
     where **: "\<forall>x\<in>Q. P (f x) x \<and> f x \<in> Q" by blast
   let ?S = "\<lambda>i. (f ^^ i) x"
   have ***: "\<forall>i. ?S i \<in> Q"
   proof
     fix i show "?S i \<in> Q" by (induct i) (auto simp: * **)
   qed
   then have "\<forall>i. ?S i \<in> A" using * by blast
   moreover have "\<forall>i. P (?S (Suc i)) (?S i)"
   proof
     fix i show "P (?S (Suc i)) (?S i)"
       by (induct i) (auto simp: * ** ***)
   qed
   ultimately have "\<forall>i. ?S i \<in> A \<and> P (?S (Suc i)) (?S i)" by blast
   with assms(1) show False
     unfolding wfp_on_def by fast
 qed
 
 lemma minimal_imp_inductive_on:
   assumes "\<forall>Q x. x \<in> Q \<and> Q \<subseteq> A \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q)"
   shows "inductive_on P A"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   then obtain Q x
     where *: "\<forall>y\<in>A. (\<forall>x\<in>A. P x y \<longrightarrow> Q x) \<longrightarrow> Q y"
     and **: "x \<in> A" "\<not> Q x"
     by (auto simp: inductive_on_def)
   let ?Q = "{x\<in>A. \<not> Q x}"
   from ** have "x \<in> ?Q" by auto
   moreover have "?Q \<subseteq> A" by auto
   ultimately obtain z where "z \<in> ?Q"
     and min: "\<forall>y. P y z \<longrightarrow> y \<notin> ?Q"
     using assms [THEN spec [of _ ?Q], THEN spec [of _ x]] by blast
   from \<open>z \<in> ?Q\<close> have "z \<in> A" and "\<not> Q z" by auto
   with * obtain y where "y \<in> A" and "P y z" and "\<not> Q y" by auto
   then have "y \<in> ?Q" by auto
   with \<open>P y z\<close> and min show False by auto
 qed
 
 lemmas wfp_on_imp_inductive_on =
   wfp_on_imp_minimal [THEN minimal_imp_inductive_on]
 
 lemma inductive_on_induct [consumes 2, case_names less, induct pred: inductive_on]:
   assumes "inductive_on P A" and "x \<in> A"
     and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
   shows "Q x"
   using assms unfolding inductive_on_def by metis
 
 lemma inductive_on_imp_wfp_on:
   assumes "inductive_on P A"
   shows "wfp_on P A"
 proof -
   let ?Q = "\<lambda>x. \<not> (\<exists>f. f 0 = x \<and> (\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)))"
   { fix x assume "x \<in> A"
     with assms have "?Q x"
     proof (induct rule: inductive_on_induct)
       fix y assume "y \<in> A" and IH: "\<And>x. x \<in> A \<Longrightarrow> P x y \<Longrightarrow> ?Q x"
       show "?Q y"
       proof (rule ccontr)
         assume "\<not> ?Q y"
         then obtain f where *: "f 0 = y"
           "\<forall>i. f i \<in> A \<and> P (f (Suc i)) (f i)" by auto
         then have "P (f (Suc 0)) (f 0)" and "f (Suc 0) \<in> A" by auto
         with IH and * have "?Q (f (Suc 0))" by auto
         with * show False by auto
       qed
     qed }
   then show ?thesis unfolding wfp_on_def by blast
 qed
 
 definition qo_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
-  "qo_on P A \<longleftrightarrow> reflp_on A P \<and> transp_on P A"
+  "qo_on P A \<longleftrightarrow> reflp_on A P \<and> transp_on A P"
 
 definition po_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
-  "po_on P A \<longleftrightarrow> (irreflp_on A P \<and> transp_on P A)"
+  "po_on P A \<longleftrightarrow> (irreflp_on A P \<and> transp_on A P)"
 
 lemma po_onI [Pure.intro]:
-  "\<lbrakk>irreflp_on A P; transp_on P A\<rbrakk> \<Longrightarrow> po_on P A"
+  "\<lbrakk>irreflp_on A P; transp_on A P\<rbrakk> \<Longrightarrow> po_on P A"
   by (auto simp: po_on_def)
 
-lemmas irreflp_on_converse_simp = irreflp_on_converse
-
 lemma po_on_converse_simp [simp]:
   "po_on P\<inverse>\<inverse> A \<longleftrightarrow> po_on P A"
   by (simp add: po_on_def)
 
 lemma po_on_imp_qo_on:
   "po_on P A \<Longrightarrow> qo_on (P\<^sup>=\<^sup>=) A"
   unfolding po_on_def qo_on_def
   by (metis reflp_on_reflclp transp_on_reflclp)
 
 lemma po_on_imp_irreflp_on:
   "po_on P A \<Longrightarrow> irreflp_on A P"
   by (auto simp: po_on_def)
 
 lemma po_on_imp_transp_on:
-  "po_on P A \<Longrightarrow> transp_on P A"
+  "po_on P A \<Longrightarrow> transp_on A P"
   by (auto simp: po_on_def)
 
 lemma po_on_subset:
   assumes "A \<subseteq> B" and "po_on P B"
   shows "po_on P A"
   using transp_on_subset and irreflp_on_subset and assms
   unfolding po_on_def by blast
 
 lemma transp_on_irreflp_on_imp_antisymp_on:
-  assumes "transp_on P A" and "irreflp_on A P"
+  assumes "transp_on A P" and "irreflp_on A P"
   shows "antisymp_on A (P\<^sup>=\<^sup>=)"
 proof (rule antisymp_onI)
   fix a b assume "a \<in> A"
     and "b \<in> A" and "P\<^sup>=\<^sup>= a b" and "P\<^sup>=\<^sup>= b a"
   show "a = b"
   proof (rule ccontr)
     assume "a \<noteq> b"
     with \<open>P\<^sup>=\<^sup>= a b\<close> and \<open>P\<^sup>=\<^sup>= b a\<close> have "P a b" and "P b a" by auto
-    with \<open>transp_on P A\<close> and \<open>a \<in> A\<close> and \<open>b \<in> A\<close> have "P a a" unfolding transp_on_def by blast
+    with \<open>transp_on A P\<close> and \<open>a \<in> A\<close> and \<open>b \<in> A\<close> have "P a a" unfolding transp_on_def by blast
     with \<open>irreflp_on A P\<close> and \<open>a \<in> A\<close> show False unfolding irreflp_on_def by blast
   qed
 qed
 
 lemma po_on_imp_antisymp_on:
   assumes "po_on P A"
   shows "antisymp_on A P"
-using transp_on_irreflp_on_imp_antisymp_on [of P A] and assms by (auto simp: po_on_def)
+using transp_on_irreflp_on_imp_antisymp_on [of A P] and assms by (auto simp: po_on_def)
 
 lemma strict_reflclp [simp]:
   assumes "x \<in> A" and "y \<in> A"
-    and "transp_on P A" and "irreflp_on A P"
+    and "transp_on A P" and "irreflp_on A P"
   shows "strict (P\<^sup>=\<^sup>=) x y = P x y"
   using assms unfolding transp_on_def irreflp_on_def
   by blast
 
 lemma qo_on_imp_reflp_on:
   "qo_on P A \<Longrightarrow> reflp_on A P"
   by (auto simp: qo_on_def)
 
 lemma qo_on_imp_transp_on:
-  "qo_on P A \<Longrightarrow> transp_on P A"
+  "qo_on P A \<Longrightarrow> transp_on A P"
   by (auto simp: qo_on_def)
 
 lemma qo_on_subset:
   "A \<subseteq> B \<Longrightarrow> qo_on P B \<Longrightarrow> qo_on P A"
   unfolding qo_on_def
   using reflp_on_subset
     and transp_on_subset by blast
 
 text \<open>
   Quasi-orders are instances of the @{class preorder} class.
 \<close>
 lemma qo_on_UNIV_conv:
   "qo_on P UNIV \<longleftrightarrow> class.preorder P (strict P)" (is "?lhs = ?rhs")
 proof
   assume "?lhs" then show "?rhs"
     unfolding qo_on_def class.preorder_def
     using qo_on_imp_reflp_on [of P UNIV]
       and qo_on_imp_transp_on [of P UNIV]
     by (auto simp: reflp_on_def) (unfold transp_on_def, blast)
 next
   assume "?rhs" then show "?lhs"
     unfolding class.preorder_def
     by (auto simp: qo_on_def reflp_on_def transp_on_def)
 qed
 
 lemma wfp_on_iff_inductive_on:
   "wfp_on P A \<longleftrightarrow> inductive_on P A"
   by (blast intro: inductive_on_imp_wfp_on wfp_on_imp_inductive_on)
 
 lemma wfp_on_iff_minimal:
   "wfp_on P A \<longleftrightarrow> (\<forall>Q x.
      x \<in> Q \<and> Q \<subseteq> A \<longrightarrow>
      (\<exists>z\<in>Q. \<forall>y. P y z \<longrightarrow> y \<notin> Q))"
   using wfp_on_imp_minimal [of P A]
     and minimal_imp_inductive_on [of A P]
     and inductive_on_imp_wfp_on [of P A]
     by blast
 
 text \<open>
   Every non-empty well-founded set @{term A} has a minimal element, i.e., an element that is not
   greater than any other element.
 \<close>
 lemma wfp_on_imp_has_min_elt:
   assumes "wfp_on P A" and "A \<noteq> {}"
   shows "\<exists>x\<in>A. \<forall>y\<in>A. \<not> P y x"
   using assms unfolding wfp_on_iff_minimal by force
 
 lemma wfp_on_induct [consumes 2, case_names less, induct pred: wfp_on]:
   assumes "wfp_on P A" and "x \<in> A"
     and "\<And>y. \<lbrakk> y \<in> A; \<And>x. \<lbrakk> x \<in> A; P x y \<rbrakk> \<Longrightarrow> Q x \<rbrakk> \<Longrightarrow> Q y"
   shows "Q x"
   using assms and inductive_on_induct [of P A x]
   unfolding wfp_on_iff_inductive_on by blast
 
 lemma wfp_on_UNIV [simp]:
   "wfp_on P UNIV \<longleftrightarrow> wfP P"
   unfolding wfp_on_iff_inductive_on inductive_on_def wfP_def wf_def by force
 
 
 subsection \<open>Measures on Sets (Instead of Full Types)\<close>
 
 definition
   inv_image_betw ::
     "('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
 where
   "inv_image_betw P f A B = (\<lambda>x y. x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y))"
 
 definition
   measure_on :: "('a \<Rightarrow> nat) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
 where
   "measure_on f A = inv_image_betw (<) f A UNIV"
 
 lemma in_inv_image_betw [simp]:
   "inv_image_betw P f A B x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x \<in> B \<and> f y \<in> B \<and> P (f x) (f y)"
   by (auto simp: inv_image_betw_def)
 
 lemma in_measure_on [simp, code_unfold]:
   "measure_on f A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> f x < f y"
   by (simp add: measure_on_def)
 
 lemma wfp_on_inv_image_betw [simp, intro!]:
   assumes "wfp_on P B"
   shows "wfp_on (inv_image_betw P f A B) A" (is "wfp_on ?P A")
 proof (rule ccontr)
   assume "\<not> ?thesis"
   then obtain g where "\<forall>i. g i \<in> A \<and> ?P (g (Suc i)) (g i)" by (auto simp: wfp_on_def)
   with assms show False by (auto simp: wfp_on_def)
 qed
 
 lemma wfp_less:
   "wfp_on (<) (UNIV :: nat set)"
   using wf_less by (auto simp: wfP_def)
 
 lemma wfp_on_measure_on [iff]:
   "wfp_on (measure_on f A) A"
   unfolding measure_on_def
   by (rule wfp_less [THEN wfp_on_inv_image_betw])
 
 lemma wfp_on_mono:
   "A \<subseteq> B \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> P x y \<Longrightarrow> Q x y) \<Longrightarrow> wfp_on Q B \<Longrightarrow> wfp_on P A"
   unfolding wfp_on_def by (metis subsetD)
 
 lemma wfp_on_subset:
   "A \<subseteq> B \<Longrightarrow> wfp_on P B \<Longrightarrow> wfp_on P A"
   using wfp_on_mono by blast
 
 lemma restrict_to_iff [iff]:
   "restrict_to P A x y \<longleftrightarrow> x \<in> A \<and> y \<in> A \<and> P x y"
   by (simp add: restrict_to_def)
 
 lemma wfp_on_restrict_to [simp]:
   "wfp_on (restrict_to P A) A = wfp_on P A"
   by (auto simp: wfp_on_def)
 
 lemma irreflp_on_strict [simp, intro]:
   "irreflp_on A (strict P)"
   by (auto simp: irreflp_on_def)
 
 lemma transp_on_map':
-  assumes "transp_on Q B"
+  assumes "transp_on B Q"
     and "g ` A \<subseteq> B"
     and "h ` A \<subseteq> B"
     and "\<And>x. x \<in> A \<Longrightarrow> Q\<^sup>=\<^sup>= (h x) (g x)"
-  shows "transp_on (\<lambda>x y. Q (g x) (h y)) A"
+  shows "transp_on A (\<lambda>x y. Q (g x) (h y))"
   using assms unfolding transp_on_def
   by auto (metis imageI subsetD)
 
 lemma transp_on_map:
-  assumes "transp_on Q B"
+  assumes "transp_on B Q"
     and "h ` A \<subseteq> B"
-  shows "transp_on (\<lambda>x y. Q (h x) (h y)) A"
-  using transp_on_map' [of Q B h A h, simplified, OF assms] by blast
+  shows "transp_on A (\<lambda>x y. Q (h x) (h y))"
+  using transp_on_map' [of B Q h A h, simplified, OF assms] by blast
 
 lemma irreflp_on_map:
   assumes "irreflp_on B Q"
     and "h ` A \<subseteq> B"
   shows "irreflp_on A (\<lambda>x y. Q (h x) (h y))"
   using assms unfolding irreflp_on_def by auto
 
 lemma po_on_map:
   assumes "po_on Q B"
     and "h ` A \<subseteq> B"
   shows "po_on (\<lambda>x y. Q (h x) (h y)) A"
   using assms and transp_on_map and irreflp_on_map
   unfolding po_on_def by auto
 
 lemma chain_transp_on_less:
-  assumes "\<forall>i. f i \<in> A \<and> P (f i) (f (Suc i))" and "transp_on P A" and "i < j"
+  assumes "\<forall>i. f i \<in> A \<and> P (f i) (f (Suc i))" and "transp_on A P" and "i < j"
   shows "P (f i) (f j)"
 using \<open>i < j\<close>
 proof (induct j)
   case 0 then show ?case by simp
 next
   case (Suc j)
   show ?case
   proof (cases "i = j")
     case True
     with Suc show ?thesis using assms(1) by simp
   next
     case False
     with Suc have "P (f i) (f j)" by force
     moreover from assms have "P (f j) (f (Suc j))" by auto
     ultimately show ?thesis using assms(1, 2) unfolding transp_on_def by blast
   qed
 qed
 
 lemma wfp_on_imp_irreflp_on:
   assumes "wfp_on P A"
   shows "irreflp_on A P"
 proof (rule irreflp_onI)
   fix x
   assume "x \<in> A"
   show "\<not> P x x"
   proof
     let ?f = "\<lambda>_. x"
     assume "P x x"
     then have "\<forall>i. P (?f (Suc i)) (?f i)" by blast
     with \<open>x \<in> A\<close> have "\<not> wfp_on P A" by (auto simp: wfp_on_def)
     with assms show False by contradiction
   qed
 qed
 
 inductive
   accessible_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> bool"
   for P and A
 where
   accessible_onI [Pure.intro]:
     "\<lbrakk>x \<in> A; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> accessible_on P A y\<rbrakk> \<Longrightarrow> accessible_on P A x"
 
 lemma accessible_on_imp_mem:
   assumes "accessible_on P A a"
   shows "a \<in> A"
   using assms by (induct) auto
 
 lemma accessible_on_induct [consumes 1, induct pred: accessible_on]:
   assumes *: "accessible_on P A a"
     and IH: "\<And>x. \<lbrakk>accessible_on P A x; \<And>y. \<lbrakk>y \<in> A; P y x\<rbrakk> \<Longrightarrow> Q y\<rbrakk> \<Longrightarrow> Q x"
   shows "Q a"
   by (rule * [THEN accessible_on.induct]) (auto intro: IH accessible_onI)
 
 lemma accessible_on_downward:
   "accessible_on P A b \<Longrightarrow> a \<in> A \<Longrightarrow> P a b \<Longrightarrow> accessible_on P A a"
   by (cases rule: accessible_on.cases) fast
 
 lemma accessible_on_restrict_to_downwards:
   assumes "(restrict_to P A)\<^sup>+\<^sup>+ a b" and "accessible_on P A b"
   shows "accessible_on P A a"
   using assms by (induct) (auto dest: accessible_on_imp_mem accessible_on_downward)
 
 lemma accessible_on_imp_inductive_on:
   assumes "\<forall>x\<in>A. accessible_on P A x"
   shows "inductive_on P A"
 proof
   fix Q x
   assume "x \<in> A"
     and *: "\<And>y. \<lbrakk>y \<in> A; \<And>x. \<lbrakk>x \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> Q y"
   with assms have "accessible_on P A x" by auto
   then show "Q x"
   proof (induct)
     case (1 z)
     then have "z \<in> A" by (blast dest: accessible_on_imp_mem)
     show ?case by (rule *) fact+
   qed
 qed
 
 lemmas accessible_on_imp_wfp_on = accessible_on_imp_inductive_on [THEN inductive_on_imp_wfp_on]
 
 lemma wfp_on_tranclp_imp_wfp_on:
   assumes "wfp_on (P\<^sup>+\<^sup>+) A"
   shows "wfp_on P A"
   by (rule ccontr) (insert assms, auto simp: wfp_on_def)
 
 lemma inductive_on_imp_accessible_on:
   assumes "inductive_on P A"
   shows "\<forall>x\<in>A. accessible_on P A x"
 proof
   fix x
   assume "x \<in> A"
   with assms show "accessible_on P A x"
     by (induct) (auto intro: accessible_onI)
 qed
 
 lemma inductive_on_accessible_on_conv:
   "inductive_on P A \<longleftrightarrow> (\<forall>x\<in>A. accessible_on P A x)"
   using inductive_on_imp_accessible_on
     and accessible_on_imp_inductive_on
     by blast
 
 lemmas wfp_on_imp_accessible_on =
   wfp_on_imp_inductive_on [THEN inductive_on_imp_accessible_on]
 
 lemma wfp_on_accessible_on_iff:
   "wfp_on P A \<longleftrightarrow> (\<forall>x\<in>A. accessible_on P A x)"
   by (blast dest: wfp_on_imp_accessible_on accessible_on_imp_wfp_on)
 
 lemma accessible_on_tranclp:
   assumes "accessible_on P A x"
   shows "accessible_on ((restrict_to P A)\<^sup>+\<^sup>+) A x"
     (is "accessible_on ?P A x")
   using assms
 proof (induct)
   case (1 x)
   then have "x \<in> A" by (blast dest: accessible_on_imp_mem)
   then show ?case
   proof (rule accessible_onI)
     fix y
     assume "y \<in> A"
     assume "?P y x"
     then show "accessible_on ?P A y"
     proof (cases)
       assume "restrict_to P A y x"
       with 1 and \<open>y \<in> A\<close> show ?thesis by blast
     next
       fix z
       assume "?P y z" and "restrict_to P A z x"
       with 1 have "accessible_on ?P A z" by (auto simp: restrict_to_def)
       from accessible_on_downward [OF this \<open>y \<in> A\<close> \<open>?P y z\<close>]
         show ?thesis .
     qed
   qed
 qed
 
 lemma wfp_on_restrict_to_tranclp:
   assumes "wfp_on P A"
   shows "wfp_on ((restrict_to P A)\<^sup>+\<^sup>+) A"
   using wfp_on_imp_accessible_on [OF assms]
     and accessible_on_tranclp [of P A]
     and accessible_on_imp_wfp_on [of A "(restrict_to P A)\<^sup>+\<^sup>+"]
     by blast
 
 lemma wfp_on_restrict_to_tranclp':
   assumes "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A"
   shows "wfp_on P A"
   by (rule ccontr) (insert assms, auto simp: wfp_on_def)
 
 lemma wfp_on_restrict_to_tranclp_wfp_on_conv:
   "wfp_on (restrict_to P A)\<^sup>+\<^sup>+ A \<longleftrightarrow> wfp_on P A"
   using wfp_on_restrict_to_tranclp [of P A]
     and wfp_on_restrict_to_tranclp' [of P A]
     by blast
 
 lemma tranclp_idemp [simp]:
   "(P\<^sup>+\<^sup>+)\<^sup>+\<^sup>+ = P\<^sup>+\<^sup>+" (is "?l = ?r")
 proof (intro ext)
   fix x y
   show "?l x y = ?r x y"
   proof
     assume "?l x y" then show "?r x y" by (induct) auto
   next
     assume "?r x y" then show "?l x y" by (induct) auto
   qed
 qed
 
 (*TODO: move the following 3 lemmas to Transitive_Closure?*)
 lemma stepfun_imp_tranclp:
   assumes "f 0 = x" and "f (Suc n) = z"
     and "\<forall>i\<le>n. P (f i) (f (Suc i))"
   shows "P\<^sup>+\<^sup>+ x z"
   using assms
   by (induct n arbitrary: x z)
      (auto intro: tranclp.trancl_into_trancl)
 
 lemma tranclp_imp_stepfun:
   assumes "P\<^sup>+\<^sup>+ x z"
   shows "\<exists>f n. f 0 = x \<and> f (Suc n) = z \<and> (\<forall>i\<le>n. P (f i) (f (Suc i)))"
     (is "\<exists>f n. ?P x z f n")
   using assms
 proof (induct rule: tranclp_induct)
   case (base y)
   let ?f = "(\<lambda>_. y)(0 := x)"
   have "?f 0 = x" and "?f (Suc 0) = y" by auto
   moreover have "\<forall>i\<le>0. P (?f i) (?f (Suc i))"
     using base by auto
   ultimately show ?case by blast
 next
   case (step y z)
   then obtain f n where IH: "?P x y f n" by blast
   then have *: "\<forall>i\<le>n. P (f i) (f (Suc i))"
     and [simp]: "f 0 = x" "f (Suc n) = y"
     by auto
   let ?n = "Suc n"
   let ?f = "f(Suc ?n := z)"
   have "?f 0 = x" and "?f (Suc ?n) = z" by auto
   moreover have "\<forall>i\<le>?n. P (?f i) (?f (Suc i))"
     using \<open>P y z\<close> and * by auto
   ultimately show ?case by blast
 qed
 
 lemma tranclp_stepfun_conv:
   "P\<^sup>+\<^sup>+ x y \<longleftrightarrow> (\<exists>f n. f 0 = x \<and> f (Suc n) = y \<and> (\<forall>i\<le>n. P (f i) (f (Suc i))))"
   using tranclp_imp_stepfun and stepfun_imp_tranclp by metis
 
 
 subsection \<open>Facts About Predecessor Sets\<close>
 
 lemma qo_on_predecessor_subset_conv':
   assumes "qo_on P A" and "B \<subseteq> A" and "C \<subseteq> A"
   shows "{x\<in>A. \<exists>y\<in>B. P x y} \<subseteq> {x\<in>A. \<exists>y\<in>C. P x y} \<longleftrightarrow> (\<forall>x\<in>B. \<exists>y\<in>C. P x y)"
   using assms
   by (auto simp: subset_eq qo_on_def reflp_on_def, unfold transp_on_def) metis+
 
 lemma qo_on_predecessor_subset_conv:
   "\<lbrakk>qo_on P A; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> {z\<in>A. P z x} \<subseteq> {z\<in>A. P z y} \<longleftrightarrow> P x y"
   using qo_on_predecessor_subset_conv' [of P A "{x}" "{y}"] by simp
 
 lemma po_on_predecessors_eq_conv:
   assumes "po_on P A" and "x \<in> A" and "y \<in> A"
   shows "{z\<in>A. P\<^sup>=\<^sup>= z x} = {z\<in>A. P\<^sup>=\<^sup>= z y} \<longleftrightarrow> x = y"
   using assms(2-)
     and reflp_on_reflclp [of A P]
     and po_on_imp_antisymp_on [OF \<open>po_on P A\<close>]
     unfolding antisymp_on_def reflp_on_def
     by blast
 
 lemma restrict_to_rtranclp:
-  assumes "transp_on P A"
+  assumes "transp_on A P"
     and "x \<in> A" and "y \<in> A"
   shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P\<^sup>=\<^sup>= x y"
 proof -
   { assume "(restrict_to P A)\<^sup>*\<^sup>* x y"
     then have "P\<^sup>=\<^sup>= x y" using assms
       by (induct) (auto, unfold transp_on_def, blast) }
   with assms show ?thesis by auto
 qed
 
 lemma reflp_on_restrict_to_rtranclp:
-  assumes "reflp_on A P" and "transp_on P A"
+  assumes "reflp_on A P" and "transp_on A P"
     and "x \<in> A" and "y \<in> A"
   shows "(restrict_to P A)\<^sup>*\<^sup>* x y \<longleftrightarrow> P x y"
   unfolding restrict_to_rtranclp [OF assms(2-)]
   unfolding reflp_on_reflclp_simp [OF assms(1, 3-)] ..
 
 end
diff --git a/thys/Saturation_Framework/Given_Clause_Architectures.thy b/thys/Saturation_Framework/Given_Clause_Architectures.thy
--- a/thys/Saturation_Framework/Given_Clause_Architectures.thy
+++ b/thys/Saturation_Framework/Given_Clause_Architectures.thy
@@ -1,1177 +1,1179 @@
 (*  Title:       Given Clause Prover Architectures
  *  Author:      Sophie Tourret <stourret at mpi-inf.mpg.de>, 2019-2020 *)
 
 section \<open>Given Clause Prover Architectures\<close>
 
 text \<open>This section covers all the results presented in the section 4 of the report.
   This is where abstract architectures of provers are defined and proven
   dynamically refutationally complete.\<close>
 
 theory Given_Clause_Architectures
   imports
     Lambda_Free_RPOs.Lambda_Free_Util
     Labeled_Lifting_to_Non_Ground_Calculi
 begin
 
 
 subsection \<open>Basis of the Given Clause Prover Architectures\<close>
 
 locale given_clause_basis = std?: labeled_lifting_intersection Bot_F Inf_F Bot_G Q
   entails_q Inf_G_q Red_I_q Red_F_q \<G>_F_q \<G>_I_q
   "{\<iota>\<^sub>F\<^sub>L :: ('f \<times> 'l) inference. Infer (map fst (prems_of \<iota>\<^sub>F\<^sub>L)) (fst (concl_of \<iota>\<^sub>F\<^sub>L)) \<in> Inf_F}"
   for
     Bot_F :: "'f set"
     and Inf_F :: "'f inference set"
     and Bot_G :: "'g set"
     and Q :: "'q set"
     and entails_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g set \<Rightarrow> bool"
     and Inf_G_q :: \<open>'q \<Rightarrow> 'g inference set\<close>
     and Red_I_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g inference set"
     and Red_F_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g set"
     and \<G>_F_q :: "'q \<Rightarrow> 'f \<Rightarrow> 'g set"
     and \<G>_I_q :: "'q \<Rightarrow> 'f inference \<Rightarrow> 'g inference set option"
   + fixes
     Equiv_F :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<doteq>" 50) and
     Prec_F :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>\<cdot>" 50) and
     Prec_L :: "'l \<Rightarrow> 'l \<Rightarrow> bool" (infix "\<sqsubset>L" 50) and
     active :: "'l"
   assumes
     equiv_equiv_F: "equivp (\<doteq>)" and
     wf_prec_F: "minimal_element (\<prec>\<cdot>) UNIV" and
     wf_prec_L: "minimal_element (\<sqsubset>L) UNIV" and
     compat_equiv_prec: "C1 \<doteq> D1 \<Longrightarrow> C2 \<doteq> D2 \<Longrightarrow> C1 \<prec>\<cdot> C2 \<Longrightarrow> D1 \<prec>\<cdot> D2" and
     equiv_F_grounding: "q \<in> Q \<Longrightarrow> C1 \<doteq> C2 \<Longrightarrow> \<G>_F_q q C1 \<subseteq> \<G>_F_q q C2" and
     prec_F_grounding: "q \<in> Q \<Longrightarrow> C2 \<prec>\<cdot> C1 \<Longrightarrow> \<G>_F_q q C1 \<subseteq> \<G>_F_q q C2" and
     active_minimal: "l2 \<noteq> active \<Longrightarrow> active \<sqsubset>L l2" and
     at_least_two_labels: "\<exists>l2. active \<sqsubset>L l2" and
     static_ref_comp: "statically_complete_calculus Bot_F Inf_F (\<Turnstile>\<inter>\<G>)
       no_labels.Red_I_\<G> no_labels.Red_F_\<G>_empty"
 begin
 
 abbreviation Inf_FL :: "('f \<times> 'l) inference set" where
   "Inf_FL \<equiv> {\<iota>\<^sub>F\<^sub>L. Infer (map fst (prems_of \<iota>\<^sub>F\<^sub>L)) (fst (concl_of \<iota>\<^sub>F\<^sub>L)) \<in> Inf_F}"
 
 abbreviation Prec_eq_F :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<preceq>\<cdot>" 50) where
   "C \<preceq>\<cdot> D \<equiv> C \<doteq> D \<or> C \<prec>\<cdot> D"
 
 definition Prec_FL :: "('f \<times> 'l) \<Rightarrow> ('f \<times> 'l) \<Rightarrow> bool" (infix "\<sqsubset>" 50) where
   "Cl1 \<sqsubset> Cl2 \<longleftrightarrow> fst Cl1 \<prec>\<cdot> fst Cl2 \<or> (fst Cl1 \<doteq> fst Cl2 \<and> snd Cl1 \<sqsubset>L snd Cl2)"
 
 lemma irrefl_prec_F: "\<not> C \<prec>\<cdot> C"
   by (simp add: minimal_element.po[OF wf_prec_F, unfolded po_on_def irreflp_on_def])
 
 lemma trans_prec_F: "C1 \<prec>\<cdot> C2 \<Longrightarrow> C2 \<prec>\<cdot> C3 \<Longrightarrow> C1 \<prec>\<cdot> C3"
   by (auto intro: minimal_element.po[OF wf_prec_F, unfolded po_on_def transp_on_def, THEN conjunct2,
         simplified, rule_format])
 
 lemma wf_prec_FL: "minimal_element (\<sqsubset>) UNIV"
 proof
   show "po_on (\<sqsubset>) UNIV" unfolding po_on_def
   proof
-    show "irreflp_on UNIV (\<sqsubset>)" unfolding irreflp_on_def Prec_FL_def
+    show "irreflp (\<sqsubset>)" unfolding irreflp_on_def Prec_FL_def
     proof
       fix Cl
       assume a_in: "Cl \<in> (UNIV::('f \<times> 'l) set)"
       have "\<not> (fst Cl \<prec>\<cdot> fst Cl)" using wf_prec_F minimal_element.min_elt_ex by force
       moreover have "\<not> (snd Cl \<sqsubset>L snd Cl)" using wf_prec_L minimal_element.min_elt_ex by force
       ultimately show "\<not> (fst Cl \<prec>\<cdot> fst Cl \<or> fst Cl \<doteq> fst Cl \<and> snd Cl \<sqsubset>L snd Cl)" by blast
     qed
   next
-    show "transp_on (\<sqsubset>) UNIV" unfolding transp_on_def Prec_FL_def
-    proof (simp, intro allI impI)
-      fix C1 l1 C2 l2 C3 l3
-      assume trans_hyp: "(C1 \<prec>\<cdot> C2 \<or> C1 \<doteq> C2 \<and> l1 \<sqsubset>L l2) \<and> (C2 \<prec>\<cdot> C3 \<or> C2 \<doteq> C3 \<and> l2 \<sqsubset>L l3)"
-      have "C1 \<prec>\<cdot> C2 \<Longrightarrow> C2 \<doteq> C3 \<Longrightarrow> C1 \<prec>\<cdot> C3"
+    show "transp (\<sqsubset>)" unfolding Prec_FL_def
+    proof (rule transpI)
+      fix Cl1 Cl2 Cl3
+      assume trans_hyps:
+        "(fst Cl1 \<prec>\<cdot> fst Cl2 \<or> fst Cl1 \<doteq> fst Cl2 \<and> snd Cl1 \<sqsubset>L snd Cl2)"
+        "(fst Cl2 \<prec>\<cdot> fst Cl3 \<or> fst Cl2 \<doteq> fst Cl3 \<and> snd Cl2 \<sqsubset>L snd Cl3)"
+      have "fst Cl1 \<prec>\<cdot> fst Cl2 \<Longrightarrow> fst Cl2 \<doteq> fst Cl3 \<Longrightarrow> fst Cl1 \<prec>\<cdot> fst Cl3"
         using compat_equiv_prec by (metis equiv_equiv_F equivp_def)
-      moreover have "C1 \<doteq> C2 \<Longrightarrow> C2 \<prec>\<cdot> C3 \<Longrightarrow> C1 \<prec>\<cdot> C3"
+      moreover have "fst Cl1 \<doteq> fst Cl2 \<Longrightarrow> fst Cl2 \<prec>\<cdot> fst Cl3 \<Longrightarrow> fst Cl1 \<prec>\<cdot> fst Cl3"
         using compat_equiv_prec by (metis equiv_equiv_F equivp_def)
-      moreover have "l1 \<sqsubset>L l2 \<Longrightarrow> l2 \<sqsubset>L l3 \<Longrightarrow> l1 \<sqsubset>L l3"
-        using wf_prec_L unfolding minimal_element_def po_on_def transp_on_def by (meson UNIV_I)
-      moreover have "C1 \<doteq> C2 \<Longrightarrow> C2 \<doteq> C3 \<Longrightarrow> C1 \<doteq> C3"
+      moreover have "snd Cl1 \<sqsubset>L snd Cl2 \<Longrightarrow> snd Cl2 \<sqsubset>L snd Cl3 \<Longrightarrow> snd Cl1 \<sqsubset>L snd Cl3"
+        using wf_prec_L unfolding minimal_element_def po_on_def transp_def by (meson UNIV_I)
+      moreover have "fst Cl1 \<doteq> fst Cl2 \<Longrightarrow> fst Cl2 \<doteq> fst Cl3 \<Longrightarrow> fst Cl1 \<doteq> fst Cl3"
         using equiv_equiv_F by (meson equivp_transp)
-      ultimately show "C1 \<prec>\<cdot> C3 \<or> C1 \<doteq> C3 \<and> l1 \<sqsubset>L l3" using trans_hyp
-        using trans_prec_F by blast
+      ultimately show "fst Cl1 \<prec>\<cdot> fst Cl3 \<or> fst Cl1 \<doteq> fst Cl3 \<and> snd Cl1 \<sqsubset>L snd Cl3"
+        using trans_hyps trans_prec_F by blast
     qed
   qed
 next
   show "wfp_on (\<sqsubset>) UNIV" unfolding wfp_on_def
   proof
     assume contra: "\<exists>f. \<forall>i. f i \<in> UNIV \<and> f (Suc i) \<sqsubset> f i"
     then obtain f where
       f_suc: "\<forall>i. f (Suc i) \<sqsubset> f i"
       by blast
 
     define R :: "(('f \<times> 'l) \<times> ('f \<times> 'l)) set" where
       "R = {(Cl1, Cl2). fst Cl1 \<prec>\<cdot> fst Cl2}"
     define S :: "(('f \<times> 'l) \<times> ('f \<times> 'l)) set" where
       "S = {(Cl1, Cl2). fst Cl1 \<doteq> fst Cl2 \<and> snd Cl1 \<sqsubset>L snd Cl2}"
 
     obtain k where
       f_chain: "\<forall>i. (f (Suc (i + k)), f (i + k)) \<in> S"
     proof (atomize_elim, rule wf_infinite_down_chain_compatible[of R f S])
       show "wf R"
         unfolding R_def using wf_app[OF wf_prec_F[unfolded minimal_element_def, THEN conjunct2,
               unfolded wfp_on_UNIV wfP_def]]
         by force
     next
       show "\<forall>i. (f (Suc i), f i) \<in> R \<union> S"
         using f_suc unfolding R_def S_def Prec_FL_def by blast
     next
       show "R O S \<subseteq> R"
         unfolding R_def S_def using compat_equiv_prec equiv_equiv_F equivp_reflp by fastforce
     qed
 
     define g where
       "\<And>i. g i = f (i + k)"
 
     have g_chain: "\<forall>i. (g (Suc i), g i) \<in> S"
       unfolding g_def using f_chain by simp
     have wf_s: "wf S"
       unfolding S_def
       by (rule wf_subset[OF wf_app[OF wf_prec_L[unfolded minimal_element_def, THEN conjunct2,
                 unfolded wfp_on_UNIV wfP_def], of snd]])
         fast
     show False
       using g_chain[unfolded S_def]
         wf_s[unfolded S_def, folded wfP_def wfp_on_UNIV, unfolded wfp_on_def]
       by auto
   qed
 qed
 
 definition active_subset :: "('f \<times> 'l) set \<Rightarrow> ('f \<times> 'l) set" where
   "active_subset M = {CL \<in> M. snd CL = active}"
 
 definition passive_subset :: "('f \<times> 'l) set \<Rightarrow> ('f \<times> 'l) set" where
   "passive_subset M = {CL \<in> M. snd CL \<noteq> active}"
 
 lemma active_subset_insert[simp]:
   "active_subset (insert Cl N) = (if snd Cl = active then {Cl} else {}) \<union> active_subset N"
   unfolding active_subset_def by auto
 
 lemma active_subset_union[simp]: "active_subset (M \<union> N) = active_subset M \<union> active_subset N"
   unfolding active_subset_def by auto
 
 lemma passive_subset_insert[simp]:
   "passive_subset (insert Cl N) = (if snd Cl \<noteq> active then {Cl} else {}) \<union> passive_subset N"
   unfolding passive_subset_def by auto
 
 lemma passive_subset_union[simp]: "passive_subset (M \<union> N) = passive_subset M \<union> passive_subset N"
   unfolding passive_subset_def by auto
 
 sublocale std?: statically_complete_calculus Bot_FL Inf_FL "(\<Turnstile>\<inter>\<G>L)" Red_I Red_F
   using labeled_static_ref[OF static_ref_comp] .
 
 lemma labeled_tiebreaker_lifting:
   assumes q_in: "q \<in> Q"
   shows "tiebreaker_lifting Bot_FL Inf_FL Bot_G (entails_q q) (Inf_G_q q)
     (Red_I_q q) (Red_F_q q) (\<G>_F_L_q q) (\<G>_I_L_q q) (\<lambda>g. Prec_FL)"
 proof -
   have "tiebreaker_lifting Bot_FL Inf_FL Bot_G (entails_q q) (Inf_G_q q)
     (Red_I_q q) (Red_F_q q) (\<G>_F_L_q q) (\<G>_I_L_q q) (\<lambda>g Cl Cl'. False)"
     using ord_fam_lifted_q[OF q_in] .
   then have "standard_lifting Inf_FL Bot_G (Inf_G_q q) (entails_q q) (Red_I_q q)
     (Red_F_q q) Bot_FL (\<G>_F_L_q q) (\<G>_I_L_q q)"
     using lifted_q[OF q_in] by blast
   then show "tiebreaker_lifting Bot_FL Inf_FL Bot_G (entails_q q) (Inf_G_q q)
     (Red_I_q q) (Red_F_q q) (\<G>_F_L_q q) (\<G>_I_L_q q) (\<lambda>g. Prec_FL)"
     using wf_prec_FL by (simp add: tiebreaker_lifting.intro tiebreaker_lifting_axioms.intro)
 qed
 
 sublocale lifting_intersection Inf_FL Bot_G Q Inf_G_q entails_q Red_I_q Red_F_q
   Bot_FL \<G>_F_L_q \<G>_I_L_q "\<lambda>g. Prec_FL"
   using labeled_tiebreaker_lifting unfolding lifting_intersection_def
   by (simp add: lifting_intersection_axioms.intro
       no_labels.ground.consequence_relation_family_axioms
       no_labels.ground.inference_system_family_axioms)
 
 notation derive (infix "\<rhd>L" 50)
 
 lemma std_Red_I_eq: "std.Red_I = Red_I_\<G>"
   unfolding Red_I_\<G>_q_def Red_I_\<G>_L_q_def by simp
 
 lemma std_Red_F_eq: "std.Red_F = Red_F_\<G>_empty"
   unfolding Red_F_\<G>_empty_q_def Red_F_\<G>_empty_L_q_def by simp
 
 sublocale statically_complete_calculus Bot_FL Inf_FL "(\<Turnstile>\<inter>\<G>L)" Red_I Red_F
   by unfold_locales (use statically_complete std_Red_I_eq in auto)
 
 (* lem:redundant-labeled-inferences *)
 lemma labeled_red_inf_eq_red_inf:
   assumes i_in: "\<iota> \<in> Inf_FL"
   shows "\<iota> \<in> Red_I N \<longleftrightarrow> to_F \<iota> \<in> no_labels.Red_I_\<G> (fst ` N)"
 proof
   assume i_in2: "\<iota> \<in> Red_I N"
   then have "X \<in> Red_I_\<G>_q ` Q \<Longrightarrow> \<iota> \<in> X N" for X
     unfolding Red_I_def by blast
   obtain X0 where "X0 \<in> Red_I_\<G>_q ` Q"
     using Q_nonempty by blast
   then obtain q0 where x0_is: "X0 N = Red_I_\<G>_q q0 N" by blast
   then obtain Y0 where y0_is: "Y0 (fst ` N) = to_F ` (X0 N)" by auto
   have "Y0 (fst ` N) = no_labels.Red_I_\<G>_q q0 (fst ` N)"
     unfolding  y0_is
   proof
     show "to_F ` X0 N \<subseteq> no_labels.Red_I_\<G>_q q0 (fst ` N)"
     proof
       fix \<iota>0
       assume i0_in: "\<iota>0 \<in> to_F ` X0 N"
       then have i0_in2: "\<iota>0 \<in> to_F ` Red_I_\<G>_q q0 N"
         using x0_is by argo
       then obtain \<iota>0_FL where i0_FL_in: "\<iota>0_FL \<in> Inf_FL" and i0_to_i0_FL: "\<iota>0 = to_F \<iota>0_FL" and
         subs1: "((\<G>_I_L_q q0 \<iota>0_FL) \<noteq> None \<and>
             the (\<G>_I_L_q q0 \<iota>0_FL) \<subseteq> Red_I_q q0 (\<G>_Fset_q q0 N))
             \<or> ((\<G>_I_L_q q0 \<iota>0_FL = None) \<and>
             \<G>_F_L_q q0 (concl_of \<iota>0_FL) \<subseteq> \<G>_Fset_q q0 N \<union> Red_F_q q0 (\<G>_Fset_q q0 N))"
         unfolding Red_I_\<G>_q_def by blast
       have concl_swap: "fst (concl_of \<iota>0_FL) = concl_of \<iota>0"
         unfolding concl_of_def i0_to_i0_FL to_F_def by simp
       have i0_in3: "\<iota>0 \<in> Inf_F"
         using i0_to_i0_FL Inf_FL_to_Inf_F[OF i0_FL_in] unfolding to_F_def by blast
       {
         assume
           not_none: "\<G>_I_q q0 \<iota>0 \<noteq> None" and
           "the (\<G>_I_q q0 \<iota>0) \<noteq> {}"
         then obtain \<iota>1 where i1_in: "\<iota>1 \<in> the (\<G>_I_q q0 \<iota>0)" by blast
         have "the (\<G>_I_q q0 \<iota>0) \<subseteq> Red_I_q q0 (no_labels.\<G>_Fset_q q0 (fst ` N))"
           using subs1 i0_to_i0_FL not_none by auto
       }
       moreover {
         assume
           is_none: "\<G>_I_q q0 \<iota>0 = None"
         then have "\<G>_F_q q0 (concl_of \<iota>0) \<subseteq> no_labels.\<G>_Fset_q q0 (fst ` N)
             \<union> Red_F_q q0 (no_labels.\<G>_Fset_q q0 (fst ` N))"
           using subs1 i0_to_i0_FL concl_swap by simp
       }
       ultimately show "\<iota>0 \<in> no_labels.Red_I_\<G>_q q0 (fst ` N)"
         unfolding no_labels.Red_I_\<G>_q_def using i0_in3 by auto
     qed
   next
     show "no_labels.Red_I_\<G>_q q0 (fst ` N) \<subseteq> to_F ` X0 N"
     proof
       fix \<iota>0
       assume i0_in: "\<iota>0 \<in> no_labels.Red_I_\<G>_q q0 (fst ` N)"
       then have i0_in2: "\<iota>0 \<in> Inf_F"
         unfolding no_labels.Red_I_\<G>_q_def by blast
       obtain \<iota>0_FL where i0_FL_in: "\<iota>0_FL \<in> Inf_FL" and i0_to_i0_FL: "\<iota>0 = to_F \<iota>0_FL"
         using Inf_F_to_Inf_FL[OF i0_in2] unfolding to_F_def
         by (smt (verit) Ex_list_of_length fst_conv inference.exhaust_sel inference.sel(1)
             inference.sel(2) map_fst_zip)
       have concl_swap: "fst (concl_of \<iota>0_FL) = concl_of \<iota>0"
         unfolding concl_of_def i0_to_i0_FL to_F_def by simp
       have subs1: "((\<G>_I_L_q q0 \<iota>0_FL) \<noteq> None \<and>
            the (\<G>_I_L_q q0 \<iota>0_FL) \<subseteq> Red_I_q q0 (\<G>_Fset_q q0 N))
            \<or> ((\<G>_I_L_q q0 \<iota>0_FL = None) \<and>
            \<G>_F_L_q q0 (concl_of \<iota>0_FL) \<subseteq> (\<G>_Fset_q q0 N \<union> Red_F_q q0 (\<G>_Fset_q q0 N)))"
         using i0_in i0_to_i0_FL concl_swap unfolding no_labels.Red_I_\<G>_q_def by simp
       then have "\<iota>0_FL \<in> Red_I_\<G>_q q0 N"
         using i0_FL_in unfolding Red_I_\<G>_q_def by simp
       then show "\<iota>0 \<in> to_F ` X0 N"
         using x0_is i0_to_i0_FL i0_in2 by blast
     qed
   qed
   then have "Y \<in> no_labels.Red_I_\<G>_q ` Q \<Longrightarrow> to_F \<iota> \<in> Y (fst ` N)" for Y
     using i_in2 no_labels.Red_I_def std_Red_I_eq red_inf_impl by force
   then show "to_F \<iota> \<in> no_labels.Red_I_\<G> (fst ` N)"
     unfolding Red_I_def no_labels.Red_I_\<G>_def by blast
 next
   assume to_F_in: "to_F \<iota> \<in> no_labels.Red_I_\<G> (fst ` N)"
   have imp_to_F: "X \<in> no_labels.Red_I_\<G>_q ` Q \<Longrightarrow> to_F \<iota> \<in> X (fst ` N)" for X
     using to_F_in unfolding no_labels.Red_I_\<G>_def by blast
   then have to_F_in2: "to_F \<iota> \<in> no_labels.Red_I_\<G>_q q (fst ` N)" if "q \<in> Q" for q
     using that by auto
   have "Red_I_\<G>_q q N = {\<iota>0_FL \<in> Inf_FL. to_F \<iota>0_FL \<in> no_labels.Red_I_\<G>_q q (fst ` N)}" for q
   proof
     show "Red_I_\<G>_q q N \<subseteq> {\<iota>0_FL \<in> Inf_FL. to_F \<iota>0_FL \<in> no_labels.Red_I_\<G>_q q (fst ` N)}"
     proof
       fix q0 \<iota>1
       assume
         i1_in: "\<iota>1 \<in> Red_I_\<G>_q q0 N"
       have i1_in2: "\<iota>1 \<in> Inf_FL"
         using i1_in unfolding Red_I_\<G>_q_def by blast
       then have to_F_i1_in: "to_F \<iota>1 \<in> Inf_F"
         using Inf_FL_to_Inf_F unfolding to_F_def by blast
       have concl_swap: "fst (concl_of \<iota>1) = concl_of (to_F \<iota>1)"
         unfolding concl_of_def to_F_def by simp
       then have i1_to_F_in: "to_F \<iota>1 \<in> no_labels.Red_I_\<G>_q q0 (fst ` N)"
         using i1_in to_F_i1_in unfolding Red_I_\<G>_q_def no_labels.Red_I_\<G>_q_def by force
       show "\<iota>1 \<in> {\<iota>0_FL \<in> Inf_FL. to_F \<iota>0_FL \<in> no_labels.Red_I_\<G>_q q0 (fst ` N)}"
         using i1_in2 i1_to_F_in by blast
     qed
   next
     show "{\<iota>0_FL \<in> Inf_FL. to_F \<iota>0_FL \<in> no_labels.Red_I_\<G>_q q (fst ` N)} \<subseteq> Red_I_\<G>_q q N"
     proof
       fix q0 \<iota>1
       assume
         i1_in: "\<iota>1 \<in> {\<iota>0_FL \<in> Inf_FL. to_F \<iota>0_FL \<in> no_labels.Red_I_\<G>_q q0 (fst ` N)}"
       then have i1_in2: "\<iota>1 \<in> Inf_FL" by blast
       then have to_F_i1_in: "to_F \<iota>1 \<in> Inf_F"
         using Inf_FL_to_Inf_F unfolding to_F_def by blast
       have concl_swap: "fst (concl_of \<iota>1) = concl_of (to_F \<iota>1)"
         unfolding concl_of_def to_F_def by simp
       then have "((\<G>_I_L_q q0 \<iota>1) \<noteq> None \<and> the (\<G>_I_L_q q0 \<iota>1) \<subseteq> Red_I_q q0 (\<G>_Fset_q q0 N))
         \<or> (\<G>_I_L_q q0 \<iota>1 = None \<and>
           \<G>_F_L_q q0 (concl_of \<iota>1) \<subseteq> \<G>_Fset_q q0 N \<union> Red_F_q q0 (\<G>_Fset_q q0 N))"
         using i1_in unfolding no_labels.Red_I_\<G>_q_def by auto
       then show "\<iota>1 \<in> Red_I_\<G>_q q0 N"
         using i1_in2 unfolding Red_I_\<G>_q_def by blast
     qed
   qed
   then have "\<iota> \<in> Red_I_\<G>_q q N" if "q \<in> Q" for q
     using that to_F_in2 i_in unfolding Red_I_\<G>_q_def no_labels.Red_I_\<G>_q_def by auto
   then show "\<iota> \<in> Red_I_\<G> N"
     unfolding Red_I_\<G>_def by blast
 qed
 
 (* lem:redundant-labeled-formulas *)
 lemma red_labeled_clauses:
   assumes \<open>C \<in> no_labels.Red_F_\<G>_empty (fst ` N) \<or>
     (\<exists>C' \<in> fst ` N. C' \<prec>\<cdot> C) \<or> (\<exists>(C', L') \<in> N. L' \<sqsubset>L L \<and> C' \<preceq>\<cdot> C)\<close>
   shows \<open>(C, L) \<in> Red_F N\<close>
 proof -
   note assms
   moreover have i: \<open>C \<in> no_labels.Red_F_\<G>_empty (fst ` N) \<Longrightarrow> (C, L) \<in> Red_F N\<close>
   proof -
     assume "C \<in> no_labels.Red_F_\<G>_empty (fst ` N)"
     then have "C \<in> no_labels.Red_F_\<G>_empty_q q (fst ` N)" if "q \<in> Q" for q
       unfolding no_labels.Red_F_\<G>_empty_def using that by fast
     then have g_in_red: "\<G>_F_q q C \<subseteq> Red_F_q q (no_labels.\<G>_Fset_q q (fst ` N))" if "q \<in> Q" for q
       unfolding no_labels.Red_F_\<G>_empty_q_def using that by blast
     have "\<G>_F_L_q q (C, L) \<subseteq> Red_F_q q (\<G>_Fset_q q N)" if "q \<in> Q" for q
       using that g_in_red by simp
     then show ?thesis
       unfolding Red_F_def Red_F_\<G>_q_def by blast
   qed
   moreover have ii: \<open>\<exists>C' \<in> fst ` N. C' \<prec>\<cdot> C \<Longrightarrow> (C, L) \<in> Red_F N\<close>
   proof -
     assume "\<exists>C' \<in> fst ` N. C' \<prec>\<cdot> C"
     then obtain C' where c'_in: "C' \<in> fst ` N" and c_prec_c': "C' \<prec>\<cdot> C" by blast
     obtain L' where c'_l'_in: "(C', L') \<in> N" using c'_in by auto
     have c'_l'_prec: "(C', L') \<sqsubset> (C, L)"
       using c_prec_c' unfolding Prec_FL_def by simp
     have c_in_c'_g: "\<G>_F_q q C \<subseteq> \<G>_F_q q C'" if "q \<in> Q" for q
       using prec_F_grounding[OF that c_prec_c'] by presburger
     then have "\<G>_F_L_q q (C, L) \<subseteq> \<G>_F_L_q q (C', L')" if "q \<in> Q" for q
       using that by auto
     then have "(C, L) \<in> Red_F_\<G>_q q N" if "q \<in> Q" for q
       unfolding Red_F_\<G>_q_def using that c'_l'_in c'_l'_prec by blast
     then show ?thesis
       unfolding Red_F_def by blast
   qed
   moreover have iii: \<open>\<exists>(C', L') \<in> N. L' \<sqsubset>L L \<and> C' \<preceq>\<cdot> C \<Longrightarrow> (C, L) \<in> Red_F N\<close>
   proof -
     assume "\<exists>(C', L') \<in> N. L' \<sqsubset>L L \<and> C' \<preceq>\<cdot> C"
     then obtain C' L' where c'_l'_in: "(C', L') \<in> N" and l'_sub_l: "L' \<sqsubset>L L" and c'_sub_c: "C' \<preceq>\<cdot> C"
       by fast
     have "(C, L) \<in> Red_F N" if "C' \<prec>\<cdot> C"
       using that c'_l'_in ii by fastforce
     moreover {
       assume equiv_c_c': "C \<doteq> C'"
       then have equiv_c'_c: "C' \<doteq> C"
         using equiv_equiv_F by (simp add: equivp_symp)
       then have c'_l'_prec: "(C', L') \<sqsubset> (C, L)"
         using l'_sub_l unfolding Prec_FL_def by simp
       have "\<G>_F_q q C = \<G>_F_q q C'" if "q \<in> Q" for q
         using that equiv_F_grounding equiv_c_c' equiv_c'_c by (simp add: set_eq_subset)
       then have "\<G>_F_L_q q (C, L) = \<G>_F_L_q q (C', L')" if "q \<in> Q" for q
         using that by auto
       then have "(C, L) \<in> Red_F_\<G>_q q N" if "q \<in> Q" for q
         unfolding Red_F_\<G>_q_def using that c'_l'_in c'_l'_prec by blast
       then have ?thesis
         unfolding Red_F_def by blast
     }
     ultimately show ?thesis
       using c'_sub_c equiv_equiv_F equivp_symp by fastforce
   qed
   ultimately show ?thesis
     by blast
 qed
 
 end
   
   
 subsection \<open>Given Clause Procedure\<close>
 
 locale given_clause = given_clause_basis Bot_F Inf_F Bot_G Q entails_q Inf_G_q Red_I_q
   Red_F_q \<G>_F_q \<G>_I_q Equiv_F Prec_F Prec_L active
   for
     Bot_F :: "'f set" and
     Inf_F :: "'f inference set" and
     Bot_G :: "'g set" and
     Q :: "'q set" and
     entails_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g set \<Rightarrow> bool" and
     Inf_G_q :: \<open>'q \<Rightarrow> 'g inference set\<close> and
     Red_I_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g inference set" and
     Red_F_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g set" and
     \<G>_F_q :: "'q \<Rightarrow> 'f \<Rightarrow> 'g set"  and
     \<G>_I_q :: "'q \<Rightarrow> 'f inference \<Rightarrow> 'g inference set option" and
     Equiv_F :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<doteq>" 50) and
     Prec_F :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>\<cdot>" 50) and
     Prec_L :: "'l \<Rightarrow> 'l \<Rightarrow> bool" (infix "\<sqsubset>L" 50) and
     active :: 'l +
   assumes
     inf_have_prems: "\<iota>F \<in> Inf_F \<Longrightarrow> prems_of \<iota>F \<noteq> []"
 begin
 
 lemma labeled_inf_have_prems: "\<iota> \<in> Inf_FL \<Longrightarrow> prems_of \<iota> \<noteq> []"
   using inf_have_prems by fastforce
 
 inductive step :: "('f \<times> 'l) set \<Rightarrow> ('f \<times> 'l) set \<Rightarrow> bool" (infix "\<leadsto>GC" 50) where
   process: "N1 = N \<union> M \<Longrightarrow> N2 = N \<union> M' \<Longrightarrow> M \<subseteq> Red_F (N \<union> M') \<Longrightarrow>
     active_subset M' = {} \<Longrightarrow> N1 \<leadsto>GC N2"
 | infer: "N1 = N \<union> {(C, L)} \<Longrightarrow> N2 = N \<union> {(C, active)} \<union> M \<Longrightarrow> L \<noteq> active \<Longrightarrow>
     active_subset M = {} \<Longrightarrow>
     no_labels.Inf_between (fst ` active_subset N) {C}
     \<subseteq> no_labels.Red_I (fst ` (N \<union> {(C, active)} \<union> M)) \<Longrightarrow>
     N1 \<leadsto>GC N2"
   
 lemma one_step_equiv: "N1 \<leadsto>GC N2 \<Longrightarrow> N1 \<rhd>L N2"
 proof (cases N1 N2 rule: step.cases)
   show "N1 \<leadsto>GC N2 \<Longrightarrow> N1 \<leadsto>GC N2" by blast
 next
   fix N M M'
   assume
     gc_step: "N1 \<leadsto>GC N2" and
     n1_is: "N1 = N \<union> M" and
     n2_is: "N2 = N \<union> M'" and
     m_red: "M \<subseteq> Red_F (N \<union> M')" and
     active_empty: "active_subset M' = {}"
   have "N1 - N2 \<subseteq> Red_F N2"
     using n1_is n2_is m_red by auto
   then show "N1 \<rhd>L N2"
     unfolding derive.simps by blast
 next
   fix N C L M
   assume
     gc_step: "N1 \<leadsto>GC N2" and
     n1_is: "N1 = N \<union> {(C, L)}" and
     not_active: "L \<noteq> active" and
     n2_is: "N2 = N \<union> {(C, active)} \<union> M" and
     active_empty: "active_subset M = {}"
   have "(C, active) \<in> N2" using n2_is by auto
   moreover have "C \<preceq>\<cdot> C" using equiv_equiv_F by (metis equivp_def)
   moreover have "active \<sqsubset>L L" using active_minimal[OF not_active] .
   ultimately have "{(C, L)} \<subseteq> Red_F N2"
     using red_labeled_clauses by blast
   moreover have "N1 - N2 = {} \<or> N1 - N2 = {(C, L)}" using n1_is n2_is by blast
   ultimately have "N1 - N2 \<subseteq> Red_F N2"
     using std_Red_F_eq by blast
   then show "N1 \<rhd>L N2"
     unfolding derive.simps by blast
 qed
 
 (* lem:gc-derivations-are-red-derivations *)
 lemma gc_to_red: "chain (\<leadsto>GC) Ns \<Longrightarrow> chain (\<rhd>L) Ns"
   using one_step_equiv Lazy_List_Chain.chain_mono by blast
 
 lemma (in-) all_ex_finite_set: "(\<forall>(j::nat)\<in>{0..<m}. \<exists>(n::nat). P j n) \<Longrightarrow>
   (\<forall>n1 n2. \<forall>j\<in>{0..<m}. P j n1 \<longrightarrow> P j n2 \<longrightarrow> n1 = n2) \<Longrightarrow> finite {n. \<exists>j \<in> {0..<m}. P j n}" for m P
 proof -
   fix m::nat and P:: "nat \<Rightarrow> nat \<Rightarrow> bool"
   assume
     allj_exn: "\<forall>j\<in>{0..<m}. \<exists>n. P j n" and
     uniq_n: "\<forall>n1 n2. \<forall>j\<in>{0..<m}. P j n1 \<longrightarrow> P j n2 \<longrightarrow> n1 = n2"
   have "{n. \<exists>j \<in> {0..<m}. P j n} = (\<Union>((\<lambda>j. {n. P j n}) ` {0..<m}))" by blast
   then have imp_finite: "(\<forall>j\<in>{0..<m}. finite {n. P j n}) \<Longrightarrow> finite {n. \<exists>j \<in> {0..<m}. P j n}"
     using finite_UN[of "{0..<m}" "\<lambda>j. {n. P j n}"] by simp
   have "\<forall>j\<in>{0..<m}. \<exists>!n. P j n" using allj_exn uniq_n by blast
   then have "\<forall>j\<in>{0..<m}. finite {n. P j n}" by (metis bounded_nat_set_is_finite lessI mem_Collect_eq)
   then show "finite {n. \<exists>j \<in> {0..<m}. P j n}" using imp_finite by simp
 qed
 
 (* lem:fair-gc-derivations *)
 lemma gc_fair:
   assumes
     deriv: "chain (\<leadsto>GC) Ns" and
     init_state: "active_subset (lhd Ns) = {}" and
     final_state: "passive_subset (Liminf_llist Ns) = {}"
   shows "fair Ns"
   unfolding fair_def
 proof
   fix \<iota>
   assume i_in: "\<iota> \<in> Inf_from (Liminf_llist Ns)"
   note lhd_is = lhd_conv_lnth[OF chain_not_lnull[OF deriv]]
   have i_in_inf_fl: "\<iota> \<in> Inf_FL" using i_in unfolding Inf_from_def by blast
   have "Liminf_llist Ns = active_subset (Liminf_llist Ns)"
     using final_state unfolding passive_subset_def active_subset_def by blast
   then have i_in2: "\<iota> \<in> Inf_from (active_subset (Liminf_llist Ns))" using i_in by simp
   define m where "m = length (prems_of \<iota>)"
   then have m_def_F: "m = length (prems_of (to_F \<iota>))" unfolding to_F_def by simp
   have i_in_F: "to_F \<iota> \<in> Inf_F"
     using i_in Inf_FL_to_Inf_F unfolding Inf_from_def to_F_def by blast
   then have m_pos: "m > 0" using m_def_F using inf_have_prems by blast
   have exist_nj: "\<forall>j \<in> {0..<m}. (\<exists>nj. enat (Suc nj) < llength Ns \<and>
       prems_of \<iota> ! j \<notin> active_subset (lnth Ns nj) \<and>
       (\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j \<in> active_subset (lnth Ns k)))"
   proof clarify
     fix j
     assume j_in: "j \<in> {0..<m}"
     then obtain C where c_is: "(C, active) = prems_of \<iota> ! j"
       using i_in2 unfolding m_def Inf_from_def active_subset_def
       by (smt Collect_mem_eq Collect_mono_iff atLeastLessThan_iff nth_mem old.prod.exhaust snd_conv)
     then have "(C, active) \<in> Liminf_llist Ns"
       using j_in i_in unfolding m_def Inf_from_def by force
     then obtain nj where nj_is: "enat nj < llength Ns" and
       c_in2: "(C, active) \<in> \<Inter> (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns})"
       unfolding Liminf_llist_def using init_state by blast
     then have c_in3: "\<forall>k. k \<ge> nj \<longrightarrow> enat k < llength Ns \<longrightarrow> (C, active) \<in> lnth Ns k" by blast
     have nj_pos: "nj > 0" using init_state c_in2 nj_is
       unfolding active_subset_def lhd_is by force
     obtain nj_min where nj_min_is: "nj_min = (LEAST nj. enat nj < llength Ns \<and>
         (C, active) \<in> \<Inter> (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns}))" by blast
     then have in_allk: "\<forall>k. k \<ge> nj_min \<longrightarrow> enat k < llength Ns \<longrightarrow> (C, active) \<in> (lnth Ns k)"
       using c_in3 nj_is c_in2
       by (metis (mono_tags, lifting) INT_E LeastI_ex mem_Collect_eq)
     have njm_smaller_D: "enat nj_min < llength Ns"
       using nj_min_is
       by (smt LeastI_ex \<open>\<And>thesis. (\<And>nj. \<lbrakk>enat nj < llength Ns;
           (C, active) \<in> \<Inter> (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns})\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>)
     have "nj_min > 0"
       using nj_is c_in2 nj_pos nj_min_is lhd_is
       by (metis (mono_tags, lifting) Collect_empty_eq \<open>(C, active) \<in> Liminf_llist Ns\<close>
           \<open>Liminf_llist Ns = active_subset (Liminf_llist Ns)\<close>
           \<open>\<forall>k\<ge>nj_min. enat k < llength Ns \<longrightarrow> (C, active) \<in> lnth Ns k\<close> active_subset_def init_state
           linorder_not_less mem_Collect_eq zero_enat_def chain_length_pos[OF deriv])
     then obtain njm_prec where nj_prec_is: "Suc njm_prec = nj_min" using gr0_conv_Suc by auto
     then have njm_prec_njm: "njm_prec < nj_min" by blast
     then have njm_prec_njm_enat: "enat njm_prec < enat nj_min" by simp
     have njm_prec_smaller_d: "njm_prec < llength Ns"
       by (rule less_trans[OF njm_prec_njm_enat njm_smaller_D])
     have njm_prec_all_suc: "\<forall>k>njm_prec. enat k < llength Ns \<longrightarrow> (C, active) \<in> lnth Ns k"
       using nj_prec_is in_allk by simp
     have notin_njm_prec: "(C, active) \<notin> lnth Ns njm_prec"
     proof (rule ccontr)
       assume "\<not> (C, active) \<notin> lnth Ns njm_prec"
       then have absurd_hyp: "(C, active) \<in> lnth Ns njm_prec" by simp
       have prec_smaller: "enat njm_prec < llength Ns" using nj_min_is nj_prec_is
         by (smt LeastI_ex Suc_leD \<open>\<And>thesis. (\<And>nj. \<lbrakk>enat nj < llength Ns;
             (C, active) \<in> \<Inter> (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns})\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
             enat_ord_simps(1) le_eq_less_or_eq le_less_trans)
       have "(C, active) \<in> \<Inter> (lnth Ns ` {k. njm_prec \<le> k \<and> enat k < llength Ns})"
       proof -
         {
           fix k
           assume k_in: "njm_prec \<le> k \<and> enat k < llength Ns"
           have "k = njm_prec \<Longrightarrow> (C, active) \<in> lnth Ns k" using absurd_hyp by simp
           moreover have "njm_prec < k \<Longrightarrow> (C, active) \<in> lnth Ns k"
             using nj_prec_is in_allk k_in by simp
           ultimately have "(C, active) \<in> lnth Ns k" using k_in by fastforce
         }
         then show "(C, active) \<in> \<Inter> (lnth Ns ` {k. njm_prec \<le> k \<and> enat k < llength Ns})" by blast
       qed
       then have "enat njm_prec < llength Ns \<and>
           (C, active) \<in> \<Inter> (lnth Ns ` {k. njm_prec \<le> k \<and> enat k < llength Ns})"
         using prec_smaller by blast
       then show False
         using nj_min_is nj_prec_is Orderings.wellorder_class.not_less_Least njm_prec_njm by blast
     qed
     then have notin_active_subs_njm_prec: "(C, active) \<notin> active_subset (lnth Ns njm_prec)"
       unfolding active_subset_def by blast
     then show "\<exists>nj. enat (Suc nj) < llength Ns \<and> prems_of \<iota> ! j \<notin> active_subset (lnth Ns nj) \<and>
         (\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j \<in> active_subset (lnth Ns k))"
       using c_is njm_prec_all_suc njm_prec_smaller_d by (metis (mono_tags, lifting)
           active_subset_def mem_Collect_eq nj_prec_is njm_smaller_D snd_conv)
   qed
   define nj_set where "nj_set = {nj. (\<exists>j\<in>{0..<m}. enat (Suc nj) < llength Ns \<and>
       prems_of \<iota> ! j \<notin> active_subset (lnth Ns nj) \<and>
       (\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j \<in> active_subset (lnth Ns k)))}"
   then have nj_not_empty: "nj_set \<noteq> {}"
   proof -
     have zero_in: "0 \<in> {0..<m}" using m_pos by simp
     then obtain n0 where "enat (Suc n0) < llength Ns" and
       "prems_of \<iota> ! 0 \<notin> active_subset (lnth Ns n0)" and
       "\<forall>k>n0. enat k < llength Ns \<longrightarrow> prems_of \<iota> ! 0 \<in> active_subset (lnth Ns k)"
       using exist_nj by fast
     then have "n0 \<in> nj_set" unfolding nj_set_def using zero_in by blast
     then show "nj_set \<noteq> {}" by auto
   qed
   have nj_finite: "finite nj_set"
     using all_ex_finite_set[OF exist_nj]
     by (metis (no_types, lifting) Suc_ile_eq dual_order.strict_implies_order
         linorder_neqE_nat nj_set_def)
       (* the n below in the n-1 from the pen-and-paper proof *)
   have "\<exists>n \<in> nj_set. \<forall>nj \<in> nj_set. nj \<le> n"
     using nj_not_empty nj_finite using Max_ge Max_in by blast
   then obtain n where n_in: "n \<in> nj_set" and n_bigger: "\<forall>nj \<in> nj_set. nj \<le> n" by blast
   then obtain j0 where j0_in: "j0 \<in> {0..<m}" and suc_n_length: "enat (Suc n) < llength Ns" and
     j0_notin: "prems_of \<iota> ! j0 \<notin> active_subset (lnth Ns n)" and
     j0_allin: "(\<forall>k. k > n \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j0 \<in> active_subset (lnth Ns k))"
     unfolding nj_set_def by blast
   obtain C0 where C0_is: "prems_of \<iota> ! j0 = (C0, active)" using j0_in
     using i_in2 unfolding m_def Inf_from_def active_subset_def
     by (smt Collect_mem_eq Collect_mono_iff atLeastLessThan_iff nth_mem old.prod.exhaust snd_conv)
   then have C0_prems_i: "(C0, active) \<in> set (prems_of \<iota>)" using in_set_conv_nth j0_in m_def by force
   have C0_in: "(C0, active) \<in> (lnth Ns (Suc n))"
     using C0_is j0_allin suc_n_length by (simp add: active_subset_def)
   have C0_notin: "(C0, active) \<notin> (lnth Ns n)" using C0_is j0_notin unfolding active_subset_def by simp
   have step_n: "lnth Ns n \<leadsto>GC lnth Ns (Suc n)"
     using deriv chain_lnth_rel n_in unfolding nj_set_def by blast
   have "\<exists>N C L M. (lnth Ns n = N \<union> {(C, L)} \<and>
       lnth Ns (Suc n) = N \<union> {(C, active)} \<union> M \<and> L \<noteq> active \<and> active_subset M = {} \<and>
       no_labels.Inf_between (fst ` active_subset N) {C}
       \<subseteq> no_labels.Red_I (fst ` (N \<union> {(C, active)} \<union> M)))"
   proof -
     have proc_or_infer: "(\<exists>N1 N M N2 M'. lnth Ns n = N1 \<and> lnth Ns (Suc n) = N2 \<and> N1 = N \<union> M \<and>
          N2 = N \<union> M' \<and> M \<subseteq> Red_F (N \<union> M') \<and> active_subset M' = {}) \<or>
        (\<exists>N1 N C L N2 M. lnth Ns n = N1 \<and> lnth Ns (Suc n) = N2 \<and> N1 = N \<union> {(C, L)} \<and>
          N2 = N \<union> {(C, active)} \<union> M \<and> L \<noteq> active \<and> active_subset M = {} \<and>
          no_labels.Inf_between (fst ` active_subset N) {C} \<subseteq>
            no_labels.Red_I (fst ` (N \<union> {(C, active)} \<union> M)))"
       using step.simps[of "lnth Ns n" "lnth Ns (Suc n)"] step_n by blast
     show ?thesis
       using C0_in C0_notin proc_or_infer j0_in C0_is
       by (smt Un_iff active_subset_def mem_Collect_eq snd_conv sup_bot.right_neutral)
   qed
   then obtain N M L where inf_from_subs:
     "no_labels.Inf_between (fst ` active_subset N) {C0}
      \<subseteq> no_labels.Red_I (fst ` (N \<union> {(C0, active)} \<union> M))" and
     nth_d_is: "lnth Ns n = N \<union> {(C0, L)}" and
     suc_nth_d_is: "lnth Ns (Suc n) = N \<union> {(C0, active)} \<union> M" and
     l_not_active: "L \<noteq> active"
     using C0_in C0_notin j0_in C0_is using active_subset_def by fastforce
   have "j \<in> {0..<m} \<Longrightarrow> prems_of \<iota> ! j \<noteq> prems_of \<iota> ! j0 \<Longrightarrow> prems_of \<iota> ! j \<in> (active_subset N)" for j
   proof -
     fix j
     assume j_in: "j \<in> {0..<m}" and
       j_not_j0: "prems_of \<iota> ! j \<noteq> prems_of \<iota> ! j0"
     obtain nj where nj_len: "enat (Suc nj) < llength Ns" and
       nj_prems: "prems_of \<iota> ! j \<notin> active_subset (lnth Ns nj)" and
       nj_greater: "(\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j \<in> active_subset (lnth Ns k))"
       using exist_nj j_in by blast
     then have "nj \<in> nj_set" unfolding nj_set_def using j_in by blast
     moreover have "nj \<noteq> n"
     proof (rule ccontr)
       assume "\<not> nj \<noteq> n"
       then have "prems_of \<iota> ! j = (C0, active)"
         using C0_in C0_notin step.simps[of "lnth Ns n" "lnth Ns (Suc n)"] step_n
         by (smt Un_iff nth_d_is suc_nth_d_is l_not_active active_subset_def insertCI insertE lessI
             mem_Collect_eq nj_greater nj_prems snd_conv suc_n_length)
       then show False using j_not_j0 C0_is by simp
     qed
     ultimately have "nj < n" using n_bigger by force
     then have "prems_of \<iota> ! j \<in> (active_subset (lnth Ns n))"
       using nj_greater n_in Suc_ile_eq dual_order.strict_implies_order unfolding nj_set_def by blast
     then show "prems_of \<iota> ! j \<in> (active_subset N)"
       using nth_d_is l_not_active unfolding active_subset_def by force
   qed
   then have "set (prems_of \<iota>) \<subseteq> active_subset N \<union> {(C0, active)}"
     using C0_prems_i C0_is m_def
     by (metis Un_iff atLeast0LessThan in_set_conv_nth insertCI lessThan_iff subrelI)
   moreover have "\<not> (set (prems_of \<iota>) \<subseteq> active_subset N - {(C0, active)})" using C0_prems_i by blast
   ultimately have "\<iota> \<in> Inf_between (active_subset N) {(C0, active)}"
     using i_in_inf_fl unfolding Inf_between_def Inf_from_def by blast
   then have "to_F \<iota> \<in> no_labels.Inf_between (fst ` active_subset N) {C0}"
     unfolding to_F_def Inf_between_def Inf_from_def
       no_labels.Inf_between_def no_labels.Inf_from_def using Inf_FL_to_Inf_F
     by force
   then have "to_F \<iota> \<in> no_labels.Red_I (fst ` (lnth Ns (Suc n)))"
     using suc_nth_d_is inf_from_subs by fastforce
   then have "\<forall>q \<in> Q. (\<G>_I_q q (to_F \<iota>) \<noteq> None \<and>
       the (\<G>_I_q q (to_F \<iota>)) \<subseteq> Red_I_q q (\<Union> (\<G>_F_q q ` fst ` lnth Ns (Suc n))))
       \<or> (\<G>_I_q q (to_F \<iota>) = None \<and>
       \<G>_F_q q (concl_of (to_F \<iota>)) \<subseteq> \<Union> (\<G>_F_q q ` fst ` lnth Ns (Suc n)) \<union>
         Red_F_q q (\<Union> (\<G>_F_q q ` fst ` lnth Ns (Suc n))))"
     unfolding to_F_def no_labels.Red_I_def no_labels.Red_I_\<G>_q_def by blast
   then have "\<iota> \<in> Red_I_\<G> (lnth Ns (Suc n))"
     using i_in_inf_fl unfolding Red_I_\<G>_def Red_I_\<G>_q_def by (simp add: to_F_def)
   then show "\<iota> \<in> Sup_llist (lmap Red_I_\<G> Ns)"
     unfolding Sup_llist_def using suc_n_length by auto
 qed
 
 theorem gc_complete_Liminf:
   assumes
     deriv: "chain (\<leadsto>GC) Ns" and
     init_state: "active_subset (lhd Ns) = {}" and
     final_state: "passive_subset (Liminf_llist Ns) = {}" and
     b_in: "B \<in> Bot_F" and
     bot_entailed: "no_labels.entails_\<G> (fst ` lhd Ns) {B}"
   shows "\<exists>BL \<in> Bot_FL. BL \<in> Liminf_llist Ns"
 proof -
   note lhd_is = lhd_conv_lnth[OF chain_not_lnull[OF deriv]]
   have labeled_b_in: "(B, active) \<in> Bot_FL" using b_in by simp
   have labeled_bot_entailed: "entails_\<G>_L (lhd Ns) {(B, active)}"
     using labeled_entailment_lifting bot_entailed lhd_is by fastforce
   have fair: "fair Ns" using gc_fair[OF deriv init_state final_state] .
   then show ?thesis
     using dynamically_complete_Liminf[OF labeled_b_in gc_to_red[OF deriv] fair
         labeled_bot_entailed]
     by blast
 qed
 
 (* thm:gc-completeness *)
 theorem gc_complete:
   assumes
     deriv: "chain (\<leadsto>GC) Ns" and
     init_state: "active_subset (lhd Ns) = {}" and
     final_state: "passive_subset (Liminf_llist Ns) = {}" and
     b_in: "B \<in> Bot_F" and
     bot_entailed: "no_labels.entails_\<G> (fst ` lhd Ns) {B}"
   shows "\<exists>i. enat i < llength Ns \<and> (\<exists>BL \<in> Bot_FL. BL \<in> lnth Ns i)"
 proof -
   note lhd_is = lhd_conv_lnth[OF chain_not_lnull[OF deriv]]
   have "\<exists>BL\<in>Bot_FL. BL \<in> Liminf_llist Ns"
     using assms by (rule gc_complete_Liminf)
   then show ?thesis
     unfolding Liminf_llist_def by auto
 qed
 
 end
 
 
 subsection \<open>Lazy Given Clause Procedure\<close>
 
 locale lazy_given_clause = given_clause_basis Bot_F Inf_F Bot_G Q entails_q Inf_G_q Red_I_q
   Red_F_q \<G>_F_q \<G>_I_q Equiv_F Prec_F Prec_L active
   for
     Bot_F :: "'f set" and
     Inf_F :: "'f inference set" and
     Bot_G :: "'g set" and
     Q :: "'q set" and
     entails_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g set \<Rightarrow> bool" and
     Inf_G_q :: \<open>'q \<Rightarrow> 'g inference set\<close> and
     Red_I_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g inference set" and
     Red_F_q :: "'q \<Rightarrow> 'g set \<Rightarrow> 'g set" and
     \<G>_F_q :: "'q \<Rightarrow> 'f \<Rightarrow> 'g set"  and
     \<G>_I_q :: "'q \<Rightarrow> 'f inference \<Rightarrow> 'g inference set option" and
     Equiv_F :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<doteq>" 50) and
     Prec_F :: "'f \<Rightarrow> 'f \<Rightarrow> bool" (infix "\<prec>\<cdot>" 50) and
     Prec_L :: "'l \<Rightarrow> 'l \<Rightarrow> bool" (infix "\<sqsubset>L" 50) and
     active :: 'l
 begin
 
 inductive step :: "'f inference set \<times> ('f \<times> 'l) set \<Rightarrow>
   'f inference set \<times> ('f \<times> 'l) set \<Rightarrow> bool" (infix "\<leadsto>LGC" 50) where
   process: "N1 = N \<union> M \<Longrightarrow> N2 = N \<union> M' \<Longrightarrow> M \<subseteq> Red_F (N \<union> M') \<Longrightarrow>
     active_subset M' = {} \<Longrightarrow> (T, N1) \<leadsto>LGC (T, N2)" |
   schedule_infer: "T2 = T1 \<union> T' \<Longrightarrow> N1 = N \<union> {(C, L)} \<Longrightarrow> N2 = N \<union> {(C, active)} \<Longrightarrow>
     L \<noteq> active \<Longrightarrow> T' = no_labels.Inf_between (fst ` active_subset N) {C} \<Longrightarrow>
     (T1, N1) \<leadsto>LGC (T2, N2)" |
   compute_infer: "T1 = T2 \<union> {\<iota>} \<Longrightarrow> N2 = N1 \<union> M \<Longrightarrow> active_subset M = {} \<Longrightarrow>
     \<iota> \<in> no_labels.Red_I (fst ` (N1 \<union> M)) \<Longrightarrow> (T1, N1) \<leadsto>LGC (T2, N2)" |
   delete_orphan_infers: "T1 = T2 \<union> T' \<Longrightarrow>
     T' \<inter> no_labels.Inf_from (fst ` active_subset N) = {} \<Longrightarrow> (T1, N) \<leadsto>LGC (T2, N)"
 
 lemma premise_free_inf_always_from: "\<iota> \<in> Inf_F \<Longrightarrow> prems_of \<iota> = [] \<Longrightarrow> \<iota> \<in> no_labels.Inf_from N"
   unfolding no_labels.Inf_from_def by simp
 
 lemma one_step_equiv: "(T1, N1) \<leadsto>LGC (T2, N2) \<Longrightarrow> N1 \<rhd>L N2"
 proof (cases "(T1, N1)" "(T2, N2)" rule: step.cases)
   show "(T1, N1) \<leadsto>LGC (T2, N2) \<Longrightarrow> (T1, N1) \<leadsto>LGC (T2, N2)" by blast
 next
   fix N M M'
   assume
     n1_is: "N1 = N \<union> M" and
     n2_is: "N2 = N \<union> M'" and
     m_red: "M \<subseteq> Red_F (N \<union> M')"
   have "N1 - N2 \<subseteq> Red_F N2"
     using n1_is n2_is m_red by auto
   then show "N1 \<rhd>L N2"
     unfolding derive.simps by blast
 next
   fix N C L M
   assume
     n1_is: "N1 = N \<union> {(C, L)}" and
     not_active: "L \<noteq> active" and
     n2_is: "N2 = N \<union> {(C, active)}"
   have "(C, active) \<in> N2" using n2_is by auto
   moreover have "C \<preceq>\<cdot> C" by (metis equivp_def equiv_equiv_F)
   moreover have "active \<sqsubset>L L" using active_minimal[OF not_active] .
   ultimately have "{(C, L)} \<subseteq> Red_F N2"
     using red_labeled_clauses by blast
   then have "N1 - N2 \<subseteq> Red_F N2"
     using std_Red_F_eq using n1_is n2_is by blast
   then show "N1 \<rhd>L N2"
     unfolding derive.simps by blast
 next
   fix M
   assume
     n2_is: "N2 = N1 \<union> M"
   have "N1 - N2 \<subseteq> Red_F N2"
     using n2_is by blast
   then show "N1 \<rhd>L N2"
     unfolding derive.simps by blast
 next
   assume n2_is: "N2 = N1"
   have "N1 - N2 \<subseteq> Red_F N2"
     using n2_is by blast
   then show "N1 \<rhd>L N2"
     unfolding derive.simps by blast
 qed
 
 (* lem:lgc-derivations-are-red-derivations *)
 lemma lgc_to_red: "chain (\<leadsto>LGC) Ns \<Longrightarrow> chain (\<rhd>L) (lmap snd Ns)"
   using one_step_equiv Lazy_List_Chain.chain_mono by (smt chain_lmap prod.collapse)
 
 (* lem:fair-lgc-derivations *)
 lemma lgc_fair:
   assumes
     deriv: "chain (\<leadsto>LGC) Ns" and
     init_state: "active_subset (snd (lhd Ns)) = {}" and
     final_state: "passive_subset (Liminf_llist (lmap snd Ns)) = {}" and
     no_prems_init: "\<forall>\<iota> \<in> Inf_F. prems_of \<iota> = [] \<longrightarrow> \<iota> \<in> fst (lhd Ns)" and
     final_schedule: "Liminf_llist (lmap fst Ns) = {}"
   shows "fair (lmap snd Ns)"
   unfolding fair_def
 proof
   fix \<iota>
   assume i_in: "\<iota> \<in> Inf_from (Liminf_llist (lmap snd Ns))"
   note lhd_is = lhd_conv_lnth[OF chain_not_lnull[OF deriv]]
   have i_in_inf_fl: "\<iota> \<in> Inf_FL" using i_in unfolding Inf_from_def by blast
   have "Liminf_llist (lmap snd Ns) = active_subset (Liminf_llist (lmap snd Ns))"
     using final_state unfolding passive_subset_def active_subset_def by blast
   then have i_in2: "\<iota> \<in> Inf_from (active_subset (Liminf_llist (lmap snd Ns)))"
     using i_in by simp
   define m where "m = length (prems_of \<iota>)"
   then have m_def_F: "m = length (prems_of (to_F \<iota>))" unfolding to_F_def by simp
   have i_in_F: "to_F \<iota> \<in> Inf_F"
     using i_in Inf_FL_to_Inf_F unfolding Inf_from_def to_F_def by blast
   have exist_nj: "\<forall>j \<in> {0..<m}. (\<exists>nj. enat (Suc nj) < llength Ns \<and>
       prems_of \<iota> ! j \<notin> active_subset (snd (lnth Ns nj)) \<and>
       (\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k))))"
   proof clarify
     fix j
     assume j_in: "j \<in> {0..<m}"
     then obtain C where c_is: "(C, active) = prems_of \<iota> ! j"
       using i_in2 unfolding m_def Inf_from_def active_subset_def
       by (smt Collect_mem_eq Collect_mono_iff atLeastLessThan_iff nth_mem old.prod.exhaust snd_conv)
     then have "(C, active) \<in> Liminf_llist (lmap snd Ns)"
       using j_in i_in unfolding m_def Inf_from_def by force
     then obtain nj where nj_is: "enat nj < llength Ns" and
       c_in2: "(C, active) \<in> \<Inter> (snd ` (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns}))"
       unfolding Liminf_llist_def using init_state by fastforce
     then have c_in3: "\<forall>k. k \<ge> nj \<longrightarrow> enat k < llength Ns \<longrightarrow> (C, active) \<in> snd (lnth Ns k)" by blast
     have nj_pos: "nj > 0" using init_state c_in2 nj_is unfolding active_subset_def lhd_is by fastforce
     obtain nj_min where nj_min_is: "nj_min = (LEAST nj. enat nj < llength Ns \<and>
         (C, active) \<in> \<Inter> (snd ` (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns})))" by blast
     then have in_allk: "\<forall>k. k \<ge> nj_min \<longrightarrow> enat k < llength Ns \<longrightarrow> (C, active) \<in> snd (lnth Ns k)"
       using c_in3 nj_is c_in2 INT_E LeastI_ex
         [of "\<lambda>n. enat n < llength Ns
             \<and> (C, active) \<in> \<Inter> (snd ` lnth Ns ` {na. n \<le> na \<and> enat na < llength Ns})"]
       by blast
     have njm_smaller_D: "enat nj_min < llength Ns"
       using nj_min_is
       by (smt LeastI_ex \<open>\<And>thesis. (\<And>nj. \<lbrakk>enat nj < llength Ns;
           (C, active) \<in> \<Inter> (snd ` (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns}))\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>)
     have "nj_min > 0"
       using nj_is c_in2 nj_pos nj_min_is lhd_is
       by (metis (mono_tags, lifting) active_subset_def emptyE in_allk init_state mem_Collect_eq
           not_less snd_conv zero_enat_def chain_length_pos[OF deriv])
     then obtain njm_prec where nj_prec_is: "Suc njm_prec = nj_min" using gr0_conv_Suc by auto
     then have njm_prec_njm: "njm_prec < nj_min" by blast
     then have njm_prec_njm_enat: "enat njm_prec < enat nj_min" by simp
     have njm_prec_smaller_d: "njm_prec < llength Ns"
       by (rule less_trans[OF njm_prec_njm_enat njm_smaller_D])
     have njm_prec_all_suc: "\<forall>k>njm_prec. enat k < llength Ns \<longrightarrow> (C, active) \<in> snd (lnth Ns k)"
       using nj_prec_is in_allk by simp
     have notin_njm_prec: "(C, active) \<notin> snd (lnth Ns njm_prec)"
     proof (rule ccontr)
       assume "\<not> (C, active) \<notin> snd (lnth Ns njm_prec)"
       then have absurd_hyp: "(C, active) \<in> snd (lnth Ns njm_prec)" by simp
       have prec_smaller: "enat njm_prec < llength Ns" using nj_min_is nj_prec_is
         by (smt LeastI_ex Suc_leD \<open>\<And>thesis. (\<And>nj. \<lbrakk>enat nj < llength Ns;
             (C, active) \<in> \<Inter> (snd ` (lnth Ns ` {k. nj \<le> k \<and> enat k < llength Ns}))\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
             enat_ord_simps(1) le_eq_less_or_eq le_less_trans)
       have "(C, active) \<in> \<Inter> (snd ` (lnth Ns ` {k. njm_prec \<le> k \<and> enat k < llength Ns}))"
       proof -
         {
           fix k
           assume k_in: "njm_prec \<le> k \<and> enat k < llength Ns"
           have "k = njm_prec \<Longrightarrow> (C, active) \<in> snd (lnth Ns k)" using absurd_hyp by simp
           moreover have "njm_prec < k \<Longrightarrow> (C, active) \<in> snd (lnth Ns k)"
             using nj_prec_is in_allk k_in by simp
           ultimately have "(C, active) \<in> snd (lnth Ns k)" using k_in by fastforce
         }
         then show "(C, active) \<in> \<Inter> (snd ` (lnth Ns ` {k. njm_prec \<le> k \<and> enat k < llength Ns}))"
           by blast
       qed
       then have "enat njm_prec < llength Ns \<and>
           (C, active) \<in> \<Inter> (snd ` (lnth Ns ` {k. njm_prec \<le> k \<and> enat k < llength Ns}))"
         using prec_smaller by blast
       then show False
         using nj_min_is nj_prec_is Orderings.wellorder_class.not_less_Least njm_prec_njm by blast
     qed
     then have notin_active_subs_njm_prec: "(C, active) \<notin> active_subset (snd (lnth Ns njm_prec))"
       unfolding active_subset_def by blast
     then show "\<exists>nj. enat (Suc nj) < llength Ns \<and> prems_of \<iota> ! j \<notin> active_subset (snd (lnth Ns nj)) \<and>
         (\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k)))"
       using c_is njm_prec_all_suc njm_prec_smaller_d by (metis (mono_tags, lifting)
           active_subset_def mem_Collect_eq nj_prec_is njm_smaller_D snd_conv)
   qed
   define nj_set where "nj_set = {nj. (\<exists>j\<in>{0..<m}. enat (Suc nj) < llength Ns \<and>
       prems_of \<iota> ! j \<notin> active_subset (snd (lnth Ns nj)) \<and>
       (\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow> prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k))))}"
   {
     assume m_null: "m = 0"
     then have "enat 0 < llength Ns \<and> to_F \<iota> \<in> fst (lhd Ns)"
       using no_prems_init i_in_F m_def_F zero_enat_def chain_length_pos[OF deriv] by auto
     then have "\<exists>n. enat n < llength Ns \<and> to_F \<iota> \<in> fst (lnth Ns n)"
       unfolding lhd_is by blast
   }
   moreover {
     assume m_pos: "m > 0"
     have nj_not_empty: "nj_set \<noteq> {}"
     proof -
       have zero_in: "0 \<in> {0..<m}" using m_pos by simp
       then obtain n0 where "enat (Suc n0) < llength Ns" and
         "prems_of \<iota> ! 0 \<notin> active_subset (snd (lnth Ns n0))" and
         "\<forall>k>n0. enat k < llength Ns \<longrightarrow> prems_of \<iota> ! 0 \<in> active_subset (snd (lnth Ns k))"
         using exist_nj by fast
       then have "n0 \<in> nj_set" unfolding nj_set_def using zero_in by blast
       then show "nj_set \<noteq> {}" by auto
     qed
     have nj_finite: "finite nj_set"
       using all_ex_finite_set[OF exist_nj] by (metis (no_types, lifting) Suc_ile_eq
           dual_order.strict_implies_order linorder_neqE_nat nj_set_def)
     have "\<exists>n \<in> nj_set. \<forall>nj \<in> nj_set. nj \<le> n"
       using nj_not_empty nj_finite using Max_ge Max_in by blast
     then obtain n where n_in: "n \<in> nj_set" and n_bigger: "\<forall>nj \<in> nj_set. nj \<le> n" by blast
     then obtain j0 where j0_in: "j0 \<in> {0..<m}" and suc_n_length: "enat (Suc n) < llength Ns" and
       j0_notin: "prems_of \<iota> ! j0 \<notin> active_subset (snd (lnth Ns n))" and
       j0_allin: "(\<forall>k. k > n \<longrightarrow> enat k < llength Ns \<longrightarrow>
           prems_of \<iota> ! j0 \<in> active_subset (snd (lnth Ns k)))"
       unfolding nj_set_def by blast
     obtain C0 where C0_is: "prems_of \<iota> ! j0 = (C0, active)"
       using j0_in i_in2 unfolding m_def Inf_from_def active_subset_def
       by (smt Collect_mem_eq Collect_mono_iff atLeastLessThan_iff nth_mem old.prod.exhaust snd_conv)
     then have C0_prems_i: "(C0, active) \<in> set (prems_of \<iota>)" using in_set_conv_nth j0_in m_def by force
     have C0_in: "(C0, active) \<in> (snd (lnth Ns (Suc n)))"
       using C0_is j0_allin suc_n_length by (simp add: active_subset_def)
     have C0_notin: "(C0, active) \<notin> (snd (lnth Ns n))"
       using C0_is j0_notin unfolding active_subset_def by simp
     have step_n: "lnth Ns n \<leadsto>LGC lnth Ns (Suc n)"
       using deriv chain_lnth_rel n_in unfolding nj_set_def by blast
     have is_scheduled: "\<exists>T2 T1 T' N1 N C L N2. lnth Ns n = (T1, N1) \<and> lnth Ns (Suc n) = (T2, N2) \<and>
         T2 = T1 \<union> T' \<and> N1 = N \<union> {(C, L)} \<and> N2 = N \<union> {(C, active)} \<and> L \<noteq> active \<and>
         T' = no_labels.Inf_between (fst ` active_subset N) {C}"
       using step.simps[of "lnth Ns n" "lnth Ns (Suc n)"] step_n C0_in C0_notin
       unfolding active_subset_def by fastforce
     then obtain T2 T1 T' N1 N L N2 where nth_d_is: "lnth Ns n = (T1, N1)" and
       suc_nth_d_is: "lnth Ns (Suc n) = (T2, N2)" and t2_is: "T2 = T1 \<union> T'" and
       n1_is: "N1 = N \<union> {(C0, L)}" "N2 = N \<union> {(C0, active)}" and
       l_not_active: "L \<noteq> active" and
       tp_is: "T' = no_labels.Inf_between (fst ` active_subset N) {C0}"
       using C0_in C0_notin j0_in C0_is using active_subset_def by fastforce
     have "j \<in> {0..<m} \<Longrightarrow> prems_of \<iota> ! j \<noteq> prems_of \<iota> ! j0 \<Longrightarrow> prems_of \<iota> ! j \<in> (active_subset N)"
       for j
     proof -
       fix j
       assume j_in: "j \<in> {0..<m}" and
         j_not_j0: "prems_of \<iota> ! j \<noteq> prems_of \<iota> ! j0"
       obtain nj where nj_len: "enat (Suc nj) < llength Ns" and
         nj_prems: "prems_of \<iota> ! j \<notin> active_subset (snd (lnth Ns nj))" and
         nj_greater: "(\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow>
             prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k)))"
         using exist_nj j_in by blast
       then have "nj \<in> nj_set" unfolding nj_set_def using j_in by blast
       moreover have "nj \<noteq> n"
       proof (rule ccontr)
         assume "\<not> nj \<noteq> n"
         then have "prems_of \<iota> ! j = (C0, active)"
           using C0_in C0_notin step.simps[of "lnth Ns n" "lnth Ns (Suc n)"] step_n
             active_subset_def is_scheduled nj_greater nj_prems suc_n_length by auto
         then show False using j_not_j0 C0_is by simp
       qed
       ultimately have "nj < n" using n_bigger by force
       then have "prems_of \<iota> ! j \<in> (active_subset (snd (lnth Ns n)))"
         using nj_greater n_in Suc_ile_eq dual_order.strict_implies_order
         unfolding nj_set_def by blast
       then show "prems_of \<iota> ! j \<in> (active_subset N)"
         using nth_d_is l_not_active n1_is unfolding active_subset_def by force
     qed
     then have prems_i_active: "set (prems_of \<iota>) \<subseteq> active_subset N \<union> {(C0, active)}"
       using C0_prems_i C0_is m_def
       by (metis Un_iff atLeast0LessThan in_set_conv_nth insertCI lessThan_iff subrelI)
     moreover have "\<not> (set (prems_of \<iota>) \<subseteq> active_subset N - {(C0, active)})" using C0_prems_i by blast
     ultimately have "\<iota> \<in> Inf_between (active_subset N) {(C0, active)}"
       using i_in_inf_fl prems_i_active unfolding Inf_between_def Inf_from_def by blast
     then have "to_F \<iota> \<in> no_labels.Inf_between (fst ` active_subset N) {C0}"
       unfolding to_F_def Inf_between_def Inf_from_def
         no_labels.Inf_between_def no_labels.Inf_from_def
       using Inf_FL_to_Inf_F by force
     then have i_in_t2: "to_F \<iota> \<in> T2" using tp_is t2_is by simp
     have "j \<in> {0..<m} \<Longrightarrow> (\<forall>k. k > n \<longrightarrow> enat k < llength Ns \<longrightarrow>
         prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k)))" for j
     proof (cases "j = j0")
       case True
       assume "j = j0"
       then show "(\<forall>k. k > n \<longrightarrow> enat k < llength Ns \<longrightarrow>
           prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k)))" using j0_allin by simp
     next
       case False
       assume j_in: "j \<in> {0..<m}" and
         "j \<noteq> j0"
       obtain nj where nj_len: "enat (Suc nj) < llength Ns" and
         nj_prems: "prems_of \<iota> ! j \<notin> active_subset (snd (lnth Ns nj))" and
         nj_greater: "(\<forall>k. k > nj \<longrightarrow> enat k < llength Ns \<longrightarrow>
             prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k)))"
         using exist_nj j_in by blast
       then have "nj \<in> nj_set" unfolding nj_set_def using j_in by blast
       then show "(\<forall>k. k > n \<longrightarrow> enat k < llength Ns \<longrightarrow>
           prems_of \<iota> ! j \<in> active_subset (snd (lnth Ns k)))"
         using nj_greater n_bigger by auto
     qed
     then have allj_allk: "(\<forall>c\<in> set (prems_of \<iota>). (\<forall>k. k > n \<longrightarrow> enat k < llength Ns \<longrightarrow>
         c \<in> active_subset (snd (lnth Ns k))))"
       using m_def by (metis atLeast0LessThan in_set_conv_nth lessThan_iff)
     have "\<forall>c\<in> set (prems_of \<iota>). snd c = active"
       using prems_i_active unfolding active_subset_def by auto
     then have ex_n_i_in: "\<exists>n. enat (Suc n) < llength Ns \<and> to_F \<iota> \<in> fst (lnth Ns (Suc n)) \<and>
         (\<forall>c\<in> set (prems_of \<iota>). snd c = active) \<and>
         (\<forall>c\<in> set (prems_of \<iota>). (\<forall>k. k > n \<longrightarrow> enat k < llength Ns \<longrightarrow>
           c \<in> active_subset (snd (lnth Ns k))))"
       using allj_allk i_in_t2 suc_nth_d_is fstI n_in nj_set_def
       by auto
     then have "\<exists>n. enat n < llength Ns \<and> to_F \<iota> \<in> fst (lnth Ns n) \<and>
         (\<forall>c\<in> set (prems_of \<iota>). snd c = active) \<and> (\<forall>c\<in> set (prems_of \<iota>). (\<forall>k. k \<ge> n \<longrightarrow>
           enat k < llength Ns \<longrightarrow> c \<in> active_subset (snd (lnth Ns k))))"
       by auto
   }
   ultimately obtain n T2 N2 where i_in_suc_n: "to_F \<iota> \<in> fst (lnth Ns n)" and
     all_prems_active_after: "m > 0 \<Longrightarrow> (\<forall>c\<in> set (prems_of \<iota>). (\<forall>k. k \<ge> n \<longrightarrow> enat k < llength Ns \<longrightarrow>
                   c \<in> active_subset (snd (lnth Ns k))))" and
     suc_n_length: "enat n < llength Ns" and suc_nth_d_is: "lnth Ns n = (T2, N2)"
     by (metis less_antisym old.prod.exhaust zero_less_Suc)
   then have i_in_t2: "to_F \<iota> \<in> T2" by simp
   have "\<exists>p\<ge>n. enat (Suc p) < llength Ns \<and> to_F \<iota> \<in> (fst (lnth Ns p)) \<and> to_F \<iota> \<notin> (fst (lnth Ns (Suc p)))"
   proof (rule ccontr)
     assume
       contra: "\<not> (\<exists>p\<ge>n. enat (Suc p) < llength Ns \<and> to_F \<iota> \<in> (fst (lnth Ns p)) \<and>
                      to_F \<iota> \<notin> (fst (lnth Ns (Suc p))))"
     then have i_in_suc: "p0 \<ge> n \<Longrightarrow> enat (Suc p0) < llength Ns \<Longrightarrow> to_F \<iota> \<in> (fst (lnth Ns p0)) \<Longrightarrow>
         to_F \<iota> \<in> (fst (lnth Ns (Suc p0)))" for p0
       by blast
     have "p0 \<ge> n \<Longrightarrow> enat p0 < llength Ns \<Longrightarrow> to_F \<iota> \<in> (fst (lnth Ns p0))" for p0
     proof (induction rule: nat_induct_at_least)
       case base
       then show ?case using i_in_t2 suc_nth_d_is
         by simp
     next
       case (Suc p0)
       assume p_bigger_n: "n \<le> p0" and
         induct_hyp: "enat p0 < llength Ns \<Longrightarrow> to_F \<iota> \<in> fst (lnth Ns p0)" and
         sucsuc_smaller_d: "enat (Suc p0) < llength Ns"
       have suc_p_bigger_n: "n \<le> p0" using p_bigger_n by simp
       have suc_smaller_d: "enat p0 < llength Ns"
         using sucsuc_smaller_d Suc_ile_eq dual_order.strict_implies_order by blast
       then have "to_F \<iota> \<in> fst (lnth Ns p0)" using induct_hyp by blast
       then show ?case using i_in_suc[OF suc_p_bigger_n sucsuc_smaller_d] by blast
     qed
     then have i_in_all_bigger_n: "\<forall>j. j \<ge> n \<and> enat j < llength Ns \<longrightarrow> to_F \<iota> \<in> (fst (lnth Ns j))"
       by presburger
     have "llength (lmap fst Ns) = llength Ns" by force
     then have "to_F \<iota> \<in> \<Inter> (lnth (lmap fst Ns) ` {j. n \<le> j \<and> enat j < llength (lmap fst Ns)})"
       using i_in_all_bigger_n using Suc_le_D by auto
     then have "to_F \<iota> \<in> Liminf_llist (lmap fst Ns)"
       unfolding Liminf_llist_def using suc_n_length by auto
     then show False using final_schedule by fast
   qed
   then obtain p where p_greater_n: "p \<ge> n" and p_smaller_d: "enat (Suc p) < llength Ns" and
     i_in_p: "to_F \<iota> \<in> (fst (lnth Ns p))" and i_notin_suc_p: "to_F \<iota> \<notin> (fst (lnth Ns (Suc p)))"
     by blast
   have p_neq_n: "Suc p \<noteq> n" using i_notin_suc_p i_in_suc_n by blast
   have step_p: "lnth Ns p \<leadsto>LGC lnth Ns (Suc p)" using deriv p_smaller_d chain_lnth_rel by blast
   then have "\<exists>T1 T2 \<iota> N2 N1 M. lnth Ns p = (T1, N1) \<and> lnth Ns (Suc p) = (T2, N2) \<and>
       T1 = T2 \<union> {\<iota>} \<and> N2 = N1 \<union> M \<and> active_subset M = {} \<and>
       \<iota> \<in> no_labels.Red_I_\<G> (fst ` (N1 \<union> M))"
   proof -
     have ci_or_do: "(\<exists>T1 T2 \<iota> N2 N1 M. lnth Ns p = (T1, N1) \<and> lnth Ns (Suc p) = (T2, N2) \<and>
         T1 = T2 \<union> {\<iota>} \<and> N2 = N1 \<union> M \<and> active_subset M = {} \<and>
         \<iota> \<in> no_labels.Red_I_\<G> (fst ` (N1 \<union> M))) \<or>
         (\<exists>T1 T2 T' N. lnth Ns p = (T1, N) \<and> lnth Ns (Suc p) = (T2, N) \<and>
         T1 = T2 \<union> T' \<and> T' \<inter> no_labels.Inf_from (fst ` active_subset N) = {})"
       using step.simps[of "lnth Ns p" "lnth Ns (Suc p)"] step_p i_in_p i_notin_suc_p by fastforce
     then have p_greater_n_strict: "n < Suc p"
       using suc_nth_d_is p_greater_n i_in_t2 i_notin_suc_p le_eq_less_or_eq by force
     have "m > 0 \<Longrightarrow> j \<in> {0..<m} \<Longrightarrow> prems_of (to_F \<iota>) ! j \<in> fst ` active_subset (snd (lnth Ns p))"
       for j
     proof -
       fix j
       assume
         m_pos: "m > 0" and
         j_in: "j \<in> {0..<m}"
       then have "prems_of \<iota> ! j \<in> (active_subset (snd (lnth Ns p)))"
         using all_prems_active_after[OF m_pos] p_smaller_d m_def p_greater_n p_neq_n
         by (meson Suc_ile_eq atLeastLessThan_iff dual_order.strict_implies_order nth_mem
             p_greater_n_strict)
       then have "fst (prems_of \<iota> ! j) \<in> fst ` active_subset (snd (lnth Ns p))"
         by blast
       then show "prems_of (to_F \<iota>) ! j \<in> fst ` active_subset (snd (lnth Ns p))"
         unfolding to_F_def using j_in m_def by simp
     qed
     then have prems_i_active_p: "m > 0 \<Longrightarrow>
         to_F \<iota> \<in> no_labels.Inf_from (fst ` active_subset (snd (lnth Ns p)))"
       using i_in_F unfolding no_labels.Inf_from_def
       by (smt atLeast0LessThan in_set_conv_nth lessThan_iff m_def_F mem_Collect_eq subsetI)
     have "m = 0 \<Longrightarrow> (\<exists>T1 T2 \<iota> N2 N1 M. lnth Ns p = (T1, N1) \<and> lnth Ns (Suc p) = (T2, N2) \<and>
         T1 = T2 \<union> {\<iota>} \<and> N2 = N1 \<union> M \<and> active_subset M = {} \<and>
         \<iota> \<in> no_labels.Red_I_\<G> (fst ` (N1 \<union> M)))"
       using ci_or_do premise_free_inf_always_from[of "to_F \<iota>" "fst ` active_subset _", OF i_in_F]
         m_def i_in_p i_notin_suc_p m_def_F by auto
     then show "(\<exists>T1 T2 \<iota> N2 N1 M. lnth Ns p = (T1, N1) \<and> lnth Ns (Suc p) = (T2, N2) \<and>
         T1 = T2 \<union> {\<iota>} \<and> N2 = N1 \<union> M \<and> active_subset M = {} \<and>
         \<iota> \<in> no_labels.Red_I_\<G> (fst ` (N1 \<union> M)))"
       using ci_or_do i_in_p i_notin_suc_p prems_i_active_p unfolding active_subset_def by force
   qed
   then obtain T1p T2p N1p N2p Mp where  "lnth Ns p = (T1p, N1p)" and
     suc_p_is: "lnth Ns (Suc p) = (T2p, N2p)" and "T1p = T2p \<union> {to_F \<iota>}" and "T2p \<inter> {to_F \<iota>} = {}" and
     n2p_is: "N2p = N1p \<union> Mp"and "active_subset Mp = {}" and
     i_in_red_inf: "to_F \<iota> \<in> no_labels.Red_I_\<G>
         (fst ` (N1p \<union> Mp))"
     using i_in_p i_notin_suc_p by fastforce
   have "to_F \<iota> \<in> no_labels.Red_I (fst ` (snd (lnth Ns (Suc p))))"
     using i_in_red_inf suc_p_is n2p_is by fastforce
   then have "\<forall>q \<in> Q. (\<G>_I_q q (to_F \<iota>) \<noteq> None \<and>
       the (\<G>_I_q q (to_F \<iota>)) \<subseteq> Red_I_q q (\<Union> (\<G>_F_q q ` fst ` snd (lnth Ns (Suc p)))))
       \<or> (\<G>_I_q q (to_F \<iota>) = None \<and>
       \<G>_F_q q (concl_of (to_F \<iota>)) \<subseteq> \<Union> (\<G>_F_q q ` fst ` snd (lnth Ns (Suc p))) \<union>
         Red_F_q q (\<Union> (\<G>_F_q q ` fst ` snd (lnth Ns (Suc p)))))"
     unfolding to_F_def no_labels.Red_I_def no_labels.Red_I_\<G>_q_def by blast
   then have "\<iota> \<in> Red_I_\<G> (snd (lnth Ns (Suc p)))"
     using i_in_inf_fl unfolding Red_I_\<G>_def Red_I_\<G>_q_def by (simp add: to_F_def)
   then show "\<iota> \<in> Sup_llist (lmap Red_I_\<G> (lmap snd Ns))"
     unfolding Sup_llist_def using suc_n_length p_smaller_d by auto
 qed
 
 theorem lgc_complete_Liminf:
   assumes
     deriv: "chain (\<leadsto>LGC) Ns" and
     init_state: "active_subset (snd (lhd Ns)) = {}" and
     final_state: "passive_subset (Liminf_llist (lmap snd Ns)) = {}" and
     no_prems_init: "\<forall>\<iota> \<in> Inf_F. prems_of \<iota> = [] \<longrightarrow> \<iota> \<in> fst (lhd Ns)" and
     final_schedule: "Liminf_llist (lmap fst Ns) = {}" and
     b_in: "B \<in> Bot_F" and
     bot_entailed: "no_labels.entails_\<G> (fst ` snd (lhd Ns)) {B}"
   shows "\<exists>BL \<in> Bot_FL. BL \<in> Liminf_llist (lmap snd Ns)"
 proof -
   have labeled_b_in: "(B, active) \<in> Bot_FL" using b_in by simp
   have simp_snd_lmap: "lhd (lmap snd Ns) = snd (lhd Ns)"
     by (rule llist.map_sel(1)[OF chain_not_lnull[OF deriv]])
   have labeled_bot_entailed: "entails_\<G>_L (snd (lhd Ns)) {(B, active)}"
     using labeled_entailment_lifting bot_entailed by fastforce
   have "fair (lmap snd Ns)"
     using lgc_fair[OF deriv init_state final_state no_prems_init final_schedule] .
   then show ?thesis
     using dynamically_complete_Liminf labeled_b_in lgc_to_red[OF deriv]
       labeled_bot_entailed simp_snd_lmap std_Red_I_eq
     by presburger
 qed
 
 (* thm:lgc-completeness *)
 theorem lgc_complete:
   assumes
     deriv: "chain (\<leadsto>LGC) Ns" and
     init_state: "active_subset (snd (lhd Ns)) = {}" and
     final_state: "passive_subset (Liminf_llist (lmap snd Ns)) = {}" and
     no_prems_init: "\<forall>\<iota> \<in> Inf_F. prems_of \<iota> = [] \<longrightarrow> \<iota> \<in> fst (lhd Ns)" and
     final_schedule: "Liminf_llist (lmap fst Ns) = {}" and
     b_in: "B \<in> Bot_F" and
     bot_entailed: "no_labels.entails_\<G> (fst ` snd (lhd Ns)) {B}"
   shows "\<exists>i. enat i < llength Ns \<and> (\<exists>BL \<in> Bot_FL. BL \<in> snd (lnth Ns i))"
 proof -
   have "\<exists>BL\<in>Bot_FL. BL \<in> Liminf_llist (lmap snd Ns)"
     using assms by (rule lgc_complete_Liminf)
   then show ?thesis
     unfolding Liminf_llist_def by auto
 qed
 
 end
 
 end
diff --git a/thys/Well_Quasi_Orders/Almost_Full.thy b/thys/Well_Quasi_Orders/Almost_Full.thy
--- a/thys/Well_Quasi_Orders/Almost_Full.thy
+++ b/thys/Well_Quasi_Orders/Almost_Full.thy
@@ -1,551 +1,550 @@
 (*  Title:      Well-Quasi-Orders
     Author:     Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>The Almost-Full Property\<close>
 
 theory Almost_Full
 imports
   "HOL-Library.Sublist"
   "HOL-Library.Ramsey"
   "Regular-Sets.Regexp_Method"
   "Abstract-Rewriting.Seq"
   Least_Enum
   Infinite_Sequences
   Open_Induction.Restricted_Predicates
 begin
 
 (*TODO: move*)
 lemma le_Suc_eq':
   "x \<le> Suc y \<longleftrightarrow> x = 0 \<or> (\<exists>x'. x = Suc x' \<and> x' \<le> y)"
   by (cases x) auto
 
 lemma ex_leq_Suc:
   "(\<exists>i\<le>Suc j. P i) \<longleftrightarrow> P 0 \<or> (\<exists>i\<le>j. P (Suc i))"
   by (auto simp: le_Suc_eq')
 
 lemma ex_less_Suc:
   "(\<exists>i<Suc j. P i) \<longleftrightarrow> P 0 \<or> (\<exists>i<j. P (Suc i))"
   by (auto simp: less_Suc_eq_0_disj)
 
 
 subsection \<open>Basic Definitions and Facts\<close>
 
 text \<open>
   An infinite sequence is \emph{good} whenever there are indices @{term "i < j"} such that
   @{term "P (f i) (f j)"}.
 \<close>
 definition good :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> bool"
 where
   "good P f \<longleftrightarrow> (\<exists>i j. i < j \<and> P (f i) (f j))"
 
 text \<open>A sequence that is not good is called \emph{bad}.\<close>
 abbreviation "bad P f \<equiv> \<not> good P f"
 
 lemma goodI:
   "\<lbrakk>i < j; P (f i) (f j)\<rbrakk> \<Longrightarrow> good P f"
 by (auto simp: good_def)
 
 lemma goodE [elim]:
   "good P f \<Longrightarrow> (\<And>i j. \<lbrakk>i < j; P (f i) (f j)\<rbrakk> \<Longrightarrow> Q) \<Longrightarrow> Q"
  by (auto simp: good_def)
 
 lemma badE [elim]:
   "bad P f \<Longrightarrow> ((\<And>i j. i < j \<Longrightarrow> \<not> P (f i) (f j)) \<Longrightarrow> Q) \<Longrightarrow> Q"
 by (auto simp: good_def)
 
 
 definition almost_full_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
 where
   "almost_full_on P A \<longleftrightarrow> (\<forall>f \<in> SEQ A. good P f)"
 
 lemma almost_full_onI [Pure.intro]:
   "(\<And>f. \<forall>i. f i \<in> A \<Longrightarrow> good P f) \<Longrightarrow> almost_full_on P A"
   unfolding almost_full_on_def by blast
 
 lemma almost_full_onD:
   fixes f :: "nat \<Rightarrow> 'a" and A :: "'a set"
   assumes "almost_full_on P A" and "\<And>i. f i \<in> A"
   obtains i j where "i < j" and "P (f i) (f j)"
   using assms unfolding almost_full_on_def by blast
 
 
 subsection \<open>An equivalent inductive definition\<close>
 
 inductive af for A
   where
     now: "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> P x y) \<Longrightarrow> af A P"
   | later: "(\<And>x. x \<in> A \<Longrightarrow> af A (\<lambda>y z. P y z \<or> P x y)) \<Longrightarrow> af A P"
 
 lemma af_imp_almost_full_on:
   assumes "af A P"
   shows "almost_full_on P A"
 proof
   fix f :: "nat \<Rightarrow> 'a" assume "\<forall>i. f i \<in> A"
   with assms obtain i and j where "i < j" and "P (f i) (f j)"
   proof (induct arbitrary: f thesis)
     case (later P)
     define g where [simp]: "g i = f (Suc i)" for i
     have "f 0 \<in> A" and "\<forall>i. g i \<in> A" using later by auto
     then obtain i and j where "i < j" and "P (g i) (g j) \<or> P (f 0) (g i)" using later by blast
     then consider "P (g i) (g j)" | "P (f 0) (g i)" by blast
     then show ?case using \<open>i < j\<close> by (cases) (auto intro: later)
   qed blast
   then show "good P f" by (auto simp: good_def)
 qed
 
 lemma af_mono:
   assumes "af A P"
     and "\<forall>x y. x \<in> A \<and> y \<in> A \<and> P x y \<longrightarrow> Q x y"
   shows "af A Q"
   using assms
 proof (induct arbitrary: Q)
   case (now P)
   then have "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> Q x y" by blast
   then show ?case by (rule af.now)
 next
   case (later P)
   show ?case
   proof (intro af.later [of A Q])
     fix x assume "x \<in> A"
     then show "af A (\<lambda>y z. Q y z \<or> Q x y)"
       using later(3) by (intro later(2) [of x]) auto
   qed
 qed
 
 lemma accessible_on_imp_af:
   assumes "accessible_on P A x"
   shows "af A (\<lambda>u v. \<not> P v u \<or> \<not> P u x)"
   using assms
 proof (induct)
   case (1 x)
   then have "af A (\<lambda>u v. (\<not> P v u \<or> \<not> P u x) \<or> \<not> P u y \<or> \<not> P y x)" if "y \<in> A" for y
     using that by (cases "P y x") (auto intro: af.now af_mono)
   then show ?case by (rule af.later)
 qed
 
 lemma wfp_on_imp_af:
   assumes "wfp_on P A"
   shows "af A (\<lambda>x y. \<not> P y x)"
   using assms by (auto simp: wfp_on_accessible_on_iff intro: accessible_on_imp_af af.later)
 
 lemma af_leq:
   "af UNIV ((\<le>) :: nat \<Rightarrow> nat \<Rightarrow> bool)"
   using wf_less [folded wfP_def wfp_on_UNIV, THEN wfp_on_imp_af] by (simp add: not_less)
 
 definition "NOTAF A P = (SOME x. x \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P x y))"
 
 lemma not_af:
   "\<not> af A P \<Longrightarrow> (\<exists>x y. x \<in> A \<and> y \<in> A \<and> \<not> P x y) \<and> (\<exists>x\<in>A. \<not> af A (\<lambda>y z. P y z \<or> P x y))"
   unfolding af.simps [of A P] by blast
 
 fun F
   where
     "F A P 0 = NOTAF A P"
   | "F A P (Suc i) = (let x = NOTAF A P in F A (\<lambda>y z. P y z \<or> P x y) i)"
 
 lemma almost_full_on_imp_af:
   assumes af: "almost_full_on P A"
   shows "af A P"
 proof (rule ccontr)
   assume "\<not> af A P"
   then have *: "F A P n \<in> A \<and>
     \<not> af A (\<lambda>y z. P y z \<or> (\<exists>i\<le>n. P (F A P i) y) \<or> (\<exists>j\<le>n. \<exists>i. i < j \<and> P (F A P i) (F A P j)))" for n
   proof (induct n arbitrary: P)
     case 0
     from \<open>\<not> af A P\<close> have "\<exists>x. x \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P x y)" by (auto intro: af.intros)
     then have "NOTAF A P \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P (NOTAF A P) y)" unfolding NOTAF_def by (rule someI_ex)
     with 0 show ?case by simp
   next
     case (Suc n)
     from \<open>\<not> af A P\<close> have "\<exists>x. x \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P x y)" by (auto intro: af.intros)
     then have "NOTAF A P \<in> A \<and> \<not> af A (\<lambda>y z. P y z \<or> P (NOTAF A P) y)" unfolding NOTAF_def by (rule someI_ex)
     from Suc(1) [OF this [THEN conjunct2]]
     show ?case
       by (fastforce simp: ex_leq_Suc ex_less_Suc elim!: back_subst [where P = "\<lambda>x. \<not> af A x"])
   qed
   then have "F A P \<in> SEQ A" by auto
   from af [unfolded almost_full_on_def, THEN bspec, OF this] and not_af [OF * [THEN conjunct2]]
   show False unfolding good_def by blast
 qed
 
 hide_const NOTAF F
 
 lemma almost_full_on_UNIV:
   "almost_full_on (\<lambda>_ _. True) UNIV"
 by (auto simp: almost_full_on_def good_def)
 
 lemma almost_full_on_imp_reflp_on:
   assumes "almost_full_on P A"
   shows "reflp_on A P"
 using assms by (auto simp: almost_full_on_def reflp_on_def)
 
 lemma almost_full_on_subset:
   "A \<subseteq> B \<Longrightarrow> almost_full_on P B \<Longrightarrow> almost_full_on P A"
 by (auto simp: almost_full_on_def)
 
 lemma almost_full_on_mono:
   assumes "A \<subseteq> B" and "\<And>x y. Q x y \<Longrightarrow> P x y"
     and "almost_full_on Q B"
   shows "almost_full_on P A"
   using assms by (metis almost_full_on_def almost_full_on_subset good_def)
 
 text \<open>
   Every sequence over elements of an almost-full set has a homogeneous subsequence.
 \<close>
 lemma almost_full_on_imp_homogeneous_subseq:
   assumes "almost_full_on P A"
     and "\<forall>i::nat. f i \<in> A"
   shows "\<exists>\<phi>::nat \<Rightarrow> nat. \<forall>i j. i < j \<longrightarrow> \<phi> i < \<phi> j \<and> P (f (\<phi> i)) (f (\<phi> j))"
 proof -
   define X where "X = {{i, j} | i j::nat. i < j \<and> P (f i) (f j)}"
   define Y where "Y = - X"
   define h where "h = (\<lambda>Z. if Z \<in> X then 0 else Suc 0)"
 
   have [iff]: "\<And>x y. h {x, y} = 0 \<longleftrightarrow> {x, y} \<in> X" by (auto simp: h_def)
   have [iff]: "\<And>x y. h {x, y} = Suc 0 \<longleftrightarrow> {x, y} \<in> Y" by (auto simp: h_def Y_def)
 
   have "\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. x \<noteq> y \<longrightarrow> h {x, y} < 2" by (simp add: h_def)
   from Ramsey2 [OF infinite_UNIV_nat this] obtain I c
     where "infinite I" and "c < 2"
     and *: "\<forall>x\<in>I. \<forall>y\<in>I. x \<noteq> y \<longrightarrow> h {x, y} = c" by blast
   then interpret infinitely_many1 "\<lambda>i. i \<in> I"
     by (unfold_locales) (simp add: infinite_nat_iff_unbounded)
 
   have "c = 0 \<or> c = 1" using \<open>c < 2\<close> by arith
   then show ?thesis
   proof
     assume [simp]: "c = 0"
     have "\<forall>i j. i < j \<longrightarrow> P (f (enum i)) (f (enum j))"
     proof (intro allI impI)
       fix i j :: nat
       assume "i < j"
       from * and enum_P and enum_less [OF \<open>i < j\<close>] have "{enum i, enum j} \<in> X" by auto
       with enum_less [OF \<open>i < j\<close>]
         show "P (f (enum i)) (f (enum j))" by (auto simp: X_def doubleton_eq_iff)
     qed
     then show ?thesis using enum_less by blast
   next
     assume [simp]: "c = 1"
     have "\<forall>i j. i < j \<longrightarrow> \<not> P (f (enum i)) (f (enum j))"
     proof (intro allI impI)
       fix i j :: nat
       assume "i < j"
       from * and enum_P and enum_less [OF \<open>i < j\<close>] have "{enum i, enum j} \<in> Y" by auto
       with enum_less [OF \<open>i < j\<close>]
         show "\<not> P (f (enum i)) (f (enum j))" by (auto simp: Y_def X_def doubleton_eq_iff)
     qed
     then have "\<not> good P (f \<circ> enum)" by auto
     moreover have "\<forall>i. f (enum i) \<in> A" using assms by auto
     ultimately show ?thesis using \<open>almost_full_on P A\<close> by (simp add: almost_full_on_def)
   qed
 qed
 
 text \<open>
   Almost full relations do not admit infinite antichains.
 \<close>
 lemma almost_full_on_imp_no_antichain_on:
   assumes "almost_full_on P A"
   shows "\<not> antichain_on P f A"
 proof
   assume *: "antichain_on P f A"
   then have "\<forall>i. f i \<in> A" by simp
   with assms have "good P f" by (auto simp: almost_full_on_def)
   then obtain i j where "i < j" and "P (f i) (f j)"
     unfolding good_def by auto
   moreover with * have "incomparable P (f i) (f j)" by auto
   ultimately show False by blast
 qed
 
 text \<open>
   If the image of a function is almost-full then also its preimage is almost-full.
 \<close>
 lemma almost_full_on_map:
   assumes "almost_full_on Q B"
     and "h ` A \<subseteq> B"
   shows "almost_full_on (\<lambda>x y. Q (h x) (h y)) A" (is "almost_full_on ?P A")
 proof
   fix f
   assume "\<forall>i::nat. f i \<in> A"
   then have "\<And>i. h (f i) \<in> B" using \<open>h ` A \<subseteq> B\<close> by auto
   with \<open>almost_full_on Q B\<close> [unfolded almost_full_on_def, THEN bspec, of "h \<circ> f"]
     show "good ?P f" unfolding good_def comp_def by blast
 qed
 
 text \<open>
   The homomorphic image of an almost-full set is almost-full.
 \<close>
 lemma almost_full_on_hom:
   fixes h :: "'a \<Rightarrow> 'b"
   assumes hom: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; P x y\<rbrakk> \<Longrightarrow> Q (h x) (h y)"
     and af: "almost_full_on P A"
   shows "almost_full_on Q (h ` A)"
 proof
   fix f :: "nat \<Rightarrow> 'b"
   assume "\<forall>i. f i \<in> h ` A"
   then have "\<forall>i. \<exists>x. x \<in> A \<and> f i = h x" by (auto simp: image_def)
   from choice [OF this] obtain g
     where *: "\<forall>i. g i \<in> A \<and> f i = h (g i)" by blast
   show "good Q f"
   proof (rule ccontr)
     assume bad: "bad Q f"
     { fix i j :: nat
       assume "i < j"
       from bad have "\<not> Q (f i) (f j)" using \<open>i < j\<close> by (auto simp: good_def)
       with hom have "\<not> P (g i) (g j)" using * by auto }
     then have "bad P g" by (auto simp: good_def)
     with af and * show False by (auto simp: good_def almost_full_on_def)
   qed
 qed
 
 text \<open>
   The monomorphic preimage of an almost-full set is almost-full.
 \<close>
 lemma almost_full_on_mon:
   assumes mon: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> P x y = Q (h x) (h y)" "bij_betw h A B"
     and af: "almost_full_on Q B"
   shows "almost_full_on P A"
 proof
   fix f :: "nat \<Rightarrow> 'a"
   assume *: "\<forall>i. f i \<in> A"
   then have **: "\<forall>i. (h \<circ> f) i \<in> B" using mon by (auto simp: bij_betw_def)
   show "good P f"
   proof (rule ccontr)
     assume bad: "bad P f"
     { fix i j :: nat
       assume "i < j"
       from bad have "\<not> P (f i) (f j)" using \<open>i < j\<close> by (auto simp: good_def)
       with mon have "\<not> Q (h (f i)) (h (f j))"
         using * by (auto simp: bij_betw_def inj_on_def) }
     then have "bad Q (h \<circ> f)" by (auto simp: good_def)
     with af and ** show False by (auto simp: good_def almost_full_on_def)
   qed
 qed
 
 text \<open>
   Every total and well-founded relation is almost-full.
 \<close>
 lemma total_on_and_wfp_on_imp_almost_full_on:
   assumes "totalp_on A P" and "wfp_on P A"
   shows "almost_full_on P\<^sup>=\<^sup>= A"
 proof (rule ccontr)
   assume "\<not> almost_full_on P\<^sup>=\<^sup>= A"
   then obtain f :: "nat \<Rightarrow> 'a" where *: "\<And>i. f i \<in> A"
     and "\<forall>i j. i < j \<longrightarrow> \<not> P\<^sup>=\<^sup>= (f i) (f j)"
     unfolding almost_full_on_def by (auto dest: badE)
   with \<open>totalp_on A P\<close> have "\<forall>i j. i < j \<longrightarrow> P (f j) (f i)"
     unfolding totalp_on_def by blast
   then have "\<And>i. P (f (Suc i)) (f i)" by auto
   with \<open>wfp_on P A\<close> and * show False
     unfolding wfp_on_def by blast
 qed
 
 lemma Nil_imp_good_list_emb [simp]:
   assumes "f i = []"
   shows "good (list_emb P) f"
 proof (rule ccontr)
   assume "bad (list_emb P) f"
   moreover have "(list_emb P) (f i) (f (Suc i))"
     unfolding assms by auto
   ultimately show False
     unfolding good_def by auto
 qed
 
 lemma ne_lists:
   assumes "xs \<noteq> []" and "xs \<in> lists A"
   shows "hd xs \<in> A" and "tl xs \<in> lists A"
   using assms by (case_tac [!] xs) simp_all
 
 lemma list_emb_eq_length_induct [consumes 2, case_names Nil Cons]:
   assumes "length xs = length ys"
     and "list_emb P xs ys"
     and "Q [] []"
     and "\<And>x y xs ys. \<lbrakk>P x y; list_emb P xs ys; Q xs ys\<rbrakk> \<Longrightarrow> Q (x#xs) (y#ys)"
   shows "Q xs ys"
   using assms(2, 1, 3-) by (induct) (auto dest: list_emb_length)
 
 lemma list_emb_eq_length_P:
   assumes "length xs = length ys"
     and "list_emb P xs ys"
   shows "\<forall>i<length xs. P (xs ! i) (ys ! i)"
 using assms
 proof (induct rule: list_emb_eq_length_induct)
   case (Cons x y xs ys)
   show ?case
   proof (intro allI impI)
     fix i assume "i < length (x # xs)"
     with Cons show "P ((x#xs)!i) ((y#ys)!i)"
       by (cases i) simp_all
   qed
 qed simp
 
 
 subsection \<open>Special Case: Finite Sets\<close>
 
 text \<open>
   Every reflexive relation on a finite set is almost-full.
 \<close>
 lemma finite_almost_full_on:
   assumes finite: "finite A"
     and refl: "reflp_on A P"
   shows "almost_full_on P A"
 proof
   fix f :: "nat \<Rightarrow> 'a"
   assume *: "\<forall>i. f i \<in> A"
   let ?I = "UNIV::nat set"
   have "f ` ?I \<subseteq> A" using * by auto
   with finite and finite_subset have 1: "finite (f ` ?I)" by blast
   have "infinite ?I" by auto
   from pigeonhole_infinite [OF this 1]
     obtain k where "infinite {j. f j = f k}" by auto
   then obtain l where "k < l" and "f l = f k"
     unfolding infinite_nat_iff_unbounded by auto
   then have "P (f k) (f l)" using refl and * by (auto simp: reflp_on_def)
   with \<open>k < l\<close> show "good P f" by (auto simp: good_def)
 qed
 
 lemma eq_almost_full_on_finite_set:
   assumes "finite A"
   shows "almost_full_on (=) A"
   using finite_almost_full_on [OF assms, of "(=)"]
   by (auto simp: reflp_on_def)
 
 
 subsection \<open>Further Results\<close>
 
 lemma af_trans_extension_imp_wf:
   assumes subrel: "\<And>x y. P x y \<Longrightarrow> Q x y"
     and af: "almost_full_on P A"
-    and trans: "transp_on Q A"
+    and trans: "transp_on A Q"
   shows "wfp_on (strict Q) A"
 proof (unfold wfp_on_def, rule notI)
   assume "\<exists>f. \<forall>i. f i \<in> A \<and> strict Q (f (Suc i)) (f i)"
   then obtain f where *: "\<forall>i. f i \<in> A \<and> ((strict Q)\<inverse>\<inverse>) (f i) (f (Suc i))" by blast
-  from chain_transp_on_less [OF this]
-    and transp_on_strict [THEN transp_on_converse, OF trans]
-  have "\<forall>i j. i < j \<longrightarrow> \<not> Q (f i) (f j)" by blast
+  from chain_transp_on_less[OF this]
+  have "\<forall>i j. i < j \<longrightarrow> \<not> Q (f i) (f j)" using trans using transp_on_conversep transp_on_strict by blast
   with subrel have "\<forall>i j. i < j \<longrightarrow> \<not> P (f i) (f j)" by blast
   with af show False
     using * by (auto simp: almost_full_on_def good_def)
 qed
 
 lemma af_trans_imp_wf:
   assumes "almost_full_on P A"
-    and "transp_on P A"
+    and "transp_on A P"
   shows "wfp_on (strict P) A"
   using assms by (intro af_trans_extension_imp_wf)
 
 lemma wf_and_no_antichain_imp_qo_extension_wf:
   assumes wf: "wfp_on (strict P) A"
     and anti: "\<not> (\<exists>f. antichain_on P f A)"
     and subrel: "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y"
     and qo: "qo_on Q A"
   shows "wfp_on (strict Q) A"
 proof (rule ccontr)
-  have "transp_on (strict Q) A"
+  have "transp_on A (strict Q)"
     using qo unfolding qo_on_def transp_on_def by blast
-  then have *: "transp_on ((strict Q)\<inverse>\<inverse>) A" by (rule transp_on_converse)
+  then have *: "transp_on A ((strict Q)\<inverse>\<inverse>)" by simp
   assume "\<not> wfp_on (strict Q) A"
   then obtain f :: "nat \<Rightarrow> 'a" where A: "\<And>i. f i \<in> A"
     and "\<forall>i. strict Q (f (Suc i)) (f i)" unfolding wfp_on_def by blast+
   then have "\<forall>i. f i \<in> A \<and> ((strict Q)\<inverse>\<inverse>) (f i) (f (Suc i))" by auto
   from chain_transp_on_less [OF this *]
     have *: "\<And>i j. i < j \<Longrightarrow> \<not> P (f i) (f j)"
     using subrel and A by blast
   show False
   proof (cases)
     assume "\<exists>k. \<forall>i>k. \<exists>j>i. P (f j) (f i)"
     then obtain k where "\<forall>i>k. \<exists>j>i. P (f j) (f i)" by auto
     from subchain [of k _ f, OF this] obtain g
       where "\<And>i j. i < j \<Longrightarrow> g i < g j"
       and "\<And>i. P (f (g (Suc i))) (f (g i))" by auto
     with * have "\<And>i. strict P (f (g (Suc i))) (f (g i))" by blast
     with wf [unfolded wfp_on_def not_ex, THEN spec, of "\<lambda>i. f (g i)"] and A
       show False by fast
   next
     assume "\<not> (\<exists>k. \<forall>i>k. \<exists>j>i. P (f j) (f i))"
     then have "\<forall>k. \<exists>i>k. \<forall>j>i. \<not> P (f j) (f i)" by auto
     from choice [OF this] obtain h
       where "\<forall>k. h k > k"
       and **: "\<forall>k. (\<forall>j>h k. \<not> P (f j) (f (h k)))" by auto
     define \<phi> where [simp]: "\<phi> = (\<lambda>i. (h ^^ Suc i) 0)"
     have "\<And>i. \<phi> i < \<phi> (Suc i)"
       using \<open>\<forall>k. h k > k\<close> by (induct_tac i) auto
     then have mono: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j" by (metis lift_Suc_mono_less)
     then have "\<forall>i j. i < j \<longrightarrow> \<not> P (f (\<phi> j)) (f (\<phi> i))"
       using ** by auto
     with mono [THEN *]
       have "\<forall>i j. i < j \<longrightarrow> incomparable P (f (\<phi> j)) (f (\<phi> i))" by blast
     moreover have "\<exists>i j. i < j \<and> \<not> incomparable P (f (\<phi> i)) (f (\<phi> j))"
       using anti [unfolded not_ex, THEN spec, of "\<lambda>i. f (\<phi> i)"] and A by blast
     ultimately show False by blast
   qed
 qed
 
 lemma every_qo_extension_wf_imp_af:
   assumes ext: "\<forall>Q. (\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y) \<and>
     qo_on Q A \<longrightarrow> wfp_on (strict Q) A"
     and "qo_on P A"
   shows "almost_full_on P A"
 proof
   from \<open>qo_on P A\<close>
     have refl: "reflp_on A P"
-    and trans: "transp_on P A"
+    and trans: "transp_on A P"
     by (auto intro: qo_on_imp_reflp_on qo_on_imp_transp_on)
 
   fix f :: "nat \<Rightarrow> 'a"
   assume "\<forall>i. f i \<in> A"
   then have A: "\<And>i. f i \<in> A" ..
   show "good P f"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     then have bad: "\<forall>i j. i < j \<longrightarrow> \<not> P (f i) (f j)" by (auto simp: good_def)
     then have *: "\<And>i j. P (f i) (f j) \<Longrightarrow> i \<ge> j" by (metis not_le_imp_less)
 
     define D where [simp]: "D = (\<lambda>x y. \<exists>i. x = f (Suc i) \<and> y = f i)"
     define P' where "P' = restrict_to P A"
     define Q where [simp]: "Q = (sup P' D)\<^sup>*\<^sup>*"
 
     have **: "\<And>i j. (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+ (f i) (f j) \<Longrightarrow> i > j"
     proof -
       fix i j
       assume "(D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+ (f i) (f j)"
       then show "i > j"
         apply (induct "f i" "f j" arbitrary: j)
         apply (insert A, auto dest!: * simp: P'_def reflp_on_restrict_to_rtranclp [OF refl trans])
         apply (metis "*" dual_order.strict_trans1 less_Suc_eq_le refl reflp_on_def)
         by (metis le_imp_less_Suc less_trans)
     qed
 
     have "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y" by (auto simp: P'_def)
     moreover have "qo_on Q A" by (auto simp: qo_on_def reflp_on_def transp_on_def)
     ultimately have "wfp_on (strict Q) A"
         using ext [THEN spec, of Q] by blast
     moreover have "\<forall>i. f i \<in> A \<and> strict Q (f (Suc i)) (f i)"
     proof
       fix i
       have "\<not> Q (f i) (f (Suc i))"
       proof
         assume "Q (f i) (f (Suc i))"
         then have "(sup P' D)\<^sup>*\<^sup>* (f i) (f (Suc i))" by auto
         moreover have "(sup P' D)\<^sup>*\<^sup>* = sup (P'\<^sup>*\<^sup>*) (P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+)"
         proof -
           have "\<And>A B. (A \<union> B)\<^sup>* = A\<^sup>* \<union> A\<^sup>* O (B O A\<^sup>*)\<^sup>+" by regexp
           from this [to_pred] show ?thesis by blast
         qed
         ultimately have "sup (P'\<^sup>*\<^sup>*) (P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+) (f i) (f (Suc i))" by simp
         then have "(P'\<^sup>*\<^sup>* OO (D OO P'\<^sup>*\<^sup>*)\<^sup>+\<^sup>+) (f i) (f (Suc i))" by auto
         then have "Suc i < i"
           using ** apply auto
           by (metis (lifting, mono_tags) less_le relcompp.relcompI tranclp_into_tranclp2)
         then show False by auto
       qed
       with A [of i] show "f i \<in> A \<and> strict Q (f (Suc i)) (f i)" by auto
     qed
     ultimately show False unfolding wfp_on_def by blast
   qed
 qed
 
 end
diff --git a/thys/Well_Quasi_Orders/Higman_OI.thy b/thys/Well_Quasi_Orders/Higman_OI.thy
--- a/thys/Well_Quasi_Orders/Higman_OI.thy
+++ b/thys/Well_Quasi_Orders/Higman_OI.thy
@@ -1,263 +1,263 @@
 (*  Title:      Well-Quasi-Orders
     Author:     Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>A Proof of Higman's Lemma via Open Induction\<close>
 
 theory Higman_OI
 imports
   Open_Induction.Open_Induction
   Minimal_Elements
   Almost_Full
 begin
 
 subsection \<open>Some facts about the suffix relation\<close>
 
 lemma wfp_on_strict_suffix:
   "wfp_on strict_suffix A"
 by (rule wfp_on_mono [OF subset_refl, of _ _ "measure_on length A"])
    (auto simp: strict_suffix_def suffix_def)
 
 lemma po_on_strict_suffix:
   "po_on strict_suffix A"
 by (force simp: strict_suffix_def po_on_def transp_on_def irreflp_on_def)
 
 
 subsection \<open>Lexicographic Order on Infinite Sequences\<close>
 
 lemma antisymp_on_LEX:
   assumes "irreflp_on A P" and "antisymp_on A P"
   shows "antisymp_on (SEQ A) (LEX P)"
 proof (rule antisymp_onI)
   fix f g assume SEQ: "f \<in> SEQ A" "g \<in> SEQ A" and "LEX P f g" and "LEX P g f"
   then obtain i j where "P (f i) (g i)" and "P (g j) (f j)"
     and "\<forall>k<i. f k = g k" and "\<forall>k<j. g k = f k" by (auto simp: LEX_def)
   then have "P (f (min i j)) (f (min i j))"
     using assms(2) and SEQ by (cases "i = j") (auto simp: antisymp_on_def min_def, force)
   with assms(1) and SEQ show  "f = g" by (auto simp: irreflp_on_def)
 qed
 
 lemma LEX_trans:
-  assumes "transp_on P A" and "f \<in> SEQ A" and "g \<in> SEQ A" and "h \<in> SEQ A"
+  assumes "transp_on A P" and "f \<in> SEQ A" and "g \<in> SEQ A" and "h \<in> SEQ A"
     and "LEX P f g" and "LEX P g h"
   shows "LEX P f h"
 using assms by (auto simp: LEX_def transp_on_def) (metis less_trans linorder_neqE_nat)
 
 lemma qo_on_LEXEQ:
-  "transp_on P A \<Longrightarrow> qo_on (LEXEQ P) (SEQ A)"
-by (auto simp: qo_on_def reflp_on_def transp_on_def [of "LEXEQ P"] dest: LEX_trans)
+  "transp_on A P \<Longrightarrow> qo_on (LEXEQ P) (SEQ A)"
+by (auto simp: qo_on_def reflp_on_def transp_on_def [of _ "LEXEQ P"] dest: LEX_trans)
 
 context minimal_element
 begin
 
 lemma glb_LEX_lexmin:
   assumes "chain_on (LEX P) C (SEQ A)" and "C \<noteq> {}"
   shows "glb (LEX P) C (lexmin C)"
 proof
   have "C \<subseteq> SEQ A" using assms by (auto simp: chain_on_def)
   then have "lexmin C \<in> SEQ A" using \<open>C \<noteq> {}\<close> by (intro lexmin_SEQ_mem)
   note * = \<open>C \<subseteq> SEQ A\<close> \<open>C \<noteq> {}\<close>
   note lex = LEX_imp_less [folded irreflp_on_def, OF po [THEN po_on_imp_irreflp_on]]
   \<comment> \<open>\<open>lexmin C\<close> is a lower bound\<close>
   show "lb (LEX P) C (lexmin C)"
   proof
     fix f assume "f \<in> C"
     then show "LEXEQ P (lexmin C) f"
     proof (cases "f = lexmin C")
       define i where "i = (LEAST i. f i \<noteq> lexmin C i)"
       case False
       then have neq: "\<exists>i. f i \<noteq> lexmin C i" by blast
       from LeastI_ex [OF this, folded i_def]
         and not_less_Least [where P = "\<lambda>i. f i \<noteq> lexmin C i", folded i_def]
       have neq: "f i \<noteq> lexmin C i" and eq: "\<forall>j<i. f j = lexmin C j" by auto
       then have **: "f \<in> eq_upto C (lexmin C) i" "f i \<in> ith (eq_upto C (lexmin C) i) i"
         using \<open>f \<in> C\<close> by force+
       moreover from ** have "\<not> P (f i) (lexmin C i)"
         using lexmin_minimal [OF *, of "f i" i] and \<open>f \<in> C\<close> and \<open>C \<subseteq> SEQ A\<close> by blast
       moreover obtain g where "g \<in> eq_upto C (lexmin C) (Suc i)"
         using eq_upto_lexmin_non_empty [OF *] by blast
       ultimately have "P (lexmin C i) (f i)"
         using neq and \<open>C \<subseteq> SEQ A\<close> and assms(1) and lex [of g f i] and lex [of f g i]
         by (auto simp: eq_upto_def chain_on_def)
       with eq show ?thesis by (auto simp: LEX_def)
     qed simp
   qed
 
   \<comment> \<open>\<open>lexmin C\<close> is greater than or equal to any other lower bound\<close>
   fix f assume lb: "lb (LEX P) C f"
   then show "LEXEQ P f (lexmin C)"
   proof (cases "f = lexmin C")
     define i where "i = (LEAST i. f i \<noteq> lexmin C i)"
     case False
     then have neq: "\<exists>i. f i \<noteq> lexmin C i" by blast
     from LeastI_ex [OF this, folded i_def]
       and not_less_Least [where P = "\<lambda>i. f i \<noteq> lexmin C i", folded i_def]
     have neq: "f i \<noteq> lexmin C i" and eq: "\<forall>j<i. f j = lexmin C j" by auto
     obtain h where "h \<in> eq_upto C (lexmin C) (Suc i)" and "h \<in> C"
       using eq_upto_lexmin_non_empty [OF *] by (auto simp: eq_upto_def)
     then have [simp]: "\<And>j. j < Suc i \<Longrightarrow> h j = lexmin C j" by auto
     with lb and \<open>h \<in> C\<close> have "LEX P f h" using neq by (auto simp: lb_def)
     then have "P (f i) (h i)"
       using neq and eq and \<open>C \<subseteq> SEQ A\<close> and \<open>h \<in> C\<close> by (intro lex) auto
     with eq show ?thesis by (auto simp: LEX_def)
   qed simp
 qed
 
 lemma dc_on_LEXEQ:
   "dc_on (LEXEQ P) (SEQ A)"
 proof
   fix C assume "chain_on (LEXEQ P) C (SEQ A)" and "C \<noteq> {}"
   then have chain: "chain_on (LEX P) C (SEQ A)" by (auto simp: chain_on_def)
   then have "C \<subseteq> SEQ A" by (auto simp: chain_on_def)
   then have "lexmin C \<in> SEQ A" using \<open>C \<noteq> {}\<close> by (intro lexmin_SEQ_mem)
   have "glb (LEX P) C (lexmin C)" by (rule glb_LEX_lexmin [OF chain \<open>C \<noteq> {}\<close>])
   then have "glb (LEXEQ P) C (lexmin C)" by (auto simp: glb_def lb_def)
   with \<open>lexmin C \<in> SEQ A\<close> show "\<exists>f \<in> SEQ A. glb (LEXEQ P) C f" by blast
 qed
 
 end
 
 text \<open>
   Properties that only depend on finite initial segments of a sequence
   (i.e., which are open with respect to the product topology).
 \<close>
 definition "pt_open_on Q A \<longleftrightarrow> (\<forall>f\<in>A. Q f \<longleftrightarrow> (\<exists>n. (\<forall>g\<in>A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g)))"
 
 lemma pt_open_onD:
   "pt_open_on Q A \<Longrightarrow> Q f \<Longrightarrow> f \<in> A \<Longrightarrow> (\<exists>n. (\<forall>g\<in>A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g))"
   unfolding pt_open_on_def by blast
 
 lemma pt_open_on_good:
   "pt_open_on (good Q) (SEQ A)"
 proof (unfold pt_open_on_def, intro ballI)
   fix f assume f: "f \<in> SEQ A"
   show "good Q f = (\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g)"
   proof
     assume "good Q f"
     then obtain i and j where *: "i < j" "Q (f i) (f j)" by auto
     have "\<forall>g\<in>SEQ A. (\<forall>i<Suc j. g i = f i) \<longrightarrow> good Q g"
     proof (intro ballI impI)
       fix g assume "g \<in> SEQ A" and "\<forall>i<Suc j. g i = f i"
       then show "good Q g" using * by (force simp: good_def)
     qed
     then show "\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g" ..
   next
     assume "\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g"
     with f show "good Q f" by blast
   qed
 qed
 
 context minimal_element
 begin
 
 lemma pt_open_on_imp_open_on_LEXEQ:
   assumes "pt_open_on Q (SEQ A)"
   shows "open_on (LEXEQ P) Q (SEQ A)"
 proof
   fix C assume chain: "chain_on (LEXEQ P) C (SEQ A)" and ne: "C \<noteq> {}"
     and "\<exists>g\<in>SEQ A. glb (LEXEQ P) C g \<and> Q g"
   then obtain g where g: "g \<in> SEQ A" and "glb (LEXEQ P) C g"
     and Q: "Q g" by blast
   then have glb: "glb (LEX P) C g" by (auto simp: glb_def lb_def)
   from chain have "chain_on (LEX P) C (SEQ A)" and C: "C \<subseteq> SEQ A" by (auto simp: chain_on_def)
   note * = glb_LEX_lexmin [OF this(1) ne]
   have "lexmin C \<in> SEQ A" using ne and C by (intro lexmin_SEQ_mem)
   from glb_unique [OF _ g this glb *]
     and antisymp_on_LEX [OF po_on_imp_irreflp_on [OF po] po_on_imp_antisymp_on [OF po]]
   have [simp]: "lexmin C = g" by auto
   from assms [THEN pt_open_onD, OF Q g]
   obtain n :: nat where **: "\<And>h. h \<in> SEQ A \<Longrightarrow> (\<forall>i<n. h i = g i) \<longrightarrow> Q h" by blast
   from eq_upto_lexmin_non_empty [OF C ne, of n]
   obtain f where "f \<in> eq_upto C g n" by auto
   then have "f \<in> C" and "Q f" using ** [of f] and C by force+
   then show "\<exists>f\<in>C. Q f" by blast
 qed
 
 lemma open_on_good:
   "open_on (LEXEQ P) (good Q) (SEQ A)"
   by (intro pt_open_on_imp_open_on_LEXEQ pt_open_on_good)
 
 end
 
 lemma open_on_LEXEQ_imp_pt_open_on_counterexample:
   fixes a b :: "'a"
   defines "A \<equiv> {a, b}" and "P \<equiv> (\<lambda>x y. False)" and "Q \<equiv> (\<lambda>f. \<forall>i. f i = b)"
   assumes [simp]: "a \<noteq> b"
   shows "minimal_element P A" and "open_on (LEXEQ P) Q (SEQ A)"
     and "\<not> pt_open_on Q (SEQ A)"
 proof -
   show "minimal_element P A"
     by standard (auto simp: P_def po_on_def irreflp_on_def transp_on_def wfp_on_def)
   show "open_on (LEXEQ P) Q (SEQ A)"
     by (auto simp: P_def open_on_def chain_on_def SEQ_def glb_def lb_def LEX_def)
   show "\<not> pt_open_on Q (SEQ A)"
   proof
     define f :: "nat \<Rightarrow> 'a" where "f \<equiv> (\<lambda>x. b)"
     have "f \<in> SEQ A" by (auto simp: A_def f_def)
     moreover assume "pt_open_on Q (SEQ A)"
     ultimately have "Q f \<longleftrightarrow> (\<exists>n. (\<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g))"
       unfolding pt_open_on_def by blast
     moreover have "Q f" by (auto simp: Q_def f_def)
     moreover have "\<exists>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<and> \<not> Q g" for n
       by (intro bexI [of _ "f(n := a)"]) (auto simp: f_def Q_def A_def)
     ultimately show False by blast
   qed
 qed
 
 lemma higman:
   assumes "almost_full_on P A"
   shows "almost_full_on (list_emb P) (lists A)"
 proof
   interpret minimal_element strict_suffix "lists A"
     by (unfold_locales) (intro po_on_strict_suffix wfp_on_strict_suffix)+
   fix f presume "f \<in> SEQ (lists A)"
   with qo_on_LEXEQ [OF po_on_imp_transp_on [OF po_on_strict_suffix]] and dc_on_LEXEQ and open_on_good
     show "good (list_emb P) f"
   proof (induct rule: open_induct_on)
     case (less f)
     define h where "h i = hd (f i)" for i
     show ?case
     proof (cases "\<exists>i. f i = []")
       case False
       then have ne: "\<forall>i. f i \<noteq> []" by auto
       with \<open>f \<in> SEQ (lists A)\<close> have "\<forall>i. h i \<in> A" by (auto simp: h_def ne_lists)
       from almost_full_on_imp_homogeneous_subseq [OF assms this]
       obtain \<phi> :: "nat \<Rightarrow> nat" where mono: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
         and P: "\<And>i j. i < j \<Longrightarrow> P (h (\<phi> i)) (h (\<phi> j))" by blast
       define f' where "f' i = (if i < \<phi> 0 then f i else tl (f (\<phi> (i - \<phi> 0))))" for i
       have f': "f' \<in> SEQ (lists A)" using ne and \<open>f \<in> SEQ (lists A)\<close>
         by (auto simp: f'_def dest: list.set_sel)
       have [simp]: "\<And>i. \<phi> 0 \<le> i \<Longrightarrow> h (\<phi> (i - \<phi> 0)) # f' i = f (\<phi> (i - \<phi> 0))"
         "\<And>i. i < \<phi> 0 \<Longrightarrow> f' i = f i" using ne by (auto simp: f'_def h_def)
       moreover have "strict_suffix (f' (\<phi> 0)) (f (\<phi> 0))" using ne by (auto simp: f'_def)
       ultimately have "LEX strict_suffix f' f" by (auto simp: LEX_def)
       with LEX_imp_not_LEX [OF this] have "strict (LEXEQ strict_suffix) f' f"
         using po_on_strict_suffix [of UNIV] unfolding po_on_def irreflp_on_def transp_on_def by blast
       from less(2) [OF f' this] have "good (list_emb P) f'" .
       then obtain i j where "i < j" and emb: "list_emb P (f' i) (f' j)" by (auto simp: good_def)
       consider "j < \<phi> 0" | "\<phi> 0 \<le> i" | "i < \<phi> 0" and "\<phi> 0 \<le> j" by arith
       then show ?thesis
       proof (cases)
         case 1 with \<open>i < j\<close> and emb show ?thesis by (auto simp: good_def)
       next
         case 2
         with \<open>i < j\<close> and P have "P (h (\<phi> (i - \<phi> 0))) (h (\<phi> (j - \<phi> 0)))" by auto
         with emb have "list_emb P (h (\<phi> (i - \<phi> 0)) # f' i) (h (\<phi> (j - \<phi> 0)) # f' j)" by auto
         then have "list_emb P (f (\<phi> (i - \<phi> 0))) (f (\<phi> (j - \<phi> 0)))" using 2 and \<open>i < j\<close> by auto
         moreover with 2 and \<open>i <j\<close> have "\<phi> (i - \<phi> 0) < \<phi> (j - \<phi> 0)" using mono by auto
         ultimately show ?thesis by (auto simp: good_def)
       next
         case 3
         with emb have "list_emb P (f i) (f' j)" by auto
         moreover have "f (\<phi> (j - \<phi> 0)) = h (\<phi> (j - \<phi> 0)) # f' j" using 3 by auto
         ultimately have "list_emb P (f i) (f (\<phi> (j - \<phi> 0)))" by auto
         moreover have "i < \<phi> (j - \<phi> 0)" using mono [of 0 "j - \<phi> 0"] and 3 by force
         ultimately show ?thesis by (auto simp: good_def)
       qed
     qed auto
   qed
 qed blast
 
 end
diff --git a/thys/Well_Quasi_Orders/Kruskal.thy b/thys/Well_Quasi_Orders/Kruskal.thy
--- a/thys/Well_Quasi_Orders/Kruskal.thy
+++ b/thys/Well_Quasi_Orders/Kruskal.thy
@@ -1,187 +1,187 @@
 (*  Title:      Well-Quasi-Orders
     Author:     Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>Kruskal's Tree Theorem\<close>
 
 theory Kruskal
 imports Well_Quasi_Orders
 begin
 
 locale kruskal_tree =
   fixes F :: "('b \<times> nat) set"
     and mk :: "'b \<Rightarrow> 'a list \<Rightarrow> ('a::size)"
     and root :: "'a \<Rightarrow> 'b \<times> nat"
     and args :: "'a \<Rightarrow> 'a list"
     and trees :: "'a set"
   assumes size_arg: "t \<in> trees \<Longrightarrow> s \<in> set (args t) \<Longrightarrow> size s < size t"
     and root_mk: "(f, length ts) \<in> F \<Longrightarrow> root (mk f ts) = (f, length ts)"
     and args_mk: "(f, length ts) \<in> F \<Longrightarrow> args (mk f ts) = ts"
     and mk_root_args: "t \<in> trees \<Longrightarrow> mk (fst (root t)) (args t) = t"
     and trees_root: "t \<in> trees \<Longrightarrow> root t \<in> F"
     and trees_arity: "t \<in> trees \<Longrightarrow> length (args t) = snd (root t)"
     and trees_args: "\<And>s. t \<in> trees \<Longrightarrow> s \<in> set (args t) \<Longrightarrow> s \<in> trees"
 begin
 
 lemma mk_inject [iff]:
   assumes "(f, length ss) \<in> F" and "(g, length ts) \<in> F"
   shows "mk f ss = mk g ts \<longleftrightarrow> f = g \<and> ss = ts"
 proof -
   { assume "mk f ss = mk g ts"
     then have "root (mk f ss) = root (mk g ts)"
       and "args (mk f ss) = args (mk g ts)" by auto }
   show ?thesis
     using root_mk [OF assms(1)] and root_mk [OF assms(2)]
       and args_mk [OF assms(1)] and args_mk [OF assms(2)] by auto
 qed
 
 inductive emb for P
 where
   arg: "\<lbrakk>(f, m) \<in> F; length ts = m; \<forall>t\<in>set ts. t \<in> trees;
     t \<in> set ts; emb P s t\<rbrakk> \<Longrightarrow> emb P s (mk f ts)" |
   list_emb: "\<lbrakk>(f, m) \<in> F; (g, n) \<in> F; length ss = m; length ts = n;
     \<forall>s \<in> set ss. s \<in> trees; \<forall>t \<in> set ts. t \<in> trees;
     P (f, m) (g, n); list_emb (emb P) ss ts\<rbrakk> \<Longrightarrow> emb P (mk f ss) (mk g ts)"
   monos list_emb_mono
 
 lemma almost_full_on_trees:
   assumes "almost_full_on P F"
   shows "almost_full_on (emb P) trees" (is "almost_full_on ?P ?A")
 proof (rule ccontr)
   interpret mbs ?A .
   assume "\<not> ?thesis"
   from mbs' [OF this] obtain m
     where bad: "m \<in> BAD ?P"
     and min: "\<forall>g. (m, g) \<in> gseq \<longrightarrow> good ?P g" ..
   then have trees: "\<And>i. m i \<in> trees" by auto
 
   define r where "r i = root (m i)" for i
   define a where "a i = args (m i)" for i
   define S where "S = \<Union>{set (a i) | i. True}"
 
   have m: "\<And>i. m i = mk (fst (r i)) (a i)"
    by (simp add: r_def a_def mk_root_args [OF trees])
   have lists: "\<forall>i. a i \<in> lists S" by (auto simp: a_def S_def)
   have arity: "\<And>i. length (a i) = snd (r i)"
     using trees_arity [OF trees] by (auto simp: r_def a_def)
   then have sig: "\<And>i. (fst (r i), length (a i)) \<in> F"
     using trees_root [OF trees] by (auto simp: a_def r_def)
   have a_trees: "\<And>i. \<forall>t \<in> set (a i). t \<in> trees" by (auto simp: a_def trees_args [OF trees])
 
   have "almost_full_on ?P S"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     then obtain s :: "nat \<Rightarrow> 'a"
       where S: "\<And>i. s i \<in> S" and bad_s: "bad ?P s" by (auto simp: almost_full_on_def)
 
     define n where "n = (LEAST n. \<exists>k. s k \<in> set (a n))"
     have "\<exists>n. \<exists>k. s k \<in> set (a n)" using S by (force simp: S_def)
     from LeastI_ex [OF this] obtain k
       where sk: "s k \<in> set (a n)" by (auto simp: n_def)
     have args: "\<And>k. \<exists>m \<ge> n. s k \<in> set (a m)"
       using S by (auto simp: S_def) (metis Least_le n_def)
 
     define m' where "m' i = (if i < n then m i else s (k + (i - n)))" for i
     
     have m'_less: "\<And>i. i < n \<Longrightarrow> m' i = m i" by (simp add: m'_def)
     have m'_geq: "\<And>i. i \<ge> n \<Longrightarrow> m' i = s (k + (i - n))" by (simp add: m'_def)
 
     have "bad ?P m'"
     proof
       assume "good ?P m'"
       then obtain i j where "i < j" and emb: "?P (m' i) (m' j)" by auto
       { assume "j < n"
         with \<open>i < j\<close> and emb have "?P (m i) (m j)" by (auto simp: m'_less)
         with \<open>i < j\<close> and bad have False by blast }
       moreover
       { assume "n \<le> i"
         with \<open>i < j\<close> and emb have "?P (s (k + (i - n))) (s (k + (j - n)))"
           and "k + (i - n) < k + (j - n)" by (auto simp: m'_geq)
         with bad_s have False by auto }
       moreover
       { assume "i < n" and "n \<le> j"
         with \<open>i < j\<close> and emb have *: "?P (m i) (s (k + (j - n)))" by (auto simp: m'_less m'_geq)
         with args obtain l where "l \<ge> n" and **: "s (k + (j - n)) \<in> set (a l)" by blast
         from emb.arg [OF sig [of l] _ a_trees [of l] ** *]
           have "?P (m i) (m l)" by (simp add: m)
         moreover have "i < l" using \<open>i < n\<close> and \<open>n \<le> l\<close> by auto
         ultimately have False using bad by blast }
       ultimately show False using \<open>i < j\<close> by arith
     qed
     moreover have "(m, m') \<in> gseq"
     proof -
       have "m \<in> SEQ ?A" using trees by auto
       moreover have "m' \<in> SEQ ?A"
         using trees and S and trees_args [OF trees] by (auto simp: m'_def a_def S_def)
       moreover have "\<forall>i < n. m i = m' i" by (auto simp: m'_less)
       moreover have "size (m' n) < size (m n)"
         using sk and size_arg [OF trees, unfolded m]
         by (auto simp: m m'_geq root_mk [OF sig] args_mk [OF sig])
       ultimately show ?thesis by (auto simp: gseq_def)
     qed
     ultimately show False using min by blast
   qed
   from almost_full_on_lists [OF this, THEN almost_full_on_imp_homogeneous_subseq, OF lists]
     obtain \<phi> :: "nat \<Rightarrow> nat"
     where less: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
       and lemb: "\<And>i j. i < j \<Longrightarrow> list_emb ?P (a (\<phi> i)) (a (\<phi> j))" by blast
   have roots: "\<And>i. r (\<phi> i) \<in> F" using trees [THEN trees_root] by (auto simp: r_def)
   then have "r \<circ> \<phi> \<in> SEQ F" by auto
   with assms have "good P (r \<circ> \<phi>)" by (auto simp: almost_full_on_def)
   then obtain i j
     where "i < j" and "P (r (\<phi> i)) (r (\<phi> j))" by auto
   with lemb [OF \<open>i < j\<close>] have "?P (m (\<phi> i)) (m (\<phi> j))"
     using sig and arity and a_trees by (auto simp: m intro!: emb.list_emb)
   with less [OF \<open>i < j\<close>] and bad show False by blast
 qed
 
 inductive_cases
   emb_mk2 [consumes 1, case_names arg list_emb]: "emb P s (mk g ts)"
 
 inductive_cases
   list_emb_Nil2_cases: "list_emb P xs []" and
   list_emb_Cons_cases: "list_emb P xs (y#ys)"
 
 lemma list_emb_trans_right:
   assumes "list_emb P xs ys" and "list_emb (\<lambda>y z. P y z \<and> (\<forall>x. P x y \<longrightarrow> P x z)) ys zs" 
   shows "list_emb P xs zs"
   using assms(2, 1) by (induct arbitrary: xs) (auto elim!: list_emb_Nil2_cases list_emb_Cons_cases)
 
 lemma emb_trans:
   assumes trans: "\<And>f g h. f \<in> F \<Longrightarrow> g \<in> F \<Longrightarrow> h \<in> F \<Longrightarrow> P f g \<Longrightarrow> P g h \<Longrightarrow> P f h"
   assumes "emb P s t" and "emb P t u"
   shows "emb P s u"
 using assms(3, 2)
 proof (induct arbitrary: s)
   case (arg f m ts v)
   then show ?case by (auto intro: emb.arg)
 next
   case (list_emb f m g n ss ts)
   note IH = this
   from \<open>emb P s (mk f ss)\<close>
     show ?case
   proof (cases rule: emb_mk2)
     case arg
     then show ?thesis using IH by (auto elim!: list_emb_set intro: emb.arg)
   next
     case list_emb
     then show ?thesis using IH by (auto intro: emb.intros dest: trans list_emb_trans_right)
   qed
 qed
 
 lemma transp_on_emb:
-  assumes "transp_on P F"
-  shows "transp_on (emb P) trees"
+  assumes "transp_on F P"
+  shows "transp_on trees (emb P)"
   using assms and emb_trans [of P] unfolding transp_on_def by blast
 
 lemma kruskal:
   assumes "wqo_on P F"
   shows "wqo_on (emb P) trees"
   using almost_full_on_trees [of P] and assms by (metis transp_on_emb wqo_on_def)
 
 end
 
 end
 
diff --git a/thys/Well_Quasi_Orders/Multiset_Extension.thy b/thys/Well_Quasi_Orders/Multiset_Extension.thy
--- a/thys/Well_Quasi_Orders/Multiset_Extension.thy
+++ b/thys/Well_Quasi_Orders/Multiset_Extension.thy
@@ -1,623 +1,623 @@
 (*  Title:      Well-Quasi-Orders
     Author:     Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>Multiset Extension of Orders (as Binary Predicates)\<close>
 
 (*TODO: move theory (and maybe rename)*)
 
 theory Multiset_Extension
 imports
   Open_Induction.Restricted_Predicates
   "HOL-Library.Multiset"
 begin
 
 definition multisets :: "'a set \<Rightarrow> 'a multiset set" where
   "multisets A = {M. set_mset M \<subseteq> A}"
 
 lemma in_multisets_iff:
   "M \<in> multisets A \<longleftrightarrow> set_mset M \<subseteq> A"
   by (simp add: multisets_def)
 
 lemma empty_multisets [simp]:
   "{#} \<in> multisets F"
   by (simp add: in_multisets_iff)
 
 lemma multisets_union [simp]:
   "M \<in> multisets A \<Longrightarrow> N \<in> multisets A \<Longrightarrow> M + N \<in> multisets A"
   by (auto simp add: in_multisets_iff)
 
 definition mulex1 :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "mulex1 P = (\<lambda>M N. (M, N) \<in> mult1 {(x, y). P x y})"
 
 lemma mulex1_empty [iff]:
   "mulex1 P M {#} \<longleftrightarrow> False"
   using not_less_empty [of M "{(x, y). P x y}"]
   by (auto simp: mulex1_def)
 
 lemma mulex1_add: "mulex1 P N (M0 + {#a#}) \<Longrightarrow>
   (\<exists>M. mulex1 P M M0 \<and> N = M + {#a#}) \<or>
   (\<exists>K. (\<forall>b. b \<in># K \<longrightarrow> P b a) \<and> N = M0 + K)"
   using less_add [of N a M0 "{(x, y). P x y}"]
   by (auto simp: mulex1_def)
 
 lemma mulex1_self_add_right [simp]:
   "mulex1 P A (add_mset a A)"
 proof -
   let ?R = "{(x, y). P x y}"
   thm mult1_def
   have "A + {#a#} = A + {#a#}" by simp
   moreover have "A = A + {#}" by simp
   moreover have "\<forall>b. b \<in># {#} \<longrightarrow> (b, a) \<in> ?R" by simp
   ultimately have "(A, add_mset a A) \<in> mult1 ?R"
     unfolding mult1_def by blast
   then show ?thesis by (simp add: mulex1_def)
 qed
 
 lemma empty_mult1 [simp]:
   "({#}, {#a#}) \<in> mult1 R"
 proof -
   have "{#a#} = {#} + {#a#}" by simp
   moreover have "{#} = {#} + {#}" by simp
   moreover have "\<forall>b. b \<in># {#} \<longrightarrow> (b, a) \<in> R" by simp
   ultimately show ?thesis unfolding mult1_def by force
 qed
 
 lemma empty_mulex1 [simp]:
   "mulex1 P {#} {#a#}"
   using empty_mult1 [of a "{(x, y). P x y}"] by (simp add: mulex1_def)
 
 definition mulex_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "mulex_on P A = (restrict_to (mulex1 P) (multisets A))\<^sup>+\<^sup>+"
 
 abbreviation mulex :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "mulex P \<equiv> mulex_on P UNIV"
 
 lemma mulex_on_induct [consumes 1, case_names base step, induct pred: mulex_on]:
   assumes "mulex_on P A M N"
     and "\<And>M N. \<lbrakk>M \<in> multisets A; N \<in> multisets A; mulex1 P M N\<rbrakk> \<Longrightarrow> Q M N"
     and "\<And>L M N. \<lbrakk>mulex_on P A L M; Q L M; N \<in> multisets A; mulex1 P M N\<rbrakk> \<Longrightarrow> Q L N"
   shows "Q M N"
   using assms unfolding mulex_on_def by (induct) blast+
 
 lemma mulex_on_self_add_singleton_right [simp]:
   assumes "a \<in> A" and "M \<in> multisets A"
   shows "mulex_on P A M (add_mset a M)"
 proof -
   have "mulex1 P M (M + {#a#})" by simp
   with assms have "restrict_to (mulex1 P) (multisets A) M (add_mset a M)"
     by (auto simp: multisets_def)
   then show ?thesis unfolding mulex_on_def by blast
 qed
 
 lemma singleton_multisets [iff]:
   "{#x#} \<in> multisets A \<longleftrightarrow> x \<in> A"
   by (auto simp: multisets_def)
 
 lemma union_multisetsD:
   assumes "M + N \<in> multisets A"
   shows "M \<in> multisets A \<and> N \<in> multisets A"
   using assms by (auto simp: multisets_def)
 
 lemma mulex_on_multisetsD [dest]:
   assumes "mulex_on P F M N"
   shows "M \<in> multisets F" and "N \<in> multisets F"
   using assms by (induct) auto
 
 lemma union_multisets_iff [iff]:
   "M + N \<in> multisets A \<longleftrightarrow> M \<in> multisets A \<and> N \<in> multisets A"
   by (auto dest: union_multisetsD)
 
 lemma add_mset_multisets_iff [iff]:
   "add_mset a M \<in> multisets A \<longleftrightarrow> a \<in> A \<and> M \<in> multisets A"
   unfolding add_mset_add_single[of a M] union_multisets_iff by auto
 
 lemma mulex_on_trans:
   "mulex_on P A L M \<Longrightarrow> mulex_on P A M N \<Longrightarrow> mulex_on P A L N"
   by (auto simp: mulex_on_def)
 
 lemma transp_on_mulex_on:
-  "transp_on (mulex_on P A) B"
+  "transp_on B (mulex_on P A)"
   using mulex_on_trans [of P A] by (auto simp: transp_on_def)
   
 lemma mulex_on_add_right [simp]:
   assumes "mulex_on P A M N" and "a \<in> A"
   shows "mulex_on P A M (add_mset a N)"
 proof -
   from assms have "a \<in> A" and "N \<in> multisets A" by auto
   then have "mulex_on P A N (add_mset a N)" by simp
   with \<open>mulex_on P A M N\<close> show ?thesis by (rule mulex_on_trans)
 qed
 
 lemma empty_mulex_on [simp]:
   assumes "M \<noteq> {#}" and "M \<in> multisets A"
   shows "mulex_on P A {#} M"
 using assms
 proof (induct M)
   case (add a M)
   show ?case
   proof (cases "M = {#}")
     assume "M = {#}"
     with add show ?thesis by (auto simp: mulex_on_def)
   next
     assume "M \<noteq> {#}"
     with add show ?thesis by (auto intro: mulex_on_trans)
   qed
 qed simp
 
 lemma mulex_on_self_add_right [simp]:
   assumes "M \<in> multisets A" and "K \<in> multisets A" and "K \<noteq> {#}"
   shows "mulex_on P A M (M + K)"
 using assms
 proof (induct K)
   case empty
   then show ?case by (cases "K = {#}") auto
 next
   case (add a M)
   show ?case
   proof (cases "M = {#}")
     assume "M = {#}" with add show ?thesis by auto
   next
     assume "M \<noteq> {#}" with add show ?thesis
       by (auto dest: mulex_on_add_right simp add: ac_simps)
   qed
 qed
 
 lemma mult1_singleton [iff]:
   "({#x#}, {#y#}) \<in> mult1 R \<longleftrightarrow> (x, y) \<in> R"
 proof
   assume "(x, y) \<in> R"
   then have "{#y#} = {#} + {#y#}"
     and "{#x#} = {#} + {#x#}"
     and "\<forall>b. b \<in># {#x#} \<longrightarrow> (b, y) \<in> R" by auto
   then show "({#x#}, {#y#}) \<in> mult1 R" unfolding mult1_def by blast
 next
   assume "({#x#}, {#y#}) \<in> mult1 R"
   then obtain M0 K a
     where "{#y#} = add_mset a M0"
     and "{#x#} = M0 + K"
     and "\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> R"
     unfolding mult1_def by blast
   then show "(x, y) \<in> R" by (auto simp: add_eq_conv_diff)
 qed
 
 lemma mulex1_singleton [iff]:
   "mulex1 P {#x#} {#y#} \<longleftrightarrow> P x y"
   using mult1_singleton [of x y "{(x, y). P x y}"] by (simp add: mulex1_def)
 
 lemma singleton_mulex_onI:
   "P x y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> mulex_on P A {#x#} {#y#}"
   by (auto simp: mulex_on_def)
 
 lemma reflclp_mulex_on_add_right [simp]:
   assumes "(mulex_on P A)\<^sup>=\<^sup>= M N" and "M \<in> multisets A" and "a \<in> A"
   shows "mulex_on P A M (N + {#a#})"
   using assms by (cases "M = N") simp_all
 
 lemma reflclp_mulex_on_add_right' [simp]:
   assumes "(mulex_on P A)\<^sup>=\<^sup>= M N" and "M \<in> multisets A" and "a \<in> A"
   shows "mulex_on P A M ({#a#} + N)"
   using reflclp_mulex_on_add_right [OF assms] by (simp add: ac_simps)
 
 lemma mulex_on_union_right [simp]:
   assumes "mulex_on P F A B" and "K \<in> multisets F"
   shows "mulex_on P F A (K + B)"
 using assms
 proof (induct K)
   case (add a K)
   then have "a \<in> F" and "mulex_on P F A (B + K)" by (auto simp: multisets_def ac_simps)
   then have "mulex_on P F A ((B + K) + {#a#})" by simp
   then show ?case by (simp add: ac_simps)
 qed simp
 
 lemma mulex_on_union_right' [simp]:
   assumes "mulex_on P F A B" and "K \<in> multisets F"
   shows "mulex_on P F A (B + K)"
   using mulex_on_union_right [OF assms] by (simp add: ac_simps)
 
 text \<open>Adapted from @{thm all_accessible} in @{theory "HOL-Library.Multiset"}.\<close>
 lemma accessible_on_mulex1_multisets:
   assumes wf: "wfp_on P A"
   shows "\<forall>M\<in>multisets A. accessible_on (mulex1 P) (multisets A) M"
 proof
   let ?P = "mulex1 P"
   let ?A = "multisets A"
   let ?acc = "accessible_on ?P ?A"
   {
     fix M M0 a
     assume M0: "?acc M0"
       and "a \<in> A"
       and "M0 \<in> ?A"
       and wf_hyp: "\<And>b. \<lbrakk>b \<in> A; P b a\<rbrakk> \<Longrightarrow> (\<forall>M. ?acc (M) \<longrightarrow> ?acc (M + {#b#}))"
       and acc_hyp: "\<forall>M. M \<in> ?A \<and> ?P M M0 \<longrightarrow> ?acc (M + {#a#})"
     then have "add_mset a M0 \<in> ?A" by (auto simp: multisets_def)
     then have "?acc (add_mset a M0)"
     proof (rule accessible_onI [of "add_mset a M0"])
       fix N
       assume "N \<in> ?A"
         and "?P N (add_mset a M0)"
       then have "((\<exists>M. M \<in> ?A \<and> ?P M M0 \<and> N = M + {#a#}) \<or>
           (\<exists>K. (\<forall>b. b \<in># K \<longrightarrow> P b a) \<and> N = M0 + K))"
         using mulex1_add [of P N M0 a] by (auto simp: multisets_def)
       then show "?acc (N)"
       proof (elim exE disjE conjE)
         fix M assume "M \<in> ?A" and "?P M M0" and N: "N = M + {#a#}"
         from acc_hyp have "M \<in> ?A \<and> ?P M M0 \<longrightarrow> ?acc (M + {#a#})" ..
         with \<open>M \<in> ?A\<close> and \<open>?P M M0\<close> have "?acc (M + {#a#})" by blast
         then show "?acc (N)" by (simp only: N)
       next
         fix K
         assume N: "N = M0 + K"
         assume "\<forall>b. b \<in># K \<longrightarrow> P b a"
         moreover from N and \<open>N \<in> ?A\<close> have "K \<in> ?A" by (auto simp: multisets_def)
         ultimately have "?acc (M0 + K)"
         proof (induct K)
           case empty
           from M0 show "?acc (M0 + {#})" by simp
         next
           case (add x K)
           from add.prems have "x \<in> A" and "P x a" by (auto simp: multisets_def)
           with wf_hyp have "\<forall>M. ?acc M \<longrightarrow> ?acc (M + {#x#})" by blast
           moreover from add have "?acc (M0 + K)" by (auto simp: multisets_def)
           ultimately show "?acc (M0 + (add_mset x K))" by simp
         qed
         then show "?acc N" by (simp only: N)
       qed
     qed
   } note tedious_reasoning = this
 
   fix M
   assume "M \<in> ?A"
   then show "?acc M"
   proof (induct M)
     show "?acc {#}"
     proof (rule accessible_onI)
       show "{#} \<in> ?A" by (auto simp: multisets_def)
     next
       fix b assume "?P b {#}" then show "?acc b" by simp
     qed
   next
     case (add a M)
     then have "?acc M" by (auto simp: multisets_def)
     from add have "a \<in> A" by (auto simp: multisets_def)
     with wf have "\<forall>M. ?acc M \<longrightarrow> ?acc (add_mset a M)"
     proof (induct)
       case (less a)
       then have r: "\<And>b. \<lbrakk>b \<in> A; P b a\<rbrakk> \<Longrightarrow> (\<forall>M. ?acc M \<longrightarrow> ?acc (M + {#b#}))" by auto
       show "\<forall>M. ?acc M \<longrightarrow> ?acc (add_mset a M)"
       proof (intro allI impI)
         fix M'
         assume "?acc M'"
         moreover then have "M' \<in> ?A" by (blast dest: accessible_on_imp_mem)
         ultimately show "?acc (add_mset a M')"
           by (induct) (rule tedious_reasoning [OF _ \<open>a \<in> A\<close> _ r], auto)
       qed
     qed
     with \<open>?acc (M)\<close> show "?acc (add_mset a M)" by blast
   qed
 qed
 
 lemmas wfp_on_mulex1_multisets =
   accessible_on_mulex1_multisets [THEN accessible_on_imp_wfp_on]
 
 lemmas irreflp_on_mulex1 =
   wfp_on_mulex1_multisets [THEN wfp_on_imp_irreflp_on]
 
 lemma wfp_on_mulex_on_multisets:
   assumes "wfp_on P A"
   shows "wfp_on (mulex_on P A) (multisets A)"
   using wfp_on_mulex1_multisets [OF assms]
   by (simp only: mulex_on_def wfp_on_restrict_to_tranclp_wfp_on_conv)
 
 lemmas irreflp_on_mulex_on =
   wfp_on_mulex_on_multisets [THEN wfp_on_imp_irreflp_on]
 
 lemma mulex1_union:
   "mulex1 P M N \<Longrightarrow> mulex1 P (K + M) (K + N)"
   by (auto simp: mulex1_def mult1_union)
 
 lemma mulex_on_union:
   assumes "mulex_on P A M N" and "K \<in> multisets A"
   shows "mulex_on P A (K + M) (K + N)"
 using assms
 proof (induct)
   case (base M N)
   then have "mulex1 P (K + M) (K + N)" by (blast dest: mulex1_union)
   moreover from base have "(K + M) \<in> multisets A"
     and "(K + N) \<in> multisets A" by (auto simp: multisets_def)
   ultimately have "restrict_to (mulex1 P) (multisets A) (K + M) (K + N)" by auto
   then show ?case by (auto simp: mulex_on_def)
 next
   case (step L M N)
   then have "mulex1 P (K + M) (K + N)" by (blast dest: mulex1_union)
   moreover from step have "(K + M) \<in> multisets A" and "(K + N) \<in> multisets A" by blast+
   ultimately have "(restrict_to (mulex1 P) (multisets A))\<^sup>+\<^sup>+ (K + M) (K + N)" by auto
   moreover have "mulex_on P A (K + L) (K + M)" using step by blast
   ultimately show ?case by (auto simp: mulex_on_def)
 qed
 
 lemma mulex_on_union':
   assumes "mulex_on P A M N" and "K \<in> multisets A"
   shows "mulex_on P A (M + K) (N + K)"
   using mulex_on_union [OF assms] by (simp add: ac_simps)
 
 lemma mulex_on_add_mset:
   assumes "mulex_on P A M N" and "m \<in> A"
   shows "mulex_on P A (add_mset m M) (add_mset m N)"
   unfolding add_mset_add_single[of m M] add_mset_add_single[of m N]
   apply (rule mulex_on_union')
   using assms by auto
 
 lemma union_mulex_on_mono:
   "mulex_on P F A C \<Longrightarrow> mulex_on P F B D \<Longrightarrow> mulex_on P F (A + B) (C + D)"
   by (metis mulex_on_multisetsD mulex_on_trans mulex_on_union mulex_on_union')
 
 lemma mulex_on_add_mset':
   assumes "P m n" and "m \<in> A" and "n \<in> A" and "M \<in> multisets A"
   shows "mulex_on P A (add_mset m M) (add_mset n M)"
   unfolding add_mset_add_single[of m M] add_mset_add_single[of n M]
   apply (rule mulex_on_union)
   using assms by (auto simp: mulex_on_def)
 
 lemma mulex_on_add_mset_mono:
   assumes "P m n" and "m \<in> A" and "n \<in> A" and "mulex_on P A M N"
   shows "mulex_on P A (add_mset m M) (add_mset n N)"
   unfolding add_mset_add_single[of m M] add_mset_add_single[of n N]
   apply (rule union_mulex_on_mono)
   using assms by (auto simp: mulex_on_def)
 
 lemma union_mulex_on_mono1:
   "A \<in> multisets F \<Longrightarrow> (mulex_on P F)\<^sup>=\<^sup>= A C \<Longrightarrow> mulex_on P F B D \<Longrightarrow>
     mulex_on P F (A + B) (C + D)"
   by (auto intro: union_mulex_on_mono mulex_on_union)
 
 lemma union_mulex_on_mono2:
   "B \<in> multisets F \<Longrightarrow> mulex_on P F A C \<Longrightarrow> (mulex_on P F)\<^sup>=\<^sup>= B D \<Longrightarrow>
     mulex_on P F (A + B) (C + D)"
   by (auto intro: union_mulex_on_mono mulex_on_union')
 
 lemma mult1_mono:
   assumes "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; (x, y) \<in> R\<rbrakk> \<Longrightarrow> (x, y) \<in> S"
     and "M \<in> multisets A"
     and "N \<in> multisets A"
     and "(M, N) \<in> mult1 R"
   shows "(M, N) \<in> mult1 S"
   using assms unfolding mult1_def multisets_def
   by auto (metis (full_types) subsetD)
 
 lemma mulex1_mono:
   assumes "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x y"
     and "M \<in> multisets A"
     and "N \<in> multisets A"
     and "mulex1 P M N"
   shows "mulex1 Q M N"
   using mult1_mono [of A "{(x, y). P x y}" "{(x, y). Q x y}" M N]
     and assms unfolding mulex1_def by blast
 
 lemma mulex_on_mono:
   assumes *: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A; P x y\<rbrakk> \<Longrightarrow> Q x y"
     and "mulex_on P A M N"
   shows "mulex_on Q A M N"
 proof -
   let ?rel = "\<lambda>P. (restrict_to (mulex1 P) (multisets A))"
   from \<open>mulex_on P A M N\<close> have "(?rel P)\<^sup>+\<^sup>+ M N" by (simp add: mulex_on_def)
   then have "(?rel Q)\<^sup>+\<^sup>+ M N"
   proof (induct rule: tranclp.induct)
     case (r_into_trancl M N)
     then have "M \<in> multisets A" and "N \<in> multisets A" by auto
     from mulex1_mono [OF * this] and r_into_trancl
       show ?case by auto
   next
     case (trancl_into_trancl L M N)
     then have "M \<in> multisets A" and "N \<in> multisets A" by auto
     from mulex1_mono [OF * this] and trancl_into_trancl
       have "?rel Q M N" by auto
     with \<open>(?rel Q)\<^sup>+\<^sup>+ L M\<close> show ?case by (rule tranclp.trancl_into_trancl)
   qed
   then show ?thesis by (simp add: mulex_on_def)
 qed
 
 lemma mult1_reflcl:
   assumes "(M, N) \<in> mult1 R"
   shows "(M, N) \<in> mult1 (R\<^sup>=)"
   using assms by (auto simp: mult1_def)
 
 lemma mulex1_reflclp:
   assumes "mulex1 P M N"
   shows "mulex1 (P\<^sup>=\<^sup>=) M N"
   using mulex1_mono [of UNIV P "P\<^sup>=\<^sup>=" M N, OF _ _ _ assms]
   by (auto simp: multisets_def)
 
 lemma mulex_on_reflclp:
   assumes "mulex_on P A M N"
   shows "mulex_on (P\<^sup>=\<^sup>=) A M N"
   using mulex_on_mono [OF _ assms, of "P\<^sup>=\<^sup>="] by auto                  
 
 lemma surj_on_multisets_mset:
   "\<forall>M\<in>multisets A. \<exists>xs\<in>lists A. M = mset xs"
 proof
   fix M
   assume "M \<in> multisets A"
   then show "\<exists>xs\<in>lists A. M = mset xs"
   proof (induct M)
     case empty show ?case by simp
   next
     case (add a M)
     then obtain xs where "xs \<in> lists A" and "M = mset xs" by auto
     then have "add_mset a M = mset (a # xs)" by simp
     moreover have "a # xs \<in> lists A" using \<open>xs \<in> lists A\<close> and add by auto
     ultimately show ?case by blast
   qed
 qed
 
 lemma image_mset_lists [simp]:
   "mset ` lists A = multisets A"
   using surj_on_multisets_mset [of A]
   by auto (metis mem_Collect_eq multisets_def set_mset_mset subsetI)
 
 lemma multisets_UNIV [simp]: "multisets UNIV = UNIV"
   by (metis image_mset_lists lists_UNIV surj_mset)
 
 lemma non_empty_multiset_induct [consumes 1, case_names singleton add]:
   assumes "M \<noteq> {#}"
     and "\<And>x. P {#x#}"
     and "\<And>x M. P M \<Longrightarrow> P (add_mset x M)"
   shows "P M"
   using assms by (induct M) auto
 
 lemma mulex_on_all_strict:
   assumes "X \<noteq> {#}"
   assumes "X \<in> multisets A" and "Y \<in> multisets A"
     and *: "\<forall>y. y \<in># Y \<longrightarrow> (\<exists>x. x \<in># X \<and> P y x)"
   shows "mulex_on P A Y X"
 using assms
 proof (induction X arbitrary: Y rule: non_empty_multiset_induct)
   case (singleton x)
   then have "mulex1 P Y {#x#}"
     unfolding mulex1_def mult1_def
     by auto
   with singleton show ?case by (auto simp: mulex_on_def)
 next
   case (add x M)
   let ?Y = "{# y \<in># Y. \<exists>x. x \<in># M \<and> P y x #}"
   let ?Z = "Y - ?Y"
   have Y: "Y = ?Z + ?Y" by (subst multiset_eq_iff) auto
   from \<open>Y \<in> multisets A\<close> have "?Y \<in> multisets A" by (metis multiset_partition union_multisets_iff)
   moreover have "\<forall>y. y \<in># ?Y \<longrightarrow> (\<exists>x. x \<in># M \<and> P y x)" by auto
   moreover have "M \<in> multisets A" using add by auto
   ultimately have "mulex_on P A ?Y M" using add by blast
   moreover have "mulex_on P A ?Z {#x#}"
   proof -
     have "{#x#} = {#} + {#x#}" by simp
     moreover have "?Z = {#} + ?Z" by simp
     moreover have "\<forall>y. y \<in># ?Z \<longrightarrow> P y x"
       using add.prems by (auto simp add: in_diff_count split: if_splits)
     ultimately have "mulex1 P ?Z {#x#}" unfolding mulex1_def mult1_def by blast
     moreover have "{#x#} \<in> multisets A" using add.prems by auto
     moreover have "?Z \<in> multisets A"
       using \<open>Y \<in> multisets A\<close> by (metis diff_union_cancelL multiset_partition union_multisetsD)
     ultimately show ?thesis by (auto simp: mulex_on_def)
   qed
   ultimately have "mulex_on P A (?Y + ?Z) (M + {#x#})" by (rule union_mulex_on_mono)
   then show ?case using Y by (simp add: ac_simps)
 qed
 
 text \<open>The following lemma shows that the textbook definition (e.g.,
 ``Term Rewriting and All That'') is the same as the one used below.\<close>
 lemma diff_set_Ex_iff:
   "X \<noteq> {#} \<and> X \<subseteq># M \<and> N = (M - X) + Y \<longleftrightarrow> X \<noteq> {#} \<and> (\<exists>Z. M = Z + X \<and> N = Z + Y)"
   by (auto) (metis add_diff_cancel_left' multiset_diff_union_assoc union_commute)
 
 text \<open>Show that @{const mulex_on} is equivalent to the textbook definition
 of multiset-extension for transitive base orders.\<close>
 lemma mulex_on_alt_def:
-  assumes trans: "transp_on P A"
+  assumes trans: "transp_on A P"
   shows "mulex_on P A M N \<longleftrightarrow> M \<in> multisets A \<and> N \<in> multisets A \<and> (\<exists>X Y Z.
     X \<noteq> {#} \<and> N = Z + X \<and> M = Z + Y \<and> (\<forall>y. y \<in># Y \<longrightarrow> (\<exists>x. x \<in># X \<and> P y x)))"
   (is "?P M N \<longleftrightarrow> ?Q M N")
 proof
   assume "?P M N" then show "?Q M N"
   proof (induct M N)
     case (base M N)
     then obtain a M0 K where N: "N = M0 + {#a#}"
       and M: "M = M0 + K"
       and *: "\<forall>b. b \<in># K \<longrightarrow> P b a"
       and "M \<in> multisets A" and "N \<in> multisets A" by (auto simp: mulex1_def mult1_def)
     moreover then have "{#a#} \<in> multisets A" and "K \<in> multisets A" by auto
     moreover have "{#a#} \<noteq> {#}" by auto
     moreover have "N = M0 + {#a#}" by fact
     moreover have "M = M0 + K" by fact
     moreover have "\<forall>y. y \<in># K \<longrightarrow> (\<exists>x. x \<in># {#a#} \<and> P y x)" using * by auto
     ultimately show ?case by blast
   next
     case (step L M N)
     then obtain X Y Z
       where "L \<in> multisets A" and "M \<in> multisets A" and "N \<in> multisets A"
       and "X \<in> multisets A" and "Y \<in> multisets A"
       and M: "M = Z + X"
       and L: "L = Z + Y" and "X \<noteq> {#}"
       and Y: "\<forall>y. y \<in># Y \<longrightarrow> (\<exists>x. x \<in># X \<and> P y x)"
       and "mulex1 P M N"
       by blast
     from \<open>mulex1 P M N\<close> obtain a M0 K
       where N: "N = add_mset a M0" and M': "M = M0 + K"
       and *: "\<forall>b. b \<in># K \<longrightarrow> P b a" unfolding mulex1_def mult1_def by blast
     have L': "L = (M - X) + Y" by (simp add: L M)
     have K: "\<forall>y. y \<in># K \<longrightarrow> (\<exists>x. x \<in># {#a#} \<and> P y x)" using * by auto
 
     txt \<open>The remainder of the proof is adapted from the proof of Lemma 2.5.4. of
     the book ``Term Rewriting and All That.''\<close>
     let ?X = "add_mset a (X - K)"
     let ?Y = "(K - X) + Y"
     
     have "L \<in> multisets A" and "N \<in> multisets A" by fact+
     moreover have "?X \<noteq> {#} \<and> (\<exists>Z. N = Z + ?X \<and> L = Z + ?Y)"
     proof -
       have "?X \<noteq> {#}" by auto
       moreover have "?X \<subseteq># N"
         using M N M' by (simp add: add.commute [of "{#a#}"])
           (metis Multiset.diff_subset_eq_self add.commute add_diff_cancel_right)
       moreover have "L = (N - ?X) + ?Y"
       proof (rule multiset_eqI)
         fix x :: 'a
         let ?c = "\<lambda>M. count M x"
         let ?ic = "\<lambda>x. int (?c x)"
         from \<open>?X \<subseteq># N\<close> have *: "?c {#a#} + ?c (X - K) \<le> ?c N"
           by (auto simp add: subseteq_mset_def split: if_splits)
         from * have **: "?c (X - K) \<le> ?c M0" unfolding N by (auto split: if_splits)
         have "?ic (N - ?X + ?Y) = int (?c N - ?c ?X) + ?ic ?Y" by simp
         also have "\<dots> = int (?c N - (?c {#a#} + ?c (X - K))) + ?ic (K - X) + ?ic Y" by simp
         also have "\<dots> = ?ic N - (?ic {#a#} + ?ic (X - K)) + ?ic (K - X) + ?ic Y"
           using of_nat_diff [OF *] by simp
         also have "\<dots> = (?ic N - ?ic {#a#}) - ?ic (X - K) + ?ic (K - X) + ?ic Y" by simp
         also have "\<dots> = (?ic N - ?ic {#a#}) + (?ic (K - X) - ?ic (X - K)) + ?ic Y" by simp
         also have "\<dots> = (?ic N - ?ic {#a#}) + (?ic K - ?ic X) + ?ic Y" by simp
         also have "\<dots> = (?ic N - ?ic ?X) + ?ic ?Y" by (simp add: N)
         also have "\<dots> = ?ic L"
           unfolding L' M' N
           using ** by (simp add: algebra_simps)
         finally show "?c L = ?c (N - ?X + ?Y)" by simp
       qed
       ultimately show ?thesis by (metis diff_set_Ex_iff)
     qed
     moreover have "\<forall>y. y \<in># ?Y \<longrightarrow> (\<exists>x. x \<in># ?X \<and> P y x)"
     proof (intro allI impI)
       fix y assume "y \<in># ?Y"
       then have "y \<in># K - X \<or> y \<in># Y" by auto
       then show "\<exists>x. x \<in># ?X \<and> P y x"
       proof
         assume "y \<in># K - X"
         then have "y \<in># K" by (rule in_diffD)
         with K show ?thesis by auto
       next
         assume "y \<in># Y"
         with Y obtain x where "x \<in># X" and "P y x" by blast
         { assume "x \<in># X - K" with \<open>P y x\<close> have ?thesis by auto }
         moreover
         { assume "x \<in># K" with * have "P x a" by auto
           moreover have "y \<in> A" using \<open>Y \<in> multisets A\<close> and \<open>y \<in># Y\<close> by (auto simp: multisets_def)
           moreover have "a \<in> A" using \<open>N \<in> multisets A\<close> by (auto simp: N)
           moreover have "x \<in> A" using \<open>M \<in> multisets A\<close> and \<open>x \<in># K\<close> by (auto simp: M' multisets_def)
           ultimately have "P y a" using \<open>P y x\<close> and trans unfolding transp_on_def by blast
           then have ?thesis by force }
         moreover from \<open>x \<in># X\<close> have "x \<in># X - K \<or> x \<in># K"
           by (auto simp add: in_diff_count not_in_iff)
         ultimately show ?thesis by auto
       qed
     qed
     ultimately show ?case by blast
   qed
 next
   assume "?Q M N"
   then obtain X Y Z where "M \<in> multisets A" and "N \<in> multisets A"
     and "X \<noteq> {#}" and N: "N = Z + X" and M: "M = Z + Y"
     and *: "\<forall>y. y \<in># Y \<longrightarrow> (\<exists>x. x \<in># X \<and> P y x)" by blast
   with mulex_on_all_strict [of X A Y] have "mulex_on P A Y X" by auto
   moreover from \<open>N \<in> multisets A\<close> have "Z \<in> multisets A" by (auto simp: N)
   ultimately show "?P M N" unfolding M N by (metis mulex_on_union)
 qed
 
 end
 
diff --git a/thys/Well_Quasi_Orders/Well_Quasi_Orders.thy b/thys/Well_Quasi_Orders/Well_Quasi_Orders.thy
--- a/thys/Well_Quasi_Orders/Well_Quasi_Orders.thy
+++ b/thys/Well_Quasi_Orders/Well_Quasi_Orders.thy
@@ -1,317 +1,317 @@
 (*  Title:      Well-Quasi-Orders
     Author:     Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>Well-Quasi-Orders\<close>
 
 theory Well_Quasi_Orders
 imports Almost_Full_Relations
 begin
 
 subsection \<open>Basic Definitions\<close>
 
 definition wqo_on :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
-  "wqo_on P A \<longleftrightarrow> transp_on P A \<and> almost_full_on P A"
+  "wqo_on P A \<longleftrightarrow> transp_on A P \<and> almost_full_on P A"
 
 lemma wqo_on_UNIV:
   "wqo_on (\<lambda>_ _. True) UNIV"
   using almost_full_on_UNIV by (auto simp: wqo_on_def transp_on_def)
 
 lemma wqo_onI [Pure.intro]:
-  "\<lbrakk>transp_on P A; almost_full_on P A\<rbrakk> \<Longrightarrow> wqo_on P A"
+  "\<lbrakk>transp_on A P; almost_full_on P A\<rbrakk> \<Longrightarrow> wqo_on P A"
   unfolding wqo_on_def almost_full_on_def by blast
 
 lemma wqo_on_imp_reflp_on:
   "wqo_on P A \<Longrightarrow> reflp_on A P"
   using almost_full_on_imp_reflp_on by (auto simp: wqo_on_def)
 
 lemma wqo_on_imp_transp_on:
-  "wqo_on P A \<Longrightarrow> transp_on P A"
+  "wqo_on P A \<Longrightarrow> transp_on A P"
   by (auto simp: wqo_on_def)
 
 lemma wqo_on_imp_almost_full_on:
   "wqo_on P A \<Longrightarrow> almost_full_on P A"
   by (auto simp: wqo_on_def)
 
 lemma wqo_on_imp_qo_on:
   "wqo_on P A \<Longrightarrow> qo_on P A"
   by (metis qo_on_def wqo_on_imp_reflp_on wqo_on_imp_transp_on)
 
 lemma wqo_on_imp_good:
   "wqo_on P A \<Longrightarrow> \<forall>i. f i \<in> A \<Longrightarrow> good P f"
   by (auto simp: wqo_on_def almost_full_on_def)
 
 lemma wqo_on_subset:
   "A \<subseteq> B \<Longrightarrow> wqo_on P B \<Longrightarrow> wqo_on P A"
   using almost_full_on_subset [of A B P]
-    and transp_on_subset [of A B P]
+    and transp_on_subset [of B P A]
   unfolding wqo_on_def by blast
 
 
 subsection \<open>Equivalent Definitions\<close>
 
 text \<open>
   Given a quasi-order @{term P}, the following statements are equivalent:
   \begin{enumerate}
   \item @{term P} is a almost-full.
   \item @{term P} does neither allow decreasing chains nor antichains.
   \item Every quasi-order extending @{term P} is well-founded.
   \end{enumerate}
 \<close>
 
 lemma wqo_af_conv:
   assumes "qo_on P A"
   shows "wqo_on P A \<longleftrightarrow> almost_full_on P A"
   using assms by (metis qo_on_def wqo_on_def)
 
 lemma wqo_wf_and_no_antichain_conv:
   assumes "qo_on P A"
   shows "wqo_on P A \<longleftrightarrow> wfp_on (strict P) A \<and> \<not> (\<exists>f. antichain_on P f A)"
   unfolding wqo_af_conv [OF assms]
   using af_trans_imp_wf [OF _ assms [THEN qo_on_imp_transp_on]]
     and almost_full_on_imp_no_antichain_on [of P A]
     and wf_and_no_antichain_imp_qo_extension_wf [of P A]
     and every_qo_extension_wf_imp_af [OF _ assms]
     by blast
 
 lemma wqo_extensions_wf_conv:
   assumes "qo_on P A"
   shows "wqo_on P A \<longleftrightarrow> (\<forall>Q. (\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q x y) \<and> qo_on Q A \<longrightarrow> wfp_on (strict Q) A)"
   unfolding wqo_af_conv [OF assms]
   using af_trans_imp_wf [OF _ assms [THEN qo_on_imp_transp_on]]
     and almost_full_on_imp_no_antichain_on [of P A]
     and wf_and_no_antichain_imp_qo_extension_wf [of P A]
     and every_qo_extension_wf_imp_af [OF _ assms]
     by blast
 
 lemma wqo_on_imp_wfp_on:
   "wqo_on P A \<Longrightarrow> wfp_on (strict P) A"
   by (metis (no_types) wqo_on_imp_qo_on wqo_wf_and_no_antichain_conv)
 
 text \<open>
   The homomorphic image of a wqo set is wqo.
 \<close>
 lemma wqo_on_hom:
-  assumes "transp_on Q (h ` A)"
+  assumes "transp_on (h ` A) Q"
     and "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longrightarrow> Q (h x) (h y)"
     and "wqo_on P A"
   shows "wqo_on Q (h ` A)"
   using assms and almost_full_on_hom [of A P Q h]
   unfolding wqo_on_def by blast
 
 text \<open>
   The monomorphic preimage of a wqo set is wqo.
 \<close>
 lemma wqo_on_mon:
   assumes *: "\<forall>x\<in>A. \<forall>y\<in>A. P x y \<longleftrightarrow> Q (h x) (h y)"
     and bij: "bij_betw h A B"
     and wqo: "wqo_on Q B"
   shows "wqo_on P A"
 proof -
-  have "transp_on P A"
-  proof
+  have "transp_on A P"
+  proof (rule transp_onI)
     fix x y z assume [intro!]: "x \<in> A" "y \<in> A" "z \<in> A"
       and "P x y" and "P y z"
     with * have "Q (h x) (h y)" and "Q (h y) (h z)" by blast+
     with wqo_on_imp_transp_on [OF wqo] have "Q (h x) (h z)"
       using bij by (auto simp: bij_betw_def transp_on_def)
     with * show "P x z" by blast
   qed
   with assms and almost_full_on_mon [of A P Q h]
     show ?thesis unfolding wqo_on_def by blast
 qed
 
 
 subsection \<open>A Type Class for Well-Quasi-Orders\<close>
 
 text \<open>
   In a well-quasi-order (wqo) every infinite sequence is good.
 \<close>
 class wqo = preorder +
   assumes good: "good (\<le>) f"
 
 lemma wqo_on_class [simp, intro]:
   "wqo_on (\<le>) (UNIV :: ('a :: wqo) set)"
   using good by (auto simp: wqo_on_def transp_on_def almost_full_on_def dest: order_trans)
 
 lemma wqo_on_UNIV_class_wqo [intro!]:
   "wqo_on P UNIV \<Longrightarrow> class.wqo P (strict P)"
   by (unfold_locales) (auto simp: wqo_on_def almost_full_on_def, unfold transp_on_def, blast)
 
 text \<open>
   The following lemma converts between @{const wqo_on} (for the special case that the domain is the
   universe of a type) and the class predicate @{const class.wqo}.
 \<close>
 lemma wqo_on_UNIV_conv:
   "wqo_on P UNIV \<longleftrightarrow> class.wqo P (strict P)" (is "?lhs = ?rhs")
 proof
   assume "?lhs" then show "?rhs" by auto
 next
   assume "?rhs" then show "?lhs"
     unfolding class.wqo_def class.preorder_def class.wqo_axioms_def
     by (auto simp: wqo_on_def almost_full_on_def transp_on_def)
 qed
 
 text \<open>
   The strict part of a wqo is well-founded.
 \<close>
 lemma (in wqo) "wfP (<)"
 proof -
   have "class.wqo (\<le>) (<)" ..
   hence "wqo_on (\<le>) UNIV"
     unfolding less_le_not_le [abs_def] wqo_on_UNIV_conv [symmetric] .
   from wqo_on_imp_wfp_on [OF this]
     show ?thesis unfolding less_le_not_le [abs_def] wfp_on_UNIV .
 qed
 
 lemma wqo_on_with_bot:
   assumes "wqo_on P A"
   shows "wqo_on (option_le P) A\<^sub>\<bottom>" (is "wqo_on ?P ?A")
 proof -
-  { from assms have trans [unfolded transp_on_def]: "transp_on P A"
+  { from assms have trans [unfolded transp_on_def]: "transp_on A P"
       by (auto simp: wqo_on_def)
-    have "transp_on ?P ?A"
+    have "transp_on ?A ?P"
       by (auto simp: transp_on_def elim!: with_bot_cases, insert trans) blast }
   moreover
   { from assms and almost_full_on_with_bot
       have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
   ultimately
   show ?thesis by (auto simp: wqo_on_def)
 qed
 
 lemma wqo_on_option_UNIV [intro]:
   "wqo_on P UNIV \<Longrightarrow> wqo_on (option_le P) UNIV"
   using wqo_on_with_bot [of P UNIV] by simp
 
 text \<open>
   When two sets are wqo, then their disjoint sum is wqo.
 \<close>
 lemma wqo_on_Plus:
   assumes "wqo_on P A" and "wqo_on Q B"
   shows "wqo_on (sum_le P Q) (A <+> B)" (is "wqo_on ?P ?A")
 proof -
-  { from assms have trans [unfolded transp_on_def]: "transp_on P A" "transp_on Q B"
+  { from assms have trans [unfolded transp_on_def]: "transp_on A P" "transp_on B Q"
       by (auto simp: wqo_on_def)
-    have "transp_on ?P ?A"
+    have "transp_on ?A ?P"
       unfolding transp_on_def by (auto, insert trans) (blast+) }
   moreover
   { from assms and almost_full_on_Plus have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
   ultimately
   show ?thesis by (auto simp: wqo_on_def)
 qed
 
 lemma wqo_on_sum_UNIV [intro]:
   "wqo_on P UNIV \<Longrightarrow> wqo_on Q UNIV \<Longrightarrow> wqo_on (sum_le P Q) UNIV"
   using wqo_on_Plus [of P UNIV Q UNIV] by simp
 
 
 subsection \<open>Dickson's Lemma\<close>
 
 lemma wqo_on_Sigma:
   fixes A1 :: "'a set" and A2 :: "'b set"
   assumes "wqo_on P1 A1" and "wqo_on P2 A2"
   shows "wqo_on (prod_le P1 P2) (A1 \<times> A2)" (is "wqo_on ?P ?A")
 proof -
-  { from assms have "transp_on P1 A1" and "transp_on P2 A2" by (auto simp: wqo_on_def)
-    hence "transp_on ?P ?A" unfolding transp_on_def prod_le_def by blast }
+  { from assms have "transp_on A1 P1" and "transp_on A2 P2" by (auto simp: wqo_on_def)
+    hence "transp_on ?A ?P" unfolding transp_on_def prod_le_def by blast }
   moreover
   { from assms and almost_full_on_Sigma [of P1 A1 P2 A2]
       have "almost_full_on ?P ?A" by (auto simp: wqo_on_def) }
   ultimately
   show ?thesis by (auto simp: wqo_on_def)
 qed
 
 lemmas dickson = wqo_on_Sigma
 
 lemma wqo_on_prod_UNIV [intro]:
   "wqo_on P UNIV \<Longrightarrow> wqo_on Q UNIV \<Longrightarrow> wqo_on (prod_le P Q) UNIV"
   using wqo_on_Sigma [of P UNIV Q UNIV] by simp
 
 
 subsection \<open>Higman's Lemma\<close>
 
 lemma transp_on_list_emb:
-  assumes "transp_on P A"
-  shows "transp_on (list_emb P) (lists A)"
+  assumes "transp_on A P"
+  shows "transp_on (lists A) (list_emb P)"
   using assms and list_emb_trans [of _ _ _ P]
     unfolding transp_on_def by blast
 
 lemma wqo_on_lists:
   assumes "wqo_on P A" shows "wqo_on (list_emb P) (lists A)"
   using assms and almost_full_on_lists
     and transp_on_list_emb by (auto simp: wqo_on_def)
 
 lemmas higman = wqo_on_lists
 
 lemma wqo_on_list_UNIV [intro]:
   "wqo_on P UNIV \<Longrightarrow> wqo_on (list_emb P) UNIV"
   using wqo_on_lists [of P UNIV] by simp
 
 text \<open>
   Every reflexive and transitive relation on a finite set is a wqo.
 \<close>
 lemma finite_wqo_on:
-  assumes "finite A" and refl: "reflp_on A P" and "transp_on P A"
+  assumes "finite A" and refl: "reflp_on A P" and "transp_on A P"
   shows "wqo_on P A"
   using assms and finite_almost_full_on by (auto simp: wqo_on_def)
 
 lemma finite_eq_wqo_on:
   assumes "finite A"
   shows "wqo_on (=) A"
   using finite_wqo_on [OF assms, of "(=)"]
   by (auto simp: reflp_on_def transp_on_def)
 
 lemma wqo_on_lists_over_finite_sets:
   "wqo_on (list_emb (=)) (UNIV::('a::finite) list set)"
   using wqo_on_lists [OF finite_eq_wqo_on [OF finite [of "UNIV::('a::finite) set"]]] by simp
 
 lemma wqo_on_map:
   fixes P and Q and h
   defines "P' \<equiv> \<lambda>x y. P x y \<and> Q (h x) (h y)"
   assumes "wqo_on P A"
     and "wqo_on Q B"
     and subset: "h ` A \<subseteq> B"
   shows "wqo_on P' A"
 proof
   let ?Q = "\<lambda>x y. Q (h x) (h y)"
-  from \<open>wqo_on P A\<close> have "transp_on P A"
+  from \<open>wqo_on P A\<close> have "transp_on A P"
     by (rule wqo_on_imp_transp_on)
-  then show "transp_on P' A"
+  then show "transp_on A P'"
     using \<open>wqo_on Q B\<close> and subset
     unfolding wqo_on_def transp_on_def P'_def by blast
 
   from \<open>wqo_on P A\<close> have "almost_full_on P A"
     by (rule wqo_on_imp_almost_full_on)
   from \<open>wqo_on Q B\<close> have "almost_full_on Q B"
     by (rule wqo_on_imp_almost_full_on)
 
   show "almost_full_on P' A"
   proof
     fix f
     assume *: "\<forall>i::nat. f i \<in> A"
     from almost_full_on_imp_homogeneous_subseq [OF \<open>almost_full_on P A\<close> this]
       obtain g :: "nat \<Rightarrow> nat"
       where g: "\<And>i j. i < j \<Longrightarrow> g i < g j"
       and **: "\<forall>i. f (g i) \<in> A \<and> P (f (g i)) (f (g (Suc i)))"
       using * by auto
-    from chain_transp_on_less [OF ** \<open>transp_on P A\<close>]
+    from chain_transp_on_less [OF ** \<open>transp_on A P\<close>]
       have **: "\<And>i j. i < j \<Longrightarrow> P (f (g i)) (f (g j))" .
     let ?g = "\<lambda>i. h (f (g i))"
     from * and subset have B: "\<And>i. ?g i \<in> B" by auto
     with \<open>almost_full_on Q B\<close> [unfolded almost_full_on_def good_def, THEN bspec, of ?g]
       obtain i j :: nat
       where "i < j" and "Q (?g i) (?g j)" by blast
     with ** [OF \<open>i < j\<close>] have "P' (f (g i)) (f (g j))"
       by (auto simp: P'_def)
     with g [OF \<open>i < j\<close>] show "good P' f" by (auto simp: good_def)
   qed
 qed
 
 lemma wqo_on_UNIV_nat:
   "wqo_on (\<le>) (UNIV :: nat set)"
   unfolding wqo_on_def transp_on_def
   using almost_full_on_UNIV_nat by simp
 
 end
diff --git a/thys/Well_Quasi_Orders/Wqo_Multiset.thy b/thys/Well_Quasi_Orders/Wqo_Multiset.thy
--- a/thys/Well_Quasi_Orders/Wqo_Multiset.thy
+++ b/thys/Well_Quasi_Orders/Wqo_Multiset.thy
@@ -1,60 +1,60 @@
 (*  Title:      Well-Quasi-Orders
     Author:     Christian Sternagel <c.sternagel@gmail.com>
     Maintainer: Christian Sternagel
     License:    LGPL
 *)
 
 section \<open>Multiset Extension Preserves Well-Quasi-Orders\<close>
 
 theory Wqo_Multiset
 imports
   Multiset_Extension
   Well_Quasi_Orders
 begin
 
 lemma list_emb_imp_reflclp_mulex_on:
   assumes "xs \<in> lists A" and "ys \<in> lists A"
     and "list_emb P xs ys"
   shows "(mulex_on P A)\<^sup>=\<^sup>= (mset xs) (mset ys)"
 using assms(3, 1, 2)
 proof (induct)
   case (list_emb_Nil ys)
   then show ?case
     by (cases ys) (auto intro!: empty_mulex_on simp: multisets_def)
 next
   case (list_emb_Cons xs ys y)
   then show ?case by (auto intro!: mulex_on_self_add_singleton_right simp: multisets_def)
 next
   case (list_emb_Cons2 x y xs ys)
   then show ?case
     by (force intro: union_mulex_on_mono mulex_on_add_mset
              mulex_on_add_mset' mulex_on_add_mset_mono
              simp: multisets_def)
 qed
 
 text \<open>The (reflexive closure of the) multiset extension of an almost-full relation
 is almost-full.\<close>
 lemma almost_full_on_multisets:
   assumes "almost_full_on P A"
   shows "almost_full_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
 proof -
   let ?P = "(mulex_on P A)\<^sup>=\<^sup>="
   from almost_full_on_hom [OF _ almost_full_on_lists, of A P ?P mset,
     OF list_emb_imp_reflclp_mulex_on, simplified]
     show ?thesis using assms by blast
 qed
 
 lemma wqo_on_multisets:
   assumes "wqo_on P A"
   shows "wqo_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
 proof
-  from transp_on_mulex_on [of P A "multisets A"]
-    show "transp_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)"
+  from transp_on_mulex_on [of "multisets A" P A]
+    show "transp_on (multisets A) (mulex_on P A)\<^sup>=\<^sup>="
     unfolding transp_on_def by blast
 next
   from almost_full_on_multisets [OF assms [THEN wqo_on_imp_almost_full_on]]
     show "almost_full_on (mulex_on P A)\<^sup>=\<^sup>= (multisets A)" .
 qed
 
 end