diff --git a/src/HOL/Finite_Set.thy b/src/HOL/Finite_Set.thy
--- a/src/HOL/Finite_Set.thy
+++ b/src/HOL/Finite_Set.thy
@@ -1,3049 +1,3065 @@
 (*  Title:      HOL/Finite_Set.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
     Author:     Andrei Popescu
 *)
 
 section \<open>Finite sets\<close>
 
 theory Finite_Set
   imports Product_Type Sum_Type Fields Relation
 begin
 
 subsection \<open>Predicate for finite sets\<close>
 
 context notes [[inductive_internals]]
 begin
 
 inductive finite :: "'a set \<Rightarrow> bool"
   where
     emptyI [simp, intro!]: "finite {}"
   | insertI [simp, intro!]: "finite A \<Longrightarrow> finite (insert a A)"
 
 end
 
 simproc_setup finite_Collect ("finite (Collect P)") = \<open>K Set_Comprehension_Pointfree.proc\<close>
 
 declare [[simproc del: finite_Collect]]
 
 lemma finite_induct [case_names empty insert, induct set: finite]:
   \<comment> \<open>Discharging \<open>x \<notin> F\<close> entails extra work.\<close>
   assumes "finite F"
   assumes "P {}"
     and insert: "\<And>x F. finite F \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
   shows "P F"
   using \<open>finite F\<close>
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume F: "finite F" and P: "P F"
   show "P (insert x F)"
   proof cases
     assume "x \<in> F"
     then have "insert x F = F" by (rule insert_absorb)
     with P show ?thesis by (simp only:)
   next
     assume "x \<notin> F"
     from F this P show ?thesis by (rule insert)
   qed
 qed
 
 lemma infinite_finite_induct [case_names infinite empty insert]:
   assumes infinite: "\<And>A. \<not> finite A \<Longrightarrow> P A"
     and empty: "P {}"
     and insert: "\<And>x F. finite F \<Longrightarrow> x \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert x F)"
   shows "P A"
 proof (cases "finite A")
   case False
   with infinite show ?thesis .
 next
   case True
   then show ?thesis by (induct A) (fact empty insert)+
 qed
 
 
 subsubsection \<open>Choice principles\<close>
 
 lemma ex_new_if_finite: \<comment> \<open>does not depend on def of finite at all\<close>
   assumes "\<not> finite (UNIV :: 'a set)" and "finite A"
   shows "\<exists>a::'a. a \<notin> A"
 proof -
   from assms have "A \<noteq> UNIV" by blast
   then show ?thesis by blast
 qed
 
 text \<open>A finite choice principle. Does not need the SOME choice operator.\<close>
 
 lemma finite_set_choice: "finite A \<Longrightarrow> \<forall>x\<in>A. \<exists>y. P x y \<Longrightarrow> \<exists>f. \<forall>x\<in>A. P x (f x)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert a A)
   then obtain f b where f: "\<forall>x\<in>A. P x (f x)" and ab: "P a b"
     by auto
   show ?case (is "\<exists>f. ?P f")
   proof
     show "?P (\<lambda>x. if x = a then b else f x)"
       using f ab by auto
   qed
 qed
 
 
 subsubsection \<open>Finite sets are the images of initial segments of natural numbers\<close>
 
 lemma finite_imp_nat_seg_image_inj_on:
   assumes "finite A"
   shows "\<exists>(n::nat) f. A = f ` {i. i < n} \<and> inj_on f {i. i < n}"
   using assms
 proof induct
   case empty
   show ?case
   proof
     show "\<exists>f. {} = f ` {i::nat. i < 0} \<and> inj_on f {i. i < 0}"
       by simp
   qed
 next
   case (insert a A)
   have notinA: "a \<notin> A" by fact
   from insert.hyps obtain n f where "A = f ` {i::nat. i < n}" "inj_on f {i. i < n}"
     by blast
   then have "insert a A = f(n:=a) ` {i. i < Suc n}" and "inj_on (f(n:=a)) {i. i < Suc n}"
     using notinA by (auto simp add: image_def Ball_def inj_on_def less_Suc_eq)
   then show ?case by blast
 qed
 
 lemma nat_seg_image_imp_finite: "A = f ` {i::nat. i < n} \<Longrightarrow> finite A"
 proof (induct n arbitrary: A)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   let ?B = "f ` {i. i < n}"
   have finB: "finite ?B" by (rule Suc.hyps[OF refl])
   show ?case
   proof (cases "\<exists>k<n. f n = f k")
     case True
     then have "A = ?B"
       using Suc.prems by (auto simp:less_Suc_eq)
     then show ?thesis
       using finB by simp
   next
     case False
     then have "A = insert (f n) ?B"
       using Suc.prems by (auto simp:less_Suc_eq)
     then show ?thesis using finB by simp
   qed
 qed
 
 lemma finite_conv_nat_seg_image: "finite A \<longleftrightarrow> (\<exists>n f. A = f ` {i::nat. i < n})"
   by (blast intro: nat_seg_image_imp_finite dest: finite_imp_nat_seg_image_inj_on)
 
 lemma finite_imp_inj_to_nat_seg:
   assumes "finite A"
   shows "\<exists>f n. f ` A = {i::nat. i < n} \<and> inj_on f A"
 proof -
   from finite_imp_nat_seg_image_inj_on [OF \<open>finite A\<close>]
   obtain f and n :: nat where bij: "bij_betw f {i. i<n} A"
     by (auto simp: bij_betw_def)
   let ?f = "the_inv_into {i. i<n} f"
   have "inj_on ?f A \<and> ?f ` A = {i. i<n}"
     by (fold bij_betw_def) (rule bij_betw_the_inv_into[OF bij])
   then show ?thesis by blast
 qed
 
 lemma finite_Collect_less_nat [iff]: "finite {n::nat. n < k}"
   by (fastforce simp: finite_conv_nat_seg_image)
 
 lemma finite_Collect_le_nat [iff]: "finite {n::nat. n \<le> k}"
   by (simp add: le_eq_less_or_eq Collect_disj_eq)
 
 
 subsection \<open>Finiteness and common set operations\<close>
 
 lemma rev_finite_subset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> finite A"
 proof (induct arbitrary: A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F A)
   have A: "A \<subseteq> insert x F" and r: "A - {x} \<subseteq> F \<Longrightarrow> finite (A - {x})"
     by fact+
   show "finite A"
   proof cases
     assume x: "x \<in> A"
     with A have "A - {x} \<subseteq> F" by (simp add: subset_insert_iff)
     with r have "finite (A - {x})" .
     then have "finite (insert x (A - {x}))" ..
     also have "insert x (A - {x}) = A"
       using x by (rule insert_Diff)
     finally show ?thesis .
   next
     show ?thesis when "A \<subseteq> F"
       using that by fact
     assume "x \<notin> A"
     with A show "A \<subseteq> F"
       by (simp add: subset_insert_iff)
   qed
 qed
 
 lemma finite_subset: "A \<subseteq> B \<Longrightarrow> finite B \<Longrightarrow> finite A"
   by (rule rev_finite_subset)
 
 simproc_setup finite ("finite A") = \<open>
 let
   val finite_subset = @{thm finite_subset}
   val Eq_TrueI = @{thm Eq_TrueI}
 
   fun is_subset A th = case Thm.prop_of th of
         (_ $ (Const (\<^const_name>\<open>less_eq\<close>, Type (\<^type_name>\<open>fun\<close>, [Type (\<^type_name>\<open>set\<close>, _), _])) $ A' $ B))
         => if A aconv A' then SOME(B,th) else NONE
       | _ => NONE;
 
   fun is_finite th = case Thm.prop_of th of
         (_ $ (Const (\<^const_name>\<open>finite\<close>, _) $ A)) => SOME(A,th)
       |  _ => NONE;
 
   fun comb (A,sub_th) (A',fin_th) ths = if A aconv A' then (sub_th,fin_th) :: ths else ths
 
   fun proc ctxt ct =
     (let
        val _ $ A = Thm.term_of ct
        val prems = Simplifier.prems_of ctxt
        val fins = map_filter is_finite prems
        val subsets = map_filter (is_subset A) prems
      in case fold_product comb subsets fins [] of
           (sub_th,fin_th) :: _ => SOME((fin_th RS (sub_th RS finite_subset)) RS Eq_TrueI)
         | _ => NONE
      end)
 in K proc end
 \<close>
 
 (* Needs to be used with care *)
 declare [[simproc del: finite]]
 
 lemma finite_UnI:
   assumes "finite F" and "finite G"
   shows "finite (F \<union> G)"
   using assms by induct simp_all
 
 lemma finite_Un [iff]: "finite (F \<union> G) \<longleftrightarrow> finite F \<and> finite G"
   by (blast intro: finite_UnI finite_subset [of _ "F \<union> G"])
 
 lemma finite_insert [simp]: "finite (insert a A) \<longleftrightarrow> finite A"
 proof -
   have "finite {a} \<and> finite A \<longleftrightarrow> finite A" by simp
   then have "finite ({a} \<union> A) \<longleftrightarrow> finite A" by (simp only: finite_Un)
   then show ?thesis by simp
 qed
 
 lemma finite_Int [simp, intro]: "finite F \<or> finite G \<Longrightarrow> finite (F \<inter> G)"
   by (blast intro: finite_subset)
 
 lemma finite_Collect_conjI [simp, intro]:
   "finite {x. P x} \<or> finite {x. Q x} \<Longrightarrow> finite {x. P x \<and> Q x}"
   by (simp add: Collect_conj_eq)
 
 lemma finite_Collect_disjI [simp]:
   "finite {x. P x \<or> Q x} \<longleftrightarrow> finite {x. P x} \<and> finite {x. Q x}"
   by (simp add: Collect_disj_eq)
 
 lemma finite_Diff [simp, intro]: "finite A \<Longrightarrow> finite (A - B)"
   by (rule finite_subset, rule Diff_subset)
 
 lemma finite_Diff2 [simp]:
   assumes "finite B"
   shows "finite (A - B) \<longleftrightarrow> finite A"
 proof -
   have "finite A \<longleftrightarrow> finite ((A - B) \<union> (A \<inter> B))"
     by (simp add: Un_Diff_Int)
   also have "\<dots> \<longleftrightarrow> finite (A - B)"
     using \<open>finite B\<close> by simp
   finally show ?thesis ..
 qed
 
 lemma finite_Diff_insert [iff]: "finite (A - insert a B) \<longleftrightarrow> finite (A - B)"
 proof -
   have "finite (A - B) \<longleftrightarrow> finite (A - B - {a})" by simp
   moreover have "A - insert a B = A - B - {a}" by auto
   ultimately show ?thesis by simp
 qed
 
 lemma finite_compl [simp]:
   "finite (A :: 'a set) \<Longrightarrow> finite (- A) \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp add: Compl_eq_Diff_UNIV)
 
 lemma finite_Collect_not [simp]:
   "finite {x :: 'a. P x} \<Longrightarrow> finite {x. \<not> P x} \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp add: Collect_neg_eq)
 
 lemma finite_Union [simp, intro]:
   "finite A \<Longrightarrow> (\<And>M. M \<in> A \<Longrightarrow> finite M) \<Longrightarrow> finite (\<Union>A)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_UN_I [intro]:
   "finite A \<Longrightarrow> (\<And>a. a \<in> A \<Longrightarrow> finite (B a)) \<Longrightarrow> finite (\<Union>a\<in>A. B a)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_UN [simp]: "finite A \<Longrightarrow> finite (\<Union>(B ` A)) \<longleftrightarrow> (\<forall>x\<in>A. finite (B x))"
   by (blast intro: finite_subset)
 
 lemma finite_Inter [intro]: "\<exists>A\<in>M. finite A \<Longrightarrow> finite (\<Inter>M)"
   by (blast intro: Inter_lower finite_subset)
 
 lemma finite_INT [intro]: "\<exists>x\<in>I. finite (A x) \<Longrightarrow> finite (\<Inter>x\<in>I. A x)"
   by (blast intro: INT_lower finite_subset)
 
 lemma finite_imageI [simp, intro]: "finite F \<Longrightarrow> finite (h ` F)"
   by (induct rule: finite_induct) simp_all
 
 lemma finite_image_set [simp]: "finite {x. P x} \<Longrightarrow> finite {f x |x. P x}"
   by (simp add: image_Collect [symmetric])
 
 lemma finite_image_set2:
   "finite {x. P x} \<Longrightarrow> finite {y. Q y} \<Longrightarrow> finite {f x y |x y. P x \<and> Q y}"
   by (rule finite_subset [where B = "\<Union>x \<in> {x. P x}. \<Union>y \<in> {y. Q y}. {f x y}"]) auto
 
 lemma finite_imageD:
   assumes "finite (f ` A)" and "inj_on f A"
   shows "finite A"
   using assms
 proof (induct "f ` A" arbitrary: A)
   case empty
   then show ?case by simp
 next
   case (insert x B)
   then have B_A: "insert x B = f ` A"
     by simp
   then obtain y where "x = f y" and "y \<in> A"
     by blast
   from B_A \<open>x \<notin> B\<close> have "B = f ` A - {x}"
     by blast
   with B_A \<open>x \<notin> B\<close> \<open>x = f y\<close> \<open>inj_on f A\<close> \<open>y \<in> A\<close> have "B = f ` (A - {y})"
     by (simp add: inj_on_image_set_diff)
   moreover from \<open>inj_on f A\<close> have "inj_on f (A - {y})"
     by (rule inj_on_diff)
   ultimately have "finite (A - {y})"
     by (rule insert.hyps)
   then show "finite A"
     by simp
 qed
 
 lemma finite_image_iff: "inj_on f A \<Longrightarrow> finite (f ` A) \<longleftrightarrow> finite A"
   using finite_imageD by blast
 
 lemma finite_surj: "finite A \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> finite B"
   by (erule finite_subset) (rule finite_imageI)
 
 lemma finite_range_imageI: "finite (range g) \<Longrightarrow> finite (range (\<lambda>x. f (g x)))"
   by (drule finite_imageI) (simp add: range_composition)
 
 lemma finite_subset_image:
   assumes "finite B"
   shows "B \<subseteq> f ` A \<Longrightarrow> \<exists>C\<subseteq>A. finite C \<and> B = f ` C"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     by (clarsimp simp del: image_insert simp add: image_insert [symmetric]) blast
 qed
 
 lemma all_subset_image: "(\<forall>B. B \<subseteq> f ` A \<longrightarrow> P B) \<longleftrightarrow> (\<forall>B. B \<subseteq> A \<longrightarrow> P(f ` B))"
   by (safe elim!: subset_imageE) (use image_mono in \<open>blast+\<close>) (* slow *)
 
 lemma all_finite_subset_image:
   "(\<forall>B. finite B \<and> B \<subseteq> f ` A \<longrightarrow> P B) \<longleftrightarrow> (\<forall>B. finite B \<and> B \<subseteq> A \<longrightarrow> P (f ` B))"
 proof safe
   fix B :: "'a set"
   assume B: "finite B" "B \<subseteq> f ` A" and P: "\<forall>B. finite B \<and> B \<subseteq> A \<longrightarrow> P (f ` B)"
   show "P B"
     using finite_subset_image [OF B] P by blast
 qed blast
 
 lemma ex_finite_subset_image:
   "(\<exists>B. finite B \<and> B \<subseteq> f ` A \<and> P B) \<longleftrightarrow> (\<exists>B. finite B \<and> B \<subseteq> A \<and> P (f ` B))"
 proof safe
   fix B :: "'a set"
   assume B: "finite B" "B \<subseteq> f ` A" and "P B"
   show "\<exists>B. finite B \<and> B \<subseteq> A \<and> P (f ` B)"
     using finite_subset_image [OF B] \<open>P B\<close> by blast
 qed blast
 
 lemma finite_vimage_IntI: "finite F \<Longrightarrow> inj_on h A \<Longrightarrow> finite (h -` F \<inter> A)"
 proof (induct rule: finite_induct)
   case (insert x F)
   then show ?case
     by (simp add: vimage_insert [of h x F] finite_subset [OF inj_on_vimage_singleton] Int_Un_distrib2)
 qed simp
 
 lemma finite_finite_vimage_IntI:
   assumes "finite F"
     and "\<And>y. y \<in> F \<Longrightarrow> finite ((h -` {y}) \<inter> A)"
   shows "finite (h -` F \<inter> A)"
 proof -
   have *: "h -` F \<inter> A = (\<Union> y\<in>F. (h -` {y}) \<inter> A)"
     by blast
   show ?thesis
     by (simp only: * assms finite_UN_I)
 qed
 
 lemma finite_vimageI: "finite F \<Longrightarrow> inj h \<Longrightarrow> finite (h -` F)"
   using finite_vimage_IntI[of F h UNIV] by auto
 
 lemma finite_vimageD': "finite (f -` A) \<Longrightarrow> A \<subseteq> range f \<Longrightarrow> finite A"
   by (auto simp add: subset_image_iff intro: finite_subset[rotated])
 
 lemma finite_vimageD: "finite (h -` F) \<Longrightarrow> surj h \<Longrightarrow> finite F"
   by (auto dest: finite_vimageD')
 
 lemma finite_vimage_iff: "bij h \<Longrightarrow> finite (h -` F) \<longleftrightarrow> finite F"
   unfolding bij_def by (auto elim: finite_vimageD finite_vimageI)
 
 lemma finite_inverse_image_gen:
   assumes "finite A" "inj_on f D"
   shows "finite {j\<in>D. f j \<in> A}"
   using finite_vimage_IntI [OF assms]
   by (simp add: Collect_conj_eq inf_commute vimage_def)
 
 lemma finite_inverse_image:
   assumes "finite A" "inj f"
   shows "finite {j. f j \<in> A}"
   using finite_inverse_image_gen [OF assms] by simp
 
 lemma finite_Collect_bex [simp]:
   assumes "finite A"
   shows "finite {x. \<exists>y\<in>A. Q x y} \<longleftrightarrow> (\<forall>y\<in>A. finite {x. Q x y})"
 proof -
   have "{x. \<exists>y\<in>A. Q x y} = (\<Union>y\<in>A. {x. Q x y})" by auto
   with assms show ?thesis by simp
 qed
 
 lemma finite_Collect_bounded_ex [simp]:
   assumes "finite {y. P y}"
   shows "finite {x. \<exists>y. P y \<and> Q x y} \<longleftrightarrow> (\<forall>y. P y \<longrightarrow> finite {x. Q x y})"
 proof -
   have "{x. \<exists>y. P y \<and> Q x y} = (\<Union>y\<in>{y. P y}. {x. Q x y})"
     by auto
   with assms show ?thesis
     by simp
 qed
 
 lemma finite_Plus: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A <+> B)"
   by (simp add: Plus_def)
 
 lemma finite_PlusD:
   fixes A :: "'a set" and B :: "'b set"
   assumes fin: "finite (A <+> B)"
   shows "finite A" "finite B"
 proof -
   have "Inl ` A \<subseteq> A <+> B"
     by auto
   then have "finite (Inl ` A :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite A"
     by (rule finite_imageD) (auto intro: inj_onI)
 next
   have "Inr ` B \<subseteq> A <+> B"
     by auto
   then have "finite (Inr ` B :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite B"
     by (rule finite_imageD) (auto intro: inj_onI)
 qed
 
 lemma finite_Plus_iff [simp]: "finite (A <+> B) \<longleftrightarrow> finite A \<and> finite B"
   by (auto intro: finite_PlusD finite_Plus)
 
 lemma finite_Plus_UNIV_iff [simp]:
   "finite (UNIV :: ('a + 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   by (subst UNIV_Plus_UNIV [symmetric]) (rule finite_Plus_iff)
 
 lemma finite_SigmaI [simp, intro]:
   "finite A \<Longrightarrow> (\<And>a. a\<in>A \<Longrightarrow> finite (B a)) \<Longrightarrow> finite (SIGMA a:A. B a)"
   unfolding Sigma_def by blast
 
 lemma finite_SigmaI2:
   assumes "finite {x\<in>A. B x \<noteq> {}}"
   and "\<And>a. a \<in> A \<Longrightarrow> finite (B a)"
   shows "finite (Sigma A B)"
 proof -
   from assms have "finite (Sigma {x\<in>A. B x \<noteq> {}} B)"
     by auto
   also have "Sigma {x:A. B x \<noteq> {}} B = Sigma A B"
     by auto
   finally show ?thesis .
 qed
 
 lemma finite_cartesian_product: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<times> B)"
   by (rule finite_SigmaI)
 
 lemma finite_Prod_UNIV:
   "finite (UNIV :: 'a set) \<Longrightarrow> finite (UNIV :: 'b set) \<Longrightarrow> finite (UNIV :: ('a \<times> 'b) set)"
   by (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product)
 
 lemma finite_cartesian_productD1:
   assumes "finite (A \<times> B)" and "B \<noteq> {}"
   shows "finite A"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "fst ` (A \<times> B) = fst ` f ` {i::nat. i < n}"
     by simp
   with \<open>B \<noteq> {}\<close> have "A = (fst \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. A = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_productD2:
   assumes "finite (A \<times> B)" and "A \<noteq> {}"
   shows "finite B"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "snd ` (A \<times> B) = snd ` f ` {i::nat. i < n}"
     by simp
   with \<open>A \<noteq> {}\<close> have "B = (snd \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. B = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_product_iff:
   "finite (A \<times> B) \<longleftrightarrow> (A = {} \<or> B = {} \<or> (finite A \<and> finite B))"
   by (auto dest: finite_cartesian_productD1 finite_cartesian_productD2 finite_cartesian_product)
 
 lemma finite_prod:
   "finite (UNIV :: ('a \<times> 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   using finite_cartesian_product_iff[of UNIV UNIV] by simp
 
 lemma finite_Pow_iff [iff]: "finite (Pow A) \<longleftrightarrow> finite A"
 proof
   assume "finite (Pow A)"
   then have "finite ((\<lambda>x. {x}) ` A)"
     by (blast intro: finite_subset)  (* somewhat slow *)
   then show "finite A"
     by (rule finite_imageD [unfolded inj_on_def]) simp
 next
   assume "finite A"
   then show "finite (Pow A)"
     by induct (simp_all add: Pow_insert)
 qed
 
 corollary finite_Collect_subsets [simp, intro]: "finite A \<Longrightarrow> finite {B. B \<subseteq> A}"
   by (simp add: Pow_def [symmetric])
 
 lemma finite_set: "finite (UNIV :: 'a set set) \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp only: finite_Pow_iff Pow_UNIV[symmetric])
 
 lemma finite_UnionD: "finite (\<Union>A) \<Longrightarrow> finite A"
   by (blast intro: finite_subset [OF subset_Pow_Union])
 
 lemma finite_bind:
   assumes "finite S"
   assumes "\<forall>x \<in> S. finite (f x)"
   shows "finite (Set.bind S f)"
 using assms by (simp add: bind_UNION)
 
 lemma finite_filter [simp]: "finite S \<Longrightarrow> finite (Set.filter P S)"
 unfolding Set.filter_def by simp
 
 lemma finite_set_of_finite_funs:
   assumes "finite A" "finite B"
   shows "finite {f. \<forall>x. (x \<in> A \<longrightarrow> f x \<in> B) \<and> (x \<notin> A \<longrightarrow> f x = d)}" (is "finite ?S")
 proof -
   let ?F = "\<lambda>f. {(a,b). a \<in> A \<and> b = f a}"
   have "?F ` ?S \<subseteq> Pow(A \<times> B)"
     by auto
   from finite_subset[OF this] assms have 1: "finite (?F ` ?S)"
     by simp
   have 2: "inj_on ?F ?S"
     by (fastforce simp add: inj_on_def set_eq_iff fun_eq_iff)  (* somewhat slow *)
   show ?thesis
     by (rule finite_imageD [OF 1 2])
 qed
 
 lemma not_finite_existsD:
   assumes "\<not> finite {a. P a}"
   shows "\<exists>a. P a"
 proof (rule classical)
   assume "\<not> ?thesis"
   with assms show ?thesis by auto
 qed
 
 lemma finite_converse [iff]: "finite (r\<inverse>) \<longleftrightarrow> finite r"
   unfolding converse_def conversep_iff
   using [[simproc add: finite_Collect]]
   by (auto elim: finite_imageD simp: inj_on_def)
 
 lemma finite_Domain: "finite r \<Longrightarrow> finite (Domain r)"
   by (induct set: finite) auto
 
 lemma finite_Range: "finite r \<Longrightarrow> finite (Range r)"
   by (induct set: finite) auto
 
 lemma finite_Field: "finite r \<Longrightarrow> finite (Field r)"
   by (simp add: Field_def finite_Domain finite_Range)
 
 lemma finite_Image[simp]: "finite R \<Longrightarrow> finite (R `` A)"
   by(rule finite_subset[OF _ finite_Range]) auto
 
 
 subsection \<open>Further induction rules on finite sets\<close>
 
 lemma finite_ne_induct [case_names singleton insert, consumes 2]:
   assumes "finite F" and "F \<noteq> {}"
   assumes "\<And>x. P {x}"
     and "\<And>x F. finite F \<Longrightarrow> F \<noteq> {} \<Longrightarrow> x \<notin> F \<Longrightarrow> P F  \<Longrightarrow> P (insert x F)"
   shows "P F"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case by cases auto
 qed
 
 lemma finite_subset_induct [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. finite F \<Longrightarrow> a \<in> A \<Longrightarrow> a \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert a F)"
   shows "P F"
   using \<open>finite F\<close> \<open>F \<subseteq> A\<close>
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
   qed
 qed
 
 lemma finite_empty_induct:
   assumes "finite A"
     and "P A"
     and remove: "\<And>a A. finite A \<Longrightarrow> a \<in> A \<Longrightarrow> P A \<Longrightarrow> P (A - {a})"
   shows "P {}"
 proof -
   have "P (A - B)" if "B \<subseteq> A" for B :: "'a set"
   proof -
     from \<open>finite A\<close> that have "finite B"
       by (rule rev_finite_subset)
     from this \<open>B \<subseteq> A\<close> show "P (A - B)"
     proof induct
       case empty
       from \<open>P A\<close> show ?case by simp
     next
       case (insert b B)
       have "P (A - B - {b})"
       proof (rule remove)
         from \<open>finite A\<close> show "finite (A - B)"
           by induct auto
         from insert show "b \<in> A - B"
           by simp
         from insert show "P (A - B)"
           by simp
       qed
       also have "A - B - {b} = A - insert b B"
         by (rule Diff_insert [symmetric])
       finally show ?case .
     qed
   qed
   then have "P (A - A)" by blast
   then show ?thesis by simp
 qed
 
 lemma finite_update_induct [consumes 1, case_names const update]:
   assumes finite: "finite {a. f a \<noteq> c}"
     and const: "P (\<lambda>a. c)"
     and update: "\<And>a b f. finite {a. f a \<noteq> c} \<Longrightarrow> f a = c \<Longrightarrow> b \<noteq> c \<Longrightarrow> P f \<Longrightarrow> P (f(a := b))"
   shows "P f"
   using finite
 proof (induct "{a. f a \<noteq> c}" arbitrary: f)
   case empty
   with const show ?case by simp
 next
   case (insert a A)
   then have "A = {a'. (f(a := c)) a' \<noteq> c}" and "f a \<noteq> c"
     by auto
   with \<open>finite A\<close> have "finite {a'. (f(a := c)) a' \<noteq> c}"
     by simp
   have "(f(a := c)) a = c"
     by simp
   from insert \<open>A = {a'. (f(a := c)) a' \<noteq> c}\<close> have "P (f(a := c))"
     by simp
   with \<open>finite {a'. (f(a := c)) a' \<noteq> c}\<close> \<open>(f(a := c)) a = c\<close> \<open>f a \<noteq> c\<close>
   have "P ((f(a := c))(a := f a))"
     by (rule update)
   then show ?case by simp
 qed
 
 lemma finite_subset_induct' [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. \<lbrakk>finite F; a \<in> A; F \<subseteq> A; a \<notin> F; P F \<rbrakk> \<Longrightarrow> P (insert a F)"
   shows "P F"
   using assms(1,2)
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and
     P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
     show "F \<subseteq> A" by fact
   qed
 qed
 
 
 subsection \<open>Class \<open>finite\<close>\<close>
 
 class finite =
   assumes finite_UNIV: "finite (UNIV :: 'a set)"
 begin
 
 lemma finite [simp]: "finite (A :: 'a set)"
   by (rule subset_UNIV finite_UNIV finite_subset)+
 
 lemma finite_code [code]: "finite (A :: 'a set) \<longleftrightarrow> True"
   by simp
 
 end
 
 instance prod :: (finite, finite) finite
   by standard (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product finite)
 
 lemma inj_graph: "inj (\<lambda>f. {(x, y). y = f x})"
   by (rule inj_onI) (auto simp add: set_eq_iff fun_eq_iff)
 
 instance "fun" :: (finite, finite) finite
 proof
   show "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   proof (rule finite_imageD)
     let ?graph = "\<lambda>f::'a \<Rightarrow> 'b. {(x, y). y = f x}"
     have "range ?graph \<subseteq> Pow UNIV"
       by simp
     moreover have "finite (Pow (UNIV :: ('a * 'b) set))"
       by (simp only: finite_Pow_iff finite)
     ultimately show "finite (range ?graph)"
       by (rule finite_subset)
     show "inj ?graph"
       by (rule inj_graph)
   qed
 qed
 
 instance bool :: finite
   by standard (simp add: UNIV_bool)
 
 instance set :: (finite) finite
   by standard (simp only: Pow_UNIV [symmetric] finite_Pow_iff finite)
 
 instance unit :: finite
   by standard (simp add: UNIV_unit)
 
 instance sum :: (finite, finite) finite
   by standard (simp only: UNIV_Plus_UNIV [symmetric] finite_Plus finite)
 
 
 subsection \<open>A basic fold functional for finite sets\<close>
 
 text \<open>
   The intended behaviour is \<open>fold f z {x\<^sub>1, \<dots>, x\<^sub>n} = f x\<^sub>1 (\<dots> (f x\<^sub>n z)\<dots>)\<close>
   if \<open>f\<close> is ``left-commutative''.
   The commutativity requirement is relativised to the carrier set \<open>S\<close>:
 \<close>
 
 locale comp_fun_commute_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma fun_left_comm: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y (f x z) = f x (f y z)"
   using comp_fun_commute_on by (simp add: fun_eq_iff)
 
 lemma commute_left_comp: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> (f x \<circ> g) = f x \<circ> (f y \<circ> g)"
   by (simp add: o_assoc comp_fun_commute_on)
 
 end
 
 inductive fold_graph :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> bool"
   for f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: 'b
   where
     emptyI [intro]: "fold_graph f z {} z"
   | insertI [intro]: "x \<notin> A \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold_graph f z (insert x A) (f x y)"
 
 inductive_cases empty_fold_graphE [elim!]: "fold_graph f z {} x"
 
 lemma fold_graph_closed_lemma:
   "fold_graph f z A x \<and> x \<in> B"
   if "fold_graph g z A x"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
     "z \<in> B"
   using that(1-3)
 proof (induction rule: fold_graph.induct)
   case (insertI x A y)
   have "fold_graph f z A y" "y \<in> B"
     unfolding atomize_conj
     by (rule insertI.IH) (auto intro: insertI.prems)
   then have "g x y \<in> B" and f_eq: "f x y = g x y"
     by (auto simp: insertI.prems)
   moreover have "fold_graph f z (insert x A) (f x y)"
     by (rule fold_graph.insertI; fact)
   ultimately
   show ?case
     by (simp add: f_eq)
 qed (auto intro!: that)
 
 lemma fold_graph_closed_eq:
   "fold_graph f z A = fold_graph g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   using fold_graph_closed_lemma[of f z A _ B g] fold_graph_closed_lemma[of g z A _ B f] that
   by auto
 
 definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b"
   where "fold f z A = (if finite A then (THE y. fold_graph f z A y) else z)"
 
 lemma fold_closed_eq: "fold f z A = fold g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   unfolding Finite_Set.fold_def
   by (subst fold_graph_closed_eq[where B=B and g=g]) (auto simp: that)
 
 text \<open>
   A tempting alternative for the definition is
   \<^term>\<open>if finite A then THE y. fold_graph f z A y else e\<close>.
   It allows the removal of finiteness assumptions from the theorems
   \<open>fold_comm\<close>, \<open>fold_reindex\<close> and \<open>fold_distrib\<close>.
   The proofs become ugly. It is not worth the effort. (???)
 \<close>
 
 lemma finite_imp_fold_graph: "finite A \<Longrightarrow> \<exists>x. fold_graph f z A x"
   by (induct rule: finite_induct) auto
 
 
 subsubsection \<open>From \<^const>\<open>fold_graph\<close> to \<^term>\<open>fold\<close>\<close>
 
 context comp_fun_commute_on
 begin
 
 lemma fold_graph_finite:
   assumes "fold_graph f z A y"
   shows "finite A"
   using assms by induct simp_all
 
 lemma fold_graph_insertE_aux:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A y" "a \<in> A"
   shows "\<exists>y'. y = f a y' \<and> fold_graph f z (A - {a}) y'"
   using assms(2-,1)
 proof (induct set: fold_graph)
   case emptyI
   then show ?case by simp
 next
   case (insertI x A y)
   show ?case
   proof (cases "x = a")
     case True
     with insertI show ?thesis by auto
   next
     case False
     then obtain y' where y: "y = f a y'" and y': "fold_graph f z (A - {a}) y'"
       using insertI by auto
     from insertI have "x \<in> S" "a \<in> S" by auto
     then have "f x y = f a (f x y')"
       unfolding y by (intro fun_left_comm; simp)
     moreover have "fold_graph f z (insert x A - {a}) (f x y')"
       using y' and \<open>x \<noteq> a\<close> and \<open>x \<notin> A\<close>
       by (simp add: insert_Diff_if fold_graph.insertI)
     ultimately show ?thesis
       by fast
   qed
 qed
 
 lemma fold_graph_insertE:
   assumes "insert x A \<subseteq> S"
   assumes "fold_graph f z (insert x A) v" and "x \<notin> A"
   obtains y where "v = f x y" and "fold_graph f z A y"
   using assms by (auto dest: fold_graph_insertE_aux[OF \<open>insert x A \<subseteq> S\<close> _ insertI1])
 
 lemma fold_graph_determ:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A x" "fold_graph f z A y"
   shows "y = x"
   using assms(2-,1)
 proof (induct arbitrary: y set: fold_graph)
   case emptyI
   then show ?case by fast
 next
   case (insertI x A y v)
   from \<open>insert x A \<subseteq> S\<close> and \<open>fold_graph f z (insert x A) v\<close> and \<open>x \<notin> A\<close>
   obtain y' where "v = f x y'" and "fold_graph f z A y'"
     by (rule fold_graph_insertE)
   from \<open>fold_graph f z A y'\<close> insertI have "y' = y"
     by simp
   with \<open>v = f x y'\<close> show "v = f x y"
     by simp
 qed
 
 lemma fold_equality: "A \<subseteq> S \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold f z A = y"
   by (cases "finite A") (auto simp add: fold_def intro: fold_graph_determ dest: fold_graph_finite)
 
 lemma fold_graph_fold:
   assumes "A \<subseteq> S"
   assumes "finite A"
   shows "fold_graph f z A (fold f z A)"
 proof -
   from \<open>finite A\<close> have "\<exists>x. fold_graph f z A x"
     by (rule finite_imp_fold_graph)
   moreover note fold_graph_determ[OF \<open>A \<subseteq> S\<close>]
   ultimately have "\<exists>!x. fold_graph f z A x"
     by (rule ex_ex1I)
   then have "fold_graph f z A (The (fold_graph f z A))"
     by (rule theI')
   with assms show ?thesis
     by (simp add: fold_def)
 qed
 
 text \<open>The base case for \<open>fold\<close>:\<close>
 
 lemma (in -) fold_infinite [simp]: "\<not> finite A \<Longrightarrow> fold f z A = z"
   by (auto simp: fold_def)
 
 lemma (in -) fold_empty [simp]: "fold f z {} = z"
   by (auto simp: fold_def)
 
 text \<open>The various recursion equations for \<^const>\<open>fold\<close>:\<close>
 
 lemma fold_insert [simp]:
   assumes "insert x A \<subseteq> S"
   assumes "finite A" and "x \<notin> A"
   shows "fold f z (insert x A) = f x (fold f z A)"
 proof (rule fold_equality[OF \<open>insert x A \<subseteq> S\<close>])
   fix z
   from \<open>insert x A \<subseteq> S\<close> \<open>finite A\<close> have "fold_graph f z A (fold f z A)"
     by (blast intro: fold_graph_fold)
   with \<open>x \<notin> A\<close> have "fold_graph f z (insert x A) (f x (fold f z A))"
     by (rule fold_graph.insertI)
   then show "fold_graph f z (insert x A) (f x (fold f z A))"
     by simp
 qed
 
 declare (in -) empty_fold_graphE [rule del] fold_graph.intros [rule del]
   \<comment> \<open>No more proofs involve these.\<close>
 
 lemma fold_fun_left_comm:
   assumes "insert x A \<subseteq> S" "finite A" 
   shows "f x (fold f z A) = fold f (f x z) A"
   using assms(2,1)
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert y F)
   then have "fold f (f x z) (insert y F) = f y (fold f (f x z) F)"
     by simp
   also have "\<dots> = f x (f y (fold f z F))"
     using insert by (simp add: fun_left_comm[where ?y=x])
   also have "\<dots> = f x (fold f z (insert y F))"
   proof -
     from insert have "insert y F \<subseteq> S" by simp
     from fold_insert[OF this] insert show ?thesis by simp
   qed
   finally show ?case ..
 qed
 
 lemma fold_insert2:
   "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> fold f z (insert x A)  = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 lemma fold_rec:
   assumes "A \<subseteq> S"
   assumes "finite A" and "x \<in> A"
   shows "fold f z A = f x (fold f z (A - {x}))"
 proof -
   have A: "A = insert x (A - {x})"
     using \<open>x \<in> A\<close> by blast
   then have "fold f z A = fold f z (insert x (A - {x}))"
     by simp
   also have "\<dots> = f x (fold f z (A - {x}))"
     by (rule fold_insert) (use assms in \<open>auto\<close>)
   finally show ?thesis .
 qed
 
 lemma fold_insert_remove:
   assumes "insert x A \<subseteq> S"
   assumes "finite A"
   shows "fold f z (insert x A) = f x (fold f z (A - {x}))"
 proof -
   from \<open>finite A\<close> have "finite (insert x A)"
     by auto
   moreover have "x \<in> insert x A"
     by auto
   ultimately have "fold f z (insert x A) = f x (fold f z (insert x A - {x}))"
     using \<open>insert x A \<subseteq> S\<close> by (blast intro: fold_rec)
   then show ?thesis
     by simp
 qed
 
 lemma fold_set_union_disj:
   assumes "A \<subseteq> S" "B \<subseteq> S"
   assumes "finite A" "finite B" "A \<inter> B = {}"
   shows "Finite_Set.fold f z (A \<union> B) = Finite_Set.fold f (Finite_Set.fold f z A) B"
   using \<open>finite B\<close> assms(1,2,3,5)
 proof induct
   case (insert x F)
   have "fold f z (A \<union> insert x F) = f x (fold f (fold f z A) F)"
     using insert by auto
   also have "\<dots> = fold f (fold f z A) (insert x F)"
     using insert by (blast intro: fold_insert[symmetric])
   finally show ?case .
 qed simp
 
 
 end
 
 text \<open>Other properties of \<^const>\<open>fold\<close>:\<close>
 
+lemma finite_set_fold_single [simp]: "Finite_Set.fold f z {x} = f x z"
+proof -
+  have "fold_graph f z {x} (f x z)"
+    by (auto intro: fold_graph.intros)
+  moreover
+  {
+    fix X y
+    have "fold_graph f z X y \<Longrightarrow> (X = {} \<longrightarrow> y = z) \<and> (X = {x} \<longrightarrow> y = f x z)"
+      by (induct rule: fold_graph.induct) auto
+  }
+  ultimately have "(THE y. fold_graph f z {x} y) = f x z"
+    by blast
+  thus ?thesis
+    by (simp add: Finite_Set.fold_def)
+qed
+
 lemma fold_graph_image:
   assumes "inj_on g A"
   shows "fold_graph f z (g ` A) = fold_graph (f \<circ> g) z A"
 proof
   fix w
   show "fold_graph f z (g ` A) w = fold_graph (f o g) z A w"
   proof
     assume "fold_graph f z (g ` A) w"
     then show "fold_graph (f \<circ> g) z A w"
       using assms
     proof (induct "g ` A" w arbitrary: A)
       case emptyI
       then show ?case by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r B)
       from \<open>inj_on g B\<close> \<open>x \<notin> A\<close> \<open>insert x A = image g B\<close> obtain x' A'
         where "x' \<notin> A'" and [simp]: "B = insert x' A'" "x = g x'" "A = g ` A'"
         by (rule inj_img_insertE)
       from insertI.prems have "fold_graph (f \<circ> g) z A' r"
         by (auto intro: insertI.hyps)
       with \<open>x' \<notin> A'\<close> have "fold_graph (f \<circ> g) z (insert x' A') ((f \<circ> g) x' r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   next
     assume "fold_graph (f \<circ> g) z A w"
     then show "fold_graph f z (g ` A) w"
       using assms
     proof induct
       case emptyI
       then show ?case
         by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r)
       from \<open>x \<notin> A\<close> insertI.prems have "g x \<notin> g ` A"
         by auto
       moreover from insertI have "fold_graph f z (g ` A) r"
         by simp
       ultimately have "fold_graph f z (insert (g x) (g ` A)) (f (g x) r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   qed
 qed
 
 lemma fold_image:
   assumes "inj_on g A"
   shows "fold f z (g ` A) = fold (f \<circ> g) z A"
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by (auto dest: finite_imageD simp add: fold_def)
 next
   case True
   then show ?thesis
     by (auto simp add: fold_def fold_graph_image[OF assms])
 qed
 
 lemma fold_cong:
   assumes "comp_fun_commute_on S f" "comp_fun_commute_on S g"
     and "A \<subseteq> S" "finite A"
     and cong: "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
     and "s = t" and "A = B"
   shows "fold f s A = fold g t B"
 proof -
   have "fold f s A = fold g s A"
     using \<open>finite A\<close> \<open>A \<subseteq> S\<close> cong
   proof (induct A)
     case empty
     then show ?case by simp
   next
     case insert
     interpret f: comp_fun_commute_on S f by (fact \<open>comp_fun_commute_on S f\<close>)
     interpret g: comp_fun_commute_on S g by (fact \<open>comp_fun_commute_on S g\<close>)
     from insert show ?case by simp
   qed
   with assms show ?thesis by simp
 qed
 
 
 text \<open>A simplified version for idempotent functions:\<close>
 
 locale comp_fun_idem_on = comp_fun_commute_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 lemma fun_left_idem: "x \<in> S \<Longrightarrow> f x (f x z) = f x z"
   using comp_fun_idem_on by (simp add: fun_eq_iff)
 
 lemma fold_insert_idem:
   assumes "insert x A \<subseteq> S"
   assumes fin: "finite A"
   shows "fold f z (insert x A)  = f x (fold f z A)"
 proof cases
   assume "x \<in> A"
   then obtain B where "A = insert x B" and "x \<notin> B"
     by (rule set_insert)
   then show ?thesis
     using assms by (simp add: comp_fun_idem_on fun_left_idem)
 next
   assume "x \<notin> A"
   then show ?thesis
     using assms by auto
 qed
 
 declare fold_insert [simp del] fold_insert_idem [simp]
 
 lemma fold_insert_idem2: "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> fold f z (insert x A) = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 end
 
 
 subsubsection \<open>Liftings to \<open>comp_fun_commute_on\<close> etc.\<close>
                    
 lemma (in comp_fun_commute_on) comp_comp_fun_commute_on:
   "range g \<subseteq> S \<Longrightarrow> comp_fun_commute_on R (f \<circ> g)"
   by standard (force intro: comp_fun_commute_on)
 
 lemma (in comp_fun_idem_on) comp_comp_fun_idem_on:
   assumes "range g \<subseteq> S"
   shows "comp_fun_idem_on R (f \<circ> g)"
 proof
   interpret f_g: comp_fun_commute_on R "f o g"
     by (fact comp_comp_fun_commute_on[OF \<open>range g \<subseteq> S\<close>])
   show "x \<in> R \<Longrightarrow> y \<in> R \<Longrightarrow> (f \<circ> g) y \<circ> (f \<circ> g) x = (f \<circ> g) x \<circ> (f \<circ> g) y" for x y
     by (fact f_g.comp_fun_commute_on)
 qed (use \<open>range g \<subseteq> S\<close> in \<open>force intro: comp_fun_idem_on\<close>)
 
 lemma (in comp_fun_commute_on) comp_fun_commute_on_funpow:
   "comp_fun_commute_on S (\<lambda>x. f x ^^ g x)"
 proof
   fix x y assume "x \<in> S" "y \<in> S"
   show "f y ^^ g y \<circ> f x ^^ g x = f x ^^ g x \<circ> f y ^^ g y"
   proof (cases "x = y")
     case True
     then show ?thesis by simp
   next
     case False
     show ?thesis
     proof (induct "g x" arbitrary: g)
       case 0
       then show ?case by simp
     next
       case (Suc n g)
       have hyp1: "f y ^^ g y \<circ> f x = f x \<circ> f y ^^ g y"
       proof (induct "g y" arbitrary: g)
         case 0
         then show ?case by simp
       next
         case (Suc n g)
         define h where "h z = g z - 1" for z
         with Suc have "n = h y"
           by simp
         with Suc have hyp: "f y ^^ h y \<circ> f x = f x \<circ> f y ^^ h y"
           by auto
         from Suc h_def have "g y = Suc (h y)"
           by simp
         with \<open>x \<in> S\<close> \<open>y \<in> S\<close> show ?case
           by (simp add: comp_assoc hyp) (simp add: o_assoc comp_fun_commute_on)
       qed
       define h where "h z = (if z = x then g x - 1 else g z)" for z
       with Suc have "n = h x"
         by simp
       with Suc have "f y ^^ h y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ h y"
         by auto
       with False h_def have hyp2: "f y ^^ g y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ g y"
         by simp
       from Suc h_def have "g x = Suc (h x)"
         by simp
       then show ?case
         by (simp del: funpow.simps add: funpow_Suc_right o_assoc hyp2) (simp add: comp_assoc hyp1)
     qed
   qed
 qed
 
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as carrier set\<close>
 
 locale comp_fun_commute =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) comp_fun_commute_def': "comp_fun_commute f = comp_fun_commute_on UNIV f"
   unfolding comp_fun_commute_def comp_fun_commute_on_def by blast
 
 text \<open>
   We abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_commute_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_commute_on UNIV f"
     by standard  (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_commute) comp_comp_fun_commute: "comp_fun_commute (f o g)"
   unfolding comp_fun_commute_def' by (fact comp_comp_fun_commute_on)
 
 lemma (in comp_fun_commute) comp_fun_commute_funpow: "comp_fun_commute (\<lambda>x. f x ^^ g x)"
   unfolding comp_fun_commute_def' by (fact comp_fun_commute_on_funpow)
 
 locale comp_fun_idem = comp_fun_commute +
   assumes comp_fun_idem: "f x o f x = f x"
 begin
 
 lemma (in -) comp_fun_idem_def': "comp_fun_idem f = comp_fun_idem_on UNIV f"
   unfolding comp_fun_idem_on_def comp_fun_idem_def comp_fun_commute_def'
   unfolding comp_fun_idem_axioms_def comp_fun_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_idem_on UNIV f"
     by standard (simp_all add: comp_fun_idem comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_idem) comp_comp_fun_idem: "comp_fun_idem (f o g)"
   unfolding comp_fun_idem_def' by (fact comp_comp_fun_idem_on)
 
 
 subsubsection \<open>Expressing set operations via \<^const>\<open>fold\<close>\<close>
 
 lemma comp_fun_commute_const: "comp_fun_commute (\<lambda>_. f)"
   by standard (rule refl)
 
 lemma comp_fun_idem_insert: "comp_fun_idem insert"
   by standard auto
 
 lemma comp_fun_idem_remove: "comp_fun_idem Set.remove"
   by standard auto
 
 lemma (in semilattice_inf) comp_fun_idem_inf: "comp_fun_idem inf"
   by standard (auto simp add: inf_left_commute)
 
 lemma (in semilattice_sup) comp_fun_idem_sup: "comp_fun_idem sup"
   by standard (auto simp add: sup_left_commute)
 
 lemma union_fold_insert:
   assumes "finite A"
   shows "A \<union> B = fold insert B A"
 proof -
   interpret comp_fun_idem insert
     by (fact comp_fun_idem_insert)
   from \<open>finite A\<close> show ?thesis
     by (induct A arbitrary: B) simp_all
 qed
 
 lemma minus_fold_remove:
   assumes "finite A"
   shows "B - A = fold Set.remove B A"
 proof -
   interpret comp_fun_idem Set.remove
     by (fact comp_fun_idem_remove)
   from \<open>finite A\<close> have "fold Set.remove B A = B - A"
     by (induct A arbitrary: B) auto  (* slow *)
   then show ?thesis ..
 qed
 
 lemma comp_fun_commute_filter_fold:
   "comp_fun_commute (\<lambda>x A'. if P x then Set.insert x A' else A')"
 proof -
   interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert)
   show ?thesis by standard (auto simp: fun_eq_iff)
 qed
 
 lemma Set_filter_fold:
   assumes "finite A"
   shows "Set.filter P A = fold (\<lambda>x A'. if P x then Set.insert x A' else A') {} A"
   using assms
 proof -
   interpret commute_insert: comp_fun_commute "(\<lambda>x A'. if P x then Set.insert x A' else A')"
     by (fact comp_fun_commute_filter_fold)
   from \<open>finite A\<close> show ?thesis
     by induct (auto simp add: Set.filter_def)
 qed
 
 lemma inter_Set_filter:
   assumes "finite B"
   shows "A \<inter> B = Set.filter (\<lambda>x. x \<in> A) B"
   using assms
   by induct (auto simp: Set.filter_def)
 
 lemma image_fold_insert:
   assumes "finite A"
   shows "image f A = fold (\<lambda>k A. Set.insert (f k) A) {} A"
 proof -
   interpret comp_fun_commute "\<lambda>k A. Set.insert (f k) A"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Ball_fold:
   assumes "finite A"
   shows "Ball A P = fold (\<lambda>k s. s \<and> P k) True A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<and> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Bex_fold:
   assumes "finite A"
   shows "Bex A P = fold (\<lambda>k s. s \<or> P k) False A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<or> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma comp_fun_commute_Pow_fold: "comp_fun_commute (\<lambda>x A. A \<union> Set.insert x ` A)"
   by (clarsimp simp: fun_eq_iff comp_fun_commute_def) blast
 
 lemma Pow_fold:
   assumes "finite A"
   shows "Pow A = fold (\<lambda>x A. A \<union> Set.insert x ` A) {{}} A"
 proof -
   interpret comp_fun_commute "\<lambda>x A. A \<union> Set.insert x ` A"
     by (rule comp_fun_commute_Pow_fold)
   show ?thesis
     using assms by (induct A) (auto simp: Pow_insert)
 qed
 
 lemma fold_union_pair:
   assumes "finite B"
   shows "(\<Union>y\<in>B. {(x, y)}) \<union> A = fold (\<lambda>y. Set.insert (x, y)) A B"
 proof -
   interpret comp_fun_commute "\<lambda>y. Set.insert (x, y)"
     by standard auto
   show ?thesis
     using assms by (induct arbitrary: A) simp_all
 qed
 
 lemma comp_fun_commute_product_fold:
   "finite B \<Longrightarrow> comp_fun_commute (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
   by standard (auto simp: fold_union_pair [symmetric])
 
 lemma product_fold:
   assumes "finite A" "finite B"
   shows "A \<times> B = fold (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B) {} A"
 proof -
   interpret commute_product: comp_fun_commute "(\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
     by (fact comp_fun_commute_product_fold[OF \<open>finite B\<close>])
   from assms show ?thesis unfolding Sigma_def
     by (induct A) (simp_all add: fold_union_pair)
 qed
 
 context complete_lattice
 begin
 
 lemma inf_Inf_fold_inf:
   assumes "finite A"
   shows "inf (Inf A) B = fold inf B A"
 proof -
   interpret comp_fun_idem inf
     by (fact comp_fun_idem_inf)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: inf_commute fun_eq_iff)
 qed
 
 lemma sup_Sup_fold_sup:
   assumes "finite A"
   shows "sup (Sup A) B = fold sup B A"
 proof -
   interpret comp_fun_idem sup
     by (fact comp_fun_idem_sup)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: sup_commute fun_eq_iff)
 qed
 
 lemma Inf_fold_inf: "finite A \<Longrightarrow> Inf A = fold inf top A"
   using inf_Inf_fold_inf [of A top] by (simp add: inf_absorb2)
 
 lemma Sup_fold_sup: "finite A \<Longrightarrow> Sup A = fold sup bot A"
   using sup_Sup_fold_sup [of A bot] by (simp add: sup_absorb2)
 
 lemma inf_INF_fold_inf:
   assumes "finite A"
   shows "inf B (\<Sqinter>(f ` A)) = fold (inf \<circ> f) B A" (is "?inf = ?fold")
 proof -
   interpret comp_fun_idem inf by (fact comp_fun_idem_inf)
   interpret comp_fun_idem "inf \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?inf"
     by (induct A arbitrary: B) (simp_all add: inf_left_commute)
   then show ?thesis ..
 qed
 
 lemma sup_SUP_fold_sup:
   assumes "finite A"
   shows "sup B (\<Squnion>(f ` A)) = fold (sup \<circ> f) B A" (is "?sup = ?fold")
 proof -
   interpret comp_fun_idem sup by (fact comp_fun_idem_sup)
   interpret comp_fun_idem "sup \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?sup"
     by (induct A arbitrary: B) (simp_all add: sup_left_commute)
   then show ?thesis ..
 qed
 
 lemma INF_fold_inf: "finite A \<Longrightarrow> \<Sqinter>(f ` A) = fold (inf \<circ> f) top A"
   using inf_INF_fold_inf [of A top] by simp
 
 lemma SUP_fold_sup: "finite A \<Longrightarrow> \<Squnion>(f ` A) = fold (sup \<circ> f) bot A"
   using sup_SUP_fold_sup [of A bot] by simp
 
 lemma finite_Inf_in:
   assumes "finite A" "A\<noteq>{}" and inf: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> inf x y \<in> A"
   shows "Inf A \<in> A"
 proof -
   have "Inf B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use inf in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 lemma finite_Sup_in:
   assumes "finite A" "A\<noteq>{}" and sup: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> sup x y \<in> A"
   shows "Sup A \<in> A"
 proof -
   have "Sup B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use sup in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 end
 
 subsubsection \<open>Expressing relation operations via \<^const>\<open>fold\<close>\<close>
 
 lemma Id_on_fold:
   assumes "finite A"
   shows "Id_on A = Finite_Set.fold (\<lambda>x. Set.insert (Pair x x)) {} A"
 proof -
   interpret comp_fun_commute "\<lambda>x. Set.insert (Pair x x)"
     by standard auto
   from assms show ?thesis
     unfolding Id_on_def by (induct A) simp_all
 qed
 
 lemma comp_fun_commute_Image_fold:
   "comp_fun_commute (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A)"
 proof -
   interpret comp_fun_idem Set.insert
     by (fact comp_fun_idem_insert)
   show ?thesis
     by standard (auto simp: fun_eq_iff comp_fun_commute split: prod.split)
 qed
 
 lemma Image_fold:
   assumes "finite R"
   shows "R `` S = Finite_Set.fold (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A) {} R"
 proof -
   interpret comp_fun_commute "(\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A)"
     by (rule comp_fun_commute_Image_fold)
   have *: "\<And>x F. Set.insert x F `` S = (if fst x \<in> S then Set.insert (snd x) (F `` S) else (F `` S))"
     by (force intro: rev_ImageI)
   show ?thesis
     using assms by (induct R) (auto simp: * )
 qed
 
 lemma insert_relcomp_union_fold:
   assumes "finite S"
   shows "{x} O S \<union> X = Finite_Set.fold (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A') X S"
 proof -
   interpret comp_fun_commute "\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A'"
   proof -
     interpret comp_fun_idem Set.insert
       by (fact comp_fun_idem_insert)
     show "comp_fun_commute (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A')"
       by standard (auto simp add: fun_eq_iff split: prod.split)
   qed
   have *: "{x} O S = {(x', z). x' = fst x \<and> (snd x, z) \<in> S}"
     by (auto simp: relcomp_unfold intro!: exI)
   show ?thesis
     unfolding * using \<open>finite S\<close> by (induct S) (auto split: prod.split)
 qed
 
 lemma insert_relcomp_fold:
   assumes "finite S"
   shows "Set.insert x R O S =
     Finite_Set.fold (\<lambda>(w,z) A'. if snd x = w then Set.insert (fst x,z) A' else A') (R O S) S"
 proof -
   have "Set.insert x R O S = ({x} O S) \<union> (R O S)"
     by auto
   then show ?thesis
     by (auto simp: insert_relcomp_union_fold [OF assms])
 qed
 
 lemma comp_fun_commute_relcomp_fold:
   assumes "finite S"
   shows "comp_fun_commute (\<lambda>(x,y) A.
     Finite_Set.fold (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') A S)"
 proof -
   have *: "\<And>a b A.
     Finite_Set.fold (\<lambda>(w, z) A'. if b = w then Set.insert (a, z) A' else A') A S = {(a,b)} O S \<union> A"
     by (auto simp: insert_relcomp_union_fold[OF assms] cong: if_cong)
   show ?thesis
     by standard (auto simp: * )
 qed
 
 lemma relcomp_fold:
   assumes "finite R" "finite S"
   shows "R O S = Finite_Set.fold
     (\<lambda>(x,y) A. Finite_Set.fold (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') A S) {} R"
 proof -
   interpret commute_relcomp_fold: comp_fun_commute
     "(\<lambda>(x, y) A. Finite_Set.fold (\<lambda>(w, z) A'. if y = w then insert (x, z) A' else A') A S)"
     by (fact comp_fun_commute_relcomp_fold[OF \<open>finite S\<close>])
   from assms show ?thesis
     by (induct R) (auto simp: comp_fun_commute_relcomp_fold insert_relcomp_fold cong: if_cong)
 qed
 
 
 subsection \<open>Locales as mini-packages for fold operations\<close>
 
 subsubsection \<open>The natural case\<close>
 
 locale folding_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y o f x = f x o f y"
 begin
 
 interpretation fold?: comp_fun_commute_on S f
   by standard (simp add: comp_fun_commute_on)
 
 definition F :: "'a set \<Rightarrow> 'b"
   where eq_fold: "F A = Finite_Set.fold f z A"
 
 lemma empty [simp]: "F {} = z"
   by (simp add: eq_fold)
 
 lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F A = z"
   by (simp add: eq_fold)
 
 lemma insert [simp]:
   assumes "insert x A \<subseteq> S" and "finite A" and "x \<notin> A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert assms
   have "Finite_Set.fold f z (insert x A) 
       = f x (Finite_Set.fold f z A)"
     by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 lemma remove:
   assumes "A \<subseteq> S" and "finite A" and "x \<in> A"
   shows "F A = f x (F (A - {x}))"
 proof -
   from \<open>x \<in> A\<close> obtain B where A: "A = insert x B" and "x \<notin> B"
     by (auto dest: mk_disjoint_insert)
   moreover from \<open>finite A\<close> A have "finite B" by simp
   ultimately show ?thesis
     using \<open>A \<subseteq> S\<close> by auto
 qed
 
 lemma insert_remove:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F (A - {x}))"
   using assms by (cases "x \<in> A") (simp_all add: remove insert_absorb)
 
 end
 
 
 subsubsection \<open>With idempotency\<close>
 
 locale folding_idem_on = folding_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 declare insert [simp del]
 
 interpretation fold?: comp_fun_idem_on S f
   by standard (simp_all add: comp_fun_commute_on comp_fun_idem_on)
 
 lemma insert_idem [simp]:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert_idem assms
   have "fold f z (insert x A) = f x (fold f z A)" by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 end
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as the carrier set\<close>
 
 locale folding =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) folding_def': "folding f = folding_on UNIV f"
   unfolding folding_def folding_on_def by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_on UNIV f"
     by standard (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 locale folding_idem = folding +
   assumes comp_fun_idem: "f x \<circ> f x = f x"
 begin
 
 lemma (in -) folding_idem_def': "folding_idem f = folding_idem_on UNIV f"
   unfolding folding_idem_def folding_def' folding_idem_on_def
   unfolding folding_idem_axioms_def folding_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_idem_on UNIV f"
     by standard (simp add: comp_fun_idem)
 qed simp_all
 
 end
 
 
 subsection \<open>Finite cardinality\<close>
 
 text \<open>
   The traditional definition
   \<^prop>\<open>card A \<equiv> LEAST n. \<exists>f. A = {f i |i. i < n}\<close>
   is ugly to work with.
   But now that we have \<^const>\<open>fold\<close> things are easy:
 \<close>
 
 global_interpretation card: folding "\<lambda>_. Suc" 0
   defines card = "folding_on.F (\<lambda>_. Suc) 0"
   by standard (rule refl)
 
 lemma card_insert_disjoint: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> card (insert x A) = Suc (card A)"
   by (fact card.insert)
 
 lemma card_insert_if: "finite A \<Longrightarrow> card (insert x A) = (if x \<in> A then card A else Suc (card A))"
   by auto (simp add: card.insert_remove card.remove)
 
 lemma card_ge_0_finite: "card A > 0 \<Longrightarrow> finite A"
   by (rule ccontr) simp
 
 lemma card_0_eq [simp]: "finite A \<Longrightarrow> card A = 0 \<longleftrightarrow> A = {}"
   by (auto dest: mk_disjoint_insert)
 
 lemma finite_UNIV_card_ge_0: "finite (UNIV :: 'a set) \<Longrightarrow> card (UNIV :: 'a set) > 0"
   by (rule ccontr) simp
 
 lemma card_eq_0_iff: "card A = 0 \<longleftrightarrow> A = {} \<or> \<not> finite A"
   by auto
 
 lemma card_range_greater_zero: "finite (range f) \<Longrightarrow> card (range f) > 0"
   by (rule ccontr) (simp add: card_eq_0_iff)
 
 lemma card_gt_0_iff: "0 < card A \<longleftrightarrow> A \<noteq> {} \<and> finite A"
   by (simp add: neq0_conv [symmetric] card_eq_0_iff)
 
 lemma card_Suc_Diff1:
   assumes "finite A" "x \<in> A" shows "Suc (card (A - {x})) = card A"
 proof -
   have "Suc (card (A - {x})) = card (insert x (A - {x}))"
     using assms by (simp add: card.insert_remove)
   also have "... = card A"
     using assms by (simp add: card_insert_if)
   finally show ?thesis .
 qed
 
 lemma card_insert_le_m1:
   assumes "n > 0" "card y \<le> n - 1" shows  "card (insert x y) \<le> n"
   using assms
   by (cases "finite y") (auto simp: card_insert_if)
 
 lemma card_Diff_singleton:
   assumes "x \<in> A" shows "card (A - {x}) = card A - 1"
 proof (cases "finite A")
   case True
   with assms show ?thesis
     by (simp add: card_Suc_Diff1 [symmetric])
 qed auto
 
 lemma card_Diff_singleton_if:
   "card (A - {x}) = (if x \<in> A then card A - 1 else card A)"
   by (simp add: card_Diff_singleton)
 
 lemma card_Diff_insert[simp]:
   assumes "a \<in> A" and "a \<notin> B"
   shows "card (A - insert a B) = card (A - B) - 1"
 proof -
   have "A - insert a B = (A - B) - {a}"
     using assms by blast
   then show ?thesis
     using assms by (simp add: card_Diff_singleton)
 qed
 
 lemma card_insert_le: "card A \<le> card (insert x A)"
 proof (cases "finite A")
   case True
   then show ?thesis   by (simp add: card_insert_if)
 qed auto
 
 lemma card_Collect_less_nat[simp]: "card {i::nat. i < n} = n"
   by (induct n) (simp_all add:less_Suc_eq Collect_disj_eq)
 
 lemma card_Collect_le_nat[simp]: "card {i::nat. i \<le> n} = Suc n"
   using card_Collect_less_nat[of "Suc n"] by (simp add: less_Suc_eq_le)
 
 lemma card_mono:
   assumes "finite B" and "A \<subseteq> B"
   shows "card A \<le> card B"
 proof -
   from assms have "finite A"
     by (auto intro: finite_subset)
   then show ?thesis
     using assms
   proof (induct A arbitrary: B)
     case empty
     then show ?case by simp
   next
     case (insert x A)
     then have "x \<in> B"
       by simp
     from insert have "A \<subseteq> B - {x}" and "finite (B - {x})"
       by auto
     with insert.hyps have "card A \<le> card (B - {x})"
       by auto
     with \<open>finite A\<close> \<open>x \<notin> A\<close> \<open>finite B\<close> \<open>x \<in> B\<close> show ?case
       by simp (simp only: card.remove)
   qed
 qed
 
 lemma card_seteq: 
   assumes "finite B" and A: "A \<subseteq> B" "card B \<le> card A"
   shows "A = B"
   using assms
 proof (induction arbitrary: A rule: finite_induct)
   case (insert b B)
   then have A: "finite A" "A - {b} \<subseteq> B" 
     by force+
   then have "card B \<le> card (A - {b})"
     using insert by (auto simp add: card_Diff_singleton_if)
   then have "A - {b} = B"
     using A insert.IH by auto
   then show ?case 
     using insert.hyps insert.prems by auto
 qed auto
 
 lemma psubset_card_mono: "finite B \<Longrightarrow> A < B \<Longrightarrow> card A < card B"
   using card_seteq [of B A] by (auto simp add: psubset_eq)
 
 lemma card_Un_Int:
   assumes "finite A" "finite B"
   shows "card A + card B = card (A \<union> B) + card (A \<inter> B)"
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     by (auto simp add: insert_absorb Int_insert_left)
 qed
 
 lemma card_Un_disjoint: "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<inter> B = {} \<Longrightarrow> card (A \<union> B) = card A + card B"
   using card_Un_Int [of A B] by simp
 
 lemma card_Un_disjnt: "\<lbrakk>finite A; finite B; disjnt A B\<rbrakk> \<Longrightarrow> card (A \<union> B) = card A + card B"
   by (simp add: card_Un_disjoint disjnt_def)
 
 lemma card_Un_le: "card (A \<union> B) \<le> card A + card B"
 proof (cases "finite A \<and> finite B")
   case True
   then show ?thesis
     using le_iff_add card_Un_Int [of A B] by auto
 qed auto
 
 lemma card_Diff_subset:
   assumes "finite B"
     and "B \<subseteq> A"
   shows "card (A - B) = card A - card B"
   using assms
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by simp
 next
   case True
   with assms show ?thesis
     by (induct B arbitrary: A) simp_all
 qed
 
 lemma card_Diff_subset_Int:
   assumes "finite (A \<inter> B)"
   shows "card (A - B) = card A - card (A \<inter> B)"
 proof -
   have "A - B = A - A \<inter> B" by auto
   with assms show ?thesis
     by (simp add: card_Diff_subset)
 qed
 
 lemma card_Int_Diff:
   assumes "finite A"
   shows "card A = card (A \<inter> B) + card (A - B)"
   by (simp add: assms card_Diff_subset_Int card_mono)
 
 lemma diff_card_le_card_Diff:
   assumes "finite B"
   shows "card A - card B \<le> card (A - B)"
 proof -
   have "card A - card B \<le> card A - card (A \<inter> B)"
     using card_mono[OF assms Int_lower2, of A] by arith
   also have "\<dots> = card (A - B)"
     using assms by (simp add: card_Diff_subset_Int)
   finally show ?thesis .
 qed
 
 lemma card_le_sym_Diff:
   assumes "finite A" "finite B" "card A \<le> card B"
   shows "card(A - B) \<le> card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> \<le> card B - card (A \<inter> B)" using assms(3) by linarith
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_less_sym_Diff:
   assumes "finite A" "finite B" "card A < card B"
   shows "card(A - B) < card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> < card B - card (A \<inter> B)" using assms(1,3) by (simp add: card_mono diff_less_mono)
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_Diff1_less_iff: "card (A - {x}) < card A \<longleftrightarrow> finite A \<and> x \<in> A"
 proof (cases "finite A \<and> x \<in> A")
   case True
   then show ?thesis
     by (auto simp: card_gt_0_iff intro: diff_less)
 qed auto
 
 lemma card_Diff1_less: "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> card (A - {x}) < card A"
   unfolding card_Diff1_less_iff by auto
 
 lemma card_Diff2_less:
   assumes "finite A" "x \<in> A" "y \<in> A" shows "card (A - {x} - {y}) < card A"
 proof (cases "x = y")
   case True
   with assms show ?thesis
     by (simp add: card_Diff1_less del: card_Diff_insert)
 next
   case False
   then have "card (A - {x} - {y}) < card (A - {x})" "card (A - {x}) < card A"
     using assms by (intro card_Diff1_less; simp)+
   then show ?thesis
     by (blast intro: less_trans)
 qed
 
 lemma card_Diff1_le: "card (A - {x}) \<le> card A"
 proof (cases "finite A")
   case True
   then show ?thesis  
     by (cases "x \<in> A") (simp_all add: card_Diff1_less less_imp_le)
 qed auto
 
 lemma card_psubset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> card A < card B \<Longrightarrow> A < B"
   by (erule psubsetI) blast
 
 lemma card_le_inj:
   assumes fA: "finite A"
     and fB: "finite B"
     and c: "card A \<le> card B"
   shows "\<exists>f. f ` A \<subseteq> B \<and> inj_on f A"
   using fA fB c
 proof (induct arbitrary: B rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x s t)
   then show ?case
   proof (induct rule: finite_induct [OF insert.prems(1)])
     case 1
     then show ?case by simp
   next
     case (2 y t)
     from "2.prems"(1,2,5) "2.hyps"(1,2) have cst: "card s \<le> card t"
       by simp
     from "2.prems"(3) [OF "2.hyps"(1) cst]
     obtain f where *: "f ` s \<subseteq> t" "inj_on f s"
       by blast
     let ?g = "(\<lambda>a. if a = x then y else f a)"
     have "?g ` insert x s \<subseteq> insert y t \<and> inj_on ?g (insert x s)"
       using * "2.prems"(2) "2.hyps"(2) unfolding inj_on_def by auto
     then show ?case by (rule exI[where ?x="?g"])
   qed
 qed
 
 lemma card_subset_eq:
   assumes fB: "finite B"
     and AB: "A \<subseteq> B"
     and c: "card A = card B"
   shows "A = B"
 proof -
   from fB AB have fA: "finite A"
     by (auto intro: finite_subset)
   from fA fB have fBA: "finite (B - A)"
     by auto
   have e: "A \<inter> (B - A) = {}"
     by blast
   have eq: "A \<union> (B - A) = B"
     using AB by blast
   from card_Un_disjoint[OF fA fBA e, unfolded eq c] have "card (B - A) = 0"
     by arith
   then have "B - A = {}"
     unfolding card_eq_0_iff using fA fB by simp
   with AB show "A = B"
     by blast
 qed
 
 lemma insert_partition:
   "x \<notin> F \<Longrightarrow> \<forall>c1 \<in> insert x F. \<forall>c2 \<in> insert x F. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<Longrightarrow> x \<inter> \<Union>F = {}"
   by auto
 
 lemma finite_psubset_induct [consumes 1, case_names psubset]:
   assumes finite: "finite A"
     and major: "\<And>A. finite A \<Longrightarrow> (\<And>B. B \<subset> A \<Longrightarrow> P B) \<Longrightarrow> P A"
   shows "P A"
   using finite
 proof (induct A taking: card rule: measure_induct_rule)
   case (less A)
   have fin: "finite A" by fact
   have ih: "card B < card A \<Longrightarrow> finite B \<Longrightarrow> P B" for B by fact
   have "P B" if "B \<subset> A" for B
   proof -
     from that have "card B < card A"
       using psubset_card_mono fin by blast
     moreover
     from that have "B \<subseteq> A"
       by auto
     then have "finite B"
       using fin finite_subset by blast
     ultimately show ?thesis using ih by simp
   qed
   with fin show "P A" using major by blast
 qed
 
 lemma finite_induct_select [consumes 1, case_names empty select]:
   assumes "finite S"
     and "P {}"
     and select: "\<And>T. T \<subset> S \<Longrightarrow> P T \<Longrightarrow> \<exists>s\<in>S - T. P (insert s T)"
   shows "P S"
 proof -
   have "0 \<le> card S" by simp
   then have "\<exists>T \<subseteq> S. card T = card S \<and> P T"
   proof (induct rule: dec_induct)
     case base with \<open>P {}\<close>
     show ?case
       by (intro exI[of _ "{}"]) auto
   next
     case (step n)
     then obtain T where T: "T \<subseteq> S" "card T = n" "P T"
       by auto
     with \<open>n < card S\<close> have "T \<subset> S" "P T"
       by auto
     with select[of T] obtain s where "s \<in> S" "s \<notin> T" "P (insert s T)"
       by auto
     with step(2) T \<open>finite S\<close> show ?case
       by (intro exI[of _ "insert s T"]) (auto dest: finite_subset)
   qed
   with \<open>finite S\<close> show "P S"
     by (auto dest: card_subset_eq)
 qed
 
 lemma remove_induct [case_names empty infinite remove]:
   assumes empty: "P ({} :: 'a set)"
     and infinite: "\<not> finite B \<Longrightarrow> P B"
     and remove: "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   shows "P B"
 proof (cases "finite B")
   case False
   then show ?thesis by (rule infinite)
 next
   case True
   define A where "A = B"
   with True have "finite A" "A \<subseteq> B"
     by simp_all
   then show "P A"
   proof (induct "card A" arbitrary: A)
     case 0
     then have "A = {}" by auto
     with empty show ?case by simp
   next
     case (Suc n A)
     from \<open>A \<subseteq> B\<close> and \<open>finite B\<close> have "finite A"
       by (rule finite_subset)
     moreover from Suc.hyps have "A \<noteq> {}" by auto
     moreover note \<open>A \<subseteq> B\<close>
     moreover have "P (A - {x})" if x: "x \<in> A" for x
       using x Suc.prems \<open>Suc n = card A\<close> by (intro Suc) auto
     ultimately show ?case by (rule remove)
   qed
 qed
 
 lemma finite_remove_induct [consumes 1, case_names empty remove]:
   fixes P :: "'a set \<Rightarrow> bool"
   assumes "finite B"
     and "P {}"
     and "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   defines "B' \<equiv> B"
   shows "P B'"
   by (induct B' rule: remove_induct) (simp_all add: assms)
 
 
 text \<open>Main cardinality theorem.\<close>
 lemma card_partition [rule_format]:
   "finite C \<Longrightarrow> finite (\<Union>C) \<Longrightarrow> (\<forall>c\<in>C. card c = k) \<Longrightarrow>
     (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}) \<Longrightarrow>
     k * card C = card (\<Union>C)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case
     by (simp add: card_Un_disjoint insert_partition finite_subset [of _ "\<Union>(insert _ _)"])
 qed
 
 lemma card_eq_UNIV_imp_eq_UNIV:
   assumes fin: "finite (UNIV :: 'a set)"
     and card: "card A = card (UNIV :: 'a set)"
   shows "A = (UNIV :: 'a set)"
 proof
   show "A \<subseteq> UNIV" by simp
   show "UNIV \<subseteq> A"
   proof
     show "x \<in> A" for x
     proof (rule ccontr)
       assume "x \<notin> A"
       then have "A \<subset> UNIV" by auto
       with fin have "card A < card (UNIV :: 'a set)"
         by (fact psubset_card_mono)
       with card show False by simp
     qed
   qed
 qed
 
 text \<open>The form of a finite set of given cardinality\<close>
 
 lemma card_eq_SucD:
   assumes "card A = Suc k"
   shows "\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {})"
 proof -
   have fin: "finite A"
     using assms by (auto intro: ccontr)
   moreover have "card A \<noteq> 0"
     using assms by auto
   ultimately obtain b where b: "b \<in> A"
     by auto
   show ?thesis
   proof (intro exI conjI)
     show "A = insert b (A - {b})"
       using b by blast
     show "b \<notin> A - {b}"
       by blast
     show "card (A - {b}) = k" and "k = 0 \<longrightarrow> A - {b} = {}"
       using assms b fin by (fastforce dest: mk_disjoint_insert)+
   qed
 qed
 
 lemma card_Suc_eq:
   "card A = Suc k \<longleftrightarrow>
     (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {}))"
   by (auto simp: card_insert_if card_gt_0_iff elim!: card_eq_SucD)
 
 lemma card_Suc_eq_finite:
   "card A = Suc k \<longleftrightarrow> (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> finite B)"
   unfolding card_Suc_eq using card_gt_0_iff by fastforce
 
 lemma card_1_singletonE:
   assumes "card A = 1"
   obtains x where "A = {x}"
   using assms by (auto simp: card_Suc_eq)
 
 lemma is_singleton_altdef: "is_singleton A \<longleftrightarrow> card A = 1"
   unfolding is_singleton_def
   by (auto elim!: card_1_singletonE is_singletonE simp del: One_nat_def)
 
 lemma card_1_singleton_iff: "card A = Suc 0 \<longleftrightarrow> (\<exists>x. A = {x})"
   by (simp add: card_Suc_eq)
 
 lemma card_le_Suc0_iff_eq:
   assumes "finite A"
   shows "card A \<le> Suc 0 \<longleftrightarrow> (\<forall>a1 \<in> A. \<forall>a2 \<in> A. a1 = a2)" (is "?C = ?A")
 proof
   assume ?C thus ?A using assms by (auto simp: le_Suc_eq dest: card_eq_SucD)
 next
   assume ?A
   show ?C
   proof cases
     assume "A = {}" thus ?C using \<open>?A\<close> by simp
   next
     assume "A \<noteq> {}"
     then obtain a where "A = {a}" using \<open>?A\<close> by blast
     thus ?C by simp
   qed
 qed
 
 lemma card_le_Suc_iff:
   "Suc n \<le> card A = (\<exists>a B. A = insert a B \<and> a \<notin> B \<and> n \<le> card B \<and> finite B)"
 proof (cases "finite A")
   case True
   then show ?thesis
     by (fastforce simp: card_Suc_eq less_eq_nat.simps split: nat.splits)
 qed auto
 
 lemma finite_fun_UNIVD2:
   assumes fin: "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   shows "finite (UNIV :: 'b set)"
 proof -
   from fin have "finite (range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary))" for arbitrary
     by (rule finite_imageI)
   moreover have "UNIV = range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary)" for arbitrary
     by (rule UNIV_eq_I) auto
   ultimately show "finite (UNIV :: 'b set)"
     by simp
 qed
 
 lemma card_UNIV_unit [simp]: "card (UNIV :: unit set) = 1"
   unfolding UNIV_unit by simp
 
 lemma infinite_arbitrarily_large:
   assumes "\<not> finite A"
   shows "\<exists>B. finite B \<and> card B = n \<and> B \<subseteq> A"
 proof (induction n)
   case 0
   show ?case by (intro exI[of _ "{}"]) auto
 next
   case (Suc n)
   then obtain B where B: "finite B \<and> card B = n \<and> B \<subseteq> A" ..
   with \<open>\<not> finite A\<close> have "A \<noteq> B" by auto
   with B have "B \<subset> A" by auto
   then have "\<exists>x. x \<in> A - B"
     by (elim psubset_imp_ex_mem)
   then obtain x where x: "x \<in> A - B" ..
   with B have "finite (insert x B) \<and> card (insert x B) = Suc n \<and> insert x B \<subseteq> A"
     by auto
   then show "\<exists>B. finite B \<and> card B = Suc n \<and> B \<subseteq> A" ..
 qed
 
 text \<open>Sometimes, to prove that a set is finite, it is convenient to work with finite subsets
 and to show that their cardinalities are uniformly bounded. This possibility is formalized in
 the next criterion.\<close>
 
 lemma finite_if_finite_subsets_card_bdd:
   assumes "\<And>G. G \<subseteq> F \<Longrightarrow> finite G \<Longrightarrow> card G \<le> C"
   shows "finite F \<and> card F \<le> C"
 proof (cases "finite F")
   case False
   obtain n::nat where n: "n > max C 0" by auto
   obtain G where G: "G \<subseteq> F" "card G = n" using infinite_arbitrarily_large[OF False] by auto
   hence "finite G" using \<open>n > max C 0\<close> using card.infinite gr_implies_not0 by blast
   hence False using assms G n not_less by auto
   thus ?thesis ..
 next
   case True thus ?thesis using assms[of F] by auto
 qed
 
 lemma obtain_subset_with_card_n:
   assumes "n \<le> card S"
   obtains T where "T \<subseteq> S" "card T = n" "finite T"
 proof -
   obtain n' where "card S = n + n'"
     using le_Suc_ex[OF assms] by blast
   with that show thesis
   proof (induct n' arbitrary: S)
     case 0 
     thus ?case by (cases "finite S") auto
   next
     case Suc 
     thus ?case by (auto simp add: card_Suc_eq)
   qed
 qed
 
 lemma exists_subset_between: 
   assumes 
     "card A \<le> n" 
     "n \<le> card C"
     "A \<subseteq> C"
     "finite C"
   shows "\<exists>B. A \<subseteq> B \<and> B \<subseteq> C \<and> card B = n" 
   using assms 
 proof (induct n arbitrary: A C)
   case 0
   thus ?case using finite_subset[of A C] by (intro exI[of _ "{}"], auto)
 next
   case (Suc n A C)
   show ?case
   proof (cases "A = {}")
     case True
     from obtain_subset_with_card_n[OF Suc(3)]
     obtain B where "B \<subseteq> C" "card B = Suc n" by blast
     thus ?thesis unfolding True by blast
   next
     case False
     then obtain a where a: "a \<in> A" by auto
     let ?A = "A - {a}" 
     let ?C = "C - {a}" 
     have 1: "card ?A \<le> n" using Suc(2-) a 
       using finite_subset by fastforce 
     have 2: "card ?C \<ge> n" using Suc(2-) a by auto
     from Suc(1)[OF 1 2 _ finite_subset[OF _ Suc(5)]] Suc(2-)
     obtain B where "?A \<subseteq> B" "B \<subseteq> ?C" "card B = n" by blast
     thus ?thesis using a Suc(2-) 
       by (intro exI[of _ "insert a B"], auto intro!: card_insert_disjoint finite_subset[of B C])
   qed
 qed
 
 
 subsubsection \<open>Cardinality of image\<close>
 
 lemma card_image_le: "finite A \<Longrightarrow> card (f ` A) \<le> card A"
   by (induct rule: finite_induct) (simp_all add: le_SucI card_insert_if)
 
 lemma card_image: "inj_on f A \<Longrightarrow> card (f ` A) = card A"
 proof (induct A rule: infinite_finite_induct)
   case (infinite A)
   then have "\<not> finite (f ` A)" by (auto dest: finite_imageD)
   with infinite show ?case by simp
 qed simp_all
 
 lemma bij_betw_same_card: "bij_betw f A B \<Longrightarrow> card A = card B"
   by (auto simp: card_image bij_betw_def)
 
 lemma endo_inj_surj: "finite A \<Longrightarrow> f ` A \<subseteq> A \<Longrightarrow> inj_on f A \<Longrightarrow> f ` A = A"
   by (simp add: card_seteq card_image)
 
 lemma eq_card_imp_inj_on:
   assumes "finite A" "card(f ` A) = card A"
   shows "inj_on f A"
   using assms
 proof (induct rule:finite_induct)
   case empty
   show ?case by simp
 next
   case (insert x A)
   then show ?case
     using card_image_le [of A f] by (simp add: card_insert_if split: if_splits)
 qed
 
 lemma inj_on_iff_eq_card: "finite A \<Longrightarrow> inj_on f A \<longleftrightarrow> card (f ` A) = card A"
   by (blast intro: card_image eq_card_imp_inj_on)
 
 lemma card_inj_on_le:
   assumes "inj_on f A" "f ` A \<subseteq> B" "finite B"
   shows "card A \<le> card B"
 proof -
   have "finite A"
     using assms by (blast intro: finite_imageD dest: finite_subset)
   then show ?thesis
     using assms by (force intro: card_mono simp: card_image [symmetric])
 qed
 
 lemma inj_on_iff_card_le:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> (\<exists>f. inj_on f A \<and> f ` A \<le> B) = (card A \<le> card B)"
 using card_inj_on_le[of _ A B] card_le_inj[of A B] by blast
 
 lemma surj_card_le: "finite A \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> card B \<le> card A"
   by (blast intro: card_image_le card_mono le_trans)
 
 lemma card_bij_eq:
   "inj_on f A \<Longrightarrow> f ` A \<subseteq> B \<Longrightarrow> inj_on g B \<Longrightarrow> g ` B \<subseteq> A \<Longrightarrow> finite A \<Longrightarrow> finite B
     \<Longrightarrow> card A = card B"
   by (auto intro: le_antisym card_inj_on_le)
 
 lemma bij_betw_finite: "bij_betw f A B \<Longrightarrow> finite A \<longleftrightarrow> finite B"
   unfolding bij_betw_def using finite_imageD [of f A] by auto
 
 lemma inj_on_finite: "inj_on f A \<Longrightarrow> f ` A \<le> B \<Longrightarrow> finite B \<Longrightarrow> finite A"
   using finite_imageD finite_subset by blast
 
 lemma card_vimage_inj_on_le:
   assumes "inj_on f D" "finite A"
   shows "card (f-`A \<inter> D) \<le> card A"
 proof (rule card_inj_on_le)
   show "inj_on f (f -` A \<inter> D)"
     by (blast intro: assms inj_on_subset)
 qed (use assms in auto)
 
 lemma card_vimage_inj: "inj f \<Longrightarrow> A \<subseteq> range f \<Longrightarrow> card (f -` A) = card A"
   by (auto 4 3 simp: subset_image_iff inj_vimage_image_eq
       intro: card_image[symmetric, OF subset_inj_on])
 
 lemma card_inverse[simp]: "card (R\<inverse>) = card R"
 proof -
   have *: "\<And>R. prod.swap ` R = R\<inverse>" by auto
   {
     assume "\<not>finite R"
     hence ?thesis
       by auto
   } moreover {
     assume "finite R"
     with card_image_le[of R prod.swap] card_image_le[of "R\<inverse>" prod.swap]
     have ?thesis by (auto simp: * )
   } ultimately show ?thesis by blast
 qed
 
 subsubsection \<open>Pigeonhole Principles\<close>
 
 lemma pigeonhole: "card A > card (f ` A) \<Longrightarrow> \<not> inj_on f A "
   by (auto dest: card_image less_irrefl_nat)
 
 lemma pigeonhole_infinite:
   assumes "\<not> finite A" and "finite (f`A)"
   shows "\<exists>a0\<in>A. \<not> finite {a\<in>A. f a = f a0}"
   using assms(2,1)
 proof (induct "f`A" arbitrary: A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert b F)
   show ?case
   proof (cases "finite {a\<in>A. f a = b}")
     case True
     with \<open>\<not> finite A\<close> have "\<not> finite (A - {a\<in>A. f a = b})"
       by simp
     also have "A - {a\<in>A. f a = b} = {a\<in>A. f a \<noteq> b}"
       by blast
     finally have "\<not> finite {a\<in>A. f a \<noteq> b}" .
     from insert(3)[OF _ this] insert(2,4) show ?thesis
       by simp (blast intro: rev_finite_subset)
   next
     case False
     then have "{a \<in> A. f a = b} \<noteq> {}" by force
     with False show ?thesis by blast
   qed
 qed
 
 lemma pigeonhole_infinite_rel:
   assumes "\<not> finite A"
     and "finite B"
     and "\<forall>a\<in>A. \<exists>b\<in>B. R a b"
   shows "\<exists>b\<in>B. \<not> finite {a:A. R a b}"
 proof -
   let ?F = "\<lambda>a. {b\<in>B. R a b}"
   from finite_Pow_iff[THEN iffD2, OF \<open>finite B\<close>] have "finite (?F ` A)"
     by (blast intro: rev_finite_subset)
   from pigeonhole_infinite [where f = ?F, OF assms(1) this]
   obtain a0 where "a0 \<in> A" and infinite: "\<not> finite {a\<in>A. ?F a = ?F a0}" ..
   obtain b0 where "b0 \<in> B" and "R a0 b0"
     using \<open>a0 \<in> A\<close> assms(3) by blast
   have "finite {a\<in>A. ?F a = ?F a0}" if "finite {a\<in>A. R a b0}"
     using \<open>b0 \<in> B\<close> \<open>R a0 b0\<close> that by (blast intro: rev_finite_subset)
   with infinite \<open>b0 \<in> B\<close> show ?thesis
     by blast
 qed
 
 
 subsubsection \<open>Cardinality of sums\<close>
 
 lemma card_Plus:
   assumes "finite A" "finite B"
   shows "card (A <+> B) = card A + card B"
 proof -
   have "Inl`A \<inter> Inr`B = {}" by fast
   with assms show ?thesis
     by (simp add: Plus_def card_Un_disjoint card_image)
 qed
 
 lemma card_Plus_conv_if:
   "card (A <+> B) = (if finite A \<and> finite B then card A + card B else 0)"
   by (auto simp add: card_Plus)
 
 text \<open>Relates to equivalence classes.  Based on a theorem of F. Kammüller.\<close>
 
 lemma dvd_partition:
   assumes f: "finite (\<Union>C)"
     and "\<forall>c\<in>C. k dvd card c" "\<forall>c1\<in>C. \<forall>c2\<in>C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}"
   shows "k dvd card (\<Union>C)"
 proof -
   have "finite C"
     by (rule finite_UnionD [OF f])
   then show ?thesis
     using assms
   proof (induct rule: finite_induct)
     case empty
     show ?case by simp
   next
     case (insert c C)
     then have "c \<inter> \<Union>C = {}"
       by auto
     with insert show ?case
       by (simp add: card_Un_disjoint)
   qed
 qed
 
 
 subsection \<open>Minimal and maximal elements of finite sets\<close>
 
 context begin
 
 qualified lemma
   assumes "finite A" and "asymp_on A R" and "transp_on A R" and "\<exists>x \<in> A. P x"
   shows
     bex_min_element_with_property: "\<exists>x \<in> A. P x \<and> (\<forall>y \<in> A. R y x \<longrightarrow> \<not> P y)" and
     bex_max_element_with_property: "\<exists>x \<in> A. P x \<and> (\<forall>y \<in> A. R x y \<longrightarrow> \<not> P y)"
   unfolding atomize_conj
   using assms
 proof (induction A rule: finite_induct)
   case empty
   hence False
     by simp_all
   thus ?case ..
 next
   case (insert x F)
 
   from insert.prems have "asymp_on F R"
     using asymp_on_subset by blast
 
   from insert.prems have "transp_on F R"
     using transp_on_subset by blast
 
   show ?case
   proof (cases "P x")
     case True
     show ?thesis
     proof (cases "\<exists>a\<in>F. P a")
       case True
       with insert.IH obtain min max where
         "min \<in> F" and "P min" and "\<forall>z \<in> F. R z min \<longrightarrow> \<not> P z"
         "max \<in> F" and "P max" and "\<forall>z \<in> F. R max z \<longrightarrow> \<not> P z"
         using \<open>asymp_on F R\<close> \<open>transp_on F R\<close> by auto
 
       show ?thesis
       proof (rule conjI)
         show "\<exists>y \<in> insert x F. P y \<and> (\<forall>z \<in> insert x F. R y z \<longrightarrow> \<not> P z)"
         proof (cases "R max x")
           case True
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "x \<in> insert x F"
               by simp
           next
             show "P x"
               using \<open>P x\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R x z"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence "R x x"
                 using \<open>R x z\<close> by simp
               moreover have "\<not> R x x"
                 using \<open>asymp_on (insert x F) R\<close>[THEN irreflp_on_if_asymp_on, THEN irreflp_onD]
                 by simp
               ultimately have False
                 by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               moreover have "R max z"
                 using \<open>R max x\<close> \<open>R x z\<close>
                 using \<open>transp_on (insert x F) R\<close>[THEN transp_onD, of max x z]
                 using \<open>max \<in> F\<close> \<open>z \<in> F\<close> by simp
               ultimately show ?thesis
                 using \<open>\<forall>z \<in> F. R max z \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         next
           case False
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "max \<in> insert x F"
               using \<open>max \<in> F\<close> by simp
           next
             show "P max"
               using \<open>P max\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R max z"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence False
                 using \<open>\<not> R max x\<close> \<open>R max z\<close> by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               thus ?thesis
                 using \<open>R max z\<close> \<open>\<forall>z\<in>F. R max z \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         qed
       next
         show "\<exists>y \<in> insert x F. P y \<and> (\<forall>z \<in> insert x F. R z y \<longrightarrow> \<not> P z)"
         proof (cases "R x min")
           case True
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "x \<in> insert x F"
               by simp
           next
             show "P x"
               using \<open>P x\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R z x"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence "R x x"
                 using \<open>R z x\<close> by simp
               moreover have "\<not> R x x"
                 using \<open>asymp_on (insert x F) R\<close>[THEN irreflp_on_if_asymp_on, THEN irreflp_onD]
                 by simp
               ultimately have False
                 by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               moreover have "R z min"
                 using \<open>R z x\<close> \<open>R x min\<close>
                 using \<open>transp_on (insert x F) R\<close>[THEN transp_onD, of z x min]
                 using \<open>min \<in> F\<close> \<open>z \<in> F\<close> by simp
               ultimately show ?thesis
                 using \<open>\<forall>z \<in> F. R z min \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         next
           case False
           show ?thesis
           proof (intro bexI conjI ballI impI)
             show "min \<in> insert x F"
               using \<open>min \<in> F\<close> by simp
           next
             show "P min"
               using \<open>P min\<close> by simp
           next
             fix z assume "z \<in> insert x F" and "R z min"
             hence "z = x \<or> z \<in> F"
               by simp
             thus "\<not> P z"
             proof (rule disjE)
               assume "z = x"
               hence False
                 using \<open>\<not> R x min\<close> \<open>R z min\<close> by simp
               thus ?thesis ..
             next
               assume "z \<in> F"
               thus ?thesis
                 using \<open>R z min\<close> \<open>\<forall>z\<in>F. R z min \<longrightarrow> \<not> P z\<close> by simp
             qed
           qed
         qed
       qed
     next
       case False
       then show ?thesis
         using \<open>\<exists>a\<in>insert x F. P a\<close>
         using \<open>asymp_on (insert x F) R\<close>[THEN asymp_onD, of x] insert_iff[of _ x F]
         by blast
     qed
   next
     case False
     with insert.prems have "\<exists>x \<in> F. P x"
       by simp
     with insert.IH have
       "\<exists>y \<in> F. P y \<and> (\<forall>z\<in>F. R z y \<longrightarrow> \<not> P z)"
       "\<exists>y \<in> F. P y \<and> (\<forall>z\<in>F. R y z \<longrightarrow> \<not> P z)"
       using \<open>asymp_on F R\<close> \<open>transp_on F R\<close> by auto
     thus ?thesis
       using False by auto
   qed
 qed
 
 qualified lemma
   assumes "finite A" and "asymp_on A R" and "transp_on A R" and "A \<noteq> {}"
   shows
     bex_min_element: "\<exists>m \<in> A. \<forall>x \<in> A. x \<noteq> m \<longrightarrow> \<not> R x m" and
     bex_max_element: "\<exists>m \<in> A. \<forall>x \<in> A. x \<noteq> m \<longrightarrow> \<not> R m x"
   using \<open>A \<noteq> {}\<close>
     bex_min_element_with_property[OF assms(1,2,3), of "\<lambda>_. True", simplified]
     bex_max_element_with_property[OF assms(1,2,3), of "\<lambda>_. True", simplified]
   by blast+
 
 end
 
 text \<open>The following alternative form might sometimes be easier to work with.\<close>
 
 lemma is_min_element_in_set_iff:
   "asymp_on A R \<Longrightarrow> (\<forall>y \<in> A. y \<noteq> x \<longrightarrow> \<not> R y x) \<longleftrightarrow> (\<forall>y. R y x \<longrightarrow> y \<notin> A)"
   by (auto dest: asymp_onD)
 
 lemma is_max_element_in_set_iff:
   "asymp_on A R \<Longrightarrow> (\<forall>y \<in> A. y \<noteq> x \<longrightarrow> \<not> R x y) \<longleftrightarrow> (\<forall>y. R x y \<longrightarrow> y \<notin> A)"
   by (auto dest: asymp_onD)
 
 context begin
 
 qualified lemma
   assumes "finite A" and "A \<noteq> {}" and "transp_on A R" and "totalp_on A R"
   shows
     bex_least_element: "\<exists>l \<in> A. \<forall>x \<in> A. x \<noteq> l \<longrightarrow> R l x" and
     bex_greatest_element: "\<exists>g \<in> A. \<forall>x \<in> A. x \<noteq> g \<longrightarrow> R x g"
   unfolding atomize_conj
   using assms
 proof (induction A rule: finite_induct)
   case empty
   hence False by simp
   thus ?case ..
 next
   case (insert a A')
 
   from insert.prems(2) have transp_on_A': "transp_on A' R"
     by (auto intro: transp_onI dest: transp_onD)
 
   from insert.prems(3) have
     totalp_on_a_A'_raw: "\<forall>y \<in> A'. a \<noteq> y \<longrightarrow> R a y \<or> R y a" and
     totalp_on_A': "totalp_on A' R"
     by (simp_all add: totalp_on_def)
 
   show ?case
   proof (cases "A' = {}")
     case True
     thus ?thesis by simp
   next
     case False
     then obtain least greatest where
       "least \<in> A'" and least_of_A': "\<forall>x\<in>A'. x \<noteq> least \<longrightarrow> R least x" and
       "greatest \<in> A'" and greatest_of_A': "\<forall>x\<in>A'. x \<noteq> greatest \<longrightarrow> R x greatest"
       using insert.IH[OF _ transp_on_A' totalp_on_A'] by auto
 
     show ?thesis
     proof (rule conjI)
       show "\<exists>l\<in>insert a A'. \<forall>x\<in>insert a A'. x \<noteq> l \<longrightarrow> R l x"
       proof (cases "R a least")
         case True
         show ?thesis
         proof (intro bexI ballI impI)
           show "a \<in> insert a A'"
             by simp
         next
           fix x
           show "\<And>x. x \<in> insert a A' \<Longrightarrow> x \<noteq> a \<Longrightarrow> R a x"
             using True \<open>least \<in> A'\<close> least_of_A'
             using insert.prems(2)[THEN transp_onD, of a least]
             by auto
         qed
       next
         case False
         show ?thesis
         proof (intro bexI ballI impI)
           show "least \<in> insert a A'"
             using \<open>least \<in> A'\<close> by simp
         next
           fix x
           show "x \<in> insert a A' \<Longrightarrow> x \<noteq> least \<Longrightarrow> R least x"
             using False \<open>least \<in> A'\<close> least_of_A' totalp_on_a_A'_raw
             by (cases "x = a") auto
         qed
       qed
     next
       show "\<exists>g \<in> insert a A'. \<forall>x \<in> insert a A'. x \<noteq> g \<longrightarrow> R x g"
       proof (cases "R greatest a")
         case True
         show ?thesis
         proof (intro bexI ballI impI)
           show "a \<in> insert a A'"
             by simp
         next
           fix x
           show "\<And>x. x \<in> insert a A' \<Longrightarrow> x \<noteq> a \<Longrightarrow> R x a"
             using True \<open>greatest \<in> A'\<close> greatest_of_A'
             using insert.prems(2)[THEN transp_onD, of _ greatest a]
             by auto
         qed
       next
         case False
         show ?thesis
         proof (intro bexI ballI impI)
           show "greatest \<in> insert a A'"
             using \<open>greatest \<in> A'\<close> by simp
         next
           fix x
           show "x \<in> insert a A' \<Longrightarrow> x \<noteq> greatest \<Longrightarrow> R x greatest"
             using False \<open>greatest \<in> A'\<close> greatest_of_A' totalp_on_a_A'_raw
             by (cases "x = a") auto
         qed
       qed
     qed
   qed
 qed
 
 end
 
 subsubsection \<open>Finite orders\<close>
 
 context order
 begin
 
 lemma finite_has_maximal:
   assumes "finite A" and "A \<noteq> {}"
   shows "\<exists> m \<in> A. \<forall> b \<in> A. m \<le> b \<longrightarrow> m = b"
 proof -
   obtain m where "m \<in> A" and m_is_max: "\<forall>x\<in>A. x \<noteq> m \<longrightarrow> \<not> m < x"
     using Finite_Set.bex_max_element[OF \<open>finite A\<close> _ _ \<open>A \<noteq> {}\<close>, of "(<)"] by auto
   moreover have "\<forall>b \<in> A. m \<le> b \<longrightarrow> m = b"
     using m_is_max by (auto simp: le_less)
   ultimately show ?thesis
     by auto
 qed
 
 lemma finite_has_maximal2:
   "\<lbrakk> finite A; a \<in> A \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. a \<le> m \<and> (\<forall> b \<in> A. m \<le> b \<longrightarrow> m = b)"
 using finite_has_maximal[of "{b \<in> A. a \<le> b}"] by fastforce
 
 lemma finite_has_minimal:
   assumes "finite A" and "A \<noteq> {}"
   shows "\<exists> m \<in> A. \<forall> b \<in> A. b \<le> m \<longrightarrow> m = b"
 proof -
   obtain m where "m \<in> A" and m_is_min: "\<forall>x\<in>A. x \<noteq> m \<longrightarrow> \<not> x < m"
     using Finite_Set.bex_min_element[OF \<open>finite A\<close> _ _ \<open>A \<noteq> {}\<close>, of "(<)"] by auto
   moreover have "\<forall>b \<in> A. b \<le> m \<longrightarrow> m = b"
     using m_is_min by (auto simp: le_less)
   ultimately show ?thesis
     by auto
 qed
 
 lemma finite_has_minimal2:
   "\<lbrakk> finite A; a \<in> A \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. m \<le> a \<and> (\<forall> b \<in> A. b \<le> m \<longrightarrow> m = b)"
 using finite_has_minimal[of "{b \<in> A. b \<le> a}"] by fastforce
 
 end
 
 subsubsection \<open>Relating injectivity and surjectivity\<close>
 
 lemma finite_surj_inj:
   assumes "finite A" "A \<subseteq> f ` A"
   shows "inj_on f A"
 proof -
   have "f ` A = A"
     by (rule card_seteq [THEN sym]) (auto simp add: assms card_image_le)
   then show ?thesis using assms
     by (simp add: eq_card_imp_inj_on)
 qed
 
 lemma finite_UNIV_surj_inj: "finite(UNIV:: 'a set) \<Longrightarrow> surj f \<Longrightarrow> inj f"
   for f :: "'a \<Rightarrow> 'a"
   by (blast intro: finite_surj_inj subset_UNIV)
 
 lemma finite_UNIV_inj_surj: "finite(UNIV:: 'a set) \<Longrightarrow> inj f \<Longrightarrow> surj f"
   for f :: "'a \<Rightarrow> 'a"
   by (fastforce simp:surj_def dest!: endo_inj_surj)
 
 lemma surjective_iff_injective_gen:
   assumes fS: "finite S"
     and fT: "finite T"
     and c: "card S = card T"
     and ST: "f ` S \<subseteq> T"
   shows "(\<forall>y \<in> T. \<exists>x \<in> S. f x = y) \<longleftrightarrow> inj_on f S"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume h: "?lhs"
   {
     fix x y
     assume x: "x \<in> S"
     assume y: "y \<in> S"
     assume f: "f x = f y"
     from x fS have S0: "card S \<noteq> 0"
       by auto
     have "x = y"
     proof (rule ccontr)
       assume xy: "\<not> ?thesis"
       have th: "card S \<le> card (f ` (S - {y}))"
         unfolding c
       proof (rule card_mono)
         show "finite (f ` (S - {y}))"
           by (simp add: fS)
         have "\<lbrakk>x \<noteq> y; x \<in> S; z \<in> S; f x = f y\<rbrakk>
          \<Longrightarrow> \<exists>x \<in> S. x \<noteq> y \<and> f z = f x" for z
           by (cases "z = y \<longrightarrow> z = x") auto
         then show "T \<subseteq> f ` (S - {y})"
           using h xy x y f by fastforce
       qed
       also have " \<dots> \<le> card (S - {y})"
         by (simp add: card_image_le fS)
       also have "\<dots> \<le> card S - 1" using y fS by simp
       finally show False using S0 by arith
     qed
   }
   then show ?rhs
     unfolding inj_on_def by blast
 next
   assume h: ?rhs
   have "f ` S = T"
     by (simp add: ST c card_image card_subset_eq fT h)
   then show ?lhs by blast
 qed
 
 hide_const (open) Finite_Set.fold
 
 
 subsection \<open>Infinite Sets\<close>
 
 text \<open>
   Some elementary facts about infinite sets, mostly by Stephan Merz.
   Beware! Because "infinite" merely abbreviates a negation, these
   lemmas may not work well with \<open>blast\<close>.
 \<close>
 
 abbreviation infinite :: "'a set \<Rightarrow> bool"
   where "infinite S \<equiv> \<not> finite S"
 
 text \<open>
   Infinite sets are non-empty, and if we remove some elements from an
   infinite set, the result is still infinite.
 \<close>
 
 lemma infinite_UNIV_nat [iff]: "infinite (UNIV :: nat set)"
 proof
   assume "finite (UNIV :: nat set)"
   with finite_UNIV_inj_surj [of Suc] show False
     by simp (blast dest: Suc_neq_Zero surjD)
 qed
 
 lemma infinite_UNIV_char_0: "infinite (UNIV :: 'a::semiring_char_0 set)"
 proof
   assume "finite (UNIV :: 'a set)"
   with subset_UNIV have "finite (range of_nat :: 'a set)"
     by (rule finite_subset)
   moreover have "inj (of_nat :: nat \<Rightarrow> 'a)"
     by (simp add: inj_on_def)
   ultimately have "finite (UNIV :: nat set)"
     by (rule finite_imageD)
   then show False
     by simp
 qed
 
 lemma infinite_imp_nonempty: "infinite S \<Longrightarrow> S \<noteq> {}"
   by auto
 
 lemma infinite_remove: "infinite S \<Longrightarrow> infinite (S - {a})"
   by simp
 
 lemma Diff_infinite_finite:
   assumes "finite T" "infinite S"
   shows "infinite (S - T)"
   using \<open>finite T\<close>
 proof induct
   from \<open>infinite S\<close> show "infinite (S - {})"
     by auto
 next
   fix T x
   assume ih: "infinite (S - T)"
   have "S - (insert x T) = (S - T) - {x}"
     by (rule Diff_insert)
   with ih show "infinite (S - (insert x T))"
     by (simp add: infinite_remove)
 qed
 
 lemma Un_infinite: "infinite S \<Longrightarrow> infinite (S \<union> T)"
   by simp
 
 lemma infinite_Un: "infinite (S \<union> T) \<longleftrightarrow> infinite S \<or> infinite T"
   by simp
 
 lemma infinite_super:
   assumes "S \<subseteq> T"
     and "infinite S"
   shows "infinite T"
 proof
   assume "finite T"
   with \<open>S \<subseteq> T\<close> have "finite S" by (simp add: finite_subset)
   with \<open>infinite S\<close> show False by simp
 qed
 
 proposition infinite_coinduct [consumes 1, case_names infinite]:
   assumes "X A"
     and step: "\<And>A. X A \<Longrightarrow> \<exists>x\<in>A. X (A - {x}) \<or> infinite (A - {x})"
   shows "infinite A"
 proof
   assume "finite A"
   then show False
     using \<open>X A\<close>
   proof (induction rule: finite_psubset_induct)
     case (psubset A)
     then obtain x where "x \<in> A" "X (A - {x}) \<or> infinite (A - {x})"
       using local.step psubset.prems by blast
     then have "X (A - {x})"
       using psubset.hyps by blast
     show False
     proof (rule psubset.IH [where B = "A - {x}"])
       show "A - {x} \<subset> A"
         using \<open>x \<in> A\<close> by blast
     qed fact
   qed
 qed
 
 text \<open>
   For any function with infinite domain and finite range there is some
   element that is the image of infinitely many domain elements.  In
   particular, any infinite sequence of elements from a finite set
   contains some element that occurs infinitely often.
 \<close>
 
 lemma inf_img_fin_dom':
   assumes img: "finite (f ` A)"
     and dom: "infinite A"
   shows "\<exists>y \<in> f ` A. infinite (f -` {y} \<inter> A)"
 proof (rule ccontr)
   have "A \<subseteq> (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by auto
   moreover assume "\<not> ?thesis"
   with img have "finite (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by blast
   ultimately have "finite A" by (rule finite_subset)
   with dom show False by contradiction
 qed
 
 lemma inf_img_fin_domE':
   assumes "finite (f ` A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y} \<inter> A)"
   using assms by (blast dest: inf_img_fin_dom')
 
 lemma inf_img_fin_dom:
   assumes img: "finite (f`A)" and dom: "infinite A"
   shows "\<exists>y \<in> f`A. infinite (f -` {y})"
   using inf_img_fin_dom'[OF assms] by auto
 
 lemma inf_img_fin_domE:
   assumes "finite (f`A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y})"
   using assms by (blast dest: inf_img_fin_dom)
 
 proposition finite_image_absD: "finite (abs ` S) \<Longrightarrow> finite S"
   for S :: "'a::linordered_ring set"
   by (rule ccontr) (auto simp: abs_eq_iff vimage_def dest: inf_img_fin_dom)
 
 
 subsection \<open>The finite powerset operator\<close>
 
 definition Fpow :: "'a set \<Rightarrow> 'a set set"
 where "Fpow A \<equiv> {X. X \<subseteq> A \<and> finite X}"
 
 lemma Fpow_mono: "A \<subseteq> B \<Longrightarrow> Fpow A \<subseteq> Fpow B"
 unfolding Fpow_def by auto
 
 lemma empty_in_Fpow: "{} \<in> Fpow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_not_empty: "Fpow A \<noteq> {}"
 using empty_in_Fpow by blast
 
 lemma Fpow_subset_Pow: "Fpow A \<subseteq> Pow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_Pow_finite: "Fpow A = Pow A Int {A. finite A}"
 unfolding Fpow_def Pow_def by blast
 
 lemma inj_on_image_Fpow:
   assumes "inj_on f A"
   shows "inj_on (image f) (Fpow A)"
   using assms Fpow_subset_Pow[of A] subset_inj_on[of "image f" "Pow A"]
     inj_on_image_Pow by blast
 
 lemma image_Fpow_mono:
   assumes "f ` A \<subseteq> B"
   shows "(image f) ` (Fpow A) \<subseteq> Fpow B"
   using assms by(unfold Fpow_def, auto)
 
 end
diff --git a/src/HOL/Library/Multiset.thy b/src/HOL/Library/Multiset.thy
--- a/src/HOL/Library/Multiset.thy
+++ b/src/HOL/Library/Multiset.thy
@@ -1,4535 +1,4739 @@
 (*  Title:      HOL/Library/Multiset.thy
     Author:     Tobias Nipkow, Markus Wenzel, Lawrence C Paulson, Norbert Voelker
     Author:     Andrei Popescu, TU Muenchen
     Author:     Jasmin Blanchette, Inria, LORIA, MPII
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Mathias Fleury, MPII
     Author:     Martin Desharnais, MPI-INF Saarbruecken
 *)
 
 section \<open>(Finite) Multisets\<close>
 
 theory Multiset
   imports Cancellation
 begin
 
 subsection \<open>The type of multisets\<close>
 
 typedef 'a multiset = \<open>{f :: 'a \<Rightarrow> nat. finite {x. f x > 0}}\<close>
   morphisms count Abs_multiset
 proof
   show \<open>(\<lambda>x. 0::nat) \<in> {f. finite {x. f x > 0}}\<close>
     by simp
 qed
 
 setup_lifting type_definition_multiset
 
 lemma count_Abs_multiset:
   \<open>count (Abs_multiset f) = f\<close> if \<open>finite {x. f x > 0}\<close>
   by (rule Abs_multiset_inverse) (simp add: that)
 
 lemma multiset_eq_iff: "M = N \<longleftrightarrow> (\<forall>a. count M a = count N a)"
   by (simp only: count_inject [symmetric] fun_eq_iff)
 
 lemma multiset_eqI: "(\<And>x. count A x = count B x) \<Longrightarrow> A = B"
   using multiset_eq_iff by auto
 
 text \<open>Preservation of the representing set \<^term>\<open>multiset\<close>.\<close>
 
 lemma diff_preserves_multiset:
   \<open>finite {x. 0 < M x - N x}\<close> if \<open>finite {x. 0 < M x}\<close> for M N :: \<open>'a \<Rightarrow> nat\<close>
   using that by (rule rev_finite_subset) auto
 
 lemma filter_preserves_multiset:
   \<open>finite {x. 0 < (if P x then M x else 0)}\<close> if \<open>finite {x. 0 < M x}\<close> for M N :: \<open>'a \<Rightarrow> nat\<close>
   using that by (rule rev_finite_subset) auto
 
 lemmas in_multiset = diff_preserves_multiset filter_preserves_multiset
 
 
 subsection \<open>Representing multisets\<close>
 
 text \<open>Multiset enumeration\<close>
 
 instantiation multiset :: (type) cancel_comm_monoid_add
 begin
 
 lift_definition zero_multiset :: \<open>'a multiset\<close>
   is \<open>\<lambda>a. 0\<close>
   by simp
 
 abbreviation empty_mset :: \<open>'a multiset\<close> (\<open>{#}\<close>)
   where \<open>empty_mset \<equiv> 0\<close>
 
 lift_definition plus_multiset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>
   is \<open>\<lambda>M N a. M a + N a\<close>
   by simp
 
 lift_definition minus_multiset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>
   is \<open>\<lambda>M N a. M a - N a\<close>
   by (rule diff_preserves_multiset)
 
 instance
   by (standard; transfer) (simp_all add: fun_eq_iff)
 
 end
 
 context
 begin
 
 qualified definition is_empty :: "'a multiset \<Rightarrow> bool" where
   [code_abbrev]: "is_empty A \<longleftrightarrow> A = {#}"
 
 end
 
 lemma add_mset_in_multiset:
   \<open>finite {x. 0 < (if x = a then Suc (M x) else M x)}\<close>
   if \<open>finite {x. 0 < M x}\<close>
   using that by (simp add: flip: insert_Collect)
 
 lift_definition add_mset :: "'a \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" is
   "\<lambda>a M b. if b = a then Suc (M b) else M b"
 by (rule add_mset_in_multiset)
 
 syntax
   "_multiset" :: "args \<Rightarrow> 'a multiset"    ("{#(_)#}")
 translations
   "{#x, xs#}" == "CONST add_mset x {#xs#}"
   "{#x#}" == "CONST add_mset x {#}"
 
 lemma count_empty [simp]: "count {#} a = 0"
   by (simp add: zero_multiset.rep_eq)
 
 lemma count_add_mset [simp]:
   "count (add_mset b A) a = (if b = a then Suc (count A a) else count A a)"
   by (simp add: add_mset.rep_eq)
 
 lemma count_single: "count {#b#} a = (if b = a then 1 else 0)"
   by simp
 
 lemma
   add_mset_not_empty [simp]: \<open>add_mset a A \<noteq> {#}\<close> and
   empty_not_add_mset [simp]: "{#} \<noteq> add_mset a A"
   by (auto simp: multiset_eq_iff)
 
 lemma add_mset_add_mset_same_iff [simp]:
   "add_mset a A = add_mset a B \<longleftrightarrow> A = B"
   by (auto simp: multiset_eq_iff)
 
 lemma add_mset_commute:
   "add_mset x (add_mset y M) = add_mset y (add_mset x M)"
   by (auto simp: multiset_eq_iff)
 
 
 subsection \<open>Basic operations\<close>
 
 subsubsection \<open>Conversion to set and membership\<close>
 
 definition set_mset :: \<open>'a multiset \<Rightarrow> 'a set\<close>
   where \<open>set_mset M = {x. count M x > 0}\<close>
 
 abbreviation member_mset :: \<open>'a \<Rightarrow> 'a multiset \<Rightarrow> bool\<close>
   where \<open>member_mset a M \<equiv> a \<in> set_mset M\<close>
 
 notation
   member_mset  (\<open>'(\<in>#')\<close>) and
   member_mset  (\<open>(_/ \<in># _)\<close> [50, 51] 50)
 
 notation  (ASCII)
   member_mset  (\<open>'(:#')\<close>) and
   member_mset  (\<open>(_/ :# _)\<close> [50, 51] 50)
 
 abbreviation not_member_mset :: \<open>'a \<Rightarrow> 'a multiset \<Rightarrow> bool\<close>
   where \<open>not_member_mset a M \<equiv> a \<notin> set_mset M\<close>
 
 notation
   not_member_mset  (\<open>'(\<notin>#')\<close>) and
   not_member_mset  (\<open>(_/ \<notin># _)\<close> [50, 51] 50)
 
 notation  (ASCII)
   not_member_mset  (\<open>'(~:#')\<close>) and
   not_member_mset  (\<open>(_/ ~:# _)\<close> [50, 51] 50)
 
 context
 begin
 
 qualified abbreviation Ball :: "'a multiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Ball M \<equiv> Set.Ball (set_mset M)"
 
 qualified abbreviation Bex :: "'a multiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Bex M \<equiv> Set.Bex (set_mset M)"
 
 end
 
 syntax
   "_MBall"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>_\<in>#_./ _)" [0, 0, 10] 10)
   "_MBex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>_\<in>#_./ _)" [0, 0, 10] 10)
 
 syntax  (ASCII)
   "_MBall"       :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<forall>_:#_./ _)" [0, 0, 10] 10)
   "_MBex"        :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool"      ("(3\<exists>_:#_./ _)" [0, 0, 10] 10)
 
 translations
   "\<forall>x\<in>#A. P" \<rightleftharpoons> "CONST Multiset.Ball A (\<lambda>x. P)"
   "\<exists>x\<in>#A. P" \<rightleftharpoons> "CONST Multiset.Bex A (\<lambda>x. P)"
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>Multiset.Ball\<close> \<^syntax_const>\<open>_MBall\<close>,
   Syntax_Trans.preserve_binder_abs2_tr' \<^const_syntax>\<open>Multiset.Bex\<close> \<^syntax_const>\<open>_MBex\<close>]
 \<close> \<comment> \<open>to avoid eta-contraction of body\<close>
 
 lemma count_eq_zero_iff:
   "count M x = 0 \<longleftrightarrow> x \<notin># M"
   by (auto simp add: set_mset_def)
 
 lemma not_in_iff:
   "x \<notin># M \<longleftrightarrow> count M x = 0"
   by (auto simp add: count_eq_zero_iff)
 
 lemma count_greater_zero_iff [simp]:
   "count M x > 0 \<longleftrightarrow> x \<in># M"
   by (auto simp add: set_mset_def)
 
 lemma count_inI:
   assumes "count M x = 0 \<Longrightarrow> False"
   shows "x \<in># M"
 proof (rule ccontr)
   assume "x \<notin># M"
   with assms show False by (simp add: not_in_iff)
 qed
 
 lemma in_countE:
   assumes "x \<in># M"
   obtains n where "count M x = Suc n"
 proof -
   from assms have "count M x > 0" by simp
   then obtain n where "count M x = Suc n"
     using gr0_conv_Suc by blast
   with that show thesis .
 qed
 
 lemma count_greater_eq_Suc_zero_iff [simp]:
   "count M x \<ge> Suc 0 \<longleftrightarrow> x \<in># M"
   by (simp add: Suc_le_eq)
 
 lemma count_greater_eq_one_iff [simp]:
   "count M x \<ge> 1 \<longleftrightarrow> x \<in># M"
   by simp
 
 lemma set_mset_empty [simp]:
   "set_mset {#} = {}"
   by (simp add: set_mset_def)
 
 lemma set_mset_single:
   "set_mset {#b#} = {b}"
   by (simp add: set_mset_def)
 
 lemma set_mset_eq_empty_iff [simp]:
   "set_mset M = {} \<longleftrightarrow> M = {#}"
   by (auto simp add: multiset_eq_iff count_eq_zero_iff)
 
 lemma finite_set_mset [iff]:
   "finite (set_mset M)"
   using count [of M] by simp
 
 lemma set_mset_add_mset_insert [simp]: \<open>set_mset (add_mset a A) = insert a (set_mset A)\<close>
   by (auto simp flip: count_greater_eq_Suc_zero_iff split: if_splits)
 
 lemma multiset_nonemptyE [elim]:
   assumes "A \<noteq> {#}"
   obtains x where "x \<in># A"
 proof -
   have "\<exists>x. x \<in># A" by (rule ccontr) (insert assms, auto)
   with that show ?thesis by blast
 qed
 
+lemma count_gt_imp_in_mset: "count M x > n \<Longrightarrow> x \<in># M"
+  using count_greater_zero_iff by fastforce
+
 
 subsubsection \<open>Union\<close>
 
 lemma count_union [simp]:
   "count (M + N) a = count M a + count N a"
   by (simp add: plus_multiset.rep_eq)
 
 lemma set_mset_union [simp]:
   "set_mset (M + N) = set_mset M \<union> set_mset N"
   by (simp only: set_eq_iff count_greater_zero_iff [symmetric] count_union) simp
 
 lemma union_mset_add_mset_left [simp]:
   "add_mset a A + B = add_mset a (A + B)"
   by (auto simp: multiset_eq_iff)
 
 lemma union_mset_add_mset_right [simp]:
   "A + add_mset a B = add_mset a (A + B)"
   by (auto simp: multiset_eq_iff)
 
 lemma add_mset_add_single: \<open>add_mset a A = A + {#a#}\<close>
   by (subst union_mset_add_mset_right, subst add.comm_neutral) standard
 
 
 subsubsection \<open>Difference\<close>
 
 instance multiset :: (type) comm_monoid_diff
   by standard (transfer; simp add: fun_eq_iff)
 
 lemma count_diff [simp]:
   "count (M - N) a = count M a - count N a"
   by (simp add: minus_multiset.rep_eq)
 
 lemma add_mset_diff_bothsides:
   \<open>add_mset a M - add_mset a A = M - A\<close>
   by (auto simp: multiset_eq_iff)
 
 lemma in_diff_count:
   "a \<in># M - N \<longleftrightarrow> count N a < count M a"
   by (simp add: set_mset_def)
 
 lemma count_in_diffI:
   assumes "\<And>n. count N x = n + count M x \<Longrightarrow> False"
   shows "x \<in># M - N"
 proof (rule ccontr)
   assume "x \<notin># M - N"
   then have "count N x = (count N x - count M x) + count M x"
     by (simp add: in_diff_count not_less)
   with assms show False by auto
 qed
 
 lemma in_diff_countE:
   assumes "x \<in># M - N"
   obtains n where "count M x = Suc n + count N x"
 proof -
   from assms have "count M x - count N x > 0" by (simp add: in_diff_count)
   then have "count M x > count N x" by simp
   then obtain n where "count M x = Suc n + count N x"
     using less_iff_Suc_add by auto
   with that show thesis .
 qed
 
 lemma in_diffD:
   assumes "a \<in># M - N"
   shows "a \<in># M"
 proof -
   have "0 \<le> count N a" by simp
   also from assms have "count N a < count M a"
     by (simp add: in_diff_count)
   finally show ?thesis by simp
 qed
 
 lemma set_mset_diff:
   "set_mset (M - N) = {a. count N a < count M a}"
   by (simp add: set_mset_def)
 
 lemma diff_empty [simp]: "M - {#} = M \<and> {#} - M = {#}"
   by rule (fact Groups.diff_zero, fact Groups.zero_diff)
 
 lemma diff_cancel: "A - A = {#}"
   by (fact Groups.diff_cancel)
 
 lemma diff_union_cancelR: "M + N - N = (M::'a multiset)"
   by (fact add_diff_cancel_right')
 
 lemma diff_union_cancelL: "N + M - N = (M::'a multiset)"
   by (fact add_diff_cancel_left')
 
 lemma diff_right_commute:
   fixes M N Q :: "'a multiset"
   shows "M - N - Q = M - Q - N"
   by (fact diff_right_commute)
 
 lemma diff_add:
   fixes M N Q :: "'a multiset"
   shows "M - (N + Q) = M - N - Q"
   by (rule sym) (fact diff_diff_add)
 
 lemma insert_DiffM [simp]: "x \<in># M \<Longrightarrow> add_mset x (M - {#x#}) = M"
   by (clarsimp simp: multiset_eq_iff)
 
 lemma insert_DiffM2: "x \<in># M \<Longrightarrow> (M - {#x#}) + {#x#} = M"
   by simp
 
 lemma diff_union_swap: "a \<noteq> b \<Longrightarrow> add_mset b (M - {#a#}) = add_mset b M - {#a#}"
   by (auto simp add: multiset_eq_iff)
 
 lemma diff_add_mset_swap [simp]: "b \<notin># A \<Longrightarrow> add_mset b M - A = add_mset b (M - A)"
   by (auto simp add: multiset_eq_iff simp: not_in_iff)
 
 lemma diff_union_swap2 [simp]: "y \<in># M \<Longrightarrow> add_mset x M - {#y#} = add_mset x (M - {#y#})"
   by (metis add_mset_diff_bothsides diff_union_swap diff_zero insert_DiffM)
 
 lemma diff_diff_add_mset [simp]: "(M::'a multiset) - N - P = M - (N + P)"
   by (rule diff_diff_add)
 
 lemma diff_union_single_conv:
   "a \<in># J \<Longrightarrow> I + J - {#a#} = I + (J - {#a#})"
   by (simp add: multiset_eq_iff Suc_le_eq)
 
 lemma mset_add [elim?]:
   assumes "a \<in># A"
   obtains B where "A = add_mset a B"
 proof -
   from assms have "A = add_mset a (A - {#a#})"
     by simp
   with that show thesis .
 qed
 
 lemma union_iff:
   "a \<in># A + B \<longleftrightarrow> a \<in># A \<or> a \<in># B"
   by auto
 
 lemma count_minus_inter_lt_count_minus_inter_iff:
   "count (M2 - M1) y < count (M1 - M2) y \<longleftrightarrow> y \<in># M1 - M2"
   by (meson count_greater_zero_iff gr_implies_not_zero in_diff_count leI order.strict_trans2
       order_less_asym)
 
 lemma minus_inter_eq_minus_inter_iff:
   "(M1 - M2) = (M2 - M1) \<longleftrightarrow> set_mset (M1 - M2) = set_mset (M2 - M1)"
   by (metis add.commute count_diff count_eq_zero_iff diff_add_zero in_diff_countE multiset_eq_iff)
 
 
 subsubsection \<open>Min and Max\<close>
 
 abbreviation Min_mset :: "'a::linorder multiset \<Rightarrow> 'a" where
 "Min_mset m \<equiv> Min (set_mset m)"
 
 abbreviation Max_mset :: "'a::linorder multiset \<Rightarrow> 'a" where
 "Max_mset m \<equiv> Max (set_mset m)"
 
+lemma
+  Min_in_mset: "M \<noteq> {#} \<Longrightarrow> Min_mset M \<in># M" and
+  Max_in_mset: "M \<noteq> {#} \<Longrightarrow> Max_mset M \<in># M"
+  by simp+
+
 
 subsubsection \<open>Equality of multisets\<close>
 
 lemma single_eq_single [simp]: "{#a#} = {#b#} \<longleftrightarrow> a = b"
   by (auto simp add: multiset_eq_iff)
 
 lemma union_eq_empty [iff]: "M + N = {#} \<longleftrightarrow> M = {#} \<and> N = {#}"
   by (auto simp add: multiset_eq_iff)
 
 lemma empty_eq_union [iff]: "{#} = M + N \<longleftrightarrow> M = {#} \<and> N = {#}"
   by (auto simp add: multiset_eq_iff)
 
 lemma multi_self_add_other_not_self [simp]: "M = add_mset x M \<longleftrightarrow> False"
   by (auto simp add: multiset_eq_iff)
 
 lemma add_mset_remove_trivial [simp]: \<open>add_mset x M - {#x#} = M\<close>
   by (auto simp: multiset_eq_iff)
 
 lemma diff_single_trivial: "\<not> x \<in># M \<Longrightarrow> M - {#x#} = M"
   by (auto simp add: multiset_eq_iff not_in_iff)
 
 lemma diff_single_eq_union: "x \<in># M \<Longrightarrow> M - {#x#} = N \<longleftrightarrow> M = add_mset x N"
   by auto
 
 lemma union_single_eq_diff: "add_mset x M = N \<Longrightarrow> M = N - {#x#}"
   unfolding add_mset_add_single[of _ M] by (fact add_implies_diff)
 
 lemma union_single_eq_member: "add_mset x M = N \<Longrightarrow> x \<in># N"
   by auto
 
 lemma add_mset_remove_trivial_If:
   "add_mset a (N - {#a#}) = (if a \<in># N then N else add_mset a N)"
   by (simp add: diff_single_trivial)
 
 lemma add_mset_remove_trivial_eq: \<open>N = add_mset a (N - {#a#}) \<longleftrightarrow> a \<in># N\<close>
   by (auto simp: add_mset_remove_trivial_If)
 
 lemma union_is_single:
   "M + N = {#a#} \<longleftrightarrow> M = {#a#} \<and> N = {#} \<or> M = {#} \<and> N = {#a#}"
   (is "?lhs = ?rhs")
 proof
   show ?lhs if ?rhs using that by auto
   show ?rhs if ?lhs
     by (metis Multiset.diff_cancel add.commute add_diff_cancel_left' diff_add_zero diff_single_trivial insert_DiffM that)
 qed
 
 lemma single_is_union: "{#a#} = M + N \<longleftrightarrow> {#a#} = M \<and> N = {#} \<or> M = {#} \<and> {#a#} = N"
   by (auto simp add: eq_commute [of "{#a#}" "M + N"] union_is_single)
 
 lemma add_eq_conv_diff:
   "add_mset a M = add_mset b N \<longleftrightarrow> M = N \<and> a = b \<or> M = add_mset b (N - {#a#}) \<and> N = add_mset a (M - {#b#})"
   (is "?lhs \<longleftrightarrow> ?rhs")
 (* shorter: by (simp add: multiset_eq_iff) fastforce *)
 proof
   show ?lhs if ?rhs
     using that
     by (auto simp add: add_mset_commute[of a b])
   show ?rhs if ?lhs
   proof (cases "a = b")
     case True with \<open>?lhs\<close> show ?thesis by simp
   next
     case False
     from \<open>?lhs\<close> have "a \<in># add_mset b N" by (rule union_single_eq_member)
     with False have "a \<in># N" by auto
     moreover from \<open>?lhs\<close> have "M = add_mset b N - {#a#}" by (rule union_single_eq_diff)
     moreover note False
     ultimately show ?thesis by (auto simp add: diff_right_commute [of _ "{#a#}"])
   qed
 qed
 
 lemma add_mset_eq_single [iff]: "add_mset b M = {#a#} \<longleftrightarrow> b = a \<and> M = {#}"
   by (auto simp: add_eq_conv_diff)
 
 lemma single_eq_add_mset [iff]: "{#a#} = add_mset b M \<longleftrightarrow> b = a \<and> M = {#}"
   by (auto simp: add_eq_conv_diff)
 
 lemma insert_noteq_member:
   assumes BC: "add_mset b B = add_mset c C"
    and bnotc: "b \<noteq> c"
   shows "c \<in># B"
 proof -
   have "c \<in># add_mset c C" by simp
   have nc: "\<not> c \<in># {#b#}" using bnotc by simp
   then have "c \<in># add_mset b B" using BC by simp
   then show "c \<in># B" using nc by simp
 qed
 
 lemma add_eq_conv_ex:
   "(add_mset a M = add_mset b N) =
     (M = N \<and> a = b \<or> (\<exists>K. M = add_mset b K \<and> N = add_mset a K))"
   by (auto simp add: add_eq_conv_diff)
 
 lemma multi_member_split: "x \<in># M \<Longrightarrow> \<exists>A. M = add_mset x A"
   by (rule exI [where x = "M - {#x#}"]) simp
 
 lemma multiset_add_sub_el_shuffle:
   assumes "c \<in># B"
     and "b \<noteq> c"
   shows "add_mset b (B - {#c#}) = add_mset b B - {#c#}"
 proof -
   from \<open>c \<in># B\<close> obtain A where B: "B = add_mset c A"
     by (blast dest: multi_member_split)
   have "add_mset b A = add_mset c (add_mset b A) - {#c#}" by simp
   then have "add_mset b A = add_mset b (add_mset c A) - {#c#}"
     by (simp add: \<open>b \<noteq> c\<close>)
   then show ?thesis using B by simp
 qed
 
 lemma add_mset_eq_singleton_iff[iff]:
   "add_mset x M = {#y#} \<longleftrightarrow> M = {#} \<and> x = y"
   by auto
 
 
 subsubsection \<open>Pointwise ordering induced by count\<close>
 
 definition subseteq_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"  (infix "\<subseteq>#" 50)
   where "A \<subseteq># B \<longleftrightarrow> (\<forall>a. count A a \<le> count B a)"
 
 definition subset_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" (infix "\<subset>#" 50)
   where "A \<subset># B \<longleftrightarrow> A \<subseteq># B \<and> A \<noteq> B"
 
 abbreviation (input) supseteq_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"  (infix "\<supseteq>#" 50)
   where "supseteq_mset A B \<equiv> B \<subseteq># A"
 
 abbreviation (input) supset_mset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"  (infix "\<supset>#" 50)
   where "supset_mset A B \<equiv> B \<subset># A"
 
 notation (input)
   subseteq_mset  (infix "\<le>#" 50) and
   supseteq_mset  (infix "\<ge>#" 50)
 
 notation (ASCII)
   subseteq_mset  (infix "<=#" 50) and
   subset_mset  (infix "<#" 50) and
   supseteq_mset  (infix ">=#" 50) and
   supset_mset  (infix ">#" 50)
 
 global_interpretation subset_mset: ordering \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (auto simp add: subset_mset_def subseteq_mset_def multiset_eq_iff intro: order.trans order.antisym)
 
 interpretation subset_mset: ordered_ab_semigroup_add_imp_le \<open>(+)\<close> \<open>(-)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (auto simp add: subset_mset_def subseteq_mset_def multiset_eq_iff intro: order_trans antisym)
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 interpretation subset_mset: ordered_ab_semigroup_monoid_add_imp_le "(+)" 0 "(-)" "(\<subseteq>#)" "(\<subset>#)"
   by standard
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 lemma mset_subset_eqI:
   "(\<And>a. count A a \<le> count B a) \<Longrightarrow> A \<subseteq># B"
   by (simp add: subseteq_mset_def)
 
 lemma mset_subset_eq_count:
   "A \<subseteq># B \<Longrightarrow> count A a \<le> count B a"
   by (simp add: subseteq_mset_def)
 
 lemma mset_subset_eq_exists_conv: "(A::'a multiset) \<subseteq># B \<longleftrightarrow> (\<exists>C. B = A + C)"
   unfolding subseteq_mset_def
   apply (rule iffI)
    apply (rule exI [where x = "B - A"])
    apply (auto intro: multiset_eq_iff [THEN iffD2])
   done
 
 interpretation subset_mset: ordered_cancel_comm_monoid_diff "(+)" 0 "(\<subseteq>#)" "(\<subset>#)" "(-)"
   by standard (simp, fact mset_subset_eq_exists_conv)
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 declare subset_mset.add_diff_assoc[simp] subset_mset.add_diff_assoc2[simp]
 
 lemma mset_subset_eq_mono_add_right_cancel: "(A::'a multiset) + C \<subseteq># B + C \<longleftrightarrow> A \<subseteq># B"
    by (fact subset_mset.add_le_cancel_right)
 
 lemma mset_subset_eq_mono_add_left_cancel: "C + (A::'a multiset) \<subseteq># C + B \<longleftrightarrow> A \<subseteq># B"
    by (fact subset_mset.add_le_cancel_left)
 
 lemma mset_subset_eq_mono_add: "(A::'a multiset) \<subseteq># B \<Longrightarrow> C \<subseteq># D \<Longrightarrow> A + C \<subseteq># B + D"
    by (fact subset_mset.add_mono)
 
 lemma mset_subset_eq_add_left: "(A::'a multiset) \<subseteq># A + B"
    by simp
 
 lemma mset_subset_eq_add_right: "B \<subseteq># (A::'a multiset) + B"
    by simp
 
 lemma single_subset_iff [simp]:
   "{#a#} \<subseteq># M \<longleftrightarrow> a \<in># M"
   by (auto simp add: subseteq_mset_def Suc_le_eq)
 
 lemma mset_subset_eq_single: "a \<in># B \<Longrightarrow> {#a#} \<subseteq># B"
   by simp
 
 lemma mset_subset_eq_add_mset_cancel: \<open>add_mset a A \<subseteq># add_mset a B \<longleftrightarrow> A \<subseteq># B\<close>
   unfolding add_mset_add_single[of _ A] add_mset_add_single[of _ B]
   by (rule mset_subset_eq_mono_add_right_cancel)
 
 lemma multiset_diff_union_assoc:
   fixes A B C D :: "'a multiset"
   shows "C \<subseteq># B \<Longrightarrow> A + B - C = A + (B - C)"
   by (fact subset_mset.diff_add_assoc)
 
 lemma mset_subset_eq_multiset_union_diff_commute:
   fixes A B C D :: "'a multiset"
   shows "B \<subseteq># A \<Longrightarrow> A - B + C = A + C - B"
   by (fact subset_mset.add_diff_assoc2)
 
 lemma diff_subset_eq_self[simp]:
   "(M::'a multiset) - N \<subseteq># M"
   by (simp add: subseteq_mset_def)
 
 lemma mset_subset_eqD:
   assumes "A \<subseteq># B" and "x \<in># A"
   shows "x \<in># B"
 proof -
   from \<open>x \<in># A\<close> have "count A x > 0" by simp
   also from \<open>A \<subseteq># B\<close> have "count A x \<le> count B x"
     by (simp add: subseteq_mset_def)
   finally show ?thesis by simp
 qed
 
 lemma mset_subsetD:
   "A \<subset># B \<Longrightarrow> x \<in># A \<Longrightarrow> x \<in># B"
   by (auto intro: mset_subset_eqD [of A])
 
 lemma set_mset_mono:
   "A \<subseteq># B \<Longrightarrow> set_mset A \<subseteq> set_mset B"
   by (metis mset_subset_eqD subsetI)
 
 lemma mset_subset_eq_insertD:
   "add_mset x A \<subseteq># B \<Longrightarrow> x \<in># B \<and> A \<subset># B"
 apply (rule conjI)
  apply (simp add: mset_subset_eqD)
  apply (clarsimp simp: subset_mset_def subseteq_mset_def)
  apply safe
   apply (erule_tac x = a in allE)
   apply (auto split: if_split_asm)
 done
 
 lemma mset_subset_insertD:
   "add_mset x A \<subset># B \<Longrightarrow> x \<in># B \<and> A \<subset># B"
   by (rule mset_subset_eq_insertD) simp
 
 lemma mset_subset_of_empty[simp]: "A \<subset># {#} \<longleftrightarrow> False"
   by (simp only: subset_mset.not_less_zero)
 
 lemma empty_subset_add_mset[simp]: "{#} \<subset># add_mset x M"
   by (auto intro: subset_mset.gr_zeroI)
 
 lemma empty_le: "{#} \<subseteq># A"
   by (fact subset_mset.zero_le)
 
 lemma insert_subset_eq_iff:
   "add_mset a A \<subseteq># B \<longleftrightarrow> a \<in># B \<and> A \<subseteq># B - {#a#}"
   using le_diff_conv2 [of "Suc 0" "count B a" "count A a"]
   apply (auto simp add: subseteq_mset_def not_in_iff Suc_le_eq)
   apply (rule ccontr)
   apply (auto simp add: not_in_iff)
   done
 
 lemma insert_union_subset_iff:
   "add_mset a A \<subset># B \<longleftrightarrow> a \<in># B \<and> A \<subset># B - {#a#}"
   by (auto simp add: insert_subset_eq_iff subset_mset_def)
 
 lemma subset_eq_diff_conv:
   "A - C \<subseteq># B \<longleftrightarrow> A \<subseteq># B + C"
   by (simp add: subseteq_mset_def le_diff_conv)
 
 lemma multi_psub_of_add_self [simp]: "A \<subset># add_mset x A"
   by (auto simp: subset_mset_def subseteq_mset_def)
 
 lemma multi_psub_self: "A \<subset># A = False"
   by simp
 
 lemma mset_subset_add_mset [simp]: "add_mset x N \<subset># add_mset x M \<longleftrightarrow> N \<subset># M"
   unfolding add_mset_add_single[of _ N] add_mset_add_single[of _ M]
   by (fact subset_mset.add_less_cancel_right)
 
 lemma mset_subset_diff_self: "c \<in># B \<Longrightarrow> B - {#c#} \<subset># B"
   by (auto simp: subset_mset_def elim: mset_add)
 
 lemma Diff_eq_empty_iff_mset: "A - B = {#} \<longleftrightarrow> A \<subseteq># B"
   by (auto simp: multiset_eq_iff subseteq_mset_def)
 
 lemma add_mset_subseteq_single_iff[iff]: "add_mset a M \<subseteq># {#b#} \<longleftrightarrow> M = {#} \<and> a = b"
 proof
   assume A: "add_mset a M \<subseteq># {#b#}"
   then have \<open>a = b\<close>
     by (auto dest: mset_subset_eq_insertD)
   then show "M={#} \<and> a=b"
     using A by (simp add: mset_subset_eq_add_mset_cancel)
 qed simp
 
+lemma nonempty_subseteq_mset_eq_single: "M \<noteq> {#} \<Longrightarrow> M \<subseteq># {#x#} \<Longrightarrow> M = {#x#}"
+  by (cases M) (metis single_is_union subset_mset.less_eqE)
+
+lemma nonempty_subseteq_mset_iff_single: "(M \<noteq> {#} \<and> M \<subseteq># {#x#} \<and> P) \<longleftrightarrow> M = {#x#} \<and> P"
+  by (cases M) (metis empty_not_add_mset nonempty_subseteq_mset_eq_single subset_mset.order_refl)
+
 
 subsubsection \<open>Intersection and bounded union\<close>
 
 definition inter_mset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>  (infixl \<open>\<inter>#\<close> 70)
   where \<open>A \<inter># B = A - (A - B)\<close>
 
 lemma count_inter_mset [simp]:
   \<open>count (A \<inter># B) x = min (count A x) (count B x)\<close>
   by (simp add: inter_mset_def)
 
 (*global_interpretation subset_mset: semilattice_order \<open>(\<inter>#)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (simp_all add: multiset_eq_iff subseteq_mset_def subset_mset_def min_def)*)
 
 interpretation subset_mset: semilattice_inf \<open>(\<inter>#)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
   by standard (simp_all add: multiset_eq_iff subseteq_mset_def)
   \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 definition union_mset :: \<open>'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>  (infixl \<open>\<union>#\<close> 70)
   where \<open>A \<union># B = A + (B - A)\<close>
 
 lemma count_union_mset [simp]:
   \<open>count (A \<union># B) x = max (count A x) (count B x)\<close>
   by (simp add: union_mset_def)
 
 global_interpretation subset_mset: semilattice_neutr_order \<open>(\<union>#)\<close> \<open>{#}\<close> \<open>(\<supseteq>#)\<close> \<open>(\<supset>#)\<close>
   apply standard
       apply (simp_all add: multiset_eq_iff subseteq_mset_def subset_mset_def max_def)
    apply (auto simp add: le_antisym dest: sym)
    apply (metis nat_le_linear)+
   done
 
 interpretation subset_mset: semilattice_sup \<open>(\<union>#)\<close> \<open>(\<subseteq>#)\<close> \<open>(\<subset>#)\<close>
 proof -
   have [simp]: "m \<le> n \<Longrightarrow> q \<le> n \<Longrightarrow> m + (q - m) \<le> n" for m n q :: nat
     by arith
   show "class.semilattice_sup (\<union>#) (\<subseteq>#) (\<subset>#)"
     by standard (auto simp add: union_mset_def subseteq_mset_def)
 qed \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 interpretation subset_mset: bounded_lattice_bot "(\<inter>#)" "(\<subseteq>#)" "(\<subset>#)"
   "(\<union>#)" "{#}"
   by standard auto
     \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 
 subsubsection \<open>Additional intersection facts\<close>
 
 lemma set_mset_inter [simp]:
   "set_mset (A \<inter># B) = set_mset A \<inter> set_mset B"
   by (simp only: set_mset_def) auto
 
 lemma diff_intersect_left_idem [simp]:
   "M - M \<inter># N = M - N"
   by (simp add: multiset_eq_iff min_def)
 
 lemma diff_intersect_right_idem [simp]:
   "M - N \<inter># M = M - N"
   by (simp add: multiset_eq_iff min_def)
 
 lemma multiset_inter_single[simp]: "a \<noteq> b \<Longrightarrow> {#a#} \<inter># {#b#} = {#}"
   by (rule multiset_eqI) auto
 
 lemma multiset_union_diff_commute:
   assumes "B \<inter># C = {#}"
   shows "A + B - C = A - C + B"
 proof (rule multiset_eqI)
   fix x
   from assms have "min (count B x) (count C x) = 0"
     by (auto simp add: multiset_eq_iff)
   then have "count B x = 0 \<or> count C x = 0"
     unfolding min_def by (auto split: if_splits)
   then show "count (A + B - C) x = count (A - C + B) x"
     by auto
 qed
 
 lemma disjunct_not_in:
   "A \<inter># B = {#} \<longleftrightarrow> (\<forall>a. a \<notin># A \<or> a \<notin># B)" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   show ?Q
   proof
     fix a
     from \<open>?P\<close> have "min (count A a) (count B a) = 0"
       by (simp add: multiset_eq_iff)
     then have "count A a = 0 \<or> count B a = 0"
       by (cases "count A a \<le> count B a") (simp_all add: min_def)
     then show "a \<notin># A \<or> a \<notin># B"
       by (simp add: not_in_iff)
   qed
 next
   assume ?Q
   show ?P
   proof (rule multiset_eqI)
     fix a
     from \<open>?Q\<close> have "count A a = 0 \<or> count B a = 0"
       by (auto simp add: not_in_iff)
     then show "count (A \<inter># B) a = count {#} a"
       by auto
   qed
 qed
 
 lemma inter_mset_empty_distrib_right: "A \<inter># (B + C) = {#} \<longleftrightarrow> A \<inter># B = {#} \<and> A \<inter># C = {#}"
   by (meson disjunct_not_in union_iff)
 
 lemma inter_mset_empty_distrib_left: "(A + B) \<inter># C = {#} \<longleftrightarrow> A \<inter># C = {#} \<and> B \<inter># C = {#}"
   by (meson disjunct_not_in union_iff)
 
 lemma add_mset_inter_add_mset [simp]:
   "add_mset a A \<inter># add_mset a B = add_mset a (A \<inter># B)"
   by (rule multiset_eqI) simp
 
 lemma add_mset_disjoint [simp]:
   "add_mset a A \<inter># B = {#} \<longleftrightarrow> a \<notin># B \<and> A \<inter># B = {#}"
   "{#} = add_mset a A \<inter># B \<longleftrightarrow> a \<notin># B \<and> {#} = A \<inter># B"
   by (auto simp: disjunct_not_in)
 
 lemma disjoint_add_mset [simp]:
   "B \<inter># add_mset a A = {#} \<longleftrightarrow> a \<notin># B \<and> B \<inter># A = {#}"
   "{#} = A \<inter># add_mset b B \<longleftrightarrow> b \<notin># A \<and> {#} = A \<inter># B"
   by (auto simp: disjunct_not_in)
 
 lemma inter_add_left1: "\<not> x \<in># N \<Longrightarrow> (add_mset x M) \<inter># N = M \<inter># N"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma inter_add_left2: "x \<in># N \<Longrightarrow> (add_mset x M) \<inter># N = add_mset x (M \<inter># (N - {#x#}))"
   by (auto simp add: multiset_eq_iff elim: mset_add)
 
 lemma inter_add_right1: "\<not> x \<in># N \<Longrightarrow> N \<inter># (add_mset x M) = N \<inter># M"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma inter_add_right2: "x \<in># N \<Longrightarrow> N \<inter># (add_mset x M) = add_mset x ((N - {#x#}) \<inter># M)"
   by (auto simp add: multiset_eq_iff elim: mset_add)
 
 lemma disjunct_set_mset_diff:
   assumes "M \<inter># N = {#}"
   shows "set_mset (M - N) = set_mset M"
 proof (rule set_eqI)
   fix a
   from assms have "a \<notin># M \<or> a \<notin># N"
     by (simp add: disjunct_not_in)
   then show "a \<in># M - N \<longleftrightarrow> a \<in># M"
     by (auto dest: in_diffD) (simp add: in_diff_count not_in_iff)
 qed
 
 lemma at_most_one_mset_mset_diff:
   assumes "a \<notin># M - {#a#}"
   shows "set_mset (M - {#a#}) = set_mset M - {a}"
   using assms by (auto simp add: not_in_iff in_diff_count set_eq_iff)
 
 lemma more_than_one_mset_mset_diff:
   assumes "a \<in># M - {#a#}"
   shows "set_mset (M - {#a#}) = set_mset M"
 proof (rule set_eqI)
   fix b
   have "Suc 0 < count M b \<Longrightarrow> count M b > 0" by arith
   then show "b \<in># M - {#a#} \<longleftrightarrow> b \<in># M"
     using assms by (auto simp add: in_diff_count)
 qed
 
 lemma inter_iff:
   "a \<in># A \<inter># B \<longleftrightarrow> a \<in># A \<and> a \<in># B"
   by simp
 
 lemma inter_union_distrib_left:
   "A \<inter># B + C = (A + C) \<inter># (B + C)"
   by (simp add: multiset_eq_iff min_add_distrib_left)
 
 lemma inter_union_distrib_right:
   "C + A \<inter># B = (C + A) \<inter># (C + B)"
   using inter_union_distrib_left [of A B C] by (simp add: ac_simps)
 
 lemma inter_subset_eq_union:
   "A \<inter># B \<subseteq># A + B"
   by (auto simp add: subseteq_mset_def)
 
 
 subsubsection \<open>Additional bounded union facts\<close>
 
 lemma set_mset_sup [simp]:
   \<open>set_mset (A \<union># B) = set_mset A \<union> set_mset B\<close>
   by (simp only: set_mset_def) (auto simp add: less_max_iff_disj)
 
 lemma sup_union_left1 [simp]: "\<not> x \<in># N \<Longrightarrow> (add_mset x M) \<union># N = add_mset x (M \<union># N)"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma sup_union_left2: "x \<in># N \<Longrightarrow> (add_mset x M) \<union># N = add_mset x (M \<union># (N - {#x#}))"
   by (simp add: multiset_eq_iff)
 
 lemma sup_union_right1 [simp]: "\<not> x \<in># N \<Longrightarrow> N \<union># (add_mset x M) = add_mset x (N \<union># M)"
   by (simp add: multiset_eq_iff not_in_iff)
 
 lemma sup_union_right2: "x \<in># N \<Longrightarrow> N \<union># (add_mset x M) = add_mset x ((N - {#x#}) \<union># M)"
   by (simp add: multiset_eq_iff)
 
 lemma sup_union_distrib_left:
   "A \<union># B + C = (A + C) \<union># (B + C)"
   by (simp add: multiset_eq_iff max_add_distrib_left)
 
 lemma union_sup_distrib_right:
   "C + A \<union># B = (C + A) \<union># (C + B)"
   using sup_union_distrib_left [of A B C] by (simp add: ac_simps)
 
 lemma union_diff_inter_eq_sup:
   "A + B - A \<inter># B = A \<union># B"
   by (auto simp add: multiset_eq_iff)
 
 lemma union_diff_sup_eq_inter:
   "A + B - A \<union># B = A \<inter># B"
   by (auto simp add: multiset_eq_iff)
 
 lemma add_mset_union:
   \<open>add_mset a A \<union># add_mset a B = add_mset a (A \<union># B)\<close>
   by (auto simp: multiset_eq_iff max_def)
 
 
 subsection \<open>Replicate and repeat operations\<close>
 
 definition replicate_mset :: "nat \<Rightarrow> 'a \<Rightarrow> 'a multiset" where
   "replicate_mset n x = (add_mset x ^^ n) {#}"
 
 lemma replicate_mset_0[simp]: "replicate_mset 0 x = {#}"
   unfolding replicate_mset_def by simp
 
 lemma replicate_mset_Suc [simp]: "replicate_mset (Suc n) x = add_mset x (replicate_mset n x)"
   unfolding replicate_mset_def by (induct n) (auto intro: add.commute)
 
 lemma count_replicate_mset[simp]: "count (replicate_mset n x) y = (if y = x then n else 0)"
   unfolding replicate_mset_def by (induct n) auto
 
 lift_definition repeat_mset :: \<open>nat \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset\<close>
   is \<open>\<lambda>n M a. n * M a\<close> by simp
 
 lemma count_repeat_mset [simp]: "count (repeat_mset i A) a = i * count A a"
   by transfer rule
 
 lemma repeat_mset_0 [simp]:
   \<open>repeat_mset 0 M = {#}\<close>
   by transfer simp
 
 lemma repeat_mset_Suc [simp]:
   \<open>repeat_mset (Suc n) M = M + repeat_mset n M\<close>
   by transfer simp
 
 lemma repeat_mset_right [simp]: "repeat_mset a (repeat_mset b A) = repeat_mset (a * b) A"
   by (auto simp: multiset_eq_iff left_diff_distrib')
 
 lemma left_diff_repeat_mset_distrib': \<open>repeat_mset (i - j) u = repeat_mset i u - repeat_mset j u\<close>
   by (auto simp: multiset_eq_iff left_diff_distrib')
 
 lemma left_add_mult_distrib_mset:
   "repeat_mset i u + (repeat_mset j u + k) = repeat_mset (i+j) u + k"
   by (auto simp: multiset_eq_iff add_mult_distrib)
 
 lemma repeat_mset_distrib:
   "repeat_mset (m + n) A = repeat_mset m A + repeat_mset n A"
   by (auto simp: multiset_eq_iff Nat.add_mult_distrib)
 
 lemma repeat_mset_distrib2[simp]:
   "repeat_mset n (A + B) = repeat_mset n A + repeat_mset n B"
   by (auto simp: multiset_eq_iff add_mult_distrib2)
 
 lemma repeat_mset_replicate_mset[simp]:
   "repeat_mset n {#a#} = replicate_mset n a"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_distrib_add_mset[simp]:
   "repeat_mset n (add_mset a A) = replicate_mset n a + repeat_mset n A"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_empty[simp]: "repeat_mset n {#} = {#}"
   by transfer simp
 
 
 subsubsection \<open>Simprocs\<close>
 
 lemma repeat_mset_iterate_add: \<open>repeat_mset n M = iterate_add n M\<close>
   unfolding iterate_add_def by (induction n) auto
 
 lemma mset_subseteq_add_iff1:
   "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<subseteq># repeat_mset j u + n) = (repeat_mset (i-j) u + m \<subseteq># n)"
   by (auto simp add: subseteq_mset_def nat_le_add_iff1)
 
 lemma mset_subseteq_add_iff2:
   "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<subseteq># repeat_mset j u + n) = (m \<subseteq># repeat_mset (j-i) u + n)"
   by (auto simp add: subseteq_mset_def nat_le_add_iff2)
 
 lemma mset_subset_add_iff1:
   "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<subset># repeat_mset j u + n) = (repeat_mset (i-j) u + m \<subset># n)"
   unfolding subset_mset_def repeat_mset_iterate_add
   by (simp add: iterate_add_eq_add_iff1 mset_subseteq_add_iff1[unfolded repeat_mset_iterate_add])
 
 lemma mset_subset_add_iff2:
   "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<subset># repeat_mset j u + n) = (m \<subset># repeat_mset (j-i) u + n)"
   unfolding subset_mset_def repeat_mset_iterate_add
   by (simp add: iterate_add_eq_add_iff2 mset_subseteq_add_iff2[unfolded repeat_mset_iterate_add])
 
 ML_file \<open>multiset_simprocs.ML\<close>
 
 lemma add_mset_replicate_mset_safe[cancelation_simproc_pre]: \<open>NO_MATCH {#} M \<Longrightarrow> add_mset a M = {#a#} + M\<close>
   by simp
 
 declare repeat_mset_iterate_add[cancelation_simproc_pre]
 
 declare iterate_add_distrib[cancelation_simproc_pre]
 declare repeat_mset_iterate_add[symmetric, cancelation_simproc_post]
 
 declare add_mset_not_empty[cancelation_simproc_eq_elim]
     empty_not_add_mset[cancelation_simproc_eq_elim]
     subset_mset.le_zero_eq[cancelation_simproc_eq_elim]
     empty_not_add_mset[cancelation_simproc_eq_elim]
     add_mset_not_empty[cancelation_simproc_eq_elim]
     subset_mset.le_zero_eq[cancelation_simproc_eq_elim]
     le_zero_eq[cancelation_simproc_eq_elim]
 
 simproc_setup mseteq_cancel
   ("(l::'a multiset) + m = n" | "(l::'a multiset) = m + n" |
    "add_mset a m = n" | "m = add_mset a n" |
    "replicate_mset p a = n" | "m = replicate_mset p a" |
    "repeat_mset p m = n" | "m = repeat_mset p m") =
   \<open>K Cancel_Simprocs.eq_cancel\<close>
 
 simproc_setup msetsubset_cancel
   ("(l::'a multiset) + m \<subset># n" | "(l::'a multiset) \<subset># m + n" |
    "add_mset a m \<subset># n" | "m \<subset># add_mset a n" |
    "replicate_mset p r \<subset># n" | "m \<subset># replicate_mset p r" |
    "repeat_mset p m \<subset># n" | "m \<subset># repeat_mset p m") =
   \<open>K Multiset_Simprocs.subset_cancel_msets\<close>
 
 simproc_setup msetsubset_eq_cancel
   ("(l::'a multiset) + m \<subseteq># n" | "(l::'a multiset) \<subseteq># m + n" |
    "add_mset a m \<subseteq># n" | "m \<subseteq># add_mset a n" |
    "replicate_mset p r \<subseteq># n" | "m \<subseteq># replicate_mset p r" |
    "repeat_mset p m \<subseteq># n" | "m \<subseteq># repeat_mset p m") =
   \<open>K Multiset_Simprocs.subseteq_cancel_msets\<close>
 
 simproc_setup msetdiff_cancel
   ("((l::'a multiset) + m) - n" | "(l::'a multiset) - (m + n)" |
    "add_mset a m - n" | "m - add_mset a n" |
    "replicate_mset p r - n" | "m - replicate_mset p r" |
    "repeat_mset p m - n" | "m - repeat_mset p m") =
   \<open>K Cancel_Simprocs.diff_cancel\<close>
 
 
 subsubsection \<open>Conditionally complete lattice\<close>
 
 instantiation multiset :: (type) Inf
 begin
 
 lift_definition Inf_multiset :: "'a multiset set \<Rightarrow> 'a multiset" is
   "\<lambda>A i. if A = {} then 0 else Inf ((\<lambda>f. f i) ` A)"
 proof -
   fix A :: "('a \<Rightarrow> nat) set"
   assume *: "\<And>f. f \<in> A \<Longrightarrow> finite {x. 0 < f x}"
   show \<open>finite {i. 0 < (if A = {} then 0 else INF f\<in>A. f i)}\<close>
   proof (cases "A = {}")
     case False
     then obtain f where "f \<in> A" by blast
     hence "{i. Inf ((\<lambda>f. f i) ` A) > 0} \<subseteq> {i. f i > 0}"
       by (auto intro: less_le_trans[OF _ cInf_lower])
     moreover from \<open>f \<in> A\<close> * have "finite \<dots>" by simp
     ultimately have "finite {i. Inf ((\<lambda>f. f i) ` A) > 0}" by (rule finite_subset)
     with False show ?thesis by simp
   qed simp_all
 qed
 
 instance ..
 
 end
 
 lemma Inf_multiset_empty: "Inf {} = {#}"
   by transfer simp_all
 
 lemma count_Inf_multiset_nonempty: "A \<noteq> {} \<Longrightarrow> count (Inf A) x = Inf ((\<lambda>X. count X x) ` A)"
   by transfer simp_all
 
 
 instantiation multiset :: (type) Sup
 begin
 
 definition Sup_multiset :: "'a multiset set \<Rightarrow> 'a multiset" where
   "Sup_multiset A = (if A \<noteq> {} \<and> subset_mset.bdd_above A then
            Abs_multiset (\<lambda>i. Sup ((\<lambda>X. count X i) ` A)) else {#})"
 
 lemma Sup_multiset_empty: "Sup {} = {#}"
   by (simp add: Sup_multiset_def)
 
 lemma Sup_multiset_unbounded: "\<not> subset_mset.bdd_above A \<Longrightarrow> Sup A = {#}"
   by (simp add: Sup_multiset_def)
 
 instance ..
 
 end
 
 lemma bdd_above_multiset_imp_bdd_above_count:
   assumes "subset_mset.bdd_above (A :: 'a multiset set)"
   shows   "bdd_above ((\<lambda>X. count X x) ` A)"
 proof -
   from assms obtain Y where Y: "\<forall>X\<in>A. X \<subseteq># Y"
     by (meson subset_mset.bdd_above.E)
   hence "count X x \<le> count Y x" if "X \<in> A" for X
     using that by (auto intro: mset_subset_eq_count)
   thus ?thesis by (intro bdd_aboveI[of _ "count Y x"]) auto
 qed
 
 lemma bdd_above_multiset_imp_finite_support:
   assumes "A \<noteq> {}" "subset_mset.bdd_above (A :: 'a multiset set)"
   shows   "finite (\<Union>X\<in>A. {x. count X x > 0})"
 proof -
   from assms obtain Y where Y: "\<forall>X\<in>A. X \<subseteq># Y"
     by (meson subset_mset.bdd_above.E)
   hence "count X x \<le> count Y x" if "X \<in> A" for X x
     using that by (auto intro: mset_subset_eq_count)
   hence "(\<Union>X\<in>A. {x. count X x > 0}) \<subseteq> {x. count Y x > 0}"
     by safe (erule less_le_trans)
   moreover have "finite \<dots>" by simp
   ultimately show ?thesis by (rule finite_subset)
 qed
 
 lemma Sup_multiset_in_multiset:
   \<open>finite {i. 0 < (SUP M\<in>A. count M i)}\<close>
   if \<open>A \<noteq> {}\<close> \<open>subset_mset.bdd_above A\<close>
 proof -
   have "{i. Sup ((\<lambda>X. count X i) ` A) > 0} \<subseteq> (\<Union>X\<in>A. {i. 0 < count X i})"
   proof safe
     fix i assume pos: "(SUP X\<in>A. count X i) > 0"
     show "i \<in> (\<Union>X\<in>A. {i. 0 < count X i})"
     proof (rule ccontr)
       assume "i \<notin> (\<Union>X\<in>A. {i. 0 < count X i})"
       hence "\<forall>X\<in>A. count X i \<le> 0" by (auto simp: count_eq_zero_iff)
       with that have "(SUP X\<in>A. count X i) \<le> 0"
         by (intro cSup_least bdd_above_multiset_imp_bdd_above_count) auto
       with pos show False by simp
     qed
   qed
   moreover from that have "finite \<dots>"
     by (rule bdd_above_multiset_imp_finite_support)
   ultimately show "finite {i. Sup ((\<lambda>X. count X i) ` A) > 0}"
     by (rule finite_subset)
 qed
 
 lemma count_Sup_multiset_nonempty:
   \<open>count (Sup A) x = (SUP X\<in>A. count X x)\<close>
   if \<open>A \<noteq> {}\<close> \<open>subset_mset.bdd_above A\<close>
   using that by (simp add: Sup_multiset_def Sup_multiset_in_multiset count_Abs_multiset)
 
 interpretation subset_mset: conditionally_complete_lattice Inf Sup "(\<inter>#)" "(\<subseteq>#)" "(\<subset>#)" "(\<union>#)"
 proof
   fix X :: "'a multiset" and A
   assume "X \<in> A"
   show "Inf A \<subseteq># X"
   proof (rule mset_subset_eqI)
     fix x
     from \<open>X \<in> A\<close> have "A \<noteq> {}" by auto
     hence "count (Inf A) x = (INF X\<in>A. count X x)"
       by (simp add: count_Inf_multiset_nonempty)
     also from \<open>X \<in> A\<close> have "\<dots> \<le> count X x"
       by (intro cInf_lower) simp_all
     finally show "count (Inf A) x \<le> count X x" .
   qed
 next
   fix X :: "'a multiset" and A
   assume nonempty: "A \<noteq> {}" and le: "\<And>Y. Y \<in> A \<Longrightarrow> X \<subseteq># Y"
   show "X \<subseteq># Inf A"
   proof (rule mset_subset_eqI)
     fix x
     from nonempty have "count X x \<le> (INF X\<in>A. count X x)"
       by (intro cInf_greatest) (auto intro: mset_subset_eq_count le)
     also from nonempty have "\<dots> = count (Inf A) x" by (simp add: count_Inf_multiset_nonempty)
     finally show "count X x \<le> count (Inf A) x" .
   qed
 next
   fix X :: "'a multiset" and A
   assume X: "X \<in> A" and bdd: "subset_mset.bdd_above A"
   show "X \<subseteq># Sup A"
   proof (rule mset_subset_eqI)
     fix x
     from X have "A \<noteq> {}" by auto
     have "count X x \<le> (SUP X\<in>A. count X x)"
       by (intro cSUP_upper X bdd_above_multiset_imp_bdd_above_count bdd)
     also from count_Sup_multiset_nonempty[OF \<open>A \<noteq> {}\<close> bdd]
       have "(SUP X\<in>A. count X x) = count (Sup A) x" by simp
     finally show "count X x \<le> count (Sup A) x" .
   qed
 next
   fix X :: "'a multiset" and A
   assume nonempty: "A \<noteq> {}" and ge: "\<And>Y. Y \<in> A \<Longrightarrow> Y \<subseteq># X"
   from ge have bdd: "subset_mset.bdd_above A"
     by blast
   show "Sup A \<subseteq># X"
   proof (rule mset_subset_eqI)
     fix x
     from count_Sup_multiset_nonempty[OF \<open>A \<noteq> {}\<close> bdd]
       have "count (Sup A) x = (SUP X\<in>A. count X x)" .
     also from nonempty have "\<dots> \<le> count X x"
       by (intro cSup_least) (auto intro: mset_subset_eq_count ge)
     finally show "count (Sup A) x \<le> count X x" .
   qed
 qed \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 lemma set_mset_Inf:
   assumes "A \<noteq> {}"
   shows   "set_mset (Inf A) = (\<Inter>X\<in>A. set_mset X)"
 proof safe
   fix x X assume "x \<in># Inf A" "X \<in> A"
   hence nonempty: "A \<noteq> {}" by (auto simp: Inf_multiset_empty)
   from \<open>x \<in># Inf A\<close> have "{#x#} \<subseteq># Inf A" by auto
   also from \<open>X \<in> A\<close> have "\<dots> \<subseteq># X" by (rule subset_mset.cInf_lower) simp_all
   finally show "x \<in># X" by simp
 next
   fix x assume x: "x \<in> (\<Inter>X\<in>A. set_mset X)"
   hence "{#x#} \<subseteq># X" if "X \<in> A" for X using that by auto
   from assms and this have "{#x#} \<subseteq># Inf A" by (rule subset_mset.cInf_greatest)
   thus "x \<in># Inf A" by simp
 qed
 
 lemma in_Inf_multiset_iff:
   assumes "A \<noteq> {}"
   shows   "x \<in># Inf A \<longleftrightarrow> (\<forall>X\<in>A. x \<in># X)"
 proof -
   from assms have "set_mset (Inf A) = (\<Inter>X\<in>A. set_mset X)" by (rule set_mset_Inf)
   also have "x \<in> \<dots> \<longleftrightarrow> (\<forall>X\<in>A. x \<in># X)" by simp
   finally show ?thesis .
 qed
 
 lemma in_Inf_multisetD: "x \<in># Inf A \<Longrightarrow> X \<in> A \<Longrightarrow> x \<in># X"
   by (subst (asm) in_Inf_multiset_iff) auto
 
 lemma set_mset_Sup:
   assumes "subset_mset.bdd_above A"
   shows   "set_mset (Sup A) = (\<Union>X\<in>A. set_mset X)"
 proof safe
   fix x assume "x \<in># Sup A"
   hence nonempty: "A \<noteq> {}" by (auto simp: Sup_multiset_empty)
   show "x \<in> (\<Union>X\<in>A. set_mset X)"
   proof (rule ccontr)
     assume x: "x \<notin> (\<Union>X\<in>A. set_mset X)"
     have "count X x \<le> count (Sup A) x" if "X \<in> A" for X x
       using that by (intro mset_subset_eq_count subset_mset.cSup_upper assms)
     with x have "X \<subseteq># Sup A - {#x#}" if "X \<in> A" for X
       using that by (auto simp: subseteq_mset_def algebra_simps not_in_iff)
     hence "Sup A \<subseteq># Sup A - {#x#}" by (intro subset_mset.cSup_least nonempty)
     with \<open>x \<in># Sup A\<close> show False
       by (auto simp: subseteq_mset_def simp flip: count_greater_zero_iff
                dest!: spec[of _ x])
   qed
 next
   fix x X assume "x \<in> set_mset X" "X \<in> A"
   hence "{#x#} \<subseteq># X" by auto
   also have "X \<subseteq># Sup A" by (intro subset_mset.cSup_upper \<open>X \<in> A\<close> assms)
   finally show "x \<in> set_mset (Sup A)" by simp
 qed
 
 lemma in_Sup_multiset_iff:
   assumes "subset_mset.bdd_above A"
   shows   "x \<in># Sup A \<longleftrightarrow> (\<exists>X\<in>A. x \<in># X)"
 proof -
   from assms have "set_mset (Sup A) = (\<Union>X\<in>A. set_mset X)" by (rule set_mset_Sup)
   also have "x \<in> \<dots> \<longleftrightarrow> (\<exists>X\<in>A. x \<in># X)" by simp
   finally show ?thesis .
 qed
 
 lemma in_Sup_multisetD:
   assumes "x \<in># Sup A"
   shows   "\<exists>X\<in>A. x \<in># X"
 proof -
   have "subset_mset.bdd_above A"
     by (rule ccontr) (insert assms, simp_all add: Sup_multiset_unbounded)
   with assms show ?thesis by (simp add: in_Sup_multiset_iff)
 qed
 
 interpretation subset_mset: distrib_lattice "(\<inter>#)" "(\<subseteq>#)" "(\<subset>#)" "(\<union>#)"
 proof
   fix A B C :: "'a multiset"
   show "A \<union># (B \<inter># C) = A \<union># B \<inter># (A \<union># C)"
     by (intro multiset_eqI) simp_all
 qed \<comment> \<open>FIXME: avoid junk stemming from type class interpretation\<close>
 
 
 subsubsection \<open>Filter (with comprehension syntax)\<close>
 
 text \<open>Multiset comprehension\<close>
 
 lift_definition filter_mset :: "('a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset"
 is "\<lambda>P M. \<lambda>x. if P x then M x else 0"
 by (rule filter_preserves_multiset)
 
 syntax (ASCII)
   "_MCollect" :: "pttrn \<Rightarrow> 'a multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"    ("(1{#_ :# _./ _#})")
 syntax
   "_MCollect" :: "pttrn \<Rightarrow> 'a multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"    ("(1{#_ \<in># _./ _#})")
 translations
   "{#x \<in># M. P#}" == "CONST filter_mset (\<lambda>x. P) M"
 
 lemma count_filter_mset [simp]:
   "count (filter_mset P M) a = (if P a then count M a else 0)"
   by (simp add: filter_mset.rep_eq)
 
 lemma set_mset_filter [simp]:
   "set_mset (filter_mset P M) = {a \<in> set_mset M. P a}"
   by (simp only: set_eq_iff count_greater_zero_iff [symmetric] count_filter_mset) simp
 
 lemma filter_empty_mset [simp]: "filter_mset P {#} = {#}"
   by (rule multiset_eqI) simp
 
 lemma filter_single_mset: "filter_mset P {#x#} = (if P x then {#x#} else {#})"
   by (rule multiset_eqI) simp
 
 lemma filter_union_mset [simp]: "filter_mset P (M + N) = filter_mset P M + filter_mset P N"
   by (rule multiset_eqI) simp
 
 lemma filter_diff_mset [simp]: "filter_mset P (M - N) = filter_mset P M - filter_mset P N"
   by (rule multiset_eqI) simp
 
 lemma filter_inter_mset [simp]: "filter_mset P (M \<inter># N) = filter_mset P M \<inter># filter_mset P N"
   by (rule multiset_eqI) simp
 
 lemma filter_sup_mset[simp]: "filter_mset P (A \<union># B) = filter_mset P A \<union># filter_mset P B"
   by (rule multiset_eqI) simp
 
 lemma filter_mset_add_mset [simp]:
    "filter_mset P (add_mset x A) =
      (if P x then add_mset x (filter_mset P A) else filter_mset P A)"
    by (auto simp: multiset_eq_iff)
 
 lemma multiset_filter_subset[simp]: "filter_mset f M \<subseteq># M"
   by (simp add: mset_subset_eqI)
 
 lemma multiset_filter_mono:
   assumes "A \<subseteq># B"
   shows "filter_mset f A \<subseteq># filter_mset f B"
 proof -
   from assms[unfolded mset_subset_eq_exists_conv]
   obtain C where B: "B = A + C" by auto
   show ?thesis unfolding B by auto
 qed
 
 lemma filter_mset_eq_conv:
   "filter_mset P M = N \<longleftrightarrow> N \<subseteq># M \<and> (\<forall>b\<in>#N. P b) \<and> (\<forall>a\<in>#M - N. \<not> P a)" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P then show ?Q by auto (simp add: multiset_eq_iff in_diff_count)
 next
   assume ?Q
   then obtain Q where M: "M = N + Q"
     by (auto simp add: mset_subset_eq_exists_conv)
   then have MN: "M - N = Q" by simp
   show ?P
   proof (rule multiset_eqI)
     fix a
     from \<open>?Q\<close> MN have *: "\<not> P a \<Longrightarrow> a \<notin># N" "P a \<Longrightarrow> a \<notin># Q"
       by auto
     show "count (filter_mset P M) a = count N a"
     proof (cases "a \<in># M")
       case True
       with * show ?thesis
         by (simp add: not_in_iff M)
     next
       case False then have "count M a = 0"
         by (simp add: not_in_iff)
       with M show ?thesis by simp
     qed
   qed
 qed
 
 lemma filter_filter_mset: "filter_mset P (filter_mset Q M) = {#x \<in># M. Q x \<and> P x#}"
   by (auto simp: multiset_eq_iff)
 
 lemma
   filter_mset_True[simp]: "{#y \<in># M. True#} = M" and
   filter_mset_False[simp]: "{#y \<in># M. False#} = {#}"
   by (auto simp: multiset_eq_iff)
 
 lemma filter_mset_cong0:
   assumes "\<And>x. x \<in># M \<Longrightarrow> f x \<longleftrightarrow> g x"
   shows "filter_mset f M = filter_mset g M"
 proof (rule subset_mset.antisym; unfold subseteq_mset_def; rule allI)
   fix x
   show "count (filter_mset f M) x \<le> count (filter_mset g M) x"
     using assms by (cases "x \<in># M") (simp_all add: not_in_iff)
 next
   fix x
   show "count (filter_mset g M) x \<le> count (filter_mset f M) x"
     using assms by (cases "x \<in># M") (simp_all add: not_in_iff)
 qed
 
 lemma filter_mset_cong:
   assumes "M = M'" and "\<And>x. x \<in># M' \<Longrightarrow> f x \<longleftrightarrow> g x"
   shows "filter_mset f M = filter_mset g M'"
   unfolding \<open>M = M'\<close>
   using assms by (auto intro: filter_mset_cong0)
 
+lemma filter_eq_replicate_mset: "{#y \<in># D. y = x#} = replicate_mset (count D x) x"
+  by (induct D) (simp add: multiset_eqI)
+
 
 subsubsection \<open>Size\<close>
 
 definition wcount where "wcount f M = (\<lambda>x. count M x * Suc (f x))"
 
 lemma wcount_union: "wcount f (M + N) a = wcount f M a + wcount f N a"
   by (auto simp: wcount_def add_mult_distrib)
 
 lemma wcount_add_mset:
   "wcount f (add_mset x M) a = (if x = a then Suc (f a) else 0) + wcount f M a"
   unfolding add_mset_add_single[of _ M] wcount_union by (auto simp: wcount_def)
 
 definition size_multiset :: "('a \<Rightarrow> nat) \<Rightarrow> 'a multiset \<Rightarrow> nat" where
   "size_multiset f M = sum (wcount f M) (set_mset M)"
 
 lemmas size_multiset_eq = size_multiset_def[unfolded wcount_def]
 
 instantiation multiset :: (type) size
 begin
 
 definition size_multiset where
   size_multiset_overloaded_def: "size_multiset = Multiset.size_multiset (\<lambda>_. 0)"
 instance ..
 
 end
 
 lemmas size_multiset_overloaded_eq =
   size_multiset_overloaded_def[THEN fun_cong, unfolded size_multiset_eq, simplified]
 
 lemma size_multiset_empty [simp]: "size_multiset f {#} = 0"
 by (simp add: size_multiset_def)
 
 lemma size_empty [simp]: "size {#} = 0"
 by (simp add: size_multiset_overloaded_def)
 
 lemma size_multiset_single : "size_multiset f {#b#} = Suc (f b)"
 by (simp add: size_multiset_eq)
 
 lemma size_single: "size {#b#} = 1"
 by (simp add: size_multiset_overloaded_def size_multiset_single)
 
 lemma sum_wcount_Int:
   "finite A \<Longrightarrow> sum (wcount f N) (A \<inter> set_mset N) = sum (wcount f N) A"
   by (induct rule: finite_induct)
     (simp_all add: Int_insert_left wcount_def count_eq_zero_iff)
 
 lemma size_multiset_union [simp]:
   "size_multiset f (M + N::'a multiset) = size_multiset f M + size_multiset f N"
 apply (simp add: size_multiset_def sum_Un_nat sum.distrib sum_wcount_Int wcount_union)
 apply (subst Int_commute)
 apply (simp add: sum_wcount_Int)
 done
 
 lemma size_multiset_add_mset [simp]:
   "size_multiset f (add_mset a M) = Suc (f a) + size_multiset f M"
   unfolding add_mset_add_single[of _ M] size_multiset_union by (auto simp: size_multiset_single)
 
 lemma size_add_mset [simp]: "size (add_mset a A) = Suc (size A)"
 by (simp add: size_multiset_overloaded_def wcount_add_mset)
 
 lemma size_union [simp]: "size (M + N::'a multiset) = size M + size N"
 by (auto simp add: size_multiset_overloaded_def)
 
 lemma size_multiset_eq_0_iff_empty [iff]:
   "size_multiset f M = 0 \<longleftrightarrow> M = {#}"
   by (auto simp add: size_multiset_eq count_eq_zero_iff)
 
 lemma size_eq_0_iff_empty [iff]: "(size M = 0) = (M = {#})"
 by (auto simp add: size_multiset_overloaded_def)
 
 lemma nonempty_has_size: "(S \<noteq> {#}) = (0 < size S)"
 by (metis gr0I gr_implies_not0 size_empty size_eq_0_iff_empty)
 
 lemma size_eq_Suc_imp_elem: "size M = Suc n \<Longrightarrow> \<exists>a. a \<in># M"
 apply (unfold size_multiset_overloaded_eq)
 apply (drule sum_SucD)
 apply auto
 done
 
 lemma size_eq_Suc_imp_eq_union:
   assumes "size M = Suc n"
   shows "\<exists>a N. M = add_mset a N"
 proof -
   from assms obtain a where "a \<in># M"
     by (erule size_eq_Suc_imp_elem [THEN exE])
   then have "M = add_mset a (M - {#a#})" by simp
   then show ?thesis by blast
 qed
 
 lemma size_mset_mono:
   fixes A B :: "'a multiset"
   assumes "A \<subseteq># B"
   shows "size A \<le> size B"
 proof -
   from assms[unfolded mset_subset_eq_exists_conv]
   obtain C where B: "B = A + C" by auto
   show ?thesis unfolding B by (induct C) auto
 qed
 
 lemma size_filter_mset_lesseq[simp]: "size (filter_mset f M) \<le> size M"
 by (rule size_mset_mono[OF multiset_filter_subset])
 
 lemma size_Diff_submset:
   "M \<subseteq># M' \<Longrightarrow> size (M' - M) = size M' - size(M::'a multiset)"
 by (metis add_diff_cancel_left' size_union mset_subset_eq_exists_conv)
 
+lemma size_lt_imp_ex_count_lt: "size M < size N \<Longrightarrow> \<exists>x \<in># N. count M x < count N x"
+  by (metis count_eq_zero_iff leD not_le_imp_less not_less_zero size_mset_mono subseteq_mset_def)
+
 
 subsection \<open>Induction and case splits\<close>
 
 theorem multiset_induct [case_names empty add, induct type: multiset]:
   assumes empty: "P {#}"
   assumes add: "\<And>x M. P M \<Longrightarrow> P (add_mset x M)"
   shows "P M"
 proof (induct "size M" arbitrary: M)
   case 0 thus "P M" by (simp add: empty)
 next
   case (Suc k)
   obtain N x where "M = add_mset x N"
     using \<open>Suc k = size M\<close> [symmetric]
     using size_eq_Suc_imp_eq_union by fast
   with Suc add show "P M" by simp
 qed
 
 lemma multiset_induct_min[case_names empty add]:
   fixes M :: "'a::linorder multiset"
   assumes
     empty: "P {#}" and
     add: "\<And>x M. P M \<Longrightarrow> (\<forall>y \<in># M. y \<ge> x) \<Longrightarrow> P (add_mset x M)"
   shows "P M"
 proof (induct "size M" arbitrary: M)
   case (Suc k)
   note ih = this(1) and Sk_eq_sz_M = this(2)
 
   let ?y = "Min_mset M"
   let ?N = "M - {#?y#}"
 
   have M: "M = add_mset ?y ?N"
     by (metis Min_in Sk_eq_sz_M finite_set_mset insert_DiffM lessI not_less_zero
       set_mset_eq_empty_iff size_empty)
   show ?case
     by (subst M, rule add, rule ih, metis M Sk_eq_sz_M nat.inject size_add_mset,
       meson Min_le finite_set_mset in_diffD)
 qed (simp add: empty)
 
 lemma multiset_induct_max[case_names empty add]:
   fixes M :: "'a::linorder multiset"
   assumes
     empty: "P {#}" and
     add: "\<And>x M. P M \<Longrightarrow> (\<forall>y \<in># M. y \<le> x) \<Longrightarrow> P (add_mset x M)"
   shows "P M"
 proof (induct "size M" arbitrary: M)
   case (Suc k)
   note ih = this(1) and Sk_eq_sz_M = this(2)
 
   let ?y = "Max_mset M"
   let ?N = "M - {#?y#}"
 
   have M: "M = add_mset ?y ?N"
     by (metis Max_in Sk_eq_sz_M finite_set_mset insert_DiffM lessI not_less_zero
       set_mset_eq_empty_iff size_empty)
   show ?case
     by (subst M, rule add, rule ih, metis M Sk_eq_sz_M nat.inject size_add_mset,
       meson Max_ge finite_set_mset in_diffD)
 qed (simp add: empty)
 
 lemma multi_nonempty_split: "M \<noteq> {#} \<Longrightarrow> \<exists>A a. M = add_mset a A"
 by (induct M) auto
 
 lemma multiset_cases [cases type]:
   obtains (empty) "M = {#}"
     | (add) x N where "M = add_mset x N"
   by (induct M) simp_all
 
 lemma multi_drop_mem_not_eq: "c \<in># B \<Longrightarrow> B - {#c#} \<noteq> B"
 by (cases "B = {#}") (auto dest: multi_member_split)
 
 lemma union_filter_mset_complement[simp]:
   "\<forall>x. P x = (\<not> Q x) \<Longrightarrow> filter_mset P M + filter_mset Q M = M"
 by (subst multiset_eq_iff) auto
 
 lemma multiset_partition: "M = {#x \<in># M. P x#} + {#x \<in># M. \<not> P x#}"
 by simp
 
 lemma mset_subset_size: "A \<subset># B \<Longrightarrow> size A < size B"
 proof (induct A arbitrary: B)
   case empty
   then show ?case
     using nonempty_has_size by auto
 next
   case (add x A)
   have "add_mset x A \<subseteq># B"
     by (meson add.prems subset_mset_def)
   then show ?case
     by (metis (no_types) add.prems add.right_neutral add_diff_cancel_left' leD nat_neq_iff
       size_Diff_submset size_eq_0_iff_empty size_mset_mono subset_mset.le_iff_add subset_mset_def)
 qed
 
 lemma size_1_singleton_mset: "size M = 1 \<Longrightarrow> \<exists>a. M = {#a#}"
   by (cases M) auto
 
 
 subsubsection \<open>Strong induction and subset induction for multisets\<close>
 
 text \<open>Well-foundedness of strict subset relation\<close>
 
 lemma wf_subset_mset_rel: "wf {(M, N :: 'a multiset). M \<subset># N}"
 apply (rule wf_measure [THEN wf_subset, where f1=size])
 apply (clarsimp simp: measure_def inv_image_def mset_subset_size)
 done
 
 lemma wfP_subset_mset[simp]: "wfP (\<subset>#)"
   by (rule wf_subset_mset_rel[to_pred])
 
 lemma full_multiset_induct [case_names less]:
 assumes ih: "\<And>B. \<forall>(A::'a multiset). A \<subset># B \<longrightarrow> P A \<Longrightarrow> P B"
 shows "P B"
 apply (rule wf_subset_mset_rel [THEN wf_induct])
 apply (rule ih, auto)
 done
 
 lemma multi_subset_induct [consumes 2, case_names empty add]:
   assumes "F \<subseteq># A"
     and empty: "P {#}"
     and insert: "\<And>a F. a \<in># A \<Longrightarrow> P F \<Longrightarrow> P (add_mset a F)"
   shows "P F"
 proof -
   from \<open>F \<subseteq># A\<close>
   show ?thesis
   proof (induct F)
     show "P {#}" by fact
   next
     fix x F
     assume P: "F \<subseteq># A \<Longrightarrow> P F" and i: "add_mset x F \<subseteq># A"
     show "P (add_mset x F)"
     proof (rule insert)
       from i show "x \<in># A" by (auto dest: mset_subset_eq_insertD)
       from i have "F \<subseteq># A" by (auto dest: mset_subset_eq_insertD)
       with P show "P F" .
     qed
   qed
 qed
 
 
 subsection \<open>Least and greatest elements\<close>
 
 context begin
 
 qualified lemma
   assumes
     "M \<noteq> {#}" and
     "transp_on (set_mset M) R" and
     "totalp_on (set_mset M) R"
   shows
     bex_least_element: "(\<exists>l \<in># M. \<forall>x \<in># M. x \<noteq> l \<longrightarrow> R l x)" and
     bex_greatest_element: "(\<exists>g \<in># M. \<forall>x \<in># M. x \<noteq> g \<longrightarrow> R x g)"
   using assms
   by (auto intro: Finite_Set.bex_least_element Finite_Set.bex_greatest_element)
 
 end
 
 
 subsection \<open>The fold combinator\<close>
 
 definition fold_mset :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a multiset \<Rightarrow> 'b"
 where
   "fold_mset f s M = Finite_Set.fold (\<lambda>x. f x ^^ count M x) s (set_mset M)"
 
 lemma fold_mset_empty [simp]: "fold_mset f s {#} = s"
   by (simp add: fold_mset_def)
 
+lemma fold_mset_single [simp]: "fold_mset f s {#x#} = f x s"
+  by (simp add: fold_mset_def)
+
 context comp_fun_commute
 begin
 
 lemma fold_mset_add_mset [simp]: "fold_mset f s (add_mset x M) = f x (fold_mset f s M)"
 proof -
   interpret mset: comp_fun_commute "\<lambda>y. f y ^^ count M y"
     by (fact comp_fun_commute_funpow)
   interpret mset_union: comp_fun_commute "\<lambda>y. f y ^^ count (add_mset x M) y"
     by (fact comp_fun_commute_funpow)
   show ?thesis
   proof (cases "x \<in> set_mset M")
     case False
     then have *: "count (add_mset x M) x = 1"
       by (simp add: not_in_iff)
     from False have "Finite_Set.fold (\<lambda>y. f y ^^ count (add_mset x M) y) s (set_mset M) =
       Finite_Set.fold (\<lambda>y. f y ^^ count M y) s (set_mset M)"
       by (auto intro!: Finite_Set.fold_cong comp_fun_commute_on_funpow)
     with False * show ?thesis
       by (simp add: fold_mset_def del: count_add_mset)
   next
     case True
     define N where "N = set_mset M - {x}"
     from N_def True have *: "set_mset M = insert x N" "x \<notin> N" "finite N" by auto
     then have "Finite_Set.fold (\<lambda>y. f y ^^ count (add_mset x M) y) s N =
       Finite_Set.fold (\<lambda>y. f y ^^ count M y) s N"
       by (auto intro!: Finite_Set.fold_cong comp_fun_commute_on_funpow)
     with * show ?thesis by (simp add: fold_mset_def del: count_add_mset) simp
   qed
 qed
 
-corollary fold_mset_single: "fold_mset f s {#x#} = f x s"
-  by simp
-
 lemma fold_mset_fun_left_comm: "f x (fold_mset f s M) = fold_mset f (f x s) M"
   by (induct M) (simp_all add: fun_left_comm)
 
 lemma fold_mset_union [simp]: "fold_mset f s (M + N) = fold_mset f (fold_mset f s M) N"
   by (induct M) (simp_all add: fold_mset_fun_left_comm)
 
 lemma fold_mset_fusion:
   assumes "comp_fun_commute g"
     and *: "\<And>x y. h (g x y) = f x (h y)"
   shows "h (fold_mset g w A) = fold_mset f (h w) A"
 proof -
   interpret comp_fun_commute g by (fact assms)
   from * show ?thesis by (induct A) auto
 qed
 
 end
 
 lemma union_fold_mset_add_mset: "A + B = fold_mset add_mset A B"
 proof -
   interpret comp_fun_commute add_mset
     by standard auto
   show ?thesis
     by (induction B) auto
 qed
 
 text \<open>
   A note on code generation: When defining some function containing a
   subterm \<^term>\<open>fold_mset F\<close>, code generation is not automatic. When
   interpreting locale \<open>left_commutative\<close> with \<open>F\<close>, the
   would be code thms for \<^const>\<open>fold_mset\<close> become thms like
   \<^term>\<open>fold_mset F z {#} = z\<close> where \<open>F\<close> is not a pattern but
   contains defined symbols, i.e.\ is not a code thm. Hence a separate
   constant with its own code thms needs to be introduced for \<open>F\<close>. See the image operator below.
 \<close>
 
 
 subsection \<open>Image\<close>
 
 definition image_mset :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset" where
   "image_mset f = fold_mset (add_mset \<circ> f) {#}"
 
 lemma comp_fun_commute_mset_image: "comp_fun_commute (add_mset \<circ> f)"
   by unfold_locales (simp add: fun_eq_iff)
 
 lemma image_mset_empty [simp]: "image_mset f {#} = {#}"
   by (simp add: image_mset_def)
 
 lemma image_mset_single: "image_mset f {#x#} = {#f x#}"
   by (simp add: comp_fun_commute.fold_mset_add_mset comp_fun_commute_mset_image image_mset_def)
 
 lemma image_mset_union [simp]: "image_mset f (M + N) = image_mset f M + image_mset f N"
 proof -
   interpret comp_fun_commute "add_mset \<circ> f"
     by (fact comp_fun_commute_mset_image)
   show ?thesis by (induct N) (simp_all add: image_mset_def)
 qed
 
 corollary image_mset_add_mset [simp]:
   "image_mset f (add_mset a M) = add_mset (f a) (image_mset f M)"
   unfolding image_mset_union add_mset_add_single[of a M] by (simp add: image_mset_single)
 
 lemma set_image_mset [simp]: "set_mset (image_mset f M) = image f (set_mset M)"
   by (induct M) simp_all
 
 lemma size_image_mset [simp]: "size (image_mset f M) = size M"
   by (induct M) simp_all
 
 lemma image_mset_is_empty_iff [simp]: "image_mset f M = {#} \<longleftrightarrow> M = {#}"
   by (cases M) auto
 
 lemma image_mset_If:
   "image_mset (\<lambda>x. if P x then f x else g x) A =
      image_mset f (filter_mset P A) + image_mset g (filter_mset (\<lambda>x. \<not>P x) A)"
   by (induction A) auto
 
 lemma image_mset_Diff:
   assumes "B \<subseteq># A"
   shows   "image_mset f (A - B) = image_mset f A - image_mset f B"
 proof -
   have "image_mset f (A - B + B) = image_mset f (A - B) + image_mset f B"
     by simp
   also from assms have "A - B + B = A"
     by (simp add: subset_mset.diff_add)
   finally show ?thesis by simp
 qed
 
 lemma count_image_mset:
   \<open>count (image_mset f A) x = (\<Sum>y\<in>f -` {x} \<inter> set_mset A. count A y)\<close>
 proof (induction A)
   case empty
   then show ?case by simp
 next
   case (add x A)
   moreover have *: "(if x = y then Suc n else n) = n + (if x = y then 1 else 0)" for n y
     by simp
   ultimately show ?case
     by (auto simp: sum.distrib intro!: sum.mono_neutral_left)
 qed
 
 lemma count_image_mset':
   \<open>count (image_mset f X) y = (\<Sum>x | x \<in># X \<and> y = f x. count X x)\<close>
   by (auto simp add: count_image_mset simp flip: singleton_conv2 simp add: Collect_conj_eq ac_simps)
 
 lemma image_mset_subseteq_mono: "A \<subseteq># B \<Longrightarrow> image_mset f A \<subseteq># image_mset f B"
   by (metis image_mset_union subset_mset.le_iff_add)
 
 lemma image_mset_subset_mono: "M \<subset># N \<Longrightarrow> image_mset f M \<subset># image_mset f N"
   by (metis (no_types) Diff_eq_empty_iff_mset image_mset_Diff image_mset_is_empty_iff
     image_mset_subseteq_mono subset_mset.less_le_not_le)
 
 syntax (ASCII)
   "_comprehension_mset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> 'a multiset"  ("({#_/. _ :# _#})")
 syntax
   "_comprehension_mset" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> 'a multiset"  ("({#_/. _ \<in># _#})")
 translations
   "{#e. x \<in># M#}" \<rightleftharpoons> "CONST image_mset (\<lambda>x. e) M"
 
 syntax (ASCII)
   "_comprehension_mset'" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"  ("({#_/ | _ :# _./ _#})")
 syntax
   "_comprehension_mset'" :: "'a \<Rightarrow> 'b \<Rightarrow> 'b multiset \<Rightarrow> bool \<Rightarrow> 'a multiset"  ("({#_/ | _ \<in># _./ _#})")
 translations
   "{#e | x\<in>#M. P#}" \<rightharpoonup> "{#e. x \<in># {# x\<in>#M. P#}#}"
 
 text \<open>
   This allows to write not just filters like \<^term>\<open>{#x\<in>#M. x<c#}\<close>
   but also images like \<^term>\<open>{#x+x. x\<in>#M #}\<close> and @{term [source]
   "{#x+x|x\<in>#M. x<c#}"}, where the latter is currently displayed as
   \<^term>\<open>{#x+x|x\<in>#M. x<c#}\<close>.
 \<close>
 
 lemma in_image_mset: "y \<in># {#f x. x \<in># M#} \<longleftrightarrow> y \<in> f ` set_mset M"
   by simp
 
 functor image_mset: image_mset
 proof -
   fix f g show "image_mset f \<circ> image_mset g = image_mset (f \<circ> g)"
   proof
     fix A
     show "(image_mset f \<circ> image_mset g) A = image_mset (f \<circ> g) A"
       by (induct A) simp_all
   qed
   show "image_mset id = id"
   proof
     fix A
     show "image_mset id A = id A"
       by (induct A) simp_all
   qed
 qed
 
 declare
   image_mset.id [simp]
   image_mset.identity [simp]
 
 lemma image_mset_id[simp]: "image_mset id x = x"
   unfolding id_def by auto
 
 lemma image_mset_cong: "(\<And>x. x \<in># M \<Longrightarrow> f x = g x) \<Longrightarrow> {#f x. x \<in># M#} = {#g x. x \<in># M#}"
   by (induct M) auto
 
 lemma image_mset_cong_pair:
   "(\<forall>x y. (x, y) \<in># M \<longrightarrow> f x y = g x y) \<Longrightarrow> {#f x y. (x, y) \<in># M#} = {#g x y. (x, y) \<in># M#}"
   by (metis image_mset_cong split_cong)
 
 lemma image_mset_const_eq:
   "{#c. a \<in># M#} = replicate_mset (size M) c"
   by (induct M) simp_all
 
 lemma image_mset_filter_mset_swap:
   "image_mset f (filter_mset (\<lambda>x. P (f x)) M) = filter_mset P (image_mset f M)"
   by (induction M rule: multiset_induct) simp_all
 
-
 lemma image_mset_eq_plusD:
   "image_mset f A = B + C \<Longrightarrow> \<exists>B' C'. A = B' + C' \<and> B = image_mset f B' \<and> C = image_mset f C'"
 proof (induction A arbitrary: B C)
   case empty
   thus ?case by simp
 next
   case (add x A)
   show ?case
   proof (cases "f x \<in># B")
     case True
     with add.prems have "image_mset f A = (B - {#f x#}) + C"
       by (metis add_mset_remove_trivial image_mset_add_mset mset_subset_eq_single
           subset_mset.add_diff_assoc2)
     thus ?thesis
       using add.IH add.prems by force
   next
     case False
     with add.prems have "image_mset f A = B + (C - {#f x#})"
       by (metis diff_single_eq_union diff_union_single_conv image_mset_add_mset union_iff
           union_single_eq_member)
     then show ?thesis
       using add.IH add.prems by force
   qed
 qed
 
 lemma image_mset_eq_image_mset_plusD:
   assumes "image_mset f A = image_mset f B + C" and inj_f: "inj_on f (set_mset A \<union> set_mset B)"
   shows "\<exists>C'. A = B + C' \<and> C = image_mset f C'"
   using assms
 proof (induction A arbitrary: B C)
   case empty
   thus ?case by simp
 next
   case (add x A)
   show ?case
   proof (cases "x \<in># B")
     case True
     with add.prems have "image_mset f A = image_mset f (B - {#x#}) + C"
       by (smt (verit, del_insts) add.left_commute add_cancel_right_left diff_union_cancelL
           diff_union_single_conv image_mset_union union_mset_add_mset_left
           union_mset_add_mset_right)
     with add.IH have "\<exists>M3'. A = B - {#x#} + M3' \<and> image_mset f M3' = C"
       by (smt (verit, del_insts) True Un_insert_left Un_insert_right add.prems(2) inj_on_insert
           insert_DiffM set_mset_add_mset_insert)
     with True show ?thesis
       by auto
   next
     case False
     with add.prems(2) have "f x \<notin># image_mset f B"
       by auto
     with add.prems(1) have "image_mset f A = image_mset f B + (C - {#f x#})"
       by (metis (no_types, lifting) diff_union_single_conv image_eqI image_mset_Diff
           image_mset_single mset_subset_eq_single set_image_mset union_iff union_single_eq_diff
           union_single_eq_member)
     with add.prems(2) add.IH have "\<exists>M3'. A = B + M3' \<and> C - {#f x#} = image_mset f M3'"
       by auto
     then show ?thesis
       by (metis add.prems(1) add_diff_cancel_left' image_mset_Diff mset_subset_eq_add_left
           union_mset_add_mset_right)
   qed
 qed
 
 lemma image_mset_eq_plus_image_msetD:
   "image_mset f A = B + image_mset f C \<Longrightarrow> inj_on f (set_mset A \<union> set_mset C) \<Longrightarrow>
   \<exists>B'. A = B' + C \<and> B = image_mset f B'"
   unfolding add.commute[of B] add.commute[of _ C]
   by (rule image_mset_eq_image_mset_plusD; assumption)
 
 
 subsection \<open>Further conversions\<close>
 
 primrec mset :: "'a list \<Rightarrow> 'a multiset" where
   "mset [] = {#}" |
   "mset (a # x) = add_mset a (mset x)"
 
 lemma in_multiset_in_set:
   "x \<in># mset xs \<longleftrightarrow> x \<in> set xs"
   by (induct xs) simp_all
 
 lemma count_mset:
   "count (mset xs) x = length (filter (\<lambda>y. x = y) xs)"
   by (induct xs) simp_all
 
 lemma mset_zero_iff[simp]: "(mset x = {#}) = (x = [])"
   by (induct x) auto
 
 lemma mset_zero_iff_right[simp]: "({#} = mset x) = (x = [])"
 by (induct x) auto
 
 lemma count_mset_gt_0: "x \<in> set xs \<Longrightarrow> count (mset xs) x > 0"
   by (induction xs) auto
 
 lemma count_mset_0_iff [simp]: "count (mset xs) x = 0 \<longleftrightarrow> x \<notin> set xs"
   by (induction xs) auto
 
 lemma mset_single_iff[iff]: "mset xs = {#x#} \<longleftrightarrow> xs = [x]"
   by (cases xs) auto
 
 lemma mset_single_iff_right[iff]: "{#x#} = mset xs \<longleftrightarrow> xs = [x]"
   by (cases xs) auto
 
 lemma set_mset_mset[simp]: "set_mset (mset xs) = set xs"
   by (induct xs) auto
 
 lemma set_mset_comp_mset [simp]: "set_mset \<circ> mset = set"
   by (simp add: fun_eq_iff)
 
 lemma size_mset [simp]: "size (mset xs) = length xs"
   by (induct xs) simp_all
 
 lemma mset_append [simp]: "mset (xs @ ys) = mset xs + mset ys"
   by (induct xs arbitrary: ys) auto
 
 lemma mset_filter[simp]: "mset (filter P xs) = {#x \<in># mset xs. P x #}"
   by (induct xs) simp_all
 
 lemma mset_rev [simp]:
   "mset (rev xs) = mset xs"
   by (induct xs) simp_all
 
 lemma surj_mset: "surj mset"
   unfolding surj_def
 proof (rule allI)
   fix M
   show "\<exists>xs. M = mset xs"
     by (induction M) (auto intro: exI[of _ "_ # _"])
 qed
 
 lemma distinct_count_atmost_1:
   "distinct x = (\<forall>a. count (mset x) a = (if a \<in> set x then 1 else 0))"
 proof (induct x)
   case Nil then show ?case by simp
 next
   case (Cons x xs) show ?case (is "?lhs \<longleftrightarrow> ?rhs")
   proof
     assume ?lhs then show ?rhs using Cons by simp
   next
     assume ?rhs then have "x \<notin> set xs"
       by (simp split: if_splits)
     moreover from \<open>?rhs\<close> have "(\<forall>a. count (mset xs) a =
        (if a \<in> set xs then 1 else 0))"
       by (auto split: if_splits simp add: count_eq_zero_iff)
     ultimately show ?lhs using Cons by simp
   qed
 qed
 
 lemma mset_eq_setD:
   assumes "mset xs = mset ys"
   shows "set xs = set ys"
 proof -
   from assms have "set_mset (mset xs) = set_mset (mset ys)"
     by simp
   then show ?thesis by simp
 qed
 
 lemma set_eq_iff_mset_eq_distinct:
   \<open>distinct x \<Longrightarrow> distinct y \<Longrightarrow> set x = set y \<longleftrightarrow> mset x = mset y\<close>
   by (auto simp: multiset_eq_iff distinct_count_atmost_1)
 
 lemma set_eq_iff_mset_remdups_eq:
   \<open>set x = set y \<longleftrightarrow> mset (remdups x) = mset (remdups y)\<close>
 apply (rule iffI)
 apply (simp add: set_eq_iff_mset_eq_distinct[THEN iffD1])
 apply (drule distinct_remdups [THEN distinct_remdups
       [THEN set_eq_iff_mset_eq_distinct [THEN iffD2]]])
 apply simp
 done
 
 lemma mset_eq_imp_distinct_iff:
   \<open>distinct xs \<longleftrightarrow> distinct ys\<close> if \<open>mset xs = mset ys\<close>
   using that by (auto simp add: distinct_count_atmost_1 dest: mset_eq_setD)
 
 lemma nth_mem_mset: "i < length ls \<Longrightarrow> (ls ! i) \<in># mset ls"
 proof (induct ls arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma mset_remove1[simp]: "mset (remove1 a xs) = mset xs - {#a#}"
   by (induct xs) (auto simp add: multiset_eq_iff)
 
 lemma mset_eq_length:
   assumes "mset xs = mset ys"
   shows "length xs = length ys"
   using assms by (metis size_mset)
 
 lemma mset_eq_length_filter:
   assumes "mset xs = mset ys"
   shows "length (filter (\<lambda>x. z = x) xs) = length (filter (\<lambda>y. z = y) ys)"
   using assms by (metis count_mset)
 
 lemma fold_multiset_equiv:
   \<open>List.fold f xs = List.fold f ys\<close>
     if f: \<open>\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x\<close>
     and \<open>mset xs = mset ys\<close>
 using f \<open>mset xs = mset ys\<close> [symmetric] proof (induction xs arbitrary: ys)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   then have *: \<open>set ys = set (x # xs)\<close>
     by (blast dest: mset_eq_setD)
   have \<open>\<And>x y. x \<in> set ys \<Longrightarrow> y \<in> set ys \<Longrightarrow> f x \<circ> f y = f y \<circ> f x\<close>
     by (rule Cons.prems(1)) (simp_all add: *)
   moreover from * have \<open>x \<in> set ys\<close>
     by simp
   ultimately have \<open>List.fold f ys = List.fold f (remove1 x ys) \<circ> f x\<close>
     by (fact fold_remove1_split)
   moreover from Cons.prems have \<open>List.fold f xs = List.fold f (remove1 x ys)\<close>
     by (auto intro: Cons.IH)
   ultimately show ?case
     by simp
 qed
 
 lemma fold_permuted_eq:
   \<open>List.fold (\<odot>) xs z = List.fold (\<odot>) ys z\<close>
     if \<open>mset xs = mset ys\<close>
     and \<open>P z\<close> and P: \<open>\<And>x z. x \<in> set xs \<Longrightarrow> P z \<Longrightarrow> P (x \<odot> z)\<close>
     and f: \<open>\<And>x y z. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> P z \<Longrightarrow> x \<odot> (y \<odot> z) = y \<odot> (x \<odot> z)\<close>
   for f (infixl \<open>\<odot>\<close> 70)
 using \<open>P z\<close> P f \<open>mset xs = mset ys\<close> [symmetric] proof (induction xs arbitrary: ys z)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   then have *: \<open>set ys = set (x # xs)\<close>
     by (blast dest: mset_eq_setD)
   have \<open>P z\<close>
     by (fact Cons.prems(1))
   moreover have \<open>\<And>x z. x \<in> set ys \<Longrightarrow> P z \<Longrightarrow> P (x \<odot> z)\<close>
     by (rule Cons.prems(2)) (simp_all add: *)
   moreover have \<open>\<And>x y z. x \<in> set ys \<Longrightarrow> y \<in> set ys \<Longrightarrow> P z \<Longrightarrow> x \<odot> (y \<odot> z) = y \<odot> (x \<odot> z)\<close>
     by (rule Cons.prems(3)) (simp_all add: *)
   moreover from * have \<open>x \<in> set ys\<close>
     by simp
   ultimately have \<open>fold (\<odot>) ys z = fold (\<odot>) (remove1 x ys) (x \<odot> z)\<close>
     by (induction ys arbitrary: z) auto
   moreover from Cons.prems have \<open>fold (\<odot>) xs (x \<odot> z) = fold (\<odot>) (remove1 x ys) (x \<odot> z)\<close>
     by (auto intro: Cons.IH)
   ultimately show ?case
     by simp
 qed
 
 lemma mset_shuffles: "zs \<in> shuffles xs ys \<Longrightarrow> mset zs = mset xs + mset ys"
   by (induction xs ys arbitrary: zs rule: shuffles.induct) auto
 
 lemma mset_insort [simp]: "mset (insort x xs) = add_mset x (mset xs)"
   by (induct xs) simp_all
 
 lemma mset_map[simp]: "mset (map f xs) = image_mset f (mset xs)"
   by (induct xs) simp_all
 
 global_interpretation mset_set: folding add_mset "{#}"
   defines mset_set = "folding_on.F add_mset {#}"
   by standard (simp add: fun_eq_iff)
 
 lemma sum_multiset_singleton [simp]: "sum (\<lambda>n. {#n#}) A = mset_set A"
   by (induction A rule: infinite_finite_induct) auto
 
 lemma count_mset_set [simp]:
   "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> count (mset_set A) x = 1" (is "PROP ?P")
   "\<not> finite A \<Longrightarrow> count (mset_set A) x = 0" (is "PROP ?Q")
   "x \<notin> A \<Longrightarrow> count (mset_set A) x = 0" (is "PROP ?R")
 proof -
   have *: "count (mset_set A) x = 0" if "x \<notin> A" for A
   proof (cases "finite A")
     case False then show ?thesis by simp
   next
     case True from True \<open>x \<notin> A\<close> show ?thesis by (induct A) auto
   qed
   then show "PROP ?P" "PROP ?Q" "PROP ?R"
   by (auto elim!: Set.set_insert)
 qed \<comment> \<open>TODO: maybe define \<^const>\<open>mset_set\<close> also in terms of \<^const>\<open>Abs_multiset\<close>\<close>
 
 lemma elem_mset_set[simp, intro]: "finite A \<Longrightarrow> x \<in># mset_set A \<longleftrightarrow> x \<in> A"
   by (induct A rule: finite_induct) simp_all
 
 lemma mset_set_Union:
   "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<inter> B = {} \<Longrightarrow> mset_set (A \<union> B) = mset_set A + mset_set B"
   by (induction A rule: finite_induct) auto
 
 lemma filter_mset_mset_set [simp]:
   "finite A \<Longrightarrow> filter_mset P (mset_set A) = mset_set {x\<in>A. P x}"
 proof (induction A rule: finite_induct)
   case (insert x A)
   from insert.hyps have "filter_mset P (mset_set (insert x A)) =
       filter_mset P (mset_set A) + mset_set (if P x then {x} else {})"
     by simp
   also have "filter_mset P (mset_set A) = mset_set {x\<in>A. P x}"
     by (rule insert.IH)
   also from insert.hyps
     have "\<dots> + mset_set (if P x then {x} else {}) =
             mset_set ({x \<in> A. P x} \<union> (if P x then {x} else {}))" (is "_ = mset_set ?A")
      by (intro mset_set_Union [symmetric]) simp_all
   also from insert.hyps have "?A = {y\<in>insert x A. P y}" by auto
   finally show ?case .
 qed simp_all
 
 lemma mset_set_Diff:
   assumes "finite A" "B \<subseteq> A"
   shows  "mset_set (A - B) = mset_set A - mset_set B"
 proof -
   from assms have "mset_set ((A - B) \<union> B) = mset_set (A - B) + mset_set B"
     by (intro mset_set_Union) (auto dest: finite_subset)
   also from assms have "A - B \<union> B = A" by blast
   finally show ?thesis by simp
 qed
 
 lemma mset_set_set: "distinct xs \<Longrightarrow> mset_set (set xs) = mset xs"
   by (induction xs) simp_all
 
 lemma count_mset_set': "count (mset_set A) x = (if finite A \<and> x \<in> A then 1 else 0)"
   by auto
 
 lemma subset_imp_msubset_mset_set: 
   assumes "A \<subseteq> B" "finite B"
   shows   "mset_set A \<subseteq># mset_set B"
 proof (rule mset_subset_eqI)
   fix x :: 'a
   from assms have "finite A" by (rule finite_subset)
   with assms show "count (mset_set A) x \<le> count (mset_set B) x"
     by (cases "x \<in> A"; cases "x \<in> B") auto
 qed
 
 lemma mset_set_set_mset_msubset: "mset_set (set_mset A) \<subseteq># A"
 proof (rule mset_subset_eqI)
   fix x show "count (mset_set (set_mset A)) x \<le> count A x"
     by (cases "x \<in># A") simp_all
 qed
 
 lemma mset_set_upto_eq_mset_upto:
   \<open>mset_set {..<n} = mset [0..<n]\<close>
   by (induction n) (auto simp: ac_simps lessThan_Suc)
 
 context linorder
 begin
 
 definition sorted_list_of_multiset :: "'a multiset \<Rightarrow> 'a list"
 where
   "sorted_list_of_multiset M = fold_mset insort [] M"
 
 lemma sorted_list_of_multiset_empty [simp]:
   "sorted_list_of_multiset {#} = []"
   by (simp add: sorted_list_of_multiset_def)
 
 lemma sorted_list_of_multiset_singleton [simp]:
   "sorted_list_of_multiset {#x#} = [x]"
 proof -
   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
   show ?thesis by (simp add: sorted_list_of_multiset_def)
 qed
 
 lemma sorted_list_of_multiset_insert [simp]:
   "sorted_list_of_multiset (add_mset x M) = List.insort x (sorted_list_of_multiset M)"
 proof -
   interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
   show ?thesis by (simp add: sorted_list_of_multiset_def)
 qed
 
 end
 
 lemma mset_sorted_list_of_multiset[simp]: "mset (sorted_list_of_multiset M) = M"
   by (induct M) simp_all
 
 lemma sorted_list_of_multiset_mset[simp]: "sorted_list_of_multiset (mset xs) = sort xs"
   by (induct xs) simp_all
 
 lemma finite_set_mset_mset_set[simp]: "finite A \<Longrightarrow> set_mset (mset_set A) = A"
   by auto
 
 lemma mset_set_empty_iff: "mset_set A = {#} \<longleftrightarrow> A = {} \<or> infinite A"
   using finite_set_mset_mset_set by fastforce
 
 lemma infinite_set_mset_mset_set: "\<not> finite A \<Longrightarrow> set_mset (mset_set A) = {}"
   by simp
 
 lemma set_sorted_list_of_multiset [simp]:
   "set (sorted_list_of_multiset M) = set_mset M"
 by (induct M) (simp_all add: set_insort_key)
 
 lemma sorted_list_of_mset_set [simp]:
   "sorted_list_of_multiset (mset_set A) = sorted_list_of_set A"
 by (cases "finite A") (induct A rule: finite_induct, simp_all)
 
 lemma mset_upt [simp]: "mset [m..<n] = mset_set {m..<n}"
   by (induction n) (simp_all add: atLeastLessThanSuc)
 
 lemma image_mset_map_of:
   "distinct (map fst xs) \<Longrightarrow> {#the (map_of xs i). i \<in># mset (map fst xs)#} = mset (map snd xs)"
 proof (induction xs)
   case (Cons x xs)
   have "{#the (map_of (x # xs) i). i \<in># mset (map fst (x # xs))#} =
           add_mset (snd x) {#the (if i = fst x then Some (snd x) else map_of xs i).
              i \<in># mset (map fst xs)#}" (is "_ = add_mset _ ?A") by simp
   also from Cons.prems have "?A = {#the (map_of xs i). i :# mset (map fst xs)#}"
     by (cases x, intro image_mset_cong) (auto simp: in_multiset_in_set)
   also from Cons.prems have "\<dots> = mset (map snd xs)" by (intro Cons.IH) simp_all
   finally show ?case by simp
 qed simp_all
 
 lemma msubset_mset_set_iff[simp]:
   assumes "finite A" "finite B"
   shows "mset_set A \<subseteq># mset_set B \<longleftrightarrow> A \<subseteq> B"
   using assms set_mset_mono subset_imp_msubset_mset_set by fastforce
 
 lemma mset_set_eq_iff[simp]:
   assumes "finite A" "finite B"
   shows "mset_set A = mset_set B \<longleftrightarrow> A = B"
   using assms by (fastforce dest: finite_set_mset_mset_set)
 
 lemma image_mset_mset_set: \<^marker>\<open>contributor \<open>Lukas Bulwahn\<close>\<close>
   assumes "inj_on f A"
   shows "image_mset f (mset_set A) = mset_set (f ` A)"
 proof cases
   assume "finite A"
   from this \<open>inj_on f A\<close> show ?thesis
     by (induct A) auto
 next
   assume "infinite A"
   from this \<open>inj_on f A\<close> have "infinite (f ` A)"
     using finite_imageD by blast
   from \<open>infinite A\<close> \<open>infinite (f ` A)\<close> show ?thesis by simp
 qed
 
 
-subsection \<open>More properties of the replicate and repeat operations\<close>
+subsection \<open>More properties of the replicate, repeat, and image operations\<close>
 
 lemma in_replicate_mset[simp]: "x \<in># replicate_mset n y \<longleftrightarrow> n > 0 \<and> x = y"
   unfolding replicate_mset_def by (induct n) auto
 
 lemma set_mset_replicate_mset_subset[simp]: "set_mset (replicate_mset n x) = (if n = 0 then {} else {x})"
   by (auto split: if_splits)
 
 lemma size_replicate_mset[simp]: "size (replicate_mset n M) = n"
   by (induct n, simp_all)
 
 lemma count_le_replicate_mset_subset_eq: "n \<le> count M x \<longleftrightarrow> replicate_mset n x \<subseteq># M"
   by (auto simp add: mset_subset_eqI) (metis count_replicate_mset subseteq_mset_def)
 
-lemma filter_eq_replicate_mset: "{#y \<in># D. y = x#} = replicate_mset (count D x) x"
-  by (induct D) simp_all
-
 lemma replicate_count_mset_eq_filter_eq: "replicate (count (mset xs) k) k = filter (HOL.eq k) xs"
   by (induct xs) auto
 
 lemma replicate_mset_eq_empty_iff [simp]: "replicate_mset n a = {#} \<longleftrightarrow> n = 0"
   by (induct n) simp_all
 
 lemma replicate_mset_eq_iff:
   "replicate_mset m a = replicate_mset n b \<longleftrightarrow> m = 0 \<and> n = 0 \<or> m = n \<and> a = b"
   by (auto simp add: multiset_eq_iff)
 
 lemma repeat_mset_cancel1: "repeat_mset a A = repeat_mset a B \<longleftrightarrow> A = B \<or> a = 0"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_cancel2: "repeat_mset a A = repeat_mset b A \<longleftrightarrow> a = b \<or> A = {#}"
   by (auto simp: multiset_eq_iff)
 
 lemma repeat_mset_eq_empty_iff: "repeat_mset n A = {#} \<longleftrightarrow> n = 0 \<or> A = {#}"
   by (cases n) auto
 
 lemma image_replicate_mset [simp]:
   "image_mset f (replicate_mset n a) = replicate_mset n (f a)"
   by (induct n) simp_all
 
 lemma replicate_mset_msubseteq_iff:
   "replicate_mset m a \<subseteq># replicate_mset n b \<longleftrightarrow> m = 0 \<or> a = b \<and> m \<le> n"
   by (cases m)
     (auto simp: insert_subset_eq_iff simp flip: count_le_replicate_mset_subset_eq)
 
 lemma msubseteq_replicate_msetE:
   assumes "A \<subseteq># replicate_mset n a"
   obtains m where "m \<le> n" and "A = replicate_mset m a"
 proof (cases "n = 0")
   case True
   with assms that show thesis
     by simp
 next
   case False
   from assms have "set_mset A \<subseteq> set_mset (replicate_mset n a)"
     by (rule set_mset_mono)
   with False have "set_mset A \<subseteq> {a}"
     by simp
   then have "\<exists>m. A = replicate_mset m a"
   proof (induction A)
     case empty
     then show ?case
       by simp
   next
     case (add b A)
     then obtain m where "A = replicate_mset m a"
       by auto
     with add.prems show ?case
       by (auto intro: exI [of _ "Suc m"])
   qed
   then obtain m where A: "A = replicate_mset m a" ..
   with assms have "m \<le> n"
     by (auto simp add: replicate_mset_msubseteq_iff)
   then show thesis using A ..
 qed
 
+lemma count_image_mset_lt_imp_lt_raw:
+  assumes
+    "finite A" and
+    "A = set_mset M \<union> set_mset N" and
+    "count (image_mset f M) b < count (image_mset f N) b"
+  shows "\<exists>x. f x = b \<and> count M x < count N x"
+  using assms
+proof (induct A arbitrary: M N b rule: finite_induct)
+  case (insert x F)
+  note fin = this(1) and x_ni_f = this(2) and ih = this(3) and x_f_eq_m_n = this(4) and
+    cnt_b = this(5)
+
+  let ?Ma = "{#y \<in># M. y \<noteq> x#}"
+  let ?Mb = "{#y \<in># M. y = x#}"
+  let ?Na = "{#y \<in># N. y \<noteq> x#}"
+  let ?Nb = "{#y \<in># N. y = x#}"
+
+  have m_part: "M = ?Mb + ?Ma" and n_part: "N = ?Nb + ?Na"
+    using multiset_partition by blast+
+
+  have f_eq_ma_na: "F = set_mset ?Ma \<union> set_mset ?Na"
+    using x_f_eq_m_n x_ni_f by auto
+
+  show ?case
+  proof (cases "count (image_mset f ?Ma) b < count (image_mset f ?Na) b")
+    case cnt_ba: True
+    obtain xa where "f xa = b" and "count ?Ma xa < count ?Na xa"
+      using ih[OF f_eq_ma_na cnt_ba] by blast
+    thus ?thesis
+      by (metis count_filter_mset not_less0)
+  next
+    case cnt_ba: False
+    have fx_eq_b: "f x = b"
+      using cnt_b cnt_ba
+      by (subst (asm) m_part, subst (asm) n_part,
+          auto simp: filter_eq_replicate_mset split: if_splits)
+    moreover have "count M x < count N x"
+      using cnt_b cnt_ba
+      by (subst (asm) m_part, subst (asm) n_part,
+          auto simp: filter_eq_replicate_mset split: if_splits)
+    ultimately show ?thesis
+      by blast
+  qed
+qed auto
+
+lemma count_image_mset_lt_imp_lt:
+  assumes cnt_b: "count (image_mset f M) b < count (image_mset f N) b"
+  shows "\<exists>x. f x = b \<and> count M x < count N x"
+  by (rule count_image_mset_lt_imp_lt_raw[of "set_mset M \<union> set_mset N", OF _ refl cnt_b]) auto
+
+lemma count_image_mset_le_imp_lt_raw:
+  assumes
+    "finite A" and
+    "A = set_mset M \<union> set_mset N" and
+    "count (image_mset f M) (f a) + count N a < count (image_mset f N) (f a) + count M a"
+  shows "\<exists>b. f b = f a \<and> count M b < count N b"
+  using assms
+proof (induct A arbitrary: M N rule: finite_induct)
+  case (insert x F)
+  note fin = this(1) and x_ni_f = this(2) and ih = this(3) and x_f_eq_m_n = this(4) and
+    cnt_lt = this(5)
+
+  let ?Ma = "{#y \<in># M. y \<noteq> x#}"
+  let ?Mb = "{#y \<in># M. y = x#}"
+  let ?Na = "{#y \<in># N. y \<noteq> x#}"
+  let ?Nb = "{#y \<in># N. y = x#}"
+
+  have m_part: "M = ?Mb + ?Ma" and n_part: "N = ?Nb + ?Na"
+    using multiset_partition by blast+
+
+  have f_eq_ma_na: "F = set_mset ?Ma \<union> set_mset ?Na"
+    using x_f_eq_m_n x_ni_f by auto
+
+  show ?case
+  proof (cases "f x = f a")
+    case fx_ne_fa: False
+
+    have cnt_fma_fa: "count (image_mset f ?Ma) (f a) = count (image_mset f M) (f a)"
+      using fx_ne_fa by (subst (2) m_part) (auto simp: filter_eq_replicate_mset)
+    have cnt_fna_fa: "count (image_mset f ?Na) (f a) = count (image_mset f N) (f a)"
+      using fx_ne_fa by (subst (2) n_part) (auto simp: filter_eq_replicate_mset)
+    have cnt_ma_a: "count ?Ma a = count M a"
+      using fx_ne_fa by (subst (2) m_part) (auto simp: filter_eq_replicate_mset)
+    have cnt_na_a: "count ?Na a = count N a"
+      using fx_ne_fa by (subst (2) n_part) (auto simp: filter_eq_replicate_mset)
+
+    obtain b where fb_eq_fa: "f b = f a" and cnt_b: "count ?Ma b < count ?Na b"
+      using ih[OF f_eq_ma_na] cnt_lt unfolding cnt_fma_fa cnt_fna_fa cnt_ma_a cnt_na_a by blast
+    have fx_ne_fb: "f x \<noteq> f b"
+      using fb_eq_fa fx_ne_fa by simp
+
+    have cnt_ma_b: "count ?Ma b = count M b"
+      using fx_ne_fb by (subst (2) m_part) auto
+    have cnt_na_b: "count ?Na b = count N b"
+      using fx_ne_fb by (subst (2) n_part) auto
+
+    show ?thesis
+      using fb_eq_fa cnt_b unfolding cnt_ma_b cnt_na_b by blast
+  next
+    case fx_eq_fa: True
+    show ?thesis
+    proof (cases "x = a")
+      case x_eq_a: True
+      have "count (image_mset f ?Ma) (f a) + count ?Na a
+        < count (image_mset f ?Na) (f a) + count ?Ma a"
+        using cnt_lt x_eq_a by (subst (asm) (1 2) m_part, subst (asm) (1 2) n_part,
+            auto simp: filter_eq_replicate_mset)
+      thus ?thesis
+        using ih[OF f_eq_ma_na] by (metis count_filter_mset nat_neq_iff)
+    next
+      case x_ne_a: False
+      show ?thesis
+      proof (cases "count M x < count N x")
+        case True
+        thus ?thesis
+          using fx_eq_fa by blast
+     next
+        case False
+        hence cnt_x: "count M x \<ge> count N x"
+          by fastforce
+        have "count M x + count (image_mset f ?Ma) (f a) + count ?Na a
+          < count N x + count (image_mset f ?Na) (f a) + count ?Ma a"
+          using cnt_lt x_ne_a fx_eq_fa by (subst (asm) (1 2) m_part, subst (asm) (1 2) n_part,
+            auto simp: filter_eq_replicate_mset)
+        hence "count (image_mset f ?Ma) (f a) + count ?Na a
+          < count (image_mset f ?Na) (f a) + count ?Ma a"
+          using cnt_x by linarith
+        thus ?thesis
+          using ih[OF f_eq_ma_na] by (metis count_filter_mset nat_neq_iff)
+      qed
+    qed
+  qed
+qed auto
+
+lemma count_image_mset_le_imp_lt:
+  assumes
+    "count (image_mset f M) (f a) \<le> count (image_mset f N) (f a)" and
+    "count M a > count N a"
+  shows "\<exists>b. f b = f a \<and> count M b < count N b"
+  using assms by (auto intro: count_image_mset_le_imp_lt_raw[of "set_mset M \<union> set_mset N"])
+
+lemma size_filter_unsat_elem:
+  assumes "x \<in># M" and "\<not> P x"
+  shows "size {#x \<in># M. P x#} < size M"
+proof -
+  have "size (filter_mset P M) \<noteq> size M"
+    using assms by (metis add.right_neutral add_diff_cancel_left' count_filter_mset mem_Collect_eq
+      multiset_partition nonempty_has_size set_mset_def size_union)
+  then show ?thesis
+    by (meson leD nat_neq_iff size_filter_mset_lesseq)
+qed
+
+lemma size_filter_ne_elem: "x \<in># M \<Longrightarrow> size {#y \<in># M. y \<noteq> x#} < size M"
+  by (simp add: size_filter_unsat_elem[of x M "\<lambda>y. y \<noteq> x"])
+
+lemma size_eq_ex_count_lt:
+  assumes
+    sz_m_eq_n: "size M = size N" and
+    m_eq_n: "M \<noteq> N"
+  shows "\<exists>x. count M x < count N x"
+proof -
+  obtain x where "count M x \<noteq> count N x"
+    using m_eq_n by (meson multiset_eqI)
+  moreover
+  {
+    assume "count M x < count N x"
+    hence ?thesis
+      by blast
+  }
+  moreover
+  {
+    assume cnt_x: "count M x > count N x"
+
+    have "size {#y \<in># M. y = x#} + size {#y \<in># M. y \<noteq> x#} =
+      size {#y \<in># N. y = x#} + size {#y \<in># N. y \<noteq> x#}"
+      using sz_m_eq_n multiset_partition by (metis size_union)
+    hence sz_m_minus_x: "size {#y \<in># M. y \<noteq> x#} < size {#y \<in># N. y \<noteq> x#}"
+      using cnt_x by (simp add: filter_eq_replicate_mset)
+    then obtain y where "count {#y \<in># M. y \<noteq> x#} y < count {#y \<in># N. y \<noteq> x#} y"
+      using size_lt_imp_ex_count_lt[OF sz_m_minus_x] by blast
+    hence "count M y < count N y"
+      by (metis count_filter_mset less_asym)
+    hence ?thesis
+      by blast
+  }
+  ultimately show ?thesis
+    by fastforce
+qed
+
 
 subsection \<open>Big operators\<close>
 
 locale comm_monoid_mset = comm_monoid
 begin
 
 interpretation comp_fun_commute f
   by standard (simp add: fun_eq_iff left_commute)
 
 interpretation comp?: comp_fun_commute "f \<circ> g"
   by (fact comp_comp_fun_commute)
 
 context
 begin
 
 definition F :: "'a multiset \<Rightarrow> 'a"
   where eq_fold: "F M = fold_mset f \<^bold>1 M"
 
 lemma empty [simp]: "F {#} = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma singleton [simp]: "F {#x#} = x"
 proof -
   interpret comp_fun_commute
     by standard (simp add: fun_eq_iff left_commute)
   show ?thesis by (simp add: eq_fold)
 qed
 
 lemma union [simp]: "F (M + N) = F M \<^bold>* F N"
 proof -
   interpret comp_fun_commute f
     by standard (simp add: fun_eq_iff left_commute)
   show ?thesis
     by (induct N) (simp_all add: left_commute eq_fold)
 qed
 
 lemma add_mset [simp]: "F (add_mset x N) = x \<^bold>* F N"
   unfolding add_mset_add_single[of x N] union by (simp add: ac_simps)
 
 lemma insert [simp]:
   shows "F (image_mset g (add_mset x A)) = g x \<^bold>* F (image_mset g A)"
   by (simp add: eq_fold)
 
 lemma remove:
   assumes "x \<in># A"
   shows "F A = x \<^bold>* F (A - {#x#})"
   using multi_member_split[OF assms] by auto
 
 lemma neutral:
   "\<forall>x\<in>#A. x = \<^bold>1 \<Longrightarrow> F A = \<^bold>1"
   by (induct A) simp_all
 
 lemma neutral_const [simp]:
   "F (image_mset (\<lambda>_. \<^bold>1) A) = \<^bold>1"
   by (simp add: neutral)
 
 private lemma F_image_mset_product:
   "F {#g x j \<^bold>* F {#g i j. i \<in># A#}. j \<in># B#} =
     F (image_mset (g x) B) \<^bold>* F {#F {#g i j. i \<in># A#}. j \<in># B#}"
   by (induction B) (simp_all add: left_commute semigroup.assoc semigroup_axioms)
 
 lemma swap:
   "F (image_mset (\<lambda>i. F (image_mset (g i) B)) A) =
     F (image_mset (\<lambda>j. F (image_mset (\<lambda>i. g i j) A)) B)"
   apply (induction A, simp)
   apply (induction B, auto simp add: F_image_mset_product ac_simps)
   done
 
 lemma distrib: "F (image_mset (\<lambda>x. g x \<^bold>* h x) A) = F (image_mset g A) \<^bold>* F (image_mset h A)"
   by (induction A) (auto simp: ac_simps)
 
 lemma union_disjoint:
   "A \<inter># B = {#} \<Longrightarrow> F (image_mset g (A \<union># B)) = F (image_mset g A) \<^bold>* F (image_mset g B)"
   by (induction A) (auto simp: ac_simps)
 
 end
 end
 
 lemma comp_fun_commute_plus_mset[simp]: "comp_fun_commute ((+) :: 'a multiset \<Rightarrow> _ \<Rightarrow> _)"
   by standard (simp add: add_ac comp_def)
 
 declare comp_fun_commute.fold_mset_add_mset[OF comp_fun_commute_plus_mset, simp]
 
 lemma in_mset_fold_plus_iff[iff]: "x \<in># fold_mset (+) M NN \<longleftrightarrow> x \<in># M \<or> (\<exists>N. N \<in># NN \<and> x \<in># N)"
   by (induct NN) auto
 
 context comm_monoid_add
 begin
 
 sublocale sum_mset: comm_monoid_mset plus 0
   defines sum_mset = sum_mset.F ..
 
 lemma sum_unfold_sum_mset:
   "sum f A = sum_mset (image_mset f (mset_set A))"
   by (cases "finite A") (induct A rule: finite_induct, simp_all)
 
 end
 
 notation sum_mset ("\<Sum>\<^sub>#")
 
 syntax (ASCII)
   "_sum_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"  ("(3SUM _:#_. _)" [0, 51, 10] 10)
 syntax
   "_sum_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_add"  ("(3\<Sum>_\<in>#_. _)" [0, 51, 10] 10)
 translations
   "\<Sum>i \<in># A. b" \<rightleftharpoons> "CONST sum_mset (CONST image_mset (\<lambda>i. b) A)"
 
 context comm_monoid_add
 begin
 
 lemma sum_mset_sum_list:
   "sum_mset (mset xs) = sum_list xs"
   by (induction xs) auto
 
 end
 
 context canonically_ordered_monoid_add
 begin
 
 lemma sum_mset_0_iff [simp]:
   "sum_mset M = 0  \<longleftrightarrow> (\<forall>x \<in> set_mset M. x = 0)"
   by (induction M) auto
 
 end
 
 context ordered_comm_monoid_add
 begin
 
 lemma sum_mset_mono:
   "sum_mset (image_mset f K) \<le> sum_mset (image_mset g K)"
   if "\<And>i. i \<in># K \<Longrightarrow> f i \<le> g i"
   using that by (induction K) (simp_all add: add_mono)
 
 end
 
 context cancel_comm_monoid_add
 begin
 
 lemma sum_mset_diff:
   "sum_mset (M - N) = sum_mset M - sum_mset N" if "N \<subseteq># M" for M N :: "'a multiset"
   using that by (auto simp add: subset_mset.le_iff_add)
 
 end
 
 context semiring_0
 begin
 
 lemma sum_mset_distrib_left:
   "c * (\<Sum>x \<in># M. f x) = (\<Sum>x \<in># M. c * f(x))"
   by (induction M) (simp_all add: algebra_simps)
 
 lemma sum_mset_distrib_right:
   "(\<Sum>x \<in># M. f x) * c = (\<Sum>x \<in># M. f x * c)"
   by (induction M) (simp_all add: algebra_simps)
 
 end
 
 lemma sum_mset_product:
   fixes f :: "'a::{comm_monoid_add,times} \<Rightarrow> 'b::semiring_0"
   shows "(\<Sum>i \<in># A. f i) * (\<Sum>i \<in># B. g i) = (\<Sum>i\<in>#A. \<Sum>j\<in>#B. f i * g j)"
   by (subst sum_mset.swap) (simp add: sum_mset_distrib_left sum_mset_distrib_right)
 
 context semiring_1
 begin
 
 lemma sum_mset_replicate_mset [simp]:
   "sum_mset (replicate_mset n a) = of_nat n * a"
   by (induction n) (simp_all add: algebra_simps)
 
 lemma sum_mset_delta:
   "sum_mset (image_mset (\<lambda>x. if x = y then c else 0) A) = c * of_nat (count A y)"
   by (induction A) (simp_all add: algebra_simps)
 
 lemma sum_mset_delta':
   "sum_mset (image_mset (\<lambda>x. if y = x then c else 0) A) = c * of_nat (count A y)"
   by (induction A) (simp_all add: algebra_simps)
 
 end
 
 lemma of_nat_sum_mset [simp]:
   "of_nat (sum_mset A) = sum_mset (image_mset of_nat A)"
   by (induction A) auto
 
 lemma size_eq_sum_mset:
   "size M = (\<Sum>a\<in>#M. 1)"
   using image_mset_const_eq [of "1::nat" M] by simp
 
 lemma size_mset_set [simp]:
   "size (mset_set A) = card A"
   by (simp only: size_eq_sum_mset card_eq_sum sum_unfold_sum_mset)
 
 lemma sum_mset_constant [simp]:
   fixes y :: "'b::semiring_1"
   shows \<open>(\<Sum>x\<in>#A. y) = of_nat (size A) * y\<close>
   by (induction A) (auto simp: algebra_simps)
 
 lemma set_mset_Union_mset[simp]: "set_mset (\<Sum>\<^sub># MM) = (\<Union>M \<in> set_mset MM. set_mset M)"
   by (induct MM) auto
 
 lemma in_Union_mset_iff[iff]: "x \<in># \<Sum>\<^sub># MM \<longleftrightarrow> (\<exists>M. M \<in># MM \<and> x \<in># M)"
   by (induct MM) auto
 
 lemma count_sum:
   "count (sum f A) x = sum (\<lambda>a. count (f a) x) A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma sum_eq_empty_iff:
   assumes "finite A"
   shows "sum f A = {#} \<longleftrightarrow> (\<forall>a\<in>A. f a = {#})"
   using assms by induct simp_all
 
 lemma Union_mset_empty_conv[simp]: "\<Sum>\<^sub># M = {#} \<longleftrightarrow> (\<forall>i\<in>#M. i = {#})"
   by (induction M) auto
 
 lemma Union_image_single_mset[simp]: "\<Sum>\<^sub># (image_mset (\<lambda>x. {#x#}) m) = m"
 by(induction m) auto
 
-
 context comm_monoid_mult
 begin
 
 sublocale prod_mset: comm_monoid_mset times 1
   defines prod_mset = prod_mset.F ..
 
 lemma prod_mset_empty:
   "prod_mset {#} = 1"
   by (fact prod_mset.empty)
 
 lemma prod_mset_singleton:
   "prod_mset {#x#} = x"
   by (fact prod_mset.singleton)
 
 lemma prod_mset_Un:
   "prod_mset (A + B) = prod_mset A * prod_mset B"
   by (fact prod_mset.union)
 
 lemma prod_mset_prod_list:
   "prod_mset (mset xs) = prod_list xs"
   by (induct xs) auto
 
 lemma prod_mset_replicate_mset [simp]:
   "prod_mset (replicate_mset n a) = a ^ n"
   by (induct n) simp_all
 
 lemma prod_unfold_prod_mset:
   "prod f A = prod_mset (image_mset f (mset_set A))"
   by (cases "finite A") (induct A rule: finite_induct, simp_all)
 
 lemma prod_mset_multiplicity:
   "prod_mset M = prod (\<lambda>x. x ^ count M x) (set_mset M)"
   by (simp add: fold_mset_def prod.eq_fold prod_mset.eq_fold funpow_times_power comp_def)
 
 lemma prod_mset_delta: "prod_mset (image_mset (\<lambda>x. if x = y then c else 1) A) = c ^ count A y"
   by (induction A) simp_all
 
 lemma prod_mset_delta': "prod_mset (image_mset (\<lambda>x. if y = x then c else 1) A) = c ^ count A y"
   by (induction A) simp_all
 
 lemma prod_mset_subset_imp_dvd:
   assumes "A \<subseteq># B"
   shows   "prod_mset A dvd prod_mset B"
 proof -
   from assms have "B = (B - A) + A" by (simp add: subset_mset.diff_add)
   also have "prod_mset \<dots> = prod_mset (B - A) * prod_mset A" by simp
   also have "prod_mset A dvd \<dots>" by simp
   finally show ?thesis .
 qed
 
 lemma dvd_prod_mset:
   assumes "x \<in># A"
   shows "x dvd prod_mset A"
   using assms prod_mset_subset_imp_dvd [of "{#x#}" A] by simp
 
 end
 
 notation prod_mset ("\<Prod>\<^sub>#")
 
 syntax (ASCII)
   "_prod_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3PROD _:#_. _)" [0, 51, 10] 10)
 syntax
   "_prod_mset_image" :: "pttrn \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'a::comm_monoid_mult"  ("(3\<Prod>_\<in>#_. _)" [0, 51, 10] 10)
 translations
   "\<Prod>i \<in># A. b" \<rightleftharpoons> "CONST prod_mset (CONST image_mset (\<lambda>i. b) A)"
 
 lemma prod_mset_constant [simp]: "(\<Prod>_\<in>#A. c) = c ^ size A"
   by (simp add: image_mset_const_eq)
 
 lemma (in semidom) prod_mset_zero_iff [iff]:
   "prod_mset A = 0 \<longleftrightarrow> 0 \<in># A"
   by (induct A) auto
 
 lemma (in semidom_divide) prod_mset_diff:
   assumes "B \<subseteq># A" and "0 \<notin># B"
   shows "prod_mset (A - B) = prod_mset A div prod_mset B"
 proof -
   from assms obtain C where "A = B + C"
     by (metis subset_mset.add_diff_inverse)
   with assms show ?thesis by simp
 qed
 
 lemma (in semidom_divide) prod_mset_minus:
   assumes "a \<in># A" and "a \<noteq> 0"
   shows "prod_mset (A - {#a#}) = prod_mset A div a"
   using assms prod_mset_diff [of "{#a#}" A] by auto
 
 lemma (in normalization_semidom) normalize_prod_mset_normalize:
   "normalize (prod_mset (image_mset normalize A)) = normalize (prod_mset A)"
 proof (induction A)
   case (add x A)
   have "normalize (prod_mset (image_mset normalize (add_mset x A))) =
           normalize (x * normalize (prod_mset (image_mset normalize A)))"
     by simp
   also note add.IH
   finally show ?case by simp
 qed auto
 
 lemma (in algebraic_semidom) is_unit_prod_mset_iff:
   "is_unit (prod_mset A) \<longleftrightarrow> (\<forall>x \<in># A. is_unit x)"
   by (induct A) (auto simp: is_unit_mult_iff)
 
 lemma (in normalization_semidom_multiplicative) normalize_prod_mset:
   "normalize (prod_mset A) = prod_mset (image_mset normalize A)"
   by (induct A) (simp_all add: normalize_mult)
 
 lemma (in normalization_semidom_multiplicative) normalized_prod_msetI:
   assumes "\<And>a. a \<in># A \<Longrightarrow> normalize a = a"
   shows "normalize (prod_mset A) = prod_mset A"
 proof -
   from assms have "image_mset normalize A = A"
     by (induct A) simp_all
   then show ?thesis by (simp add: normalize_prod_mset)
 qed
 
 
 subsection \<open>Multiset as order-ignorant lists\<close>
 
 context linorder
 begin
 
 lemma mset_insort [simp]:
   "mset (insort_key k x xs) = add_mset x (mset xs)"
   by (induct xs) simp_all
 
 lemma mset_sort [simp]:
   "mset (sort_key k xs) = mset xs"
   by (induct xs) simp_all
 
 text \<open>
   This lemma shows which properties suffice to show that a function
   \<open>f\<close> with \<open>f xs = ys\<close> behaves like sort.
 \<close>
 
 lemma properties_for_sort_key:
   assumes "mset ys = mset xs"
     and "\<And>k. k \<in> set ys \<Longrightarrow> filter (\<lambda>x. f k = f x) ys = filter (\<lambda>x. f k = f x) xs"
     and "sorted (map f ys)"
   shows "sort_key f xs = ys"
   using assms
 proof (induct xs arbitrary: ys)
   case Nil then show ?case by simp
 next
   case (Cons x xs)
   from Cons.prems(2) have
     "\<forall>k \<in> set ys. filter (\<lambda>x. f k = f x) (remove1 x ys) = filter (\<lambda>x. f k = f x) xs"
     by (simp add: filter_remove1)
   with Cons.prems have "sort_key f xs = remove1 x ys"
     by (auto intro!: Cons.hyps simp add: sorted_map_remove1)
   moreover from Cons.prems have "x \<in># mset ys"
     by auto
   then have "x \<in> set ys"
     by simp
   ultimately show ?case using Cons.prems by (simp add: insort_key_remove1)
 qed
 
 lemma properties_for_sort:
   assumes multiset: "mset ys = mset xs"
     and "sorted ys"
   shows "sort xs = ys"
 proof (rule properties_for_sort_key)
   from multiset show "mset ys = mset xs" .
   from \<open>sorted ys\<close> show "sorted (map (\<lambda>x. x) ys)" by simp
   from multiset have "length (filter (\<lambda>y. k = y) ys) = length (filter (\<lambda>x. k = x) xs)" for k
     by (rule mset_eq_length_filter)
   then have "replicate (length (filter (\<lambda>y. k = y) ys)) k =
     replicate (length (filter (\<lambda>x. k = x) xs)) k" for k
     by simp
   then show "k \<in> set ys \<Longrightarrow> filter (\<lambda>y. k = y) ys = filter (\<lambda>x. k = x) xs" for k
     by (simp add: replicate_length_filter)
 qed
 
 lemma sort_key_inj_key_eq:
   assumes mset_equal: "mset xs = mset ys"
     and "inj_on f (set xs)"
     and "sorted (map f ys)"
   shows "sort_key f xs = ys"
 proof (rule properties_for_sort_key)
   from mset_equal
   show "mset ys = mset xs" by simp
   from \<open>sorted (map f ys)\<close>
   show "sorted (map f ys)" .
   show "[x\<leftarrow>ys . f k = f x] = [x\<leftarrow>xs . f k = f x]" if "k \<in> set ys" for k
   proof -
     from mset_equal
     have set_equal: "set xs = set ys" by (rule mset_eq_setD)
     with that have "insert k (set ys) = set ys" by auto
     with \<open>inj_on f (set xs)\<close> have inj: "inj_on f (insert k (set ys))"
       by (simp add: set_equal)
     from inj have "[x\<leftarrow>ys . f k = f x] = filter (HOL.eq k) ys"
       by (auto intro!: inj_on_filter_key_eq)
     also have "\<dots> = replicate (count (mset ys) k) k"
       by (simp add: replicate_count_mset_eq_filter_eq)
     also have "\<dots> = replicate (count (mset xs) k) k"
       using mset_equal by simp
     also have "\<dots> = filter (HOL.eq k) xs"
       by (simp add: replicate_count_mset_eq_filter_eq)
     also have "\<dots> = [x\<leftarrow>xs . f k = f x]"
       using inj by (auto intro!: inj_on_filter_key_eq [symmetric] simp add: set_equal)
     finally show ?thesis .
   qed
 qed
 
 lemma sort_key_eq_sort_key:
   assumes "mset xs = mset ys"
     and "inj_on f (set xs)"
   shows "sort_key f xs = sort_key f ys"
   by (rule sort_key_inj_key_eq) (simp_all add: assms)
 
 lemma sort_key_by_quicksort:
   "sort_key f xs = sort_key f [x\<leftarrow>xs. f x < f (xs ! (length xs div 2))]
     @ [x\<leftarrow>xs. f x = f (xs ! (length xs div 2))]
     @ sort_key f [x\<leftarrow>xs. f x > f (xs ! (length xs div 2))]" (is "sort_key f ?lhs = ?rhs")
 proof (rule properties_for_sort_key)
   show "mset ?rhs = mset ?lhs"
     by (rule multiset_eqI) auto
   show "sorted (map f ?rhs)"
     by (auto simp add: sorted_append intro: sorted_map_same)
 next
   fix l
   assume "l \<in> set ?rhs"
   let ?pivot = "f (xs ! (length xs div 2))"
   have *: "\<And>x. f l = f x \<longleftrightarrow> f x = f l" by auto
   have "[x \<leftarrow> sort_key f xs . f x = f l] = [x \<leftarrow> xs. f x = f l]"
     unfolding filter_sort by (rule properties_for_sort_key) (auto intro: sorted_map_same)
   with * have **: "[x \<leftarrow> sort_key f xs . f l = f x] = [x \<leftarrow> xs. f l = f x]" by simp
   have "\<And>x P. P (f x) ?pivot \<and> f l = f x \<longleftrightarrow> P (f l) ?pivot \<and> f l = f x" by auto
   then have "\<And>P. [x \<leftarrow> sort_key f xs . P (f x) ?pivot \<and> f l = f x] =
     [x \<leftarrow> sort_key f xs. P (f l) ?pivot \<and> f l = f x]" by simp
   note *** = this [of "(<)"] this [of "(>)"] this [of "(=)"]
   show "[x \<leftarrow> ?rhs. f l = f x] = [x \<leftarrow> ?lhs. f l = f x]"
   proof (cases "f l" ?pivot rule: linorder_cases)
     case less
     then have "f l \<noteq> ?pivot" and "\<not> f l > ?pivot" by auto
     with less show ?thesis
       by (simp add: filter_sort [symmetric] ** ***)
   next
     case equal then show ?thesis
       by (simp add: * less_le)
   next
     case greater
     then have "f l \<noteq> ?pivot" and "\<not> f l < ?pivot" by auto
     with greater show ?thesis
       by (simp add: filter_sort [symmetric] ** ***)
   qed
 qed
 
 lemma sort_by_quicksort:
   "sort xs = sort [x\<leftarrow>xs. x < xs ! (length xs div 2)]
     @ [x\<leftarrow>xs. x = xs ! (length xs div 2)]
     @ sort [x\<leftarrow>xs. x > xs ! (length xs div 2)]" (is "sort ?lhs = ?rhs")
   using sort_key_by_quicksort [of "\<lambda>x. x", symmetric] by simp
 
 text \<open>A stable parameterized quicksort\<close>
 
 definition part :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> 'b list \<times> 'b list \<times> 'b list" where
   "part f pivot xs = ([x \<leftarrow> xs. f x < pivot], [x \<leftarrow> xs. f x = pivot], [x \<leftarrow> xs. pivot < f x])"
 
 lemma part_code [code]:
   "part f pivot [] = ([], [], [])"
   "part f pivot (x # xs) = (let (lts, eqs, gts) = part f pivot xs; x' = f x in
      if x' < pivot then (x # lts, eqs, gts)
      else if x' > pivot then (lts, eqs, x # gts)
      else (lts, x # eqs, gts))"
   by (auto simp add: part_def Let_def split_def)
 
 lemma sort_key_by_quicksort_code [code]:
   "sort_key f xs =
     (case xs of
       [] \<Rightarrow> []
     | [x] \<Rightarrow> xs
     | [x, y] \<Rightarrow> (if f x \<le> f y then xs else [y, x])
     | _ \<Rightarrow>
         let (lts, eqs, gts) = part f (f (xs ! (length xs div 2))) xs
         in sort_key f lts @ eqs @ sort_key f gts)"
 proof (cases xs)
   case Nil then show ?thesis by simp
 next
   case (Cons _ ys) note hyps = Cons show ?thesis
   proof (cases ys)
     case Nil with hyps show ?thesis by simp
   next
     case (Cons _ zs) note hyps = hyps Cons show ?thesis
     proof (cases zs)
       case Nil with hyps show ?thesis by auto
     next
       case Cons
       from sort_key_by_quicksort [of f xs]
       have "sort_key f xs = (let (lts, eqs, gts) = part f (f (xs ! (length xs div 2))) xs
         in sort_key f lts @ eqs @ sort_key f gts)"
       by (simp only: split_def Let_def part_def fst_conv snd_conv)
       with hyps Cons show ?thesis by (simp only: list.cases)
     qed
   qed
 qed
 
 end
 
 hide_const (open) part
 
 lemma mset_remdups_subset_eq: "mset (remdups xs) \<subseteq># mset xs"
   by (induct xs) (auto intro: subset_mset.order_trans)
 
 lemma mset_update:
   "i < length ls \<Longrightarrow> mset (ls[i := v]) = add_mset v (mset ls - {#ls ! i#})"
 proof (induct ls arbitrary: i)
   case Nil then show ?case by simp
 next
   case (Cons x xs)
   show ?case
   proof (cases i)
     case 0 then show ?thesis by simp
   next
     case (Suc i')
     with Cons show ?thesis
       by (cases \<open>x = xs ! i'\<close>) auto
   qed
 qed
 
 lemma mset_swap:
   "i < length ls \<Longrightarrow> j < length ls \<Longrightarrow>
     mset (ls[j := ls ! i, i := ls ! j]) = mset ls"
   by (cases "i = j") (simp_all add: mset_update nth_mem_mset)
 
 lemma mset_eq_finite:
   \<open>finite {ys. mset ys = mset xs}\<close>
 proof -
   have \<open>{ys. mset ys = mset xs} \<subseteq> {ys. set ys \<subseteq> set xs \<and> length ys \<le> length xs}\<close>
     by (auto simp add: dest: mset_eq_setD mset_eq_length)
   moreover have \<open>finite {ys. set ys \<subseteq> set xs \<and> length ys \<le> length xs}\<close>
     using finite_lists_length_le by blast
   ultimately show ?thesis
     by (rule finite_subset)
 qed
 
 
 subsection \<open>The multiset order\<close>
 
 definition mult1 :: "('a \<times> 'a) set \<Rightarrow> ('a multiset \<times> 'a multiset) set" where
   "mult1 r = {(N, M). \<exists>a M0 K. M = add_mset a M0 \<and> N = M0 + K \<and>
       (\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r)}"
 
 definition mult :: "('a \<times> 'a) set \<Rightarrow> ('a multiset \<times> 'a multiset) set" where
   "mult r = (mult1 r)\<^sup>+"
 
 definition multp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multp r M N \<longleftrightarrow> (M, N) \<in> mult {(x, y). r x y}"
 
 declare multp_def[pred_set_conv]
 
 lemma mult1I:
   assumes "M = add_mset a M0" and "N = M0 + K" and "\<And>b. b \<in># K \<Longrightarrow> (b, a) \<in> r"
   shows "(N, M) \<in> mult1 r"
   using assms unfolding mult1_def by blast
 
 lemma mult1E:
   assumes "(N, M) \<in> mult1 r"
   obtains a M0 K where "M = add_mset a M0" "N = M0 + K" "\<And>b. b \<in># K \<Longrightarrow> (b, a) \<in> r"
   using assms unfolding mult1_def by blast
 
 lemma mono_mult1:
   assumes "r \<subseteq> r'" shows "mult1 r \<subseteq> mult1 r'"
   unfolding mult1_def using assms by blast
 
 lemma mono_mult:
   assumes "r \<subseteq> r'" shows "mult r \<subseteq> mult r'"
   unfolding mult_def using mono_mult1[OF assms] trancl_mono by blast
 
 lemma mono_multp[mono]: "r \<le> r' \<Longrightarrow> multp r \<le> multp r'"
   unfolding le_fun_def le_bool_def
 proof (intro allI impI)
   fix M N :: "'a multiset"
   assume "\<forall>x xa. r x xa \<longrightarrow> r' x xa"
   hence "{(x, y). r x y} \<subseteq> {(x, y). r' x y}"
     by blast
   thus "multp r M N \<Longrightarrow> multp r' M N"
     unfolding multp_def
     by (fact mono_mult[THEN subsetD, rotated])
 qed
 
 lemma not_less_empty [iff]: "(M, {#}) \<notin> mult1 r"
   by (simp add: mult1_def)
 
 
 subsubsection \<open>Well-foundedness\<close>
 
 lemma less_add:
   assumes mult1: "(N, add_mset a M0) \<in> mult1 r"
   shows
     "(\<exists>M. (M, M0) \<in> mult1 r \<and> N = add_mset a M) \<or>
      (\<exists>K. (\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r) \<and> N = M0 + K)"
 proof -
   let ?r = "\<lambda>K a. \<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r"
   let ?R = "\<lambda>N M. \<exists>a M0 K. M = add_mset a M0 \<and> N = M0 + K \<and> ?r K a"
   obtain a' M0' K where M0: "add_mset a M0 = add_mset a' M0'"
     and N: "N = M0' + K"
     and r: "?r K a'"
     using mult1 unfolding mult1_def by auto
   show ?thesis (is "?case1 \<or> ?case2")
   proof -
     from M0 consider "M0 = M0'" "a = a'"
       | K' where "M0 = add_mset a' K'" "M0' = add_mset a K'"
       by atomize_elim (simp only: add_eq_conv_ex)
     then show ?thesis
     proof cases
       case 1
       with N r have "?r K a \<and> N = M0 + K" by simp
       then have ?case2 ..
       then show ?thesis ..
     next
       case 2
       from N 2(2) have n: "N = add_mset a (K' + K)" by simp
       with r 2(1) have "?R (K' + K) M0" by blast
       with n have ?case1 by (simp add: mult1_def)
       then show ?thesis ..
     qed
   qed
 qed
 
 lemma all_accessible:
   assumes "wf r"
   shows "\<forall>M. M \<in> Wellfounded.acc (mult1 r)"
 proof
   let ?R = "mult1 r"
   let ?W = "Wellfounded.acc ?R"
   {
     fix M M0 a
     assume M0: "M0 \<in> ?W"
       and wf_hyp: "\<And>b. (b, a) \<in> r \<Longrightarrow> (\<forall>M \<in> ?W. add_mset b M \<in> ?W)"
       and acc_hyp: "\<forall>M. (M, M0) \<in> ?R \<longrightarrow> add_mset a M \<in> ?W"
     have "add_mset a M0 \<in> ?W"
     proof (rule accI [of "add_mset a M0"])
       fix N
       assume "(N, add_mset a M0) \<in> ?R"
       then consider M where "(M, M0) \<in> ?R" "N = add_mset a M"
         | K where "\<forall>b. b \<in># K \<longrightarrow> (b, a) \<in> r" "N = M0 + K"
         by atomize_elim (rule less_add)
       then show "N \<in> ?W"
       proof cases
         case 1
         from acc_hyp have "(M, M0) \<in> ?R \<longrightarrow> add_mset a M \<in> ?W" ..
         from this and \<open>(M, M0) \<in> ?R\<close> have "add_mset a M \<in> ?W" ..
         then show "N \<in> ?W" by (simp only: \<open>N = add_mset a M\<close>)
       next
         case 2
         from this(1) have "M0 + K \<in> ?W"
         proof (induct K)
           case empty
           from M0 show "M0 + {#} \<in> ?W" by simp
         next
           case (add x K)
           from add.prems have "(x, a) \<in> r" by simp
           with wf_hyp have "\<forall>M \<in> ?W. add_mset x M \<in> ?W" by blast
           moreover from add have "M0 + K \<in> ?W" by simp
           ultimately have "add_mset x (M0 + K) \<in> ?W" ..
           then show "M0 + (add_mset x K) \<in> ?W" by simp
         qed
         then show "N \<in> ?W" by (simp only: 2(2))
       qed
     qed
   } note tedious_reasoning = this
 
   show "M \<in> ?W" for M
   proof (induct M)
     show "{#} \<in> ?W"
     proof (rule accI)
       fix b assume "(b, {#}) \<in> ?R"
       with not_less_empty show "b \<in> ?W" by contradiction
     qed
 
     fix M a assume "M \<in> ?W"
     from \<open>wf r\<close> have "\<forall>M \<in> ?W. add_mset a M \<in> ?W"
     proof induct
       fix a
       assume r: "\<And>b. (b, a) \<in> r \<Longrightarrow> (\<forall>M \<in> ?W. add_mset b M \<in> ?W)"
       show "\<forall>M \<in> ?W. add_mset a M \<in> ?W"
       proof
         fix M assume "M \<in> ?W"
         then show "add_mset a M \<in> ?W"
           by (rule acc_induct) (rule tedious_reasoning [OF _ r])
       qed
     qed
     from this and \<open>M \<in> ?W\<close> show "add_mset a M \<in> ?W" ..
   qed
 qed
 
 lemma wf_mult1: "wf r \<Longrightarrow> wf (mult1 r)"
   by (rule acc_wfI) (rule all_accessible)
 
 lemma wf_mult: "wf r \<Longrightarrow> wf (mult r)"
   unfolding mult_def by (rule wf_trancl) (rule wf_mult1)
 
 lemma wfP_multp: "wfP r \<Longrightarrow> wfP (multp r)"
   unfolding multp_def wfP_def
   by (simp add: wf_mult)
 
 
 subsubsection \<open>Closure-free presentation\<close>
 
 text \<open>One direction.\<close>
 lemma mult_implies_one_step:
   assumes
     trans: "trans r" and
     MN: "(M, N) \<in> mult r"
   shows "\<exists>I J K. N = I + J \<and> M = I + K \<and> J \<noteq> {#} \<and> (\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> r)"
   using MN unfolding mult_def mult1_def
 proof (induction rule: converse_trancl_induct)
   case (base y)
   then show ?case by force
 next
   case (step y z) note yz = this(1) and zN = this(2) and N_decomp = this(3)
   obtain I J K where
     N: "N = I + J" "z = I + K" "J \<noteq> {#}" "\<forall>k\<in>#K. \<exists>j\<in>#J. (k, j) \<in> r"
     using N_decomp by blast
   obtain a M0 K' where
     z: "z = add_mset a M0" and y: "y = M0 + K'" and K: "\<forall>b. b \<in># K' \<longrightarrow> (b, a) \<in> r"
     using yz by blast
   show ?case
   proof (cases "a \<in># K")
     case True
     moreover have "\<exists>j\<in>#J. (k, j) \<in> r" if "k \<in># K'" for k
       using K N trans True by (meson that transE)
     ultimately show ?thesis
       by (rule_tac x = I in exI, rule_tac x = J in exI, rule_tac x = "(K - {#a#}) + K'" in exI)
         (use z y N in \<open>auto simp del: subset_mset.add_diff_assoc2 dest: in_diffD\<close>)
   next
     case False
     then have "a \<in># I" by (metis N(2) union_iff union_single_eq_member z)
     moreover have "M0 = I + K - {#a#}"
       using N(2) z by force
     ultimately show ?thesis
       by (rule_tac x = "I - {#a#}" in exI, rule_tac x = "add_mset a J" in exI,
           rule_tac x = "K + K'" in exI)
         (use z y N False K in \<open>auto simp: add.assoc\<close>)
   qed
 qed
 
 lemma multp_implies_one_step:
   "transp R \<Longrightarrow> multp R M N \<Longrightarrow> \<exists>I J K. N = I + J \<and> M = I + K \<and> J \<noteq> {#} \<and> (\<forall>k\<in>#K. \<exists>x\<in>#J. R k x)"
   by (rule mult_implies_one_step[to_pred])
 
 lemma one_step_implies_mult:
   assumes
     "J \<noteq> {#}" and
     "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> r"
   shows "(I + K, I + J) \<in> mult r"
   using assms
 proof (induction "size J" arbitrary: I J K)
   case 0
   then show ?case by auto
 next
   case (Suc n) note IH = this(1) and size_J = this(2)[THEN sym]
   obtain J' a where J: "J = add_mset a J'"
     using size_J by (blast dest: size_eq_Suc_imp_eq_union)
   show ?case
   proof (cases "J' = {#}")
     case True
     then show ?thesis
       using J Suc by (fastforce simp add: mult_def mult1_def)
   next
     case [simp]: False
     have K: "K = {#x \<in># K. (x, a) \<in> r#} + {#x \<in># K. (x, a) \<notin> r#}"
       by simp
     have "(I + K, (I + {# x \<in># K. (x, a) \<in> r #}) + J') \<in> mult r"
       using IH[of J' "{# x \<in># K. (x, a) \<notin> r#}" "I + {# x \<in># K. (x, a) \<in> r#}"]
         J Suc.prems K size_J by (auto simp: ac_simps)
     moreover have "(I + {#x \<in># K. (x, a) \<in> r#} + J', I + J) \<in> mult r"
       by (fastforce simp: J mult1_def mult_def)
     ultimately show ?thesis
       unfolding mult_def by simp
   qed
 qed
 
 lemma one_step_implies_multp:
   "J \<noteq> {#} \<Longrightarrow> \<forall>k\<in>#K. \<exists>j\<in>#J. R k j \<Longrightarrow> multp R (I + K) (I + J)"
   by (rule one_step_implies_mult[of _ _ "{(x, y). r x y}" for r, folded multp_def, simplified])
 
 lemma subset_implies_mult:
   assumes sub: "A \<subset># B"
   shows "(A, B) \<in> mult r"
 proof -
   have ApBmA: "A + (B - A) = B"
     using sub by simp
   have BmA: "B - A \<noteq> {#}"
     using sub by (simp add: Diff_eq_empty_iff_mset subset_mset.less_le_not_le)
   thus ?thesis
     by (rule one_step_implies_mult[of "B - A" "{#}" _ A, unfolded ApBmA, simplified])
 qed
 
 lemma subset_implies_multp: "A \<subset># B \<Longrightarrow> multp r A B"
   by (rule subset_implies_mult[of _ _ "{(x, y). r x y}" for r, folded multp_def])
 
 lemma multp_repeat_mset_repeat_msetI:
   assumes "transp R" and "multp R A B" and "n \<noteq> 0"
   shows "multp R (repeat_mset n A) (repeat_mset n  B)"
 proof -
   from \<open>transp R\<close> \<open>multp R A B\<close> obtain I J K where
     "B = I + J" and "A = I + K" and "J \<noteq> {#}" and "\<forall>k \<in># K. \<exists>x \<in># J. R k x"
     by (auto dest: multp_implies_one_step)
 
   have repeat_n_A_eq: "repeat_mset n A = repeat_mset n I + repeat_mset n K"
     using \<open>A = I + K\<close> by simp
 
   have repeat_n_B_eq: "repeat_mset n B = repeat_mset n I + repeat_mset n J"
     using \<open>B = I + J\<close> by simp
 
   show ?thesis
     unfolding repeat_n_A_eq repeat_n_B_eq
   proof (rule one_step_implies_multp)
     from \<open>n \<noteq> 0\<close> show "repeat_mset n J \<noteq> {#}"
       using \<open>J \<noteq> {#}\<close>
       by (simp add: repeat_mset_eq_empty_iff)
   next
     show "\<forall>k \<in># repeat_mset n K. \<exists>j \<in># repeat_mset n J. R k j"
       using \<open>\<forall>k \<in># K. \<exists>x \<in># J. R k x\<close>
       by (metis count_greater_zero_iff nat_0_less_mult_iff repeat_mset.rep_eq)
   qed
 qed
 
 
 subsubsection \<open>Monotonicity\<close>
 
 lemma multp_mono_strong:
   assumes "multp R M1 M2" and "transp R" and
     S_if_R: "\<And>x y. x \<in> set_mset M1 \<Longrightarrow> y \<in> set_mset M2 \<Longrightarrow> R x y \<Longrightarrow> S x y"
   shows "multp S M1 M2"
 proof -
   obtain I J K where "M2 = I + J" and "M1 = I + K" and "J \<noteq> {#}" and "\<forall>k\<in>#K. \<exists>x\<in>#J. R k x"
     using multp_implies_one_step[OF \<open>transp R\<close> \<open>multp R M1 M2\<close>] by auto
   show ?thesis
     unfolding \<open>M2 = I + J\<close> \<open>M1 = I + K\<close>
   proof (rule one_step_implies_multp[OF \<open>J \<noteq> {#}\<close>])
     show "\<forall>k\<in>#K. \<exists>j\<in>#J. S k j"
       using S_if_R
       by (metis \<open>M1 = I + K\<close> \<open>M2 = I + J\<close> \<open>\<forall>k\<in>#K. \<exists>x\<in>#J. R k x\<close> union_iff)
   qed
 qed
 
 lemma mult_mono_strong:
   assumes "(M1, M2) \<in> mult r" and "trans r" and
     S_if_R: "\<And>x y. x \<in> set_mset M1 \<Longrightarrow> y \<in> set_mset M2 \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> (x, y) \<in> s"
   shows "(M1, M2) \<in> mult s"
   using assms multp_mono_strong[of "\<lambda>x y. (x, y) \<in> r" M1 M2 "\<lambda>x y. (x, y) \<in> s",
       unfolded multp_def transp_trans_eq, simplified]
   by blast
 
 lemma monotone_on_multp_multp_image_mset:
   assumes "monotone_on A orda ordb f" and "transp orda"
   shows "monotone_on {M. set_mset M \<subseteq> A} (multp orda) (multp ordb) (image_mset f)"
 proof (rule monotone_onI)
   fix M1 M2
   assume
     M1_in: "M1 \<in> {M. set_mset M \<subseteq> A}" and
     M2_in: "M2 \<in> {M. set_mset M \<subseteq> A}" and
     M1_lt_M2: "multp orda M1 M2"
 
   from multp_implies_one_step[OF \<open>transp orda\<close> M1_lt_M2] obtain I J K where
     M2_eq: "M2 = I + J" and
     M1_eq: "M1 = I + K" and
     J_neq_mempty: "J \<noteq> {#}" and
     ball_K_less: "\<forall>k\<in>#K. \<exists>x\<in>#J. orda k x"
     by metis
 
   have "multp ordb (image_mset f I + image_mset f K) (image_mset f I + image_mset f J)"
   proof (intro one_step_implies_multp ballI)
     show "image_mset f J \<noteq> {#}"
       using J_neq_mempty by simp
   next
     fix k' assume "k'\<in>#image_mset f K"
     then obtain k where "k' = f k" and k_in: "k \<in># K"
       by auto
     then obtain j where j_in: "j\<in>#J" and "orda k j"
       using ball_K_less by auto
 
     have "ordb (f k) (f j)"
     proof (rule \<open>monotone_on A orda ordb f\<close>[THEN monotone_onD, OF _ _ \<open>orda k j\<close>])
       show "k \<in> A"
         using M1_eq M1_in k_in by auto
     next
       show "j \<in> A"
         using M2_eq M2_in j_in by auto
     qed
     thus "\<exists>j\<in>#image_mset f J. ordb k' j"
       using \<open>j \<in># J\<close> \<open>k' = f k\<close> by auto
   qed
   thus "multp ordb (image_mset f M1) (image_mset f M2)"
     by (simp add: M1_eq M2_eq)
 qed
 
 lemma monotone_multp_multp_image_mset:
   assumes "monotone orda ordb f" and "transp orda"
   shows "monotone (multp orda) (multp ordb) (image_mset f)"
   by (rule monotone_on_multp_multp_image_mset[OF assms, simplified])
 
 lemma multp_image_mset_image_msetI:
   assumes "multp (\<lambda>x y. R (f x) (f y)) M1 M2" and "transp R"
   shows "multp R (image_mset f M1) (image_mset f M2)"
 proof -
   from \<open>transp R\<close> have "transp (\<lambda>x y. R (f x) (f y))"
     by (auto intro: transpI dest: transpD)
   with \<open>multp (\<lambda>x y. R (f x) (f y)) M1 M2\<close> obtain I J K where
     "M2 = I + J" and "M1 = I + K" and "J \<noteq> {#}" and "\<forall>k\<in>#K. \<exists>x\<in>#J. R (f k) (f x)"
     using multp_implies_one_step by blast
 
   have "multp R (image_mset f I + image_mset f K) (image_mset f I + image_mset f J)"
   proof (rule one_step_implies_multp)
     show "image_mset f J \<noteq> {#}"
       by (simp add: \<open>J \<noteq> {#}\<close>)
   next
     show "\<forall>k\<in>#image_mset f K. \<exists>j\<in>#image_mset f J. R k j"
       by (simp add: \<open>\<forall>k\<in>#K. \<exists>x\<in>#J. R (f k) (f x)\<close>)
   qed
   thus ?thesis
     by (simp add: \<open>M1 = I + K\<close> \<open>M2 = I + J\<close>)
 qed
 
 lemma multp_image_mset_image_msetD:
   assumes
     "multp R (image_mset f A) (image_mset f B)" and
     "transp R" and
     inj_on_f: "inj_on f (set_mset A \<union> set_mset B)"
   shows "multp (\<lambda>x y. R (f x) (f y)) A B"
 proof -
   from assms(1,2) obtain I J K where
     f_B_eq: "image_mset f B = I + J" and
     f_A_eq: "image_mset f A = I + K" and
     J_neq_mempty: "J \<noteq> {#}" and
     ball_K_less: "\<forall>k\<in>#K. \<exists>x\<in>#J. R k x"
     by (auto dest: multp_implies_one_step)
 
   from f_B_eq obtain I' J' where
     B_def: "B = I' + J'" and I_def: "I = image_mset f I'" and J_def: "J = image_mset f J'"
     using image_mset_eq_plusD by blast
 
   from inj_on_f have inj_on_f': "inj_on f (set_mset A \<union> set_mset I')"
     by (rule inj_on_subset) (auto simp add: B_def)
 
   from f_A_eq obtain K' where
     A_def: "A = I' + K'" and K_def: "K = image_mset f K'"
     by (auto simp: I_def dest: image_mset_eq_image_mset_plusD[OF _ inj_on_f'])
 
   show ?thesis
     unfolding A_def B_def
   proof (intro one_step_implies_multp ballI)
     from J_neq_mempty show "J' \<noteq> {#}"
       by (simp add: J_def)
   next
     fix k assume "k \<in># K'"
     with ball_K_less obtain j' where "j' \<in># J" and "R (f k) j'"
       using K_def by auto
     moreover then obtain j where "j \<in># J'" and "f j = j'"
       using J_def by auto
     ultimately show "\<exists>j\<in>#J'. R (f k) (f j)"
       by blast
   qed
 qed
 
 
 subsubsection \<open>The multiset extension is cancellative for multiset union\<close>
 
 lemma mult_cancel:
   assumes "trans s" and "irrefl_on (set_mset Z) s"
   shows "(X + Z, Y + Z) \<in> mult s \<longleftrightarrow> (X, Y) \<in> mult s" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L thus ?R
     using \<open>irrefl_on (set_mset Z) s\<close>
   proof (induct Z)
     case (add z Z)
     obtain X' Y' Z' where *: "add_mset z X + Z = Z' + X'" "add_mset z Y + Z = Z' + Y'" "Y' \<noteq> {#}"
       "\<forall>x \<in> set_mset X'. \<exists>y \<in> set_mset Y'. (x, y) \<in> s"
       using mult_implies_one_step[OF \<open>trans s\<close> add(2)] by auto
     consider Z2 where "Z' = add_mset z Z2" | X2 Y2 where "X' = add_mset z X2" "Y' = add_mset z Y2"
       using *(1,2) by (metis add_mset_remove_trivial_If insert_iff set_mset_add_mset_insert union_iff)
     thus ?case
     proof (cases)
       case 1 thus ?thesis
         using * one_step_implies_mult[of Y' X' s Z2] add(3)
         by (auto simp: add.commute[of _ "{#_#}"] add.assoc intro: add(1) elim: irrefl_on_subset)
     next
       case 2 then obtain y where "y \<in> set_mset Y2" "(z, y) \<in> s"
         using *(4) \<open>irrefl_on (set_mset (add_mset z Z)) s\<close>
         by (auto simp: irrefl_on_def)
       moreover from this transD[OF \<open>trans s\<close> _ this(2)]
       have "x' \<in> set_mset X2 \<Longrightarrow> \<exists>y \<in> set_mset Y2. (x', y) \<in> s" for x'
         using 2 *(4)[rule_format, of x'] by auto
       ultimately show ?thesis
         using * one_step_implies_mult[of Y2 X2 s Z'] 2 add(3)
         by (force simp: add.commute[of "{#_#}"] add.assoc[symmetric] intro: add(1)
             elim: irrefl_on_subset)
     qed
   qed auto
 next
   assume ?R then obtain I J K
     where "Y = I + J" "X = I + K" "J \<noteq> {#}" "\<forall>k \<in> set_mset K. \<exists>j \<in> set_mset J. (k, j) \<in> s"
     using mult_implies_one_step[OF \<open>trans s\<close>] by blast
   thus ?L using one_step_implies_mult[of J K s "I + Z"] by (auto simp: ac_simps)
 qed
 
 lemma multp_cancel:
   "transp R \<Longrightarrow> irreflp_on (set_mset Z) R \<Longrightarrow> multp R (X + Z) (Y + Z) \<longleftrightarrow> multp R X Y"
   by (rule mult_cancel[to_pred])
 
 lemma mult_cancel_add_mset:
   "trans r \<Longrightarrow> irrefl_on {z} r \<Longrightarrow>
     ((add_mset z X, add_mset z Y) \<in> mult r) = ((X, Y) \<in> mult r)"
   by (rule mult_cancel[of _ "{#_#}", simplified])
 
 lemma multp_cancel_add_mset:
   "transp R \<Longrightarrow> irreflp_on {z} R \<Longrightarrow> multp R (add_mset z X) (add_mset z Y) = multp R X Y"
   by (rule mult_cancel_add_mset[to_pred, folded bot_set_def])
 
 lemma mult_cancel_max0:
   assumes "trans s" and "irrefl_on (set_mset X \<inter> set_mset Y) s"
   shows "(X, Y) \<in> mult s \<longleftrightarrow> (X - X \<inter># Y, Y - X \<inter># Y) \<in> mult s" (is "?L \<longleftrightarrow> ?R")
 proof -
   have "(X - X \<inter># Y + X \<inter># Y, Y - X \<inter># Y + X \<inter># Y) \<in> mult s \<longleftrightarrow> (X - X \<inter># Y, Y - X \<inter># Y) \<in> mult s"
   proof (rule mult_cancel)
     from assms show "trans s"
       by simp
   next
     from assms show "irrefl_on (set_mset (X \<inter># Y)) s"
       by simp
   qed
   moreover have "X - X \<inter># Y + X \<inter># Y = X" "Y - X \<inter># Y + X \<inter># Y = Y"
     by (auto simp flip: count_inject)
   ultimately show ?thesis
     by simp
 qed
 
 lemma mult_cancel_max:
   "trans r \<Longrightarrow> irrefl_on (set_mset X \<inter> set_mset Y) r \<Longrightarrow>
     (X, Y) \<in> mult r \<longleftrightarrow> (X - Y, Y - X) \<in> mult r"
   by (rule mult_cancel_max0[simplified])
 
 lemma multp_cancel_max:
   "transp R \<Longrightarrow> irreflp_on (set_mset X \<inter> set_mset Y) R \<Longrightarrow> multp R X Y \<longleftrightarrow> multp R (X - Y) (Y - X)"
   by (rule mult_cancel_max[to_pred])
 
 
 subsubsection \<open>Strict partial-order properties\<close>
 
 lemma mult1_lessE:
   assumes "(N, M) \<in> mult1 {(a, b). r a b}" and "asymp r"
   obtains a M0 K where "M = add_mset a M0" "N = M0 + K"
     "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> r b a"
 proof -
   from assms obtain a M0 K where "M = add_mset a M0" "N = M0 + K" and
     *: "b \<in># K \<Longrightarrow> r b a" for b by (blast elim: mult1E)
   moreover from * [of a] have "a \<notin># K"
     using \<open>asymp r\<close> by (meson asympD)
   ultimately show thesis by (auto intro: that)
 qed
 
 lemma trans_on_mult:
   assumes "trans_on A r" and "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "trans_on B (mult r)"
   using assms by (metis mult_def subset_UNIV trans_on_subset trans_trancl)
 
 lemma trans_mult: "trans r \<Longrightarrow> trans (mult r)"
   using trans_on_mult[of UNIV r UNIV, simplified] .
 
 lemma transp_on_multp:
   assumes "transp_on A r" and "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "transp_on B (multp r)"
   by (metis mult_def multp_def transD trans_trancl transp_onI)
 
 lemma transp_multp: "transp r \<Longrightarrow> transp (multp r)"
   using transp_on_multp[of UNIV r UNIV, simplified] .
 
 lemma irrefl_mult:
   assumes "trans r" "irrefl r"
   shows "irrefl (mult r)"
 proof (intro irreflI notI)
   fix M
   assume "(M, M) \<in> mult r"
   then obtain I J K where "M = I + J" and "M = I + K"
     and "J \<noteq> {#}" and "(\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> r)"
     using mult_implies_one_step[OF \<open>trans r\<close>] by blast
   then have *: "K \<noteq> {#}" and **: "\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset K. (k, j) \<in> r" by auto
   have "finite (set_mset K)" by simp
   hence "set_mset K = {}"
     using **
   proof (induction rule: finite_induct)
     case empty
     thus ?case by simp
   next
     case (insert x F)
     have False
       using \<open>irrefl r\<close>[unfolded irrefl_def, rule_format]
       using \<open>trans r\<close>[THEN transD]
       by (metis equals0D insert.IH insert.prems insertE insertI1 insertI2)
     thus ?case ..
   qed
   with * show False by simp
 qed
 
 lemma irreflp_multp: "transp R \<Longrightarrow> irreflp R \<Longrightarrow> irreflp (multp R)"
   by (rule irrefl_mult[of "{(x, y). r x y}" for r,
     folded transp_trans_eq irreflp_irrefl_eq, simplified, folded multp_def])
 
 instantiation multiset :: (preorder) order begin
 
 definition less_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"
   where "M < N \<longleftrightarrow> multp (<) M N"
 
 definition less_eq_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"
   where "less_eq_multiset M N \<longleftrightarrow> M < N \<or> M = N"
 
 instance
 proof intro_classes
   fix M N :: "'a multiset"
   show "(M < N) = (M \<le> N \<and> \<not> N \<le> M)"
     unfolding less_eq_multiset_def less_multiset_def
     by (metis irreflp_def irreflp_on_less irreflp_multp transpE transp_on_less transp_multp)
 next
   fix M :: "'a multiset"
   show "M \<le> M"
     unfolding less_eq_multiset_def
     by simp
 next
   fix M1 M2 M3 :: "'a multiset"
   show "M1 \<le> M2 \<Longrightarrow> M2 \<le> M3 \<Longrightarrow> M1 \<le> M3"
     unfolding less_eq_multiset_def less_multiset_def
     using transp_multp[OF transp_on_less, THEN transpD]
     by blast
 next
   fix M N :: "'a multiset"
   show "M \<le> N \<Longrightarrow> N \<le> M \<Longrightarrow> M = N"
     unfolding less_eq_multiset_def less_multiset_def
     using transp_multp[OF transp_on_less, THEN transpD]
     using irreflp_multp[OF transp_on_less irreflp_on_less, unfolded irreflp_def, rule_format]
     by blast
 qed
 
 end
 
 lemma mset_le_irrefl [elim!]:
   fixes M :: "'a::preorder multiset"
   shows "M < M \<Longrightarrow> R"
   by simp
 
 lemma wfP_less_multiset[simp]:
   assumes wfP_less: "wfP ((<) :: ('a :: preorder) \<Rightarrow> 'a \<Rightarrow> bool)"
   shows "wfP ((<) :: 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool)"
   using wfP_multp[OF wfP_less] less_multiset_def
   by (metis wfPUNIVI wfP_induct)
 
 
 subsubsection \<open>Strict total-order properties\<close>
 
 lemma total_on_mult:
   assumes "total_on A r" and "trans r" and "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "total_on B (mult r)"
 proof (rule total_onI)
   fix M1 M2 assume "M1 \<in> B" and "M2 \<in> B" and "M1 \<noteq> M2"
   let ?I = "M1 \<inter># M2"
   show "(M1, M2) \<in> mult r \<or> (M2, M1) \<in> mult r"
   proof (cases "M1 - ?I = {#} \<or> M2 - ?I = {#}")
     case True
     with \<open>M1 \<noteq> M2\<close> show ?thesis
       by (metis Diff_eq_empty_iff_mset diff_intersect_left_idem diff_intersect_right_idem
           subset_implies_mult subset_mset.less_le)
   next
     case False
     from assms(1) have "total_on (set_mset (M1 - ?I)) r"
       by (meson \<open>M1 \<in> B\<close> assms(3) diff_subset_eq_self set_mset_mono total_on_subset)
     with False obtain greatest1 where
       greatest1_in: "greatest1 \<in># M1 - ?I" and
       greatest1_greatest: "\<forall>x \<in># M1 - ?I. greatest1 \<noteq> x \<longrightarrow> (x, greatest1) \<in> r"
       using Multiset.bex_greatest_element[to_set, of "M1 - ?I" r]
       by (metis assms(2) subset_UNIV trans_on_subset)
 
     from assms(1) have "total_on (set_mset (M2 - ?I)) r"
       by (meson \<open>M2 \<in> B\<close> assms(3) diff_subset_eq_self set_mset_mono total_on_subset)
     with False obtain greatest2 where
       greatest2_in: "greatest2 \<in># M2 - ?I" and
       greatest2_greatest: "\<forall>x \<in># M2 - ?I. greatest2 \<noteq> x \<longrightarrow> (x, greatest2) \<in> r"
       using Multiset.bex_greatest_element[to_set, of "M2 - ?I" r]
       by (metis assms(2) subset_UNIV trans_on_subset)
 
     have "greatest1 \<noteq> greatest2"
       using greatest1_in \<open>greatest2 \<in># M2 - ?I\<close>
       by (metis diff_intersect_left_idem diff_intersect_right_idem dual_order.eq_iff in_diff_count
           in_diff_countE le_add_same_cancel2 less_irrefl zero_le)
     hence "(greatest1, greatest2) \<in> r \<or> (greatest2, greatest1) \<in> r"
       using \<open>total_on A r\<close>[unfolded total_on_def, rule_format, of greatest1 greatest2]
         \<open>M1 \<in> B\<close> \<open>M2 \<in> B\<close> greatest1_in greatest2_in assms(3)
       by (meson in_diffD in_mono)
     thus ?thesis
     proof (elim disjE)
       assume "(greatest1, greatest2) \<in> r"
       have "(?I + (M1 - ?I), ?I + (M2 - ?I)) \<in> mult r"
       proof (rule one_step_implies_mult[of "M2 - ?I" "M1 - ?I" r ?I])
         show "M2 - ?I \<noteq> {#}"
           using False by force
       next
         show "\<forall>k\<in>#M1 - ?I. \<exists>j\<in>#M2 - ?I. (k, j) \<in> r"
           using \<open>(greatest1, greatest2) \<in> r\<close> greatest2_in greatest1_greatest
           by (metis assms(2) transD)
       qed
       hence "(M1, M2) \<in> mult r"
         by (metis subset_mset.add_diff_inverse subset_mset.inf.cobounded1
             subset_mset.inf.cobounded2)
       thus "(M1, M2) \<in> mult r \<or> (M2, M1) \<in> mult r" ..
     next
       assume "(greatest2, greatest1) \<in> r"
       have "(?I + (M2 - ?I), ?I + (M1 - ?I)) \<in> mult r"
       proof (rule one_step_implies_mult[of "M1 - ?I" "M2 - ?I" r ?I])
         show "M1 - M1 \<inter># M2 \<noteq> {#}"
           using False by force
       next
         show "\<forall>k\<in>#M2 - ?I. \<exists>j\<in>#M1 - ?I. (k, j) \<in> r"
           using \<open>(greatest2, greatest1) \<in> r\<close> greatest1_in greatest2_greatest
           by (metis assms(2) transD)
       qed
       hence "(M2, M1) \<in> mult r"
         by (metis subset_mset.add_diff_inverse subset_mset.inf.cobounded1
             subset_mset.inf.cobounded2)
       thus "(M1, M2) \<in> mult r \<or> (M2, M1) \<in> mult r" ..
     qed
   qed
 qed
 
 lemma total_mult: "total r \<Longrightarrow> trans r \<Longrightarrow> total (mult r)"
   by (rule total_on_mult[of UNIV r UNIV, simplified])
 
 lemma totalp_on_multp:
   "totalp_on A R \<Longrightarrow> transp R \<Longrightarrow> (\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A) \<Longrightarrow> totalp_on B (multp R)"
   using total_on_mult[of A "{(x,y). R x y}" B, to_pred]
   by (simp add: multp_def total_on_def totalp_on_def)
 
 lemma totalp_multp: "totalp R \<Longrightarrow> transp R \<Longrightarrow> totalp (multp R)"
   by (rule totalp_on_multp[of UNIV R UNIV, simplified])
 
 
 subsection \<open>Quasi-executable version of the multiset extension\<close>
 
 text \<open>
   Predicate variants of \<open>mult\<close> and the reflexive closure of \<open>mult\<close>, which are
   executable whenever the given predicate \<open>P\<close> is. Together with the standard
   code equations for \<open>(\<inter>#\<close>) and \<open>(-\<close>) this should yield quadratic
   (with respect to calls to \<open>P\<close>) implementations of \<open>multp_code\<close> and \<open>multeqp_code\<close>.
 \<close>
 
 definition multp_code :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multp_code P N M =
     (let Z = M \<inter># N; X = M - Z in
     X \<noteq> {#} \<and> (let Y = N - Z in (\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. P y x)))"
 
 definition multeqp_code :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multeqp_code P N M =
     (let Z = M \<inter># N; X = M - Z; Y = N - Z in
     (\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. P y x))"
 
 lemma multp_code_iff_mult:
   assumes "irrefl_on (set_mset N \<inter> set_mset M) R" and "trans R" and
     [simp]: "\<And>x y. P x y \<longleftrightarrow> (x, y) \<in> R"
   shows "multp_code P N M \<longleftrightarrow> (N, M) \<in> mult R" (is "?L \<longleftrightarrow> ?R")
 proof -
   have *: "M \<inter># N + (N - M \<inter># N) = N" "M \<inter># N + (M - M \<inter># N) = M"
     "(M - M \<inter># N) \<inter># (N - M \<inter># N) = {#}" by (auto simp flip: count_inject)
   show ?thesis
   proof
     assume ?L thus ?R
       using one_step_implies_mult[of "M - M \<inter># N" "N - M \<inter># N" R "M \<inter># N"] *
       by (auto simp: multp_code_def Let_def)
   next
     { fix I J K :: "'a multiset" assume "(I + J) \<inter># (I + K) = {#}"
       then have "I = {#}" by (metis inter_union_distrib_right union_eq_empty)
     } note [dest!] = this
     assume ?R thus ?L
       using mult_cancel_max
       using mult_implies_one_step[OF assms(2), of "N - M \<inter># N" "M - M \<inter># N"]
         mult_cancel_max[OF assms(2,1)] * by (auto simp: multp_code_def)
   qed
 qed
 
 lemma multp_code_iff_multp:
   "irreflp_on (set_mset M \<inter> set_mset N) R \<Longrightarrow> transp R \<Longrightarrow> multp_code R M N \<longleftrightarrow> multp R M N"
   using multp_code_iff_mult[simplified, to_pred, of M N R R] by simp
 
 lemma multp_code_eq_multp:
   assumes "irreflp R" and "transp R"
   shows "multp_code R = multp R"
 proof (intro ext)
   fix M N
   show "multp_code R M N = multp R M N"
   proof (rule multp_code_iff_multp)
     from assms show "irreflp_on (set_mset M \<inter> set_mset N) R"
       by (auto intro: irreflp_on_subset)
   next
     from assms show "transp R"
       by simp
   qed
 qed
 
 lemma multeqp_code_iff_reflcl_mult:
   assumes "irrefl_on (set_mset N \<inter> set_mset M) R" and "trans R" and "\<And>x y. P x y \<longleftrightarrow> (x, y) \<in> R"
   shows "multeqp_code P N M \<longleftrightarrow> (N, M) \<in> (mult R)\<^sup>="
 proof -
   { assume "N \<noteq> M" "M - M \<inter># N = {#}"
     then obtain y where "count N y \<noteq> count M y" by (auto simp flip: count_inject)
     then have "\<exists>y. count M y < count N y" using \<open>M - M \<inter># N = {#}\<close>
       by (auto simp flip: count_inject dest!: le_neq_implies_less fun_cong[of _ _ y])
   }
   then have "multeqp_code P N M \<longleftrightarrow> multp_code P N M \<or> N = M"
     by (auto simp: multeqp_code_def multp_code_def Let_def in_diff_count)
   thus ?thesis
     using multp_code_iff_mult[OF assms] by simp
 qed
 
 lemma multeqp_code_iff_reflclp_multp:
   "irreflp_on (set_mset M \<inter> set_mset N) R \<Longrightarrow> transp R \<Longrightarrow> multeqp_code R M N \<longleftrightarrow> (multp R)\<^sup>=\<^sup>= M N"
   using multeqp_code_iff_reflcl_mult[simplified, to_pred, of M N R R] by simp
 
 lemma multeqp_code_eq_reflclp_multp:
   assumes "irreflp R" and "transp R"
   shows "multeqp_code R = (multp R)\<^sup>=\<^sup>="
 proof (intro ext)
   fix M N
   show "multeqp_code R M N \<longleftrightarrow> (multp R)\<^sup>=\<^sup>= M N"
   proof (rule multeqp_code_iff_reflclp_multp)
     from assms show "irreflp_on (set_mset M \<inter> set_mset N) R"
       by (auto intro: irreflp_on_subset)
   next
     from assms show "transp R"
       by simp
   qed
 qed
 
 
 subsubsection \<open>Monotonicity of multiset union\<close>
 
 lemma mult1_union: "(B, D) \<in> mult1 r \<Longrightarrow> (C + B, C + D) \<in> mult1 r"
   by (force simp: mult1_def)
 
 lemma union_le_mono2: "B < D \<Longrightarrow> C + B < C + (D::'a::preorder multiset)"
 apply (unfold less_multiset_def multp_def mult_def)
 apply (erule trancl_induct)
  apply (blast intro: mult1_union)
 apply (blast intro: mult1_union trancl_trans)
 done
 
 lemma union_le_mono1: "B < D \<Longrightarrow> B + C < D + (C::'a::preorder multiset)"
 apply (subst add.commute [of B C])
 apply (subst add.commute [of D C])
 apply (erule union_le_mono2)
 done
 
 lemma union_less_mono:
   fixes A B C D :: "'a::preorder multiset"
   shows "A < C \<Longrightarrow> B < D \<Longrightarrow> A + B < C + D"
   by (blast intro!: union_le_mono1 union_le_mono2 less_trans)
 
 instantiation multiset :: (preorder) ordered_ab_semigroup_add
 begin
 instance
   by standard (auto simp add: less_eq_multiset_def intro: union_le_mono2)
 end
 
 
 subsubsection \<open>Termination proofs with multiset orders\<close>
 
 lemma multi_member_skip: "x \<in># XS \<Longrightarrow> x \<in># {# y #} + XS"
   and multi_member_this: "x \<in># {# x #} + XS"
   and multi_member_last: "x \<in># {# x #}"
   by auto
 
 definition "ms_strict = mult pair_less"
 definition "ms_weak = ms_strict \<union> Id"
 
 lemma ms_reduction_pair: "reduction_pair (ms_strict, ms_weak)"
 unfolding reduction_pair_def ms_strict_def ms_weak_def pair_less_def
 by (auto intro: wf_mult1 wf_trancl simp: mult_def)
 
 lemma smsI:
   "(set_mset A, set_mset B) \<in> max_strict \<Longrightarrow> (Z + A, Z + B) \<in> ms_strict"
   unfolding ms_strict_def
 by (rule one_step_implies_mult) (auto simp add: max_strict_def pair_less_def elim!:max_ext.cases)
 
 lemma wmsI:
   "(set_mset A, set_mset B) \<in> max_strict \<or> A = {#} \<and> B = {#}
   \<Longrightarrow> (Z + A, Z + B) \<in> ms_weak"
 unfolding ms_weak_def ms_strict_def
 by (auto simp add: pair_less_def max_strict_def elim!:max_ext.cases intro: one_step_implies_mult)
 
 inductive pw_leq
 where
   pw_leq_empty: "pw_leq {#} {#}"
 | pw_leq_step:  "\<lbrakk>(x,y) \<in> pair_leq; pw_leq X Y \<rbrakk> \<Longrightarrow> pw_leq ({#x#} + X) ({#y#} + Y)"
 
 lemma pw_leq_lstep:
   "(x, y) \<in> pair_leq \<Longrightarrow> pw_leq {#x#} {#y#}"
 by (drule pw_leq_step) (rule pw_leq_empty, simp)
 
 lemma pw_leq_split:
   assumes "pw_leq X Y"
   shows "\<exists>A B Z. X = A + Z \<and> Y = B + Z \<and> ((set_mset A, set_mset B) \<in> max_strict \<or> (B = {#} \<and> A = {#}))"
   using assms
 proof induct
   case pw_leq_empty thus ?case by auto
 next
   case (pw_leq_step x y X Y)
   then obtain A B Z where
     [simp]: "X = A + Z" "Y = B + Z"
       and 1[simp]: "(set_mset A, set_mset B) \<in> max_strict \<or> (B = {#} \<and> A = {#})"
     by auto
   from pw_leq_step consider "x = y" | "(x, y) \<in> pair_less"
     unfolding pair_leq_def by auto
   thus ?case
   proof cases
     case [simp]: 1
     have "{#x#} + X = A + ({#y#}+Z) \<and> {#y#} + Y = B + ({#y#}+Z) \<and>
       ((set_mset A, set_mset B) \<in> max_strict \<or> (B = {#} \<and> A = {#}))"
       by auto
     thus ?thesis by blast
   next
     case 2
     let ?A' = "{#x#} + A" and ?B' = "{#y#} + B"
     have "{#x#} + X = ?A' + Z"
       "{#y#} + Y = ?B' + Z"
       by auto
     moreover have
       "(set_mset ?A', set_mset ?B') \<in> max_strict"
       using 1 2 unfolding max_strict_def
       by (auto elim!: max_ext.cases)
     ultimately show ?thesis by blast
   qed
 qed
 
 lemma
   assumes pwleq: "pw_leq Z Z'"
   shows ms_strictI: "(set_mset A, set_mset B) \<in> max_strict \<Longrightarrow> (Z + A, Z' + B) \<in> ms_strict"
     and ms_weakI1:  "(set_mset A, set_mset B) \<in> max_strict \<Longrightarrow> (Z + A, Z' + B) \<in> ms_weak"
     and ms_weakI2:  "(Z + {#}, Z' + {#}) \<in> ms_weak"
 proof -
   from pw_leq_split[OF pwleq]
   obtain A' B' Z''
     where [simp]: "Z = A' + Z''" "Z' = B' + Z''"
     and mx_or_empty: "(set_mset A', set_mset B') \<in> max_strict \<or> (A' = {#} \<and> B' = {#})"
     by blast
   {
     assume max: "(set_mset A, set_mset B) \<in> max_strict"
     from mx_or_empty
     have "(Z'' + (A + A'), Z'' + (B + B')) \<in> ms_strict"
     proof
       assume max': "(set_mset A', set_mset B') \<in> max_strict"
       with max have "(set_mset (A + A'), set_mset (B + B')) \<in> max_strict"
         by (auto simp: max_strict_def intro: max_ext_additive)
       thus ?thesis by (rule smsI)
     next
       assume [simp]: "A' = {#} \<and> B' = {#}"
       show ?thesis by (rule smsI) (auto intro: max)
     qed
     thus "(Z + A, Z' + B) \<in> ms_strict" by (simp add: ac_simps)
     thus "(Z + A, Z' + B) \<in> ms_weak" by (simp add: ms_weak_def)
   }
   from mx_or_empty
   have "(Z'' + A', Z'' + B') \<in> ms_weak" by (rule wmsI)
   thus "(Z + {#}, Z' + {#}) \<in> ms_weak" by (simp add: ac_simps)
 qed
 
 lemma empty_neutral: "{#} + x = x" "x + {#} = x"
 and nonempty_plus: "{# x #} + rs \<noteq> {#}"
 and nonempty_single: "{# x #} \<noteq> {#}"
 by auto
 
 setup \<open>
   let
     fun msetT T = \<^Type>\<open>multiset T\<close>;
 
     fun mk_mset T [] = \<^instantiate>\<open>'a = T in term \<open>{#}\<close>\<close>
       | mk_mset T [x] = \<^instantiate>\<open>'a = T and x in term \<open>{#x#}\<close>\<close>
       | mk_mset T (x :: xs) = \<^Const>\<open>plus \<open>msetT T\<close> for \<open>mk_mset T [x]\<close> \<open>mk_mset T xs\<close>\<close>
 
     fun mset_member_tac ctxt m i =
       if m <= 0 then
         resolve_tac ctxt @{thms multi_member_this} i ORELSE
         resolve_tac ctxt @{thms multi_member_last} i
       else
         resolve_tac ctxt @{thms multi_member_skip} i THEN mset_member_tac ctxt (m - 1) i
 
     fun mset_nonempty_tac ctxt =
       resolve_tac ctxt @{thms nonempty_plus} ORELSE'
       resolve_tac ctxt @{thms nonempty_single}
 
     fun regroup_munion_conv ctxt =
       Function_Lib.regroup_conv ctxt \<^const_abbrev>\<open>empty_mset\<close> \<^const_name>\<open>plus\<close>
         (map (fn t => t RS eq_reflection) (@{thms ac_simps} @ @{thms empty_neutral}))
 
     fun unfold_pwleq_tac ctxt i =
       (resolve_tac ctxt @{thms pw_leq_step} i THEN (fn st => unfold_pwleq_tac ctxt (i + 1) st))
         ORELSE (resolve_tac ctxt @{thms pw_leq_lstep} i)
         ORELSE (resolve_tac ctxt @{thms pw_leq_empty} i)
 
     val set_mset_simps = [@{thm set_mset_empty}, @{thm set_mset_single}, @{thm set_mset_union},
                         @{thm Un_insert_left}, @{thm Un_empty_left}]
   in
     ScnpReconstruct.multiset_setup (ScnpReconstruct.Multiset
     {
       msetT=msetT, mk_mset=mk_mset, mset_regroup_conv=regroup_munion_conv,
       mset_member_tac=mset_member_tac, mset_nonempty_tac=mset_nonempty_tac,
       mset_pwleq_tac=unfold_pwleq_tac, set_of_simps=set_mset_simps,
       smsI'= @{thm ms_strictI}, wmsI2''= @{thm ms_weakI2}, wmsI1= @{thm ms_weakI1},
       reduction_pair = @{thm ms_reduction_pair}
     })
   end
 \<close>
 
 
 subsection \<open>Legacy theorem bindings\<close>
 
 lemmas multi_count_eq = multiset_eq_iff [symmetric]
 
 lemma union_commute: "M + N = N + (M::'a multiset)"
   by (fact add.commute)
 
 lemma union_assoc: "(M + N) + K = M + (N + (K::'a multiset))"
   by (fact add.assoc)
 
 lemma union_lcomm: "M + (N + K) = N + (M + (K::'a multiset))"
   by (fact add.left_commute)
 
 lemmas union_ac = union_assoc union_commute union_lcomm add_mset_commute
 
 lemma union_right_cancel: "M + K = N + K \<longleftrightarrow> M = (N::'a multiset)"
   by (fact add_right_cancel)
 
 lemma union_left_cancel: "K + M = K + N \<longleftrightarrow> M = (N::'a multiset)"
   by (fact add_left_cancel)
 
 lemma multi_union_self_other_eq: "(A::'a multiset) + X = A + Y \<Longrightarrow> X = Y"
   by (fact add_left_imp_eq)
 
 lemma mset_subset_trans: "(M::'a multiset) \<subset># K \<Longrightarrow> K \<subset># N \<Longrightarrow> M \<subset># N"
   by (fact subset_mset.less_trans)
 
 lemma multiset_inter_commute: "A \<inter># B = B \<inter># A"
   by (fact subset_mset.inf.commute)
 
 lemma multiset_inter_assoc: "A \<inter># (B \<inter># C) = A \<inter># B \<inter># C"
   by (fact subset_mset.inf.assoc [symmetric])
 
 lemma multiset_inter_left_commute: "A \<inter># (B \<inter># C) = B \<inter># (A \<inter># C)"
   by (fact subset_mset.inf.left_commute)
 
 lemmas multiset_inter_ac =
   multiset_inter_commute
   multiset_inter_assoc
   multiset_inter_left_commute
 
 lemma mset_le_not_refl: "\<not> M < (M::'a::preorder multiset)"
   by (fact less_irrefl)
 
 lemma mset_le_trans: "K < M \<Longrightarrow> M < N \<Longrightarrow> K < (N::'a::preorder multiset)"
   by (fact less_trans)
 
 lemma mset_le_not_sym: "M < N \<Longrightarrow> \<not> N < (M::'a::preorder multiset)"
   by (fact less_not_sym)
 
 lemma mset_le_asym: "M < N \<Longrightarrow> (\<not> P \<Longrightarrow> N < (M::'a::preorder multiset)) \<Longrightarrow> P"
   by (fact less_asym)
 
 declaration \<open>
   let
     fun multiset_postproc _ maybe_name all_values (T as Type (_, [elem_T])) (Const _ $ t') =
           let
             val (maybe_opt, ps) =
               Nitpick_Model.dest_plain_fun t'
               ||> (~~)
               ||> map (apsnd (snd o HOLogic.dest_number))
             fun elems_for t =
               (case AList.lookup (=) ps t of
                 SOME n => replicate n t
               | NONE => [Const (maybe_name, elem_T --> elem_T) $ t])
           in
             (case maps elems_for (all_values elem_T) @
                  (if maybe_opt then [Const (Nitpick_Model.unrep_mixfix (), elem_T)] else []) of
               [] => \<^Const>\<open>Groups.zero T\<close>
             | ts => foldl1 (fn (s, t) => \<^Const>\<open>add_mset elem_T for s t\<close>) ts)
           end
       | multiset_postproc _ _ _ _ t = t
   in Nitpick_Model.register_term_postprocessor \<^typ>\<open>'a multiset\<close> multiset_postproc end
 \<close>
 
 
 subsection \<open>Naive implementation using lists\<close>
 
 code_datatype mset
 
 lemma [code]: "{#} = mset []"
   by simp
 
 lemma [code]: "add_mset x (mset xs) = mset (x # xs)"
   by simp
 
 lemma [code]: "Multiset.is_empty (mset xs) \<longleftrightarrow> List.null xs"
   by (simp add: Multiset.is_empty_def List.null_def)
 
 lemma union_code [code]: "mset xs + mset ys = mset (xs @ ys)"
   by simp
 
 lemma [code]: "image_mset f (mset xs) = mset (map f xs)"
   by simp
 
 lemma [code]: "filter_mset f (mset xs) = mset (filter f xs)"
   by simp
 
 lemma [code]: "mset xs - mset ys = mset (fold remove1 ys xs)"
   by (rule sym, induct ys arbitrary: xs) (simp_all add: diff_add diff_right_commute diff_diff_add)
 
 lemma [code]:
   "mset xs \<inter># mset ys =
     mset (snd (fold (\<lambda>x (ys, zs).
       if x \<in> set ys then (remove1 x ys, x # zs) else (ys, zs)) xs (ys, [])))"
 proof -
   have "\<And>zs. mset (snd (fold (\<lambda>x (ys, zs).
     if x \<in> set ys then (remove1 x ys, x # zs) else (ys, zs)) xs (ys, zs))) =
       (mset xs \<inter># mset ys) + mset zs"
     by (induct xs arbitrary: ys)
       (auto simp add: inter_add_right1 inter_add_right2 ac_simps)
   then show ?thesis by simp
 qed
 
 lemma [code]:
   "mset xs \<union># mset ys =
     mset (case_prod append (fold (\<lambda>x (ys, zs). (remove1 x ys, x # zs)) xs (ys, [])))"
 proof -
   have "\<And>zs. mset (case_prod append (fold (\<lambda>x (ys, zs). (remove1 x ys, x # zs)) xs (ys, zs))) =
       (mset xs \<union># mset ys) + mset zs"
     by (induct xs arbitrary: ys) (simp_all add: multiset_eq_iff)
   then show ?thesis by simp
 qed
 
 declare in_multiset_in_set [code_unfold]
 
 lemma [code]: "count (mset xs) x = fold (\<lambda>y. if x = y then Suc else id) xs 0"
 proof -
   have "\<And>n. fold (\<lambda>y. if x = y then Suc else id) xs n = count (mset xs) x + n"
     by (induct xs) simp_all
   then show ?thesis by simp
 qed
 
 declare set_mset_mset [code]
 
 declare sorted_list_of_multiset_mset [code]
 
 lemma [code]: \<comment> \<open>not very efficient, but representation-ignorant!\<close>
   "mset_set A = mset (sorted_list_of_set A)"
   apply (cases "finite A")
   apply simp_all
   apply (induct A rule: finite_induct)
   apply simp_all
   done
 
 declare size_mset [code]
 
 fun subset_eq_mset_impl :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool option" where
   "subset_eq_mset_impl [] ys = Some (ys \<noteq> [])"
 | "subset_eq_mset_impl (Cons x xs) ys = (case List.extract ((=) x) ys of
      None \<Rightarrow> None
    | Some (ys1,_,ys2) \<Rightarrow> subset_eq_mset_impl xs (ys1 @ ys2))"
 
 lemma subset_eq_mset_impl: "(subset_eq_mset_impl xs ys = None \<longleftrightarrow> \<not> mset xs \<subseteq># mset ys) \<and>
   (subset_eq_mset_impl xs ys = Some True \<longleftrightarrow> mset xs \<subset># mset ys) \<and>
   (subset_eq_mset_impl xs ys = Some False \<longrightarrow> mset xs = mset ys)"
 proof (induct xs arbitrary: ys)
   case (Nil ys)
   show ?case by (auto simp: subset_mset.zero_less_iff_neq_zero)
 next
   case (Cons x xs ys)
   show ?case
   proof (cases "List.extract ((=) x) ys")
     case None
     hence x: "x \<notin> set ys" by (simp add: extract_None_iff)
     {
       assume "mset (x # xs) \<subseteq># mset ys"
       from set_mset_mono[OF this] x have False by simp
     } note nle = this
     moreover
     {
       assume "mset (x # xs) \<subset># mset ys"
       hence "mset (x # xs) \<subseteq># mset ys" by auto
       from nle[OF this] have False .
     }
     ultimately show ?thesis using None by auto
   next
     case (Some res)
     obtain ys1 y ys2 where res: "res = (ys1,y,ys2)" by (cases res, auto)
     note Some = Some[unfolded res]
     from extract_SomeE[OF Some] have "ys = ys1 @ x # ys2" by simp
     hence id: "mset ys = add_mset x (mset (ys1 @ ys2))"
       by auto
     show ?thesis unfolding subset_eq_mset_impl.simps
       unfolding Some option.simps split
       unfolding id
       using Cons[of "ys1 @ ys2"]
       unfolding subset_mset_def subseteq_mset_def by auto
   qed
 qed
 
 lemma [code]: "mset xs \<subseteq># mset ys \<longleftrightarrow> subset_eq_mset_impl xs ys \<noteq> None"
   using subset_eq_mset_impl[of xs ys] by (cases "subset_eq_mset_impl xs ys", auto)
 
 lemma [code]: "mset xs \<subset># mset ys \<longleftrightarrow> subset_eq_mset_impl xs ys = Some True"
   using subset_eq_mset_impl[of xs ys] by (cases "subset_eq_mset_impl xs ys", auto)
 
 instantiation multiset :: (equal) equal
 begin
 
 definition
   [code del]: "HOL.equal A (B :: 'a multiset) \<longleftrightarrow> A = B"
 lemma [code]: "HOL.equal (mset xs) (mset ys) \<longleftrightarrow> subset_eq_mset_impl xs ys = Some False"
   unfolding equal_multiset_def
   using subset_eq_mset_impl[of xs ys] by (cases "subset_eq_mset_impl xs ys", auto)
 
 instance
   by standard (simp add: equal_multiset_def)
 
 end
 
 declare sum_mset_sum_list [code]
 
 lemma [code]: "prod_mset (mset xs) = fold times xs 1"
 proof -
   have "\<And>x. fold times xs x = prod_mset (mset xs) * x"
     by (induct xs) (simp_all add: ac_simps)
   then show ?thesis by simp
 qed
 
 text \<open>
   Exercise for the casual reader: add implementations for \<^term>\<open>(\<le>)\<close>
   and \<^term>\<open>(<)\<close> (multiset order).
 \<close>
 
 text \<open>Quickcheck generators\<close>
 
 context
   includes term_syntax
 begin
 
 definition
   msetify :: "'a::typerep list \<times> (unit \<Rightarrow> Code_Evaluation.term)
     \<Rightarrow> 'a multiset \<times> (unit \<Rightarrow> Code_Evaluation.term)" where
   [code_unfold]: "msetify xs = Code_Evaluation.valtermify mset {\<cdot>} xs"
 
 end
 
 instantiation multiset :: (random) random
 begin
 
 context
   includes state_combinator_syntax
 begin
 
 definition
   "Quickcheck_Random.random i = Quickcheck_Random.random i \<circ>\<rightarrow> (\<lambda>xs. Pair (msetify xs))"
 
 instance ..
 
 end
 
 end
 
 instantiation multiset :: (full_exhaustive) full_exhaustive
 begin
 
 definition full_exhaustive_multiset :: "('a multiset \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option) \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "full_exhaustive_multiset f i = Quickcheck_Exhaustive.full_exhaustive (\<lambda>xs. f (msetify xs)) i"
 
 instance ..
 
 end
 
 hide_const (open) msetify
 
 
 subsection \<open>BNF setup\<close>
 
 definition rel_mset where
   "rel_mset R X Y \<longleftrightarrow> (\<exists>xs ys. mset xs = X \<and> mset ys = Y \<and> list_all2 R xs ys)"
 
 lemma mset_zip_take_Cons_drop_twice:
   assumes "length xs = length ys" "j \<le> length xs"
   shows "mset (zip (take j xs @ x # drop j xs) (take j ys @ y # drop j ys)) =
     add_mset (x,y) (mset (zip xs ys))"
   using assms
 proof (induct xs ys arbitrary: x y j rule: list_induct2)
   case Nil
   thus ?case
     by simp
 next
   case (Cons x xs y ys)
   thus ?case
   proof (cases "j = 0")
     case True
     thus ?thesis
       by simp
   next
     case False
     then obtain k where k: "j = Suc k"
       by (cases j) simp
     hence "k \<le> length xs"
       using Cons.prems by auto
     hence "mset (zip (take k xs @ x # drop k xs) (take k ys @ y # drop k ys)) =
       add_mset (x,y) (mset (zip xs ys))"
       by (rule Cons.hyps(2))
     thus ?thesis
       unfolding k by auto
   qed
 qed
 
 lemma ex_mset_zip_left:
   assumes "length xs = length ys" "mset xs' = mset xs"
   shows "\<exists>ys'. length ys' = length xs' \<and> mset (zip xs' ys') = mset (zip xs ys)"
 using assms
 proof (induct xs ys arbitrary: xs' rule: list_induct2)
   case Nil
   thus ?case
     by auto
 next
   case (Cons x xs y ys xs')
   obtain j where j_len: "j < length xs'" and nth_j: "xs' ! j = x"
     by (metis Cons.prems in_set_conv_nth list.set_intros(1) mset_eq_setD)
 
   define xsa where "xsa = take j xs' @ drop (Suc j) xs'"
   have "mset xs' = {#x#} + mset xsa"
     unfolding xsa_def using j_len nth_j
     by (metis Cons_nth_drop_Suc union_mset_add_mset_right add_mset_remove_trivial add_diff_cancel_left'
         append_take_drop_id mset.simps(2) mset_append)
   hence ms_x: "mset xsa = mset xs"
     by (simp add: Cons.prems)
   then obtain ysa where
     len_a: "length ysa = length xsa" and ms_a: "mset (zip xsa ysa) = mset (zip xs ys)"
     using Cons.hyps(2) by blast
 
   define ys' where "ys' = take j ysa @ y # drop j ysa"
   have xs': "xs' = take j xsa @ x # drop j xsa"
     using ms_x j_len nth_j Cons.prems xsa_def
     by (metis append_eq_append_conv append_take_drop_id diff_Suc_Suc Cons_nth_drop_Suc length_Cons
       length_drop size_mset)
   have j_len': "j \<le> length xsa"
     using j_len xs' xsa_def
     by (metis add_Suc_right append_take_drop_id length_Cons length_append less_eq_Suc_le not_less)
   have "length ys' = length xs'"
     unfolding ys'_def using Cons.prems len_a ms_x
     by (metis add_Suc_right append_take_drop_id length_Cons length_append mset_eq_length)
   moreover have "mset (zip xs' ys') = mset (zip (x # xs) (y # ys))"
     unfolding xs' ys'_def
     by (rule trans[OF mset_zip_take_Cons_drop_twice])
       (auto simp: len_a ms_a j_len')
   ultimately show ?case
     by blast
 qed
 
 lemma list_all2_reorder_left_invariance:
   assumes rel: "list_all2 R xs ys" and ms_x: "mset xs' = mset xs"
   shows "\<exists>ys'. list_all2 R xs' ys' \<and> mset ys' = mset ys"
 proof -
   have len: "length xs = length ys"
     using rel list_all2_conv_all_nth by auto
   obtain ys' where
     len': "length xs' = length ys'" and ms_xy: "mset (zip xs' ys') = mset (zip xs ys)"
     using len ms_x by (metis ex_mset_zip_left)
   have "list_all2 R xs' ys'"
     using assms(1) len' ms_xy unfolding list_all2_iff by (blast dest: mset_eq_setD)
   moreover have "mset ys' = mset ys"
     using len len' ms_xy map_snd_zip mset_map by metis
   ultimately show ?thesis
     by blast
 qed
 
 lemma ex_mset: "\<exists>xs. mset xs = X"
   by (induct X) (simp, metis mset.simps(2))
 
 inductive pred_mset :: "('a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> bool" 
 where
   "pred_mset P {#}"
 | "\<lbrakk>P a; pred_mset P M\<rbrakk> \<Longrightarrow> pred_mset P (add_mset a M)"
 
 lemma pred_mset_iff: \<comment> \<open>TODO: alias for \<^const>\<open>Multiset.Ball\<close>\<close>
   \<open>pred_mset P M \<longleftrightarrow> Multiset.Ball M P\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?P
   then show ?Q by induction simp_all
 next
   assume ?Q
   then show ?P
     by (induction M) (auto intro: pred_mset.intros)
 qed
 
 bnf "'a multiset"
   map: image_mset
   sets: set_mset
   bd: natLeq
   wits: "{#}"
   rel: rel_mset
   pred: pred_mset
 proof -
   show "image_mset id = id"
     by (rule image_mset.id)
   show "image_mset (g \<circ> f) = image_mset g \<circ> image_mset f" for f g
     unfolding comp_def by (rule ext) (simp add: comp_def image_mset.compositionality)
   show "(\<And>z. z \<in> set_mset X \<Longrightarrow> f z = g z) \<Longrightarrow> image_mset f X = image_mset g X" for f g X
     by (induct X) simp_all
   show "set_mset \<circ> image_mset f = (`) f \<circ> set_mset" for f
     by auto
   show "card_order natLeq"
     by (rule natLeq_card_order)
   show "BNF_Cardinal_Arithmetic.cinfinite natLeq"
     by (rule natLeq_cinfinite)
   show "regularCard natLeq"
     by (rule regularCard_natLeq)
   show "ordLess2 (card_of (set_mset X)) natLeq" for X
     by transfer
       (auto simp: finite_iff_ordLess_natLeq[symmetric])
   show "rel_mset R OO rel_mset S \<le> rel_mset (R OO S)" for R S
     unfolding rel_mset_def[abs_def] OO_def
     apply clarify
     subgoal for X Z Y xs ys' ys zs
       apply (drule list_all2_reorder_left_invariance [where xs = ys' and ys = zs and xs' = ys])
       apply (auto intro: list_all2_trans)
       done
     done
   show "rel_mset R =
     (\<lambda>x y. \<exists>z. set_mset z \<subseteq> {(x, y). R x y} \<and>
     image_mset fst z = x \<and> image_mset snd z = y)" for R
     unfolding rel_mset_def[abs_def]
     apply (rule ext)+
     apply safe
      apply (rule_tac x = "mset (zip xs ys)" in exI;
        auto simp: in_set_zip list_all2_iff simp flip: mset_map)
     apply (rename_tac XY)
     apply (cut_tac X = XY in ex_mset)
     apply (erule exE)
     apply (rename_tac xys)
     apply (rule_tac x = "map fst xys" in exI)
     apply (auto simp: mset_map)
     apply (rule_tac x = "map snd xys" in exI)
     apply (auto simp: mset_map list_all2I subset_eq zip_map_fst_snd)
     done
   show "z \<in> set_mset {#} \<Longrightarrow> False" for z
     by auto
   show "pred_mset P = (\<lambda>x. Ball (set_mset x) P)" for P
     by (simp add: fun_eq_iff pred_mset_iff)
 qed
 
 inductive rel_mset' :: \<open>('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'b multiset \<Rightarrow> bool\<close>
 where
   Zero[intro]: "rel_mset' R {#} {#}"
 | Plus[intro]: "\<lbrakk>R a b; rel_mset' R M N\<rbrakk> \<Longrightarrow> rel_mset' R (add_mset a M) (add_mset b N)"
 
 lemma rel_mset_Zero: "rel_mset R {#} {#}"
 unfolding rel_mset_def Grp_def by auto
 
 declare multiset.count[simp]
 declare count_Abs_multiset[simp]
 declare multiset.count_inverse[simp]
 
 lemma rel_mset_Plus:
   assumes ab: "R a b"
     and MN: "rel_mset R M N"
   shows "rel_mset R (add_mset a M) (add_mset b N)"
 proof -
   have "\<exists>ya. add_mset a (image_mset fst y) = image_mset fst ya \<and>
     add_mset b (image_mset snd y) = image_mset snd ya \<and>
     set_mset ya \<subseteq> {(x, y). R x y}"
     if "R a b" and "set_mset y \<subseteq> {(x, y). R x y}" for y
     using that by (intro exI[of _ "add_mset (a,b) y"]) auto
   thus ?thesis
   using assms
   unfolding multiset.rel_compp_Grp Grp_def by blast
 qed
 
 lemma rel_mset'_imp_rel_mset: "rel_mset' R M N \<Longrightarrow> rel_mset R M N"
   by (induct rule: rel_mset'.induct) (auto simp: rel_mset_Zero rel_mset_Plus)
 
 lemma rel_mset_size: "rel_mset R M N \<Longrightarrow> size M = size N"
   unfolding multiset.rel_compp_Grp Grp_def by auto
 
 lemma rel_mset_Zero_iff [simp]:
   shows "rel_mset rel {#} Y \<longleftrightarrow> Y = {#}" and "rel_mset rel X {#} \<longleftrightarrow> X = {#}"
   by (auto simp add: rel_mset_Zero dest: rel_mset_size)
 
 lemma multiset_induct2[case_names empty addL addR]:
   assumes empty: "P {#} {#}"
     and addL: "\<And>a M N. P M N \<Longrightarrow> P (add_mset a M) N"
     and addR: "\<And>a M N. P M N \<Longrightarrow> P M (add_mset a N)"
   shows "P M N"
 apply(induct N rule: multiset_induct)
   apply(induct M rule: multiset_induct, rule empty, erule addL)
   apply(induct M rule: multiset_induct, erule addR, erule addR)
 done
 
 lemma multiset_induct2_size[consumes 1, case_names empty add]:
   assumes c: "size M = size N"
     and empty: "P {#} {#}"
     and add: "\<And>a b M N a b. P M N \<Longrightarrow> P (add_mset a M) (add_mset b N)"
   shows "P M N"
   using c
 proof (induct M arbitrary: N rule: measure_induct_rule[of size])
   case (less M)
   show ?case
   proof(cases "M = {#}")
     case True hence "N = {#}" using less.prems by auto
     thus ?thesis using True empty by auto
   next
     case False then obtain M1 a where M: "M = add_mset a M1" by (metis multi_nonempty_split)
     have "N \<noteq> {#}" using False less.prems by auto
     then obtain N1 b where N: "N = add_mset b N1" by (metis multi_nonempty_split)
     have "size M1 = size N1" using less.prems unfolding M N by auto
     thus ?thesis using M N less.hyps add by auto
   qed
 qed
 
 lemma msed_map_invL:
   assumes "image_mset f (add_mset a M) = N"
   shows "\<exists>N1. N = add_mset (f a) N1 \<and> image_mset f M = N1"
 proof -
   have "f a \<in># N"
     using assms multiset.set_map[of f "add_mset a M"] by auto
   then obtain N1 where N: "N = add_mset (f a) N1" using multi_member_split by metis
   have "image_mset f M = N1" using assms unfolding N by simp
   thus ?thesis using N by blast
 qed
 
 lemma msed_map_invR:
   assumes "image_mset f M = add_mset b N"
   shows "\<exists>M1 a. M = add_mset a M1 \<and> f a = b \<and> image_mset f M1 = N"
 proof -
   obtain a where a: "a \<in># M" and fa: "f a = b"
     using multiset.set_map[of f M] unfolding assms
     by (metis image_iff union_single_eq_member)
   then obtain M1 where M: "M = add_mset a M1" using multi_member_split by metis
   have "image_mset f M1 = N" using assms unfolding M fa[symmetric] by simp
   thus ?thesis using M fa by blast
 qed
 
 lemma msed_rel_invL:
   assumes "rel_mset R (add_mset a M) N"
   shows "\<exists>N1 b. N = add_mset b N1 \<and> R a b \<and> rel_mset R M N1"
 proof -
   obtain K where KM: "image_mset fst K = add_mset a M"
     and KN: "image_mset snd K = N" and sK: "set_mset K \<subseteq> {(a, b). R a b}"
     using assms
     unfolding multiset.rel_compp_Grp Grp_def by auto
   obtain K1 ab where K: "K = add_mset ab K1" and a: "fst ab = a"
     and K1M: "image_mset fst K1 = M" using msed_map_invR[OF KM] by auto
   obtain N1 where N: "N = add_mset (snd ab) N1" and K1N1: "image_mset snd K1 = N1"
     using msed_map_invL[OF KN[unfolded K]] by auto
   have Rab: "R a (snd ab)" using sK a unfolding K by auto
   have "rel_mset R M N1" using sK K1M K1N1
     unfolding K multiset.rel_compp_Grp Grp_def by auto
   thus ?thesis using N Rab by auto
 qed
 
 lemma msed_rel_invR:
   assumes "rel_mset R M (add_mset b N)"
   shows "\<exists>M1 a. M = add_mset a M1 \<and> R a b \<and> rel_mset R M1 N"
 proof -
   obtain K where KN: "image_mset snd K = add_mset b N"
     and KM: "image_mset fst K = M" and sK: "set_mset K \<subseteq> {(a, b). R a b}"
     using assms
     unfolding multiset.rel_compp_Grp Grp_def by auto
   obtain K1 ab where K: "K = add_mset ab K1" and b: "snd ab = b"
     and K1N: "image_mset snd K1 = N" using msed_map_invR[OF KN] by auto
   obtain M1 where M: "M = add_mset (fst ab) M1" and K1M1: "image_mset fst K1 = M1"
     using msed_map_invL[OF KM[unfolded K]] by auto
   have Rab: "R (fst ab) b" using sK b unfolding K by auto
   have "rel_mset R M1 N" using sK K1N K1M1
     unfolding K multiset.rel_compp_Grp Grp_def by auto
   thus ?thesis using M Rab by auto
 qed
 
 lemma rel_mset_imp_rel_mset':
   assumes "rel_mset R M N"
   shows "rel_mset' R M N"
 using assms proof(induct M arbitrary: N rule: measure_induct_rule[of size])
   case (less M)
   have c: "size M = size N" using rel_mset_size[OF less.prems] .
   show ?case
   proof(cases "M = {#}")
     case True hence "N = {#}" using c by simp
     thus ?thesis using True rel_mset'.Zero by auto
   next
     case False then obtain M1 a where M: "M = add_mset a M1" by (metis multi_nonempty_split)
     obtain N1 b where N: "N = add_mset b N1" and R: "R a b" and ms: "rel_mset R M1 N1"
       using msed_rel_invL[OF less.prems[unfolded M]] by auto
     have "rel_mset' R M1 N1" using less.hyps[of M1 N1] ms unfolding M by simp
     thus ?thesis using rel_mset'.Plus[of R a b, OF R] unfolding M N by simp
   qed
 qed
 
 lemma rel_mset_rel_mset': "rel_mset R M N = rel_mset' R M N"
   using rel_mset_imp_rel_mset' rel_mset'_imp_rel_mset by auto
 
 text \<open>The main end product for \<^const>\<open>rel_mset\<close>: inductive characterization:\<close>
 lemmas rel_mset_induct[case_names empty add, induct pred: rel_mset] =
   rel_mset'.induct[unfolded rel_mset_rel_mset'[symmetric]]
 
 
 subsection \<open>Size setup\<close>
 
 lemma size_multiset_o_map: "size_multiset g \<circ> image_mset f = size_multiset (g \<circ> f)"
   apply (rule ext)
   subgoal for x by (induct x) auto
   done
 
 setup \<open>
   BNF_LFP_Size.register_size_global \<^type_name>\<open>multiset\<close> \<^const_name>\<open>size_multiset\<close>
     @{thm size_multiset_overloaded_def}
     @{thms size_multiset_empty size_multiset_single size_multiset_union size_empty size_single
       size_union}
     @{thms size_multiset_o_map}
 \<close>
 
 subsection \<open>Lemmas about Size\<close>
 
 lemma size_mset_SucE: "size A = Suc n \<Longrightarrow> (\<And>a B. A = {#a#} + B \<Longrightarrow> size B = n \<Longrightarrow> P) \<Longrightarrow> P"
   by (cases A) (auto simp add: ac_simps)
 
 lemma size_Suc_Diff1: "x \<in># M \<Longrightarrow> Suc (size (M - {#x#})) = size M"
   using arg_cong[OF insert_DiffM, of _ _ size] by simp
 
 lemma size_Diff_singleton: "x \<in># M \<Longrightarrow> size (M - {#x#}) = size M - 1"
   by (simp flip: size_Suc_Diff1)
 
 lemma size_Diff_singleton_if: "size (A - {#x#}) = (if x \<in># A then size A - 1 else size A)"
   by (simp add: diff_single_trivial size_Diff_singleton)
 
 lemma size_Un_Int: "size A + size B = size (A \<union># B) + size (A \<inter># B)"
   by (metis inter_subset_eq_union size_union subset_mset.diff_add union_diff_inter_eq_sup)
 
 lemma size_Un_disjoint: "A \<inter># B = {#} \<Longrightarrow> size (A \<union># B) = size A + size B"
   using size_Un_Int[of A B] by simp
 
 lemma size_Diff_subset_Int: "size (M - M') = size M - size (M \<inter># M')"
   by (metis diff_intersect_left_idem size_Diff_submset subset_mset.inf_le1)
 
 lemma diff_size_le_size_Diff: "size (M :: _ multiset) - size M' \<le> size (M - M')"
   by (simp add: diff_le_mono2 size_Diff_subset_Int size_mset_mono)
 
 lemma size_Diff1_less: "x\<in># M \<Longrightarrow> size (M - {#x#}) < size M"
   by (rule Suc_less_SucD) (simp add: size_Suc_Diff1)
 
 lemma size_Diff2_less: "x\<in># M \<Longrightarrow> y\<in># M \<Longrightarrow> size (M - {#x#} - {#y#}) < size M"
   by (metis less_imp_diff_less size_Diff1_less size_Diff_subset_Int)
 
 lemma size_Diff1_le: "size (M - {#x#}) \<le> size M"
   by (cases "x \<in># M") (simp_all add: size_Diff1_less less_imp_le diff_single_trivial)
 
 lemma size_psubset: "M \<subseteq># M' \<Longrightarrow> size M < size M' \<Longrightarrow> M \<subset># M'"
   using less_irrefl subset_mset_def by blast
 
 lifting_update multiset.lifting
 lifting_forget multiset.lifting
 
 hide_const (open) wcount
 
 end
diff --git a/src/HOL/Library/Multiset_Order.thy b/src/HOL/Library/Multiset_Order.thy
--- a/src/HOL/Library/Multiset_Order.thy
+++ b/src/HOL/Library/Multiset_Order.thy
@@ -1,856 +1,915 @@
 (*  Title:      HOL/Library/Multiset_Order.thy
     Author:     Dmitriy Traytel, TU Muenchen
     Author:     Jasmin Blanchette, Inria, LORIA, MPII
     Author:     Martin Desharnais, MPI-INF Saarbruecken
 *)
 
 section \<open>More Theorems about the Multiset Order\<close>
 
 theory Multiset_Order
 imports Multiset
 begin
 
 subsection \<open>Alternative Characterizations\<close>
 
 subsubsection \<open>The Dershowitz--Manna Ordering\<close>
 
 definition multp\<^sub>D\<^sub>M where
   "multp\<^sub>D\<^sub>M r M N \<longleftrightarrow>
    (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = (N - X) + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> r k a)))"
 
 lemma multp\<^sub>D\<^sub>M_imp_multp:
   "multp\<^sub>D\<^sub>M r M N \<Longrightarrow> multp r M N"
 proof -
   assume "multp\<^sub>D\<^sub>M r M N"
   then obtain X Y where
     "X \<noteq> {#}" and "X \<subseteq># N" and "M = N - X + Y" and "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> r k a)"
     unfolding multp\<^sub>D\<^sub>M_def by blast
   then have "multp r (N - X + Y) (N - X + X)"
     by (intro one_step_implies_multp) (auto simp: Bex_def trans_def)
   with \<open>M = N - X + Y\<close> \<open>X \<subseteq># N\<close> show "multp r M N"
     by (metis subset_mset.diff_add)
 qed
 
 subsubsection \<open>The Huet--Oppen Ordering\<close>
 
 definition multp\<^sub>H\<^sub>O where
   "multp\<^sub>H\<^sub>O r M N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. r y x \<and> count M x < count N x))"
 
 lemma multp_imp_multp\<^sub>H\<^sub>O:
   assumes "asymp r" and "transp r"
   shows "multp r M N \<Longrightarrow> multp\<^sub>H\<^sub>O r M N"
   unfolding multp_def mult_def
 proof (induction rule: trancl_induct)
   case (base P)
   then show ?case
     using \<open>asymp r\<close>
     by (auto elim!: mult1_lessE simp: count_eq_zero_iff multp\<^sub>H\<^sub>O_def split: if_splits
         dest!: Suc_lessD)
 next
   case (step N P)
   from step(3) have "M \<noteq> N" and
     **: "\<And>y. count N y < count M y \<Longrightarrow> (\<exists>x. r y x \<and> count M x < count N x)"
     by (simp_all add: multp\<^sub>H\<^sub>O_def)
   from step(2) obtain M0 a K where
     *: "P = add_mset a M0" "N = M0 + K" "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> r b a"
     using \<open>asymp r\<close> by (auto elim: mult1_lessE)
   from \<open>M \<noteq> N\<close> ** *(1,2,3) have "M \<noteq> P"
     using *(4) \<open>asymp r\<close>
     by (metis asympD add_cancel_right_right add_diff_cancel_left' add_mset_add_single count_inI
         count_union diff_diff_add_mset diff_single_trivial in_diff_count multi_member_last)
   moreover
   { assume "count P a \<le> count M a"
     with \<open>a \<notin># K\<close> have "count N a < count M a" unfolding *(1,2)
       by (auto simp add: not_in_iff)
       with ** obtain z where z: "r a z" "count M z < count N z"
         by blast
       with * have "count N z \<le> count P z"
         using \<open>asymp r\<close>
         by (metis add_diff_cancel_left' add_mset_add_single asympD diff_diff_add_mset
             diff_single_trivial in_diff_count not_le_imp_less)
       with z have "\<exists>z. r a z \<and> count M z < count P z" by auto
   } note count_a = this
   { fix y
     assume count_y: "count P y < count M y"
     have "\<exists>x. r y x \<and> count M x < count P x"
     proof (cases "y = a")
       case True
       with count_y count_a show ?thesis by auto
     next
       case False
       show ?thesis
       proof (cases "y \<in># K")
         case True
         with *(4) have "r y a" by simp
         then show ?thesis
           by (cases "count P a \<le> count M a") (auto dest: count_a intro: \<open>transp r\<close>[THEN transpD])
       next
         case False
         with \<open>y \<noteq> a\<close> have "count P y = count N y" unfolding *(1,2)
           by (simp add: not_in_iff)
         with count_y ** obtain z where z: "r y z" "count M z < count N z" by auto
         show ?thesis
         proof (cases "z \<in># K")
           case True
           with *(4) have "r z a" by simp
           with z(1) show ?thesis
             by (cases "count P a \<le> count M a") (auto dest!: count_a intro: \<open>transp r\<close>[THEN transpD])
         next
           case False
           with \<open>a \<notin># K\<close> have "count N z \<le> count P z" unfolding *
             by (auto simp add: not_in_iff)
           with z show ?thesis by auto
         qed
       qed
     qed
   }
   ultimately show ?case unfolding multp\<^sub>H\<^sub>O_def by blast
 qed
 
 lemma multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M: "multp\<^sub>H\<^sub>O r M N \<Longrightarrow> multp\<^sub>D\<^sub>M r M N"
 unfolding multp\<^sub>D\<^sub>M_def
 proof (intro iffI exI conjI)
   assume "multp\<^sub>H\<^sub>O r M N"
   then obtain z where z: "count M z < count N z"
     unfolding multp\<^sub>H\<^sub>O_def by (auto simp: multiset_eq_iff nat_neq_iff)
   define X where "X = N - M"
   define Y where "Y = M - N"
   from z show "X \<noteq> {#}" unfolding X_def by (auto simp: multiset_eq_iff not_less_eq_eq Suc_le_eq)
   from z show "X \<subseteq># N" unfolding X_def by auto
   show "M = (N - X) + Y" unfolding X_def Y_def multiset_eq_iff count_union count_diff by force
   show "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> r k a)"
   proof (intro allI impI)
     fix k
     assume "k \<in># Y"
     then have "count N k < count M k" unfolding Y_def
       by (auto simp add: in_diff_count)
     with \<open>multp\<^sub>H\<^sub>O r M N\<close> obtain a where "r k a" and "count M a < count N a"
       unfolding multp\<^sub>H\<^sub>O_def by blast
     then show "\<exists>a. a \<in># X \<and> r k a" unfolding X_def
       by (auto simp add: in_diff_count)
   qed
 qed
 
 lemma multp_eq_multp\<^sub>D\<^sub>M: "asymp r \<Longrightarrow> transp r \<Longrightarrow> multp r = multp\<^sub>D\<^sub>M r"
   using multp\<^sub>D\<^sub>M_imp_multp multp_imp_multp\<^sub>H\<^sub>O[THEN multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M]
   by blast
 
 lemma multp_eq_multp\<^sub>H\<^sub>O: "asymp r \<Longrightarrow> transp r \<Longrightarrow> multp r = multp\<^sub>H\<^sub>O r"
   using multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M[THEN multp\<^sub>D\<^sub>M_imp_multp] multp_imp_multp\<^sub>H\<^sub>O
   by blast
 
 lemma multp\<^sub>D\<^sub>M_plus_plusI[simp]:
   assumes "multp\<^sub>D\<^sub>M R M1 M2"
   shows "multp\<^sub>D\<^sub>M R (M + M1) (M + M2)"
 proof -
   from assms obtain X Y where
     "X \<noteq> {#}" and "X \<subseteq># M2" and "M1 = M2 - X + Y" and "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)"
   unfolding multp\<^sub>D\<^sub>M_def by auto
 
   show "multp\<^sub>D\<^sub>M R (M + M1) (M + M2)"
     unfolding multp\<^sub>D\<^sub>M_def
   proof (intro exI conjI)
     show "X \<noteq> {#}"
       using \<open>X \<noteq> {#}\<close> by simp
   next
     show "X \<subseteq># M + M2"
       using \<open>X \<subseteq># M2\<close>
       by (simp add: subset_mset.add_increasing)
   next
     show "M + M1 = M + M2 - X + Y"
       using \<open>X \<subseteq># M2\<close> \<open>M1 = M2 - X + Y\<close>
       by (metis multiset_diff_union_assoc union_assoc)
   next
     show "\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)"
       using \<open>\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> R k a)\<close> by simp
   qed
 qed
 
 lemma multp\<^sub>H\<^sub>O_plus_plus[simp]: "multp\<^sub>H\<^sub>O R (M + M1) (M + M2) \<longleftrightarrow> multp\<^sub>H\<^sub>O R M1 M2"
   unfolding multp\<^sub>H\<^sub>O_def by simp
 
 lemma strict_subset_implies_multp\<^sub>D\<^sub>M: "A \<subset># B \<Longrightarrow> multp\<^sub>D\<^sub>M r A B"
   unfolding multp\<^sub>D\<^sub>M_def
   by (metis add.right_neutral add_diff_cancel_right' empty_iff mset_subset_eq_add_right
       set_mset_empty subset_mset.lessE)
 
 lemma strict_subset_implies_multp\<^sub>H\<^sub>O: "A \<subset># B \<Longrightarrow> multp\<^sub>H\<^sub>O r A B"
   unfolding multp\<^sub>H\<^sub>O_def
   by (simp add: leD mset_subset_eq_count)
 
 lemma multp\<^sub>H\<^sub>O_implies_one_step_strong:
   assumes "multp\<^sub>H\<^sub>O R A B"
   defines "J \<equiv> B - A" and "K \<equiv> A - B"
   shows "J \<noteq> {#}" and "\<forall>k \<in># K. \<exists>x \<in># J. R k x"
 proof -
   show "J \<noteq> {#}"
   using \<open>multp\<^sub>H\<^sub>O R A B\<close>
   by (metis Diff_eq_empty_iff_mset J_def add.right_neutral multp\<^sub>D\<^sub>M_def multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M
       multp\<^sub>H\<^sub>O_plus_plus subset_mset.add_diff_inverse subset_mset.le_zero_eq)
 
   show "\<forall>k\<in>#K. \<exists>x\<in>#J. R k x"
     using \<open>multp\<^sub>H\<^sub>O R A B\<close>
     by (metis J_def K_def in_diff_count multp\<^sub>H\<^sub>O_def)
 qed
 
 lemma multp\<^sub>H\<^sub>O_minus_inter_minus_inter_iff:
   fixes M1 M2 :: "_ multiset"
   shows "multp\<^sub>H\<^sub>O R (M1 - M2) (M2 - M1) \<longleftrightarrow> multp\<^sub>H\<^sub>O R M1 M2"
   by (metis diff_intersect_left_idem multiset_inter_commute multp\<^sub>H\<^sub>O_plus_plus
       subset_mset.add_diff_inverse subset_mset.inf.cobounded1)
 
 lemma multp\<^sub>H\<^sub>O_iff_set_mset_less\<^sub>H\<^sub>O_set_mset:
   "multp\<^sub>H\<^sub>O R M1 M2 \<longleftrightarrow> (set_mset (M1 - M2) \<noteq> set_mset (M2 - M1) \<and>
     (\<forall>y \<in># M1 - M2. (\<exists>x \<in># M2 - M1. R y x)))"
   unfolding multp\<^sub>H\<^sub>O_minus_inter_minus_inter_iff[of R M1 M2, symmetric]
   unfolding multp\<^sub>H\<^sub>O_def
   unfolding count_minus_inter_lt_count_minus_inter_iff
   unfolding minus_inter_eq_minus_inter_iff
   by auto
 
 
 subsubsection \<open>Monotonicity\<close>
 
 lemma multp\<^sub>D\<^sub>M_mono_strong:
   "multp\<^sub>D\<^sub>M R M1 M2 \<Longrightarrow> (\<And>x y. x \<in># M1 \<Longrightarrow> y \<in># M2 \<Longrightarrow> R x y \<Longrightarrow> S x y) \<Longrightarrow> multp\<^sub>D\<^sub>M S M1 M2"
   unfolding multp\<^sub>D\<^sub>M_def
   by (metis add_diff_cancel_left' in_diffD subset_mset.diff_add)
 
 lemma multp\<^sub>H\<^sub>O_mono_strong:
   "multp\<^sub>H\<^sub>O R M1 M2 \<Longrightarrow> (\<And>x y. x \<in># M1 \<Longrightarrow> y \<in># M2 \<Longrightarrow> R x y \<Longrightarrow> S x y) \<Longrightarrow> multp\<^sub>H\<^sub>O S M1 M2"
   unfolding multp\<^sub>H\<^sub>O_def
   by (metis count_inI less_zeroE)
 
 
 subsubsection \<open>Properties of Orders\<close>
 
 paragraph \<open>Asymmetry\<close>
 
 text \<open>The following lemma is a negative result stating that asymmetry of an arbitrary binary
 relation cannot be simply lifted to @{const multp\<^sub>H\<^sub>O}. It suffices to have four distinct values to
 build a counterexample.\<close>
 
 lemma asymp_not_liftable_to_multp\<^sub>H\<^sub>O:
   fixes a b c d :: 'a
   assumes "distinct [a, b, c, d]"
   shows "\<not> (\<forall>(R :: 'a \<Rightarrow> 'a \<Rightarrow> bool). asymp R \<longrightarrow> asymp (multp\<^sub>H\<^sub>O R))"
 proof -
   define R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" where
     "R = (\<lambda>x y. x = a \<and> y = c \<or> x = b \<and> y = d \<or> x = c \<and> y = b \<or> x = d \<and> y = a)"
 
   from assms(1) have "{#a, b#} \<noteq> {#c, d#}"
     by (metis add_mset_add_single distinct.simps(2) list.set(1) list.simps(15) multi_member_this
         set_mset_add_mset_insert set_mset_single)
 
   from assms(1) have "asymp R"
     by (auto simp: R_def intro: asymp_onI)
   moreover have "\<not> asymp (multp\<^sub>H\<^sub>O R)"
     unfolding asymp_on_def Set.ball_simps not_all not_imp not_not
   proof (intro exI conjI)
     show "multp\<^sub>H\<^sub>O R {#a, b#} {#c, d#}"
       unfolding multp\<^sub>H\<^sub>O_def
       using \<open>{#a, b#} \<noteq> {#c, d#}\<close> R_def assms by auto
   next
     show "multp\<^sub>H\<^sub>O R {#c, d#} {#a, b#}"
       unfolding multp\<^sub>H\<^sub>O_def
       using \<open>{#a, b#} \<noteq> {#c, d#}\<close> R_def assms by auto
   qed
   ultimately show ?thesis
     unfolding not_all not_imp by auto
 qed
 
 text \<open>However, if the binary relation is both asymmetric and transitive, then @{const multp\<^sub>H\<^sub>O} is
 also asymmetric.\<close>
 
 lemma asymp_on_multp\<^sub>H\<^sub>O:
   assumes "asymp_on A R" and "transp_on A R" and
     B_sub_A: "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "asymp_on B (multp\<^sub>H\<^sub>O R)"
 proof (rule asymp_onI)
   fix M1 M2 :: "'a multiset"
   assume "M1 \<in> B" "M2 \<in> B" "multp\<^sub>H\<^sub>O R M1 M2"
 
   from \<open>transp_on A R\<close> B_sub_A have tran: "transp_on (set_mset (M1 - M2)) R"
     using \<open>M1 \<in> B\<close>
     by (meson in_diffD subset_eq transp_on_subset)
 
   from \<open>asymp_on A R\<close> B_sub_A have asym: "asymp_on (set_mset (M1 - M2)) R"
     using \<open>M1 \<in> B\<close>
     by (meson in_diffD subset_eq asymp_on_subset)
 
   show "\<not> multp\<^sub>H\<^sub>O R M2 M1"
   proof (cases "M1 - M2 = {#}")
     case True
     then show ?thesis
       using multp\<^sub>H\<^sub>O_implies_one_step_strong(1) by metis
   next
     case False
     hence "\<exists>m\<in>#M1 - M2. \<forall>x\<in>#M1 - M2. x \<noteq> m \<longrightarrow> \<not> R m x"
       using Finite_Set.bex_max_element[of "set_mset (M1 - M2)" R, OF finite_set_mset asym tran]
       by simp
     with \<open>transp_on A R\<close> B_sub_A have "\<exists>y\<in>#M2 - M1. \<forall>x\<in>#M1 - M2. \<not> R y x"
       using \<open>multp\<^sub>H\<^sub>O R M1 M2\<close>[THEN multp\<^sub>H\<^sub>O_implies_one_step_strong(2)]
       using asym[THEN irreflp_on_if_asymp_on, THEN irreflp_onD]
       by (metis \<open>M1 \<in> B\<close> \<open>M2 \<in> B\<close> in_diffD subsetD transp_onD)
     thus ?thesis
       unfolding multp\<^sub>H\<^sub>O_iff_set_mset_less\<^sub>H\<^sub>O_set_mset by simp
   qed
 qed
 
 lemma asymp_multp\<^sub>H\<^sub>O:
   assumes "asymp R" and "transp R"
   shows "asymp (multp\<^sub>H\<^sub>O R)"
   using assms asymp_on_multp\<^sub>H\<^sub>O[of UNIV, simplified] by metis
 
 
 paragraph \<open>Irreflexivity\<close>
 
 lemma irreflp_on_multp\<^sub>H\<^sub>O[simp]: "irreflp_on B (multp\<^sub>H\<^sub>O R)"
     by (simp add: irreflp_onI multp\<^sub>H\<^sub>O_def)
 
 
 paragraph \<open>Transitivity\<close>
 
 lemma transp_on_multp\<^sub>H\<^sub>O:
   assumes "asymp_on A R" and "transp_on A R" and
     B_sub_A: "\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A"
   shows "transp_on B (multp\<^sub>H\<^sub>O R)"
 proof (rule transp_onI)
   from assms have "asymp_on B (multp\<^sub>H\<^sub>O R)"
     using asymp_on_multp\<^sub>H\<^sub>O by metis
 
   fix M1 M2 M3
   assume hyps: "M1 \<in> B" "M2 \<in> B" "M3 \<in> B" "multp\<^sub>H\<^sub>O R M1 M2" "multp\<^sub>H\<^sub>O R M2 M3"
 
   from assms have
     [intro]: "asymp_on (set_mset M1 \<union> set_mset M2) R" "transp_on (set_mset M1 \<union> set_mset M2) R"
     using \<open>M1 \<in> B\<close> \<open>M2 \<in> B\<close>
     by (simp_all add: asymp_on_subset transp_on_subset)
 
   from assms have "transp_on (set_mset M1) R"
     by (meson transp_on_subset hyps(1))
 
   from \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> have
     "M1 \<noteq> M2" and
     "\<forall>y. count M2 y < count M1 y \<longrightarrow> (\<exists>x. R y x \<and> count M1 x < count M2 x)"
     unfolding multp\<^sub>H\<^sub>O_def by simp_all
 
   from \<open>multp\<^sub>H\<^sub>O R M2 M3\<close> have
     "M2 \<noteq> M3" and
     "\<forall>y. count M3 y < count M2 y \<longrightarrow> (\<exists>x. R y x \<and> count M2 x < count M3 x)"
     unfolding multp\<^sub>H\<^sub>O_def by simp_all
 
   show "multp\<^sub>H\<^sub>O R M1 M3"
   proof (rule ccontr)
     let ?P = "\<lambda>x. count M3 x < count M1 x \<and> (\<forall>y. R x y \<longrightarrow> count M1 y \<ge> count M3 y)"
 
     assume "\<not> multp\<^sub>H\<^sub>O R M1 M3"
     hence "M1 = M3 \<or> (\<exists>x. ?P x)"
       unfolding multp\<^sub>H\<^sub>O_def by force
     thus False
     proof (elim disjE)
       assume "M1 = M3"
       thus False
         using \<open>asymp_on B (multp\<^sub>H\<^sub>O R)\<close>[THEN asymp_onD]
         using \<open>M2 \<in> B\<close> \<open>M3 \<in> B\<close> \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> \<open>multp\<^sub>H\<^sub>O R M2 M3\<close>
         by metis
     next
       assume "\<exists>x. ?P x"
       hence "\<exists>x \<in># M1 + M2. ?P x"
         by (auto simp: count_inI)
       have "\<exists>y \<in># M1 + M2. ?P y \<and> (\<forall>z \<in># M1 + M2. R y z \<longrightarrow> \<not> ?P z)"
       proof (rule Finite_Set.bex_max_element_with_property)
         show "\<exists>x \<in># M1 + M2. ?P x"
           using \<open>\<exists>x. ?P x\<close>
           by (auto simp: count_inI)
       qed auto
       then obtain x where
         "x \<in># M1 + M2" and
         "count M3 x < count M1 x" and
         "\<forall>y. R x y \<longrightarrow> count M1 y \<ge> count M3 y" and
         "\<forall>y \<in># M1 + M2. R x y \<longrightarrow> count M3 y < count M1 y \<longrightarrow> (\<exists>z. R y z \<and> count M1 z < count M3 z)"
         by force
 
       let ?Q = "\<lambda>x'. R\<^sup>=\<^sup>= x x' \<and> count M3 x' < count M2 x'"
       show False
       proof (cases "\<exists>x'. ?Q x'")
         case True
         have "\<exists>y \<in># M1 + M2. ?Q y \<and> (\<forall>z \<in># M1 + M2. R y z \<longrightarrow> \<not> ?Q z)"
         proof (rule Finite_Set.bex_max_element_with_property)
           show "\<exists>x \<in># M1 + M2. ?Q x"
             using \<open>\<exists>x. ?Q x\<close>
             by (auto simp: count_inI)
         qed auto
         then obtain x' where
           "x' \<in># M1 + M2" and
           "R\<^sup>=\<^sup>= x x'" and
           "count M3 x' < count M2 x'" and
           maximality_x': "\<forall>z \<in># M1 + M2. R x' z \<longrightarrow> \<not> (R\<^sup>=\<^sup>= x z) \<or> count M3 z \<ge> count M2 z"
           by (auto simp: linorder_not_less)
         with \<open>multp\<^sub>H\<^sub>O R M2 M3\<close> obtain y' where
           "R x' y'" and "count M2 y' < count M3 y'"
           unfolding multp\<^sub>H\<^sub>O_def by auto
         hence "count M2 y' < count M1 y'"
           by (smt (verit) \<open>R\<^sup>=\<^sup>= x x'\<close> \<open>\<forall>y. R x y \<longrightarrow> count M3 y \<le> count M1 y\<close>
               \<open>count M3 x < count M1 x\<close> \<open>count M3 x' < count M2 x'\<close> assms(2) count_inI
               dual_order.strict_trans1 hyps(1) hyps(2) hyps(3) less_nat_zero_code B_sub_A subsetD
               sup2E transp_onD)
         with \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> obtain y'' where
           "R y' y''" and "count M1 y'' < count M2 y''"
           unfolding multp\<^sub>H\<^sub>O_def by auto
         hence "count M3 y'' < count M2 y''"
           by (smt (verit, del_insts) \<open>R x' y'\<close> \<open>R\<^sup>=\<^sup>= x x'\<close> \<open>\<forall>y. R x y \<longrightarrow> count M3 y \<le> count M1 y\<close>
               \<open>count M2 y' < count M3 y'\<close> \<open>count M3 x < count M1 x\<close> \<open>count M3 x' < count M2 x'\<close>
               assms(2) count_greater_zero_iff dual_order.strict_trans1 hyps(1) hyps(2) hyps(3)
               less_nat_zero_code linorder_not_less B_sub_A subset_iff sup2E transp_onD)
 
         moreover have "count M2 y'' \<le> count M3 y''"
         proof -
           have "y'' \<in># M1 + M2"
             by (metis \<open>count M1 y'' < count M2 y''\<close> count_inI not_less_iff_gr_or_eq union_iff)
 
           moreover have "R x' y''"
             by (metis \<open>R x' y'\<close> \<open>R y' y''\<close> \<open>count M2 y' < count M1 y'\<close>
                 \<open>transp_on (set_mset M1 \<union> set_mset M2) R\<close> \<open>x' \<in># M1 + M2\<close> calculation count_inI
                 nat_neq_iff set_mset_union transp_onD union_iff)
 
           moreover have "R\<^sup>=\<^sup>= x y''"
             using \<open>R\<^sup>=\<^sup>= x x'\<close>
             by (metis (mono_tags, opaque_lifting) \<open>transp_on (set_mset M1 \<union> set_mset M2) R\<close>
                 \<open>x \<in># M1 + M2\<close> \<open>x' \<in># M1 + M2\<close> calculation(1) calculation(2) set_mset_union sup2I1
                 transp_onD transp_on_reflclp)
 
           ultimately show ?thesis
             using maximality_x'[rule_format, of y''] by metis
         qed
 
         ultimately show ?thesis
           by linarith
       next
         case False
         hence "\<And>x'. R\<^sup>=\<^sup>= x x' \<Longrightarrow> count M2 x' \<le> count M3 x'"
           by auto
         hence "count M2 x \<le> count M3 x"
           by simp
         hence "count M2 x < count M1 x"
           using \<open>count M3 x < count M1 x\<close> by linarith
         with \<open>multp\<^sub>H\<^sub>O R M1 M2\<close> obtain y where
           "R x y" and "count M1 y < count M2 y"
           unfolding multp\<^sub>H\<^sub>O_def by auto
         hence "count M3 y < count M2 y"
           using \<open>\<forall>y. R x y \<longrightarrow> count M3 y \<le> count M1 y\<close> dual_order.strict_trans2 by metis
         then show ?thesis
           using False \<open>R x y\<close> by auto
       qed
     qed
   qed
 qed
 
 lemma transp_multp\<^sub>H\<^sub>O:
   assumes "asymp R" and "transp R"
   shows "transp (multp\<^sub>H\<^sub>O R)"
   using assms transp_on_multp\<^sub>H\<^sub>O[of UNIV, simplified] by metis
 
 
 paragraph \<open>Totality\<close>
 
 lemma totalp_on_multp\<^sub>D\<^sub>M:
   "totalp_on A R \<Longrightarrow> (\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A) \<Longrightarrow> totalp_on B (multp\<^sub>D\<^sub>M R)"
   by (smt (verit, ccfv_SIG) count_inI in_mono multp\<^sub>H\<^sub>O_def multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M not_less_iff_gr_or_eq
       totalp_onD totalp_onI)
 
 lemma totalp_multp\<^sub>D\<^sub>M: "totalp R \<Longrightarrow> totalp (multp\<^sub>D\<^sub>M R)"
   by (rule totalp_on_multp\<^sub>D\<^sub>M[of UNIV R UNIV, simplified])
 
 lemma totalp_on_multp\<^sub>H\<^sub>O:
   "totalp_on A R \<Longrightarrow> (\<And>M. M \<in> B \<Longrightarrow> set_mset M \<subseteq> A) \<Longrightarrow> totalp_on B (multp\<^sub>H\<^sub>O R)"
   by (smt (verit, ccfv_SIG) count_inI in_mono multp\<^sub>H\<^sub>O_def not_less_iff_gr_or_eq totalp_onD
       totalp_onI)
 
 lemma totalp_multp\<^sub>H\<^sub>O: "totalp R \<Longrightarrow> totalp (multp\<^sub>H\<^sub>O R)"
   by (rule totalp_on_multp\<^sub>H\<^sub>O[of UNIV R UNIV, simplified])
 
 
 paragraph \<open>Type Classes\<close>
 
 context preorder
 begin
 
 lemma order_mult: "class.order
   (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y} \<or> M = N)
   (\<lambda>M N. (M, N) \<in> mult {(x, y). x < y})"
   (is "class.order ?le ?less")
 proof -
   have irrefl: "\<And>M :: 'a multiset. \<not> ?less M M"
   proof
     fix M :: "'a multiset"
     have "trans {(x'::'a, x). x' < x}"
       by (rule transI) (blast intro: less_trans)
     moreover
     assume "(M, M) \<in> mult {(x, y). x < y}"
     ultimately have "\<exists>I J K. M = I + J \<and> M = I + K
       \<and> J \<noteq> {#} \<and> (\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})"
       by (rule mult_implies_one_step)
     then obtain I J K where "M = I + J" and "M = I + K"
       and "J \<noteq> {#}" and "(\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset J. (k, j) \<in> {(x, y). x < y})" by blast
     then have aux1: "K \<noteq> {#}" and aux2: "\<forall>k\<in>set_mset K. \<exists>j\<in>set_mset K. k < j" by auto
     have "finite (set_mset K)" by simp
     moreover note aux2
     ultimately have "set_mset K = {}"
       by (induct rule: finite_induct)
        (simp, metis (mono_tags) insert_absorb insert_iff insert_not_empty less_irrefl less_trans)
     with aux1 show False by simp
   qed
   have trans: "\<And>K M N :: 'a multiset. ?less K M \<Longrightarrow> ?less M N \<Longrightarrow> ?less K N"
     unfolding mult_def by (blast intro: trancl_trans)
   show "class.order ?le ?less"
     by standard (auto simp add: less_eq_multiset_def irrefl dest: trans)
 qed
 
 text \<open>The Dershowitz--Manna ordering:\<close>
 
 definition less_multiset\<^sub>D\<^sub>M where
   "less_multiset\<^sub>D\<^sub>M M N \<longleftrightarrow>
    (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = (N - X) + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)))"
 
 
 text \<open>The Huet--Oppen ordering:\<close>
 
 definition less_multiset\<^sub>H\<^sub>O where
   "less_multiset\<^sub>H\<^sub>O M N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"
 
 lemma mult_imp_less_multiset\<^sub>H\<^sub>O:
   "(M, N) \<in> mult {(x, y). x < y} \<Longrightarrow> less_multiset\<^sub>H\<^sub>O M N"
   unfolding multp_def[of "(<)", symmetric]
   using multp_imp_multp\<^sub>H\<^sub>O[of "(<)"]
   by (simp add: less_multiset\<^sub>H\<^sub>O_def multp\<^sub>H\<^sub>O_def)
 
 lemma less_multiset\<^sub>D\<^sub>M_imp_mult:
   "less_multiset\<^sub>D\<^sub>M M N \<Longrightarrow> (M, N) \<in> mult {(x, y). x < y}"
   unfolding multp_def[of "(<)", symmetric]
   by (rule multp\<^sub>D\<^sub>M_imp_multp[of "(<)" M N]) (simp add: less_multiset\<^sub>D\<^sub>M_def multp\<^sub>D\<^sub>M_def)
 
 lemma less_multiset\<^sub>H\<^sub>O_imp_less_multiset\<^sub>D\<^sub>M: "less_multiset\<^sub>H\<^sub>O M N \<Longrightarrow> less_multiset\<^sub>D\<^sub>M M N"
   unfolding less_multiset\<^sub>D\<^sub>M_def less_multiset\<^sub>H\<^sub>O_def
   unfolding multp\<^sub>D\<^sub>M_def[symmetric] multp\<^sub>H\<^sub>O_def[symmetric]
   by (rule multp\<^sub>H\<^sub>O_imp_multp\<^sub>D\<^sub>M)
 
 lemma mult_less_multiset\<^sub>D\<^sub>M: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>D\<^sub>M M N"
   unfolding multp_def[of "(<)", symmetric]
   using multp_eq_multp\<^sub>D\<^sub>M[of "(<)", simplified]
   by (simp add: multp\<^sub>D\<^sub>M_def less_multiset\<^sub>D\<^sub>M_def)
 
 lemma mult_less_multiset\<^sub>H\<^sub>O: "(M, N) \<in> mult {(x, y). x < y} \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
   unfolding multp_def[of "(<)", symmetric]
   using multp_eq_multp\<^sub>H\<^sub>O[of "(<)", simplified]
   by (simp add: multp\<^sub>H\<^sub>O_def less_multiset\<^sub>H\<^sub>O_def)
 
 lemmas mult\<^sub>D\<^sub>M = mult_less_multiset\<^sub>D\<^sub>M[unfolded less_multiset\<^sub>D\<^sub>M_def]
 lemmas mult\<^sub>H\<^sub>O = mult_less_multiset\<^sub>H\<^sub>O[unfolded less_multiset\<^sub>H\<^sub>O_def]
 
 end
 
 lemma less_multiset_less_multiset\<^sub>H\<^sub>O: "M < N \<longleftrightarrow> less_multiset\<^sub>H\<^sub>O M N"
   unfolding less_multiset_def multp_def mult\<^sub>H\<^sub>O less_multiset\<^sub>H\<^sub>O_def ..
 
 lemma less_multiset\<^sub>D\<^sub>M:
   "M < N \<longleftrightarrow> (\<exists>X Y. X \<noteq> {#} \<and> X \<subseteq># N \<and> M = N - X + Y \<and> (\<forall>k. k \<in># Y \<longrightarrow> (\<exists>a. a \<in># X \<and> k < a)))"
   by (rule mult\<^sub>D\<^sub>M[folded multp_def less_multiset_def])
 
 lemma less_multiset\<^sub>H\<^sub>O:
   "M < N \<longleftrightarrow> M \<noteq> N \<and> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x>y. count M x < count N x))"
   by (rule mult\<^sub>H\<^sub>O[folded multp_def less_multiset_def])
 
 lemma subset_eq_imp_le_multiset:
   shows "M \<subseteq># N \<Longrightarrow> M \<le> N"
   unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O
   by (simp add: less_le_not_le subseteq_mset_def)
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma le_multiset_right_total: "M < add_mset x M"
   unfolding less_eq_multiset_def less_multiset\<^sub>H\<^sub>O by simp
 
 lemma less_eq_multiset_empty_left[simp]:
   shows "{#} \<le> M"
   by (simp add: subset_eq_imp_le_multiset)
 
 lemma ex_gt_imp_less_multiset: "(\<exists>y. y \<in># N \<and> (\<forall>x. x \<in># M \<longrightarrow> x < y)) \<Longrightarrow> M < N"
   unfolding less_multiset\<^sub>H\<^sub>O
   by (metis count_eq_zero_iff count_greater_zero_iff less_le_not_le)
 
 lemma less_eq_multiset_empty_right[simp]: "M \<noteq> {#} \<Longrightarrow> \<not> M \<le> {#}"
   by (metis less_eq_multiset_empty_left antisym)
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma le_multiset_empty_left[simp]: "M \<noteq> {#} \<Longrightarrow> {#} < M"
   by (simp add: less_multiset\<^sub>H\<^sub>O)
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma le_multiset_empty_right[simp]: "\<not> M < {#}"
   using subset_mset.le_zero_eq less_multiset_def multp_def less_multiset\<^sub>D\<^sub>M by blast
 
 (* FIXME: "le" should be "less" in this and other names *)
 lemma union_le_diff_plus: "P \<subseteq># M \<Longrightarrow> N < P \<Longrightarrow> M - P + N < M"
   by (drule subset_mset.diff_add[symmetric]) (metis union_le_mono2)
 
 instantiation multiset :: (preorder) ordered_ab_semigroup_monoid_add_imp_le
 begin
 
 lemma less_eq_multiset\<^sub>H\<^sub>O:
   "M \<le> N \<longleftrightarrow> (\<forall>y. count N y < count M y \<longrightarrow> (\<exists>x. y < x \<and> count M x < count N x))"
   by (auto simp: less_eq_multiset_def less_multiset\<^sub>H\<^sub>O)
 
 instance by standard (auto simp: less_eq_multiset\<^sub>H\<^sub>O)
 
 lemma
   fixes M N :: "'a multiset"
   shows
     less_eq_multiset_plus_left: "N \<le> (M + N)" and
     less_eq_multiset_plus_right: "M \<le> (M + N)"
   by simp_all
 
 lemma
   fixes M N :: "'a multiset"
   shows
     le_multiset_plus_left_nonempty: "M \<noteq> {#} \<Longrightarrow> N < M + N" and
     le_multiset_plus_right_nonempty: "N \<noteq> {#} \<Longrightarrow> M < M + N"
     by simp_all
 
 end
 
 lemma all_lt_Max_imp_lt_mset: "N \<noteq> {#} \<Longrightarrow> (\<forall>a \<in># M. a < Max (set_mset N)) \<Longrightarrow> M < N"
   by (meson Max_in[OF finite_set_mset] ex_gt_imp_less_multiset set_mset_eq_empty_iff)
 
 lemma lt_imp_ex_count_lt: "M < N \<Longrightarrow> \<exists>y. count M y < count N y"
   by (meson less_eq_multiset\<^sub>H\<^sub>O less_le_not_le)
 
 lemma subset_imp_less_mset: "A \<subset># B \<Longrightarrow> A < B"
   by (simp add: order.not_eq_order_implies_strict subset_eq_imp_le_multiset)
 
 lemma image_mset_strict_mono:
   assumes
     mono_f: "\<forall>x \<in> set_mset M. \<forall>y \<in> set_mset N. x < y \<longrightarrow> f x < f y" and
     less: "M < N"
   shows "image_mset f M < image_mset f N"
 proof -
   obtain Y X where
     y_nemp: "Y \<noteq> {#}" and y_sub_N: "Y \<subseteq># N" and M_eq: "M = N - Y + X" and
     ex_y: "\<forall>x. x \<in># X \<longrightarrow> (\<exists>y. y \<in># Y \<and> x < y)"
     using less[unfolded less_multiset\<^sub>D\<^sub>M] by blast
 
   have x_sub_M: "X \<subseteq># M"
     using M_eq by simp
 
   let ?fY = "image_mset f Y"
   let ?fX = "image_mset f X"
 
   show ?thesis
     unfolding less_multiset\<^sub>D\<^sub>M
   proof (intro exI conjI)
     show "image_mset f M = image_mset f N - ?fY + ?fX"
       using M_eq[THEN arg_cong, of "image_mset f"] y_sub_N
       by (metis image_mset_Diff image_mset_union)
   next
     obtain y where y: "\<forall>x. x \<in># X \<longrightarrow> y x \<in># Y \<and> x < y x"
       using ex_y by metis
 
     show "\<forall>fx. fx \<in># ?fX \<longrightarrow> (\<exists>fy. fy \<in># ?fY \<and> fx < fy)"
     proof (intro allI impI)
       fix fx
       assume "fx \<in># ?fX"
       then obtain x where fx: "fx = f x" and x_in: "x \<in># X"
         by auto
       hence y_in: "y x \<in># Y" and y_gt: "x < y x"
         using y[rule_format, OF x_in] by blast+
       hence "f (y x) \<in># ?fY \<and> f x < f (y x)"
         using mono_f y_sub_N x_sub_M x_in
         by (metis image_eqI in_image_mset mset_subset_eqD)
       thus "\<exists>fy. fy \<in># ?fY \<and> fx < fy"
         unfolding fx by auto
     qed
   qed (auto simp: y_nemp y_sub_N image_mset_subseteq_mono)
 qed
 
 lemma image_mset_mono:
   assumes
     mono_f: "\<forall>x \<in> set_mset M. \<forall>y \<in> set_mset N. x < y \<longrightarrow> f x < f y" and
     less: "M \<le> N"
   shows "image_mset f M \<le> image_mset f N"
   by (metis eq_iff image_mset_strict_mono less less_imp_le mono_f order.not_eq_order_implies_strict)
 
 lemma mset_lt_single_right_iff[simp]: "M < {#y#} \<longleftrightarrow> (\<forall>x \<in># M. x < y)" for y :: "'a::linorder"
 proof (rule iffI)
   assume M_lt_y: "M < {#y#}"
   show "\<forall>x \<in># M. x < y"
   proof
     fix x
     assume x_in: "x \<in># M"
     hence M: "M - {#x#} + {#x#} = M"
       by (meson insert_DiffM2)
     hence "\<not> {#x#} < {#y#} \<Longrightarrow> x < y"
       using x_in M_lt_y
       by (metis diff_single_eq_union le_multiset_empty_left less_add_same_cancel2 mset_le_trans)
     also have "\<not> {#y#} < M"
       using M_lt_y mset_le_not_sym by blast
     ultimately show "x < y"
       by (metis (no_types) Max_ge all_lt_Max_imp_lt_mset empty_iff finite_set_mset insertE
         less_le_trans linorder_less_linear mset_le_not_sym set_mset_add_mset_insert
         set_mset_eq_empty_iff x_in)
   qed
 next
   assume y_max: "\<forall>x \<in># M. x < y"
   show "M < {#y#}"
     by (rule all_lt_Max_imp_lt_mset) (auto intro!: y_max)
 qed
 
 lemma mset_le_single_right_iff[simp]:
   "M \<le> {#y#} \<longleftrightarrow> M = {#y#} \<or> (\<forall>x \<in># M. x < y)" for y :: "'a::linorder"
   by (meson less_eq_multiset_def mset_lt_single_right_iff)
 
 
 subsubsection \<open>Simplifications\<close>
 
 lemma multp\<^sub>H\<^sub>O_repeat_mset_repeat_mset[simp]:
   assumes "n \<noteq> 0"
   shows "multp\<^sub>H\<^sub>O R (repeat_mset n A) (repeat_mset n B) \<longleftrightarrow> multp\<^sub>H\<^sub>O R A B"
 proof (rule iffI)
   assume hyp: "multp\<^sub>H\<^sub>O R (repeat_mset n A) (repeat_mset n B)"
   hence
     1: "repeat_mset n A \<noteq> repeat_mset n B" and
     2: "\<forall>y. n * count B y < n * count A y \<longrightarrow> (\<exists>x. R y x \<and> n * count A x < n * count B x)"
     by (simp_all add: multp\<^sub>H\<^sub>O_def)
 
   from 1 \<open>n \<noteq> 0\<close> have "A \<noteq> B"
     by auto
 
   moreover from 2 \<open>n \<noteq> 0\<close> have "\<forall>y. count B y < count A y \<longrightarrow> (\<exists>x. R y x \<and> count A x < count B x)"
     by auto
 
   ultimately show "multp\<^sub>H\<^sub>O R A B"
     by (simp add: multp\<^sub>H\<^sub>O_def)
 next
   assume "multp\<^sub>H\<^sub>O R A B"
   hence 1: "A \<noteq> B" and 2: "\<forall>y. count B y < count A y \<longrightarrow> (\<exists>x. R y x \<and> count A x < count B x)"
     by (simp_all add: multp\<^sub>H\<^sub>O_def)
 
   from 1 have "repeat_mset n A \<noteq> repeat_mset n B"
     by (simp add: assms repeat_mset_cancel1)
 
   moreover from 2 have "\<forall>y. n * count B y < n * count A y \<longrightarrow>
     (\<exists>x. R y x \<and> n * count A x < n * count B x)"
     by auto
 
   ultimately show "multp\<^sub>H\<^sub>O R (repeat_mset n A) (repeat_mset n B)"
     by (simp add: multp\<^sub>H\<^sub>O_def)
 qed
 
 lemma multp\<^sub>H\<^sub>O_double_double[simp]: "multp\<^sub>H\<^sub>O R (A + A) (B + B) \<longleftrightarrow> multp\<^sub>H\<^sub>O R A B"
   using multp\<^sub>H\<^sub>O_repeat_mset_repeat_mset[of 2]
   by (simp add: numeral_Bit0)
 
 
 subsection \<open>Simprocs\<close>
 
 lemma mset_le_add_iff1:
   "j \<le> (i::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (repeat_mset (i-j) u + m \<le> n)"
 proof -
   assume "j \<le> i"
   then have "j + (i - j) = i"
     using le_add_diff_inverse by blast
   then show ?thesis
     by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
 qed
 
 lemma mset_le_add_iff2:
   "i \<le> (j::nat) \<Longrightarrow> (repeat_mset i u + m \<le> repeat_mset j u + n) = (m \<le> repeat_mset (j-i) u + n)"
 proof -
   assume "i \<le> j"
   then have "i + (j - i) = j"
     using le_add_diff_inverse by blast
   then show ?thesis
     by (metis (no_types) add_le_cancel_left left_add_mult_distrib_mset)
 qed
 
 simproc_setup msetless_cancel
   ("(l::'a::preorder multiset) + m < n" | "(l::'a multiset) < m + n" |
    "add_mset a m < n" | "m < add_mset a n" |
    "replicate_mset p a < n" | "m < replicate_mset p a" |
    "repeat_mset p m < n" | "m < repeat_mset p n") =
   \<open>K Cancel_Simprocs.less_cancel\<close>
 
 simproc_setup msetle_cancel
   ("(l::'a::preorder multiset) + m \<le> n" | "(l::'a multiset) \<le> m + n" |
    "add_mset a m \<le> n" | "m \<le> add_mset a n" |
    "replicate_mset p a \<le> n" | "m \<le> replicate_mset p a" |
    "repeat_mset p m \<le> n" | "m \<le> repeat_mset p n") =
   \<open>K Cancel_Simprocs.less_eq_cancel\<close>
 
 
 subsection \<open>Additional facts and instantiations\<close>
 
 lemma ex_gt_count_imp_le_multiset:
   "(\<forall>y :: 'a :: order. y \<in># M + N \<longrightarrow> y \<le> x) \<Longrightarrow> count M x < count N x \<Longrightarrow> M < N"
   unfolding less_multiset\<^sub>H\<^sub>O
   by (metis count_greater_zero_iff le_imp_less_or_eq less_imp_not_less not_gr_zero union_iff)
 
 lemma mset_lt_single_iff[iff]: "{#x#} < {#y#} \<longleftrightarrow> x < y"
   unfolding less_multiset\<^sub>H\<^sub>O by simp
 
 lemma mset_le_single_iff[iff]: "{#x#} \<le> {#y#} \<longleftrightarrow> x \<le> y" for x y :: "'a::order"
   unfolding less_eq_multiset\<^sub>H\<^sub>O by force
 
 instance multiset :: (linorder) linordered_cancel_ab_semigroup_add
   by standard (metis less_eq_multiset\<^sub>H\<^sub>O not_less_iff_gr_or_eq)
 
 lemma less_eq_multiset_total:
   fixes M N :: "'a :: linorder multiset"
   shows "\<not> M \<le> N \<Longrightarrow> N \<le> M"
   by simp
 
 instantiation multiset :: (wellorder) wellorder
 begin
 
 lemma wf_less_multiset: "wf {(M :: 'a multiset, N). M < N}"
   unfolding less_multiset_def multp_def by (auto intro: wf_mult wf)
 
 instance by standard (metis less_multiset_def multp_def wf wf_def wf_mult)
 
 end
 
 instantiation multiset :: (preorder) order_bot
 begin
 
 definition bot_multiset :: "'a multiset" where "bot_multiset = {#}"
 
 instance by standard (simp add: bot_multiset_def)
 
 end
 
 instance multiset :: (preorder) no_top
 proof standard
   fix x :: "'a multiset"
   obtain a :: 'a where True by simp
   have "x < x + (x + {#a#})"
     by simp
   then show "\<exists>y. x < y"
     by blast
 qed
 
 instance multiset :: (preorder) ordered_cancel_comm_monoid_add
   by standard
 
 instantiation multiset :: (linorder) distrib_lattice
 begin
 
 definition inf_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
   "inf_multiset A B = (if A < B then A else B)"
 
 definition sup_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset" where
   "sup_multiset A B = (if B > A then B else A)"
 
 instance
   by intro_classes (auto simp: inf_multiset_def sup_multiset_def)
 
 end
 
+lemma add_mset_lt_left_lt: "a < b \<Longrightarrow> add_mset a A < add_mset b A"
+  by fastforce
+
+lemma add_mset_le_left_le: "a \<le> b \<Longrightarrow> add_mset a A \<le> add_mset b A" for a :: "'a :: linorder"
+  by fastforce
+
+lemma add_mset_lt_right_lt: "A < B \<Longrightarrow> add_mset a A < add_mset a B"
+  by fastforce
+
+lemma add_mset_le_right_le: "A \<le> B \<Longrightarrow> add_mset a A \<le> add_mset a B"
+  by fastforce
+
+lemma add_mset_lt_lt_lt:
+  assumes a_lt_b: "a < b" and A_le_B: "A < B"
+  shows "add_mset a A < add_mset b B"
+  by (rule less_trans[OF add_mset_lt_left_lt[OF a_lt_b] add_mset_lt_right_lt[OF A_le_B]])
+
+lemma add_mset_lt_lt_le: "a < b \<Longrightarrow> A \<le> B \<Longrightarrow> add_mset a A < add_mset b B"
+  using add_mset_lt_lt_lt le_neq_trans by fastforce
+
+lemma add_mset_lt_le_lt: "a \<le> b \<Longrightarrow> A < B \<Longrightarrow> add_mset a A < add_mset b B" for a :: "'a :: linorder"
+  using add_mset_lt_lt_lt by (metis add_mset_lt_right_lt le_less)
+
+lemma add_mset_le_le_le:
+  fixes a :: "'a :: linorder"
+  assumes a_le_b: "a \<le> b" and A_le_B: "A \<le> B"
+  shows "add_mset a A \<le> add_mset b B"
+  by (rule order.trans[OF add_mset_le_left_le[OF a_le_b] add_mset_le_right_le[OF A_le_B]])
+
+lemma Max_lt_imp_lt_mset:
+  assumes n_nemp: "N \<noteq> {#}" and max: "Max_mset M < Max_mset N" (is "?max_M < ?max_N")
+  shows "M < N"
+proof (cases "M = {#}")
+  case m_nemp: False
+
+  have max_n_in_n: "?max_N \<in># N"
+    using n_nemp by simp
+  have max_n_nin_m: "?max_N \<notin># M"
+    using max Max_ge leD by auto
+
+  have "M \<noteq> N"
+    using max by auto
+  moreover
+  {
+    fix y
+    assume "count N y < count M y"
+    hence "y \<in># M"
+      by (simp add: count_inI)
+    hence "?max_M \<ge> y"
+      by simp
+    hence "?max_N > y"
+      using max by auto
+    hence "\<exists>x > y. count M x < count N x"
+      using max_n_nin_m max_n_in_n count_inI by force
+  }
+  ultimately show ?thesis
+    unfolding less_multiset\<^sub>H\<^sub>O by blast
+qed (auto simp: n_nemp)
+
 end