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,2351 +1,2526 @@
 (*  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
 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.simproc\<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)
 
 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_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
 
 
 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'':
+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 =
+locale comp_fun_commute_on =
+  fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
-  assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
+  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: "f y (f x z) = f x (f y z)"
-  using comp_fun_commute by (simp add: fun_eq_iff)
+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: "f y \<circ> (f x \<circ> g) = f x \<circ> (f y \<circ> g)"
-  by (simp add: o_assoc comp_fun_commute)
+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 definiens is
+  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
+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:
-  "fold_graph f z A y \<Longrightarrow> a \<in> A \<Longrightarrow> \<exists>y'. y = f a y' \<and> fold_graph f z (A - {a}) y'"
+  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
-    have "f x y = f a (f x y')"
-      unfolding y by (rule fun_left_comm)
+    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 _ insertI1])
+  using assms by (auto dest: fold_graph_insertE_aux[OF \<open>insert x A \<subseteq> S\<close> _ insertI1])
 
-lemma fold_graph_determ: "fold_graph f z A x \<Longrightarrow> fold_graph f z A y \<Longrightarrow> y = x"
+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>fold_graph f z (insert x A) v\<close> and \<open>x \<notin> A\<close>
+  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> have "y' = y"
-    by (rule insertI)
+  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: "fold_graph f z A y \<Longrightarrow> fold f z A = y"
+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 assms have "\<exists>x. fold_graph f z A x"
+  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
+  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)
+proof (rule fold_equality[OF \<open>insert x A \<subseteq> S\<close>])
   fix z
-  from \<open>finite A\<close> have "fold_graph f z A (fold f z A)"
-    by (rule fold_graph_fold)
+  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: "finite A \<Longrightarrow> f x (fold f z A) = fold f (f x z) A"
+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
-  then show ?case
-    by (simp add: fun_left_comm [of x])
+  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: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> fold f z (insert x A)  = fold f (f x z) A"
+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) (simp add: \<open>finite A\<close>)+
+    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}))"
-    by (rule fold_rec)
+    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 assms(2,1,3) by induct simp_all
+  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 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
-  have "fold_graph f z (g ` A) = fold_graph (f \<circ> g) z A"
-  proof
-    fix w
-    show "fold_graph f z (g ` A) w \<longleftrightarrow> fold_graph (f \<circ> g) z A w" (is "?P \<longleftrightarrow> ?Q")
-    proof
-      assume ?P
-      then show ?Q
-        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 ?Q
-      then show ?P
-        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
-  with True assms show ?thesis
-    by (auto simp add: fold_def)
+  then show ?thesis
+    by (auto simp add: fold_def fold_graph_image[OF assms])
 qed
 
 lemma fold_cong:
-  assumes "comp_fun_commute f" "comp_fun_commute g"
-    and "finite A"
+  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> cong
+    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 f by (fact \<open>comp_fun_commute f\<close>)
-    interpret g: comp_fun_commute g by (fact \<open>comp_fun_commute g\<close>)
+    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 = comp_fun_commute +
-  assumes comp_fun_idem: "f x \<circ> f x = f x"
+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: "f x (f x z) = f x z"
-  using comp_fun_idem by (simp add: fun_eq_iff)
+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 fun_left_idem)
+    using assms by (simp add: comp_fun_idem_on fun_left_idem)
 next
   assume "x \<notin> A"
   then show ?thesis
-    using assms by simp
+    using assms by auto
 qed
 
 declare fold_insert [simp del] fold_insert_idem [simp]
 
-lemma fold_insert_idem2: "finite A \<Longrightarrow> fold f z (insert x A) = fold f (f x z) A"
+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\<close> etc.\<close>
-
-lemma (in comp_fun_commute) comp_comp_fun_commute: "comp_fun_commute (f \<circ> g)"
-  by standard (simp_all add: comp_fun_commute)
+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) comp_comp_fun_idem: "comp_fun_idem (f \<circ> g)"
-  by (rule comp_fun_idem.intro, rule comp_comp_fun_commute, unfold_locales)
-    (simp_all add: comp_fun_idem)
+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) comp_fun_commute_funpow: "comp_fun_commute (\<lambda>x. f x ^^ g x)"
+lemma (in comp_fun_commute_on) comp_fun_commute_on_funpow:
+  "comp_fun_commute_on S (\<lambda>x. f x ^^ g x)"
 proof
-  show "f y ^^ g y \<circ> f x ^^ g x = f x ^^ g x \<circ> f y ^^ g y" for x y
+  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
-        then show ?case
-          by (simp add: comp_assoc hyp) (simp add: o_assoc comp_fun_commute)
+        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
 
 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
-  by induct
-    (auto simp add: Set.filter_def comp_fun_commute.fold_insert[OF comp_fun_commute_filter_fold])
+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  (* somewhat slow *)
+  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"
-  using assms unfolding Sigma_def
-  by (induct A)
-    (simp_all add: comp_fun_commute.fold_insert[OF comp_fun_commute_product_fold] fold_union_pair)
+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
 
 
 subsection \<open>Locales as mini-packages for fold operations\<close>
 
 subsubsection \<open>The natural case\<close>
 
-locale folding =
+locale folding_on =
+  fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
-  assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
+  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 f
-  by standard (use comp_fun_commute in \<open>simp add: fun_eq_iff\<close>)
+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 = fold f z A"
+  where eq_fold: "F A = Finite_Set.fold f z A"
 
-lemma empty [simp]:"F {} = z"
+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 "finite A" and "x \<notin> A"
+  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 "fold f z (insert x A) = f x (fold f z A)" by simp
+  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 "finite A" and "x \<in> A"
+  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 by simp
+  ultimately show ?thesis
+    using \<open>A \<subseteq> S\<close> by auto
 qed
 
-lemma insert_remove: "finite A \<Longrightarrow> F (insert x A) = f x (F (A - {x}))"
-  by (cases "x \<in> A") (simp_all add: remove insert_absorb)
+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 = folding +
-  assumes comp_fun_idem: "f x \<circ> f x = f x"
+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 f
-  by standard (insert comp_fun_commute comp_fun_idem, simp add: fun_eq_iff)
+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 "finite A"
+  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.F (\<lambda>_. Suc) 0"
+  defines card = "folding_on.F (\<lambda>_. Suc) 0"
   by standard rule
 
 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: "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> card (A - {x}) = card A - 1"
   by (simp add: card_Suc_Diff1 [symmetric])
 
 lemma card_Diff_singleton_if:
   "finite A \<Longrightarrow> 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 "finite A" and "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: "finite A \<Longrightarrow> card A \<le> card (insert x A)"
   by (simp add: card_insert_if)
 
 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 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: "finite A \<Longrightarrow> card (A - {x}) \<le> card A"
   by (cases "x \<in> A") (simp_all add: card_Diff1_less less_imp_le)
 
 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
     with "2.prems"(2) "2.hyps"(2) show ?case
       unfolding inj_on_def
       by (rule_tac x = "\<lambda>z. if z = x then y else f z" in exI) auto
   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  (* somewhat slow *)
 
 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
 
 
 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: "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])
 
 
 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
 
 subsubsection \<open>Finite orders\<close>
 
 context order
 begin
 
 lemma finite_has_maximal:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. \<forall> b \<in> A. m \<le> b \<longrightarrow> m = b"
 proof (induction rule: finite_psubset_induct)
   case (psubset A)
   from \<open>A \<noteq> {}\<close> obtain a where "a \<in> A" by auto
   let ?B = "{b \<in> A. a < b}"
   show ?case
   proof cases
     assume "?B = {}"
     hence "\<forall> b \<in> A. a \<le> b \<longrightarrow> a = b" using le_neq_trans by blast
     thus ?thesis using \<open>a \<in> A\<close> by blast
   next
     assume "?B \<noteq> {}"
     have "a \<notin> ?B" by auto
     hence "?B \<subset> A" using \<open>a \<in> A\<close> by blast
     from psubset.IH[OF this \<open>?B \<noteq> {}\<close>] show ?thesis using order.strict_trans2 by blast
   qed
 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:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists> m \<in> A. \<forall> b \<in> A. b \<le> m \<longrightarrow> m = b"
 proof (induction rule: finite_psubset_induct)
   case (psubset A)
   from \<open>A \<noteq> {}\<close> obtain a where "a \<in> A" by auto
   let ?B = "{b \<in> A. b < a}"
   show ?case
   proof cases
     assume "?B = {}"
     hence "\<forall> b \<in> A. b \<le> a \<longrightarrow> a = b" using le_neq_trans by blast
     thus ?thesis using \<open>a \<in> A\<close> by blast
   next
     assume "?B \<noteq> {}"
     have "a \<notin> ?B" by auto
     hence "?B \<subset> A" using \<open>a \<in> A\<close> by blast
     from psubset.IH[OF this \<open>?B \<noteq> {}\<close>] show ?thesis using order.strict_trans1 by blast
   qed
 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 (case_tac "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/AList.thy b/src/HOL/Library/AList.thy
--- a/src/HOL/Library/AList.thy
+++ b/src/HOL/Library/AList.thy
@@ -1,777 +1,780 @@
 (*  Title:      HOL/Library/AList.thy
     Author:     Norbert Schirmer, Tobias Nipkow, Martin Wildmoser, TU Muenchen
 *)
 
 section \<open>Implementation of Association Lists\<close>
 
 theory AList
   imports Main
 begin
 
 context
 begin
 
 text \<open>
   The operations preserve distinctness of keys and
   function \<^term>\<open>clearjunk\<close> distributes over them. Since
   \<^term>\<open>clearjunk\<close> enforces distinctness of keys it can be used
   to establish the invariant, e.g. for inductive proofs.
 \<close>
 
 subsection \<open>\<open>update\<close> and \<open>updates\<close>\<close>
 
 qualified primrec update :: "'key \<Rightarrow> 'val \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where
     "update k v [] = [(k, v)]"
   | "update k v (p # ps) = (if fst p = k then (k, v) # ps else p # update k v ps)"
 
 lemma update_conv': "map_of (update k v al)  = (map_of al)(k\<mapsto>v)"
   by (induct al) (auto simp add: fun_eq_iff)
 
 corollary update_conv: "map_of (update k v al) k' = ((map_of al)(k\<mapsto>v)) k'"
   by (simp add: update_conv')
 
 lemma dom_update: "fst ` set (update k v al) = {k} \<union> fst ` set al"
   by (induct al) auto
 
 lemma update_keys:
   "map fst (update k v al) =
     (if k \<in> set (map fst al) then map fst al else map fst al @ [k])"
   by (induct al) simp_all
 
 lemma distinct_update:
   assumes "distinct (map fst al)"
   shows "distinct (map fst (update k v al))"
   using assms by (simp add: update_keys)
 
 lemma update_filter:
   "a \<noteq> k \<Longrightarrow> update k v [q\<leftarrow>ps. fst q \<noteq> a] = [q\<leftarrow>update k v ps. fst q \<noteq> a]"
   by (induct ps) auto
 
 lemma update_triv: "map_of al k = Some v \<Longrightarrow> update k v al = al"
   by (induct al) auto
 
 lemma update_nonempty [simp]: "update k v al \<noteq> []"
   by (induct al) auto
 
 lemma update_eqD: "update k v al = update k v' al' \<Longrightarrow> v = v'"
 proof (induct al arbitrary: al')
   case Nil
   then show ?case
     by (cases al') (auto split: if_split_asm)
 next
   case Cons
   then show ?case
     by (cases al') (auto split: if_split_asm)
 qed
 
 lemma update_last [simp]: "update k v (update k v' al) = update k v al"
   by (induct al) auto
 
 text \<open>Note that the lists are not necessarily the same:
         \<^term>\<open>update k v (update k' v' []) = [(k', v'), (k, v)]\<close> and
         \<^term>\<open>update k' v' (update k v []) = [(k, v), (k', v')]\<close>.\<close>
 
 lemma update_swap:
   "k \<noteq> k' \<Longrightarrow> map_of (update k v (update k' v' al)) = map_of (update k' v' (update k v al))"
   by (simp add: update_conv' fun_eq_iff)
 
 lemma update_Some_unfold:
   "map_of (update k v al) x = Some y \<longleftrightarrow>
     x = k \<and> v = y \<or> x \<noteq> k \<and> map_of al x = Some y"
   by (simp add: update_conv' map_upd_Some_unfold)
 
 lemma image_update [simp]: "x \<notin> A \<Longrightarrow> map_of (update x y al) ` A = map_of al ` A"
   by (auto simp add: update_conv')
 
 qualified definition updates ::
     "'key list \<Rightarrow> 'val list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where "updates ks vs = fold (case_prod update) (zip ks vs)"
 
 lemma updates_simps [simp]:
   "updates [] vs ps = ps"
   "updates ks [] ps = ps"
   "updates (k#ks) (v#vs) ps = updates ks vs (update k v ps)"
   by (simp_all add: updates_def)
 
 lemma updates_key_simp [simp]:
   "updates (k # ks) vs ps =
     (case vs of [] \<Rightarrow> ps | v # vs \<Rightarrow> updates ks vs (update k v ps))"
   by (cases vs) simp_all
 
 lemma updates_conv': "map_of (updates ks vs al) = (map_of al)(ks[\<mapsto>]vs)"
 proof -
   have "map_of \<circ> fold (case_prod update) (zip ks vs) =
       fold (\<lambda>(k, v) f. f(k \<mapsto> v)) (zip ks vs) \<circ> map_of"
     by (rule fold_commute) (auto simp add: fun_eq_iff update_conv')
   then show ?thesis
     by (auto simp add: updates_def fun_eq_iff map_upds_fold_map_upd foldl_conv_fold split_def)
 qed
 
 lemma updates_conv: "map_of (updates ks vs al) k = ((map_of al)(ks[\<mapsto>]vs)) k"
   by (simp add: updates_conv')
 
 lemma distinct_updates:
   assumes "distinct (map fst al)"
   shows "distinct (map fst (updates ks vs al))"
 proof -
   have "distinct (fold
        (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k])
        (zip ks vs) (map fst al))"
     by (rule fold_invariant [of "zip ks vs" "\<lambda>_. True"]) (auto intro: assms)
   moreover have "map fst \<circ> fold (case_prod update) (zip ks vs) =
       fold (\<lambda>(k, v) al. if k \<in> set al then al else al @ [k]) (zip ks vs) \<circ> map fst"
     by (rule fold_commute) (simp add: update_keys split_def case_prod_beta comp_def)
   ultimately show ?thesis
     by (simp add: updates_def fun_eq_iff)
 qed
 
 lemma updates_append1[simp]: "size ks < size vs \<Longrightarrow>
     updates (ks@[k]) vs al = update k (vs!size ks) (updates ks vs al)"
   by (induct ks arbitrary: vs al) (auto split: list.splits)
 
 lemma updates_list_update_drop[simp]:
   "size ks \<le> i \<Longrightarrow> i < size vs \<Longrightarrow>
     updates ks (vs[i:=v]) al = updates ks vs al"
   by (induct ks arbitrary: al vs i) (auto split: list.splits nat.splits)
 
 lemma update_updates_conv_if:
   "map_of (updates xs ys (update x y al)) =
     map_of
      (if x \<in> set (take (length ys) xs)
       then updates xs ys al
       else (update x y (updates xs ys al)))"
   by (simp add: updates_conv' update_conv' map_upd_upds_conv_if)
 
 lemma updates_twist [simp]:
   "k \<notin> set ks \<Longrightarrow>
     map_of (updates ks vs (update k v al)) = map_of (update k v (updates ks vs al))"
   by (simp add: updates_conv' update_conv')
 
 lemma updates_apply_notin [simp]:
   "k \<notin> set ks \<Longrightarrow> map_of (updates ks vs al) k = map_of al k"
   by (simp add: updates_conv)
 
 lemma updates_append_drop [simp]:
   "size xs = size ys \<Longrightarrow> updates (xs @ zs) ys al = updates xs ys al"
   by (induct xs arbitrary: ys al) (auto split: list.splits)
 
 lemma updates_append2_drop [simp]:
   "size xs = size ys \<Longrightarrow> updates xs (ys @ zs) al = updates xs ys al"
   by (induct xs arbitrary: ys al) (auto split: list.splits)
 
 
 subsection \<open>\<open>delete\<close>\<close>
 
 qualified definition delete :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where delete_eq: "delete k = filter (\<lambda>(k', _). k \<noteq> k')"
 
 lemma delete_simps [simp]:
   "delete k [] = []"
   "delete k (p # ps) = (if fst p = k then delete k ps else p # delete k ps)"
   by (auto simp add: delete_eq)
 
 lemma delete_conv': "map_of (delete k al) = (map_of al)(k := None)"
   by (induct al) (auto simp add: fun_eq_iff)
 
 corollary delete_conv: "map_of (delete k al) k' = ((map_of al)(k := None)) k'"
   by (simp add: delete_conv')
 
 lemma delete_keys: "map fst (delete k al) = removeAll k (map fst al)"
   by (simp add: delete_eq removeAll_filter_not_eq filter_map split_def comp_def)
 
 lemma distinct_delete:
   assumes "distinct (map fst al)"
   shows "distinct (map fst (delete k al))"
   using assms by (simp add: delete_keys distinct_removeAll)
 
 lemma delete_id [simp]: "k \<notin> fst ` set al \<Longrightarrow> delete k al = al"
   by (auto simp add: image_iff delete_eq filter_id_conv)
 
 lemma delete_idem: "delete k (delete k al) = delete k al"
   by (simp add: delete_eq)
 
 lemma map_of_delete [simp]: "k' \<noteq> k \<Longrightarrow> map_of (delete k al) k' = map_of al k'"
   by (simp add: delete_conv')
 
 lemma delete_notin_dom: "k \<notin> fst ` set (delete k al)"
   by (auto simp add: delete_eq)
 
 lemma dom_delete_subset: "fst ` set (delete k al) \<subseteq> fst ` set al"
   by (auto simp add: delete_eq)
 
 lemma delete_update_same: "delete k (update k v al) = delete k al"
   by (induct al) simp_all
 
 lemma delete_update: "k \<noteq> l \<Longrightarrow> delete l (update k v al) = update k v (delete l al)"
   by (induct al) simp_all
 
 lemma delete_twist: "delete x (delete y al) = delete y (delete x al)"
   by (simp add: delete_eq conj_commute)
 
 lemma length_delete_le: "length (delete k al) \<le> length al"
   by (simp add: delete_eq)
 
 
 subsection \<open>\<open>update_with_aux\<close> and \<open>delete_aux\<close>\<close>
 
 qualified primrec update_with_aux ::
     "'val \<Rightarrow> 'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where
     "update_with_aux v k f [] = [(k, f v)]"
   | "update_with_aux v k f (p # ps) =
       (if (fst p = k) then (k, f (snd p)) # ps else p # update_with_aux v k f ps)"
 
 text \<open>
   The above \<^term>\<open>delete\<close> traverses all the list even if it has found the key.
   This one does not have to keep going because is assumes the invariant that keys are distinct.
 \<close>
 qualified fun delete_aux :: "'key \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where
     "delete_aux k [] = []"
   | "delete_aux k ((k', v) # xs) = (if k = k' then xs else (k', v) # delete_aux k xs)"
 
 lemma map_of_update_with_aux':
   "map_of (update_with_aux v k f ps) k' =
     ((map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))) k'"
   by (induct ps) auto
 
 lemma map_of_update_with_aux:
   "map_of (update_with_aux v k f ps) =
     (map_of ps)(k \<mapsto> (case map_of ps k of None \<Rightarrow> f v | Some v \<Rightarrow> f v))"
   by (simp add: fun_eq_iff map_of_update_with_aux')
 
 lemma dom_update_with_aux: "fst ` set (update_with_aux v k f ps) = {k} \<union> fst ` set ps"
   by (induct ps) auto
 
 lemma distinct_update_with_aux [simp]:
   "distinct (map fst (update_with_aux v k f ps)) = distinct (map fst ps)"
   by (induct ps) (auto simp add: dom_update_with_aux)
 
 lemma set_update_with_aux:
   "distinct (map fst xs) \<Longrightarrow>
     set (update_with_aux v k f xs) =
       (set xs - {k} \<times> UNIV \<union> {(k, f (case map_of xs k of None \<Rightarrow> v | Some v \<Rightarrow> v))})"
   by (induct xs) (auto intro: rev_image_eqI)
 
 lemma set_delete_aux: "distinct (map fst xs) \<Longrightarrow> set (delete_aux k xs) = set xs - {k} \<times> UNIV"
   apply (induct xs)
    apply simp_all
   apply clarsimp
   apply (fastforce intro: rev_image_eqI)
   done
 
 lemma dom_delete_aux: "distinct (map fst ps) \<Longrightarrow> fst ` set (delete_aux k ps) = fst ` set ps - {k}"
   by (auto simp add: set_delete_aux)
 
 lemma distinct_delete_aux [simp]: "distinct (map fst ps) \<Longrightarrow> distinct (map fst (delete_aux k ps))"
 proof (induct ps)
   case Nil
   then show ?case by simp
 next
   case (Cons a ps)
   obtain k' v where a: "a = (k', v)"
     by (cases a)
   show ?case
   proof (cases "k' = k")
     case True
     with Cons a show ?thesis by simp
   next
     case False
     with Cons a have "k' \<notin> fst ` set ps" "distinct (map fst ps)"
       by simp_all
     with False a have "k' \<notin> fst ` set (delete_aux k ps)"
       by (auto dest!: dom_delete_aux[where k=k])
     with Cons a show ?thesis
       by simp
   qed
 qed
 
 lemma map_of_delete_aux':
   "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) = (map_of xs)(k := None)"
   apply (induct xs)
    apply (fastforce simp add: map_of_eq_None_iff fun_upd_twist)
   apply (auto intro!: ext)
   apply (simp add: map_of_eq_None_iff)
   done
 
 lemma map_of_delete_aux:
   "distinct (map fst xs) \<Longrightarrow> map_of (delete_aux k xs) k' = ((map_of xs)(k := None)) k'"
   by (simp add: map_of_delete_aux')
 
 lemma delete_aux_eq_Nil_conv: "delete_aux k ts = [] \<longleftrightarrow> ts = [] \<or> (\<exists>v. ts = [(k, v)])"
   by (cases ts) (auto split: if_split_asm)
 
 
 subsection \<open>\<open>restrict\<close>\<close>
 
 qualified definition restrict :: "'key set \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where restrict_eq: "restrict A = filter (\<lambda>(k, v). k \<in> A)"
 
 lemma restr_simps [simp]:
   "restrict A [] = []"
   "restrict A (p#ps) = (if fst p \<in> A then p # restrict A ps else restrict A ps)"
   by (auto simp add: restrict_eq)
 
 lemma restr_conv': "map_of (restrict A al) = ((map_of al)|` A)"
 proof
   show "map_of (restrict A al) k = ((map_of al)|` A) k" for k
     apply (induct al)
      apply simp
     apply (cases "k \<in> A")
      apply auto
     done
 qed
 
 corollary restr_conv: "map_of (restrict A al) k = ((map_of al)|` A) k"
   by (simp add: restr_conv')
 
 lemma distinct_restr: "distinct (map fst al) \<Longrightarrow> distinct (map fst (restrict A al))"
   by (induct al) (auto simp add: restrict_eq)
 
 lemma restr_empty [simp]:
   "restrict {} al = []"
   "restrict A [] = []"
   by (induct al) (auto simp add: restrict_eq)
 
 lemma restr_in [simp]: "x \<in> A \<Longrightarrow> map_of (restrict A al) x = map_of al x"
   by (simp add: restr_conv')
 
 lemma restr_out [simp]: "x \<notin> A \<Longrightarrow> map_of (restrict A al) x = None"
   by (simp add: restr_conv')
 
 lemma dom_restr [simp]: "fst ` set (restrict A al) = fst ` set al \<inter> A"
   by (induct al) (auto simp add: restrict_eq)
 
 lemma restr_upd_same [simp]: "restrict (-{x}) (update x y al) = restrict (-{x}) al"
   by (induct al) (auto simp add: restrict_eq)
 
 lemma restr_restr [simp]: "restrict A (restrict B al) = restrict (A\<inter>B) al"
   by (induct al) (auto simp add: restrict_eq)
 
 lemma restr_update[simp]:
   "map_of (restrict D (update x y al)) =
     map_of ((if x \<in> D then (update x y (restrict (D-{x}) al)) else restrict D al))"
   by (simp add: restr_conv' update_conv')
 
 lemma restr_delete [simp]:
   "delete x (restrict D al) = (if x \<in> D then restrict (D - {x}) al else restrict D al)"
   apply (simp add: delete_eq restrict_eq)
   apply (auto simp add: split_def)
 proof -
   have "y \<noteq> x \<longleftrightarrow> x \<noteq> y" for y
     by auto
   then show "[p \<leftarrow> al. fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al. fst p \<in> D \<and> fst p \<noteq> x]"
     by simp
   assume "x \<notin> D"
   then have "y \<in> D \<longleftrightarrow> y \<in> D \<and> x \<noteq> y" for y
     by auto
   then show "[p \<leftarrow> al . fst p \<in> D \<and> x \<noteq> fst p] = [p \<leftarrow> al . fst p \<in> D]"
     by simp
 qed
 
 lemma update_restr:
   "map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
   by (simp add: update_conv' restr_conv') (rule fun_upd_restrict)
 
 lemma update_restr_conv [simp]:
   "x \<in> D \<Longrightarrow>
     map_of (update x y (restrict D al)) = map_of (update x y (restrict (D - {x}) al))"
   by (simp add: update_conv' restr_conv')
 
 lemma restr_updates [simp]:
   "length xs = length ys \<Longrightarrow> set xs \<subseteq> D \<Longrightarrow>
     map_of (restrict D (updates xs ys al)) =
       map_of (updates xs ys (restrict (D - set xs) al))"
   by (simp add: updates_conv' restr_conv')
 
 lemma restr_delete_twist: "(restrict A (delete a ps)) = delete a (restrict A ps)"
   by (induct ps) auto
 
 
 subsection \<open>\<open>clearjunk\<close>\<close>
 
 qualified function clearjunk  :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where
     "clearjunk [] = []"
   | "clearjunk (p#ps) = p # clearjunk (delete (fst p) ps)"
   by pat_completeness auto
 termination
   by (relation "measure length") (simp_all add: less_Suc_eq_le length_delete_le)
 
 lemma map_of_clearjunk: "map_of (clearjunk al) = map_of al"
   by (induct al rule: clearjunk.induct) (simp_all add: fun_eq_iff)
 
 lemma clearjunk_keys_set: "set (map fst (clearjunk al)) = set (map fst al)"
   by (induct al rule: clearjunk.induct) (simp_all add: delete_keys)
 
 lemma dom_clearjunk: "fst ` set (clearjunk al) = fst ` set al"
   using clearjunk_keys_set by simp
 
 lemma distinct_clearjunk [simp]: "distinct (map fst (clearjunk al))"
   by (induct al rule: clearjunk.induct) (simp_all del: set_map add: clearjunk_keys_set delete_keys)
 
 lemma ran_clearjunk: "ran (map_of (clearjunk al)) = ran (map_of al)"
   by (simp add: map_of_clearjunk)
 
 lemma ran_map_of: "ran (map_of al) = snd ` set (clearjunk al)"
 proof -
   have "ran (map_of al) = ran (map_of (clearjunk al))"
     by (simp add: ran_clearjunk)
   also have "\<dots> = snd ` set (clearjunk al)"
     by (simp add: ran_distinct)
   finally show ?thesis .
 qed
 
+lemma graph_map_of: "Map.graph (map_of al) = set (clearjunk al)"
+  by (metis distinct_clearjunk graph_map_of_if_distinct_ran map_of_clearjunk)
+
 lemma clearjunk_update: "clearjunk (update k v al) = update k v (clearjunk al)"
   by (induct al rule: clearjunk.induct) (simp_all add: delete_update)
 
 lemma clearjunk_updates: "clearjunk (updates ks vs al) = updates ks vs (clearjunk al)"
 proof -
   have "clearjunk \<circ> fold (case_prod update) (zip ks vs) =
       fold (case_prod update) (zip ks vs) \<circ> clearjunk"
     by (rule fold_commute) (simp add: clearjunk_update case_prod_beta o_def)
   then show ?thesis
     by (simp add: updates_def fun_eq_iff)
 qed
 
 lemma clearjunk_delete: "clearjunk (delete x al) = delete x (clearjunk al)"
   by (induct al rule: clearjunk.induct) (auto simp add: delete_idem delete_twist)
 
 lemma clearjunk_restrict: "clearjunk (restrict A al) = restrict A (clearjunk al)"
   by (induct al rule: clearjunk.induct) (auto simp add: restr_delete_twist)
 
 lemma distinct_clearjunk_id [simp]: "distinct (map fst al) \<Longrightarrow> clearjunk al = al"
   by (induct al rule: clearjunk.induct) auto
 
 lemma clearjunk_idem: "clearjunk (clearjunk al) = clearjunk al"
   by simp
 
 lemma length_clearjunk: "length (clearjunk al) \<le> length al"
 proof (induct al rule: clearjunk.induct [case_names Nil Cons])
   case Nil
   then show ?case by simp
 next
   case (Cons kv al)
   moreover have "length (delete (fst kv) al) \<le> length al"
     by (fact length_delete_le)
   ultimately have "length (clearjunk (delete (fst kv) al)) \<le> length al"
     by (rule order_trans)
   then show ?case
     by simp
 qed
 
 lemma delete_map:
   assumes "\<And>kv. fst (f kv) = fst kv"
   shows "delete k (map f ps) = map f (delete k ps)"
   by (simp add: delete_eq filter_map comp_def split_def assms)
 
 lemma clearjunk_map:
   assumes "\<And>kv. fst (f kv) = fst kv"
   shows "clearjunk (map f ps) = map f (clearjunk ps)"
   by (induct ps rule: clearjunk.induct [case_names Nil Cons])
     (simp_all add: clearjunk_delete delete_map assms)
 
 
 subsection \<open>\<open>map_ran\<close>\<close>
 
 definition map_ran :: "('key \<Rightarrow> 'val1 \<Rightarrow> 'val2) \<Rightarrow> ('key \<times> 'val1) list \<Rightarrow> ('key \<times> 'val2) list"
   where "map_ran f = map (\<lambda>(k, v). (k, f k v))"
 
 lemma map_ran_simps [simp]:
   "map_ran f [] = []"
   "map_ran f ((k, v) # ps) = (k, f k v) # map_ran f ps"
   by (simp_all add: map_ran_def)
 
 lemma map_ran_Cons_sel: "map_ran f (p # ps) = (fst p, f (fst p) (snd p)) # map_ran f ps"
   by (simp add: map_ran_def case_prod_beta)
 
 lemma length_map_ran[simp]: "length (map_ran f al) = length al"
   by (simp add: map_ran_def)
 
 lemma map_fst_map_ran[simp]: "map fst (map_ran f al) = map fst al"
   by (simp add: map_ran_def case_prod_beta)
 
 lemma dom_map_ran: "fst ` set (map_ran f al) = fst ` set al"
   by (simp add: map_ran_def image_image split_def)
 
 lemma map_ran_conv: "map_of (map_ran f al) k = map_option (f k) (map_of al k)"
   by (induct al) auto
 
 lemma distinct_map_ran: "distinct (map fst al) \<Longrightarrow> distinct (map fst (map_ran f al))"
   by simp
 
 lemma map_ran_filter: "map_ran f [p\<leftarrow>ps. fst p \<noteq> a] = [p\<leftarrow>map_ran f ps. fst p \<noteq> a]"
   by (simp add: map_ran_def filter_map split_def comp_def)
 
 lemma clearjunk_map_ran: "clearjunk (map_ran f al) = map_ran f (clearjunk al)"
   by (simp add: map_ran_def split_def clearjunk_map)
 
 
 subsection \<open>\<open>merge\<close>\<close>
 
 qualified definition merge :: "('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where "merge qs ps = foldr (\<lambda>(k, v). update k v) ps qs"
 
 lemma merge_simps [simp]:
   "merge qs [] = qs"
   "merge qs (p#ps) = update (fst p) (snd p) (merge qs ps)"
   by (simp_all add: merge_def split_def)
 
 lemma merge_updates: "merge qs ps = updates (rev (map fst ps)) (rev (map snd ps)) qs"
   by (simp add: merge_def updates_def foldr_conv_fold zip_rev zip_map_fst_snd)
 
 lemma dom_merge: "fst ` set (merge xs ys) = fst ` set xs \<union> fst ` set ys"
   by (induct ys arbitrary: xs) (auto simp add: dom_update)
 
 lemma distinct_merge: "distinct (map fst xs) \<Longrightarrow> distinct (map fst (merge xs ys))"
   by (simp add: merge_updates distinct_updates)
 
 lemma clearjunk_merge: "clearjunk (merge xs ys) = merge (clearjunk xs) ys"
   by (simp add: merge_updates clearjunk_updates)
 
 lemma merge_conv': "map_of (merge xs ys) = map_of xs ++ map_of ys"
 proof -
   have "map_of \<circ> fold (case_prod update) (rev ys) =
       fold (\<lambda>(k, v) m. m(k \<mapsto> v)) (rev ys) \<circ> map_of"
     by (rule fold_commute) (simp add: update_conv' case_prod_beta split_def fun_eq_iff)
   then show ?thesis
     by (simp add: merge_def map_add_map_of_foldr foldr_conv_fold fun_eq_iff)
 qed
 
 corollary merge_conv: "map_of (merge xs ys) k = (map_of xs ++ map_of ys) k"
   by (simp add: merge_conv')
 
 lemma merge_empty: "map_of (merge [] ys) = map_of ys"
   by (simp add: merge_conv')
 
 lemma merge_assoc [simp]: "map_of (merge m1 (merge m2 m3)) = map_of (merge (merge m1 m2) m3)"
   by (simp add: merge_conv')
 
 lemma merge_Some_iff:
   "map_of (merge m n) k = Some x \<longleftrightarrow>
     map_of n k = Some x \<or> map_of n k = None \<and> map_of m k = Some x"
   by (simp add: merge_conv' map_add_Some_iff)
 
 lemmas merge_SomeD [dest!] = merge_Some_iff [THEN iffD1]
 
 lemma merge_find_right [simp]: "map_of n k = Some v \<Longrightarrow> map_of (merge m n) k = Some v"
   by (simp add: merge_conv')
 
 lemma merge_None [iff]: "(map_of (merge m n) k = None) = (map_of n k = None \<and> map_of m k = None)"
   by (simp add: merge_conv')
 
 lemma merge_upd [simp]: "map_of (merge m (update k v n)) = map_of (update k v (merge m n))"
   by (simp add: update_conv' merge_conv')
 
 lemma merge_updatess [simp]:
   "map_of (merge m (updates xs ys n)) = map_of (updates xs ys (merge m n))"
   by (simp add: updates_conv' merge_conv')
 
 lemma merge_append: "map_of (xs @ ys) = map_of (merge ys xs)"
   by (simp add: merge_conv')
 
 
 subsection \<open>\<open>compose\<close>\<close>
 
 qualified function compose :: "('key \<times> 'a) list \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> ('key \<times> 'b) list"
   where
     "compose [] ys = []"
   | "compose (x # xs) ys =
       (case map_of ys (snd x) of
         None \<Rightarrow> compose (delete (fst x) xs) ys
       | Some v \<Rightarrow> (fst x, v) # compose xs ys)"
   by pat_completeness auto
 termination
   by (relation "measure (length \<circ> fst)") (simp_all add: less_Suc_eq_le length_delete_le)
 
 lemma compose_first_None [simp]: "map_of xs k = None \<Longrightarrow> map_of (compose xs ys) k = None"
   by (induct xs ys rule: compose.induct) (auto split: option.splits if_split_asm)
 
 lemma compose_conv: "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
 proof (induct xs ys rule: compose.induct)
   case 1
   then show ?case by simp
 next
   case (2 x xs ys)
   show ?case
   proof (cases "map_of ys (snd x)")
     case None
     with 2 have hyp: "map_of (compose (delete (fst x) xs) ys) k =
         (map_of ys \<circ>\<^sub>m map_of (delete (fst x) xs)) k"
       by simp
     show ?thesis
     proof (cases "fst x = k")
       case True
       from True delete_notin_dom [of k xs]
       have "map_of (delete (fst x) xs) k = None"
         by (simp add: map_of_eq_None_iff)
       with hyp show ?thesis
         using True None
         by simp
     next
       case False
       from False have "map_of (delete (fst x) xs) k = map_of xs k"
         by simp
       with hyp show ?thesis
         using False None by (simp add: map_comp_def)
     qed
   next
     case (Some v)
     with 2
     have "map_of (compose xs ys) k = (map_of ys \<circ>\<^sub>m map_of xs) k"
       by simp
     with Some show ?thesis
       by (auto simp add: map_comp_def)
   qed
 qed
 
 lemma compose_conv': "map_of (compose xs ys) = (map_of ys \<circ>\<^sub>m map_of xs)"
   by (rule ext) (rule compose_conv)
 
 lemma compose_first_Some [simp]: "map_of xs k = Some v \<Longrightarrow> map_of (compose xs ys) k = map_of ys v"
   by (simp add: compose_conv)
 
 lemma dom_compose: "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
 proof (induct xs ys rule: compose.induct)
   case 1
   then show ?case by simp
 next
   case (2 x xs ys)
   show ?case
   proof (cases "map_of ys (snd x)")
     case None
     with "2.hyps" have "fst ` set (compose (delete (fst x) xs) ys) \<subseteq> fst ` set (delete (fst x) xs)"
       by simp
     also have "\<dots> \<subseteq> fst ` set xs"
       by (rule dom_delete_subset)
     finally show ?thesis
       using None by auto
   next
     case (Some v)
     with "2.hyps" have "fst ` set (compose xs ys) \<subseteq> fst ` set xs"
       by simp
     with Some show ?thesis
       by auto
   qed
 qed
 
 lemma distinct_compose:
   assumes "distinct (map fst xs)"
   shows "distinct (map fst (compose xs ys))"
   using assms
 proof (induct xs ys rule: compose.induct)
   case 1
   then show ?case by simp
 next
   case (2 x xs ys)
   show ?case
   proof (cases "map_of ys (snd x)")
     case None
     with 2 show ?thesis by simp
   next
     case (Some v)
     with 2 dom_compose [of xs ys] show ?thesis
       by auto
   qed
 qed
 
 lemma compose_delete_twist: "compose (delete k xs) ys = delete k (compose xs ys)"
 proof (induct xs ys rule: compose.induct)
   case 1
   then show ?case by simp
 next
   case (2 x xs ys)
   show ?case
   proof (cases "map_of ys (snd x)")
     case None
     with 2 have hyp: "compose (delete k (delete (fst x) xs)) ys =
         delete k (compose (delete (fst x) xs) ys)"
       by simp
     show ?thesis
     proof (cases "fst x = k")
       case True
       with None hyp show ?thesis
         by (simp add: delete_idem)
     next
       case False
       from None False hyp show ?thesis
         by (simp add: delete_twist)
     qed
   next
     case (Some v)
     with 2 have hyp: "compose (delete k xs) ys = delete k (compose xs ys)"
       by simp
     with Some show ?thesis
       by simp
   qed
 qed
 
 lemma compose_clearjunk: "compose xs (clearjunk ys) = compose xs ys"
   by (induct xs ys rule: compose.induct)
     (auto simp add: map_of_clearjunk split: option.splits)
 
 lemma clearjunk_compose: "clearjunk (compose xs ys) = compose (clearjunk xs) ys"
   by (induct xs rule: clearjunk.induct)
     (auto split: option.splits simp add: clearjunk_delete delete_idem compose_delete_twist)
 
 lemma compose_empty [simp]: "compose xs [] = []"
   by (induct xs) (auto simp add: compose_delete_twist)
 
 lemma compose_Some_iff:
   "(map_of (compose xs ys) k = Some v) \<longleftrightarrow>
     (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = Some v)"
   by (simp add: compose_conv map_comp_Some_iff)
 
 lemma map_comp_None_iff:
   "map_of (compose xs ys) k = None \<longleftrightarrow>
     (map_of xs k = None \<or> (\<exists>k'. map_of xs k = Some k' \<and> map_of ys k' = None))"
   by (simp add: compose_conv map_comp_None_iff)
 
 
 subsection \<open>\<open>map_entry\<close>\<close>
 
 qualified fun map_entry :: "'key \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where
     "map_entry k f [] = []"
   | "map_entry k f (p # ps) =
       (if fst p = k then (k, f (snd p)) # ps else p # map_entry k f ps)"
 
 lemma map_of_map_entry:
   "map_of (map_entry k f xs) =
     (map_of xs)(k := case map_of xs k of None \<Rightarrow> None | Some v' \<Rightarrow> Some (f v'))"
   by (induct xs) auto
 
 lemma dom_map_entry: "fst ` set (map_entry k f xs) = fst ` set xs"
   by (induct xs) auto
 
 lemma distinct_map_entry:
   assumes "distinct (map fst xs)"
   shows "distinct (map fst (map_entry k f xs))"
   using assms by (induct xs) (auto simp add: dom_map_entry)
 
 
 subsection \<open>\<open>map_default\<close>\<close>
 
 fun map_default :: "'key \<Rightarrow> 'val \<Rightarrow> ('val \<Rightarrow> 'val) \<Rightarrow> ('key \<times> 'val) list \<Rightarrow> ('key \<times> 'val) list"
   where
     "map_default k v f [] = [(k, v)]"
   | "map_default k v f (p # ps) =
       (if fst p = k then (k, f (snd p)) # ps else p # map_default k v f ps)"
 
 lemma map_of_map_default:
   "map_of (map_default k v f xs) =
     (map_of xs)(k := case map_of xs k of None \<Rightarrow> Some v | Some v' \<Rightarrow> Some (f v'))"
   by (induct xs) auto
 
 lemma dom_map_default: "fst ` set (map_default k v f xs) = insert k (fst ` set xs)"
   by (induct xs) auto
 
 lemma distinct_map_default:
   assumes "distinct (map fst xs)"
   shows "distinct (map fst (map_default k v f xs))"
   using assms by (induct xs) (auto simp add: dom_map_default)
 
 end
 
 end
diff --git a/src/HOL/Library/AList_Mapping.thy b/src/HOL/Library/AList_Mapping.thy
--- a/src/HOL/Library/AList_Mapping.thy
+++ b/src/HOL/Library/AList_Mapping.thy
@@ -1,118 +1,137 @@
 (*  Title:      HOL/Library/AList_Mapping.thy
     Author:     Florian Haftmann, TU Muenchen
 *)
 
 section \<open>Implementation of mappings with Association Lists\<close>
 
 theory AList_Mapping
   imports AList Mapping
 begin
 
 lift_definition Mapping :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping" is map_of .
 
 code_datatype Mapping
 
 lemma lookup_Mapping [simp, code]: "Mapping.lookup (Mapping xs) = map_of xs"
   by transfer rule
 
 lemma keys_Mapping [simp, code]: "Mapping.keys (Mapping xs) = set (map fst xs)"
   by transfer (simp add: dom_map_of_conv_image_fst)
 
 lemma empty_Mapping [code]: "Mapping.empty = Mapping []"
   by transfer simp
 
 lemma is_empty_Mapping [code]: "Mapping.is_empty (Mapping xs) \<longleftrightarrow> List.null xs"
   by (cases xs) (simp_all add: is_empty_def null_def)
 
 lemma update_Mapping [code]: "Mapping.update k v (Mapping xs) = Mapping (AList.update k v xs)"
   by transfer (simp add: update_conv')
 
 lemma delete_Mapping [code]: "Mapping.delete k (Mapping xs) = Mapping (AList.delete k xs)"
   by transfer (simp add: delete_conv')
 
 lemma ordered_keys_Mapping [code]:
   "Mapping.ordered_keys (Mapping xs) = sort (remdups (map fst xs))"
   by (simp only: ordered_keys_def keys_Mapping sorted_list_of_set_sort_remdups) simp
 
+lemma entries_Mapping [code]:
+  "Mapping.entries (Mapping xs) = set (AList.clearjunk xs)"
+  by transfer (fact graph_map_of)
+
+lemma ordered_entries_Mapping [code]:
+  "Mapping.ordered_entries (Mapping xs) = sort_key fst (AList.clearjunk xs)"
+proof -
+  have distinct: "distinct (sort_key fst (AList.clearjunk xs))"
+    using distinct_clearjunk distinct_map distinct_sort by blast
+  note folding_Map_graph.idem_if_sorted_distinct[where ?m="map_of xs", OF _ sorted_sort_key distinct]
+  then show ?thesis
+    unfolding ordered_entries_def
+    by (transfer fixing: xs) (auto simp: graph_map_of)
+qed
+
+lemma fold_Mapping [code]:
+  "Mapping.fold f (Mapping xs) a = List.fold (case_prod f) (sort_key fst (AList.clearjunk xs)) a"
+  by (simp add: Mapping.fold_def ordered_entries_Mapping)
+
 lemma size_Mapping [code]: "Mapping.size (Mapping xs) = length (remdups (map fst xs))"
   by (simp add: size_def length_remdups_card_conv dom_map_of_conv_image_fst)
 
 lemma tabulate_Mapping [code]: "Mapping.tabulate ks f = Mapping (map (\<lambda>k. (k, f k)) ks)"
   by transfer (simp add: map_of_map_restrict)
 
 lemma bulkload_Mapping [code]:
   "Mapping.bulkload vs = Mapping (map (\<lambda>n. (n, vs ! n)) [0..<length vs])"
   by transfer (simp add: map_of_map_restrict fun_eq_iff)
 
 lemma equal_Mapping [code]:
   "HOL.equal (Mapping xs) (Mapping ys) \<longleftrightarrow>
     (let ks = map fst xs; ls = map fst ys
      in (\<forall>l\<in>set ls. l \<in> set ks) \<and> (\<forall>k\<in>set ks. k \<in> set ls \<and> map_of xs k = map_of ys k))"
 proof -
   have *: "(a, b) \<in> set xs \<Longrightarrow> a \<in> fst ` set xs" for a b xs
     by (auto simp add: image_def intro!: bexI)
   show ?thesis
     apply transfer
     apply (auto intro!: map_of_eqI)
      apply (auto dest!: map_of_eq_dom intro: *)
     done
 qed
 
 lemma map_values_Mapping [code]:
   "Mapping.map_values f (Mapping xs) = Mapping (map (\<lambda>(x,y). (x, f x y)) xs)"
   for f :: "'c \<Rightarrow> 'a \<Rightarrow> 'b" and xs :: "('c \<times> 'a) list"
   apply transfer
   apply (rule ext)
   subgoal for f xs x by (induct xs) auto
   done
 
 lemma combine_with_key_code [code]:
   "Mapping.combine_with_key f (Mapping xs) (Mapping ys) =
      Mapping.tabulate (remdups (map fst xs @ map fst ys))
        (\<lambda>x. the (combine_options (f x) (map_of xs x) (map_of ys x)))"
   apply transfer
   apply (rule ext)
   apply (rule sym)
   subgoal for f xs ys x
     apply (cases "map_of xs x"; cases "map_of ys x"; simp)
        apply (force simp: map_of_eq_None_iff combine_options_def option.the_def o_def image_iff
         dest: map_of_SomeD split: option.splits)+
     done
   done
 
 lemma combine_code [code]:
   "Mapping.combine f (Mapping xs) (Mapping ys) =
      Mapping.tabulate (remdups (map fst xs @ map fst ys))
        (\<lambda>x. the (combine_options f (map_of xs x) (map_of ys x)))"
   apply transfer
   apply (rule ext)
   apply (rule sym)
   subgoal for f xs ys x
     apply (cases "map_of xs x"; cases "map_of ys x"; simp)
        apply (force simp: map_of_eq_None_iff combine_options_def option.the_def o_def image_iff
         dest: map_of_SomeD split: option.splits)+
     done
   done
 
 lemma map_of_filter_distinct:  (* TODO: move? *)
   assumes "distinct (map fst xs)"
   shows "map_of (filter P xs) x =
     (case map_of xs x of
       None \<Rightarrow> None
     | Some y \<Rightarrow> if P (x,y) then Some y else None)"
   using assms
   by (auto simp: map_of_eq_None_iff filter_map distinct_map_filter dest: map_of_SomeD
       simp del: map_of_eq_Some_iff intro!: map_of_is_SomeI split: option.splits)
 
 lemma filter_Mapping [code]:
   "Mapping.filter P (Mapping xs) = Mapping (filter (\<lambda>(k,v). P k v) (AList.clearjunk xs))"
   apply transfer
   apply (rule ext)
   apply (subst map_of_filter_distinct)
    apply (simp_all add: map_of_clearjunk split: option.split)
   done
 
 lemma [code nbe]: "HOL.equal (x :: ('a, 'b) mapping) x \<longleftrightarrow> True"
   by (fact equal_refl)
 
 end
diff --git a/src/HOL/Library/FSet.thy b/src/HOL/Library/FSet.thy
--- a/src/HOL/Library/FSet.thy
+++ b/src/HOL/Library/FSet.thy
@@ -1,1386 +1,1387 @@
 (*  Title:      HOL/Library/FSet.thy
     Author:     Ondrej Kuncar, TU Muenchen
     Author:     Cezary Kaliszyk and Christian Urban
     Author:     Andrei Popescu, TU Muenchen
 *)
 
 section \<open>Type of finite sets defined as a subtype of sets\<close>
 
 theory FSet
 imports Main Countable
 begin
 
 subsection \<open>Definition of the type\<close>
 
 typedef 'a fset = "{A :: 'a set. finite A}"  morphisms fset Abs_fset
 by auto
 
 setup_lifting type_definition_fset
 
 
 subsection \<open>Basic operations and type class instantiations\<close>
 
 (* FIXME transfer and right_total vs. bi_total *)
 instantiation fset :: (finite) finite
 begin
 instance by (standard; transfer; simp)
 end
 
 instantiation fset :: (type) "{bounded_lattice_bot, distrib_lattice, minus}"
 begin
 
 lift_definition bot_fset :: "'a fset" is "{}" parametric empty_transfer by simp
 
 lift_definition less_eq_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" is subset_eq parametric subset_transfer
   .
 
 definition less_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" where "xs < ys \<equiv> xs \<le> ys \<and> xs \<noteq> (ys::'a fset)"
 
 lemma less_fset_transfer[transfer_rule]:
   includes lifting_syntax
   assumes [transfer_rule]: "bi_unique A"
   shows "((pcr_fset A) ===> (pcr_fset A) ===> (=)) (\<subset>) (<)"
   unfolding less_fset_def[abs_def] psubset_eq[abs_def] by transfer_prover
 
 
 lift_definition sup_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is union parametric union_transfer
   by simp
 
 lift_definition inf_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is inter parametric inter_transfer
   by simp
 
 lift_definition minus_fset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is minus parametric Diff_transfer
   by simp
 
 instance
   by (standard; transfer; auto)+
 
 end
 
 abbreviation fempty :: "'a fset" ("{||}") where "{||} \<equiv> bot"
 abbreviation fsubset_eq :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subseteq>|" 50) where "xs |\<subseteq>| ys \<equiv> xs \<le> ys"
 abbreviation fsubset :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<subset>|" 50) where "xs |\<subset>| ys \<equiv> xs < ys"
 abbreviation funion :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<union>|" 65) where "xs |\<union>| ys \<equiv> sup xs ys"
 abbreviation finter :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|\<inter>|" 65) where "xs |\<inter>| ys \<equiv> inf xs ys"
 abbreviation fminus :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" (infixl "|-|" 65) where "xs |-| ys \<equiv> minus xs ys"
 
 instantiation fset :: (equal) equal
 begin
 definition "HOL.equal A B \<longleftrightarrow> A |\<subseteq>| B \<and> B |\<subseteq>| A"
 instance by intro_classes (auto simp add: equal_fset_def)
 end
 
 instantiation fset :: (type) conditionally_complete_lattice
 begin
 
 context includes lifting_syntax
 begin
 
 lemma right_total_Inf_fset_transfer:
   assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
   shows "(rel_set (rel_set A) ===> rel_set A)
     (\<lambda>S. if finite (\<Inter>S \<inter> Collect (Domainp A)) then \<Inter>S \<inter> Collect (Domainp A) else {})
       (\<lambda>S. if finite (Inf S) then Inf S else {})"
     by transfer_prover
 
 lemma Inf_fset_transfer:
   assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
   shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Inf A) then Inf A else {})
     (\<lambda>A. if finite (Inf A) then Inf A else {})"
   by transfer_prover
 
 lift_definition Inf_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Inf A) then Inf A else {}"
 parametric right_total_Inf_fset_transfer Inf_fset_transfer by simp
 
 lemma Sup_fset_transfer:
   assumes [transfer_rule]: "bi_unique A"
   shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>A. if finite (Sup A) then Sup A else {})
   (\<lambda>A. if finite (Sup A) then Sup A else {})" by transfer_prover
 
 lift_definition Sup_fset :: "'a fset set \<Rightarrow> 'a fset" is "\<lambda>A. if finite (Sup A) then Sup A else {}"
 parametric Sup_fset_transfer by simp
 
 lemma finite_Sup: "\<exists>z. finite z \<and> (\<forall>a. a \<in> X \<longrightarrow> a \<le> z) \<Longrightarrow> finite (Sup X)"
 by (auto intro: finite_subset)
 
 lemma transfer_bdd_below[transfer_rule]: "(rel_set (pcr_fset (=)) ===> (=)) bdd_below bdd_below"
   by auto
 
 end
 
 instance
 proof
   fix x z :: "'a fset"
   fix X :: "'a fset set"
   {
     assume "x \<in> X" "bdd_below X"
     then show "Inf X |\<subseteq>| x" by transfer auto
   next
     assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> z |\<subseteq>| x)"
     then show "z |\<subseteq>| Inf X" by transfer (clarsimp, blast)
   next
     assume "x \<in> X" "bdd_above X"
     then obtain z where "x \<in> X" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
       by (auto simp: bdd_above_def)
     then show "x |\<subseteq>| Sup X"
       by transfer (auto intro!: finite_Sup)
   next
     assume "X \<noteq> {}" "(\<And>x. x \<in> X \<Longrightarrow> x |\<subseteq>| z)"
     then show "Sup X |\<subseteq>| z" by transfer (clarsimp, blast)
   }
 qed
 end
 
 instantiation fset :: (finite) complete_lattice
 begin
 
 lift_definition top_fset :: "'a fset" is UNIV parametric right_total_UNIV_transfer UNIV_transfer
   by simp
 
 instance
   by (standard; transfer; auto)
 
 end
 
 instantiation fset :: (finite) complete_boolean_algebra
 begin
 
 lift_definition uminus_fset :: "'a fset \<Rightarrow> 'a fset" is uminus
   parametric right_total_Compl_transfer Compl_transfer by simp
 
 instance
   by (standard; transfer) (simp_all add: Inf_Sup Diff_eq)
 end
 
 abbreviation fUNIV :: "'a::finite fset" where "fUNIV \<equiv> top"
 abbreviation fuminus :: "'a::finite fset \<Rightarrow> 'a fset" ("|-| _" [81] 80) where "|-| x \<equiv> uminus x"
 
 declare top_fset.rep_eq[simp]
 
 
 subsection \<open>Other operations\<close>
 
 lift_definition finsert :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is insert parametric Lifting_Set.insert_transfer
   by simp
 
 syntax
   "_insert_fset"     :: "args => 'a fset"  ("{|(_)|}")
 
 translations
   "{|x, xs|}" == "CONST finsert x {|xs|}"
   "{|x|}"     == "CONST finsert x {||}"
 
 lift_definition fmember :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<in>|" 50) is Set.member
   parametric member_transfer .
 
 abbreviation notin_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<notin>|" 50) where "x |\<notin>| S \<equiv> \<not> (x |\<in>| S)"
 
 context includes lifting_syntax
 begin
 
 lift_definition ffilter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is Set.filter
   parametric Lifting_Set.filter_transfer unfolding Set.filter_def by simp
 
 lift_definition fPow :: "'a fset \<Rightarrow> 'a fset fset" is Pow parametric Pow_transfer
 by (simp add: finite_subset)
 
 lift_definition fcard :: "'a fset \<Rightarrow> nat" is card parametric card_transfer .
 
 lift_definition fimage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset" (infixr "|`|" 90) is image
   parametric image_transfer by simp
 
 lift_definition fthe_elem :: "'a fset \<Rightarrow> 'a" is the_elem .
 
 lift_definition fbind :: "'a fset \<Rightarrow> ('a \<Rightarrow> 'b fset) \<Rightarrow> 'b fset" is Set.bind parametric bind_transfer
 by (simp add: Set.bind_def)
 
 lift_definition ffUnion :: "'a fset fset \<Rightarrow> 'a fset" is Union parametric Union_transfer by simp
 
 lift_definition fBall :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Ball parametric Ball_transfer .
 lift_definition fBex :: "'a fset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" is Bex parametric Bex_transfer .
 
 lift_definition ffold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a fset \<Rightarrow> 'b" is Finite_Set.fold .
 
 lift_definition fset_of_list :: "'a list \<Rightarrow> 'a fset" is set by (rule finite_set)
 
 lift_definition sorted_list_of_fset :: "'a::linorder fset \<Rightarrow> 'a list" is sorted_list_of_set .
 
 subsection \<open>Transferred lemmas from Set.thy\<close>
 
 lemmas fset_eqI = set_eqI[Transfer.transferred]
 lemmas fset_eq_iff[no_atp] = set_eq_iff[Transfer.transferred]
 lemmas fBallI[intro!] = ballI[Transfer.transferred]
 lemmas fbspec[dest?] = bspec[Transfer.transferred]
 lemmas fBallE[elim] = ballE[Transfer.transferred]
 lemmas fBexI[intro] = bexI[Transfer.transferred]
 lemmas rev_fBexI[intro?] = rev_bexI[Transfer.transferred]
 lemmas fBexCI = bexCI[Transfer.transferred]
 lemmas fBexE[elim!] = bexE[Transfer.transferred]
 lemmas fBall_triv[simp] = ball_triv[Transfer.transferred]
 lemmas fBex_triv[simp] = bex_triv[Transfer.transferred]
 lemmas fBex_triv_one_point1[simp] = bex_triv_one_point1[Transfer.transferred]
 lemmas fBex_triv_one_point2[simp] = bex_triv_one_point2[Transfer.transferred]
 lemmas fBex_one_point1[simp] = bex_one_point1[Transfer.transferred]
 lemmas fBex_one_point2[simp] = bex_one_point2[Transfer.transferred]
 lemmas fBall_one_point1[simp] = ball_one_point1[Transfer.transferred]
 lemmas fBall_one_point2[simp] = ball_one_point2[Transfer.transferred]
 lemmas fBall_conj_distrib = ball_conj_distrib[Transfer.transferred]
 lemmas fBex_disj_distrib = bex_disj_distrib[Transfer.transferred]
 lemmas fBall_cong[fundef_cong] = ball_cong[Transfer.transferred]
 lemmas fBex_cong[fundef_cong] = bex_cong[Transfer.transferred]
 lemmas fsubsetI[intro!] = subsetI[Transfer.transferred]
 lemmas fsubsetD[elim, intro?] = subsetD[Transfer.transferred]
 lemmas rev_fsubsetD[no_atp,intro?] = rev_subsetD[Transfer.transferred]
 lemmas fsubsetCE[no_atp,elim] = subsetCE[Transfer.transferred]
 lemmas fsubset_eq[no_atp] = subset_eq[Transfer.transferred]
 lemmas contra_fsubsetD[no_atp] = contra_subsetD[Transfer.transferred]
 lemmas fsubset_refl = subset_refl[Transfer.transferred]
 lemmas fsubset_trans = subset_trans[Transfer.transferred]
 lemmas fset_rev_mp = rev_subsetD[Transfer.transferred]
 lemmas fset_mp = subsetD[Transfer.transferred]
 lemmas fsubset_not_fsubset_eq[code] = subset_not_subset_eq[Transfer.transferred]
 lemmas eq_fmem_trans = eq_mem_trans[Transfer.transferred]
 lemmas fsubset_antisym[intro!] = subset_antisym[Transfer.transferred]
 lemmas fequalityD1 = equalityD1[Transfer.transferred]
 lemmas fequalityD2 = equalityD2[Transfer.transferred]
 lemmas fequalityE = equalityE[Transfer.transferred]
 lemmas fequalityCE[elim] = equalityCE[Transfer.transferred]
 lemmas eqfset_imp_iff = eqset_imp_iff[Transfer.transferred]
 lemmas eqfelem_imp_iff = eqelem_imp_iff[Transfer.transferred]
 lemmas fempty_iff[simp] = empty_iff[Transfer.transferred]
 lemmas fempty_fsubsetI[iff] = empty_subsetI[Transfer.transferred]
 lemmas equalsffemptyI = equals0I[Transfer.transferred]
 lemmas equalsffemptyD = equals0D[Transfer.transferred]
 lemmas fBall_fempty[simp] = ball_empty[Transfer.transferred]
 lemmas fBex_fempty[simp] = bex_empty[Transfer.transferred]
 lemmas fPow_iff[iff] = Pow_iff[Transfer.transferred]
 lemmas fPowI = PowI[Transfer.transferred]
 lemmas fPowD = PowD[Transfer.transferred]
 lemmas fPow_bottom = Pow_bottom[Transfer.transferred]
 lemmas fPow_top = Pow_top[Transfer.transferred]
 lemmas fPow_not_fempty = Pow_not_empty[Transfer.transferred]
 lemmas finter_iff[simp] = Int_iff[Transfer.transferred]
 lemmas finterI[intro!] = IntI[Transfer.transferred]
 lemmas finterD1 = IntD1[Transfer.transferred]
 lemmas finterD2 = IntD2[Transfer.transferred]
 lemmas finterE[elim!] = IntE[Transfer.transferred]
 lemmas funion_iff[simp] = Un_iff[Transfer.transferred]
 lemmas funionI1[elim?] = UnI1[Transfer.transferred]
 lemmas funionI2[elim?] = UnI2[Transfer.transferred]
 lemmas funionCI[intro!] = UnCI[Transfer.transferred]
 lemmas funionE[elim!] = UnE[Transfer.transferred]
 lemmas fminus_iff[simp] = Diff_iff[Transfer.transferred]
 lemmas fminusI[intro!] = DiffI[Transfer.transferred]
 lemmas fminusD1 = DiffD1[Transfer.transferred]
 lemmas fminusD2 = DiffD2[Transfer.transferred]
 lemmas fminusE[elim!] = DiffE[Transfer.transferred]
 lemmas finsert_iff[simp] = insert_iff[Transfer.transferred]
 lemmas finsertI1 = insertI1[Transfer.transferred]
 lemmas finsertI2 = insertI2[Transfer.transferred]
 lemmas finsertE[elim!] = insertE[Transfer.transferred]
 lemmas finsertCI[intro!] = insertCI[Transfer.transferred]
 lemmas fsubset_finsert_iff = subset_insert_iff[Transfer.transferred]
 lemmas finsert_ident = insert_ident[Transfer.transferred]
 lemmas fsingletonI[intro!,no_atp] = singletonI[Transfer.transferred]
 lemmas fsingletonD[dest!,no_atp] = singletonD[Transfer.transferred]
 lemmas fsingleton_iff = singleton_iff[Transfer.transferred]
 lemmas fsingleton_inject[dest!] = singleton_inject[Transfer.transferred]
 lemmas fsingleton_finsert_inj_eq[iff,no_atp] = singleton_insert_inj_eq[Transfer.transferred]
 lemmas fsingleton_finsert_inj_eq'[iff,no_atp] = singleton_insert_inj_eq'[Transfer.transferred]
 lemmas fsubset_fsingletonD = subset_singletonD[Transfer.transferred]
 lemmas fminus_single_finsert = Diff_single_insert[Transfer.transferred]
 lemmas fdoubleton_eq_iff = doubleton_eq_iff[Transfer.transferred]
 lemmas funion_fsingleton_iff = Un_singleton_iff[Transfer.transferred]
 lemmas fsingleton_funion_iff = singleton_Un_iff[Transfer.transferred]
 lemmas fimage_eqI[simp, intro] = image_eqI[Transfer.transferred]
 lemmas fimageI = imageI[Transfer.transferred]
 lemmas rev_fimage_eqI = rev_image_eqI[Transfer.transferred]
 lemmas fimageE[elim!] = imageE[Transfer.transferred]
 lemmas Compr_fimage_eq = Compr_image_eq[Transfer.transferred]
 lemmas fimage_funion = image_Un[Transfer.transferred]
 lemmas fimage_iff = image_iff[Transfer.transferred]
 lemmas fimage_fsubset_iff[no_atp] = image_subset_iff[Transfer.transferred]
 lemmas fimage_fsubsetI = image_subsetI[Transfer.transferred]
 lemmas fimage_ident[simp] = image_ident[Transfer.transferred]
 lemmas if_split_fmem1 = if_split_mem1[Transfer.transferred]
 lemmas if_split_fmem2 = if_split_mem2[Transfer.transferred]
 lemmas pfsubsetI[intro!,no_atp] = psubsetI[Transfer.transferred]
 lemmas pfsubsetE[elim!,no_atp] = psubsetE[Transfer.transferred]
 lemmas pfsubset_finsert_iff = psubset_insert_iff[Transfer.transferred]
 lemmas pfsubset_eq = psubset_eq[Transfer.transferred]
 lemmas pfsubset_imp_fsubset = psubset_imp_subset[Transfer.transferred]
 lemmas pfsubset_trans = psubset_trans[Transfer.transferred]
 lemmas pfsubsetD = psubsetD[Transfer.transferred]
 lemmas pfsubset_fsubset_trans = psubset_subset_trans[Transfer.transferred]
 lemmas fsubset_pfsubset_trans = subset_psubset_trans[Transfer.transferred]
 lemmas pfsubset_imp_ex_fmem = psubset_imp_ex_mem[Transfer.transferred]
 lemmas fimage_fPow_mono = image_Pow_mono[Transfer.transferred]
 lemmas fimage_fPow_surj = image_Pow_surj[Transfer.transferred]
 lemmas fsubset_finsertI = subset_insertI[Transfer.transferred]
 lemmas fsubset_finsertI2 = subset_insertI2[Transfer.transferred]
 lemmas fsubset_finsert = subset_insert[Transfer.transferred]
 lemmas funion_upper1 = Un_upper1[Transfer.transferred]
 lemmas funion_upper2 = Un_upper2[Transfer.transferred]
 lemmas funion_least = Un_least[Transfer.transferred]
 lemmas finter_lower1 = Int_lower1[Transfer.transferred]
 lemmas finter_lower2 = Int_lower2[Transfer.transferred]
 lemmas finter_greatest = Int_greatest[Transfer.transferred]
 lemmas fminus_fsubset = Diff_subset[Transfer.transferred]
 lemmas fminus_fsubset_conv = Diff_subset_conv[Transfer.transferred]
 lemmas fsubset_fempty[simp] = subset_empty[Transfer.transferred]
 lemmas not_pfsubset_fempty[iff] = not_psubset_empty[Transfer.transferred]
 lemmas finsert_is_funion = insert_is_Un[Transfer.transferred]
 lemmas finsert_not_fempty[simp] = insert_not_empty[Transfer.transferred]
 lemmas fempty_not_finsert = empty_not_insert[Transfer.transferred]
 lemmas finsert_absorb = insert_absorb[Transfer.transferred]
 lemmas finsert_absorb2[simp] = insert_absorb2[Transfer.transferred]
 lemmas finsert_commute = insert_commute[Transfer.transferred]
 lemmas finsert_fsubset[simp] = insert_subset[Transfer.transferred]
 lemmas finsert_inter_finsert[simp] = insert_inter_insert[Transfer.transferred]
 lemmas finsert_disjoint[simp,no_atp] = insert_disjoint[Transfer.transferred]
 lemmas disjoint_finsert[simp,no_atp] = disjoint_insert[Transfer.transferred]
 lemmas fimage_fempty[simp] = image_empty[Transfer.transferred]
 lemmas fimage_finsert[simp] = image_insert[Transfer.transferred]
 lemmas fimage_constant = image_constant[Transfer.transferred]
 lemmas fimage_constant_conv = image_constant_conv[Transfer.transferred]
 lemmas fimage_fimage = image_image[Transfer.transferred]
 lemmas finsert_fimage[simp] = insert_image[Transfer.transferred]
 lemmas fimage_is_fempty[iff] = image_is_empty[Transfer.transferred]
 lemmas fempty_is_fimage[iff] = empty_is_image[Transfer.transferred]
 lemmas fimage_cong = image_cong[Transfer.transferred]
 lemmas fimage_finter_fsubset = image_Int_subset[Transfer.transferred]
 lemmas fimage_fminus_fsubset = image_diff_subset[Transfer.transferred]
 lemmas finter_absorb = Int_absorb[Transfer.transferred]
 lemmas finter_left_absorb = Int_left_absorb[Transfer.transferred]
 lemmas finter_commute = Int_commute[Transfer.transferred]
 lemmas finter_left_commute = Int_left_commute[Transfer.transferred]
 lemmas finter_assoc = Int_assoc[Transfer.transferred]
 lemmas finter_ac = Int_ac[Transfer.transferred]
 lemmas finter_absorb1 = Int_absorb1[Transfer.transferred]
 lemmas finter_absorb2 = Int_absorb2[Transfer.transferred]
 lemmas finter_fempty_left = Int_empty_left[Transfer.transferred]
 lemmas finter_fempty_right = Int_empty_right[Transfer.transferred]
 lemmas disjoint_iff_fnot_equal = disjoint_iff_not_equal[Transfer.transferred]
 lemmas finter_funion_distrib = Int_Un_distrib[Transfer.transferred]
 lemmas finter_funion_distrib2 = Int_Un_distrib2[Transfer.transferred]
 lemmas finter_fsubset_iff[no_atp, simp] = Int_subset_iff[Transfer.transferred]
 lemmas funion_absorb = Un_absorb[Transfer.transferred]
 lemmas funion_left_absorb = Un_left_absorb[Transfer.transferred]
 lemmas funion_commute = Un_commute[Transfer.transferred]
 lemmas funion_left_commute = Un_left_commute[Transfer.transferred]
 lemmas funion_assoc = Un_assoc[Transfer.transferred]
 lemmas funion_ac = Un_ac[Transfer.transferred]
 lemmas funion_absorb1 = Un_absorb1[Transfer.transferred]
 lemmas funion_absorb2 = Un_absorb2[Transfer.transferred]
 lemmas funion_fempty_left = Un_empty_left[Transfer.transferred]
 lemmas funion_fempty_right = Un_empty_right[Transfer.transferred]
 lemmas funion_finsert_left[simp] = Un_insert_left[Transfer.transferred]
 lemmas funion_finsert_right[simp] = Un_insert_right[Transfer.transferred]
 lemmas finter_finsert_left = Int_insert_left[Transfer.transferred]
 lemmas finter_finsert_left_ifffempty[simp] = Int_insert_left_if0[Transfer.transferred]
 lemmas finter_finsert_left_if1[simp] = Int_insert_left_if1[Transfer.transferred]
 lemmas finter_finsert_right = Int_insert_right[Transfer.transferred]
 lemmas finter_finsert_right_ifffempty[simp] = Int_insert_right_if0[Transfer.transferred]
 lemmas finter_finsert_right_if1[simp] = Int_insert_right_if1[Transfer.transferred]
 lemmas funion_finter_distrib = Un_Int_distrib[Transfer.transferred]
 lemmas funion_finter_distrib2 = Un_Int_distrib2[Transfer.transferred]
 lemmas funion_finter_crazy = Un_Int_crazy[Transfer.transferred]
 lemmas fsubset_funion_eq = subset_Un_eq[Transfer.transferred]
 lemmas funion_fempty[iff] = Un_empty[Transfer.transferred]
 lemmas funion_fsubset_iff[no_atp, simp] = Un_subset_iff[Transfer.transferred]
 lemmas funion_fminus_finter = Un_Diff_Int[Transfer.transferred]
 lemmas ffunion_empty[simp] = Union_empty[Transfer.transferred]
 lemmas ffunion_mono = Union_mono[Transfer.transferred]
 lemmas ffunion_insert[simp] = Union_insert[Transfer.transferred]
 lemmas fminus_finter2 = Diff_Int2[Transfer.transferred]
 lemmas funion_finter_assoc_eq = Un_Int_assoc_eq[Transfer.transferred]
 lemmas fBall_funion = ball_Un[Transfer.transferred]
 lemmas fBex_funion = bex_Un[Transfer.transferred]
 lemmas fminus_eq_fempty_iff[simp,no_atp] = Diff_eq_empty_iff[Transfer.transferred]
 lemmas fminus_cancel[simp] = Diff_cancel[Transfer.transferred]
 lemmas fminus_idemp[simp] = Diff_idemp[Transfer.transferred]
 lemmas fminus_triv = Diff_triv[Transfer.transferred]
 lemmas fempty_fminus[simp] = empty_Diff[Transfer.transferred]
 lemmas fminus_fempty[simp] = Diff_empty[Transfer.transferred]
 lemmas fminus_finsertffempty[simp,no_atp] = Diff_insert0[Transfer.transferred]
 lemmas fminus_finsert = Diff_insert[Transfer.transferred]
 lemmas fminus_finsert2 = Diff_insert2[Transfer.transferred]
 lemmas finsert_fminus_if = insert_Diff_if[Transfer.transferred]
 lemmas finsert_fminus1[simp] = insert_Diff1[Transfer.transferred]
 lemmas finsert_fminus_single[simp] = insert_Diff_single[Transfer.transferred]
 lemmas finsert_fminus = insert_Diff[Transfer.transferred]
 lemmas fminus_finsert_absorb = Diff_insert_absorb[Transfer.transferred]
 lemmas fminus_disjoint[simp] = Diff_disjoint[Transfer.transferred]
 lemmas fminus_partition = Diff_partition[Transfer.transferred]
 lemmas double_fminus = double_diff[Transfer.transferred]
 lemmas funion_fminus_cancel[simp] = Un_Diff_cancel[Transfer.transferred]
 lemmas funion_fminus_cancel2[simp] = Un_Diff_cancel2[Transfer.transferred]
 lemmas fminus_funion = Diff_Un[Transfer.transferred]
 lemmas fminus_finter = Diff_Int[Transfer.transferred]
 lemmas funion_fminus = Un_Diff[Transfer.transferred]
 lemmas finter_fminus = Int_Diff[Transfer.transferred]
 lemmas fminus_finter_distrib = Diff_Int_distrib[Transfer.transferred]
 lemmas fminus_finter_distrib2 = Diff_Int_distrib2[Transfer.transferred]
 lemmas fUNIV_bool[no_atp] = UNIV_bool[Transfer.transferred]
 lemmas fPow_fempty[simp] = Pow_empty[Transfer.transferred]
 lemmas fPow_finsert = Pow_insert[Transfer.transferred]
 lemmas funion_fPow_fsubset = Un_Pow_subset[Transfer.transferred]
 lemmas fPow_finter_eq[simp] = Pow_Int_eq[Transfer.transferred]
 lemmas fset_eq_fsubset = set_eq_subset[Transfer.transferred]
 lemmas fsubset_iff[no_atp] = subset_iff[Transfer.transferred]
 lemmas fsubset_iff_pfsubset_eq = subset_iff_psubset_eq[Transfer.transferred]
 lemmas all_not_fin_conv[simp] = all_not_in_conv[Transfer.transferred]
 lemmas ex_fin_conv = ex_in_conv[Transfer.transferred]
 lemmas fimage_mono = image_mono[Transfer.transferred]
 lemmas fPow_mono = Pow_mono[Transfer.transferred]
 lemmas finsert_mono = insert_mono[Transfer.transferred]
 lemmas funion_mono = Un_mono[Transfer.transferred]
 lemmas finter_mono = Int_mono[Transfer.transferred]
 lemmas fminus_mono = Diff_mono[Transfer.transferred]
 lemmas fin_mono = in_mono[Transfer.transferred]
 lemmas fthe_felem_eq[simp] = the_elem_eq[Transfer.transferred]
 lemmas fLeast_mono = Least_mono[Transfer.transferred]
 lemmas fbind_fbind = bind_bind[Transfer.transferred]
 lemmas fempty_fbind[simp] = empty_bind[Transfer.transferred]
 lemmas nonfempty_fbind_const = nonempty_bind_const[Transfer.transferred]
 lemmas fbind_const = bind_const[Transfer.transferred]
 lemmas ffmember_filter[simp] = member_filter[Transfer.transferred]
 lemmas fequalityI = equalityI[Transfer.transferred]
 lemmas fset_of_list_simps[simp] = set_simps[Transfer.transferred]
 lemmas fset_of_list_append[simp] = set_append[Transfer.transferred]
 lemmas fset_of_list_rev[simp] = set_rev[Transfer.transferred]
 lemmas fset_of_list_map[simp] = set_map[Transfer.transferred]
 
 
 subsection \<open>Additional lemmas\<close>
 
 subsubsection \<open>\<open>ffUnion\<close>\<close>
 
 lemmas ffUnion_funion_distrib[simp] = Union_Un_distrib[Transfer.transferred]
 
 
 subsubsection \<open>\<open>fbind\<close>\<close>
 
 lemma fbind_cong[fundef_cong]: "A = B \<Longrightarrow> (\<And>x. x |\<in>| B \<Longrightarrow> f x = g x) \<Longrightarrow> fbind A f = fbind B g"
 by transfer force
 
 
 subsubsection \<open>\<open>fsingleton\<close>\<close>
 
 lemmas fsingletonE = fsingletonD [elim_format]
 
 
 subsubsection \<open>\<open>femepty\<close>\<close>
 
 lemma fempty_ffilter[simp]: "ffilter (\<lambda>_. False) A = {||}"
 by transfer auto
 
 (* FIXME, transferred doesn't work here *)
 lemma femptyE [elim!]: "a |\<in>| {||} \<Longrightarrow> P"
   by simp
 
 
 subsubsection \<open>\<open>fset\<close>\<close>
 
 lemmas fset_simps[simp] = bot_fset.rep_eq finsert.rep_eq
 
 lemma finite_fset [simp]:
   shows "finite (fset S)"
   by transfer simp
 
 lemmas fset_cong = fset_inject
 
 lemma filter_fset [simp]:
   shows "fset (ffilter P xs) = Collect P \<inter> fset xs"
   by transfer auto
 
 lemma notin_fset: "x |\<notin>| S \<longleftrightarrow> x \<notin> fset S" by (simp add: fmember.rep_eq)
 
 lemmas inter_fset[simp] = inf_fset.rep_eq
 
 lemmas union_fset[simp] = sup_fset.rep_eq
 
 lemmas minus_fset[simp] = minus_fset.rep_eq
 
 
 subsubsection \<open>\<open>ffilter\<close>\<close>
 
 lemma subset_ffilter:
   "ffilter P A |\<subseteq>| ffilter Q A = (\<forall> x. x |\<in>| A \<longrightarrow> P x \<longrightarrow> Q x)"
   by transfer auto
 
 lemma eq_ffilter:
   "(ffilter P A = ffilter Q A) = (\<forall>x. x |\<in>| A \<longrightarrow> P x = Q x)"
   by transfer auto
 
 lemma pfsubset_ffilter:
   "(\<And>x. x |\<in>| A \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> (x |\<in>| A \<and> \<not> P x \<and> Q x) \<Longrightarrow>
     ffilter P A |\<subset>| ffilter Q A"
   unfolding less_fset_def by (auto simp add: subset_ffilter eq_ffilter)
 
 
 subsubsection \<open>\<open>fset_of_list\<close>\<close>
 
 lemma fset_of_list_filter[simp]:
   "fset_of_list (filter P xs) = ffilter P (fset_of_list xs)"
   by transfer (auto simp: Set.filter_def)
 
 lemma fset_of_list_subset[intro]:
   "set xs \<subseteq> set ys \<Longrightarrow> fset_of_list xs |\<subseteq>| fset_of_list ys"
   by transfer simp
 
 lemma fset_of_list_elem: "(x |\<in>| fset_of_list xs) \<longleftrightarrow> (x \<in> set xs)"
   by transfer simp
 
 
 subsubsection \<open>\<open>finsert\<close>\<close>
 
 (* FIXME, transferred doesn't work here *)
 lemma set_finsert:
   assumes "x |\<in>| A"
   obtains B where "A = finsert x B" and "x |\<notin>| B"
 using assms by transfer (metis Set.set_insert finite_insert)
 
 lemma mk_disjoint_finsert: "a |\<in>| A \<Longrightarrow> \<exists>B. A = finsert a B \<and> a |\<notin>| B"
   by (rule exI [where x = "A |-| {|a|}"]) blast
 
 lemma finsert_eq_iff:
   assumes "a |\<notin>| A" and "b |\<notin>| B"
   shows "(finsert a A = finsert b B) =
     (if a = b then A = B else \<exists>C. A = finsert b C \<and> b |\<notin>| C \<and> B = finsert a C \<and> a |\<notin>| C)"
   using assms by transfer (force simp: insert_eq_iff)
 
 
 subsubsection \<open>\<open>fimage\<close>\<close>
 
 lemma subset_fimage_iff: "(B |\<subseteq>| f|`|A) = (\<exists> AA. AA |\<subseteq>| A \<and> B = f|`|AA)"
 by transfer (metis mem_Collect_eq rev_finite_subset subset_image_iff)
 
 
 subsubsection \<open>bounded quantification\<close>
 
 lemma bex_simps [simp, no_atp]:
   "\<And>A P Q. fBex A (\<lambda>x. P x \<and> Q) = (fBex A P \<and> Q)"
   "\<And>A P Q. fBex A (\<lambda>x. P \<and> Q x) = (P \<and> fBex A Q)"
   "\<And>P. fBex {||} P = False"
   "\<And>a B P. fBex (finsert a B) P = (P a \<or> fBex B P)"
   "\<And>A P f. fBex (f |`| A) P = fBex A (\<lambda>x. P (f x))"
   "\<And>A P. (\<not> fBex A P) = fBall A (\<lambda>x. \<not> P x)"
 by auto
 
 lemma ball_simps [simp, no_atp]:
   "\<And>A P Q. fBall A (\<lambda>x. P x \<or> Q) = (fBall A P \<or> Q)"
   "\<And>A P Q. fBall A (\<lambda>x. P \<or> Q x) = (P \<or> fBall A Q)"
   "\<And>A P Q. fBall A (\<lambda>x. P \<longrightarrow> Q x) = (P \<longrightarrow> fBall A Q)"
   "\<And>A P Q. fBall A (\<lambda>x. P x \<longrightarrow> Q) = (fBex A P \<longrightarrow> Q)"
   "\<And>P. fBall {||} P = True"
   "\<And>a B P. fBall (finsert a B) P = (P a \<and> fBall B P)"
   "\<And>A P f. fBall (f |`| A) P = fBall A (\<lambda>x. P (f x))"
   "\<And>A P. (\<not> fBall A P) = fBex A (\<lambda>x. \<not> P x)"
 by auto
 
 lemma atomize_fBall:
     "(\<And>x. x |\<in>| A ==> P x) == Trueprop (fBall A (\<lambda>x. P x))"
 apply (simp only: atomize_all atomize_imp)
 apply (rule equal_intr_rule)
   by (transfer, simp)+
 
 lemma fBall_mono[mono]: "P \<le> Q \<Longrightarrow> fBall S P \<le> fBall S Q"
 by auto
 
 lemma fBex_mono[mono]: "P \<le> Q \<Longrightarrow> fBex S P \<le> fBex S Q"
 by auto
 
 end
 
 
 subsubsection \<open>\<open>fcard\<close>\<close>
 
 (* FIXME: improve transferred to handle bounded meta quantification *)
 
 lemma fcard_fempty:
   "fcard {||} = 0"
   by transfer (rule card.empty)
 
 lemma fcard_finsert_disjoint:
   "x |\<notin>| A \<Longrightarrow> fcard (finsert x A) = Suc (fcard A)"
   by transfer (rule card_insert_disjoint)
 
 lemma fcard_finsert_if:
   "fcard (finsert x A) = (if x |\<in>| A then fcard A else Suc (fcard A))"
   by transfer (rule card_insert_if)
 
 lemma fcard_0_eq [simp, no_atp]:
   "fcard A = 0 \<longleftrightarrow> A = {||}"
   by transfer (rule card_0_eq)
 
 lemma fcard_Suc_fminus1:
   "x |\<in>| A \<Longrightarrow> Suc (fcard (A |-| {|x|})) = fcard A"
   by transfer (rule card_Suc_Diff1)
 
 lemma fcard_fminus_fsingleton:
   "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) = fcard A - 1"
   by transfer (rule card_Diff_singleton)
 
 lemma fcard_fminus_fsingleton_if:
   "fcard (A |-| {|x|}) = (if x |\<in>| A then fcard A - 1 else fcard A)"
   by transfer (rule card_Diff_singleton_if)
 
 lemma fcard_fminus_finsert[simp]:
   assumes "a |\<in>| A" and "a |\<notin>| B"
   shows "fcard (A |-| finsert a B) = fcard (A |-| B) - 1"
 using assms by transfer (rule card_Diff_insert)
 
 lemma fcard_finsert: "fcard (finsert x A) = Suc (fcard (A |-| {|x|}))"
 by transfer (rule card.insert_remove)
 
 lemma fcard_finsert_le: "fcard A \<le> fcard (finsert x A)"
 by transfer (rule card_insert_le)
 
 lemma fcard_mono:
   "A |\<subseteq>| B \<Longrightarrow> fcard A \<le> fcard B"
 by transfer (rule card_mono)
 
 lemma fcard_seteq: "A |\<subseteq>| B \<Longrightarrow> fcard B \<le> fcard A \<Longrightarrow> A = B"
 by transfer (rule card_seteq)
 
 lemma pfsubset_fcard_mono: "A |\<subset>| B \<Longrightarrow> fcard A < fcard B"
 by transfer (rule psubset_card_mono)
 
 lemma fcard_funion_finter:
   "fcard A + fcard B = fcard (A |\<union>| B) + fcard (A |\<inter>| B)"
 by transfer (rule card_Un_Int)
 
 lemma fcard_funion_disjoint:
   "A |\<inter>| B = {||} \<Longrightarrow> fcard (A |\<union>| B) = fcard A + fcard B"
 by transfer (rule card_Un_disjoint)
 
 lemma fcard_funion_fsubset:
   "B |\<subseteq>| A \<Longrightarrow> fcard (A |-| B) = fcard A - fcard B"
 by transfer (rule card_Diff_subset)
 
 lemma diff_fcard_le_fcard_fminus:
   "fcard A - fcard B \<le> fcard(A |-| B)"
 by transfer (rule diff_card_le_card_Diff)
 
 lemma fcard_fminus1_less: "x |\<in>| A \<Longrightarrow> fcard (A |-| {|x|}) < fcard A"
 by transfer (rule card_Diff1_less)
 
 lemma fcard_fminus2_less:
   "x |\<in>| A \<Longrightarrow> y |\<in>| A \<Longrightarrow> fcard (A |-| {|x|} |-| {|y|}) < fcard A"
 by transfer (rule card_Diff2_less)
 
 lemma fcard_fminus1_le: "fcard (A |-| {|x|}) \<le> fcard A"
 by transfer (rule card_Diff1_le)
 
 lemma fcard_pfsubset: "A |\<subseteq>| B \<Longrightarrow> fcard A < fcard B \<Longrightarrow> A < B"
 by transfer (rule card_psubset)
 
 
 subsubsection \<open>\<open>sorted_list_of_fset\<close>\<close>
 
 lemma sorted_list_of_fset_simps[simp]:
   "set (sorted_list_of_fset S) = fset S"
   "fset_of_list (sorted_list_of_fset S) = S"
 by (transfer, simp)+
 
 
 subsubsection \<open>\<open>ffold\<close>\<close>
 
 (* FIXME: improve transferred to handle bounded meta quantification *)
 
 context comp_fun_commute
 begin
   lemmas ffold_empty[simp] = fold_empty[Transfer.transferred]
 
   lemma ffold_finsert [simp]:
     assumes "x |\<notin>| A"
     shows "ffold f z (finsert x A) = f x (ffold f z A)"
     using assms by (transfer fixing: f) (rule fold_insert)
 
   lemma ffold_fun_left_comm:
     "f x (ffold f z A) = ffold f (f x z) A"
     by (transfer fixing: f) (rule fold_fun_left_comm)
 
   lemma ffold_finsert2:
     "x |\<notin>| A \<Longrightarrow> ffold f z (finsert x A) = ffold f (f x z) A"
     by (transfer fixing: f) (rule fold_insert2)
 
   lemma ffold_rec:
     assumes "x |\<in>| A"
     shows "ffold f z A = f x (ffold f z (A |-| {|x|}))"
     using assms by (transfer fixing: f) (rule fold_rec)
 
   lemma ffold_finsert_fremove:
     "ffold f z (finsert x A) = f x (ffold f z (A |-| {|x|}))"
      by (transfer fixing: f) (rule fold_insert_remove)
 end
 
 lemma ffold_fimage:
   assumes "inj_on g (fset A)"
   shows "ffold f z (g |`| A) = ffold (f \<circ> g) z A"
 using assms by transfer' (rule fold_image)
 
 lemma ffold_cong:
   assumes "comp_fun_commute f" "comp_fun_commute g"
   "\<And>x. x |\<in>| A \<Longrightarrow> f x = g x"
     and "s = t" and "A = B"
   shows "ffold f s A = ffold g t B"
-using assms by transfer (metis Finite_Set.fold_cong)
+  using assms[unfolded comp_fun_commute_def']
+  by transfer (meson Finite_Set.fold_cong subset_UNIV)
 
 context comp_fun_idem
 begin
 
   lemma ffold_finsert_idem:
     "ffold f z (finsert x A) = f x (ffold f z A)"
     by (transfer fixing: f) (rule fold_insert_idem)
 
   declare ffold_finsert [simp del] ffold_finsert_idem [simp]
 
   lemma ffold_finsert_idem2:
     "ffold f z (finsert x A) = ffold f (f x z) A"
     by (transfer fixing: f) (rule fold_insert_idem2)
 
 end
 
 
 subsubsection \<open>Group operations\<close>
 
 locale comm_monoid_fset = comm_monoid
 begin
 
 sublocale set: comm_monoid_set ..
 
 lift_definition F :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b fset \<Rightarrow> 'a" is set.F .
 
 lemmas cong[fundef_cong] = set.cong[Transfer.transferred]
 
 lemma cong_simp[cong]:
   "\<lbrakk> A = B;  \<And>x. x |\<in>| B =simp=> g x = h x \<rbrakk> \<Longrightarrow> F g A = F h B"
 unfolding simp_implies_def by (auto cong: cong)
 
 end
 
 context comm_monoid_add begin
 
 sublocale fsum: comm_monoid_fset plus 0
   rewrites "comm_monoid_set.F plus 0 = sum"
   defines fsum = fsum.F
 proof -
   show "comm_monoid_fset (+) 0" by standard
 
   show "comm_monoid_set.F (+) 0 = sum" unfolding sum_def ..
 qed
 
 end
 
 
 subsubsection \<open>Semilattice operations\<close>
 
 locale semilattice_fset = semilattice
 begin
 
 sublocale set: semilattice_set ..
 
 lift_definition F :: "'a fset \<Rightarrow> 'a" is set.F .
 
 lemma eq_fold: "F (finsert x A) = ffold f x A"
   by transfer (rule set.eq_fold)
 
 lemma singleton [simp]: "F {|x|} = x"
   by transfer (rule set.singleton)
 
 lemma insert_not_elem: "x |\<notin>| A \<Longrightarrow> A \<noteq> {||} \<Longrightarrow> F (finsert x A) = x \<^bold>* F A"
   by transfer (rule set.insert_not_elem)
 
 lemma in_idem: "x |\<in>| A \<Longrightarrow> x \<^bold>* F A = F A"
   by transfer (rule set.in_idem)
 
 lemma insert [simp]: "A \<noteq> {||} \<Longrightarrow> F (finsert x A) = x \<^bold>* F A"
   by transfer (rule set.insert)
 
 end
 
 locale semilattice_order_fset = binary?: semilattice_order + semilattice_fset
 begin
 
 end
 
 
 context linorder begin
 
 sublocale fMin: semilattice_order_fset min less_eq less
   rewrites "semilattice_set.F min = Min"
   defines fMin = fMin.F
 proof -
   show "semilattice_order_fset min (\<le>) (<)" by standard
 
   show "semilattice_set.F min = Min" unfolding Min_def ..
 qed
 
 sublocale fMax: semilattice_order_fset max greater_eq greater
   rewrites "semilattice_set.F max = Max"
   defines fMax = fMax.F
 proof -
   show "semilattice_order_fset max (\<ge>) (>)"
     by standard
 
   show "semilattice_set.F max = Max"
     unfolding Max_def ..
 qed
 
 end
 
 lemma mono_fMax_commute: "mono f \<Longrightarrow> A \<noteq> {||} \<Longrightarrow> f (fMax A) = fMax (f |`| A)"
   by transfer (rule mono_Max_commute)
 
 lemma mono_fMin_commute: "mono f \<Longrightarrow> A \<noteq> {||} \<Longrightarrow> f (fMin A) = fMin (f |`| A)"
   by transfer (rule mono_Min_commute)
 
 lemma fMax_in[simp]: "A \<noteq> {||} \<Longrightarrow> fMax A |\<in>| A"
   by transfer (rule Max_in)
 
 lemma fMin_in[simp]: "A \<noteq> {||} \<Longrightarrow> fMin A |\<in>| A"
   by transfer (rule Min_in)
 
 lemma fMax_ge[simp]: "x |\<in>| A \<Longrightarrow> x \<le> fMax A"
   by transfer (rule Max_ge)
 
 lemma fMin_le[simp]: "x |\<in>| A \<Longrightarrow> fMin A \<le> x"
   by transfer (rule Min_le)
 
 lemma fMax_eqI: "(\<And>y. y |\<in>| A \<Longrightarrow> y \<le> x) \<Longrightarrow> x |\<in>| A \<Longrightarrow> fMax A = x"
   by transfer (rule Max_eqI)
 
 lemma fMin_eqI: "(\<And>y. y |\<in>| A \<Longrightarrow> x \<le> y) \<Longrightarrow> x |\<in>| A \<Longrightarrow> fMin A = x"
   by transfer (rule Min_eqI)
 
 lemma fMax_finsert[simp]: "fMax (finsert x A) = (if A = {||} then x else max x (fMax A))"
   by transfer simp
 
 lemma fMin_finsert[simp]: "fMin (finsert x A) = (if A = {||} then x else min x (fMin A))"
   by transfer simp
 
 context linorder begin
 
 lemma fset_linorder_max_induct[case_names fempty finsert]:
   assumes "P {||}"
   and     "\<And>x S. \<lbrakk>\<forall>y. y |\<in>| S \<longrightarrow> y < x; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
   shows "P S"
 proof -
   (* FIXME transfer and right_total vs. bi_total *)
   note Domainp_forall_transfer[transfer_rule]
   show ?thesis
   using assms by (transfer fixing: less) (auto intro: finite_linorder_max_induct)
 qed
 
 lemma fset_linorder_min_induct[case_names fempty finsert]:
   assumes "P {||}"
   and     "\<And>x S. \<lbrakk>\<forall>y. y |\<in>| S \<longrightarrow> y > x; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
   shows "P S"
 proof -
   (* FIXME transfer and right_total vs. bi_total *)
   note Domainp_forall_transfer[transfer_rule]
   show ?thesis
   using assms by (transfer fixing: less) (auto intro: finite_linorder_min_induct)
 qed
 
 end
 
 
 subsection \<open>Choice in fsets\<close>
 
 lemma fset_choice:
   assumes "\<forall>x. x |\<in>| A \<longrightarrow> (\<exists>y. P x y)"
   shows "\<exists>f. \<forall>x. x |\<in>| A \<longrightarrow> P x (f x)"
   using assms by transfer metis
 
 
 subsection \<open>Induction and Cases rules for fsets\<close>
 
 lemma fset_exhaust [case_names empty insert, cases type: fset]:
   assumes fempty_case: "S = {||} \<Longrightarrow> P"
   and     finsert_case: "\<And>x S'. S = finsert x S' \<Longrightarrow> P"
   shows "P"
   using assms by transfer blast
 
 lemma fset_induct [case_names empty insert]:
   assumes fempty_case: "P {||}"
   and     finsert_case: "\<And>x S. P S \<Longrightarrow> P (finsert x S)"
   shows "P S"
 proof -
   (* FIXME transfer and right_total vs. bi_total *)
   note Domainp_forall_transfer[transfer_rule]
   show ?thesis
   using assms by transfer (auto intro: finite_induct)
 qed
 
 lemma fset_induct_stronger [case_names empty insert, induct type: fset]:
   assumes empty_fset_case: "P {||}"
   and     insert_fset_case: "\<And>x S. \<lbrakk>x |\<notin>| S; P S\<rbrakk> \<Longrightarrow> P (finsert x S)"
   shows "P S"
 proof -
   (* FIXME transfer and right_total vs. bi_total *)
   note Domainp_forall_transfer[transfer_rule]
   show ?thesis
   using assms by transfer (auto intro: finite_induct)
 qed
 
 lemma fset_card_induct:
   assumes empty_fset_case: "P {||}"
   and     card_fset_Suc_case: "\<And>S T. Suc (fcard S) = (fcard T) \<Longrightarrow> P S \<Longrightarrow> P T"
   shows "P S"
 proof (induct S)
   case empty
   show "P {||}" by (rule empty_fset_case)
 next
   case (insert x S)
   have h: "P S" by fact
   have "x |\<notin>| S" by fact
   then have "Suc (fcard S) = fcard (finsert x S)"
     by transfer auto
   then show "P (finsert x S)"
     using h card_fset_Suc_case by simp
 qed
 
 lemma fset_strong_cases:
   obtains "xs = {||}"
     | ys x where "x |\<notin>| ys" and "xs = finsert x ys"
 by transfer blast
 
 lemma fset_induct2:
   "P {||} {||} \<Longrightarrow>
   (\<And>x xs. x |\<notin>| xs \<Longrightarrow> P (finsert x xs) {||}) \<Longrightarrow>
   (\<And>y ys. y |\<notin>| ys \<Longrightarrow> P {||} (finsert y ys)) \<Longrightarrow>
   (\<And>x xs y ys. \<lbrakk>P xs ys; x |\<notin>| xs; y |\<notin>| ys\<rbrakk> \<Longrightarrow> P (finsert x xs) (finsert y ys)) \<Longrightarrow>
   P xsa ysa"
   apply (induct xsa arbitrary: ysa)
   apply (induct_tac x rule: fset_induct_stronger)
   apply simp_all
   apply (induct_tac xa rule: fset_induct_stronger)
   apply simp_all
   done
 
 
 subsection \<open>Setup for Lifting/Transfer\<close>
 
 subsubsection \<open>Relator and predicator properties\<close>
 
 lift_definition rel_fset :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> bool" is rel_set
 parametric rel_set_transfer .
 
 lemma rel_fset_alt_def: "rel_fset R = (\<lambda>A B. (\<forall>x.\<exists>y. x|\<in>|A \<longrightarrow> y|\<in>|B \<and> R x y)
   \<and> (\<forall>y. \<exists>x. y|\<in>|B \<longrightarrow> x|\<in>|A \<and> R x y))"
 apply (rule ext)+
 apply transfer'
 apply (subst rel_set_def[unfolded fun_eq_iff])
 by blast
 
 lemma finite_rel_set:
   assumes fin: "finite X" "finite Z"
   assumes R_S: "rel_set (R OO S) X Z"
   shows "\<exists>Y. finite Y \<and> rel_set R X Y \<and> rel_set S Y Z"
 proof -
   obtain f where f: "\<forall>x\<in>X. R x (f x) \<and> (\<exists>z\<in>Z. S (f x) z)"
   apply atomize_elim
   apply (subst bchoice_iff[symmetric])
   using R_S[unfolded rel_set_def OO_def] by blast
 
   obtain g where g: "\<forall>z\<in>Z. S (g z) z \<and> (\<exists>x\<in>X. R x (g z))"
   apply atomize_elim
   apply (subst bchoice_iff[symmetric])
   using R_S[unfolded rel_set_def OO_def] by blast
 
   let ?Y = "f ` X \<union> g ` Z"
   have "finite ?Y" by (simp add: fin)
   moreover have "rel_set R X ?Y"
     unfolding rel_set_def
     using f g by clarsimp blast
   moreover have "rel_set S ?Y Z"
     unfolding rel_set_def
     using f g by clarsimp blast
   ultimately show ?thesis by metis
 qed
 
 subsubsection \<open>Transfer rules for the Transfer package\<close>
 
 text \<open>Unconditional transfer rules\<close>
 
 context includes lifting_syntax
 begin
 
 lemmas fempty_transfer [transfer_rule] = empty_transfer[Transfer.transferred]
 
 lemma finsert_transfer [transfer_rule]:
   "(A ===> rel_fset A ===> rel_fset A) finsert finsert"
   unfolding rel_fun_def rel_fset_alt_def by blast
 
 lemma funion_transfer [transfer_rule]:
   "(rel_fset A ===> rel_fset A ===> rel_fset A) funion funion"
   unfolding rel_fun_def rel_fset_alt_def by blast
 
 lemma ffUnion_transfer [transfer_rule]:
   "(rel_fset (rel_fset A) ===> rel_fset A) ffUnion ffUnion"
   unfolding rel_fun_def rel_fset_alt_def by transfer (simp, fast)
 
 lemma fimage_transfer [transfer_rule]:
   "((A ===> B) ===> rel_fset A ===> rel_fset B) fimage fimage"
   unfolding rel_fun_def rel_fset_alt_def by simp blast
 
 lemma fBall_transfer [transfer_rule]:
   "(rel_fset A ===> (A ===> (=)) ===> (=)) fBall fBall"
   unfolding rel_fset_alt_def rel_fun_def by blast
 
 lemma fBex_transfer [transfer_rule]:
   "(rel_fset A ===> (A ===> (=)) ===> (=)) fBex fBex"
   unfolding rel_fset_alt_def rel_fun_def by blast
 
 (* FIXME transfer doesn't work here *)
 lemma fPow_transfer [transfer_rule]:
   "(rel_fset A ===> rel_fset (rel_fset A)) fPow fPow"
   unfolding rel_fun_def
   using Pow_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred]
   by blast
 
 lemma rel_fset_transfer [transfer_rule]:
   "((A ===> B ===> (=)) ===> rel_fset A ===> rel_fset B ===> (=))
     rel_fset rel_fset"
   unfolding rel_fun_def
   using rel_set_transfer[unfolded rel_fun_def,rule_format, Transfer.transferred, where A = A and B = B]
   by simp
 
 lemma bind_transfer [transfer_rule]:
   "(rel_fset A ===> (A ===> rel_fset B) ===> rel_fset B) fbind fbind"
   unfolding rel_fun_def
   using bind_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast
 
 text \<open>Rules requiring bi-unique, bi-total or right-total relations\<close>
 
 lemma fmember_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(A ===> rel_fset A ===> (=)) (|\<in>|) (|\<in>|)"
   using assms unfolding rel_fun_def rel_fset_alt_def bi_unique_def by metis
 
 lemma finter_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(rel_fset A ===> rel_fset A ===> rel_fset A) finter finter"
   using assms unfolding rel_fun_def
   using inter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast
 
 lemma fminus_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(rel_fset A ===> rel_fset A ===> rel_fset A) (|-|) (|-|)"
   using assms unfolding rel_fun_def
   using Diff_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast
 
 lemma fsubset_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(rel_fset A ===> rel_fset A ===> (=)) (|\<subseteq>|) (|\<subseteq>|)"
   using assms unfolding rel_fun_def
   using subset_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast
 
 lemma fSup_transfer [transfer_rule]:
   "bi_unique A \<Longrightarrow> (rel_set (rel_fset A) ===> rel_fset A) Sup Sup"
   unfolding rel_fun_def
   apply clarify
   apply transfer'
   using Sup_fset_transfer[unfolded rel_fun_def] by blast
 
 (* FIXME: add right_total_fInf_transfer *)
 
 lemma fInf_transfer [transfer_rule]:
   assumes "bi_unique A" and "bi_total A"
   shows "(rel_set (rel_fset A) ===> rel_fset A) Inf Inf"
   using assms unfolding rel_fun_def
   apply clarify
   apply transfer'
   using Inf_fset_transfer[unfolded rel_fun_def] by blast
 
 lemma ffilter_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "((A ===> (=)) ===> rel_fset A ===> rel_fset A) ffilter ffilter"
   using assms unfolding rel_fun_def
   using Lifting_Set.filter_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast
 
 lemma card_transfer [transfer_rule]:
   "bi_unique A \<Longrightarrow> (rel_fset A ===> (=)) fcard fcard"
   unfolding rel_fun_def
   using card_transfer[unfolded rel_fun_def, rule_format, Transfer.transferred] by blast
 
 end
 
 lifting_update fset.lifting
 lifting_forget fset.lifting
 
 
 subsection \<open>BNF setup\<close>
 
 context
 includes fset.lifting
 begin
 
 lemma rel_fset_alt:
   "rel_fset R a b \<longleftrightarrow> (\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>t \<in> fset b. \<exists>u \<in> fset a. R u t)"
 by transfer (simp add: rel_set_def)
 
 lemma fset_to_fset: "finite A \<Longrightarrow> fset (the_inv fset A) = A"
 apply (rule f_the_inv_into_f[unfolded inj_on_def])
 apply (simp add: fset_inject)
 apply (rule range_eqI Abs_fset_inverse[symmetric] CollectI)+
 .
 
 lemma rel_fset_aux:
 "(\<forall>t \<in> fset a. \<exists>u \<in> fset b. R t u) \<and> (\<forall>u \<in> fset b. \<exists>t \<in> fset a. R t u) \<longleftrightarrow>
  ((BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage fst))\<inverse>\<inverse> OO
   BNF_Def.Grp {a. fset a \<subseteq> {(a, b). R a b}} (fimage snd)) a b" (is "?L = ?R")
 proof
   assume ?L
   define R' where "R' =
     the_inv fset (Collect (case_prod R) \<inter> (fset a \<times> fset b))" (is "_ = the_inv fset ?L'")
   have "finite ?L'" by (intro finite_Int[OF disjI2] finite_cartesian_product) (transfer, simp)+
   hence *: "fset R' = ?L'" unfolding R'_def by (intro fset_to_fset)
   show ?R unfolding Grp_def relcompp.simps conversep.simps
   proof (intro CollectI case_prodI exI[of _ a] exI[of _ b] exI[of _ R'] conjI refl)
     from * show "a = fimage fst R'" using conjunct1[OF \<open>?L\<close>]
       by (transfer, auto simp add: image_def Int_def split: prod.splits)
     from * show "b = fimage snd R'" using conjunct2[OF \<open>?L\<close>]
       by (transfer, auto simp add: image_def Int_def split: prod.splits)
   qed (auto simp add: *)
 next
   assume ?R thus ?L unfolding Grp_def relcompp.simps conversep.simps
   apply (simp add: subset_eq Ball_def)
   apply (rule conjI)
   apply (transfer, clarsimp, metis snd_conv)
   by (transfer, clarsimp, metis fst_conv)
 qed
 
 bnf "'a fset"
   map: fimage
   sets: fset
   bd: natLeq
   wits: "{||}"
   rel: rel_fset
 apply -
           apply transfer' apply simp
          apply transfer' apply force
         apply transfer apply force
        apply transfer' apply force
       apply (rule natLeq_card_order)
      apply (rule natLeq_cinfinite)
     apply transfer apply (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq)
    apply (fastforce simp: rel_fset_alt)
  apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff rel_fset_alt
    rel_fset_aux[unfolded OO_Grp_alt])
 apply transfer apply simp
 done
 
 lemma rel_fset_fset: "rel_set \<chi> (fset A1) (fset A2) = rel_fset \<chi> A1 A2"
   by transfer (rule refl)
 
 end
 
 lemmas [simp] = fset.map_comp fset.map_id fset.set_map
 
 
 subsection \<open>Size setup\<close>
 
 context includes fset.lifting begin
 lift_definition size_fset :: "('a \<Rightarrow> nat) \<Rightarrow> 'a fset \<Rightarrow> nat" is "\<lambda>f. sum (Suc \<circ> f)" .
 end
 
 instantiation fset :: (type) size begin
 definition size_fset where
   size_fset_overloaded_def: "size_fset = FSet.size_fset (\<lambda>_. 0)"
 instance ..
 end
 
 lemmas size_fset_simps[simp] =
   size_fset_def[THEN meta_eq_to_obj_eq, THEN fun_cong, THEN fun_cong,
     unfolded map_fun_def comp_def id_apply]
 
 lemmas size_fset_overloaded_simps[simp] =
   size_fset_simps[of "\<lambda>_. 0", unfolded add_0_left add_0_right,
     folded size_fset_overloaded_def]
 
 lemma fset_size_o_map: "inj f \<Longrightarrow> size_fset g \<circ> fimage f = size_fset (g \<circ> f)"
   apply (subst fun_eq_iff)
   including fset.lifting by transfer (auto intro: sum.reindex_cong subset_inj_on)
 
 setup \<open>
 BNF_LFP_Size.register_size_global \<^type_name>\<open>fset\<close> \<^const_name>\<open>size_fset\<close>
   @{thm size_fset_overloaded_def} @{thms size_fset_simps size_fset_overloaded_simps}
   @{thms fset_size_o_map}
 \<close>
 
 lifting_update fset.lifting
 lifting_forget fset.lifting
 
 subsection \<open>Advanced relator customization\<close>
 
 text \<open>Set vs. sum relators:\<close>
 
 lemma rel_set_rel_sum[simp]:
 "rel_set (rel_sum \<chi> \<phi>) A1 A2 \<longleftrightarrow>
  rel_set \<chi> (Inl -` A1) (Inl -` A2) \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
 (is "?L \<longleftrightarrow> ?Rl \<and> ?Rr")
 proof safe
   assume L: "?L"
   show ?Rl unfolding rel_set_def Bex_def vimage_eq proof safe
     fix l1 assume "Inl l1 \<in> A1"
     then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inl l1) a2"
     using L unfolding rel_set_def by auto
     then obtain l2 where "a2 = Inl l2 \<and> \<chi> l1 l2" by (cases a2, auto)
     thus "\<exists> l2. Inl l2 \<in> A2 \<and> \<chi> l1 l2" using a2 by auto
   next
     fix l2 assume "Inl l2 \<in> A2"
     then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inl l2)"
     using L unfolding rel_set_def by auto
     then obtain l1 where "a1 = Inl l1 \<and> \<chi> l1 l2" by (cases a1, auto)
     thus "\<exists> l1. Inl l1 \<in> A1 \<and> \<chi> l1 l2" using a1 by auto
   qed
   show ?Rr unfolding rel_set_def Bex_def vimage_eq proof safe
     fix r1 assume "Inr r1 \<in> A1"
     then obtain a2 where a2: "a2 \<in> A2" and "rel_sum \<chi> \<phi> (Inr r1) a2"
     using L unfolding rel_set_def by auto
     then obtain r2 where "a2 = Inr r2 \<and> \<phi> r1 r2" by (cases a2, auto)
     thus "\<exists> r2. Inr r2 \<in> A2 \<and> \<phi> r1 r2" using a2 by auto
   next
     fix r2 assume "Inr r2 \<in> A2"
     then obtain a1 where a1: "a1 \<in> A1" and "rel_sum \<chi> \<phi> a1 (Inr r2)"
     using L unfolding rel_set_def by auto
     then obtain r1 where "a1 = Inr r1 \<and> \<phi> r1 r2" by (cases a1, auto)
     thus "\<exists> r1. Inr r1 \<in> A1 \<and> \<phi> r1 r2" using a1 by auto
   qed
 next
   assume Rl: "?Rl" and Rr: "?Rr"
   show ?L unfolding rel_set_def Bex_def vimage_eq proof safe
     fix a1 assume a1: "a1 \<in> A1"
     show "\<exists> a2. a2 \<in> A2 \<and> rel_sum \<chi> \<phi> a1 a2"
     proof(cases a1)
       case (Inl l1) then obtain l2 where "Inl l2 \<in> A2 \<and> \<chi> l1 l2"
       using Rl a1 unfolding rel_set_def by blast
       thus ?thesis unfolding Inl by auto
     next
       case (Inr r1) then obtain r2 where "Inr r2 \<in> A2 \<and> \<phi> r1 r2"
       using Rr a1 unfolding rel_set_def by blast
       thus ?thesis unfolding Inr by auto
     qed
   next
     fix a2 assume a2: "a2 \<in> A2"
     show "\<exists> a1. a1 \<in> A1 \<and> rel_sum \<chi> \<phi> a1 a2"
     proof(cases a2)
       case (Inl l2) then obtain l1 where "Inl l1 \<in> A1 \<and> \<chi> l1 l2"
       using Rl a2 unfolding rel_set_def by blast
       thus ?thesis unfolding Inl by auto
     next
       case (Inr r2) then obtain r1 where "Inr r1 \<in> A1 \<and> \<phi> r1 r2"
       using Rr a2 unfolding rel_set_def by blast
       thus ?thesis unfolding Inr by auto
     qed
   qed
 qed
 
 
 subsubsection \<open>Countability\<close>
 
 lemma exists_fset_of_list: "\<exists>xs. fset_of_list xs = S"
 including fset.lifting
 by transfer (rule finite_list)
 
 lemma fset_of_list_surj[simp, intro]: "surj fset_of_list"
 proof -
   have "x \<in> range fset_of_list" for x :: "'a fset"
     unfolding image_iff
     using exists_fset_of_list by fastforce
   thus ?thesis by auto
 qed
 
 instance fset :: (countable) countable
 proof
   obtain to_nat :: "'a list \<Rightarrow> nat" where "inj to_nat"
     by (metis ex_inj)
   moreover have "inj (inv fset_of_list)"
     using fset_of_list_surj by (rule surj_imp_inj_inv)
   ultimately have "inj (to_nat \<circ> inv fset_of_list)"
     by (rule inj_compose)
   thus "\<exists>to_nat::'a fset \<Rightarrow> nat. inj to_nat"
     by auto
 qed
 
 
 subsection \<open>Quickcheck setup\<close>
 
 text \<open>Setup adapted from sets.\<close>
 
 notation Quickcheck_Exhaustive.orelse (infixr "orelse" 55)
 
 context
   includes term_syntax
 begin
 
 definition [code_unfold]:
 "valterm_femptyset = Code_Evaluation.valtermify ({||} :: ('a :: typerep) fset)"
 
 definition [code_unfold]:
 "valtermify_finsert x s = Code_Evaluation.valtermify finsert {\<cdot>} (x :: ('a :: typerep * _)) {\<cdot>} s"
 
 end
 
 instantiation fset :: (exhaustive) exhaustive
 begin
 
 fun exhaustive_fset where
 "exhaustive_fset f i = (if i = 0 then None else (f {||} orelse exhaustive_fset (\<lambda>A. f A orelse Quickcheck_Exhaustive.exhaustive (\<lambda>x. if x |\<in>| A then None else f (finsert x A)) (i - 1)) (i - 1)))"
 
 instance ..
 
 end
 
 instantiation fset :: (full_exhaustive) full_exhaustive
 begin
 
 fun full_exhaustive_fset where
 "full_exhaustive_fset f i = (if i = 0 then None else (f valterm_femptyset orelse full_exhaustive_fset (\<lambda>A. f A orelse Quickcheck_Exhaustive.full_exhaustive (\<lambda>x. if fst x |\<in>| fst A then None else f (valtermify_finsert x A)) (i - 1)) (i - 1)))"
 
 instance ..
 
 end
 
 no_notation Quickcheck_Exhaustive.orelse (infixr "orelse" 55)
 
 instantiation fset :: (random) random
 begin
 
 context
   includes state_combinator_syntax
 begin
 
 fun random_aux_fset :: "natural \<Rightarrow> natural \<Rightarrow> natural \<times> natural \<Rightarrow> ('a fset \<times> (unit \<Rightarrow> term)) \<times> natural \<times> natural" where
 "random_aux_fset 0 j = Quickcheck_Random.collapse (Random.select_weight [(1, Pair valterm_femptyset)])" |
 "random_aux_fset (Code_Numeral.Suc i) j =
   Quickcheck_Random.collapse (Random.select_weight
     [(1, Pair valterm_femptyset),
      (Code_Numeral.Suc i,
       Quickcheck_Random.random j \<circ>\<rightarrow> (\<lambda>x. random_aux_fset i j \<circ>\<rightarrow> (\<lambda>s. Pair (valtermify_finsert x s))))])"
 
 lemma [code]:
   "random_aux_fset i j =
     Quickcheck_Random.collapse (Random.select_weight [(1, Pair valterm_femptyset),
       (i, Quickcheck_Random.random j \<circ>\<rightarrow> (\<lambda>x. random_aux_fset (i - 1) j \<circ>\<rightarrow> (\<lambda>s. Pair (valtermify_finsert x s))))])"
 proof (induct i rule: natural.induct)
   case zero
   show ?case by (subst select_weight_drop_zero[symmetric]) (simp add: less_natural_def)
 next
   case (Suc i)
   show ?case by (simp only: random_aux_fset.simps Suc_natural_minus_one)
 qed
 
 definition "random_fset i = random_aux_fset i i"
 
 instance ..
 
 end
 
 end
 
 end
diff --git a/src/HOL/Library/Finite_Lattice.thy b/src/HOL/Library/Finite_Lattice.thy
--- a/src/HOL/Library/Finite_Lattice.thy
+++ b/src/HOL/Library/Finite_Lattice.thy
@@ -1,273 +1,294 @@
 (*  Title:      HOL/Library/Finite_Lattice.thy
     Author:     Alessandro Coglio
 *)
 
 theory Finite_Lattice
 imports Product_Order
 begin
 
 text \<open>A non-empty finite lattice is a complete lattice.
 Since types are never empty in Isabelle/HOL,
 a type of classes \<^class>\<open>finite\<close> and \<^class>\<open>lattice\<close>
 should also have class \<^class>\<open>complete_lattice\<close>.
 A type class is defined
 that extends classes \<^class>\<open>finite\<close> and \<^class>\<open>lattice\<close>
 with the operators \<^const>\<open>bot\<close>, \<^const>\<open>top\<close>, \<^const>\<open>Inf\<close>, and \<^const>\<open>Sup\<close>,
 along with assumptions that define these operators
 in terms of the ones of classes \<^class>\<open>finite\<close> and \<^class>\<open>lattice\<close>.
 The resulting class is a subclass of \<^class>\<open>complete_lattice\<close>.\<close>
 
 class finite_lattice_complete = finite + lattice + bot + top + Inf + Sup +
   assumes bot_def: "bot = Inf_fin UNIV"
   assumes top_def: "top = Sup_fin UNIV"
   assumes Inf_def: "Inf A = Finite_Set.fold inf top A"
   assumes Sup_def: "Sup A = Finite_Set.fold sup bot A"
 
 text \<open>The definitional assumptions
 on the operators \<^const>\<open>bot\<close> and \<^const>\<open>top\<close>
 of class \<^class>\<open>finite_lattice_complete\<close>
 ensure that they yield bottom and top.\<close>
 
 lemma finite_lattice_complete_bot_least: "(bot::'a::finite_lattice_complete) \<le> x"
   by (auto simp: bot_def intro: Inf_fin.coboundedI)
 
 instance finite_lattice_complete \<subseteq> order_bot
   by standard (auto simp: finite_lattice_complete_bot_least)
 
 lemma finite_lattice_complete_top_greatest: "(top::'a::finite_lattice_complete) \<ge> x"
   by (auto simp: top_def Sup_fin.coboundedI)
 
 instance finite_lattice_complete \<subseteq> order_top
   by standard (auto simp: finite_lattice_complete_top_greatest)
 
 instance finite_lattice_complete \<subseteq> bounded_lattice ..
 
 text \<open>The definitional assumptions
 on the operators \<^const>\<open>Inf\<close> and \<^const>\<open>Sup\<close>
 of class \<^class>\<open>finite_lattice_complete\<close>
 ensure that they yield infimum and supremum.\<close>
 
 lemma finite_lattice_complete_Inf_empty: "Inf {} = (top :: 'a::finite_lattice_complete)"
   by (simp add: Inf_def)
 
 lemma finite_lattice_complete_Sup_empty: "Sup {} = (bot :: 'a::finite_lattice_complete)"
   by (simp add: Sup_def)
 
 lemma finite_lattice_complete_Inf_insert:
   fixes A :: "'a::finite_lattice_complete set"
   shows "Inf (insert x A) = inf x (Inf A)"
 proof -
   interpret comp_fun_idem "inf :: 'a \<Rightarrow> _"
     by (fact comp_fun_idem_inf)
   show ?thesis by (simp add: Inf_def)
 qed
 
 lemma finite_lattice_complete_Sup_insert:
   fixes A :: "'a::finite_lattice_complete set"
   shows "Sup (insert x A) = sup x (Sup A)"
 proof -
   interpret comp_fun_idem "sup :: 'a \<Rightarrow> _"
     by (fact comp_fun_idem_sup)
   show ?thesis by (simp add: Sup_def)
 qed
 
 lemma finite_lattice_complete_Inf_lower:
   "(x::'a::finite_lattice_complete) \<in> A \<Longrightarrow> Inf A \<le> x"
   using finite [of A]
   by (induct A) (auto simp add: finite_lattice_complete_Inf_insert intro: le_infI2)
 
 lemma finite_lattice_complete_Inf_greatest:
   "\<forall>x::'a::finite_lattice_complete \<in> A. z \<le> x \<Longrightarrow> z \<le> Inf A"
   using finite [of A]
   by (induct A) (auto simp add: finite_lattice_complete_Inf_empty finite_lattice_complete_Inf_insert)
 
 lemma finite_lattice_complete_Sup_upper:
   "(x::'a::finite_lattice_complete) \<in> A \<Longrightarrow> Sup A \<ge> x"
   using finite [of A]
   by (induct A) (auto simp add: finite_lattice_complete_Sup_insert intro: le_supI2)
 
 lemma finite_lattice_complete_Sup_least:
   "\<forall>x::'a::finite_lattice_complete \<in> A. z \<ge> x \<Longrightarrow> z \<ge> Sup A"
   using finite [of A]
   by (induct A) (auto simp add: finite_lattice_complete_Sup_empty finite_lattice_complete_Sup_insert)
 
 instance finite_lattice_complete \<subseteq> complete_lattice
 proof
 qed (auto simp:
   finite_lattice_complete_Inf_lower
   finite_lattice_complete_Inf_greatest
   finite_lattice_complete_Sup_upper
   finite_lattice_complete_Sup_least
   finite_lattice_complete_Inf_empty
   finite_lattice_complete_Sup_empty)
 
 text \<open>The product of two finite lattices is already a finite lattice.\<close>
 
 lemma finite_bot_prod:
   "(bot :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete)) =
     Inf_fin UNIV"
   by (metis Inf_fin.coboundedI UNIV_I bot.extremum_uniqueI finite_UNIV)
 
 lemma finite_top_prod:
   "(top :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete)) =
     Sup_fin UNIV"
   by (metis Sup_fin.coboundedI UNIV_I top.extremum_uniqueI finite_UNIV)
 
 lemma finite_Inf_prod:
   "Inf(A :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete) set) =
     Finite_Set.fold inf top A"
   by (metis Inf_fold_inf finite)
 
 lemma finite_Sup_prod:
   "Sup (A :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete) set) =
     Finite_Set.fold sup bot A"
   by (metis Sup_fold_sup finite)
 
 instance prod :: (finite_lattice_complete, finite_lattice_complete) finite_lattice_complete
   by standard (auto simp: finite_bot_prod finite_top_prod finite_Inf_prod finite_Sup_prod)
 
 text \<open>Functions with a finite domain and with a finite lattice as codomain
 already form a finite lattice.\<close>
 
 lemma finite_bot_fun: "(bot :: ('a::finite \<Rightarrow> 'b::finite_lattice_complete)) = Inf_fin UNIV"
   by (metis Inf_UNIV Inf_fin_Inf empty_not_UNIV finite)
 
 lemma finite_top_fun: "(top :: ('a::finite \<Rightarrow> 'b::finite_lattice_complete)) = Sup_fin UNIV"
   by (metis Sup_UNIV Sup_fin_Sup empty_not_UNIV finite)
 
 lemma finite_Inf_fun:
   "Inf (A::('a::finite \<Rightarrow> 'b::finite_lattice_complete) set) =
     Finite_Set.fold inf top A"
   by (metis Inf_fold_inf finite)
 
 lemma finite_Sup_fun:
   "Sup (A::('a::finite \<Rightarrow> 'b::finite_lattice_complete) set) =
     Finite_Set.fold sup bot A"
   by (metis Sup_fold_sup finite)
 
 instance "fun" :: (finite, finite_lattice_complete) finite_lattice_complete
   by standard (auto simp: finite_bot_fun finite_top_fun finite_Inf_fun finite_Sup_fun)
 
 
 subsection \<open>Finite Distributive Lattices\<close>
 
 text \<open>A finite distributive lattice is a complete lattice
 whose \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close> operators
 distribute over \<^const>\<open>Sup\<close> and \<^const>\<open>Inf\<close>.\<close>
 
 class finite_distrib_lattice_complete =
   distrib_lattice + finite_lattice_complete
 
 lemma finite_distrib_lattice_complete_sup_Inf:
   "sup (x::'a::finite_distrib_lattice_complete) (Inf A) = (INF y\<in>A. sup x y)"
   using finite
   by (induct A rule: finite_induct) (simp_all add: sup_inf_distrib1)
 
 lemma finite_distrib_lattice_complete_inf_Sup:
   "inf (x::'a::finite_distrib_lattice_complete) (Sup A) = (SUP y\<in>A. inf x y)"
   using finite [of A] by induct (simp_all add: inf_sup_distrib1)
 
 context finite_distrib_lattice_complete
 begin
 subclass finite_distrib_lattice
-  apply standard
-  apply (simp_all add: Inf_def Sup_def bot_def top_def)
-       apply (metis (mono_tags) insert_UNIV local.Sup_fin.eq_fold local.bot_def local.finite_UNIV local.top_def) 
-      apply (simp add: comp_fun_idem.fold_insert_idem local.comp_fun_idem_inf) 
-     apply (metis (mono_tags) insert_UNIV local.Inf_fin.eq_fold local.finite_UNIV) 
-    apply (simp add: comp_fun_idem.fold_insert_idem local.comp_fun_idem_sup)
-  apply (metis (mono_tags) insert_UNIV local.Inf_fin.eq_fold local.finite_UNIV) 
-  apply (metis (mono_tags) insert_UNIV local.Sup_fin.eq_fold local.finite_UNIV)
-  done
+proof -
+  show "class.finite_distrib_lattice Inf Sup inf (\<le>) (<) sup bot top"
+  proof
+    show "bot = Inf UNIV"
+      unfolding bot_def top_def Inf_def
+      using Inf_fin.eq_fold Inf_fin.insert inf.absorb2 by force
+  next
+    show "top = Sup UNIV"
+      unfolding bot_def top_def Sup_def
+      using Sup_fin.eq_fold Sup_fin.insert by force
+  next
+    show "Inf {} = Sup UNIV"
+      unfolding Inf_def Sup_def bot_def top_def
+      using Sup_fin.eq_fold Sup_fin.insert by force
+  next
+    show "Sup {} = Inf UNIV"
+      unfolding Inf_def Sup_def bot_def top_def
+      using Inf_fin.eq_fold Inf_fin.insert inf.absorb2 by force
+  next
+    interpret comp_fun_idem_inf: comp_fun_idem inf
+      by (fact comp_fun_idem_inf)
+    show "Inf (insert a A) = inf a (Inf A)" for a A
+      using comp_fun_idem_inf.fold_insert_idem Inf_def finite by simp
+  next
+    interpret comp_fun_idem_sup: comp_fun_idem sup
+      by (fact comp_fun_idem_sup)
+    show "Sup (insert a A) = sup a (Sup A)" for a A
+      using comp_fun_idem_sup.fold_insert_idem Sup_def finite by simp
+  qed
+qed
 end
 
 instance finite_distrib_lattice_complete \<subseteq> complete_distrib_lattice ..
 
 text \<open>The product of two finite distributive lattices
 is already a finite distributive lattice.\<close>
 
 instance prod ::
   (finite_distrib_lattice_complete, finite_distrib_lattice_complete)
   finite_distrib_lattice_complete
   ..
 
 text \<open>Functions with a finite domain
 and with a finite distributive lattice as codomain
 already form a finite distributive lattice.\<close>
 
 instance "fun" ::
   (finite, finite_distrib_lattice_complete) finite_distrib_lattice_complete
   ..
 
 subsection \<open>Linear Orders\<close>
 
 text \<open>A linear order is a distributive lattice.
 A type class is defined
 that extends class \<^class>\<open>linorder\<close>
 with the operators \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close>,
 along with assumptions that define these operators
 in terms of the ones of class \<^class>\<open>linorder\<close>.
 The resulting class is a subclass of \<^class>\<open>distrib_lattice\<close>.\<close>
 
 class linorder_lattice = linorder + inf + sup +
   assumes inf_def: "inf x y = (if x \<le> y then x else y)"
   assumes sup_def: "sup x y = (if x \<ge> y then x else y)"
 
 text \<open>The definitional assumptions
 on the operators \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close>
 of class \<^class>\<open>linorder_lattice\<close>
 ensure that they yield infimum and supremum
 and that they distribute over each other.\<close>
 
 lemma linorder_lattice_inf_le1: "inf (x::'a::linorder_lattice) y \<le> x"
   unfolding inf_def by (metis (full_types) linorder_linear)
 
 lemma linorder_lattice_inf_le2: "inf (x::'a::linorder_lattice) y \<le> y"
   unfolding inf_def by (metis (full_types) linorder_linear)
 
 lemma linorder_lattice_inf_greatest:
   "(x::'a::linorder_lattice) \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> inf y z"
   unfolding inf_def by (metis (full_types))
 
 lemma linorder_lattice_sup_ge1: "sup (x::'a::linorder_lattice) y \<ge> x"
   unfolding sup_def by (metis (full_types) linorder_linear)
 
 lemma linorder_lattice_sup_ge2: "sup (x::'a::linorder_lattice) y \<ge> y"
   unfolding sup_def by (metis (full_types) linorder_linear)
 
 lemma linorder_lattice_sup_least:
   "(x::'a::linorder_lattice) \<ge> y \<Longrightarrow> x \<ge> z \<Longrightarrow> x \<ge> sup y z"
   by (auto simp: sup_def)
 
 lemma linorder_lattice_sup_inf_distrib1:
   "sup (x::'a::linorder_lattice) (inf y z) = inf (sup x y) (sup x z)"
   by (auto simp: inf_def sup_def)
 
 instance linorder_lattice \<subseteq> distrib_lattice
 proof
 qed (auto simp:
   linorder_lattice_inf_le1
   linorder_lattice_inf_le2
   linorder_lattice_inf_greatest
   linorder_lattice_sup_ge1
   linorder_lattice_sup_ge2
   linorder_lattice_sup_least
   linorder_lattice_sup_inf_distrib1)
 
 
 subsection \<open>Finite Linear Orders\<close>
 
 text \<open>A (non-empty) finite linear order is a complete linear order.\<close>
 
 class finite_linorder_complete = linorder_lattice + finite_lattice_complete
 
 instance finite_linorder_complete \<subseteq> complete_linorder ..
 
 text \<open>A (non-empty) finite linear order is a complete lattice
 whose \<^const>\<open>inf\<close> and \<^const>\<open>sup\<close> operators
 distribute over \<^const>\<open>Sup\<close> and \<^const>\<open>Inf\<close>.\<close>
 
 instance finite_linorder_complete \<subseteq> finite_distrib_lattice_complete ..
 
 end
 
diff --git a/src/HOL/Library/Mapping.thy b/src/HOL/Library/Mapping.thy
--- a/src/HOL/Library/Mapping.thy
+++ b/src/HOL/Library/Mapping.thy
@@ -1,656 +1,934 @@
 (*  Title:      HOL/Library/Mapping.thy
     Author:     Florian Haftmann and Ondrej Kuncar
 *)
 
 section \<open>An abstract view on maps for code generation.\<close>
 
 theory Mapping
-imports Main
+imports Main AList
 begin
 
 subsection \<open>Parametricity transfer rules\<close>
 
 lemma map_of_foldr: "map_of xs = foldr (\<lambda>(k, v) m. m(k \<mapsto> v)) xs Map.empty"  (* FIXME move *)
   using map_add_map_of_foldr [of Map.empty] by auto
 
 context includes lifting_syntax
 begin
 
 lemma empty_parametric: "(A ===> rel_option B) Map.empty Map.empty"
   by transfer_prover
 
 lemma lookup_parametric: "((A ===> B) ===> A ===> B) (\<lambda>m k. m k) (\<lambda>m k. m k)"
   by transfer_prover
 
 lemma update_parametric:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> B ===> (A ===> rel_option B) ===> A ===> rel_option B)
     (\<lambda>k v m. m(k \<mapsto> v)) (\<lambda>k v m. m(k \<mapsto> v))"
   by transfer_prover
 
 lemma delete_parametric:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> (A ===> rel_option B) ===> A ===> rel_option B)
     (\<lambda>k m. m(k := None)) (\<lambda>k m. m(k := None))"
   by transfer_prover
 
 lemma is_none_parametric [transfer_rule]:
   "(rel_option A ===> HOL.eq) Option.is_none Option.is_none"
   by (auto simp add: Option.is_none_def rel_fun_def rel_option_iff split: option.split)
 
 lemma dom_parametric:
   assumes [transfer_rule]: "bi_total A"
   shows "((A ===> rel_option B) ===> rel_set A) dom dom"
   unfolding dom_def [abs_def] Option.is_none_def [symmetric] by transfer_prover
 
+lemma graph_parametric:
+  assumes "bi_total A"
+  shows "((A ===> rel_option B) ===> rel_set (rel_prod A B)) Map.graph Map.graph"
+proof
+  fix f g assume "(A ===> rel_option B) f g"
+  with assms[unfolded bi_total_def] show "rel_set (rel_prod A B) (Map.graph f) (Map.graph g)"
+    unfolding graph_def rel_set_def rel_fun_def
+    by auto (metis option_rel_Some1 option_rel_Some2)+
+qed
+
 lemma map_of_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_unique R1"
   shows "(list_all2 (rel_prod R1 R2) ===> R1 ===> rel_option R2) map_of map_of"
   unfolding map_of_def by transfer_prover
 
 lemma map_entry_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> (B ===> B) ===> (A ===> rel_option B) ===> A ===> rel_option B)
     (\<lambda>k f m. (case m k of None \<Rightarrow> m
       | Some v \<Rightarrow> m (k \<mapsto> (f v)))) (\<lambda>k f m. (case m k of None \<Rightarrow> m
       | Some v \<Rightarrow> m (k \<mapsto> (f v))))"
   by transfer_prover
 
 lemma tabulate_parametric:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> (A ===> B) ===> A ===> rel_option B)
     (\<lambda>ks f. (map_of (map (\<lambda>k. (k, f k)) ks))) (\<lambda>ks f. (map_of (map (\<lambda>k. (k, f k)) ks)))"
   by transfer_prover
 
 lemma bulkload_parametric:
   "(list_all2 A ===> HOL.eq ===> rel_option A)
     (\<lambda>xs k. if k < length xs then Some (xs ! k) else None)
     (\<lambda>xs k. if k < length xs then Some (xs ! k) else None)"
 proof
   fix xs ys
   assume "list_all2 A xs ys"
   then show
     "(HOL.eq ===> rel_option A)
       (\<lambda>k. if k < length xs then Some (xs ! k) else None)
       (\<lambda>k. if k < length ys then Some (ys ! k) else None)"
     apply induct
      apply auto
     unfolding rel_fun_def
     apply clarsimp
     apply (case_tac xa)
      apply (auto dest: list_all2_lengthD list_all2_nthD)
     done
 qed
 
 lemma map_parametric:
   "((A ===> B) ===> (C ===> D) ===> (B ===> rel_option C) ===> A ===> rel_option D)
      (\<lambda>f g m. (map_option g \<circ> m \<circ> f)) (\<lambda>f g m. (map_option g \<circ> m \<circ> f))"
   by transfer_prover
 
 lemma combine_with_key_parametric:
   "((A ===> B ===> B ===> B) ===> (A ===> rel_option B) ===> (A ===> rel_option B) ===>
     (A ===> rel_option B)) (\<lambda>f m1 m2 x. combine_options (f x) (m1 x) (m2 x))
     (\<lambda>f m1 m2 x. combine_options (f x) (m1 x) (m2 x))"
   unfolding combine_options_def by transfer_prover
 
 lemma combine_parametric:
   "((B ===> B ===> B) ===> (A ===> rel_option B) ===> (A ===> rel_option B) ===>
     (A ===> rel_option B)) (\<lambda>f m1 m2 x. combine_options f (m1 x) (m2 x))
     (\<lambda>f m1 m2 x. combine_options f (m1 x) (m2 x))"
   unfolding combine_options_def by transfer_prover
 
 end
 
 
 subsection \<open>Type definition and primitive operations\<close>
 
 typedef ('a, 'b) mapping = "UNIV :: ('a \<rightharpoonup> 'b) set"
   morphisms rep Mapping ..
 
 setup_lifting type_definition_mapping
 
 lift_definition empty :: "('a, 'b) mapping"
   is Map.empty parametric empty_parametric .
 
 lift_definition lookup :: "('a, 'b) mapping \<Rightarrow> 'a \<Rightarrow> 'b option"
   is "\<lambda>m k. m k" parametric lookup_parametric .
 
 definition "lookup_default d m k = (case Mapping.lookup m k of None \<Rightarrow> d | Some v \<Rightarrow> v)"
 
 lift_definition update :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
   is "\<lambda>k v m. m(k \<mapsto> v)" parametric update_parametric .
 
 lift_definition delete :: "'a \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
   is "\<lambda>k m. m(k := None)" parametric delete_parametric .
 
 lift_definition filter :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
   is "\<lambda>P m k. case m k of None \<Rightarrow> None | Some v \<Rightarrow> if P k v then Some v else None" .
 
 lift_definition keys :: "('a, 'b) mapping \<Rightarrow> 'a set"
   is dom parametric dom_parametric .
 
+lift_definition entries :: "('a, 'b) mapping \<Rightarrow> ('a \<times> 'b) set"
+  is Map.graph parametric graph_parametric .
+
 lift_definition tabulate :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping"
   is "\<lambda>ks f. (map_of (List.map (\<lambda>k. (k, f k)) ks))" parametric tabulate_parametric .
 
 lift_definition bulkload :: "'a list \<Rightarrow> (nat, 'a) mapping"
   is "\<lambda>xs k. if k < length xs then Some (xs ! k) else None" parametric bulkload_parametric .
 
 lift_definition map :: "('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('c, 'd) mapping"
   is "\<lambda>f g m. (map_option g \<circ> m \<circ> f)" parametric map_parametric .
 
 lift_definition map_values :: "('c \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('c, 'a) mapping \<Rightarrow> ('c, 'b) mapping"
   is "\<lambda>f m x. map_option (f x) (m x)" .
 
 lift_definition combine_with_key ::
   "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping"
   is "\<lambda>f m1 m2 x. combine_options (f x) (m1 x) (m2 x)" parametric combine_with_key_parametric .
 
 lift_definition combine ::
   "('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping \<Rightarrow> ('a,'b) mapping"
   is "\<lambda>f m1 m2 x. combine_options f (m1 x) (m2 x)" parametric combine_parametric .
 
 definition "All_mapping m P \<longleftrightarrow>
   (\<forall>x. case Mapping.lookup m x of None \<Rightarrow> True | Some y \<Rightarrow> P x y)"
 
 declare [[code drop: map]]
 
 
 subsection \<open>Functorial structure\<close>
 
 functor map: map
   by (transfer, auto simp add: fun_eq_iff option.map_comp option.map_id)+
 
 
 subsection \<open>Derived operations\<close>
 
 definition ordered_keys :: "('a::linorder, 'b) mapping \<Rightarrow> 'a list"
   where "ordered_keys m = (if finite (keys m) then sorted_list_of_set (keys m) else [])"
 
+definition ordered_entries :: "('a::linorder, 'b) mapping \<Rightarrow> ('a \<times> 'b) list"
+  where "ordered_entries m = (if finite (entries m) then sorted_key_list_of_set fst (entries m)
+                                                    else [])"
+
+definition fold :: "('a::linorder \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> 'c \<Rightarrow> 'c"
+  where "fold f m a = List.fold (case_prod f) (ordered_entries m) a"
+
 definition is_empty :: "('a, 'b) mapping \<Rightarrow> bool"
   where "is_empty m \<longleftrightarrow> keys m = {}"
 
 definition size :: "('a, 'b) mapping \<Rightarrow> nat"
   where "size m = (if finite (keys m) then card (keys m) else 0)"
 
 definition replace :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
   where "replace k v m = (if k \<in> keys m then update k v m else m)"
 
 definition default :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
   where "default k v m = (if k \<in> keys m then m else update k v m)"
 
 text \<open>Manual derivation of transfer rule is non-trivial\<close>
 
 lift_definition map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping" is
   "\<lambda>k f m.
     (case m k of
       None \<Rightarrow> m
     | Some v \<Rightarrow> m (k \<mapsto> (f v)))" parametric map_entry_parametric .
 
 lemma map_entry_code [code]:
   "map_entry k f m =
     (case lookup m k of
       None \<Rightarrow> m
     | Some v \<Rightarrow> update k (f v) m)"
   by transfer rule
 
 definition map_default :: "'a \<Rightarrow> 'b \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping \<Rightarrow> ('a, 'b) mapping"
   where "map_default k v f m = map_entry k f (default k v m)"
 
 definition of_alist :: "('k \<times> 'v) list \<Rightarrow> ('k, 'v) mapping"
   where "of_alist xs = foldr (\<lambda>(k, v) m. update k v m) xs empty"
 
 instantiation mapping :: (type, type) equal
 begin
 
 definition "HOL.equal m1 m2 \<longleftrightarrow> (\<forall>k. lookup m1 k = lookup m2 k)"
 
 instance
   apply standard
   unfolding equal_mapping_def
   apply transfer
   apply auto
   done
 
 end
 
 context includes lifting_syntax
 begin
 
 lemma [transfer_rule]:
   assumes [transfer_rule]: "bi_total A"
     and [transfer_rule]: "bi_unique B"
   shows "(pcr_mapping A B ===> pcr_mapping A B ===> (=)) HOL.eq HOL.equal"
   unfolding equal by transfer_prover
 
 lemma of_alist_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique R1"
   shows "(list_all2 (rel_prod R1 R2) ===> pcr_mapping R1 R2) map_of of_alist"
   unfolding of_alist_def [abs_def] map_of_foldr [abs_def] by transfer_prover
 
 end
 
 
 subsection \<open>Properties\<close>
 
 lemma mapping_eqI: "(\<And>x. lookup m x = lookup m' x) \<Longrightarrow> m = m'"
   by transfer (simp add: fun_eq_iff)
 
 lemma mapping_eqI':
   assumes "\<And>x. x \<in> Mapping.keys m \<Longrightarrow> Mapping.lookup_default d m x = Mapping.lookup_default d m' x"
     and "Mapping.keys m = Mapping.keys m'"
   shows "m = m'"
 proof (intro mapping_eqI)
   show "Mapping.lookup m x = Mapping.lookup m' x" for x
   proof (cases "Mapping.lookup m x")
     case None
     then have "x \<notin> Mapping.keys m"
       by transfer (simp add: dom_def)
     then have "x \<notin> Mapping.keys m'"
       by (simp add: assms)
     then have "Mapping.lookup m' x = None"
       by transfer (simp add: dom_def)
     with None show ?thesis
       by simp
   next
     case (Some y)
     then have A: "x \<in> Mapping.keys m"
       by transfer (simp add: dom_def)
     then have "x \<in> Mapping.keys m'"
       by (simp add: assms)
     then have "\<exists>y'. Mapping.lookup m' x = Some y'"
       by transfer (simp add: dom_def)
     with Some assms(1)[OF A] show ?thesis
       by (auto simp add: lookup_default_def)
   qed
 qed
 
 lemma lookup_update: "lookup (update k v m) k = Some v"
   by transfer simp
 
 lemma lookup_update_neq: "k \<noteq> k' \<Longrightarrow> lookup (update k v m) k' = lookup m k'"
   by transfer simp
 
 lemma lookup_update': "Mapping.lookup (update k v m) k' = (if k = k' then Some v else lookup m k')"
   by (auto simp: lookup_update lookup_update_neq)
 
 lemma lookup_empty: "lookup empty k = None"
   by transfer simp
 
 lemma lookup_filter:
   "lookup (filter P m) k =
     (case lookup m k of
       None \<Rightarrow> None
     | Some v \<Rightarrow> if P k v then Some v else None)"
   by transfer simp_all
 
 lemma lookup_map_values: "lookup (map_values f m) k = map_option (f k) (lookup m k)"
   by transfer simp_all
 
 lemma lookup_default_empty: "lookup_default d empty k = d"
   by (simp add: lookup_default_def lookup_empty)
 
 lemma lookup_default_update: "lookup_default d (update k v m) k = v"
   by (simp add: lookup_default_def lookup_update)
 
 lemma lookup_default_update_neq:
   "k \<noteq> k' \<Longrightarrow> lookup_default d (update k v m) k' = lookup_default d m k'"
   by (simp add: lookup_default_def lookup_update_neq)
 
 lemma lookup_default_update':
   "lookup_default d (update k v m) k' = (if k = k' then v else lookup_default d m k')"
   by (auto simp: lookup_default_update lookup_default_update_neq)
 
 lemma lookup_default_filter:
   "lookup_default d (filter P m) k =
      (if P k (lookup_default d m k) then lookup_default d m k else d)"
   by (simp add: lookup_default_def lookup_filter split: option.splits)
 
 lemma lookup_default_map_values:
   "lookup_default (f k d) (map_values f m) k = f k (lookup_default d m k)"
   by (simp add: lookup_default_def lookup_map_values split: option.splits)
 
 lemma lookup_combine_with_key:
   "Mapping.lookup (combine_with_key f m1 m2) x =
     combine_options (f x) (Mapping.lookup m1 x) (Mapping.lookup m2 x)"
   by transfer (auto split: option.splits)
 
 lemma combine_altdef: "combine f m1 m2 = combine_with_key (\<lambda>_. f) m1 m2"
   by transfer' (rule refl)
 
 lemma lookup_combine:
   "Mapping.lookup (combine f m1 m2) x =
      combine_options f (Mapping.lookup m1 x) (Mapping.lookup m2 x)"
   by transfer (auto split: option.splits)
 
 lemma lookup_default_neutral_combine_with_key:
   assumes "\<And>x. f k d x = x" "\<And>x. f k x d = x"
   shows "Mapping.lookup_default d (combine_with_key f m1 m2) k =
     f k (Mapping.lookup_default d m1 k) (Mapping.lookup_default d m2 k)"
   by (auto simp: lookup_default_def lookup_combine_with_key assms split: option.splits)
 
 lemma lookup_default_neutral_combine:
   assumes "\<And>x. f d x = x" "\<And>x. f x d = x"
   shows "Mapping.lookup_default d (combine f m1 m2) x =
     f (Mapping.lookup_default d m1 x) (Mapping.lookup_default d m2 x)"
   by (auto simp: lookup_default_def lookup_combine assms split: option.splits)
 
 lemma lookup_map_entry: "lookup (map_entry x f m) x = map_option f (lookup m x)"
   by transfer (auto split: option.splits)
 
 lemma lookup_map_entry_neq: "x \<noteq> y \<Longrightarrow> lookup (map_entry x f m) y = lookup m y"
   by transfer (auto split: option.splits)
 
 lemma lookup_map_entry':
   "lookup (map_entry x f m) y =
      (if x = y then map_option f (lookup m y) else lookup m y)"
   by transfer (auto split: option.splits)
 
 lemma lookup_default: "lookup (default x d m) x = Some (lookup_default d m x)"
   unfolding lookup_default_def default_def
   by transfer (auto split: option.splits)
 
 lemma lookup_default_neq: "x \<noteq> y \<Longrightarrow> lookup (default x d m) y = lookup m y"
   unfolding lookup_default_def default_def
   by transfer (auto split: option.splits)
 
 lemma lookup_default':
   "lookup (default x d m) y =
     (if x = y then Some (lookup_default d m x) else lookup m y)"
   unfolding lookup_default_def default_def
   by transfer (auto split: option.splits)
 
 lemma lookup_map_default: "lookup (map_default x d f m) x = Some (f (lookup_default d m x))"
   unfolding lookup_default_def default_def
   by (simp add: map_default_def lookup_map_entry lookup_default lookup_default_def)
 
 lemma lookup_map_default_neq: "x \<noteq> y \<Longrightarrow> lookup (map_default x d f m) y = lookup m y"
   unfolding lookup_default_def default_def
   by (simp add: map_default_def lookup_map_entry_neq lookup_default_neq)
 
 lemma lookup_map_default':
   "lookup (map_default x d f m) y =
     (if x = y then Some (f (lookup_default d m x)) else lookup m y)"
   unfolding lookup_default_def default_def
   by (simp add: map_default_def lookup_map_entry' lookup_default' lookup_default_def)
 
 lemma lookup_tabulate:
   assumes "distinct xs"
   shows "Mapping.lookup (Mapping.tabulate xs f) x = (if x \<in> set xs then Some (f x) else None)"
   using assms by transfer (auto simp: map_of_eq_None_iff o_def dest!: map_of_SomeD)
 
 lemma lookup_of_alist: "Mapping.lookup (Mapping.of_alist xs) k = map_of xs k"
   by transfer simp_all
 
 lemma keys_is_none_rep [code_unfold]: "k \<in> keys m \<longleftrightarrow> \<not> (Option.is_none (lookup m k))"
   by transfer (auto simp add: Option.is_none_def)
 
 lemma update_update:
   "update k v (update k w m) = update k v m"
   "k \<noteq> l \<Longrightarrow> update k v (update l w m) = update l w (update k v m)"
   by (transfer; simp add: fun_upd_twist)+
 
 lemma update_delete [simp]: "update k v (delete k m) = update k v m"
   by transfer simp
 
 lemma delete_update:
   "delete k (update k v m) = delete k m"
   "k \<noteq> l \<Longrightarrow> delete k (update l v m) = update l v (delete k m)"
   by (transfer; simp add: fun_upd_twist)+
 
 lemma delete_empty [simp]: "delete k empty = empty"
   by transfer simp
 
 lemma replace_update:
   "k \<notin> keys m \<Longrightarrow> replace k v m = m"
   "k \<in> keys m \<Longrightarrow> replace k v m = update k v m"
   by (transfer; auto simp add: replace_def fun_upd_twist)+
 
 lemma map_values_update: "map_values f (update k v m) = update k (f k v) (map_values f m)"
   by transfer (simp_all add: fun_eq_iff)
 
 lemma size_mono: "finite (keys m') \<Longrightarrow> keys m \<subseteq> keys m' \<Longrightarrow> size m \<le> size m'"
   unfolding size_def by (auto intro: card_mono)
 
 lemma size_empty [simp]: "size empty = 0"
   unfolding size_def by transfer simp
 
 lemma size_update:
   "finite (keys m) \<Longrightarrow> size (update k v m) =
     (if k \<in> keys m then size m else Suc (size m))"
   unfolding size_def by transfer (auto simp add: insert_dom)
 
 lemma size_delete: "size (delete k m) = (if k \<in> keys m then size m - 1 else size m)"
   unfolding size_def by transfer simp
 
 lemma size_tabulate [simp]: "size (tabulate ks f) = length (remdups ks)"
   unfolding size_def by transfer (auto simp add: map_of_map_restrict card_set comp_def)
 
 lemma keys_filter: "keys (filter P m) \<subseteq> keys m"
   by transfer (auto split: option.splits)
 
 lemma size_filter: "finite (keys m) \<Longrightarrow> size (filter P m) \<le> size m"
   by (intro size_mono keys_filter)
 
 lemma bulkload_tabulate: "bulkload xs = tabulate [0..<length xs] (nth xs)"
   by transfer (auto simp add: map_of_map_restrict)
 
 lemma is_empty_empty [simp]: "is_empty empty"
   unfolding is_empty_def by transfer simp
 
 lemma is_empty_update [simp]: "\<not> is_empty (update k v m)"
   unfolding is_empty_def by transfer simp
 
 lemma is_empty_delete: "is_empty (delete k m) \<longleftrightarrow> is_empty m \<or> keys m = {k}"
   unfolding is_empty_def by transfer (auto simp del: dom_eq_empty_conv)
 
 lemma is_empty_replace [simp]: "is_empty (replace k v m) \<longleftrightarrow> is_empty m"
   unfolding is_empty_def replace_def by transfer auto
 
 lemma is_empty_default [simp]: "\<not> is_empty (default k v m)"
   unfolding is_empty_def default_def by transfer auto
 
 lemma is_empty_map_entry [simp]: "is_empty (map_entry k f m) \<longleftrightarrow> is_empty m"
   unfolding is_empty_def by transfer (auto split: option.split)
 
 lemma is_empty_map_values [simp]: "is_empty (map_values f m) \<longleftrightarrow> is_empty m"
   unfolding is_empty_def by transfer (auto simp: fun_eq_iff)
 
 lemma is_empty_map_default [simp]: "\<not> is_empty (map_default k v f m)"
   by (simp add: map_default_def)
 
 lemma keys_dom_lookup: "keys m = dom (Mapping.lookup m)"
   by transfer rule
 
 lemma keys_empty [simp]: "keys empty = {}"
-  by transfer simp
+  by transfer (fact dom_empty)
+
+lemma in_keysD: "k \<in> keys m \<Longrightarrow> \<exists>v. lookup m k = Some v"
+  by transfer (fact domD)
+
+lemma in_entriesI: "lookup m k = Some v \<Longrightarrow> (k, v) \<in> entries m"
+  by transfer (fact in_graphI)
 
 lemma keys_update [simp]: "keys (update k v m) = insert k (keys m)"
   by transfer simp
 
 lemma keys_delete [simp]: "keys (delete k m) = keys m - {k}"
   by transfer simp
 
 lemma keys_replace [simp]: "keys (replace k v m) = keys m"
   unfolding replace_def by transfer (simp add: insert_absorb)
 
 lemma keys_default [simp]: "keys (default k v m) = insert k (keys m)"
   unfolding default_def by transfer (simp add: insert_absorb)
 
 lemma keys_map_entry [simp]: "keys (map_entry k f m) = keys m"
   by transfer (auto split: option.split)
 
 lemma keys_map_default [simp]: "keys (map_default k v f m) = insert k (keys m)"
   by (simp add: map_default_def)
 
 lemma keys_map_values [simp]: "keys (map_values f m) = keys m"
   by transfer (simp_all add: dom_def)
 
 lemma keys_combine_with_key [simp]:
   "Mapping.keys (combine_with_key f m1 m2) = Mapping.keys m1 \<union> Mapping.keys m2"
   by transfer (auto simp: dom_def combine_options_def split: option.splits)
 
 lemma keys_combine [simp]: "Mapping.keys (combine f m1 m2) = Mapping.keys m1 \<union> Mapping.keys m2"
   by (simp add: combine_altdef)
 
 lemma keys_tabulate [simp]: "keys (tabulate ks f) = set ks"
   by transfer (simp add: map_of_map_restrict o_def)
 
 lemma keys_of_alist [simp]: "keys (of_alist xs) = set (List.map fst xs)"
   by transfer (simp_all add: dom_map_of_conv_image_fst)
 
 lemma keys_bulkload [simp]: "keys (bulkload xs) = {0..<length xs}"
   by (simp add: bulkload_tabulate)
 
 lemma distinct_ordered_keys [simp]: "distinct (ordered_keys m)"
   by (simp add: ordered_keys_def)
 
 lemma ordered_keys_infinite [simp]: "\<not> finite (keys m) \<Longrightarrow> ordered_keys m = []"
   by (simp add: ordered_keys_def)
 
 lemma ordered_keys_empty [simp]: "ordered_keys empty = []"
   by (simp add: ordered_keys_def)
 
 lemma ordered_keys_update [simp]:
   "k \<in> keys m \<Longrightarrow> ordered_keys (update k v m) = ordered_keys m"
   "finite (keys m) \<Longrightarrow> k \<notin> keys m \<Longrightarrow>
     ordered_keys (update k v m) = insort k (ordered_keys m)"
   by (simp_all add: ordered_keys_def)
-    (auto simp only: sorted_list_of_set_insert [symmetric] insert_absorb)
+     (auto simp only: sorted_list_of_set_insert_remove[symmetric] insert_absorb)
 
 lemma ordered_keys_delete [simp]: "ordered_keys (delete k m) = remove1 k (ordered_keys m)"
 proof (cases "finite (keys m)")
   case False
   then show ?thesis by simp
 next
   case fin: True
   show ?thesis
   proof (cases "k \<in> keys m")
     case False
     with fin have "k \<notin> set (sorted_list_of_set (keys m))"
       by simp
     with False show ?thesis
       by (simp add: ordered_keys_def remove1_idem)
   next
     case True
     with fin show ?thesis
       by (simp add: ordered_keys_def sorted_list_of_set_remove)
   qed
 qed
 
 lemma ordered_keys_replace [simp]: "ordered_keys (replace k v m) = ordered_keys m"
   by (simp add: replace_def)
 
 lemma ordered_keys_default [simp]:
   "k \<in> keys m \<Longrightarrow> ordered_keys (default k v m) = ordered_keys m"
   "finite (keys m) \<Longrightarrow> k \<notin> keys m \<Longrightarrow> ordered_keys (default k v m) = insort k (ordered_keys m)"
   by (simp_all add: default_def)
 
 lemma ordered_keys_map_entry [simp]: "ordered_keys (map_entry k f m) = ordered_keys m"
   by (simp add: ordered_keys_def)
 
 lemma ordered_keys_map_default [simp]:
   "k \<in> keys m \<Longrightarrow> ordered_keys (map_default k v f m) = ordered_keys m"
   "finite (keys m) \<Longrightarrow> k \<notin> keys m \<Longrightarrow> ordered_keys (map_default k v f m) = insort k (ordered_keys m)"
   by (simp_all add: map_default_def)
 
 lemma ordered_keys_tabulate [simp]: "ordered_keys (tabulate ks f) = sort (remdups ks)"
   by (simp add: ordered_keys_def sorted_list_of_set_sort_remdups)
 
 lemma ordered_keys_bulkload [simp]: "ordered_keys (bulkload ks) = [0..<length ks]"
   by (simp add: ordered_keys_def)
 
-lemma tabulate_fold: "tabulate xs f = fold (\<lambda>k m. update k (f k) m) xs empty"
+lemma tabulate_fold: "tabulate xs f = List.fold (\<lambda>k m. update k (f k) m) xs empty"
 proof transfer
   fix f :: "'a \<Rightarrow> 'b" and xs
   have "map_of (List.map (\<lambda>k. (k, f k)) xs) = foldr (\<lambda>k m. m(k \<mapsto> f k)) xs Map.empty"
     by (simp add: foldr_map comp_def map_of_foldr)
-  also have "foldr (\<lambda>k m. m(k \<mapsto> f k)) xs = fold (\<lambda>k m. m(k \<mapsto> f k)) xs"
+  also have "foldr (\<lambda>k m. m(k \<mapsto> f k)) xs = List.fold (\<lambda>k m. m(k \<mapsto> f k)) xs"
     by (rule foldr_fold) (simp add: fun_eq_iff)
-  ultimately show "map_of (List.map (\<lambda>k. (k, f k)) xs) = fold (\<lambda>k m. m(k \<mapsto> f k)) xs Map.empty"
+  ultimately show "map_of (List.map (\<lambda>k. (k, f k)) xs) = List.fold (\<lambda>k m. m(k \<mapsto> f k)) xs Map.empty"
     by simp
 qed
 
 lemma All_mapping_mono:
   "(\<And>k v. k \<in> keys m \<Longrightarrow> P k v \<Longrightarrow> Q k v) \<Longrightarrow> All_mapping m P \<Longrightarrow> All_mapping m Q"
   unfolding All_mapping_def by transfer (auto simp: All_mapping_def dom_def split: option.splits)
 
 lemma All_mapping_empty [simp]: "All_mapping Mapping.empty P"
   by (auto simp: All_mapping_def lookup_empty)
 
 lemma All_mapping_update_iff:
   "All_mapping (Mapping.update k v m) P \<longleftrightarrow> P k v \<and> All_mapping m (\<lambda>k' v'. k = k' \<or> P k' v')"
   unfolding All_mapping_def
 proof safe
   assume "\<forall>x. case Mapping.lookup (Mapping.update k v m) x of None \<Rightarrow> True | Some y \<Rightarrow> P x y"
   then have *: "case Mapping.lookup (Mapping.update k v m) x of None \<Rightarrow> True | Some y \<Rightarrow> P x y" for x
     by blast
   from *[of k] show "P k v"
     by (simp add: lookup_update)
   show "case Mapping.lookup m x of None \<Rightarrow> True | Some v' \<Rightarrow> k = x \<or> P x v'" for x
     using *[of x] by (auto simp add: lookup_update' split: if_splits option.splits)
 next
   assume "P k v"
   assume "\<forall>x. case Mapping.lookup m x of None \<Rightarrow> True | Some v' \<Rightarrow> k = x \<or> P x v'"
   then have A: "case Mapping.lookup m x of None \<Rightarrow> True | Some v' \<Rightarrow> k = x \<or> P x v'" for x
     by blast
   show "case Mapping.lookup (Mapping.update k v m) x of None \<Rightarrow> True | Some xa \<Rightarrow> P x xa" for x
     using \<open>P k v\<close> A[of x] by (auto simp: lookup_update' split: option.splits)
 qed
 
 lemma All_mapping_update:
   "P k v \<Longrightarrow> All_mapping m (\<lambda>k' v'. k = k' \<or> P k' v') \<Longrightarrow> All_mapping (Mapping.update k v m) P"
   by (simp add: All_mapping_update_iff)
 
 lemma All_mapping_filter_iff: "All_mapping (filter P m) Q \<longleftrightarrow> All_mapping m (\<lambda>k v. P k v \<longrightarrow> Q k v)"
   by (auto simp: All_mapping_def lookup_filter split: option.splits)
 
 lemma All_mapping_filter: "All_mapping m Q \<Longrightarrow> All_mapping (filter P m) Q"
   by (auto simp: All_mapping_filter_iff intro: All_mapping_mono)
 
 lemma All_mapping_map_values: "All_mapping (map_values f m) P \<longleftrightarrow> All_mapping m (\<lambda>k v. P k (f k v))"
   by (auto simp: All_mapping_def lookup_map_values split: option.splits)
 
 lemma All_mapping_tabulate: "(\<forall>x\<in>set xs. P x (f x)) \<Longrightarrow> All_mapping (Mapping.tabulate xs f) P"
   unfolding All_mapping_def
   apply (intro allI)
   apply transfer
   apply (auto split: option.split dest!: map_of_SomeD)
   done
 
 lemma All_mapping_alist:
   "(\<And>k v. (k, v) \<in> set xs \<Longrightarrow> P k v) \<Longrightarrow> All_mapping (Mapping.of_alist xs) P"
   by (auto simp: All_mapping_def lookup_of_alist dest!: map_of_SomeD split: option.splits)
 
 lemma combine_empty [simp]: "combine f Mapping.empty y = y" "combine f y Mapping.empty = y"
   by (transfer; force)+
 
 lemma (in abel_semigroup) comm_monoid_set_combine: "comm_monoid_set (combine f) Mapping.empty"
   by standard (transfer fixing: f, simp add: combine_options_ac[of f] ac_simps)+
 
 locale combine_mapping_abel_semigroup = abel_semigroup
 begin
 
 sublocale combine: comm_monoid_set "combine f" Mapping.empty
   by (rule comm_monoid_set_combine)
 
 lemma fold_combine_code:
   "combine.F g (set xs) = foldr (\<lambda>x. combine f (g x)) (remdups xs) Mapping.empty"
 proof -
   have "combine.F g (set xs) = foldr (\<lambda>x. combine f (g x)) xs Mapping.empty"
     if "distinct xs" for xs
     using that by (induction xs) simp_all
   from this[of "remdups xs"] show ?thesis by simp
 qed
 
 lemma keys_fold_combine: "finite A \<Longrightarrow> Mapping.keys (combine.F g A) = (\<Union>x\<in>A. Mapping.keys (g x))"
   by (induct A rule: finite_induct) simp_all
 
 end
 
+subsubsection \<open>@{term [source] entries}, @{term [source] ordered_entries},
+               and @{term [source] fold}\<close>
+
+context linorder
+begin
+
+sublocale folding_Map_graph: folding_insort_key "(\<le>)" "(<)" "Map.graph m" fst for m
+  by unfold_locales (fact inj_on_fst_graph)
+
+end
+
+lemma sorted_fst_list_of_set_insort_Map_graph[simp]:
+  assumes "finite (dom m)" "fst x \<notin> dom m"
+  shows "sorted_key_list_of_set fst (insert x (Map.graph m))
+       = insort_key fst x (sorted_key_list_of_set fst (Map.graph m))"
+proof(cases x)
+  case (Pair k v)
+  with \<open>fst x \<notin> dom m\<close> have "Map.graph m \<subseteq> Map.graph (m(k \<mapsto> v))"
+    by(auto simp: graph_def)
+  moreover from Pair \<open>fst x \<notin> dom m\<close> have "(k, v) \<notin> Map.graph m"
+    using graph_domD by fastforce
+  ultimately show ?thesis
+    using Pair assms folding_Map_graph.sorted_key_list_of_set_insert[where ?m="m(k \<mapsto> v)"]
+    by auto
+qed
+
+lemma sorted_fst_list_of_set_insort_insert_Map_graph[simp]:
+  assumes "finite (dom m)" "fst x \<notin> dom m"
+  shows "sorted_key_list_of_set fst (insert x (Map.graph m))
+       = insort_insert_key fst x (sorted_key_list_of_set fst (Map.graph m))"
+proof(cases x)
+  case (Pair k v)
+  with \<open>fst x \<notin> dom m\<close> have "Map.graph m \<subseteq> Map.graph (m(k \<mapsto> v))"
+    by(auto simp: graph_def)    
+  with assms Pair show ?thesis
+    unfolding sorted_fst_list_of_set_insort_Map_graph[OF assms] insort_insert_key_def
+    using folding_Map_graph.set_sorted_key_list_of_set in_graphD by (fastforce split: if_splits)
+qed
+
+lemma linorder_finite_Map_induct[consumes 1, case_names empty update]:
+  fixes m :: "'a::linorder \<rightharpoonup> 'b"
+  assumes "finite (dom m)"
+  assumes "P Map.empty"
+  assumes "\<And>k v m. \<lbrakk> finite (dom m); k \<notin> dom m; (\<And>k'. k' \<in> dom m \<Longrightarrow> k' \<le> k); P m \<rbrakk>
+                    \<Longrightarrow> P (m(k \<mapsto> v))"
+  shows "P m"
+proof -
+  let ?key_list = "\<lambda>m. sorted_list_of_set (dom m)"
+  from assms(1,2) show ?thesis
+  proof(induction "length (?key_list m)" arbitrary: m)
+    case 0
+    then have "sorted_list_of_set (dom m) = []"
+      by auto
+    with \<open>finite (dom m)\<close> have "m = Map.empty"
+       by auto
+     with \<open>P Map.empty\<close> show ?case by simp
+  next
+    case (Suc n)
+    then obtain x xs where x_xs: "sorted_list_of_set (dom m) = xs @ [x]"
+      by (metis append_butlast_last_id length_greater_0_conv zero_less_Suc)
+    have "sorted_list_of_set (dom (m(x := None))) = xs"
+    proof -
+      have "distinct (xs @ [x])"
+        by (metis sorted_list_of_set.distinct_sorted_key_list_of_set x_xs)
+      then have "remove1 x (xs @ [x]) = xs"
+        by (simp add: remove1_append)
+      with \<open>finite (dom m)\<close> x_xs show ?thesis
+        by (simp add: sorted_list_of_set_remove)
+    qed
+    moreover have "k \<le> x" if "k \<in> dom (m(x := None))" for k
+    proof -
+      from x_xs have "sorted (xs @ [x])"
+        by (metis sorted_list_of_set.sorted_sorted_key_list_of_set)
+      moreover from \<open>k \<in> dom (m(x := None))\<close> have "k \<in> set xs"
+        using \<open>finite (dom m)\<close> \<open>sorted_list_of_set (dom (m(x := None))) = xs\<close>
+        by auto
+      ultimately show "k \<le> x"
+        by (simp add: sorted_append)
+    qed     
+    moreover from \<open>finite (dom m)\<close> have "finite (dom (m(x := None)))" "x \<notin> dom (m(x := None))"
+      by simp_all
+    moreover have "P (m(x := None))"
+      using Suc \<open>sorted_list_of_set (dom (m(x := None))) = xs\<close> x_xs by auto
+    ultimately show ?case
+      using assms(3)[where ?m="m(x := None)"] by (metis fun_upd_triv fun_upd_upd not_Some_eq)
+  qed
+qed
+
+lemma delete_insort_fst[simp]: "AList.delete k (insort_key fst (k, v) xs) = AList.delete k xs"
+  by (induction xs) simp_all
+
+lemma insort_fst_delete: "\<lbrakk> fst x \<noteq> k2; sorted (List.map fst xs) \<rbrakk>
+  \<Longrightarrow> insort_key fst x (AList.delete k2 xs) = AList.delete k2 (insort_key fst x xs)"
+  by (induction xs) (fastforce simp add: insort_is_Cons order_trans)+
+
+lemma sorted_fst_list_of_set_Map_graph_fun_upd_None[simp]:
+  "sorted_key_list_of_set fst (Map.graph (m(k := None)))
+   = AList.delete k (sorted_key_list_of_set fst (Map.graph m))"
+proof(cases "finite (Map.graph m)")
+  assume "finite (Map.graph m)"
+  from this[unfolded finite_graph_iff_finite_dom] show ?thesis
+  proof(induction rule: finite_Map_induct)
+    let ?list_of="sorted_key_list_of_set fst"
+    case (update k2 v2 m)
+    note [simp] = \<open>k2 \<notin> dom m\<close> \<open>finite (dom m)\<close>
+
+    have right_eq: "AList.delete k (?list_of (Map.graph (m(k2 \<mapsto> v2))))
+      = AList.delete k (insort_key fst (k2, v2) (?list_of (Map.graph m)))"
+      by simp
+
+    show ?case
+    proof(cases "k = k2")
+      case True
+      then have "?list_of (Map.graph ((m(k2 \<mapsto> v2))(k := None)))
+        = AList.delete k (insort_key fst (k2, v2) (?list_of (Map.graph m)))"
+        using fst_graph_eq_dom update.IH by auto
+      then show ?thesis
+        using right_eq by metis
+    next
+      case False
+      then have "AList.delete k (insort_key fst (k2, v2) (?list_of (Map.graph m)))
+        = insort_key fst (k2, v2) (?list_of (Map.graph (m(k := None))))"
+        by (auto simp add: insort_fst_delete update.IH
+                      folding_Map_graph.sorted_sorted_key_list_of_set[OF subset_refl])
+      also have "\<dots> = ?list_of (insert (k2, v2) (Map.graph (m(k := None))))"
+        by auto
+      also from False \<open>k2 \<notin> dom m\<close> have "\<dots> = ?list_of (Map.graph ((m(k2 \<mapsto> v2))(k := None)))"
+        by (metis graph_map_upd domIff fun_upd_triv fun_upd_twist)
+      finally show ?thesis using right_eq by metis
+    qed
+  qed simp
+qed simp
+
+lemma entries_lookup: "entries m = Map.graph (lookup m)"
+  by transfer rule
+
+lemma entries_empty[simp]: "entries empty = {}"
+  by transfer (fact graph_empty)
+
+lemma finite_entries_iff_finite_keys[simp]:
+  "finite (entries m) = finite (keys m)"
+  by transfer (fact finite_graph_iff_finite_dom)
+
+lemma entries_update[simp]:
+  "entries (update k v m) = insert (k, v) (entries (delete k m))"
+  by transfer (fact graph_map_upd)
+
+lemma Mapping_delete_if_notin_keys[simp]:
+  "k \<notin> Mapping.keys m \<Longrightarrow> delete k m = m"
+  by transfer simp
+
+lemma entries_delete:
+  "entries (delete k m) = {e \<in> entries m. fst e \<noteq> k}"
+  by transfer (fact graph_fun_upd_None)
+
+lemma entries_of_alist[simp]:
+  "distinct (List.map fst xs) \<Longrightarrow> entries (of_alist xs) = set xs"
+  by transfer (fact graph_map_of_if_distinct_ran)
+
+lemma entries_keysD:
+  "x \<in> entries m \<Longrightarrow> fst x \<in> keys m"
+  by transfer (fact graph_domD)
+
+lemma finite_keys_entries[simp]:
+  "finite (keys (update k v m)) = finite (keys m)"
+  by transfer simp
+
+lemma set_ordered_entries[simp]:
+  "finite (Mapping.keys m) \<Longrightarrow> set (ordered_entries m) = entries m"
+  unfolding ordered_entries_def
+  by transfer (auto simp: folding_Map_graph.set_sorted_key_list_of_set[OF subset_refl])
+
+lemma distinct_ordered_entries[simp]: "distinct (List.map fst (ordered_entries m))"
+  unfolding ordered_entries_def
+  by transfer (simp add: folding_Map_graph.distinct_sorted_key_list_of_set[OF subset_refl])
+
+lemma sorted_ordered_entries[simp]: "sorted (List.map fst (ordered_entries m))"
+  unfolding ordered_entries_def
+  by transfer (auto intro: folding_Map_graph.sorted_sorted_key_list_of_set)
+
+lemma ordered_entries_infinite[simp]:
+  "\<not> finite (Mapping.keys m) \<Longrightarrow> ordered_entries m = []"
+  by (simp add: ordered_entries_def)
+
+lemma ordered_entries_empty[simp]: "ordered_entries empty = []"
+  by (simp add: ordered_entries_def)
+
+lemma ordered_entries_update[simp]:
+  assumes "finite (keys m)"
+  shows "ordered_entries (update k v m)
+   = insort_insert_key fst (k, v) (AList.delete k (ordered_entries m))"
+proof -
+  let ?list_of="sorted_key_list_of_set fst" and ?insort="insort_insert_key fst"
+
+  have *: "?list_of (insert (k, v) (Map.graph (m(k := None))))
+    = ?insort (k, v) (AList.delete k (?list_of (Map.graph m)))" if "finite (dom m)" for m
+  proof -
+    from \<open>finite (dom m)\<close> have "?list_of (insert (k, v) (Map.graph (m(k := None))))
+      = ?insort (k, v) (?list_of (Map.graph (m(k := None))))"
+      by (intro sorted_fst_list_of_set_insort_insert_Map_graph) (simp_all add: subset_insertI) 
+    then show ?thesis by simp
+  qed
+  from assms show ?thesis
+    unfolding ordered_entries_def
+    apply (transfer fixing: k v) using "*" by auto
+qed
+
+lemma ordered_entries_delete[simp]:
+  "ordered_entries (delete k m) = AList.delete k (ordered_entries m)"
+  unfolding ordered_entries_def by transfer auto
+
+lemma fold_empty[simp]: "fold f empty a = a"
+  unfolding fold_def by simp
+
+lemma insort_key_is_snoc_if_sorted_and_distinct:
+  assumes "sorted (List.map f xs)" "f y \<notin> f ` set xs" "\<forall>x \<in> set xs. f x \<le> f y"
+  shows "insort_key f y xs = xs @ [y]"
+  using assms by (induction xs) (auto dest!: insort_is_Cons)
+
+lemma fold_update:
+  assumes "finite (keys m)"
+  assumes "k \<notin> keys m" "\<And>k'. k' \<in> keys m \<Longrightarrow> k' \<le> k"
+  shows "fold f (update k v m) a = f k v (fold f m a)"
+proof -
+  from assms have k_notin_entries: "k \<notin> fst ` set (ordered_entries m)"
+    using entries_keysD by fastforce
+  with assms have "ordered_entries (update k v m)
+    = insort_insert_key fst (k, v) (ordered_entries m)"
+    by simp
+  also from k_notin_entries have "\<dots> = ordered_entries m @ [(k, v)]"
+  proof -
+    from assms have "\<forall>x \<in> set (ordered_entries m). fst x \<le> fst (k, v)"
+      unfolding ordered_entries_def
+      by transfer (fastforce simp: folding_Map_graph.set_sorted_key_list_of_set[OF order_refl]
+                             dest: graph_domD)
+    from insort_key_is_snoc_if_sorted_and_distinct[OF _ _ this] k_notin_entries show ?thesis
+      unfolding insort_insert_key_def by auto
+  qed
+  finally show ?thesis unfolding fold_def by simp
+qed
+
+lemma linorder_finite_Mapping_induct[consumes 1, case_names empty update]:
+  fixes m :: "('a::linorder, 'b) mapping"
+  assumes "finite (keys m)"
+  assumes "P empty"
+  assumes "\<And>k v m.
+    \<lbrakk> finite (keys m); k \<notin> keys m; (\<And>k'. k' \<in> keys m \<Longrightarrow> k' \<le> k); P m \<rbrakk>
+    \<Longrightarrow> P (update k v m)"
+  shows "P m"
+  using assms by transfer (simp add: linorder_finite_Map_induct)
+
 
 subsection \<open>Code generator setup\<close>
 
 hide_const (open) empty is_empty rep lookup lookup_default filter update delete ordered_keys
   keys size replace default map_entry map_default tabulate bulkload map map_values combine of_alist
+  entries ordered_entries fold
 
 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,4002 +1,4002 @@
 (*  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
 *)
 
 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
 
 
 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
 
 
 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)"
 
 
 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
 
 
 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>fn phi => 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>fn phi => 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>fn phi => 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>fn phi => 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)
 
 
 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)
 
 
 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 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>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)
 
 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_funpow)
+      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_funpow)
+      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
 
 
 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"
 apply (unfold surj_def)
 apply (rule allI)
 apply (rule_tac M = y in multiset_induct)
  apply auto
 apply (rule_tac x = "x # xa" in exI)
 apply auto
 done
 
 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.F 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>
 
 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
 
 
 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>
 
 subsubsection \<open>Well-foundedness\<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>+"
 
 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 not_less_empty [iff]: "(M, {#}) \<notin> mult1 r"
 by (simp add: mult1_def)
 
 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
 
 theorem wf_mult1: "wf r \<Longrightarrow> wf (mult1 r)"
 by (rule acc_wfI) (rule all_accessible)
 
 theorem wf_mult: "wf r \<Longrightarrow> wf (mult r)"
 unfolding mult_def by (rule wf_trancl) (rule wf_mult1)
 
 
 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 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 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
 
 
 subsection \<open>The multiset extension is cancellative for multiset union\<close>
 
 lemma mult_cancel:
   assumes "trans s" and "irrefl s"
   shows "(X + Z, Y + Z) \<in> mult s \<longleftrightarrow> (X, Y) \<in> mult s" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L thus ?R
   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]
         by (auto simp: add.commute[of _ "{#_#}"] add.assoc intro: add(1))
     next
       case 2 then obtain y where "y \<in> set_mset Y2" "(z, y) \<in> s" using *(4) \<open>irrefl s\<close>
         by (auto simp: irrefl_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
         by (force simp: add.commute[of "{#_#}"] add.assoc[symmetric] intro: add(1))
     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
 
 lemmas mult_cancel_add_mset =
   mult_cancel[of _ _ "{#_#}", unfolded union_mset_add_mset_right add.comm_neutral]
 
 lemma mult_cancel_max:
   assumes "trans s" and "irrefl 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 = X" "Y - X \<inter># Y + X \<inter># Y = Y" by (auto simp flip: count_inject)
   thus ?thesis using mult_cancel[OF assms, of "X - X \<inter># Y"  "X \<inter># Y" "Y - X \<inter># Y"] by auto
 qed
 
 
 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\<close> and \<open>multeqp\<close>.
 \<close>
 
 definition multp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multp 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 :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool" where
   "multeqp 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_iff:
   assumes "irrefl R" and "trans R" and [simp]: "\<And>x y. P x y \<longleftrightarrow> (x, y) \<in> R"
   shows "multp 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_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_implies_one_step[OF assms(2), of "N - M \<inter># N" "M - M \<inter># N"]
         mult_cancel_max[OF assms(2,1), of "N" "M"] * by (auto simp: multp_def)
   qed
 qed
 
 lemma multeqp_iff:
   assumes "irrefl R" and "trans R" and "\<And>x y. P x y \<longleftrightarrow> (x, y) \<in> R"
   shows "multeqp 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 P N M \<longleftrightarrow> multp P N M \<or> N = M"
     by (auto simp: multeqp_def multp_def Let_def in_diff_count)
   thus ?thesis using multp_iff[OF assms] by simp
 qed
 
 
 subsubsection \<open>Partial-order properties\<close>
 
 lemma (in preorder) mult1_lessE:
   assumes "(N, M) \<in> mult1 {(a, b). a < b}"
   obtains a M0 K where "M = add_mset a M0" "N = M0 + K"
     "a \<notin># K" "\<And>b. b \<in># K \<Longrightarrow> b < a"
 proof -
   from assms obtain a M0 K where "M = add_mset a M0" "N = M0 + K" and
     *: "b \<in># K \<Longrightarrow> b < a" for b by (blast elim: mult1E)
   moreover from * [of a] have "a \<notin># K" by auto
   ultimately show thesis by (auto intro: that)
 qed
 
 instantiation multiset :: (preorder) order
 begin
 
 definition less_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"
   where "M' < M \<longleftrightarrow> (M', M) \<in> mult {(x', x). x' < x}"
 
 definition less_eq_multiset :: "'a multiset \<Rightarrow> 'a multiset \<Rightarrow> bool"
   where "less_eq_multiset M' M \<longleftrightarrow> M' < M \<or> M' = M"
 
 instance
 proof -
   have irrefl: "\<not> M < M" for M :: "'a multiset"
   proof
     assume "M < M"
     then have MM: "(M, M) \<in> mult {(x, y). x < y}" by (simp add: less_multiset_def)
     have "trans {(x'::'a, x). x' < x}"
       by (metis (mono_tags, lifting) case_prodD case_prodI less_trans mem_Collect_eq transI)
     moreover note MM
     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 *: "K \<noteq> {#}" and **: "\<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 **
     ultimately have "set_mset K = {}"
       by (induct rule: finite_induct) (auto intro: order_less_trans)
     with * show False by simp
   qed
   have trans: "K < M \<Longrightarrow> M < N \<Longrightarrow> K < N" for K M N :: "'a multiset"
     unfolding less_multiset_def mult_def by (blast intro: trancl_trans)
   show "OFCLASS('a multiset, order_class)"
     by standard (auto simp add: less_eq_multiset_def irrefl dest: trans)
 qed
 
 end
 
 lemma mset_le_irrefl [elim!]:
   fixes M :: "'a::preorder multiset"
   shows "M < M \<Longrightarrow> R"
   by simp
 
 
 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 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 (\<^type_name>\<open>multiset\<close>, [T]);
 
     fun mk_mset T [] = Const (\<^const_abbrev>\<open>empty_mset\<close>, msetT T)
       | mk_mset T [x] =
         Const (\<^const_name>\<open>add_mset\<close>, T --> msetT T --> msetT T) $ x $
           Const (\<^const_abbrev>\<open>empty_mset\<close>, msetT T)
       | mk_mset T (x :: xs) =
         Const (\<^const_name>\<open>plus\<close>, msetT T --> msetT T --> msetT T) $
           mk_mset T [x] $ mk_mset T xs
 
     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 (\<^const_name>\<open>zero_class.zero\<close>, T)
             | ts =>
                 foldl1 (fn (s, t) => Const (\<^const_name>\<open>add_mset\<close>, elem_T --> T --> T) $ s $ t)
                   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 "ordLeq3 (card_of (set_mset X)) natLeq" for X
     by transfer
       (auto intro!: ordLess_imp_ordLeq 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
 
 hide_const (open) wcount
 
 end
diff --git a/src/HOL/Library/RBT.thy b/src/HOL/Library/RBT.thy
--- a/src/HOL/Library/RBT.thy
+++ b/src/HOL/Library/RBT.thy
@@ -1,240 +1,243 @@
 (*  Title:      HOL/Library/RBT.thy
     Author:     Lukas Bulwahn and Ondrej Kuncar
 *)
 
 section \<open>Abstract type of RBT trees\<close>
 
 theory RBT 
 imports Main RBT_Impl
 begin
 
 subsection \<open>Type definition\<close>
 
 typedef (overloaded) ('a, 'b) rbt = "{t :: ('a::linorder, 'b) RBT_Impl.rbt. is_rbt t}"
   morphisms impl_of RBT
 proof -
   have "RBT_Impl.Empty \<in> ?rbt" by simp
   then show ?thesis ..
 qed
 
 lemma rbt_eq_iff:
   "t1 = t2 \<longleftrightarrow> impl_of t1 = impl_of t2"
   by (simp add: impl_of_inject)
 
 lemma rbt_eqI:
   "impl_of t1 = impl_of t2 \<Longrightarrow> t1 = t2"
   by (simp add: rbt_eq_iff)
 
 lemma is_rbt_impl_of [simp, intro]:
   "is_rbt (impl_of t)"
   using impl_of [of t] by simp
 
 lemma RBT_impl_of [simp, code abstype]:
   "RBT (impl_of t) = t"
   by (simp add: impl_of_inverse)
 
 subsection \<open>Primitive operations\<close>
 
 setup_lifting type_definition_rbt
 
 lift_definition lookup :: "('a::linorder, 'b) rbt \<Rightarrow> 'a \<rightharpoonup> 'b" is "rbt_lookup" .
 
 lift_definition empty :: "('a::linorder, 'b) rbt" is RBT_Impl.Empty 
 by (simp add: empty_def)
 
 lift_definition insert :: "'a::linorder \<Rightarrow> 'b \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_insert" 
 by simp
 
 lift_definition delete :: "'a::linorder \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_delete" 
 by simp
 
 lift_definition entries :: "('a::linorder, 'b) rbt \<Rightarrow> ('a \<times> 'b) list" is RBT_Impl.entries .
 
 lift_definition keys :: "('a::linorder, 'b) rbt \<Rightarrow> 'a list" is RBT_Impl.keys .
 
 lift_definition bulkload :: "('a::linorder \<times> 'b) list \<Rightarrow> ('a, 'b) rbt" is "rbt_bulkload" ..
 
 lift_definition map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is rbt_map_entry
 by simp
 
 lift_definition map :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'c) rbt" is RBT_Impl.map
 by simp
 
 lift_definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"  is RBT_Impl.fold .
 
 lift_definition union :: "('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt" is "rbt_union"
 by (simp add: rbt_union_is_rbt)
 
 lift_definition foldi :: "('c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a :: linorder, 'b) rbt \<Rightarrow> 'c \<Rightarrow> 'c"
   is RBT_Impl.foldi .
   
 lift_definition combine_with_key :: "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
   is RBT_Impl.rbt_union_with_key by (rule is_rbt_rbt_unionwk)
 
 lift_definition combine :: "('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt \<Rightarrow> ('a, 'b) rbt"
   is RBT_Impl.rbt_union_with by (rule rbt_unionw_is_rbt)
 
 subsection \<open>Derived operations\<close>
 
 definition is_empty :: "('a::linorder, 'b) rbt \<Rightarrow> bool" where
   [code]: "is_empty t = (case impl_of t of RBT_Impl.Empty \<Rightarrow> True | _ \<Rightarrow> False)"
 
 (* TODO: Is deleting more efficient than re-building the tree? 
    (Probably more difficult to prove though *)
 definition filter :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) rbt" where
   [code]: "filter P t = fold (\<lambda>k v t. if P k v then insert k v t else t) t empty" 
 
 subsection \<open>Abstract lookup properties\<close>
 
 lemma lookup_RBT:
   "is_rbt t \<Longrightarrow> lookup (RBT t) = rbt_lookup t"
   by (simp add: lookup_def RBT_inverse)
 
 lemma lookup_impl_of:
   "rbt_lookup (impl_of t) = lookup t"
   by transfer (rule refl)
 
 lemma entries_impl_of:
   "RBT_Impl.entries (impl_of t) = entries t"
   by transfer (rule refl)
 
 lemma keys_impl_of:
   "RBT_Impl.keys (impl_of t) = keys t"
   by transfer (rule refl)
 
 lemma lookup_keys: 
   "dom (lookup t) = set (keys t)" 
   by transfer (simp add: rbt_lookup_keys)
 
 lemma lookup_empty [simp]:
   "lookup empty = Map.empty"
   by (simp add: empty_def lookup_RBT fun_eq_iff)
 
 lemma lookup_insert [simp]:
   "lookup (insert k v t) = (lookup t)(k \<mapsto> v)"
   by transfer (rule rbt_lookup_rbt_insert)
 
 lemma lookup_delete [simp]:
   "lookup (delete k t) = (lookup t)(k := None)"
   by transfer (simp add: rbt_lookup_rbt_delete restrict_complement_singleton_eq)
 
 lemma map_of_entries [simp]:
   "map_of (entries t) = lookup t"
   by transfer (simp add: map_of_entries)
 
 lemma entries_lookup:
   "entries t1 = entries t2 \<longleftrightarrow> lookup t1 = lookup t2"
   by transfer (simp add: entries_rbt_lookup)
 
 lemma lookup_bulkload [simp]:
   "lookup (bulkload xs) = map_of xs"
   by transfer (rule rbt_lookup_rbt_bulkload)
 
 lemma lookup_map_entry [simp]:
   "lookup (map_entry k f t) = (lookup t)(k := map_option f (lookup t k))"
   by transfer (rule rbt_lookup_rbt_map_entry)
 
 lemma lookup_map [simp]:
   "lookup (map f t) k = map_option (f k) (lookup t k)"
   by transfer (rule rbt_lookup_map)
 
 lemma lookup_combine_with_key [simp]:
   "lookup (combine_with_key f t1 t2) k = combine_options (f k) (lookup t1 k) (lookup t2 k)"
   by transfer (simp_all add: combine_options_def rbt_lookup_rbt_unionwk)
 
 lemma combine_altdef: "combine f t1 t2 = combine_with_key (\<lambda>_. f) t1 t2"
   by transfer (simp add: rbt_union_with_def)
 
 lemma lookup_combine [simp]:
   "lookup (combine f t1 t2) k = combine_options f (lookup t1 k) (lookup t2 k)"
   by (simp add: combine_altdef)
 
 lemma fold_fold:
   "fold f t = List.fold (case_prod f) (entries t)"
   by transfer (rule RBT_Impl.fold_def)
 
 lemma impl_of_empty:
   "impl_of empty = RBT_Impl.Empty"
   by transfer (rule refl)
 
 lemma is_empty_empty [simp]:
   "is_empty t \<longleftrightarrow> t = empty"
   unfolding is_empty_def by transfer (simp split: rbt.split)
 
 lemma RBT_lookup_empty [simp]: (*FIXME*)
   "rbt_lookup t = Map.empty \<longleftrightarrow> t = RBT_Impl.Empty"
   by (cases t) (auto simp add: fun_eq_iff)
 
 lemma lookup_empty_empty [simp]:
   "lookup t = Map.empty \<longleftrightarrow> t = empty"
   by transfer (rule RBT_lookup_empty)
 
 lemma sorted_keys [iff]:
   "sorted (keys t)"
   by transfer (simp add: RBT_Impl.keys_def rbt_sorted_entries)
 
 lemma distinct_keys [iff]:
   "distinct (keys t)"
   by transfer (simp add: RBT_Impl.keys_def distinct_entries)
 
 lemma finite_dom_lookup [simp, intro!]: "finite (dom (lookup t))"
   by transfer simp
 
 lemma lookup_union: "lookup (union s t) = lookup s ++ lookup t"
   by transfer (simp add: rbt_lookup_rbt_union)
 
 lemma lookup_in_tree: "(lookup t k = Some v) = ((k, v) \<in> set (entries t))"
   by transfer (simp add: rbt_lookup_in_tree)
 
 lemma keys_entries: "(k \<in> set (keys t)) = (\<exists>v. (k, v) \<in> set (entries t))"
   by transfer (simp add: keys_entries)
 
 lemma fold_def_alt:
   "fold f t = List.fold (case_prod f) (entries t)"
   by transfer (auto simp: RBT_Impl.fold_def)
 
 lemma distinct_entries: "distinct (List.map fst (entries t))"
   by transfer (simp add: distinct_entries)
 
+lemma sorted_entries: "sorted (List.map fst (entries t))"
+  by (transfer) (simp add: rbt_sorted_entries)
+
 lemma non_empty_keys: "t \<noteq> empty \<Longrightarrow> keys t \<noteq> []"
   by transfer (simp add: non_empty_rbt_keys)
 
 lemma keys_def_alt:
   "keys t = List.map fst (entries t)"
   by transfer (simp add: RBT_Impl.keys_def)
 
 context
 begin
 
 private lemma lookup_filter_aux:
   assumes "distinct (List.map fst xs)"
   shows   "lookup (List.fold (\<lambda>(k, v) t. if P k v then insert k v t else t) xs t) k =
              (case map_of xs k of 
                 None \<Rightarrow> lookup t k
               | Some v \<Rightarrow> if P k v then Some v else lookup t k)"
   using assms by (induction xs arbitrary: t) (force split: option.splits)+
 
 lemma lookup_filter: 
   "lookup (filter P t) k = 
      (case lookup t k of None \<Rightarrow> None | Some v \<Rightarrow> if P k v then Some v else None)"
   unfolding filter_def using lookup_filter_aux[of "entries t" P empty k]
   by (simp add: fold_fold distinct_entries split: option.splits)
   
 end
 
 
 subsection \<open>Quickcheck generators\<close>
 
 quickcheck_generator rbt predicate: is_rbt constructors: empty, insert
 
 subsection \<open>Hide implementation details\<close>
 
 lifting_update rbt.lifting
 lifting_forget rbt.lifting
 
 hide_const (open) impl_of empty lookup keys entries bulkload delete map fold union insert map_entry foldi 
   is_empty filter
 hide_fact (open) empty_def lookup_def keys_def entries_def bulkload_def delete_def map_def fold_def 
   union_def insert_def map_entry_def foldi_def is_empty_def filter_def
 
 end
diff --git a/src/HOL/Library/RBT_Mapping.thy b/src/HOL/Library/RBT_Mapping.thy
--- a/src/HOL/Library/RBT_Mapping.thy
+++ b/src/HOL/Library/RBT_Mapping.thy
@@ -1,229 +1,247 @@
 (*  Title:      HOL/Library/RBT_Mapping.thy
     Author:     Florian Haftmann and Ondrej Kuncar
 *)
 
 section \<open>Implementation of mappings with Red-Black Trees\<close>
 
 (*<*)
 theory RBT_Mapping
 imports RBT Mapping
 begin
 
 subsection \<open>Implementation of mappings\<close>
 
 context includes rbt.lifting begin
 lift_definition Mapping :: "('a::linorder, 'b) rbt \<Rightarrow> ('a, 'b) mapping" is RBT.lookup .
 end
 
 code_datatype Mapping
 
 context includes rbt.lifting begin
 
 lemma lookup_Mapping [simp, code]:
   "Mapping.lookup (Mapping t) = RBT.lookup t"
    by (transfer fixing: t) rule
 
 lemma empty_Mapping [code]: "Mapping.empty = Mapping RBT.empty"
 proof -
   note RBT.empty.transfer[transfer_rule del]
   show ?thesis by transfer simp
 qed
 
 lemma is_empty_Mapping [code]:
   "Mapping.is_empty (Mapping t) \<longleftrightarrow> RBT.is_empty t"
   unfolding is_empty_def by (transfer fixing: t) simp
 
 lemma insert_Mapping [code]:
   "Mapping.update k v (Mapping t) = Mapping (RBT.insert k v t)"
   by (transfer fixing: t) simp
 
 lemma delete_Mapping [code]:
   "Mapping.delete k (Mapping t) = Mapping (RBT.delete k t)"
   by (transfer fixing: t) simp
 
 lemma map_entry_Mapping [code]:
   "Mapping.map_entry k f (Mapping t) = Mapping (RBT.map_entry k f t)"
   apply (transfer fixing: t)
   apply (case_tac "RBT.lookup t k")
    apply auto
   done
 
 lemma keys_Mapping [code]:
   "Mapping.keys (Mapping t) = set (RBT.keys t)"
 by (transfer fixing: t) (simp add: lookup_keys)
 
 lemma ordered_keys_Mapping [code]:
   "Mapping.ordered_keys (Mapping t) = RBT.keys t"
 unfolding ordered_keys_def 
 by (transfer fixing: t) (auto simp add: lookup_keys intro: sorted_distinct_set_unique)
 
+lemma Map_graph_lookup: "Map.graph (RBT.lookup t) = set (RBT.entries t)"
+  by (metis RBT.distinct_entries RBT.map_of_entries graph_map_of_if_distinct_ran)
+
+lemma entries_Mapping [code]: "Mapping.entries (Mapping t) = set (RBT.entries t)"
+  by (transfer fixing: t) (fact Map_graph_lookup)
+
+lemma ordered_entries_Mapping [code]: "Mapping.ordered_entries (Mapping t) = RBT.entries t"
+proof -
+  note folding_Map_graph.idem_if_sorted_distinct[
+      where ?m="RBT.lookup t", OF _ _ folding_Map_graph.distinct_if_distinct_map]
+  then show ?thesis
+    unfolding ordered_entries_def
+    by (transfer fixing: t) (auto simp: Map_graph_lookup distinct_entries sorted_entries)
+qed
+
+lemma fold_Mapping [code]: "Mapping.fold f (Mapping t) a = RBT.fold f t a"
+  by (simp add: Mapping.fold_def fold_fold ordered_entries_Mapping)
+
 lemma Mapping_size_card_keys: (*FIXME*)
   "Mapping.size m = card (Mapping.keys m)"
 unfolding size_def by transfer simp
 
 lemma size_Mapping [code]:
   "Mapping.size (Mapping t) = length (RBT.keys t)"
 unfolding size_def
 by (transfer fixing: t) (simp add: lookup_keys distinct_card)
 
 context
   notes RBT.bulkload.transfer[transfer_rule del]
 begin
 
 lemma tabulate_Mapping [code]:
   "Mapping.tabulate ks f = Mapping (RBT.bulkload (List.map (\<lambda>k. (k, f k)) ks))"
 by transfer (simp add: map_of_map_restrict)
 
 lemma bulkload_Mapping [code]:
   "Mapping.bulkload vs = Mapping (RBT.bulkload (List.map (\<lambda>n. (n, vs ! n)) [0..<length vs]))"
 by transfer (simp add: map_of_map_restrict fun_eq_iff)
 
 end
 
 lemma map_values_Mapping [code]: 
   "Mapping.map_values f (Mapping t) = Mapping (RBT.map f t)"
   by (transfer fixing: t) (auto simp: fun_eq_iff)
 
 lemma filter_Mapping [code]: 
   "Mapping.filter P (Mapping t) = Mapping (RBT.filter P t)"
   by (transfer' fixing: P t) (simp add: RBT.lookup_filter fun_eq_iff)
 
 lemma combine_with_key_Mapping [code]:
   "Mapping.combine_with_key f (Mapping t1) (Mapping t2) =
      Mapping (RBT.combine_with_key f t1 t2)"
   by (transfer fixing: f t1 t2) (simp_all add: fun_eq_iff)
 
 lemma combine_Mapping [code]:
   "Mapping.combine f (Mapping t1) (Mapping t2) =
      Mapping (RBT.combine f t1 t2)"
   by (transfer fixing: f t1 t2) (simp_all add: fun_eq_iff)
 
 lemma equal_Mapping [code]:
   "HOL.equal (Mapping t1) (Mapping t2) \<longleftrightarrow> RBT.entries t1 = RBT.entries t2"
-  by (transfer fixing: t1 t2) (simp add: entries_lookup)
+  by (transfer fixing: t1 t2) (simp add: RBT.entries_lookup)
 
 lemma [code nbe]:
   "HOL.equal (x :: (_, _) mapping) x \<longleftrightarrow> True"
   by (fact equal_refl)
 
 end
 
 (*>*)
 
 text \<open>
   This theory defines abstract red-black trees as an efficient
   representation of finite maps, backed by the implementation
   in \<^theory>\<open>HOL-Library.RBT_Impl\<close>.
 \<close>
 
 subsection \<open>Data type and invariant\<close>
 
 text \<open>
   The type \<^typ>\<open>('k, 'v) RBT_Impl.rbt\<close> denotes red-black trees with
   keys of type \<^typ>\<open>'k\<close> and values of type \<^typ>\<open>'v\<close>. To function
   properly, the key type musorted belong to the \<open>linorder\<close>
   class.
 
   A value \<^term>\<open>t\<close> of this type is a valid red-black tree if it
   satisfies the invariant \<open>is_rbt t\<close>.  The abstract type \<^typ>\<open>('k, 'v) rbt\<close> always obeys this invariant, and for this reason you
   should only use this in our application.  Going back to \<^typ>\<open>('k,
   'v) RBT_Impl.rbt\<close> may be necessary in proofs if not yet proven
   properties about the operations must be established.
 
   The interpretation function \<^const>\<open>RBT.lookup\<close> returns the partial
   map represented by a red-black tree:
   @{term_type[display] "RBT.lookup"}
 
   This function should be used for reasoning about the semantics of the RBT
   operations. Furthermore, it implements the lookup functionality for
   the data structure: It is executable and the lookup is performed in
   $O(\log n)$.  
 \<close>
 
 subsection \<open>Operations\<close>
 
 text \<open>
   Currently, the following operations are supported:
 
   @{term_type [display] "RBT.empty"}
   Returns the empty tree. $O(1)$
 
   @{term_type [display] "RBT.insert"}
   Updates the map at a given position. $O(\log n)$
 
   @{term_type [display] "RBT.delete"}
   Deletes a map entry at a given position. $O(\log n)$
 
   @{term_type [display] "RBT.entries"}
   Return a corresponding key-value list for a tree.
 
   @{term_type [display] "RBT.bulkload"}
   Builds a tree from a key-value list.
 
   @{term_type [display] "RBT.map_entry"}
   Maps a single entry in a tree.
 
   @{term_type [display] "RBT.map"}
   Maps all values in a tree. $O(n)$
 
   @{term_type [display] "RBT.fold"}
   Folds over all entries in a tree. $O(n)$
 \<close>
 
 
 subsection \<open>Invariant preservation\<close>
 
 text \<open>
   \noindent
   @{thm Empty_is_rbt}\hfill(\<open>Empty_is_rbt\<close>)
 
   \noindent
   @{thm rbt_insert_is_rbt}\hfill(\<open>rbt_insert_is_rbt\<close>)
 
   \noindent
   @{thm rbt_delete_is_rbt}\hfill(\<open>delete_is_rbt\<close>)
 
   \noindent
   @{thm rbt_bulkload_is_rbt}\hfill(\<open>bulkload_is_rbt\<close>)
 
   \noindent
   @{thm rbt_map_entry_is_rbt}\hfill(\<open>map_entry_is_rbt\<close>)
 
   \noindent
   @{thm map_is_rbt}\hfill(\<open>map_is_rbt\<close>)
 
   \noindent
   @{thm rbt_union_is_rbt}\hfill(\<open>union_is_rbt\<close>)
 \<close>
 
 
 subsection \<open>Map Semantics\<close>
 
 text \<open>
   \noindent
   \underline{\<open>lookup_empty\<close>}
   @{thm [display] lookup_empty}
   \vspace{1ex}
 
   \noindent
   \underline{\<open>lookup_insert\<close>}
   @{thm [display] lookup_insert}
   \vspace{1ex}
 
   \noindent
   \underline{\<open>lookup_delete\<close>}
   @{thm [display] lookup_delete}
   \vspace{1ex}
 
   \noindent
   \underline{\<open>lookup_bulkload\<close>}
   @{thm [display] lookup_bulkload}
   \vspace{1ex}
 
   \noindent
   \underline{\<open>lookup_map\<close>}
   @{thm [display] lookup_map}
   \vspace{1ex}
 \<close>
 
 end
diff --git a/src/HOL/Library/RBT_Set.thy b/src/HOL/Library/RBT_Set.thy
--- a/src/HOL/Library/RBT_Set.thy
+++ b/src/HOL/Library/RBT_Set.thy
@@ -1,800 +1,802 @@
 (*  Title:      HOL/Library/RBT_Set.thy
     Author:     Ondrej Kuncar
 *)
 
 section \<open>Implementation of sets using RBT trees\<close>
 
 theory RBT_Set
 imports RBT Product_Lexorder
 begin
 
 (*
   Users should be aware that by including this file all code equations
   outside of List.thy using 'a list as an implementation of sets cannot be
   used for code generation. If such equations are not needed, they can be
   deleted from the code generator. Otherwise, a user has to provide their 
   own equations using RBT trees. 
 *)
 
 section \<open>Definition of code datatype constructors\<close>
 
 definition Set :: "('a::linorder, unit) rbt \<Rightarrow> 'a set" 
   where "Set t = {x . RBT.lookup t x = Some ()}"
 
 definition Coset :: "('a::linorder, unit) rbt \<Rightarrow> 'a set" 
   where [simp]: "Coset t = - Set t"
 
 
 section \<open>Deletion of already existing code equations\<close>
 
 declare [[code drop: Set.empty Set.is_empty uminus_set_inst.uminus_set
   Set.member Set.insert Set.remove UNIV Set.filter image
   Set.subset_eq Ball Bex can_select Set.union minus_set_inst.minus_set Set.inter
   card the_elem Pow sum prod Product_Type.product Id_on
   Image trancl relcomp wf Min Inf_fin Max Sup_fin
   "(Inf :: 'a set set \<Rightarrow> 'a set)" "(Sup :: 'a set set \<Rightarrow> 'a set)"
   sorted_list_of_set List.map_project List.Bleast]]
 
 
 section \<open>Lemmas\<close>
 
 subsection \<open>Auxiliary lemmas\<close>
 
 lemma [simp]: "x \<noteq> Some () \<longleftrightarrow> x = None"
 by (auto simp: not_Some_eq[THEN iffD1])
 
 lemma Set_set_keys: "Set x = dom (RBT.lookup x)" 
 by (auto simp: Set_def)
 
 lemma finite_Set [simp, intro!]: "finite (Set x)"
 by (simp add: Set_set_keys)
 
 lemma set_keys: "Set t = set(RBT.keys t)"
 by (simp add: Set_set_keys lookup_keys)
 
 subsection \<open>fold and filter\<close>
 
 lemma finite_fold_rbt_fold_eq:
   assumes "comp_fun_commute f" 
   shows "Finite_Set.fold f A (set (RBT.entries t)) = RBT.fold (curry f) t A"
 proof -
+  interpret comp_fun_commute: comp_fun_commute f
+    by (fact assms)
   have *: "remdups (RBT.entries t) = RBT.entries t"
     using distinct_entries distinct_map by (auto intro: distinct_remdups_id)
   show ?thesis using assms by (auto simp: fold_def_alt comp_fun_commute.fold_set_fold_remdups *)
 qed
 
 definition fold_keys :: "('a :: linorder \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, _) rbt \<Rightarrow> 'b \<Rightarrow> 'b" 
   where [code_unfold]:"fold_keys f t A = RBT.fold (\<lambda>k _ t. f k t) t A"
 
 lemma fold_keys_def_alt:
   "fold_keys f t s = List.fold f (RBT.keys t) s"
 by (auto simp: fold_map o_def split_def fold_def_alt keys_def_alt fold_keys_def)
 
 lemma finite_fold_fold_keys:
   assumes "comp_fun_commute f"
   shows "Finite_Set.fold f A (Set t) = fold_keys f t A"
 using assms
 proof -
   interpret comp_fun_commute f by fact
   have "set (RBT.keys t) = fst ` (set (RBT.entries t))" by (auto simp: fst_eq_Domain keys_entries)
   moreover have "inj_on fst (set (RBT.entries t))" using distinct_entries distinct_map by auto
   ultimately show ?thesis 
     by (auto simp add: set_keys fold_keys_def curry_def fold_image finite_fold_rbt_fold_eq 
       comp_comp_fun_commute)
 qed
 
 definition rbt_filter :: "('a :: linorder \<Rightarrow> bool) \<Rightarrow> ('a, 'b) rbt \<Rightarrow> 'a set" where
   "rbt_filter P t = RBT.fold (\<lambda>k _ A'. if P k then Set.insert k A' else A') t {}"
 
 lemma Set_filter_rbt_filter:
   "Set.filter P (Set t) = rbt_filter P t"
 by (simp add: fold_keys_def Set_filter_fold rbt_filter_def 
   finite_fold_fold_keys[OF comp_fun_commute_filter_fold])
 
 
 subsection \<open>foldi and Ball\<close>
 
 lemma Ball_False: "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t False = False"
 by (induction t) auto
 
 lemma rbt_foldi_fold_conj: 
   "RBT_Impl.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t val"
 proof (induction t arbitrary: val) 
   case (Branch c t1) then show ?case
     by (cases "RBT_Impl.fold (\<lambda>k v s. s \<and> P k) t1 True") (simp_all add: Ball_False) 
 qed simp
 
 lemma foldi_fold_conj: "RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t val = fold_keys (\<lambda>k s. s \<and> P k) t val"
 unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_conj)
 
 
 subsection \<open>foldi and Bex\<close>
 
 lemma Bex_True: "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t True = True"
 by (induction t) auto
 
 lemma rbt_foldi_fold_disj: 
   "RBT_Impl.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t val"
 proof (induction t arbitrary: val) 
   case (Branch c t1) then show ?case
     by (cases "RBT_Impl.fold (\<lambda>k v s. s \<or> P k) t1 False") (simp_all add: Bex_True) 
 qed simp
 
 lemma foldi_fold_disj: "RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t val = fold_keys (\<lambda>k s. s \<or> P k) t val"
 unfolding fold_keys_def including rbt.lifting by transfer (rule rbt_foldi_fold_disj)
 
 
 subsection \<open>folding over non empty trees and selecting the minimal and maximal element\<close>
 
 subsubsection \<open>concrete\<close>
 
 text \<open>The concrete part is here because it's probably not general enough to be moved to \<open>RBT_Impl\<close>\<close>
 
 definition rbt_fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) RBT_Impl.rbt \<Rightarrow> 'a" 
   where "rbt_fold1_keys f t = List.fold f (tl(RBT_Impl.keys t)) (hd(RBT_Impl.keys t))"
 
 
 paragraph \<open>minimum\<close>
 
 definition rbt_min :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a" 
   where "rbt_min t = rbt_fold1_keys min t"
 
 lemma key_le_right: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys rt) \<Longrightarrow> k \<le> x)"
 by  (auto simp: rbt_greater_prop less_imp_le)
 
 lemma left_le_key: "rbt_sorted (Branch c lt k v rt) \<Longrightarrow> (\<And>x. x \<in>set (RBT_Impl.keys lt) \<Longrightarrow> x \<le> k)"
 by (auto simp: rbt_less_prop less_imp_le)
 
 lemma fold_min_triv:
   fixes k :: "_ :: linorder"
   shows "(\<forall>x\<in>set xs. k \<le> x) \<Longrightarrow> List.fold min xs k = k" 
 by (induct xs) (auto simp add: min_def)
 
 lemma rbt_min_simps:
   "is_rbt (Branch c RBT_Impl.Empty k v rt) \<Longrightarrow> rbt_min (Branch c RBT_Impl.Empty k v rt) = k"
 by (auto intro: fold_min_triv dest: key_le_right is_rbt_rbt_sorted simp: rbt_fold1_keys_def rbt_min_def)
 
 fun rbt_min_opt where
   "rbt_min_opt (Branch c RBT_Impl.Empty k v rt) = k" |
   "rbt_min_opt (Branch c (Branch lc llc lk lv lrt) k v rt) = rbt_min_opt (Branch lc llc lk lv lrt)"
 
 lemma rbt_min_opt_Branch:
   "t1 \<noteq> rbt.Empty \<Longrightarrow> rbt_min_opt (Branch c t1 k () t2) = rbt_min_opt t1" 
 by (cases t1) auto
 
 lemma rbt_min_opt_induct [case_names empty left_empty left_non_empty]:
   fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
   assumes "P rbt.Empty"
   assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
   assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t1 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
   shows "P t"
   using assms
 proof (induct t)
   case Empty
   then show ?case by simp
 next
   case (Branch x1 t1 x3 x4 t2)
   then show ?case by (cases "t1 = rbt.Empty") simp_all
 qed
 
 lemma rbt_min_opt_in_set: 
   fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
   assumes "t \<noteq> rbt.Empty"
   shows "rbt_min_opt t \<in> set (RBT_Impl.keys t)"
 using assms by (induction t rule: rbt_min_opt.induct) (auto)
 
 lemma rbt_min_opt_is_min:
   fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
   assumes "rbt_sorted t"
   assumes "t \<noteq> rbt.Empty"
   shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<ge> rbt_min_opt t"
 using assms 
 proof (induction t rule: rbt_min_opt_induct)
   case empty
   then show ?case by simp
 next
   case left_empty
   then show ?case by (auto intro: key_le_right simp del: rbt_sorted.simps)
 next
   case (left_non_empty c t1 k v t2 y)
   then consider "y = k" | "y \<in> set (RBT_Impl.keys t1)" | "y \<in> set (RBT_Impl.keys t2)"
     by auto
   then show ?case 
   proof cases
     case 1
     with left_non_empty show ?thesis
       by (auto simp add: rbt_min_opt_Branch intro: left_le_key rbt_min_opt_in_set)
   next
     case 2
     with left_non_empty show ?thesis
       by (auto simp add: rbt_min_opt_Branch)
   next 
     case y: 3
     have "rbt_min_opt t1 \<le> k"
       using left_non_empty by (simp add: left_le_key rbt_min_opt_in_set)
     moreover have "k \<le> y"
       using left_non_empty y by (simp add: key_le_right)
     ultimately show ?thesis
       using left_non_empty y by (simp add: rbt_min_opt_Branch)
   qed
 qed
 
 lemma rbt_min_eq_rbt_min_opt:
   assumes "t \<noteq> RBT_Impl.Empty"
   assumes "is_rbt t"
   shows "rbt_min t = rbt_min_opt t"
 proof -
   from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
   with assms show ?thesis
     by (simp add: rbt_min_def rbt_fold1_keys_def rbt_min_opt_is_min
       Min.set_eq_fold [symmetric] Min_eqI rbt_min_opt_in_set)
 qed
 
 
 paragraph \<open>maximum\<close>
 
 definition rbt_max :: "('a::linorder, unit) RBT_Impl.rbt \<Rightarrow> 'a" 
   where "rbt_max t = rbt_fold1_keys max t"
 
 lemma fold_max_triv:
   fixes k :: "_ :: linorder"
   shows "(\<forall>x\<in>set xs. x \<le> k) \<Longrightarrow> List.fold max xs k = k" 
 by (induct xs) (auto simp add: max_def)
 
 lemma fold_max_rev_eq:
   fixes xs :: "('a :: linorder) list"
   assumes "xs \<noteq> []"
   shows "List.fold max (tl xs) (hd xs) = List.fold max (tl (rev xs)) (hd (rev xs))" 
   using assms by (simp add: Max.set_eq_fold [symmetric])
 
 lemma rbt_max_simps:
   assumes "is_rbt (Branch c lt k v RBT_Impl.Empty)" 
   shows "rbt_max (Branch c lt k v RBT_Impl.Empty) = k"
 proof -
   have "List.fold max (tl (rev(RBT_Impl.keys lt @ [k]))) (hd (rev(RBT_Impl.keys lt @ [k]))) = k"
     using assms by (auto intro!: fold_max_triv dest!: left_le_key is_rbt_rbt_sorted)
   then show ?thesis by (auto simp add: rbt_max_def rbt_fold1_keys_def fold_max_rev_eq)
 qed
 
 fun rbt_max_opt where
   "rbt_max_opt (Branch c lt k v RBT_Impl.Empty) = k" |
   "rbt_max_opt (Branch c lt k v (Branch rc rlc rk rv rrt)) = rbt_max_opt (Branch rc rlc rk rv rrt)"
 
 lemma rbt_max_opt_Branch:
   "t2 \<noteq> rbt.Empty \<Longrightarrow> rbt_max_opt (Branch c t1 k () t2) = rbt_max_opt t2" 
 by (cases t2) auto
 
 lemma rbt_max_opt_induct [case_names empty right_empty right_non_empty]:
   fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
   assumes "P rbt.Empty"
   assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 = rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
   assumes "\<And>color t1 a b t2. P t1 \<Longrightarrow> P t2 \<Longrightarrow> t2 \<noteq> rbt.Empty \<Longrightarrow> P (Branch color t1 a b t2)"
   shows "P t"
   using assms
 proof (induct t)
   case Empty
   then show ?case by simp
 next
   case (Branch x1 t1 x3 x4 t2)
   then show ?case by (cases "t2 = rbt.Empty") simp_all
 qed
 
 lemma rbt_max_opt_in_set: 
   fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
   assumes "t \<noteq> rbt.Empty"
   shows "rbt_max_opt t \<in> set (RBT_Impl.keys t)"
 using assms by (induction t rule: rbt_max_opt.induct) (auto)
 
 lemma rbt_max_opt_is_max:
   fixes t :: "('a :: linorder, unit) RBT_Impl.rbt"
   assumes "rbt_sorted t"
   assumes "t \<noteq> rbt.Empty"
   shows "\<And>y. y \<in> set (RBT_Impl.keys t) \<Longrightarrow> y \<le> rbt_max_opt t"
 using assms 
 proof (induction t rule: rbt_max_opt_induct)
   case empty
   then show ?case by simp
 next
   case right_empty
   then show ?case by (auto intro: left_le_key simp del: rbt_sorted.simps)
 next
   case (right_non_empty c t1 k v t2 y)
   then consider "y = k" | "y \<in> set (RBT_Impl.keys t2)" | "y \<in> set (RBT_Impl.keys t1)"
     by auto
   then show ?case 
   proof cases
     case 1
     with right_non_empty show ?thesis
       by (auto simp add: rbt_max_opt_Branch intro: key_le_right rbt_max_opt_in_set)
   next
     case 2
     with right_non_empty show ?thesis
       by (auto simp add: rbt_max_opt_Branch)
   next 
     case y: 3
     have "rbt_max_opt t2 \<ge> k"
       using right_non_empty by (simp add: key_le_right rbt_max_opt_in_set)
     moreover have "y \<le> k"
       using right_non_empty y by (simp add: left_le_key)
     ultimately show ?thesis
       using right_non_empty by (simp add: rbt_max_opt_Branch)
   qed
 qed
 
 lemma rbt_max_eq_rbt_max_opt:
   assumes "t \<noteq> RBT_Impl.Empty"
   assumes "is_rbt t"
   shows "rbt_max t = rbt_max_opt t"
 proof -
   from assms have "hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t) = RBT_Impl.keys t" by (cases t) simp_all
   with assms show ?thesis
     by (simp add: rbt_max_def rbt_fold1_keys_def rbt_max_opt_is_max
       Max.set_eq_fold [symmetric] Max_eqI rbt_max_opt_in_set)
 qed
 
 
 subsubsection \<open>abstract\<close>
 
 context includes rbt.lifting begin
 lift_definition fold1_keys :: "('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('a::linorder, 'b) rbt \<Rightarrow> 'a"
   is rbt_fold1_keys .
 
 lemma fold1_keys_def_alt:
   "fold1_keys f t = List.fold f (tl (RBT.keys t)) (hd (RBT.keys t))"
   by transfer (simp add: rbt_fold1_keys_def)
 
 lemma finite_fold1_fold1_keys:
   assumes "semilattice f"
   assumes "\<not> RBT.is_empty t"
   shows "semilattice_set.F f (Set t) = fold1_keys f t"
 proof -
   from \<open>semilattice f\<close> interpret semilattice_set f by (rule semilattice_set.intro)
   show ?thesis using assms 
     by (auto simp: fold1_keys_def_alt set_keys fold_def_alt non_empty_keys set_eq_fold [symmetric])
 qed
 
 
 paragraph \<open>minimum\<close>
 
 lift_definition r_min :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min .
 
 lift_definition r_min_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_min_opt .
 
 lemma r_min_alt_def: "r_min t = fold1_keys min t"
 by transfer (simp add: rbt_min_def)
 
 lemma r_min_eq_r_min_opt:
   assumes "\<not> (RBT.is_empty t)"
   shows "r_min t = r_min_opt t"
 using assms unfolding is_empty_empty by transfer (auto intro: rbt_min_eq_rbt_min_opt)
 
 lemma fold_keys_min_top_eq:
   fixes t :: "('a::{linorder,bounded_lattice_top}, unit) rbt"
   assumes "\<not> (RBT.is_empty t)"
   shows "fold_keys min t top = fold1_keys min t"
 proof -
   have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold min (RBT_Impl.keys t) top = 
       List.fold min (hd (RBT_Impl.keys t) # tl (RBT_Impl.keys t)) top"
     by (simp add: hd_Cons_tl[symmetric])
   have **: "List.fold min (x # xs) top = List.fold min xs x" for x :: 'a and xs
     by (simp add: inf_min[symmetric])
   show ?thesis
     using assms
     unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
     apply transfer 
     apply (case_tac t) 
      apply simp 
     apply (subst *)
      apply simp
     apply (subst **)
     apply simp
     done
 qed
 
 
 paragraph \<open>maximum\<close>
 
 lift_definition r_max :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max .
 
 lift_definition r_max_opt :: "('a :: linorder, unit) rbt \<Rightarrow> 'a" is rbt_max_opt .
 
 lemma r_max_alt_def: "r_max t = fold1_keys max t"
 by transfer (simp add: rbt_max_def)
 
 lemma r_max_eq_r_max_opt:
   assumes "\<not> (RBT.is_empty t)"
   shows "r_max t = r_max_opt t"
 using assms unfolding is_empty_empty by transfer (auto intro: rbt_max_eq_rbt_max_opt)
 
 lemma fold_keys_max_bot_eq:
   fixes t :: "('a::{linorder,bounded_lattice_bot}, unit) rbt"
   assumes "\<not> (RBT.is_empty t)"
   shows "fold_keys max t bot = fold1_keys max t"
 proof -
   have *: "\<And>t. RBT_Impl.keys t \<noteq> [] \<Longrightarrow> List.fold max (RBT_Impl.keys t) bot = 
       List.fold max (hd(RBT_Impl.keys t) # tl(RBT_Impl.keys t)) bot"
     by (simp add: hd_Cons_tl[symmetric])
   have **: "List.fold max (x # xs) bot = List.fold max xs x" for x :: 'a and xs
     by (simp add: sup_max[symmetric])
   show ?thesis
     using assms
     unfolding fold_keys_def_alt fold1_keys_def_alt is_empty_empty
     apply transfer 
     apply (case_tac t) 
      apply simp 
     apply (subst *)
      apply simp
     apply (subst **)
     apply simp
     done
 qed
 
 end
 
 section \<open>Code equations\<close>
 
 code_datatype Set Coset
 
 declare list.set[code] (* needed? *)
 
 lemma empty_Set [code]:
   "Set.empty = Set RBT.empty"
 by (auto simp: Set_def)
 
 lemma UNIV_Coset [code]:
   "UNIV = Coset RBT.empty"
 by (auto simp: Set_def)
 
 lemma is_empty_Set [code]:
   "Set.is_empty (Set t) = RBT.is_empty t"
   unfolding Set.is_empty_def by (auto simp: fun_eq_iff Set_def intro: lookup_empty_empty[THEN iffD1])
 
 lemma compl_code [code]:
   "- Set xs = Coset xs"
   "- Coset xs = Set xs"
 by (simp_all add: Set_def)
 
 lemma member_code [code]:
   "x \<in> (Set t) = (RBT.lookup t x = Some ())"
   "x \<in> (Coset t) = (RBT.lookup t x = None)"
 by (simp_all add: Set_def)
 
 lemma insert_code [code]:
   "Set.insert x (Set t) = Set (RBT.insert x () t)"
   "Set.insert x (Coset t) = Coset (RBT.delete x t)"
 by (auto simp: Set_def)
 
 lemma remove_code [code]:
   "Set.remove x (Set t) = Set (RBT.delete x t)"
   "Set.remove x (Coset t) = Coset (RBT.insert x () t)"
 by (auto simp: Set_def)
 
 lemma union_Set [code]:
   "Set t \<union> A = fold_keys Set.insert t A"
 proof -
   interpret comp_fun_idem Set.insert
     by (fact comp_fun_idem_insert)
   from finite_fold_fold_keys[OF comp_fun_commute_axioms]
   show ?thesis by (auto simp add: union_fold_insert)
 qed
 
 lemma inter_Set [code]:
   "A \<inter> Set t = rbt_filter (\<lambda>k. k \<in> A) t"
 by (simp add: inter_Set_filter Set_filter_rbt_filter)
 
 lemma minus_Set [code]:
   "A - Set t = fold_keys Set.remove t A"
 proof -
   interpret comp_fun_idem Set.remove
     by (fact comp_fun_idem_remove)
   from finite_fold_fold_keys[OF comp_fun_commute_axioms]
   show ?thesis by (auto simp add: minus_fold_remove)
 qed
 
 lemma union_Coset [code]:
   "Coset t \<union> A = - rbt_filter (\<lambda>k. k \<notin> A) t"
 proof -
   have *: "\<And>A B. (-A \<union> B) = -(-B \<inter> A)" by blast
   show ?thesis by (simp del: boolean_algebra_class.compl_inf add: * inter_Set)
 qed
  
 lemma union_Set_Set [code]:
   "Set t1 \<union> Set t2 = Set (RBT.union t1 t2)"
 by (auto simp add: lookup_union map_add_Some_iff Set_def)
 
 lemma inter_Coset [code]:
   "A \<inter> Coset t = fold_keys Set.remove t A"
 by (simp add: Diff_eq [symmetric] minus_Set)
 
 lemma inter_Coset_Coset [code]:
   "Coset t1 \<inter> Coset t2 = Coset (RBT.union t1 t2)"
 by (auto simp add: lookup_union map_add_Some_iff Set_def)
 
 lemma minus_Coset [code]:
   "A - Coset t = rbt_filter (\<lambda>k. k \<in> A) t"
 by (simp add: inter_Set[simplified Int_commute])
 
 lemma filter_Set [code]:
   "Set.filter P (Set t) = (rbt_filter P t)"
 by (auto simp add: Set_filter_rbt_filter)
 
 lemma image_Set [code]:
   "image f (Set t) = fold_keys (\<lambda>k A. Set.insert (f k) A) t {}"
 proof -
   have "comp_fun_commute (\<lambda>k. Set.insert (f k))"
     by standard auto
   then show ?thesis
     by (auto simp add: image_fold_insert intro!: finite_fold_fold_keys)
 qed
 
 lemma Ball_Set [code]:
   "Ball (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> P k) t True"
 proof -
   have "comp_fun_commute (\<lambda>k s. s \<and> P k)"
     by standard auto
   then show ?thesis 
     by (simp add: foldi_fold_conj[symmetric] Ball_fold finite_fold_fold_keys)
 qed
 
 lemma Bex_Set [code]:
   "Bex (Set t) P \<longleftrightarrow> RBT.foldi (\<lambda>s. s = False) (\<lambda>k v s. s \<or> P k) t False"
 proof -
   have "comp_fun_commute (\<lambda>k s. s \<or> P k)"
     by standard auto
   then show ?thesis 
     by (simp add: foldi_fold_disj[symmetric] Bex_fold finite_fold_fold_keys)
 qed
 
 lemma subset_code [code]:
   "Set t \<le> B \<longleftrightarrow> (\<forall>x\<in>Set t. x \<in> B)"
   "A \<le> Coset t \<longleftrightarrow> (\<forall>y\<in>Set t. y \<notin> A)"
 by auto
 
 lemma subset_Coset_empty_Set_empty [code]:
   "Coset t1 \<le> Set t2 \<longleftrightarrow> (case (RBT.impl_of t1, RBT.impl_of t2) of 
     (rbt.Empty, rbt.Empty) \<Rightarrow> False |
     (_, _) \<Rightarrow> Code.abort (STR ''non_empty_trees'') (\<lambda>_. Coset t1 \<le> Set t2))"
 proof -
   have *: "\<And>t. RBT.impl_of t = rbt.Empty \<Longrightarrow> t = RBT rbt.Empty"
     by (subst(asm) RBT_inverse[symmetric]) (auto simp: impl_of_inject)
   have **: "eq_onp is_rbt rbt.Empty rbt.Empty" unfolding eq_onp_def by simp
   show ?thesis  
     by (auto simp: Set_def lookup.abs_eq[OF **] dest!: * split: rbt.split)
 qed
 
 text \<open>A frequent case -- avoid intermediate sets\<close>
 lemma [code_unfold]:
   "Set t1 \<subseteq> Set t2 \<longleftrightarrow> RBT.foldi (\<lambda>s. s = True) (\<lambda>k v s. s \<and> k \<in> Set t2) t1 True"
 by (simp add: subset_code Ball_Set)
 
 lemma card_Set [code]:
   "card (Set t) = fold_keys (\<lambda>_ n. n + 1) t 0"
   by (auto simp add: card.eq_fold intro: finite_fold_fold_keys comp_fun_commute_const)
 
 lemma sum_Set [code]:
   "sum f (Set xs) = fold_keys (plus \<circ> f) xs 0"
 proof -
   have "comp_fun_commute (\<lambda>x. (+) (f x))"
     by standard (auto simp: ac_simps)
   then show ?thesis 
     by (auto simp add: sum.eq_fold finite_fold_fold_keys o_def)
 qed
 
 lemma the_elem_set [code]:
   fixes t :: "('a :: linorder, unit) rbt"
   shows "the_elem (Set t) = (case RBT.impl_of t of 
     (Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty) \<Rightarrow> x
     | _ \<Rightarrow> Code.abort (STR ''not_a_singleton_tree'') (\<lambda>_. the_elem (Set t)))"
 proof -
   {
     fix x :: "'a :: linorder"
     let ?t = "Branch RBT_Impl.B RBT_Impl.Empty x () RBT_Impl.Empty" 
     have *:"?t \<in> {t. is_rbt t}" unfolding is_rbt_def by auto
     then have **:"eq_onp is_rbt ?t ?t" unfolding eq_onp_def by auto
 
     have "RBT.impl_of t = ?t \<Longrightarrow> the_elem (Set t) = x" 
       by (subst(asm) RBT_inverse[symmetric, OF *])
         (auto simp: Set_def the_elem_def lookup.abs_eq[OF **] impl_of_inject)
   }
   then show ?thesis
     by(auto split: rbt.split unit.split color.split)
 qed
 
 lemma Pow_Set [code]: "Pow (Set t) = fold_keys (\<lambda>x A. A \<union> Set.insert x ` A) t {{}}"
   by (simp add: Pow_fold finite_fold_fold_keys[OF comp_fun_commute_Pow_fold])
 
 lemma product_Set [code]:
   "Product_Type.product (Set t1) (Set t2) = 
     fold_keys (\<lambda>x A. fold_keys (\<lambda>y. Set.insert (x, y)) t2 A) t1 {}"
 proof -
   have *: "comp_fun_commute (\<lambda>y. Set.insert (x, y))" for x
     by standard auto
   show ?thesis using finite_fold_fold_keys[OF comp_fun_commute_product_fold, of "Set t2" "{}" "t1"]  
     by (simp add: product_fold Product_Type.product_def finite_fold_fold_keys[OF *])
 qed
 
 lemma Id_on_Set [code]: "Id_on (Set t) =  fold_keys (\<lambda>x. Set.insert (x, x)) t {}"
 proof -
   have "comp_fun_commute (\<lambda>x. Set.insert (x, x))"
     by standard auto
   then show ?thesis
     by (auto simp add: Id_on_fold intro!: finite_fold_fold_keys)
 qed
 
 lemma Image_Set [code]:
   "(Set t) `` S = fold_keys (\<lambda>(x,y) A. if x \<in> S then Set.insert y A else A) t {}"
 by (auto simp add: Image_fold finite_fold_fold_keys[OF comp_fun_commute_Image_fold])
 
 lemma trancl_set_ntrancl [code]:
   "trancl (Set t) = ntrancl (card (Set t) - 1) (Set t)"
 by (simp add: finite_trancl_ntranl)
 
 lemma relcomp_Set[code]:
   "(Set t1) O (Set t2) = fold_keys 
     (\<lambda>(x,y) A. fold_keys (\<lambda>(w,z) A'. if y = w then Set.insert (x,z) A' else A') t2 A) t1 {}"
 proof -
   interpret comp_fun_idem Set.insert
     by (fact comp_fun_idem_insert)
   have *: "\<And>x y. comp_fun_commute (\<lambda>(w, z) A'. if y = w then Set.insert (x, z) A' else A')"
     by standard (auto simp add: fun_eq_iff)
   show ?thesis
     using finite_fold_fold_keys[OF comp_fun_commute_relcomp_fold, of "Set t2" "{}" t1]
     by (simp add: relcomp_fold finite_fold_fold_keys[OF *])
 qed
 
 lemma wf_set [code]:
   "wf (Set t) = acyclic (Set t)"
 by (simp add: wf_iff_acyclic_if_finite)
 
 lemma Min_fin_set_fold [code]:
   "Min (Set t) = 
   (if RBT.is_empty t
    then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Min (Set t))
    else r_min_opt t)"
 proof -
   have *: "semilattice (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
   with finite_fold1_fold1_keys [OF *, folded Min_def]
   show ?thesis
     by (simp add: r_min_alt_def r_min_eq_r_min_opt [symmetric])  
 qed
 
 lemma Inf_fin_set_fold [code]:
   "Inf_fin (Set t) = Min (Set t)"
 by (simp add: inf_min Inf_fin_def Min_def)
 
 lemma Inf_Set_fold:
   fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
   shows "Inf (Set t) = (if RBT.is_empty t then top else r_min_opt t)"
 proof -
   have "comp_fun_commute (min :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)"
     by standard (simp add: fun_eq_iff ac_simps)
   then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold min top (Set t) = fold1_keys min t"
     by (simp add: finite_fold_fold_keys fold_keys_min_top_eq)
   then show ?thesis 
     by (auto simp add: Inf_fold_inf inf_min empty_Set[symmetric]
       r_min_eq_r_min_opt[symmetric] r_min_alt_def)
 qed
 
 lemma Max_fin_set_fold [code]:
   "Max (Set t) = 
   (if RBT.is_empty t
    then Code.abort (STR ''not_non_empty_tree'') (\<lambda>_. Max (Set t))
    else r_max_opt t)"
 proof -
   have *: "semilattice (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)" ..
   with finite_fold1_fold1_keys [OF *, folded Max_def]
   show ?thesis
     by (simp add: r_max_alt_def r_max_eq_r_max_opt [symmetric])  
 qed
 
 lemma Sup_fin_set_fold [code]:
   "Sup_fin (Set t) = Max (Set t)"
 by (simp add: sup_max Sup_fin_def Max_def)
 
 lemma Sup_Set_fold:
   fixes t :: "('a :: {linorder, complete_lattice}, unit) rbt"
   shows "Sup (Set t) = (if RBT.is_empty t then bot else r_max_opt t)"
 proof -
   have "comp_fun_commute (max :: 'a \<Rightarrow> 'a \<Rightarrow> 'a)"
     by standard (simp add: fun_eq_iff ac_simps)
   then have "t \<noteq> RBT.empty \<Longrightarrow> Finite_Set.fold max bot (Set t) = fold1_keys max t"
     by (simp add: finite_fold_fold_keys fold_keys_max_bot_eq)
   then show ?thesis 
     by (auto simp add: Sup_fold_sup sup_max empty_Set[symmetric]
       r_max_eq_r_max_opt[symmetric] r_max_alt_def)
 qed
 
 context
 begin
 
 qualified definition Inf' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a"
   where [code_abbrev]: "Inf' = Inf"
 
 lemma Inf'_Set_fold [code]:
   "Inf' (Set t) = (if RBT.is_empty t then top else r_min_opt t)"
   by (simp add: Inf'_def Inf_Set_fold)
 
 qualified definition Sup' :: "'a :: {linorder, complete_lattice} set \<Rightarrow> 'a"
   where [code_abbrev]: "Sup' = Sup"
 
 lemma Sup'_Set_fold [code]:
   "Sup' (Set t) = (if RBT.is_empty t then bot else r_max_opt t)"
   by (simp add: Sup'_def Sup_Set_fold)
 
 lemma [code drop: Gcd_fin, code]:
   "Gcd\<^sub>f\<^sub>i\<^sub>n (Set t) = fold_keys gcd t (0::'a::{semiring_gcd, linorder})"
 proof -
   have "comp_fun_commute (gcd :: 'a \<Rightarrow> _)"
     by standard (simp add: fun_eq_iff ac_simps)
   with finite_fold_fold_keys [of _ 0 t]
   have "Finite_Set.fold gcd 0 (Set t) = fold_keys gcd t 0"
     by blast
   then show ?thesis
     by (simp add: Gcd_fin.eq_fold)
 qed
     
 lemma [code drop: "Gcd :: _ \<Rightarrow> nat", code]:
   "Gcd (Set t) = (Gcd\<^sub>f\<^sub>i\<^sub>n (Set t) :: nat)"
   by simp
 
 lemma [code drop: "Gcd :: _ \<Rightarrow> int", code]:
   "Gcd (Set t) = (Gcd\<^sub>f\<^sub>i\<^sub>n (Set t) :: int)"
   by simp
 
 lemma [code drop: Lcm_fin,code]:
   "Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) = fold_keys lcm t (1::'a::{semiring_gcd, linorder})"
 proof -
   have "comp_fun_commute (lcm :: 'a \<Rightarrow> _)"
     by standard (simp add: fun_eq_iff ac_simps)
   with finite_fold_fold_keys [of _ 1 t]
   have "Finite_Set.fold lcm 1 (Set t) = fold_keys lcm t 1"
     by blast
   then show ?thesis
     by (simp add: Lcm_fin.eq_fold)
 qed
 
 qualified definition Lcm' :: "'a :: semiring_Gcd set \<Rightarrow> 'a"
   where [code_abbrev]: "Lcm' = Lcm"
 
 lemma [code drop: "Lcm :: _ \<Rightarrow> nat", code]:
   "Lcm (Set t) = (Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) :: nat)"
   by simp
 
 lemma [code drop: "Lcm :: _ \<Rightarrow> int", code]:
   "Lcm (Set t) = (Lcm\<^sub>f\<^sub>i\<^sub>n (Set t) :: int)"
   by simp
 
 end
 
 lemma sorted_list_set[code]: "sorted_list_of_set (Set t) = RBT.keys t"
   by (auto simp add: set_keys intro: sorted_distinct_set_unique) 
 
 lemma Bleast_code [code]:
   "Bleast (Set t) P =
     (case List.filter P (RBT.keys t) of
       x # xs \<Rightarrow> x
     | [] \<Rightarrow> abort_Bleast (Set t) P)"
 proof (cases "List.filter P (RBT.keys t)")
   case Nil
   thus ?thesis by (simp add: Bleast_def abort_Bleast_def)
 next
   case (Cons x ys)
   have "(LEAST x. x \<in> Set t \<and> P x) = x"
   proof (rule Least_equality)
     show "x \<in> Set t \<and> P x"
       using Cons[symmetric]
       by (auto simp add: set_keys Cons_eq_filter_iff)
     next
       fix y
       assume "y \<in> Set t \<and> P y"
       then show "x \<le> y"
         using Cons[symmetric]
         by(auto simp add: set_keys Cons_eq_filter_iff)
           (metis sorted_wrt.simps(2) sorted_append sorted_keys)
   qed
   thus ?thesis using Cons by (simp add: Bleast_def)
 qed
 
 hide_const (open) RBT_Set.Set RBT_Set.Coset
 
 end
diff --git a/src/HOL/Lifting_Set.thy b/src/HOL/Lifting_Set.thy
--- a/src/HOL/Lifting_Set.thy
+++ b/src/HOL/Lifting_Set.thy
@@ -1,332 +1,372 @@
 (*  Title:      HOL/Lifting_Set.thy
     Author:     Brian Huffman and Ondrej Kuncar
 *)
 
 section \<open>Setup for Lifting/Transfer for the set type\<close>
 
 theory Lifting_Set
 imports Lifting
 begin
 
 subsection \<open>Relator and predicator properties\<close>
 
 lemma rel_setD1: "\<lbrakk> rel_set R A B; x \<in> A \<rbrakk> \<Longrightarrow> \<exists>y \<in> B. R x y"
   and rel_setD2: "\<lbrakk> rel_set R A B; y \<in> B \<rbrakk> \<Longrightarrow> \<exists>x \<in> A. R x y"
   by (simp_all add: rel_set_def)
 
 lemma rel_set_conversep [simp]: "rel_set A\<inverse>\<inverse> = (rel_set A)\<inverse>\<inverse>"
   unfolding rel_set_def by auto
 
 lemma rel_set_eq [relator_eq]: "rel_set (=) = (=)"
   unfolding rel_set_def fun_eq_iff by auto
 
 lemma rel_set_mono[relator_mono]:
   assumes "A \<le> B"
   shows "rel_set A \<le> rel_set B"
   using assms unfolding rel_set_def by blast
 
 lemma rel_set_OO[relator_distr]: "rel_set R OO rel_set S = rel_set (R OO S)"
   apply (rule sym)
   apply (intro ext)
   subgoal for X Z
     apply (rule iffI)
     apply (rule relcomppI [where b="{y. (\<exists>x\<in>X. R x y) \<and> (\<exists>z\<in>Z. S y z)}"])
     apply (simp add: rel_set_def, fast)+
     done
   done
 
 lemma Domainp_set[relator_domain]:
   "Domainp (rel_set T) = (\<lambda>A. Ball A (Domainp T))"
   unfolding rel_set_def Domainp_iff[abs_def]
   apply (intro ext)
   apply (rule iffI) 
   apply blast
   subgoal for A by (rule exI [where x="{y. \<exists>x\<in>A. T x y}"]) fast
   done
 
 lemma left_total_rel_set[transfer_rule]: 
   "left_total A \<Longrightarrow> left_total (rel_set A)"
   unfolding left_total_def rel_set_def
   apply safe
   subgoal for X by (rule exI [where x="{y. \<exists>x\<in>X. A x y}"]) fast
   done
 
 lemma left_unique_rel_set[transfer_rule]: 
   "left_unique A \<Longrightarrow> left_unique (rel_set A)"
   unfolding left_unique_def rel_set_def
   by fast
 
 lemma right_total_rel_set [transfer_rule]:
   "right_total A \<Longrightarrow> right_total (rel_set A)"
   using left_total_rel_set[of "A\<inverse>\<inverse>"] by simp
 
 lemma right_unique_rel_set [transfer_rule]:
   "right_unique A \<Longrightarrow> right_unique (rel_set A)"
   unfolding right_unique_def rel_set_def by fast
 
 lemma bi_total_rel_set [transfer_rule]:
   "bi_total A \<Longrightarrow> bi_total (rel_set A)"
   by(simp add: bi_total_alt_def left_total_rel_set right_total_rel_set)
 
 lemma bi_unique_rel_set [transfer_rule]:
   "bi_unique A \<Longrightarrow> bi_unique (rel_set A)"
   unfolding bi_unique_def rel_set_def by fast
 
 lemma set_relator_eq_onp [relator_eq_onp]:
   "rel_set (eq_onp P) = eq_onp (\<lambda>A. Ball A P)"
   unfolding fun_eq_iff rel_set_def eq_onp_def Ball_def by fast
 
 lemma bi_unique_rel_set_lemma:
   assumes "bi_unique R" and "rel_set R X Y"
   obtains f where "Y = image f X" and "inj_on f X" and "\<forall>x\<in>X. R x (f x)"
 proof
   define f where "f x = (THE y. R x y)" for x
   { fix x assume "x \<in> X"
     with \<open>rel_set R X Y\<close> \<open>bi_unique R\<close> have "R x (f x)"
       by (simp add: bi_unique_def rel_set_def f_def) (metis theI)
     with assms \<open>x \<in> X\<close> 
     have  "R x (f x)" "\<forall>x'\<in>X. R x' (f x) \<longrightarrow> x = x'" "\<forall>y\<in>Y. R x y \<longrightarrow> y = f x" "f x \<in> Y"
       by (fastforce simp add: bi_unique_def rel_set_def)+ }
   note * = this
   moreover
   { fix y assume "y \<in> Y"
     with \<open>rel_set R X Y\<close> *(3) \<open>y \<in> Y\<close> have "\<exists>x\<in>X. y = f x"
       by (fastforce simp: rel_set_def) }
   ultimately show "\<forall>x\<in>X. R x (f x)" "Y = image f X" "inj_on f X"
     by (auto simp: inj_on_def image_iff)
 qed
 
 subsection \<open>Quotient theorem for the Lifting package\<close>
 
 lemma Quotient_set[quot_map]:
   assumes "Quotient R Abs Rep T"
   shows "Quotient (rel_set R) (image Abs) (image Rep) (rel_set T)"
   using assms unfolding Quotient_alt_def4
   apply (simp add: rel_set_OO[symmetric])
   apply (simp add: rel_set_def)
   apply fast
   done
 
 
 subsection \<open>Transfer rules for the Transfer package\<close>
 
 subsubsection \<open>Unconditional transfer rules\<close>
 
 context includes lifting_syntax
 begin
 
 lemma empty_transfer [transfer_rule]: "(rel_set A) {} {}"
   unfolding rel_set_def by simp
 
 lemma insert_transfer [transfer_rule]:
   "(A ===> rel_set A ===> rel_set A) insert insert"
   unfolding rel_fun_def rel_set_def by auto
 
 lemma union_transfer [transfer_rule]:
   "(rel_set A ===> rel_set A ===> rel_set A) union union"
   unfolding rel_fun_def rel_set_def by auto
 
 lemma Union_transfer [transfer_rule]:
   "(rel_set (rel_set A) ===> rel_set A) Union Union"
   unfolding rel_fun_def rel_set_def by simp fast
 
 lemma image_transfer [transfer_rule]:
   "((A ===> B) ===> rel_set A ===> rel_set B) image image"
   unfolding rel_fun_def rel_set_def by simp fast
 
 lemma UNION_transfer [transfer_rule]: \<comment> \<open>TODO deletion candidate\<close>
   "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) (\<lambda>A f. \<Union>(f ` A)) (\<lambda>A f. \<Union>(f ` A))"
   by transfer_prover
 
 lemma Ball_transfer [transfer_rule]:
   "(rel_set A ===> (A ===> (=)) ===> (=)) Ball Ball"
   unfolding rel_set_def rel_fun_def by fast
 
 lemma Bex_transfer [transfer_rule]:
   "(rel_set A ===> (A ===> (=)) ===> (=)) Bex Bex"
   unfolding rel_set_def rel_fun_def by fast
 
 lemma Pow_transfer [transfer_rule]:
   "(rel_set A ===> rel_set (rel_set A)) Pow Pow"
   apply (rule rel_funI)
   apply (rule rel_setI)
   subgoal for X Y X'
     apply (rule rev_bexI [where x="{y\<in>Y. \<exists>x\<in>X'. A x y}"])
     apply clarsimp
     apply (simp add: rel_set_def)
     apply fast
     done
   subgoal for X Y Y'
     apply (rule rev_bexI [where x="{x\<in>X. \<exists>y\<in>Y'. A x y}"])
     apply clarsimp
     apply (simp add: rel_set_def)
     apply fast
     done
   done
 
 lemma rel_set_transfer [transfer_rule]:
   "((A ===> B ===> (=)) ===> rel_set A ===> rel_set B ===> (=)) rel_set rel_set"
   unfolding rel_fun_def rel_set_def by fast
 
 lemma bind_transfer [transfer_rule]:
   "(rel_set A ===> (A ===> rel_set B) ===> rel_set B) Set.bind Set.bind"
   unfolding bind_UNION [abs_def] by transfer_prover
 
 lemma INF_parametric [transfer_rule]: \<comment> \<open>TODO deletion candidate\<close>
   "(rel_set A ===> (A ===> HOL.eq) ===> HOL.eq) (\<lambda>A f. Inf (f ` A)) (\<lambda>A f. Inf (f ` A))"
   by transfer_prover
 
 lemma SUP_parametric [transfer_rule]: \<comment> \<open>TODO deletion candidate\<close>
   "(rel_set R ===> (R ===> HOL.eq) ===> HOL.eq) (\<lambda>A f. Sup (f ` A)) (\<lambda>A f. Sup (f ` A))"
   by transfer_prover
 
 
 subsubsection \<open>Rules requiring bi-unique, bi-total or right-total relations\<close>
 
 lemma member_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(A ===> rel_set A ===> (=)) (\<in>) (\<in>)"
   using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast
 
 lemma right_total_Collect_transfer[transfer_rule]:
   assumes "right_total A"
   shows "((A ===> (=)) ===> rel_set A) (\<lambda>P. Collect (\<lambda>x. P x \<and> Domainp A x)) Collect"
   using assms unfolding right_total_def rel_set_def rel_fun_def Domainp_iff by fast
 
 lemma Collect_transfer [transfer_rule]:
   assumes "bi_total A"
   shows "((A ===> (=)) ===> rel_set A) Collect Collect"
   using assms unfolding rel_fun_def rel_set_def bi_total_def by fast
 
 lemma inter_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(rel_set A ===> rel_set A ===> rel_set A) inter inter"
   using assms unfolding rel_fun_def rel_set_def bi_unique_def by fast
 
 lemma Diff_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(rel_set A ===> rel_set A ===> rel_set A) (-) (-)"
   using assms unfolding rel_fun_def rel_set_def bi_unique_def
   unfolding Ball_def Bex_def Diff_eq
   by (safe, simp, metis, simp, metis)
 
 lemma subset_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(rel_set A ===> rel_set A ===> (=)) (\<subseteq>) (\<subseteq>)"
   unfolding subset_eq [abs_def] by transfer_prover
 
 context
   includes lifting_syntax
 begin
 
 lemma strict_subset_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(rel_set A ===> rel_set A ===> (=)) (\<subset>) (\<subset>)"
   unfolding subset_not_subset_eq by transfer_prover
 
 end
 
 declare right_total_UNIV_transfer[transfer_rule]
 
 lemma UNIV_transfer [transfer_rule]:
   assumes "bi_total A"
   shows "(rel_set A) UNIV UNIV"
   using assms unfolding rel_set_def bi_total_def by simp
 
 lemma right_total_Compl_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
   shows "(rel_set A ===> rel_set A) (\<lambda>S. uminus S \<inter> Collect (Domainp A)) uminus"
   unfolding Compl_eq [abs_def]
   by (subst Collect_conj_eq[symmetric]) transfer_prover
 
 lemma Compl_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
   shows "(rel_set A ===> rel_set A) uminus uminus"
   unfolding Compl_eq [abs_def] by transfer_prover
 
 lemma right_total_Inter_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "right_total A"
   shows "(rel_set (rel_set A) ===> rel_set A) (\<lambda>S. \<Inter>S \<inter> Collect (Domainp A)) Inter"
   unfolding Inter_eq[abs_def]
   by (subst Collect_conj_eq[symmetric]) transfer_prover
 
 lemma Inter_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" and [transfer_rule]: "bi_total A"
   shows "(rel_set (rel_set A) ===> rel_set A) Inter Inter"
   unfolding Inter_eq [abs_def] by transfer_prover
 
 lemma filter_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "((A ===> (=)) ===> rel_set A ===> rel_set A) Set.filter Set.filter"
   unfolding Set.filter_def[abs_def] rel_fun_def rel_set_def by blast
 
 lemma finite_transfer [transfer_rule]:
   "bi_unique A \<Longrightarrow> (rel_set A ===> (=)) finite finite"
   by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
      (auto dest: finite_imageD)
 
 lemma card_transfer [transfer_rule]:
   "bi_unique A \<Longrightarrow> (rel_set A ===> (=)) card card"
   by (rule rel_funI, erule (1) bi_unique_rel_set_lemma)
      (simp add: card_image)
 
 context
   includes lifting_syntax
 begin
 
 lemma vimage_right_total_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_unique B" "right_total A"
   shows "((A ===> B) ===> rel_set B ===> rel_set A) (\<lambda>f X. f -` X \<inter> Collect (Domainp A)) vimage"
 proof -
   let ?vimage = "(\<lambda>f B. {x. f x \<in> B \<and> Domainp A x})"
   have "((A ===> B) ===> rel_set B ===> rel_set A) ?vimage vimage"
     unfolding vimage_def
     by transfer_prover
   also have "?vimage = (\<lambda>f X. f -` X \<inter> Collect (Domainp A))"
     by auto
   finally show ?thesis .
 qed
 
 end
 
 lemma vimage_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A" "bi_unique B"
   shows "((A ===> B) ===> rel_set B ===> rel_set A) vimage vimage"
   unfolding vimage_def[abs_def] by transfer_prover
 
 lemma Image_parametric [transfer_rule]:
   assumes "bi_unique A"
   shows "(rel_set (rel_prod A B) ===> rel_set A ===> rel_set B) (``) (``)"
   by (intro rel_funI rel_setI)
     (force dest: rel_setD1 bi_uniqueDr[OF assms], force dest: rel_setD2 bi_uniqueDl[OF assms])
 
 lemma inj_on_transfer[transfer_rule]:
   "((A ===> B) ===> rel_set A ===> (=)) inj_on inj_on"
   if [transfer_rule]: "bi_unique A" "bi_unique B"
   unfolding inj_on_def
   by transfer_prover
 
 end
 
 lemma (in comm_monoid_set) F_parametric [transfer_rule]:
   fixes A :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
   assumes "bi_unique A"
   shows "rel_fun (rel_fun A (=)) (rel_fun (rel_set A) (=)) F F"
 proof (rule rel_funI)+
   fix f :: "'b \<Rightarrow> 'a" and g S T
   assume "rel_fun A (=) f g" "rel_set A S T"
   with \<open>bi_unique A\<close> obtain i where "bij_betw i S T" "\<And>x. x \<in> S \<Longrightarrow> f x = g (i x)"
     by (auto elim: bi_unique_rel_set_lemma simp: rel_fun_def bij_betw_def)
   then show "F f S = F g T"
     by (simp add: reindex_bij_betw)
 qed
 
 lemmas sum_parametric = sum.F_parametric
 lemmas prod_parametric = prod.F_parametric
 
 lemma rel_set_UNION:
   assumes [transfer_rule]: "rel_set Q A B" "rel_fun Q (rel_set R) f g"
   shows "rel_set R (\<Union>(f ` A)) (\<Union>(g ` B))"
   by transfer_prover
 
+context
+  includes lifting_syntax
+begin
+
+lemma fold_graph_transfer[transfer_rule]:
+  assumes "bi_unique R" "right_total R"
+  shows "((R ===> (=) ===> (=)) ===> (=) ===> rel_set R ===> (=) ===> (=)) fold_graph fold_graph"
+proof(intro rel_funI)
+  fix f1 :: "'a \<Rightarrow> 'c \<Rightarrow> 'c" and f2 :: "'b \<Rightarrow> 'c \<Rightarrow> 'c"
+  assume rel_f: "(R ===> (=) ===> (=)) f1 f2"
+  fix z1 z2 :: 'c assume [simp]: "z1 = z2"
+  fix A1 A2 assume rel_A: "rel_set R A1 A2"
+  fix y1 y2 :: 'c assume [simp]: "y1 = y2"
+
+  from \<open>bi_unique R\<close> \<open>right_total R\<close> have The_y: "\<forall>y. \<exists>!x. R x y"
+    unfolding bi_unique_def right_total_def by auto
+  define r where "r \<equiv> \<lambda>y. THE x. R x y"
+  
+  from The_y have r_y: "R (r y) y" for y
+    unfolding r_def using the_equality by fastforce
+  with assms rel_A have "inj_on r A2" "A1 = r ` A2"
+    unfolding r_def rel_set_def inj_on_def bi_unique_def
+      apply(auto simp: image_iff) by metis+
+  with \<open>bi_unique R\<close> rel_f r_y have "(f1 o r) y = f2 y" for y
+    unfolding bi_unique_def rel_fun_def by auto
+  then have "(f1 o r) = f2"
+    by blast
+  then show "fold_graph f1 z1 A1 y1 = fold_graph f2 z2 A2 y2"
+    by (fastforce simp: fold_graph_image[OF \<open>inj_on r A2\<close>] \<open>A1 = r ` A2\<close>)
+qed
+
+lemma fold_transfer[transfer_rule]:
+  assumes [transfer_rule]: "bi_unique R" "right_total R"
+  shows "((R ===> (=) ===> (=)) ===> (=) ===> rel_set R ===> (=)) Finite_Set.fold Finite_Set.fold"
+  unfolding Finite_Set.fold_def
+  by transfer_prover
+
 end
+
+
+end
diff --git a/src/HOL/List.thy b/src/HOL/List.thy
--- a/src/HOL/List.thy
+++ b/src/HOL/List.thy
@@ -1,8217 +1,8327 @@
 (*  Title:      HOL/List.thy
     Author:     Tobias Nipkow; proofs tidied by LCP
 *)
 
 section \<open>The datatype of finite lists\<close>
 
 theory List
 imports Sledgehammer Code_Numeral Lifting_Set
 begin
 
 datatype (set: 'a) list =
     Nil  ("[]")
   | Cons (hd: 'a) (tl: "'a list")  (infixr "#" 65)
 for
   map: map
   rel: list_all2
   pred: list_all
 where
   "tl [] = []"
 
 datatype_compat list
 
 lemma [case_names Nil Cons, cases type: list]:
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   "(y = [] \<Longrightarrow> P) \<Longrightarrow> (\<And>a list. y = a # list \<Longrightarrow> P) \<Longrightarrow> P"
 by (rule list.exhaust)
 
 lemma [case_names Nil Cons, induct type: list]:
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   "P [] \<Longrightarrow> (\<And>a list. P list \<Longrightarrow> P (a # list)) \<Longrightarrow> P list"
 by (rule list.induct)
 
 text \<open>Compatibility:\<close>
 
 setup \<open>Sign.mandatory_path "list"\<close>
 
 lemmas inducts = list.induct
 lemmas recs = list.rec
 lemmas cases = list.case
 
 setup \<open>Sign.parent_path\<close>
 
 lemmas set_simps = list.set (* legacy *)
 
 syntax
   \<comment> \<open>list Enumeration\<close>
   "_list" :: "args => 'a list"    ("[(_)]")
 
 translations
   "[x, xs]" == "x#[xs]"
   "[x]" == "x#[]"
 
 
 subsection \<open>Basic list processing functions\<close>
 
 primrec (nonexhaustive) last :: "'a list \<Rightarrow> 'a" where
 "last (x # xs) = (if xs = [] then x else last xs)"
 
 primrec butlast :: "'a list \<Rightarrow> 'a list" where
 "butlast [] = []" |
 "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"
 
 lemma set_rec: "set xs = rec_list {} (\<lambda>x _. insert x) xs"
   by (induct xs) auto
 
 definition coset :: "'a list \<Rightarrow> 'a set" where
 [simp]: "coset xs = - set xs"
 
 primrec append :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" (infixr "@" 65) where
 append_Nil: "[] @ ys = ys" |
 append_Cons: "(x#xs) @ ys = x # xs @ ys"
 
 primrec rev :: "'a list \<Rightarrow> 'a list" where
 "rev [] = []" |
 "rev (x # xs) = rev xs @ [x]"
 
 primrec filter:: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "filter P [] = []" |
 "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"
 
 text \<open>Special input syntax for filter:\<close>
 syntax (ASCII)
   "_filter" :: "[pttrn, 'a list, bool] => 'a list"  ("(1[_<-_./ _])")
 syntax
   "_filter" :: "[pttrn, 'a list, bool] => 'a list"  ("(1[_\<leftarrow>_ ./ _])")
 translations
   "[x<-xs . P]" \<rightharpoonup> "CONST filter (\<lambda>x. P) xs"
 
 primrec fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
 fold_Nil:  "fold f [] = id" |
 fold_Cons: "fold f (x # xs) = fold f xs \<circ> f x"
 
 primrec foldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
 foldr_Nil:  "foldr f [] = id" |
 foldr_Cons: "foldr f (x # xs) = f x \<circ> foldr f xs"
 
 primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
 foldl_Nil:  "foldl f a [] = a" |
 foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"
 
 primrec concat:: "'a list list \<Rightarrow> 'a list" where
 "concat [] = []" |
 "concat (x # xs) = x @ concat xs"
 
 primrec drop:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 drop_Nil: "drop n [] = []" |
 drop_Cons: "drop n (x # xs) = (case n of 0 \<Rightarrow> x # xs | Suc m \<Rightarrow> drop m xs)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>n = 0\<close> and \<open>n = Suc k\<close>\<close>
 
 primrec take:: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 take_Nil:"take n [] = []" |
 take_Cons: "take n (x # xs) = (case n of 0 \<Rightarrow> [] | Suc m \<Rightarrow> x # take m xs)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>n = 0\<close> and \<open>n = Suc k\<close>\<close>
 
 primrec (nonexhaustive) nth :: "'a list => nat => 'a" (infixl "!" 100) where
 nth_Cons: "(x # xs) ! n = (case n of 0 \<Rightarrow> x | Suc k \<Rightarrow> xs ! k)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>n = 0\<close> and \<open>n = Suc k\<close>\<close>
 
 primrec list_update :: "'a list \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
 "list_update [] i v = []" |
 "list_update (x # xs) i v =
   (case i of 0 \<Rightarrow> v # xs | Suc j \<Rightarrow> x # list_update xs j v)"
 
 nonterminal lupdbinds and lupdbind
 
 syntax
   "_lupdbind":: "['a, 'a] => lupdbind"    ("(2_ :=/ _)")
   "" :: "lupdbind => lupdbinds"    ("_")
   "_lupdbinds" :: "[lupdbind, lupdbinds] => lupdbinds"    ("_,/ _")
   "_LUpdate" :: "['a, lupdbinds] => 'a"    ("_/[(_)]" [1000,0] 900)
 
 translations
   "_LUpdate xs (_lupdbinds b bs)" == "_LUpdate (_LUpdate xs b) bs"
   "xs[i:=x]" == "CONST list_update xs i x"
 
 primrec takeWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "takeWhile P [] = []" |
 "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"
 
 primrec dropWhile :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "dropWhile P [] = []" |
 "dropWhile P (x # xs) = (if P x then dropWhile P xs else x # xs)"
 
 primrec zip :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
 "zip xs [] = []" |
 zip_Cons: "zip xs (y # ys) =
   (case xs of [] \<Rightarrow> [] | z # zs \<Rightarrow> (z, y) # zip zs ys)"
   \<comment> \<open>Warning: simpset does not contain this definition, but separate
        theorems for \<open>xs = []\<close> and \<open>xs = z # zs\<close>\<close>
 
 abbreviation map2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list" where
 "map2 f xs ys \<equiv> map (\<lambda>(x,y). f x y) (zip xs ys)"
 
 primrec product :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
 "product [] _ = []" |
 "product (x#xs) ys = map (Pair x) ys @ product xs ys"
 
 hide_const (open) product
 
 primrec product_lists :: "'a list list \<Rightarrow> 'a list list" where
 "product_lists [] = [[]]" |
 "product_lists (xs # xss) = concat (map (\<lambda>x. map (Cons x) (product_lists xss)) xs)"
 
 primrec upt :: "nat \<Rightarrow> nat \<Rightarrow> nat list" ("(1[_..</_'])") where
 upt_0: "[i..<0] = []" |
 upt_Suc: "[i..<(Suc j)] = (if i \<le> j then [i..<j] @ [j] else [])"
 
 definition insert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "insert x xs = (if x \<in> set xs then xs else x # xs)"
 
 definition union :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "union = fold insert"
 
 hide_const (open) insert union
 hide_fact (open) insert_def union_def
 
 primrec find :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a option" where
 "find _ [] = None" |
 "find P (x#xs) = (if P x then Some x else find P xs)"
 
 text \<open>In the context of multisets, \<open>count_list\<close> is equivalent to
   \<^term>\<open>count \<circ> mset\<close> and it it advisable to use the latter.\<close>
 primrec count_list :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
 "count_list [] y = 0" |
 "count_list (x#xs) y = (if x=y then count_list xs y + 1 else count_list xs y)"
 
 definition
    "extract" :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> ('a list * 'a * 'a list) option"
 where "extract P xs =
   (case dropWhile (Not \<circ> P) xs of
      [] \<Rightarrow> None |
      y#ys \<Rightarrow> Some(takeWhile (Not \<circ> P) xs, y, ys))"
 
 hide_const (open) "extract"
 
 primrec those :: "'a option list \<Rightarrow> 'a list option"
 where
 "those [] = Some []" |
 "those (x # xs) = (case x of
   None \<Rightarrow> None
 | Some y \<Rightarrow> map_option (Cons y) (those xs))"
 
 primrec remove1 :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "remove1 x [] = []" |
 "remove1 x (y # xs) = (if x = y then xs else y # remove1 x xs)"
 
 primrec removeAll :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "removeAll x [] = []" |
 "removeAll x (y # xs) = (if x = y then removeAll x xs else y # removeAll x xs)"
 
 primrec distinct :: "'a list \<Rightarrow> bool" where
 "distinct [] \<longleftrightarrow> True" |
 "distinct (x # xs) \<longleftrightarrow> x \<notin> set xs \<and> distinct xs"
 
 fun successively :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 "successively P []  = True" |
 "successively P [x] = True" |
 "successively P (x # y # xs) = (P x y \<and> successively P (y#xs))"
 
 definition distinct_adj where
 "distinct_adj = successively (\<noteq>)"
 
 primrec remdups :: "'a list \<Rightarrow> 'a list" where
 "remdups [] = []" |
 "remdups (x # xs) = (if x \<in> set xs then remdups xs else x # remdups xs)"
 
 fun remdups_adj :: "'a list \<Rightarrow> 'a list" where
 "remdups_adj [] = []" |
 "remdups_adj [x] = [x]" |
 "remdups_adj (x # y # xs) = (if x = y then remdups_adj (x # xs) else x # remdups_adj (y # xs))"
 
 primrec replicate :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list" where
 replicate_0: "replicate 0 x = []" |
 replicate_Suc: "replicate (Suc n) x = x # replicate n x"
 
 text \<open>
   Function \<open>size\<close> is overloaded for all datatypes. Users may
   refer to the list version as \<open>length\<close>.\<close>
 
 abbreviation length :: "'a list \<Rightarrow> nat" where
 "length \<equiv> size"
 
 definition enumerate :: "nat \<Rightarrow> 'a list \<Rightarrow> (nat \<times> 'a) list" where
 enumerate_eq_zip: "enumerate n xs = zip [n..<n + length xs] xs"
 
 primrec rotate1 :: "'a list \<Rightarrow> 'a list" where
 "rotate1 [] = []" |
 "rotate1 (x # xs) = xs @ [x]"
 
 definition rotate :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "rotate n = rotate1 ^^ n"
 
 definition nths :: "'a list => nat set => 'a list" where
 "nths xs A = map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [0..<size xs]))"
 
 primrec subseqs :: "'a list \<Rightarrow> 'a list list" where
 "subseqs [] = [[]]" |
 "subseqs (x#xs) = (let xss = subseqs xs in map (Cons x) xss @ xss)"
 
 primrec n_lists :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
 "n_lists 0 xs = [[]]" |
 "n_lists (Suc n) xs = concat (map (\<lambda>ys. map (\<lambda>y. y # ys) xs) (n_lists n xs))"
 
 hide_const (open) n_lists
 
 function splice :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
 "splice [] ys = ys" |
 "splice (x#xs) ys = x # splice ys xs"
 by pat_completeness auto
 
 termination
 by(relation "measure(\<lambda>(xs,ys). size xs + size ys)") auto
 
 function shuffles where
   "shuffles [] ys = {ys}"
 | "shuffles xs [] = {xs}"
 | "shuffles (x # xs) (y # ys) = (#) x ` shuffles xs (y # ys) \<union> (#) y ` shuffles (x # xs) ys"
   by pat_completeness simp_all
 termination by lexicographic_order
 
 text\<open>Use only if you cannot use \<^const>\<open>Min\<close> instead:\<close>
 fun min_list :: "'a::ord list \<Rightarrow> 'a" where
 "min_list (x # xs) = (case xs of [] \<Rightarrow> x | _ \<Rightarrow> min x (min_list xs))"
 
 text\<open>Returns first minimum:\<close>
 fun arg_min_list :: "('a \<Rightarrow> ('b::linorder)) \<Rightarrow> 'a list \<Rightarrow> 'a" where
 "arg_min_list f [x] = x" |
 "arg_min_list f (x#y#zs) = (let m = arg_min_list f (y#zs) in if f x \<le> f m then x else m)"
 
 text\<open>
 \begin{figure}[htbp]
 \fbox{
 \begin{tabular}{l}
 @{lemma "[a,b]@[c,d] = [a,b,c,d]" by simp}\\
 @{lemma "length [a,b,c] = 3" by simp}\\
 @{lemma "set [a,b,c] = {a,b,c}" by simp}\\
 @{lemma "map f [a,b,c] = [f a, f b, f c]" by simp}\\
 @{lemma "rev [a,b,c] = [c,b,a]" by simp}\\
 @{lemma "hd [a,b,c,d] = a" by simp}\\
 @{lemma "tl [a,b,c,d] = [b,c,d]" by simp}\\
 @{lemma "last [a,b,c,d] = d" by simp}\\
 @{lemma "butlast [a,b,c,d] = [a,b,c]" by simp}\\
 @{lemma[source] "filter (\<lambda>n::nat. n<2) [0,2,1] = [0,1]" by simp}\\
 @{lemma "concat [[a,b],[c,d,e],[],[f]] = [a,b,c,d,e,f]" by simp}\\
 @{lemma "fold f [a,b,c] x = f c (f b (f a x))" by simp}\\
 @{lemma "foldr f [a,b,c] x = f a (f b (f c x))" by simp}\\
 @{lemma "foldl f x [a,b,c] = f (f (f x a) b) c" by simp}\\
 @{lemma "successively (\<noteq>) [True,False,True,False]" by simp}\\
 @{lemma "zip [a,b,c] [x,y,z] = [(a,x),(b,y),(c,z)]" by simp}\\
 @{lemma "zip [a,b] [x,y,z] = [(a,x),(b,y)]" by simp}\\
 @{lemma "enumerate 3 [a,b,c] = [(3,a),(4,b),(5,c)]" by normalization}\\
 @{lemma "List.product [a,b] [c,d] = [(a, c), (a, d), (b, c), (b, d)]" by simp}\\
 @{lemma "product_lists [[a,b], [c], [d,e]] = [[a,c,d], [a,c,e], [b,c,d], [b,c,e]]" by simp}\\
 @{lemma "splice [a,b,c] [x,y,z] = [a,x,b,y,c,z]" by simp}\\
 @{lemma "splice [a,b,c,d] [x,y] = [a,x,b,y,c,d]" by simp}\\
 @{lemma "shuffles [a,b] [c,d] =  {[a,b,c,d],[a,c,b,d],[a,c,d,b],[c,a,b,d],[c,a,d,b],[c,d,a,b]}"
     by (simp add: insert_commute)}\\
 @{lemma "take 2 [a,b,c,d] = [a,b]" by simp}\\
 @{lemma "take 6 [a,b,c,d] = [a,b,c,d]" by simp}\\
 @{lemma "drop 2 [a,b,c,d] = [c,d]" by simp}\\
 @{lemma "drop 6 [a,b,c,d] = []" by simp}\\
 @{lemma "takeWhile (%n::nat. n<3) [1,2,3,0] = [1,2]" by simp}\\
 @{lemma "dropWhile (%n::nat. n<3) [1,2,3,0] = [3,0]" by simp}\\
 @{lemma "distinct [2,0,1::nat]" by simp}\\
 @{lemma "remdups [2,0,2,1::nat,2] = [0,1,2]" by simp}\\
 @{lemma "remdups_adj [2,2,3,1,1::nat,2,1] = [2,3,1,2,1]" by simp}\\
 @{lemma "List.insert 2 [0::nat,1,2] = [0,1,2]" by (simp add: List.insert_def)}\\
 @{lemma "List.insert 3 [0::nat,1,2] = [3,0,1,2]" by (simp add: List.insert_def)}\\
 @{lemma "List.union [2,3,4] [0::int,1,2] = [4,3,0,1,2]" by (simp add: List.insert_def List.union_def)}\\
 @{lemma "List.find (%i::int. i>0) [0,0] = None" by simp}\\
 @{lemma "List.find (%i::int. i>0) [0,1,0,2] = Some 1" by simp}\\
 @{lemma "count_list [0,1,0,2::int] 0 = 2" by (simp)}\\
 @{lemma "List.extract (%i::int. i>0) [0,0] = None" by(simp add: extract_def)}\\
 @{lemma "List.extract (%i::int. i>0) [0,1,0,2] = Some([0], 1, [0,2])" by(simp add: extract_def)}\\
 @{lemma "remove1 2 [2,0,2,1::nat,2] = [0,2,1,2]" by simp}\\
 @{lemma "removeAll 2 [2,0,2,1::nat,2] = [0,1]" by simp}\\
 @{lemma "nth [a,b,c,d] 2 = c" by simp}\\
 @{lemma "[a,b,c,d][2 := x] = [a,b,x,d]" by simp}\\
 @{lemma "nths [a,b,c,d,e] {0,2,3} = [a,c,d]" by (simp add:nths_def)}\\
 @{lemma "subseqs [a,b] = [[a, b], [a], [b], []]" by simp}\\
 @{lemma "List.n_lists 2 [a,b,c] = [[a, a], [b, a], [c, a], [a, b], [b, b], [c, b], [a, c], [b, c], [c, c]]" by (simp add: eval_nat_numeral)}\\
 @{lemma "rotate1 [a,b,c,d] = [b,c,d,a]" by simp}\\
 @{lemma "rotate 3 [a,b,c,d] = [d,a,b,c]" by (simp add:rotate_def eval_nat_numeral)}\\
 @{lemma "replicate 4 a = [a,a,a,a]" by (simp add:eval_nat_numeral)}\\
 @{lemma "[2..<5] = [2,3,4]" by (simp add:eval_nat_numeral)}\\
 @{lemma "min_list [3,1,-2::int] = -2" by (simp)}\\
 @{lemma "arg_min_list (\<lambda>i. i*i) [3,-1,1,-2::int] = -1" by (simp)}
 \end{tabular}}
 \caption{Characteristic examples}
 \label{fig:Characteristic}
 \end{figure}
 Figure~\ref{fig:Characteristic} shows characteristic examples
 that should give an intuitive understanding of the above functions.
 \<close>
 
 text\<open>The following simple sort(ed) functions are intended for proofs,
 not for efficient implementations.\<close>
 
 text \<open>A sorted predicate w.r.t. a relation:\<close>
 
 fun sorted_wrt :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 "sorted_wrt P [] = True" |
 "sorted_wrt P (x # ys) = ((\<forall>y \<in> set ys. P x y) \<and> sorted_wrt P ys)"
 
 text \<open>A class-based sorted predicate:\<close>
 
 context linorder
 begin
 
 abbreviation sorted :: "'a list \<Rightarrow> bool" where
   "sorted \<equiv> sorted_wrt (\<le>)" 
 
 lemma sorted_simps: "sorted [] = True" "sorted (x # ys) = ((\<forall>y \<in> set ys. x\<le>y) \<and> sorted ys)"
   by auto
 
 lemma strict_sorted_simps: "sorted_wrt (<) [] = True" "sorted_wrt (<) (x # ys) = ((\<forall>y \<in> set ys. x<y) \<and> sorted_wrt (<) ys)"
   by auto
 
 primrec insort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   "insort_key f x [] = [x]" |
   "insort_key f x (y#ys) =
   (if f x \<le> f y then (x#y#ys) else y#(insort_key f x ys))"
 
 definition sort_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   "sort_key f xs = foldr (insort_key f) xs []"
 
 definition insort_insert_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b \<Rightarrow> 'b list \<Rightarrow> 'b list" where
   "insort_insert_key f x xs =
   (if f x \<in> f ` set xs then xs else insort_key f x xs)"
 
 abbreviation "sort \<equiv> sort_key (\<lambda>x. x)"
 abbreviation "insort \<equiv> insort_key (\<lambda>x. x)"
 abbreviation "insort_insert \<equiv> insort_insert_key (\<lambda>x. x)"
 
 definition stable_sort_key :: "(('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list) \<Rightarrow> bool" where
   "stable_sort_key sk =
    (\<forall>f xs k. filter (\<lambda>y. f y = k) (sk f xs) = filter (\<lambda>y. f y = k) xs)"
 
 lemma strict_sorted_iff: "sorted_wrt (<) l \<longleftrightarrow> sorted l \<and> distinct l"
   by (induction l) (auto iff: antisym_conv1)
 
 lemma strict_sorted_imp_sorted: "sorted_wrt (<) xs \<Longrightarrow> sorted xs"
   by (auto simp: strict_sorted_iff)
 
 end
 
 
 subsubsection \<open>List comprehension\<close>
 
 text\<open>Input syntax for Haskell-like list comprehension notation.
 Typical example: \<open>[(x,y). x \<leftarrow> xs, y \<leftarrow> ys, x \<noteq> y]\<close>,
 the list of all pairs of distinct elements from \<open>xs\<close> and \<open>ys\<close>.
 The syntax is as in Haskell, except that \<open>|\<close> becomes a dot
 (like in Isabelle's set comprehension): \<open>[e. x \<leftarrow> xs, \<dots>]\<close> rather than
 \verb![e| x <- xs, ...]!.
 
 The qualifiers after the dot are
 \begin{description}
 \item[generators] \<open>p \<leftarrow> xs\<close>,
  where \<open>p\<close> is a pattern and \<open>xs\<close> an expression of list type, or
 \item[guards] \<open>b\<close>, where \<open>b\<close> is a boolean expression.
 %\item[local bindings] @ {text"let x = e"}.
 \end{description}
 
 Just like in Haskell, list comprehension is just a shorthand. To avoid
 misunderstandings, the translation into desugared form is not reversed
 upon output. Note that the translation of \<open>[e. x \<leftarrow> xs]\<close> is
 optmized to \<^term>\<open>map (%x. e) xs\<close>.
 
 It is easy to write short list comprehensions which stand for complex
 expressions. During proofs, they may become unreadable (and
 mangled). In such cases it can be advisable to introduce separate
 definitions for the list comprehensions in question.\<close>
 
 nonterminal lc_qual and lc_quals
 
 syntax
   "_listcompr" :: "'a \<Rightarrow> lc_qual \<Rightarrow> lc_quals \<Rightarrow> 'a list"  ("[_ . __")
   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ \<leftarrow> _")
   "_lc_test" :: "bool \<Rightarrow> lc_qual" ("_")
   (*"_lc_let" :: "letbinds => lc_qual"  ("let _")*)
   "_lc_end" :: "lc_quals" ("]")
   "_lc_quals" :: "lc_qual \<Rightarrow> lc_quals \<Rightarrow> lc_quals"  (", __")
 
 syntax (ASCII)
   "_lc_gen" :: "'a \<Rightarrow> 'a list \<Rightarrow> lc_qual"  ("_ <- _")
 
 parse_translation \<open>
 let
   val NilC = Syntax.const \<^const_syntax>\<open>Nil\<close>;
   val ConsC = Syntax.const \<^const_syntax>\<open>Cons\<close>;
   val mapC = Syntax.const \<^const_syntax>\<open>map\<close>;
   val concatC = Syntax.const \<^const_syntax>\<open>concat\<close>;
   val IfC = Syntax.const \<^const_syntax>\<open>If\<close>;
   val dummyC = Syntax.const \<^const_syntax>\<open>Pure.dummy_pattern\<close>
 
   fun single x = ConsC $ x $ NilC;
 
   fun pat_tr ctxt p e opti = (* %x. case x of p => e | _ => [] *)
     let
       (* FIXME proper name context!? *)
       val x =
         Free (singleton (Name.variant_list (fold Term.add_free_names [p, e] [])) "x", dummyT);
       val e = if opti then single e else e;
       val case1 = Syntax.const \<^syntax_const>\<open>_case1\<close> $ p $ e;
       val case2 =
         Syntax.const \<^syntax_const>\<open>_case1\<close> $ dummyC $ NilC;
       val cs = Syntax.const \<^syntax_const>\<open>_case2\<close> $ case1 $ case2;
     in Syntax_Trans.abs_tr [x, Case_Translation.case_tr false ctxt [x, cs]] end;
 
   fun pair_pat_tr (x as Free _) e = Syntax_Trans.abs_tr [x, e]
     | pair_pat_tr (_ $ p1 $ p2) e =
         Syntax.const \<^const_syntax>\<open>case_prod\<close> $ pair_pat_tr p1 (pair_pat_tr p2 e)
     | pair_pat_tr dummy e = Syntax_Trans.abs_tr [Syntax.const "_idtdummy", e]
 
   fun pair_pat ctxt (Const (\<^const_syntax>\<open>Pair\<close>,_) $ s $ t) =
         pair_pat ctxt s andalso pair_pat ctxt t
     | pair_pat ctxt (Free (s,_)) =
         let
           val thy = Proof_Context.theory_of ctxt;
           val s' = Proof_Context.intern_const ctxt s;
         in not (Sign.declared_const thy s') end
     | pair_pat _ t = (t = dummyC);
 
   fun abs_tr ctxt p e opti =
     let val p = Term_Position.strip_positions p
     in if pair_pat ctxt p
        then (pair_pat_tr p e, true)
        else (pat_tr ctxt p e opti, false)
     end
 
   fun lc_tr ctxt [e, Const (\<^syntax_const>\<open>_lc_test\<close>, _) $ b, qs] =
     let
       val res =
         (case qs of
            Const (\<^syntax_const>\<open>_lc_end\<close>, _) => single e
          | Const (\<^syntax_const>\<open>_lc_quals\<close>, _) $ q $ qs => lc_tr ctxt [e, q, qs]);
     in IfC $ b $ res $ NilC end
   | lc_tr ctxt
       [e, Const (\<^syntax_const>\<open>_lc_gen\<close>, _) $ p $ es,
           Const(\<^syntax_const>\<open>_lc_end\<close>, _)] =
       (case abs_tr ctxt p e true of
          (f, true) => mapC $ f $ es
        | (f, false) => concatC $ (mapC $ f $ es))
   | lc_tr ctxt
       [e, Const (\<^syntax_const>\<open>_lc_gen\<close>, _) $ p $ es,
           Const (\<^syntax_const>\<open>_lc_quals\<close>, _) $ q $ qs] =
       let val e' = lc_tr ctxt [e, q, qs];
       in concatC $ (mapC $ (fst (abs_tr ctxt p e' false)) $ es) end;
 
 in [(\<^syntax_const>\<open>_listcompr\<close>, lc_tr)] end
 \<close>
 
 ML_val \<open>
   let
     val read = Syntax.read_term \<^context> o Syntax.implode_input;
     fun check s1 s2 =
       read s1 aconv read s2 orelse
         error ("Check failed: " ^
           quote (#1 (Input.source_content s1)) ^ Position.here_list [Input.pos_of s1, Input.pos_of s2]);
   in
     check \<open>[(x,y,z). b]\<close> \<open>if b then [(x, y, z)] else []\<close>;
     check \<open>[(x,y,z). (x,_,y)\<leftarrow>xs]\<close> \<open>map (\<lambda>(x,_,y). (x, y, z)) xs\<close>;
     check \<open>[e x y. (x,_)\<leftarrow>xs, y\<leftarrow>ys]\<close> \<open>concat (map (\<lambda>(x,_). map (\<lambda>y. e x y) ys) xs)\<close>;
     check \<open>[(x,y,z). x<a, x>b]\<close> \<open>if x < a then if b < x then [(x, y, z)] else [] else []\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, x>b]\<close> \<open>concat (map (\<lambda>x. if b < x then [(x, y, z)] else []) xs)\<close>;
     check \<open>[(x,y,z). x<a, x\<leftarrow>xs]\<close> \<open>if x < a then map (\<lambda>x. (x, y, z)) xs else []\<close>;
     check \<open>[(x,y). Cons True x \<leftarrow> xs]\<close>
       \<open>concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | True # x \<Rightarrow> [(x, y)] | False # x \<Rightarrow> []) xs)\<close>;
     check \<open>[(x,y,z). Cons x [] \<leftarrow> xs]\<close>
       \<open>concat (map (\<lambda>xa. case xa of [] \<Rightarrow> [] | [x] \<Rightarrow> [(x, y, z)] | x # aa # lista \<Rightarrow> []) xs)\<close>;
     check \<open>[(x,y,z). x<a, x>b, x=d]\<close>
       \<open>if x < a then if b < x then if x = d then [(x, y, z)] else [] else [] else []\<close>;
     check \<open>[(x,y,z). x<a, x>b, y\<leftarrow>ys]\<close>
       \<open>if x < a then if b < x then map (\<lambda>y. (x, y, z)) ys else [] else []\<close>;
     check \<open>[(x,y,z). x<a, (_,x)\<leftarrow>xs,y>b]\<close>
       \<open>if x < a then concat (map (\<lambda>(_,x). if b < y then [(x, y, z)] else []) xs) else []\<close>;
     check \<open>[(x,y,z). x<a, x\<leftarrow>xs, y\<leftarrow>ys]\<close>
       \<open>if x < a then concat (map (\<lambda>x. map (\<lambda>y. (x, y, z)) ys) xs) else []\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, x>b, y<a]\<close>
       \<open>concat (map (\<lambda>x. if b < x then if y < a then [(x, y, z)] else [] else []) xs)\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, x>b, y\<leftarrow>ys]\<close>
       \<open>concat (map (\<lambda>x. if b < x then map (\<lambda>y. (x, y, z)) ys else []) xs)\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, (y,_)\<leftarrow>ys,y>x]\<close>
       \<open>concat (map (\<lambda>x. concat (map (\<lambda>(y,_). if x < y then [(x, y, z)] else []) ys)) xs)\<close>;
     check \<open>[(x,y,z). x\<leftarrow>xs, y\<leftarrow>ys,z\<leftarrow>zs]\<close>
       \<open>concat (map (\<lambda>x. concat (map (\<lambda>y. map (\<lambda>z. (x, y, z)) zs) ys)) xs)\<close>
   end;
 \<close>
 
 ML \<open>
 (* Simproc for rewriting list comprehensions applied to List.set to set
    comprehension. *)
 
 signature LIST_TO_SET_COMPREHENSION =
 sig
   val simproc : Proof.context -> cterm -> thm option
 end
 
 structure List_to_Set_Comprehension : LIST_TO_SET_COMPREHENSION =
 struct
 
 (* conversion *)
 
 fun all_exists_conv cv ctxt ct =
   (case Thm.term_of ct of
     Const (\<^const_name>\<open>Ex\<close>, _) $ Abs _ =>
       Conv.arg_conv (Conv.abs_conv (all_exists_conv cv o #2) ctxt) ct
   | _ => cv ctxt ct)
 
 fun all_but_last_exists_conv cv ctxt ct =
   (case Thm.term_of ct of
     Const (\<^const_name>\<open>Ex\<close>, _) $ Abs (_, _, Const (\<^const_name>\<open>Ex\<close>, _) $ _) =>
       Conv.arg_conv (Conv.abs_conv (all_but_last_exists_conv cv o #2) ctxt) ct
   | _ => cv ctxt ct)
 
 fun Collect_conv cv ctxt ct =
   (case Thm.term_of ct of
     Const (\<^const_name>\<open>Collect\<close>, _) $ Abs _ => Conv.arg_conv (Conv.abs_conv cv ctxt) ct
   | _ => raise CTERM ("Collect_conv", [ct]))
 
 fun rewr_conv' th = Conv.rewr_conv (mk_meta_eq th)
 
 fun conjunct_assoc_conv ct =
   Conv.try_conv
     (rewr_conv' @{thm conj_assoc} then_conv HOLogic.conj_conv Conv.all_conv conjunct_assoc_conv) ct
 
 fun right_hand_set_comprehension_conv conv ctxt =
   HOLogic.Trueprop_conv (HOLogic.eq_conv Conv.all_conv
     (Collect_conv (all_exists_conv conv o #2) ctxt))
 
 
 (* term abstraction of list comprehension patterns *)
 
 datatype termlets = If | Case of typ * int
 
 local
 
 val set_Nil_I = @{lemma "set [] = {x. False}" by (simp add: empty_def [symmetric])}
 val set_singleton = @{lemma "set [a] = {x. x = a}" by simp}
 val inst_Collect_mem_eq = @{lemma "set A = {x. x \<in> set A}" by simp}
 val del_refl_eq = @{lemma "(t = t \<and> P) \<equiv> P" by simp}
 
 fun mk_set T = Const (\<^const_name>\<open>set\<close>, HOLogic.listT T --> HOLogic.mk_setT T)
 fun dest_set (Const (\<^const_name>\<open>set\<close>, _) $ xs) = xs
 
 fun dest_singleton_list (Const (\<^const_name>\<open>Cons\<close>, _) $ t $ (Const (\<^const_name>\<open>Nil\<close>, _))) = t
   | dest_singleton_list t = raise TERM ("dest_singleton_list", [t])
 
 (*We check that one case returns a singleton list and all other cases
   return [], and return the index of the one singleton list case.*)
 fun possible_index_of_singleton_case cases =
   let
     fun check (i, case_t) s =
       (case strip_abs_body case_t of
         (Const (\<^const_name>\<open>Nil\<close>, _)) => s
       | _ => (case s of SOME NONE => SOME (SOME i) | _ => NONE))
   in
     fold_index check cases (SOME NONE) |> the_default NONE
   end
 
 (*returns condition continuing term option*)
 fun dest_if (Const (\<^const_name>\<open>If\<close>, _) $ cond $ then_t $ Const (\<^const_name>\<open>Nil\<close>, _)) =
       SOME (cond, then_t)
   | dest_if _ = NONE
 
 (*returns (case_expr type index chosen_case constr_name) option*)
 fun dest_case ctxt case_term =
   let
     val (case_const, args) = strip_comb case_term
   in
     (case try dest_Const case_const of
       SOME (c, T) =>
         (case Ctr_Sugar.ctr_sugar_of_case ctxt c of
           SOME {ctrs, ...} =>
             (case possible_index_of_singleton_case (fst (split_last args)) of
               SOME i =>
                 let
                   val constr_names = map (fst o dest_Const) ctrs
                   val (Ts, _) = strip_type T
                   val T' = List.last Ts
                 in SOME (List.last args, T', i, nth args i, nth constr_names i) end
             | NONE => NONE)
         | NONE => NONE)
     | NONE => NONE)
   end
 
 fun tac ctxt [] =
       resolve_tac ctxt [set_singleton] 1 ORELSE
       resolve_tac ctxt [inst_Collect_mem_eq] 1
   | tac ctxt (If :: cont) =
       Splitter.split_tac ctxt @{thms if_split} 1
       THEN resolve_tac ctxt @{thms conjI} 1
       THEN resolve_tac ctxt @{thms impI} 1
       THEN Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
         CONVERSION (right_hand_set_comprehension_conv (K
           (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_TrueI})) Conv.all_conv
            then_conv
            rewr_conv' @{lemma "(True \<and> P) = P" by simp})) ctxt') 1) ctxt 1
       THEN tac ctxt cont
       THEN resolve_tac ctxt @{thms impI} 1
       THEN Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
           CONVERSION (right_hand_set_comprehension_conv (K
             (HOLogic.conj_conv (Conv.rewr_conv (List.last prems RS @{thm Eq_FalseI})) Conv.all_conv
              then_conv rewr_conv' @{lemma "(False \<and> P) = False" by simp})) ctxt') 1) ctxt 1
       THEN resolve_tac ctxt [set_Nil_I] 1
   | tac ctxt (Case (T, i) :: cont) =
       let
         val SOME {injects, distincts, case_thms, split, ...} =
           Ctr_Sugar.ctr_sugar_of ctxt (fst (dest_Type T))
       in
         (* do case distinction *)
         Splitter.split_tac ctxt [split] 1
         THEN EVERY (map_index (fn (i', _) =>
           (if i' < length case_thms - 1 then resolve_tac ctxt @{thms conjI} 1 else all_tac)
           THEN REPEAT_DETERM (resolve_tac ctxt @{thms allI} 1)
           THEN resolve_tac ctxt @{thms impI} 1
           THEN (if i' = i then
             (* continue recursively *)
             Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
               CONVERSION (Thm.eta_conversion then_conv right_hand_set_comprehension_conv (K
                   ((HOLogic.conj_conv
                     (HOLogic.eq_conv Conv.all_conv (rewr_conv' (List.last prems)) then_conv
                       (Conv.try_conv (Conv.rewrs_conv (map mk_meta_eq injects))))
                     Conv.all_conv)
                     then_conv (Conv.try_conv (Conv.rewr_conv del_refl_eq))
                     then_conv conjunct_assoc_conv)) ctxt'
                 then_conv
                   (HOLogic.Trueprop_conv
                     (HOLogic.eq_conv Conv.all_conv (Collect_conv (fn (_, ctxt'') =>
                       Conv.repeat_conv
                         (all_but_last_exists_conv
                           (K (rewr_conv'
                             @{lemma "(\<exists>x. x = t \<and> P x) = P t" by simp})) ctxt'')) ctxt')))) 1) ctxt 1
             THEN tac ctxt cont
           else
             Subgoal.FOCUS (fn {prems, context = ctxt', ...} =>
               CONVERSION
                 (right_hand_set_comprehension_conv (K
                   (HOLogic.conj_conv
                     ((HOLogic.eq_conv Conv.all_conv
                       (rewr_conv' (List.last prems))) then_conv
                       (Conv.rewrs_conv (map (fn th => th RS @{thm Eq_FalseI}) distincts)))
                     Conv.all_conv then_conv
                     (rewr_conv' @{lemma "(False \<and> P) = False" by simp}))) ctxt' then_conv
                   HOLogic.Trueprop_conv
                     (HOLogic.eq_conv Conv.all_conv
                       (Collect_conv (fn (_, ctxt'') =>
                         Conv.repeat_conv
                           (Conv.bottom_conv
                             (K (rewr_conv' @{lemma "(\<exists>x. P) = P" by simp})) ctxt'')) ctxt'))) 1) ctxt 1
             THEN resolve_tac ctxt [set_Nil_I] 1)) case_thms)
       end
 
 in
 
 fun simproc ctxt redex =
   let
     fun make_inner_eqs bound_vs Tis eqs t =
       (case dest_case ctxt t of
         SOME (x, T, i, cont, constr_name) =>
           let
             val (vs, body) = strip_abs (Envir.eta_long (map snd bound_vs) cont)
             val x' = incr_boundvars (length vs) x
             val eqs' = map (incr_boundvars (length vs)) eqs
             val constr_t =
               list_comb
                 (Const (constr_name, map snd vs ---> T), map Bound (((length vs) - 1) downto 0))
             val constr_eq = Const (\<^const_name>\<open>HOL.eq\<close>, T --> T --> \<^typ>\<open>bool\<close>) $ constr_t $ x'
           in
             make_inner_eqs (rev vs @ bound_vs) (Case (T, i) :: Tis) (constr_eq :: eqs') body
           end
       | NONE =>
           (case dest_if t of
             SOME (condition, cont) => make_inner_eqs bound_vs (If :: Tis) (condition :: eqs) cont
           | NONE =>
             if null eqs then NONE (*no rewriting, nothing to be done*)
             else
               let
                 val Type (\<^type_name>\<open>list\<close>, [rT]) = fastype_of1 (map snd bound_vs, t)
                 val pat_eq =
                   (case try dest_singleton_list t of
                     SOME t' =>
                       Const (\<^const_name>\<open>HOL.eq\<close>, rT --> rT --> \<^typ>\<open>bool\<close>) $
                         Bound (length bound_vs) $ t'
                   | NONE =>
                       Const (\<^const_name>\<open>Set.member\<close>, rT --> HOLogic.mk_setT rT --> \<^typ>\<open>bool\<close>) $
                         Bound (length bound_vs) $ (mk_set rT $ t))
                 val reverse_bounds = curry subst_bounds
                   ((map Bound ((length bound_vs - 1) downto 0)) @ [Bound (length bound_vs)])
                 val eqs' = map reverse_bounds eqs
                 val pat_eq' = reverse_bounds pat_eq
                 val inner_t =
                   fold (fn (_, T) => fn t => HOLogic.exists_const T $ absdummy T t)
                     (rev bound_vs) (fold (curry HOLogic.mk_conj) eqs' pat_eq')
                 val lhs = Thm.term_of redex
                 val rhs = HOLogic.mk_Collect ("x", rT, inner_t)
                 val rewrite_rule_t = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))
               in
                 SOME
                   ((Goal.prove ctxt [] [] rewrite_rule_t
                     (fn {context = ctxt', ...} => tac ctxt' (rev Tis))) RS @{thm eq_reflection})
               end))
   in
     make_inner_eqs [] [] [] (dest_set (Thm.term_of redex))
   end
 
 end
 
 end
 \<close>
 
 simproc_setup list_to_set_comprehension ("set xs") =
   \<open>K List_to_Set_Comprehension.simproc\<close>
 
 code_datatype set coset
 hide_const (open) coset
 
 
 subsubsection \<open>\<^const>\<open>Nil\<close> and \<^const>\<open>Cons\<close>\<close>
 
 lemma not_Cons_self [simp]:
   "xs \<noteq> x # xs"
 by (induct xs) auto
 
 lemma not_Cons_self2 [simp]: "x # xs \<noteq> xs"
 by (rule not_Cons_self [symmetric])
 
 lemma neq_Nil_conv: "(xs \<noteq> []) = (\<exists>y ys. xs = y # ys)"
 by (induct xs) auto
 
 lemma tl_Nil: "tl xs = [] \<longleftrightarrow> xs = [] \<or> (\<exists>x. xs = [x])"
 by (cases xs) auto
 
 lemma Nil_tl: "[] = tl xs \<longleftrightarrow> xs = [] \<or> (\<exists>x. xs = [x])"
 by (cases xs) auto
 
 lemma length_induct:
   "(\<And>xs. \<forall>ys. length ys < length xs \<longrightarrow> P ys \<Longrightarrow> P xs) \<Longrightarrow> P xs"
 by (fact measure_induct)
 
 lemma induct_list012:
   "\<lbrakk>P []; \<And>x. P [x]; \<And>x y zs. \<lbrakk> P zs; P (y # zs) \<rbrakk> \<Longrightarrow> P (x # y # zs)\<rbrakk> \<Longrightarrow> P xs"
 by induction_schema (pat_completeness, lexicographic_order)
 
 lemma list_nonempty_induct [consumes 1, case_names single cons]:
   "\<lbrakk> xs \<noteq> []; \<And>x. P [x]; \<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (x # xs)\<rbrakk> \<Longrightarrow> P xs"
 by(induction xs rule: induct_list012) auto
 
 lemma inj_split_Cons: "inj_on (\<lambda>(xs, n). n#xs) X"
   by (auto intro!: inj_onI)
 
 lemma inj_on_Cons1 [simp]: "inj_on ((#) x) A"
 by(simp add: inj_on_def)
 
 
 subsubsection \<open>\<^const>\<open>length\<close>\<close>
 
 text \<open>
   Needs to come before \<open>@\<close> because of theorem \<open>append_eq_append_conv\<close>.
 \<close>
 
 lemma length_append [simp]: "length (xs @ ys) = length xs + length ys"
 by (induct xs) auto
 
 lemma length_map [simp]: "length (map f xs) = length xs"
 by (induct xs) auto
 
 lemma length_rev [simp]: "length (rev xs) = length xs"
 by (induct xs) auto
 
 lemma length_tl [simp]: "length (tl xs) = length xs - 1"
 by (cases xs) auto
 
 lemma length_0_conv [iff]: "(length xs = 0) = (xs = [])"
 by (induct xs) auto
 
 lemma length_greater_0_conv [iff]: "(0 < length xs) = (xs \<noteq> [])"
 by (induct xs) auto
 
 lemma length_pos_if_in_set: "x \<in> set xs \<Longrightarrow> length xs > 0"
 by auto
 
 lemma length_Suc_conv: "(length xs = Suc n) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
 by (induct xs) auto
 
 lemma Suc_length_conv:
   "(Suc n = length xs) = (\<exists>y ys. xs = y # ys \<and> length ys = n)"
 by (induct xs; simp; blast)
 
 lemma Suc_le_length_iff:
   "(Suc n \<le> length xs) = (\<exists>x ys. xs = x # ys \<and> n \<le> length ys)"
 by (metis Suc_le_D[of n] Suc_le_mono[of n] Suc_length_conv[of _ xs])
 
 lemma impossible_Cons: "length xs \<le> length ys \<Longrightarrow> xs = x # ys = False"
 by (induct xs) auto
 
 lemma list_induct2 [consumes 1, case_names Nil Cons]:
   "length xs = length ys \<Longrightarrow> P [] [] \<Longrightarrow>
    (\<And>x xs y ys. length xs = length ys \<Longrightarrow> P xs ys \<Longrightarrow> P (x#xs) (y#ys))
    \<Longrightarrow> P xs ys"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys) then show ?case by (cases ys) simp_all
 qed simp
 
 lemma list_induct3 [consumes 2, case_names Nil Cons]:
   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P [] [] [] \<Longrightarrow>
    (\<And>x xs y ys z zs. length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> P xs ys zs \<Longrightarrow> P (x#xs) (y#ys) (z#zs))
    \<Longrightarrow> P xs ys zs"
 proof (induct xs arbitrary: ys zs)
   case Nil then show ?case by simp
 next
   case (Cons x xs ys zs) then show ?case by (cases ys, simp_all)
     (cases zs, simp_all)
 qed
 
 lemma list_induct4 [consumes 3, case_names Nil Cons]:
   "length xs = length ys \<Longrightarrow> length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow>
    P [] [] [] [] \<Longrightarrow> (\<And>x xs y ys z zs w ws. length xs = length ys \<Longrightarrow>
    length ys = length zs \<Longrightarrow> length zs = length ws \<Longrightarrow> P xs ys zs ws \<Longrightarrow>
    P (x#xs) (y#ys) (z#zs) (w#ws)) \<Longrightarrow> P xs ys zs ws"
 proof (induct xs arbitrary: ys zs ws)
   case Nil then show ?case by simp
 next
   case (Cons x xs ys zs ws) then show ?case by ((cases ys, simp_all), (cases zs,simp_all)) (cases ws, simp_all)
 qed
 
 lemma list_induct2':
   "\<lbrakk> P [] [];
   \<And>x xs. P (x#xs) [];
   \<And>y ys. P [] (y#ys);
    \<And>x xs y ys. P xs ys  \<Longrightarrow> P (x#xs) (y#ys) \<rbrakk>
  \<Longrightarrow> P xs ys"
 by (induct xs arbitrary: ys) (case_tac x, auto)+
 
 lemma list_all2_iff:
   "list_all2 P xs ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x, y) \<in> set (zip xs ys). P x y)"
 by (induct xs ys rule: list_induct2') auto
 
 lemma neq_if_length_neq: "length xs \<noteq> length ys \<Longrightarrow> (xs = ys) == False"
 by (rule Eq_FalseI) auto
 
 
 subsubsection \<open>\<open>@\<close> -- append\<close>
 
 global_interpretation append: monoid append Nil
 proof
   fix xs ys zs :: "'a list"
   show "(xs @ ys) @ zs = xs @ (ys @ zs)"
     by (induct xs) simp_all
   show "xs @ [] = xs"
     by (induct xs) simp_all
 qed simp
 
 lemma append_assoc [simp]: "(xs @ ys) @ zs = xs @ (ys @ zs)"
   by (fact append.assoc)
 
 lemma append_Nil2: "xs @ [] = xs"
   by (fact append.right_neutral)
 
 lemma append_is_Nil_conv [iff]: "(xs @ ys = []) = (xs = [] \<and> ys = [])"
 by (induct xs) auto
 
 lemma Nil_is_append_conv [iff]: "([] = xs @ ys) = (xs = [] \<and> ys = [])"
 by (induct xs) auto
 
 lemma append_self_conv [iff]: "(xs @ ys = xs) = (ys = [])"
 by (induct xs) auto
 
 lemma self_append_conv [iff]: "(xs = xs @ ys) = (ys = [])"
 by (induct xs) auto
 
 lemma append_eq_append_conv [simp]:
   "length xs = length ys \<or> length us = length vs
   \<Longrightarrow> (xs@us = ys@vs) = (xs=ys \<and> us=vs)"
   by (induct xs arbitrary: ys; case_tac ys; force)
 
 lemma append_eq_append_conv2: "(xs @ ys = zs @ ts) =
   (\<exists>us. xs = zs @ us \<and> us @ ys = ts \<or> xs @ us = zs \<and> ys = us @ ts)"
 proof (induct xs arbitrary: ys zs ts)
   case (Cons x xs)
   then show ?case
     by (cases zs) auto
 qed fastforce
 
 lemma same_append_eq [iff, induct_simp]: "(xs @ ys = xs @ zs) = (ys = zs)"
 by simp
 
 lemma append1_eq_conv [iff]: "(xs @ [x] = ys @ [y]) = (xs = ys \<and> x = y)"
 by simp
 
 lemma append_same_eq [iff, induct_simp]: "(ys @ xs = zs @ xs) = (ys = zs)"
 by simp
 
 lemma append_self_conv2 [iff]: "(xs @ ys = ys) = (xs = [])"
 using append_same_eq [of _ _ "[]"] by auto
 
 lemma self_append_conv2 [iff]: "(ys = xs @ ys) = (xs = [])"
 using append_same_eq [of "[]"] by auto
 
 lemma hd_Cons_tl: "xs \<noteq> [] \<Longrightarrow> hd xs # tl xs = xs"
   by (fact list.collapse)
 
 lemma hd_append: "hd (xs @ ys) = (if xs = [] then hd ys else hd xs)"
 by (induct xs) auto
 
 lemma hd_append2 [simp]: "xs \<noteq> [] \<Longrightarrow> hd (xs @ ys) = hd xs"
 by (simp add: hd_append split: list.split)
 
 lemma tl_append: "tl (xs @ ys) = (case xs of [] \<Rightarrow> tl ys | z#zs \<Rightarrow> zs @ ys)"
 by (simp split: list.split)
 
 lemma tl_append2 [simp]: "xs \<noteq> [] \<Longrightarrow> tl (xs @ ys) = tl xs @ ys"
 by (simp add: tl_append split: list.split)
 
 
 lemma Cons_eq_append_conv: "x#xs = ys@zs =
  (ys = [] \<and> x#xs = zs \<or> (\<exists>ys'. x#ys' = ys \<and> xs = ys'@zs))"
 by(cases ys) auto
 
 lemma append_eq_Cons_conv: "(ys@zs = x#xs) =
  (ys = [] \<and> zs = x#xs \<or> (\<exists>ys'. ys = x#ys' \<and> ys'@zs = xs))"
 by(cases ys) auto
 
 lemma longest_common_prefix:
   "\<exists>ps xs' ys'. xs = ps @ xs' \<and> ys = ps @ ys'
        \<and> (xs' = [] \<or> ys' = [] \<or> hd xs' \<noteq> hd ys')"
 by (induct xs ys rule: list_induct2')
    (blast, blast, blast,
     metis (no_types, hide_lams) append_Cons append_Nil list.sel(1))
 
 text \<open>Trivial rules for solving \<open>@\<close>-equations automatically.\<close>
 
 lemma eq_Nil_appendI: "xs = ys \<Longrightarrow> xs = [] @ ys"
   by simp
 
 lemma Cons_eq_appendI: "\<lbrakk>x # xs1 = ys; xs = xs1 @ zs\<rbrakk> \<Longrightarrow> x # xs = ys @ zs"
   by auto
 
 lemma append_eq_appendI: "\<lbrakk>xs @ xs1 = zs; ys = xs1 @ us\<rbrakk> \<Longrightarrow> xs @ ys = zs @ us"
   by auto
 
 
 text \<open>
 Simplification procedure for all list equalities.
 Currently only tries to rearrange \<open>@\<close> to see if
 - both lists end in a singleton list,
 - or both lists end in the same list.
 \<close>
 
 simproc_setup list_eq ("(xs::'a list) = ys")  = \<open>
   let
     fun last (cons as Const (\<^const_name>\<open>Cons\<close>, _) $ _ $ xs) =
           (case xs of Const (\<^const_name>\<open>Nil\<close>, _) => cons | _ => last xs)
       | last (Const(\<^const_name>\<open>append\<close>,_) $ _ $ ys) = last ys
       | last t = t;
 
     fun list1 (Const(\<^const_name>\<open>Cons\<close>,_) $ _ $ Const(\<^const_name>\<open>Nil\<close>,_)) = true
       | list1 _ = false;
 
     fun butlast ((cons as Const(\<^const_name>\<open>Cons\<close>,_) $ x) $ xs) =
           (case xs of Const (\<^const_name>\<open>Nil\<close>, _) => xs | _ => cons $ butlast xs)
       | butlast ((app as Const (\<^const_name>\<open>append\<close>, _) $ xs) $ ys) = app $ butlast ys
       | butlast xs = Const(\<^const_name>\<open>Nil\<close>, fastype_of xs);
 
     val rearr_ss =
       simpset_of (put_simpset HOL_basic_ss \<^context>
         addsimps [@{thm append_assoc}, @{thm append_Nil}, @{thm append_Cons}]);
 
     fun list_eq ctxt (F as (eq as Const(_,eqT)) $ lhs $ rhs) =
       let
         val lastl = last lhs and lastr = last rhs;
         fun rearr conv =
           let
             val lhs1 = butlast lhs and rhs1 = butlast rhs;
             val Type(_,listT::_) = eqT
             val appT = [listT,listT] ---> listT
             val app = Const(\<^const_name>\<open>append\<close>,appT)
             val F2 = eq $ (app$lhs1$lastl) $ (app$rhs1$lastr)
             val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (F,F2));
             val thm = Goal.prove ctxt [] [] eq
               (K (simp_tac (put_simpset rearr_ss ctxt) 1));
           in SOME ((conv RS (thm RS trans)) RS eq_reflection) end;
       in
         if list1 lastl andalso list1 lastr then rearr @{thm append1_eq_conv}
         else if lastl aconv lastr then rearr @{thm append_same_eq}
         else NONE
       end;
   in fn _ => fn ctxt => fn ct => list_eq ctxt (Thm.term_of ct) end
 \<close>
 
 
 subsubsection \<open>\<^const>\<open>map\<close>\<close>
 
 lemma hd_map: "xs \<noteq> [] \<Longrightarrow> hd (map f xs) = f (hd xs)"
 by (cases xs) simp_all
 
 lemma map_tl: "map f (tl xs) = tl (map f xs)"
 by (cases xs) simp_all
 
 lemma map_ext: "(\<And>x. x \<in> set xs \<longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g xs"
 by (induct xs) simp_all
 
 lemma map_ident [simp]: "map (\<lambda>x. x) = (\<lambda>xs. xs)"
 by (rule ext, induct_tac xs) auto
 
 lemma map_append [simp]: "map f (xs @ ys) = map f xs @ map f ys"
 by (induct xs) auto
 
 lemma map_map [simp]: "map f (map g xs) = map (f \<circ> g) xs"
 by (induct xs) auto
 
 lemma map_comp_map[simp]: "((map f) \<circ> (map g)) = map(f \<circ> g)"
 by (rule ext) simp
 
 lemma rev_map: "rev (map f xs) = map f (rev xs)"
 by (induct xs) auto
 
 lemma map_eq_conv[simp]: "(map f xs = map g xs) = (\<forall>x \<in> set xs. f x = g x)"
 by (induct xs) auto
 
 lemma map_cong [fundef_cong]:
   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> map f xs = map g ys"
 by simp
 
 lemma map_is_Nil_conv [iff]: "(map f xs = []) = (xs = [])"
 by (cases xs) auto
 
 lemma Nil_is_map_conv [iff]: "([] = map f xs) = (xs = [])"
 by (cases xs) auto
 
 lemma map_eq_Cons_conv:
   "(map f xs = y#ys) = (\<exists>z zs. xs = z#zs \<and> f z = y \<and> map f zs = ys)"
 by (cases xs) auto
 
 lemma Cons_eq_map_conv:
   "(x#xs = map f ys) = (\<exists>z zs. ys = z#zs \<and> x = f z \<and> xs = map f zs)"
 by (cases ys) auto
 
 lemmas map_eq_Cons_D = map_eq_Cons_conv [THEN iffD1]
 lemmas Cons_eq_map_D = Cons_eq_map_conv [THEN iffD1]
 declare map_eq_Cons_D [dest!]  Cons_eq_map_D [dest!]
 
 lemma ex_map_conv:
   "(\<exists>xs. ys = map f xs) = (\<forall>y \<in> set ys. \<exists>x. y = f x)"
 by(induct ys, auto simp add: Cons_eq_map_conv)
 
 lemma map_eq_imp_length_eq:
   assumes "map f xs = map g ys"
   shows "length xs = length ys"
   using assms
 proof (induct ys arbitrary: xs)
   case Nil then show ?case by simp
 next
   case (Cons y ys) then obtain z zs where xs: "xs = z # zs" by auto
   from Cons xs have "map f zs = map g ys" by simp
   with Cons have "length zs = length ys" by blast
   with xs show ?case by simp
 qed
 
 lemma map_inj_on:
   assumes map: "map f xs = map f ys" and inj: "inj_on f (set xs Un set ys)"
   shows "xs = ys"
   using map_eq_imp_length_eq [OF map] assms
 proof (induct rule: list_induct2)
   case (Cons x xs y ys)
   then show ?case
     by (auto intro: sym)
 qed auto
 
 lemma inj_on_map_eq_map:
   "inj_on f (set xs Un set ys) \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"
 by(blast dest:map_inj_on)
 
 lemma map_injective:
   "map f xs = map f ys \<Longrightarrow> inj f \<Longrightarrow> xs = ys"
 by (induct ys arbitrary: xs) (auto dest!:injD)
 
 lemma inj_map_eq_map[simp]: "inj f \<Longrightarrow> (map f xs = map f ys) = (xs = ys)"
 by(blast dest:map_injective)
 
 lemma inj_mapI: "inj f \<Longrightarrow> inj (map f)"
 by (iprover dest: map_injective injD intro: inj_onI)
 
 lemma inj_mapD: "inj (map f) \<Longrightarrow> inj f"
   by (metis (no_types, hide_lams) injI list.inject list.simps(9) the_inv_f_f)
 
 lemma inj_map[iff]: "inj (map f) = inj f"
 by (blast dest: inj_mapD intro: inj_mapI)
 
 lemma inj_on_mapI: "inj_on f (\<Union>(set ` A)) \<Longrightarrow> inj_on (map f) A"
   by (blast intro:inj_onI dest:inj_onD map_inj_on)
 
 lemma map_idI: "(\<And>x. x \<in> set xs \<Longrightarrow> f x = x) \<Longrightarrow> map f xs = xs"
 by (induct xs, auto)
 
 lemma map_fun_upd [simp]: "y \<notin> set xs \<Longrightarrow> map (f(y:=v)) xs = map f xs"
 by (induct xs) auto
 
 lemma map_fst_zip[simp]:
   "length xs = length ys \<Longrightarrow> map fst (zip xs ys) = xs"
 by (induct rule:list_induct2, simp_all)
 
 lemma map_snd_zip[simp]:
   "length xs = length ys \<Longrightarrow> map snd (zip xs ys) = ys"
 by (induct rule:list_induct2, simp_all)
 
 lemma map_fst_zip_take:
   "map fst (zip xs ys) = take (min (length xs) (length ys)) xs"
 by (induct xs ys rule: list_induct2') simp_all
 
 lemma map_snd_zip_take:
   "map snd (zip xs ys) = take (min (length xs) (length ys)) ys"
 by (induct xs ys rule: list_induct2') simp_all
 
 lemma map2_map_map: "map2 h (map f xs) (map g xs) = map (\<lambda>x. h (f x) (g x)) xs"
 by (induction xs) (auto)
 
 functor map: map
 by (simp_all add: id_def)
 
 declare map.id [simp]
 
 
 subsubsection \<open>\<^const>\<open>rev\<close>\<close>
 
 lemma rev_append [simp]: "rev (xs @ ys) = rev ys @ rev xs"
 by (induct xs) auto
 
 lemma rev_rev_ident [simp]: "rev (rev xs) = xs"
 by (induct xs) auto
 
 lemma rev_swap: "(rev xs = ys) = (xs = rev ys)"
 by auto
 
 lemma rev_is_Nil_conv [iff]: "(rev xs = []) = (xs = [])"
 by (induct xs) auto
 
 lemma Nil_is_rev_conv [iff]: "([] = rev xs) = (xs = [])"
 by (induct xs) auto
 
 lemma rev_singleton_conv [simp]: "(rev xs = [x]) = (xs = [x])"
 by (cases xs) auto
 
 lemma singleton_rev_conv [simp]: "([x] = rev xs) = (xs = [x])"
 by (cases xs) auto
 
 lemma rev_is_rev_conv [iff]: "(rev xs = rev ys) = (xs = ys)"
 proof (induct xs arbitrary: ys)
   case Nil
   then show ?case by force
 next
   case Cons
   then show ?case by (cases ys) auto
 qed
 
 lemma inj_on_rev[iff]: "inj_on rev A"
 by(simp add:inj_on_def)
 
 lemma rev_induct [case_names Nil snoc]:
   assumes "P []" and "\<And>x xs. P xs \<Longrightarrow> P (xs @ [x])"
   shows "P xs"
 proof -
   have "P (rev (rev xs))"
     by (rule_tac list = "rev xs" in list.induct, simp_all add: assms)
   then show ?thesis by simp
 qed
 
 lemma rev_exhaust [case_names Nil snoc]:
   "(xs = [] \<Longrightarrow> P) \<Longrightarrow>(\<And>ys y. xs = ys @ [y] \<Longrightarrow> P) \<Longrightarrow> P"
 by (induct xs rule: rev_induct) auto
 
 lemmas rev_cases = rev_exhaust
 
 lemma rev_nonempty_induct [consumes 1, case_names single snoc]:
   assumes "xs \<noteq> []"
   and single: "\<And>x. P [x]"
   and snoc': "\<And>x xs. xs \<noteq> [] \<Longrightarrow> P xs \<Longrightarrow> P (xs@[x])"
   shows "P xs"
 using \<open>xs \<noteq> []\<close> proof (induct xs rule: rev_induct)
   case (snoc x xs) then show ?case
   proof (cases xs)
     case Nil thus ?thesis by (simp add: single)
   next
     case Cons with snoc show ?thesis by (fastforce intro!: snoc')
   qed
 qed simp
 
 lemma rev_eq_Cons_iff[iff]: "(rev xs = y#ys) = (xs = rev ys @ [y])"
 by(rule rev_cases[of xs]) auto
 
 
 subsubsection \<open>\<^const>\<open>set\<close>\<close>
 
 declare list.set[code_post]  \<comment> \<open>pretty output\<close>
 
 lemma finite_set [iff]: "finite (set xs)"
 by (induct xs) auto
 
 lemma set_append [simp]: "set (xs @ ys) = (set xs \<union> set ys)"
 by (induct xs) auto
 
 lemma hd_in_set[simp]: "xs \<noteq> [] \<Longrightarrow> hd xs \<in> set xs"
 by(cases xs) auto
 
 lemma set_subset_Cons: "set xs \<subseteq> set (x # xs)"
 by auto
 
 lemma set_ConsD: "y \<in> set (x # xs) \<Longrightarrow> y=x \<or> y \<in> set xs"
 by auto
 
 lemma set_empty [iff]: "(set xs = {}) = (xs = [])"
 by (induct xs) auto
 
 lemma set_empty2[iff]: "({} = set xs) = (xs = [])"
 by(induct xs) auto
 
 lemma set_rev [simp]: "set (rev xs) = set xs"
 by (induct xs) auto
 
 lemma set_map [simp]: "set (map f xs) = f`(set xs)"
 by (induct xs) auto
 
 lemma set_filter [simp]: "set (filter P xs) = {x. x \<in> set xs \<and> P x}"
 by (induct xs) auto
 
 lemma set_upt [simp]: "set[i..<j] = {i..<j}"
 by (induct j) auto
 
 
 lemma split_list: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case Cons thus ?case by (auto intro: Cons_eq_appendI)
 qed
 
 lemma in_set_conv_decomp: "x \<in> set xs \<longleftrightarrow> (\<exists>ys zs. xs = ys @ x # zs)"
   by (auto elim: split_list)
 
 lemma split_list_first: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons a xs)
   show ?case
   proof cases
     assume "x = a" thus ?case using Cons by fastforce
   next
     assume "x \<noteq> a" thus ?case using Cons by(fastforce intro!: Cons_eq_appendI)
   qed
 qed
 
 lemma in_set_conv_decomp_first:
   "(x \<in> set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set ys)"
   by (auto dest!: split_list_first)
 
 lemma split_list_last: "x \<in> set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs"
 proof (induct xs rule: rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc a xs)
   show ?case
   proof cases
     assume "x = a" thus ?case using snoc by (auto intro!: exI)
   next
     assume "x \<noteq> a" thus ?case using snoc by fastforce
   qed
 qed
 
 lemma in_set_conv_decomp_last:
   "(x \<in> set xs) = (\<exists>ys zs. xs = ys @ x # zs \<and> x \<notin> set zs)"
   by (auto dest!: split_list_last)
 
 lemma split_list_prop: "\<exists>x \<in> set xs. P x \<Longrightarrow> \<exists>ys x zs. xs = ys @ x # zs \<and> P x"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case Cons thus ?case
     by(simp add:Bex_def)(metis append_Cons append.simps(1))
 qed
 
 lemma split_list_propE:
   assumes "\<exists>x \<in> set xs. P x"
   obtains ys x zs where "xs = ys @ x # zs" and "P x"
 using split_list_prop [OF assms] by blast
 
 lemma split_list_first_prop:
   "\<exists>x \<in> set xs. P x \<Longrightarrow>
    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y)"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   show ?case
   proof cases
     assume "P x"
     hence "x # xs = [] @ x # xs \<and> P x \<and> (\<forall>y\<in>set []. \<not> P y)" by simp
     thus ?thesis by fast
   next
     assume "\<not> P x"
     hence "\<exists>x\<in>set xs. P x" using Cons(2) by simp
     thus ?thesis using \<open>\<not> P x\<close> Cons(1) by (metis append_Cons set_ConsD)
   qed
 qed
 
 lemma split_list_first_propE:
   assumes "\<exists>x \<in> set xs. P x"
   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>y \<in> set ys. \<not> P y"
 using split_list_first_prop [OF assms] by blast
 
 lemma split_list_first_prop_iff:
   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>y \<in> set ys. \<not> P y))"
 by (rule, erule split_list_first_prop) auto
 
 lemma split_list_last_prop:
   "\<exists>x \<in> set xs. P x \<Longrightarrow>
    \<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z)"
 proof(induct xs rule:rev_induct)
   case Nil thus ?case by simp
 next
   case (snoc x xs)
   show ?case
   proof cases
     assume "P x" thus ?thesis by (auto intro!: exI)
   next
     assume "\<not> P x"
     hence "\<exists>x\<in>set xs. P x" using snoc(2) by simp
     thus ?thesis using \<open>\<not> P x\<close> snoc(1) by fastforce
   qed
 qed
 
 lemma split_list_last_propE:
   assumes "\<exists>x \<in> set xs. P x"
   obtains ys x zs where "xs = ys @ x # zs" and "P x" and "\<forall>z \<in> set zs. \<not> P z"
 using split_list_last_prop [OF assms] by blast
 
 lemma split_list_last_prop_iff:
   "(\<exists>x \<in> set xs. P x) \<longleftrightarrow>
    (\<exists>ys x zs. xs = ys@x#zs \<and> P x \<and> (\<forall>z \<in> set zs. \<not> P z))"
   by rule (erule split_list_last_prop, auto)
 
 
 lemma finite_list: "finite A \<Longrightarrow> \<exists>xs. set xs = A"
   by (erule finite_induct) (auto simp add: list.set(2)[symmetric] simp del: list.set(2))
 
 lemma card_length: "card (set xs) \<le> length xs"
 by (induct xs) (auto simp add: card_insert_if)
 
 lemma set_minus_filter_out:
   "set xs - {y} = set (filter (\<lambda>x. \<not> (x = y)) xs)"
   by (induct xs) auto
 
 lemma append_Cons_eq_iff:
   "\<lbrakk> x \<notin> set xs; x \<notin> set ys \<rbrakk> \<Longrightarrow>
    xs @ x # ys = xs' @ x # ys' \<longleftrightarrow> (xs = xs' \<and> ys = ys')"
 by(auto simp: append_eq_Cons_conv Cons_eq_append_conv append_eq_append_conv2)
 
 
 subsubsection \<open>\<^const>\<open>concat\<close>\<close>
 
 lemma concat_append [simp]: "concat (xs @ ys) = concat xs @ concat ys"
   by (induct xs) auto
 
 lemma concat_eq_Nil_conv [simp]: "(concat xss = []) = (\<forall>xs \<in> set xss. xs = [])"
   by (induct xss) auto
 
 lemma Nil_eq_concat_conv [simp]: "([] = concat xss) = (\<forall>xs \<in> set xss. xs = [])"
   by (induct xss) auto
 
 lemma set_concat [simp]: "set (concat xs) = (\<Union>x\<in>set xs. set x)"
   by (induct xs) auto
 
 lemma concat_map_singleton[simp]: "concat(map (%x. [f x]) xs) = map f xs"
   by (induct xs) auto
 
 lemma map_concat: "map f (concat xs) = concat (map (map f) xs)"
   by (induct xs) auto
 
 lemma rev_concat: "rev (concat xs) = concat (map rev (rev xs))"
   by (induct xs) auto
 
 lemma length_concat_rev[simp]: "length (concat (rev xs)) = length (concat xs)"
 by (induction xs) auto
 
 lemma concat_eq_concat_iff: "\<forall>(x, y) \<in> set (zip xs ys). length x = length y \<Longrightarrow> length xs = length ys \<Longrightarrow> (concat xs = concat ys) = (xs = ys)"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys)
   thus ?case by (cases ys) auto
 qed (auto)
 
 lemma concat_injective: "concat xs = concat ys \<Longrightarrow> length xs = length ys \<Longrightarrow> \<forall>(x, y) \<in> set (zip xs ys). length x = length y \<Longrightarrow> xs = ys"
   by (simp add: concat_eq_concat_iff)
 
 lemma concat_eq_appendD:
   assumes "concat xss = ys @ zs" "xss \<noteq> []"
   shows "\<exists>xss1 xs xs' xss2. xss = xss1 @ (xs @ xs') # xss2 \<and> ys = concat xss1 @ xs \<and> zs = xs' @ concat xss2"
   using assms
 proof(induction xss arbitrary: ys)
   case (Cons xs xss)
   from Cons.prems consider
     us where "xs @ us = ys" "concat xss = us @ zs" |
     us where "xs = ys @ us" "us @ concat xss = zs"
     by(auto simp add: append_eq_append_conv2)
   then show ?case
   proof cases
     case 1
     then show ?thesis using Cons.IH[OF 1(2)]
       by(cases xss)(auto intro: exI[where x="[]"], metis append.assoc append_Cons concat.simps(2))
   qed(auto intro: exI[where x="[]"])
 qed simp
 
 lemma concat_eq_append_conv:
   "concat xss = ys @ zs \<longleftrightarrow>
   (if xss = [] then ys = [] \<and> zs = []
    else \<exists>xss1 xs xs' xss2. xss = xss1 @ (xs @ xs') # xss2 \<and> ys = concat xss1 @ xs \<and> zs = xs' @ concat xss2)"
   by(auto dest: concat_eq_appendD)
 
 lemma hd_concat: "\<lbrakk>xs \<noteq> []; hd xs \<noteq> []\<rbrakk> \<Longrightarrow> hd (concat xs) = hd (hd xs)"
   by (metis concat.simps(2) hd_Cons_tl hd_append2)
 
 
 simproc_setup list_neq ("(xs::'a list) = ys") = \<open>
 (*
 Reduces xs=ys to False if xs and ys cannot be of the same length.
 This is the case if the atomic sublists of one are a submultiset
 of those of the other list and there are fewer Cons's in one than the other.
 *)
 
 let
 
 fun len (Const(\<^const_name>\<open>Nil\<close>,_)) acc = acc
   | len (Const(\<^const_name>\<open>Cons\<close>,_) $ _ $ xs) (ts,n) = len xs (ts,n+1)
   | len (Const(\<^const_name>\<open>append\<close>,_) $ xs $ ys) acc = len xs (len ys acc)
   | len (Const(\<^const_name>\<open>rev\<close>,_) $ xs) acc = len xs acc
   | len (Const(\<^const_name>\<open>map\<close>,_) $ _ $ xs) acc = len xs acc
   | len (Const(\<^const_name>\<open>concat\<close>,T) $ (Const(\<^const_name>\<open>rev\<close>,_) $ xss)) acc
     = len (Const(\<^const_name>\<open>concat\<close>,T) $ xss) acc 
   | len t (ts,n) = (t::ts,n);
 
 val ss = simpset_of \<^context>;
 
 fun list_neq ctxt ct =
   let
     val (Const(_,eqT) $ lhs $ rhs) = Thm.term_of ct;
     val (ls,m) = len lhs ([],0) and (rs,n) = len rhs ([],0);
     fun prove_neq() =
       let
         val Type(_,listT::_) = eqT;
         val size = HOLogic.size_const listT;
         val eq_len = HOLogic.mk_eq (size $ lhs, size $ rhs);
         val neq_len = HOLogic.mk_Trueprop (HOLogic.Not $ eq_len);
         val thm = Goal.prove ctxt [] [] neq_len
           (K (simp_tac (put_simpset ss ctxt) 1));
       in SOME (thm RS @{thm neq_if_length_neq}) end
   in
     if m < n andalso submultiset (op aconv) (ls,rs) orelse
        n < m andalso submultiset (op aconv) (rs,ls)
     then prove_neq() else NONE
   end;
 in K list_neq end
 \<close>
 
 subsubsection \<open>\<^const>\<open>filter\<close>\<close>
 
 lemma filter_append [simp]: "filter P (xs @ ys) = filter P xs @ filter P ys"
 by (induct xs) auto
 
 lemma rev_filter: "rev (filter P xs) = filter P (rev xs)"
 by (induct xs) simp_all
 
 lemma filter_filter [simp]: "filter P (filter Q xs) = filter (\<lambda>x. Q x \<and> P x) xs"
 by (induct xs) auto
 
 lemma filter_concat: "filter p (concat xs) = concat (map (filter p) xs)"
 by (induct xs) auto
 
 lemma length_filter_le [simp]: "length (filter P xs) \<le> length xs"
 by (induct xs) (auto simp add: le_SucI)
 
 lemma sum_length_filter_compl:
   "length(filter P xs) + length(filter (\<lambda>x. \<not>P x) xs) = length xs"
 by(induct xs) simp_all
 
 lemma filter_True [simp]: "\<forall>x \<in> set xs. P x \<Longrightarrow> filter P xs = xs"
 by (induct xs) auto
 
 lemma filter_False [simp]: "\<forall>x \<in> set xs. \<not> P x \<Longrightarrow> filter P xs = []"
 by (induct xs) auto
 
 lemma filter_empty_conv: "(filter P xs = []) = (\<forall>x\<in>set xs. \<not> P x)"
 by (induct xs) simp_all
 
 lemma filter_id_conv: "(filter P xs = xs) = (\<forall>x\<in>set xs. P x)"
 proof (induct xs)
   case (Cons x xs)
   then show ?case
     using length_filter_le
     by (simp add: impossible_Cons)
 qed auto
 
 lemma filter_map: "filter P (map f xs) = map f (filter (P \<circ> f) xs)"
 by (induct xs) simp_all
 
 lemma length_filter_map[simp]:
   "length (filter P (map f xs)) = length(filter (P \<circ> f) xs)"
 by (simp add:filter_map)
 
 lemma filter_is_subset [simp]: "set (filter P xs) \<le> set xs"
 by auto
 
 lemma length_filter_less:
   "\<lbrakk> x \<in> set xs; \<not> P x \<rbrakk> \<Longrightarrow> length(filter P xs) < length xs"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case
     using Suc_le_eq by fastforce
 qed
 
 lemma length_filter_conv_card:
   "length(filter p xs) = card{i. i < length xs \<and> p(xs!i)}"
 proof (induct xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   let ?S = "{i. i < length xs \<and> p(xs!i)}"
   have fin: "finite ?S" by(fast intro: bounded_nat_set_is_finite)
   show ?case (is "?l = card ?S'")
   proof (cases)
     assume "p x"
     hence eq: "?S' = insert 0 (Suc ` ?S)"
       by(auto simp: image_def split:nat.split dest:gr0_implies_Suc)
     have "length (filter p (x # xs)) = Suc(card ?S)"
       using Cons \<open>p x\<close> by simp
     also have "\<dots> = Suc(card(Suc ` ?S))" using fin
       by (simp add: card_image)
     also have "\<dots> = card ?S'" using eq fin
       by (simp add:card_insert_if)
     finally show ?thesis .
   next
     assume "\<not> p x"
     hence eq: "?S' = Suc ` ?S"
       by(auto simp add: image_def split:nat.split elim:lessE)
     have "length (filter p (x # xs)) = card ?S"
       using Cons \<open>\<not> p x\<close> by simp
     also have "\<dots> = card(Suc ` ?S)" using fin
       by (simp add: card_image)
     also have "\<dots> = card ?S'" using eq fin
       by (simp add:card_insert_if)
     finally show ?thesis .
   qed
 qed
 
 lemma Cons_eq_filterD:
   "x#xs = filter P ys \<Longrightarrow>
   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"
   (is "_ \<Longrightarrow> \<exists>us vs. ?P ys us vs")
 proof(induct ys)
   case Nil thus ?case by simp
 next
   case (Cons y ys)
   show ?case (is "\<exists>x. ?Q x")
   proof cases
     assume Py: "P y"
     show ?thesis
     proof cases
       assume "x = y"
       with Py Cons.prems have "?Q []" by simp
       then show ?thesis ..
     next
       assume "x \<noteq> y"
       with Py Cons.prems show ?thesis by simp
     qed
   next
     assume "\<not> P y"
     with Cons obtain us vs where "?P (y#ys) (y#us) vs" by fastforce
     then have "?Q (y#us)" by simp
     then show ?thesis ..
   qed
 qed
 
 lemma filter_eq_ConsD:
   "filter P ys = x#xs \<Longrightarrow>
   \<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs"
   by(rule Cons_eq_filterD) simp
 
 lemma filter_eq_Cons_iff:
   "(filter P ys = x#xs) =
   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"
   by(auto dest:filter_eq_ConsD)
 
 lemma Cons_eq_filter_iff:
   "(x#xs = filter P ys) =
   (\<exists>us vs. ys = us @ x # vs \<and> (\<forall>u\<in>set us. \<not> P u) \<and> P x \<and> xs = filter P vs)"
   by(auto dest:Cons_eq_filterD)
 
 lemma inj_on_filter_key_eq:
   assumes "inj_on f (insert y (set xs))"
   shows "filter (\<lambda>x. f y = f x) xs = filter (HOL.eq y) xs"
   using assms by (induct xs) auto
 
 lemma filter_cong[fundef_cong]:
   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x) \<Longrightarrow> filter P xs = filter Q ys"
   by (induct ys arbitrary: xs) auto
 
 
 subsubsection \<open>List partitioning\<close>
 
 primrec partition :: "('a \<Rightarrow> bool) \<Rightarrow>'a list \<Rightarrow> 'a list \<times> 'a list" where
   "partition P [] = ([], [])" |
   "partition P (x # xs) =
   (let (yes, no) = partition P xs
    in if P x then (x # yes, no) else (yes, x # no))"
 
 lemma partition_filter1: "fst (partition P xs) = filter P xs"
   by (induct xs) (auto simp add: Let_def split_def)
 
 lemma partition_filter2: "snd (partition P xs) = filter (Not \<circ> P) xs"
   by (induct xs) (auto simp add: Let_def split_def)
 
 lemma partition_P:
   assumes "partition P xs = (yes, no)"
   shows "(\<forall>p \<in> set yes.  P p) \<and> (\<forall>p  \<in> set no. \<not> P p)"
 proof -
   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"
     by simp_all
   then show ?thesis by (simp_all add: partition_filter1 partition_filter2)
 qed
 
 lemma partition_set:
   assumes "partition P xs = (yes, no)"
   shows "set yes \<union> set no = set xs"
 proof -
   from assms have "yes = fst (partition P xs)" and "no = snd (partition P xs)"
     by simp_all
   then show ?thesis by (auto simp add: partition_filter1 partition_filter2)
 qed
 
 lemma partition_filter_conv[simp]:
   "partition f xs = (filter f xs,filter (Not \<circ> f) xs)"
   unfolding partition_filter2[symmetric]
   unfolding partition_filter1[symmetric] by simp
 
 declare partition.simps[simp del]
 
 
 subsubsection \<open>\<^const>\<open>nth\<close>\<close>
 
 lemma nth_Cons_0 [simp, code]: "(x # xs)!0 = x"
   by auto
 
 lemma nth_Cons_Suc [simp, code]: "(x # xs)!(Suc n) = xs!n"
   by auto
 
 declare nth.simps [simp del]
 
 lemma nth_Cons_pos[simp]: "0 < n \<Longrightarrow> (x#xs) ! n = xs ! (n - 1)"
   by(auto simp: Nat.gr0_conv_Suc)
 
 lemma nth_append:
   "(xs @ ys)!n = (if n < length xs then xs!n else ys!(n - length xs))"
 proof (induct xs arbitrary: n)
   case (Cons x xs)
   then show ?case
     using less_Suc_eq_0_disj by auto
 qed simp
 
 lemma nth_append_length [simp]: "(xs @ x # ys) ! length xs = x"
   by (induct xs) auto
 
 lemma nth_append_length_plus[simp]: "(xs @ ys) ! (length xs + n) = ys ! n"
   by (induct xs) auto
 
 lemma nth_map [simp]: "n < length xs \<Longrightarrow> (map f xs)!n = f(xs!n)"
 proof (induct xs arbitrary: n)
   case (Cons x xs)
   then show ?case
     using less_Suc_eq_0_disj by auto
 qed simp
 
 lemma nth_tl: "n < length (tl xs) \<Longrightarrow> tl xs ! n = xs ! Suc n"
   by (induction xs) auto
 
 lemma hd_conv_nth: "xs \<noteq> [] \<Longrightarrow> hd xs = xs!0"
   by(cases xs) simp_all
 
 
 lemma list_eq_iff_nth_eq:
   "(xs = ys) = (length xs = length ys \<and> (\<forall>i<length xs. xs!i = ys!i))"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys)
   show ?case
   proof (cases ys)
     case (Cons y ys)
     then show ?thesis
       using Cons.hyps by fastforce
   qed simp
 qed force
 
 lemma set_conv_nth: "set xs = {xs!i | i. i < length xs}"
 proof (induct xs)
   case (Cons x xs)
   have "insert x {xs ! i |i. i < length xs} = {(x # xs) ! i |i. i < Suc (length xs)}" (is "?L=?R")
   proof
     show "?L \<subseteq> ?R"
       by force
     show "?R \<subseteq> ?L"
       using less_Suc_eq_0_disj by auto
   qed
   with Cons show ?case
     by simp
 qed simp
 
 lemma in_set_conv_nth: "(x \<in> set xs) = (\<exists>i < length xs. xs!i = x)"
   by(auto simp:set_conv_nth)
 
 lemma nth_equal_first_eq:
   assumes "x \<notin> set xs"
   assumes "n \<le> length xs"
   shows "(x # xs) ! n = x \<longleftrightarrow> n = 0" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   show ?rhs
   proof (rule ccontr)
     assume "n \<noteq> 0"
     then have "n > 0" by simp
     with \<open>?lhs\<close> have "xs ! (n - 1) = x" by simp
     moreover from \<open>n > 0\<close> \<open>n \<le> length xs\<close> have "n - 1 < length xs" by simp
     ultimately have "\<exists>i<length xs. xs ! i = x" by auto
     with \<open>x \<notin> set xs\<close> in_set_conv_nth [of x xs] show False by simp
   qed
 next
   assume ?rhs then show ?lhs by simp
 qed
 
 lemma nth_non_equal_first_eq:
   assumes "x \<noteq> y"
   shows "(x # xs) ! n = y \<longleftrightarrow> xs ! (n - 1) = y \<and> n > 0" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume "?lhs" with assms have "n > 0" by (cases n) simp_all
   with \<open>?lhs\<close> show ?rhs by simp
 next
   assume "?rhs" then show "?lhs" by simp
 qed
 
 lemma list_ball_nth: "\<lbrakk>n < length xs; \<forall>x \<in> set xs. P x\<rbrakk> \<Longrightarrow> P(xs!n)"
   by (auto simp add: set_conv_nth)
 
 lemma nth_mem [simp]: "n < length xs \<Longrightarrow> xs!n \<in> set xs"
   by (auto simp add: set_conv_nth)
 
 lemma all_nth_imp_all_set:
   "\<lbrakk>\<forall>i < length xs. P(xs!i); x \<in> set xs\<rbrakk> \<Longrightarrow> P x"
   by (auto simp add: set_conv_nth)
 
 lemma all_set_conv_all_nth:
   "(\<forall>x \<in> set xs. P x) = (\<forall>i. i < length xs \<longrightarrow> P (xs ! i))"
   by (auto simp add: set_conv_nth)
 
 lemma rev_nth:
   "n < size xs \<Longrightarrow> rev xs ! n = xs ! (length xs - Suc n)"
 proof (induct xs arbitrary: n)
   case Nil thus ?case by simp
 next
   case (Cons x xs)
   hence n: "n < Suc (length xs)" by simp
   moreover
   { assume "n < length xs"
     with n obtain n' where n': "length xs - n = Suc n'"
       by (cases "length xs - n", auto)
     moreover
     from n' have "length xs - Suc n = n'" by simp
     ultimately
     have "xs ! (length xs - Suc n) = (x # xs) ! (length xs - n)" by simp
   }
   ultimately
   show ?case by (clarsimp simp add: Cons nth_append)
 qed
 
 lemma Skolem_list_nth:
   "(\<forall>i<k. \<exists>x. P i x) = (\<exists>xs. size xs = k \<and> (\<forall>i<k. P i (xs!i)))"
   (is "_ = (\<exists>xs. ?P k xs)")
 proof(induct k)
   case 0 show ?case by simp
 next
   case (Suc k)
   show ?case (is "?L = ?R" is "_ = (\<exists>xs. ?P' xs)")
   proof
     assume "?R" thus "?L" using Suc by auto
   next
     assume "?L"
     with Suc obtain x xs where "?P k xs \<and> P k x" by (metis less_Suc_eq)
     hence "?P'(xs@[x])" by(simp add:nth_append less_Suc_eq)
     thus "?R" ..
   qed
 qed
 
 
 subsubsection \<open>\<^const>\<open>list_update\<close>\<close>
 
 lemma length_list_update [simp]: "length(xs[i:=x]) = length xs"
   by (induct xs arbitrary: i) (auto split: nat.split)
 
 lemma nth_list_update:
   "i < length xs\<Longrightarrow> (xs[i:=x])!j = (if i = j then x else xs!j)"
   by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)
 
 lemma nth_list_update_eq [simp]: "i < length xs \<Longrightarrow> (xs[i:=x])!i = x"
   by (simp add: nth_list_update)
 
 lemma nth_list_update_neq [simp]: "i \<noteq> j \<Longrightarrow> xs[i:=x]!j = xs!j"
   by (induct xs arbitrary: i j) (auto simp add: nth_Cons split: nat.split)
 
 lemma list_update_id[simp]: "xs[i := xs!i] = xs"
   by (induct xs arbitrary: i) (simp_all split:nat.splits)
 
 lemma list_update_beyond[simp]: "length xs \<le> i \<Longrightarrow> xs[i:=x] = xs"
 proof (induct xs arbitrary: i)
   case (Cons x xs i)
   then show ?case
     by (metis leD length_list_update list_eq_iff_nth_eq nth_list_update_neq)
 qed simp
 
 lemma list_update_nonempty[simp]: "xs[k:=x] = [] \<longleftrightarrow> xs=[]"
   by (simp only: length_0_conv[symmetric] length_list_update)
 
 lemma list_update_same_conv:
   "i < length xs \<Longrightarrow> (xs[i := x] = xs) = (xs!i = x)"
   by (induct xs arbitrary: i) (auto split: nat.split)
 
 lemma list_update_append1:
   "i < size xs \<Longrightarrow> (xs @ ys)[i:=x] = xs[i:=x] @ ys"
   by (induct xs arbitrary: i)(auto split:nat.split)
 
 lemma list_update_append:
   "(xs @ ys) [n:= x] =
   (if n < length xs then xs[n:= x] @ ys else xs @ (ys [n-length xs:= x]))"
   by (induct xs arbitrary: n) (auto split:nat.splits)
 
 lemma list_update_length [simp]:
   "(xs @ x # ys)[length xs := y] = (xs @ y # ys)"
   by (induct xs, auto)
 
 lemma map_update: "map f (xs[k:= y]) = (map f xs)[k := f y]"
   by(induct xs arbitrary: k)(auto split:nat.splits)
 
 lemma rev_update:
   "k < length xs \<Longrightarrow> rev (xs[k:= y]) = (rev xs)[length xs - k - 1 := y]"
   by (induct xs arbitrary: k) (auto simp: list_update_append split:nat.splits)
 
 lemma update_zip:
   "(zip xs ys)[i:=xy] = zip (xs[i:=fst xy]) (ys[i:=snd xy])"
   by (induct ys arbitrary: i xy xs) (auto, case_tac xs, auto split: nat.split)
 
 lemma set_update_subset_insert: "set(xs[i:=x]) \<le> insert x (set xs)"
   by (induct xs arbitrary: i) (auto split: nat.split)
 
 lemma set_update_subsetI: "\<lbrakk>set xs \<subseteq> A; x \<in> A\<rbrakk> \<Longrightarrow> set(xs[i := x]) \<subseteq> A"
   by (blast dest!: set_update_subset_insert [THEN subsetD])
 
 lemma set_update_memI: "n < length xs \<Longrightarrow> x \<in> set (xs[n := x])"
   by (induct xs arbitrary: n) (auto split:nat.splits)
 
 lemma list_update_overwrite[simp]:
   "xs [i := x, i := y] = xs [i := y]"
   by (induct xs arbitrary: i) (simp_all split: nat.split)
 
 lemma list_update_swap:
   "i \<noteq> i' \<Longrightarrow> xs [i := x, i' := x'] = xs [i' := x', i := x]"
   by (induct xs arbitrary: i i') (simp_all split: nat.split)
 
 lemma list_update_code [code]:
   "[][i := y] = []"
   "(x # xs)[0 := y] = y # xs"
   "(x # xs)[Suc i := y] = x # xs[i := y]"
   by simp_all
 
 
 subsubsection \<open>\<^const>\<open>last\<close> and \<^const>\<open>butlast\<close>\<close>
 
 lemma hd_Nil_eq_last: "hd Nil = last Nil"
   unfolding hd_def last_def by simp
 
 lemma last_snoc [simp]: "last (xs @ [x]) = x"
   by (induct xs) auto
 
 lemma butlast_snoc [simp]: "butlast (xs @ [x]) = xs"
   by (induct xs) auto
 
 lemma last_ConsL: "xs = [] \<Longrightarrow> last(x#xs) = x"
   by simp
 
 lemma last_ConsR: "xs \<noteq> [] \<Longrightarrow> last(x#xs) = last xs"
   by simp
 
 lemma last_append: "last(xs @ ys) = (if ys = [] then last xs else last ys)"
   by (induct xs) (auto)
 
 lemma last_appendL[simp]: "ys = [] \<Longrightarrow> last(xs @ ys) = last xs"
   by(simp add:last_append)
 
 lemma last_appendR[simp]: "ys \<noteq> [] \<Longrightarrow> last(xs @ ys) = last ys"
   by(simp add:last_append)
 
 lemma last_tl: "xs = [] \<or> tl xs \<noteq> [] \<Longrightarrow>last (tl xs) = last xs"
   by (induct xs) simp_all
 
 lemma butlast_tl: "butlast (tl xs) = tl (butlast xs)"
   by (induct xs) simp_all
 
 lemma hd_rev: "hd(rev xs) = last xs"
   by (metis hd_Cons_tl hd_Nil_eq_last last_snoc rev_eq_Cons_iff rev_is_Nil_conv)
 
 lemma last_rev: "last(rev xs) = hd xs"
   by (metis hd_rev rev_swap)
 
 lemma last_in_set[simp]: "as \<noteq> [] \<Longrightarrow> last as \<in> set as"
   by (induct as) auto
 
 lemma length_butlast [simp]: "length (butlast xs) = length xs - 1"
   by (induct xs rule: rev_induct) auto
 
 lemma butlast_append:
   "butlast (xs @ ys) = (if ys = [] then butlast xs else xs @ butlast ys)"
   by (induct xs arbitrary: ys) auto
 
 lemma append_butlast_last_id [simp]:
   "xs \<noteq> [] \<Longrightarrow> butlast xs @ [last xs] = xs"
   by (induct xs) auto
 
 lemma in_set_butlastD: "x \<in> set (butlast xs) \<Longrightarrow> x \<in> set xs"
   by (induct xs) (auto split: if_split_asm)
 
 lemma in_set_butlast_appendI:
   "x \<in> set (butlast xs) \<or> x \<in> set (butlast ys) \<Longrightarrow> x \<in> set (butlast (xs @ ys))"
   by (auto dest: in_set_butlastD simp add: butlast_append)
 
 lemma last_drop[simp]: "n < length xs \<Longrightarrow> last (drop n xs) = last xs"
   by (induct xs arbitrary: n)(auto split:nat.split)
 
 lemma nth_butlast:
   assumes "n < length (butlast xs)" shows "butlast xs ! n = xs ! n"
 proof (cases xs)
   case (Cons y ys)
   moreover from assms have "butlast xs ! n = (butlast xs @ [last xs]) ! n"
     by (simp add: nth_append)
   ultimately show ?thesis using append_butlast_last_id by simp
 qed simp
 
 lemma last_conv_nth: "xs\<noteq>[] \<Longrightarrow> last xs = xs!(length xs - 1)"
   by(induct xs)(auto simp:neq_Nil_conv)
 
 lemma butlast_conv_take: "butlast xs = take (length xs - 1) xs"
   by (induction xs rule: induct_list012) simp_all
 
 lemma last_list_update:
   "xs \<noteq> [] \<Longrightarrow> last(xs[k:=x]) = (if k = size xs - 1 then x else last xs)"
   by (auto simp: last_conv_nth)
 
 lemma butlast_list_update:
   "butlast(xs[k:=x]) =
   (if k = size xs - 1 then butlast xs else (butlast xs)[k:=x])"
   by(cases xs rule:rev_cases)(auto simp: list_update_append split: nat.splits)
 
 lemma last_map: "xs \<noteq> [] \<Longrightarrow> last (map f xs) = f (last xs)"
   by (cases xs rule: rev_cases) simp_all
 
 lemma map_butlast: "map f (butlast xs) = butlast (map f xs)"
   by (induct xs) simp_all
 
 lemma snoc_eq_iff_butlast:
   "xs @ [x] = ys \<longleftrightarrow> (ys \<noteq> [] \<and> butlast ys = xs \<and> last ys = x)"
   by fastforce
 
 corollary longest_common_suffix:
   "\<exists>ss xs' ys'. xs = xs' @ ss \<and> ys = ys' @ ss
        \<and> (xs' = [] \<or> ys' = [] \<or> last xs' \<noteq> last ys')"
   using longest_common_prefix[of "rev xs" "rev ys"]
   unfolding rev_swap rev_append by (metis last_rev rev_is_Nil_conv)
 
 lemma butlast_rev [simp]: "butlast (rev xs) = rev (tl xs)"
   by (cases xs) simp_all
 
 
 subsubsection \<open>\<^const>\<open>take\<close> and \<^const>\<open>drop\<close>\<close>
 
 lemma take_0: "take 0 xs = []"
   by (induct xs) auto
 
 lemma drop_0: "drop 0 xs = xs"
   by (induct xs) auto
 
 lemma take0[simp]: "take 0 = (\<lambda>xs. [])"
   by(rule ext) (rule take_0)
 
 lemma drop0[simp]: "drop 0 = (\<lambda>x. x)"
   by(rule ext) (rule drop_0)
 
 lemma take_Suc_Cons [simp]: "take (Suc n) (x # xs) = x # take n xs"
   by simp
 
 lemma drop_Suc_Cons [simp]: "drop (Suc n) (x # xs) = drop n xs"
   by simp
 
 declare take_Cons [simp del] and drop_Cons [simp del]
 
 lemma take_Suc: "xs \<noteq> [] \<Longrightarrow> take (Suc n) xs = hd xs # take n (tl xs)"
   by(clarsimp simp add:neq_Nil_conv)
 
 lemma drop_Suc: "drop (Suc n) xs = drop n (tl xs)"
   by(cases xs, simp_all)
 
 lemma hd_take[simp]: "j > 0 \<Longrightarrow> hd (take j xs) = hd xs"
   by (metis gr0_conv_Suc list.sel(1) take.simps(1) take_Suc)
 
 lemma take_tl: "take n (tl xs) = tl (take (Suc n) xs)"
   by (induct xs arbitrary: n) simp_all
 
 lemma drop_tl: "drop n (tl xs) = tl(drop n xs)"
   by(induct xs arbitrary: n, simp_all add:drop_Cons drop_Suc split:nat.split)
 
 lemma tl_take: "tl (take n xs) = take (n - 1) (tl xs)"
   by (cases n, simp, cases xs, auto)
 
 lemma tl_drop: "tl (drop n xs) = drop n (tl xs)"
   by (simp only: drop_tl)
 
 lemma nth_via_drop: "drop n xs = y#ys \<Longrightarrow> xs!n = y"
   by (induct xs arbitrary: n, simp)(auto simp: drop_Cons nth_Cons split: nat.splits)
 
 lemma take_Suc_conv_app_nth:
   "i < length xs \<Longrightarrow> take (Suc i) xs = take i xs @ [xs!i]"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma Cons_nth_drop_Suc:
   "i < length xs \<Longrightarrow> (xs!i) # (drop (Suc i) xs) = drop i xs"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma length_take [simp]: "length (take n xs) = min (length xs) n"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma length_drop [simp]: "length (drop n xs) = (length xs - n)"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma take_all [simp]: "length xs \<le> n \<Longrightarrow> take n xs = xs"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma drop_all [simp]: "length xs \<le> n \<Longrightarrow> drop n xs = []"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma take_all_iff [simp]: "take n xs = xs \<longleftrightarrow> length xs \<le> n"
 by (metis length_take min.order_iff take_all)
 
 lemma drop_all_iff [simp]: "drop n xs = [] \<longleftrightarrow> length xs \<le> n"
 by (metis diff_is_0_eq drop_all length_drop list.size(3))
 
 lemma take_append [simp]:
   "take n (xs @ ys) = (take n xs @ take (n - length xs) ys)"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma drop_append [simp]:
   "drop n (xs @ ys) = drop n xs @ drop (n - length xs) ys"
   by (induct n arbitrary: xs) (auto, case_tac xs, auto)
 
 lemma take_take [simp]: "take n (take m xs) = take (min n m) xs"
 proof (induct m arbitrary: xs n)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases n) simp_all
 qed
 
 lemma drop_drop [simp]: "drop n (drop m xs) = drop (n + m) xs"
 proof (induct m arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma take_drop: "take n (drop m xs) = drop m (take (n + m) xs)"
 proof (induct m arbitrary: xs n)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases n) simp_all
 qed
 
 lemma drop_take: "drop n (take m xs) = take (m-n) (drop n xs)"
   by(induct xs arbitrary: m n)(auto simp: take_Cons drop_Cons split: nat.split)
 
 lemma append_take_drop_id [simp]: "take n xs @ drop n xs = xs"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma take_eq_Nil[simp]: "(take n xs = []) = (n = 0 \<or> xs = [])"
   by(induct xs arbitrary: n)(auto simp: take_Cons split:nat.split)
 
 lemma drop_eq_Nil[simp]: "(drop n xs = []) = (length xs \<le> n)"
   by (induct xs arbitrary: n) (auto simp: drop_Cons split:nat.split)
 
 lemma take_map: "take n (map f xs) = map f (take n xs)"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma drop_map: "drop n (map f xs) = map f (drop n xs)"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma rev_take: "rev (take i xs) = drop (length xs - i) (rev xs)"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma rev_drop: "rev (drop i xs) = take (length xs - i) (rev xs)"
 proof (induct xs arbitrary: i)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases i) auto
 qed
 
 lemma drop_rev: "drop n (rev xs) = rev (take (length xs - n) xs)"
   by (cases "length xs < n") (auto simp: rev_take)
 
 lemma take_rev: "take n (rev xs) = rev (drop (length xs - n) xs)"
   by (cases "length xs < n") (auto simp: rev_drop)
 
 lemma nth_take [simp]: "i < n \<Longrightarrow> (take n xs)!i = xs!i"
 proof (induct xs arbitrary: i n)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases n; cases i) simp_all
 qed
 
 lemma nth_drop [simp]:
   "n \<le> length xs \<Longrightarrow> (drop n xs)!i = xs!(n + i)"
 proof (induct n arbitrary: xs)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs) simp_all
 qed
 
 lemma butlast_take:
   "n \<le> length xs \<Longrightarrow> butlast (take n xs) = take (n - 1) xs"
   by (simp add: butlast_conv_take min.absorb1 min.absorb2)
 
 lemma butlast_drop: "butlast (drop n xs) = drop n (butlast xs)"
   by (simp add: butlast_conv_take drop_take ac_simps)
 
 lemma take_butlast: "n < length xs \<Longrightarrow> take n (butlast xs) = take n xs"
   by (simp add: butlast_conv_take min.absorb1)
 
 lemma drop_butlast: "drop n (butlast xs) = butlast (drop n xs)"
   by (simp add: butlast_conv_take drop_take ac_simps)
 
 lemma butlast_power: "(butlast ^^ n) xs = take (length xs - n) xs"
   by (induct n) (auto simp: butlast_take)
 
 lemma hd_drop_conv_nth: "n < length xs \<Longrightarrow> hd(drop n xs) = xs!n"
   by(simp add: hd_conv_nth)
 
 lemma set_take_subset_set_take:
   "m \<le> n \<Longrightarrow> set(take m xs) \<le> set(take n xs)"
 proof (induct xs arbitrary: m n)
   case (Cons x xs m n) then show ?case
     by (cases n) (auto simp: take_Cons)
 qed simp
 
 lemma set_take_subset: "set(take n xs) \<subseteq> set xs"
   by(induct xs arbitrary: n)(auto simp:take_Cons split:nat.split)
 
 lemma set_drop_subset: "set(drop n xs) \<subseteq> set xs"
   by(induct xs arbitrary: n)(auto simp:drop_Cons split:nat.split)
 
 lemma set_drop_subset_set_drop:
   "m \<ge> n \<Longrightarrow> set(drop m xs) \<le> set(drop n xs)"
 proof (induct xs arbitrary: m n)
   case (Cons x xs m n)
   then show ?case
     by (clarsimp simp: drop_Cons split: nat.split) (metis set_drop_subset subset_iff)
 qed simp
 
 lemma in_set_takeD: "x \<in> set(take n xs) \<Longrightarrow> x \<in> set xs"
   using set_take_subset by fast
 
 lemma in_set_dropD: "x \<in> set(drop n xs) \<Longrightarrow> x \<in> set xs"
   using set_drop_subset by fast
 
 lemma append_eq_conv_conj:
   "(xs @ ys = zs) = (xs = take (length xs) zs \<and> ys = drop (length xs) zs)"
 proof (induct xs arbitrary: zs)
   case (Cons x xs zs) then show ?case
     by (cases zs, auto)
 qed auto
 
 lemma map_eq_append_conv:
   "map f xs = ys @ zs \<longleftrightarrow> (\<exists>us vs. xs = us @ vs \<and> ys = map f us \<and> zs = map f vs)"
 proof -
   have "map f xs \<noteq> ys @ zs \<and> map f xs \<noteq> ys @ zs \<or> map f xs \<noteq> ys @ zs \<or> map f xs = ys @ zs \<and>
     (\<exists>bs bsa. xs = bs @ bsa \<and> ys = map f bs \<and> zs = map f bsa)"
     by (metis append_eq_conv_conj append_take_drop_id drop_map take_map)
   then show ?thesis
     using map_append by blast
 qed
 
 lemma append_eq_map_conv:
   "ys @ zs = map f xs \<longleftrightarrow> (\<exists>us vs. xs = us @ vs \<and> ys = map f us \<and> zs = map f vs)"
 by (metis map_eq_append_conv)
 
 lemma take_add:  "take (i+j) xs = take i xs @ take j (drop i xs)"
 proof (induct xs arbitrary: i)
   case (Cons x xs i) then show ?case
     by (cases i, auto)
 qed auto
 
 lemma append_eq_append_conv_if:
   "(xs\<^sub>1 @ xs\<^sub>2 = ys\<^sub>1 @ ys\<^sub>2) =
   (if size xs\<^sub>1 \<le> size ys\<^sub>1
    then xs\<^sub>1 = take (size xs\<^sub>1) ys\<^sub>1 \<and> xs\<^sub>2 = drop (size xs\<^sub>1) ys\<^sub>1 @ ys\<^sub>2
    else take (size ys\<^sub>1) xs\<^sub>1 = ys\<^sub>1 \<and> drop (size ys\<^sub>1) xs\<^sub>1 @ xs\<^sub>2 = ys\<^sub>2)"
 proof (induct xs\<^sub>1 arbitrary: ys\<^sub>1)
   case (Cons a xs\<^sub>1 ys\<^sub>1) then show ?case
     by (cases ys\<^sub>1, auto)
 qed auto
 
 lemma take_hd_drop:
   "n < length xs \<Longrightarrow> take n xs @ [hd (drop n xs)] = take (Suc n) xs"
   by (induct xs arbitrary: n) (simp_all add:drop_Cons split:nat.split)
 
 lemma id_take_nth_drop:
   "i < length xs \<Longrightarrow> xs = take i xs @ xs!i # drop (Suc i) xs"
 proof -
   assume si: "i < length xs"
   hence "xs = take (Suc i) xs @ drop (Suc i) xs" by auto
   moreover
   from si have "take (Suc i) xs = take i xs @ [xs!i]"
     using take_Suc_conv_app_nth by blast
   ultimately show ?thesis by auto
 qed
 
 lemma take_update_cancel[simp]: "n \<le> m \<Longrightarrow> take n (xs[m := y]) = take n xs"
   by(simp add: list_eq_iff_nth_eq)
 
 lemma drop_update_cancel[simp]: "n < m \<Longrightarrow> drop m (xs[n := x]) = drop m xs"
   by(simp add: list_eq_iff_nth_eq)
 
 lemma upd_conv_take_nth_drop:
   "i < length xs \<Longrightarrow> xs[i:=a] = take i xs @ a # drop (Suc i) xs"
 proof -
   assume i: "i < length xs"
   have "xs[i:=a] = (take i xs @ xs!i # drop (Suc i) xs)[i:=a]"
     by(rule arg_cong[OF id_take_nth_drop[OF i]])
   also have "\<dots> = take i xs @ a # drop (Suc i) xs"
     using i by (simp add: list_update_append)
   finally show ?thesis .
 qed
 
 lemma take_update_swap: "take m (xs[n := x]) = (take m xs)[n := x]"
 proof (cases "n \<ge> length xs")
   case False
   then show ?thesis
     by (simp add: upd_conv_take_nth_drop take_Cons drop_take min_def diff_Suc split: nat.split)
 qed auto
 
 lemma drop_update_swap:
   assumes "m \<le> n" shows "drop m (xs[n := x]) = (drop m xs)[n-m := x]"
 proof (cases "n \<ge> length xs")
   case False
   with assms show ?thesis
     by (simp add: upd_conv_take_nth_drop drop_take)
 qed auto
 
 lemma nth_image: "l \<le> size xs \<Longrightarrow> nth xs ` {0..<l} = set(take l xs)"
   by(auto simp: set_conv_nth image_def) (metis Suc_le_eq nth_take order_trans)
 
 
 subsubsection \<open>\<^const>\<open>takeWhile\<close> and \<^const>\<open>dropWhile\<close>\<close>
 
 lemma length_takeWhile_le: "length (takeWhile P xs) \<le> length xs"
   by (induct xs) auto
 
 lemma takeWhile_dropWhile_id [simp]: "takeWhile P xs @ dropWhile P xs = xs"
   by (induct xs) auto
 
 lemma takeWhile_append1 [simp]:
   "\<lbrakk>x \<in> set xs; \<not>P(x)\<rbrakk> \<Longrightarrow> takeWhile P (xs @ ys) = takeWhile P xs"
   by (induct xs) auto
 
 lemma takeWhile_append2 [simp]:
   "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> takeWhile P (xs @ ys) = xs @ takeWhile P ys"
   by (induct xs) auto
 
 lemma takeWhile_append:
   "takeWhile P (xs @ ys) = (if \<forall>x\<in>set xs. P x then xs @ takeWhile P ys else takeWhile P xs)"
 using takeWhile_append1[of _ xs P ys] takeWhile_append2[of xs P ys] by auto
 
 lemma takeWhile_tail: "\<not> P x \<Longrightarrow> takeWhile P (xs @ (x#l)) = takeWhile P xs"
   by (induct xs) auto
 
 lemma takeWhile_eq_Nil_iff: "takeWhile P xs = [] \<longleftrightarrow> xs = [] \<or> \<not>P (hd xs)"
 by (cases xs) auto
 
 lemma takeWhile_nth: "j < length (takeWhile P xs) \<Longrightarrow> takeWhile P xs ! j = xs ! j"
   by (metis nth_append takeWhile_dropWhile_id)
 
 lemma dropWhile_nth: "j < length (dropWhile P xs) \<Longrightarrow>
   dropWhile P xs ! j = xs ! (j + length (takeWhile P xs))"
   by (metis add.commute nth_append_length_plus takeWhile_dropWhile_id)
 
 lemma length_dropWhile_le: "length (dropWhile P xs) \<le> length xs"
   by (induct xs) auto
 
 lemma dropWhile_append1 [simp]:
   "\<lbrakk>x \<in> set xs; \<not>P(x)\<rbrakk> \<Longrightarrow> dropWhile P (xs @ ys) = (dropWhile P xs)@ys"
   by (induct xs) auto
 
 lemma dropWhile_append2 [simp]:
   "(\<And>x. x \<in> set xs \<Longrightarrow> P(x)) \<Longrightarrow> dropWhile P (xs @ ys) = dropWhile P ys"
   by (induct xs) auto
 
 lemma dropWhile_append3:
   "\<not> P y \<Longrightarrow>dropWhile P (xs @ y # ys) = dropWhile P xs @ y # ys"
   by (induct xs) auto
 
 lemma dropWhile_append:
   "dropWhile P (xs @ ys) = (if \<forall>x\<in>set xs. P x then dropWhile P ys else dropWhile P xs @ ys)"
 using dropWhile_append1[of _ xs P ys] dropWhile_append2[of xs P ys] by auto
 
 lemma dropWhile_last:
   "x \<in> set xs \<Longrightarrow> \<not> P x \<Longrightarrow> last (dropWhile P xs) = last xs"
   by (auto simp add: dropWhile_append3 in_set_conv_decomp)
 
 lemma set_dropWhileD: "x \<in> set (dropWhile P xs) \<Longrightarrow> x \<in> set xs"
   by (induct xs) (auto split: if_split_asm)
 
 lemma set_takeWhileD: "x \<in> set (takeWhile P xs) \<Longrightarrow> x \<in> set xs \<and> P x"
   by (induct xs) (auto split: if_split_asm)
 
 lemma takeWhile_eq_all_conv[simp]:
   "(takeWhile P xs = xs) = (\<forall>x \<in> set xs. P x)"
   by(induct xs, auto)
 
 lemma dropWhile_eq_Nil_conv[simp]:
   "(dropWhile P xs = []) = (\<forall>x \<in> set xs. P x)"
   by(induct xs, auto)
 
 lemma dropWhile_eq_Cons_conv:
   "(dropWhile P xs = y#ys) = (xs = takeWhile P xs @ y # ys \<and> \<not> P y)"
   by(induct xs, auto)
 
 lemma dropWhile_eq_self_iff: "dropWhile P xs = xs \<longleftrightarrow> xs = [] \<or> \<not>P (hd xs)"
 by (cases xs) (auto simp: dropWhile_eq_Cons_conv)
 
 lemma distinct_takeWhile[simp]: "distinct xs \<Longrightarrow> distinct (takeWhile P xs)"
   by (induct xs) (auto dest: set_takeWhileD)
 
 lemma distinct_dropWhile[simp]: "distinct xs \<Longrightarrow> distinct (dropWhile P xs)"
   by (induct xs) auto
 
 lemma takeWhile_map: "takeWhile P (map f xs) = map f (takeWhile (P \<circ> f) xs)"
   by (induct xs) auto
 
 lemma dropWhile_map: "dropWhile P (map f xs) = map f (dropWhile (P \<circ> f) xs)"
   by (induct xs) auto
 
 lemma takeWhile_eq_take: "takeWhile P xs = take (length (takeWhile P xs)) xs"
   by (induct xs) auto
 
 lemma dropWhile_eq_drop: "dropWhile P xs = drop (length (takeWhile P xs)) xs"
   by (induct xs) auto
 
 lemma hd_dropWhile: "dropWhile P xs \<noteq> [] \<Longrightarrow> \<not> P (hd (dropWhile P xs))"
   by (induct xs) auto
 
 lemma takeWhile_eq_filter:
   assumes "\<And> x. x \<in> set (dropWhile P xs) \<Longrightarrow> \<not> P x"
   shows "takeWhile P xs = filter P xs"
 proof -
   have A: "filter P xs = filter P (takeWhile P xs @ dropWhile P xs)"
     by simp
   have B: "filter P (dropWhile P xs) = []"
     unfolding filter_empty_conv using assms by blast
   have "filter P xs = takeWhile P xs"
     unfolding A filter_append B
     by (auto simp add: filter_id_conv dest: set_takeWhileD)
   thus ?thesis ..
 qed
 
 lemma takeWhile_eq_take_P_nth:
   "\<lbrakk> \<And> i. \<lbrakk> i < n ; i < length xs \<rbrakk> \<Longrightarrow> P (xs ! i) ; n < length xs \<Longrightarrow> \<not> P (xs ! n) \<rbrakk> \<Longrightarrow>
   takeWhile P xs = take n xs"
 proof (induct xs arbitrary: n)
   case Nil
   thus ?case by simp
 next
   case (Cons x xs)
   show ?case
   proof (cases n)
     case 0
     with Cons show ?thesis by simp
   next
     case [simp]: (Suc n')
     have "P x" using Cons.prems(1)[of 0] by simp
     moreover have "takeWhile P xs = take n' xs"
     proof (rule Cons.hyps)
       fix i
       assume "i < n'" "i < length xs"
       thus "P (xs ! i)" using Cons.prems(1)[of "Suc i"] by simp
     next
       assume "n' < length xs"
       thus "\<not> P (xs ! n')" using Cons by auto
     qed
     ultimately show ?thesis by simp
   qed
 qed
 
 lemma nth_length_takeWhile:
   "length (takeWhile P xs) < length xs \<Longrightarrow> \<not> P (xs ! length (takeWhile P xs))"
   by (induct xs) auto
 
 lemma length_takeWhile_less_P_nth:
   assumes all: "\<And> i. i < j \<Longrightarrow> P (xs ! i)" and "j \<le> length xs"
   shows "j \<le> length (takeWhile P xs)"
 proof (rule classical)
   assume "\<not> ?thesis"
   hence "length (takeWhile P xs) < length xs" using assms by simp
   thus ?thesis using all \<open>\<not> ?thesis\<close> nth_length_takeWhile[of P xs] by auto
 qed
 
 lemma takeWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>
   takeWhile (\<lambda>y. y \<noteq> x) (rev xs) = rev (tl (dropWhile (\<lambda>y. y \<noteq> x) xs))"
   by(induct xs) (auto simp: takeWhile_tail[where l="[]"])
 
 lemma dropWhile_neq_rev: "\<lbrakk>distinct xs; x \<in> set xs\<rbrakk> \<Longrightarrow>
   dropWhile (\<lambda>y. y \<noteq> x) (rev xs) = x # rev (takeWhile (\<lambda>y. y \<noteq> x) xs)"
 proof (induct xs)
   case (Cons a xs)
   then show ?case
     by(auto, subst dropWhile_append2, auto)
 qed simp
 
 lemma takeWhile_not_last:
   "distinct xs \<Longrightarrow> takeWhile (\<lambda>y. y \<noteq> last xs) xs = butlast xs"
   by(induction xs rule: induct_list012) auto
 
 lemma takeWhile_cong [fundef_cong]:
   "\<lbrakk>l = k; \<And>x. x \<in> set l \<Longrightarrow> P x = Q x\<rbrakk>
   \<Longrightarrow> takeWhile P l = takeWhile Q k"
   by (induct k arbitrary: l) (simp_all)
 
 lemma dropWhile_cong [fundef_cong]:
   "\<lbrakk>l = k; \<And>x. x \<in> set l \<Longrightarrow> P x = Q x\<rbrakk>
   \<Longrightarrow> dropWhile P l = dropWhile Q k"
   by (induct k arbitrary: l, simp_all)
 
 lemma takeWhile_idem [simp]:
   "takeWhile P (takeWhile P xs) = takeWhile P xs"
   by (induct xs) auto
 
 lemma dropWhile_idem [simp]:
   "dropWhile P (dropWhile P xs) = dropWhile P xs"
   by (induct xs) auto
 
 
 subsubsection \<open>\<^const>\<open>zip\<close>\<close>
 
 lemma zip_Nil [simp]: "zip [] ys = []"
   by (induct ys) auto
 
 lemma zip_Cons_Cons [simp]: "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
   by simp
 
 declare zip_Cons [simp del]
 
 lemma [code]:
   "zip [] ys = []"
   "zip xs [] = []"
   "zip (x # xs) (y # ys) = (x, y) # zip xs ys"
   by (fact zip_Nil zip.simps(1) zip_Cons_Cons)+
 
 lemma zip_Cons1:
   "zip (x#xs) ys = (case ys of [] \<Rightarrow> [] | y#ys \<Rightarrow> (x,y)#zip xs ys)"
   by(auto split:list.split)
 
 lemma length_zip [simp]:
   "length (zip xs ys) = min (length xs) (length ys)"
   by (induct xs ys rule:list_induct2') auto
 
 lemma zip_obtain_same_length:
   assumes "\<And>zs ws n. length zs = length ws \<Longrightarrow> n = min (length xs) (length ys)
     \<Longrightarrow> zs = take n xs \<Longrightarrow> ws = take n ys \<Longrightarrow> P (zip zs ws)"
   shows "P (zip xs ys)"
 proof -
   let ?n = "min (length xs) (length ys)"
   have "P (zip (take ?n xs) (take ?n ys))"
     by (rule assms) simp_all
   moreover have "zip xs ys = zip (take ?n xs) (take ?n ys)"
   proof (induct xs arbitrary: ys)
     case Nil then show ?case by simp
   next
     case (Cons x xs) then show ?case by (cases ys) simp_all
   qed
   ultimately show ?thesis by simp
 qed
 
 lemma zip_append1:
   "zip (xs @ ys) zs =
   zip xs (take (length xs) zs) @ zip ys (drop (length xs) zs)"
   by (induct xs zs rule:list_induct2') auto
 
 lemma zip_append2:
   "zip xs (ys @ zs) =
   zip (take (length ys) xs) ys @ zip (drop (length ys) xs) zs"
   by (induct xs ys rule:list_induct2') auto
 
 lemma zip_append [simp]:
   "\<lbrakk>length xs = length us\<rbrakk> \<Longrightarrow>
   zip (xs@ys) (us@vs) = zip xs us @ zip ys vs"
   by (simp add: zip_append1)
 
 lemma zip_rev:
   "length xs = length ys \<Longrightarrow> zip (rev xs) (rev ys) = rev (zip xs ys)"
   by (induct rule:list_induct2, simp_all)
 
 lemma zip_map_map:
   "zip (map f xs) (map g ys) = map (\<lambda> (x, y). (f x, g y)) (zip xs ys)"
 proof (induct xs arbitrary: ys)
   case (Cons x xs) note Cons_x_xs = Cons.hyps
   show ?case
   proof (cases ys)
     case (Cons y ys')
     show ?thesis unfolding Cons using Cons_x_xs by simp
   qed simp
 qed simp
 
 lemma zip_map1:
   "zip (map f xs) ys = map (\<lambda>(x, y). (f x, y)) (zip xs ys)"
   using zip_map_map[of f xs "\<lambda>x. x" ys] by simp
 
 lemma zip_map2:
   "zip xs (map f ys) = map (\<lambda>(x, y). (x, f y)) (zip xs ys)"
   using zip_map_map[of "\<lambda>x. x" xs f ys] by simp
 
 lemma map_zip_map:
   "map f (zip (map g xs) ys) = map (%(x,y). f(g x, y)) (zip xs ys)"
   by (auto simp: zip_map1)
 
 lemma map_zip_map2:
   "map f (zip xs (map g ys)) = map (%(x,y). f(x, g y)) (zip xs ys)"
   by (auto simp: zip_map2)
 
 text\<open>Courtesy of Andreas Lochbihler:\<close>
 lemma zip_same_conv_map: "zip xs xs = map (\<lambda>x. (x, x)) xs"
   by(induct xs) auto
 
 lemma nth_zip [simp]:
   "\<lbrakk>i < length xs; i < length ys\<rbrakk> \<Longrightarrow> (zip xs ys)!i = (xs!i, ys!i)"
 proof (induct ys arbitrary: i xs)
   case (Cons y ys)
   then show ?case
     by (cases xs) (simp_all add: nth.simps split: nat.split)
 qed auto
 
 lemma set_zip:
   "set (zip xs ys) = {(xs!i, ys!i) | i. i < min (length xs) (length ys)}"
   by(simp add: set_conv_nth cong: rev_conj_cong)
 
 lemma zip_same: "((a,b) \<in> set (zip xs xs)) = (a \<in> set xs \<and> a = b)"
   by(induct xs) auto
 
 lemma zip_update: "zip (xs[i:=x]) (ys[i:=y]) = (zip xs ys)[i:=(x,y)]"
   by (simp add: update_zip)
 
 lemma zip_replicate [simp]:
   "zip (replicate i x) (replicate j y) = replicate (min i j) (x,y)"
 proof (induct i arbitrary: j)
   case (Suc i)
   then show ?case
     by (cases j, auto)
 qed auto
 
 lemma zip_replicate1: "zip (replicate n x) ys = map (Pair x) (take n ys)"
   by(induction ys arbitrary: n)(case_tac [2] n, simp_all)
 
 lemma take_zip: "take n (zip xs ys) = zip (take n xs) (take n ys)"
 proof (induct n arbitrary: xs ys)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases ys) simp_all
 qed
 
 lemma drop_zip: "drop n (zip xs ys) = zip (drop n xs) (drop n ys)"
 proof (induct n arbitrary: xs ys)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case by (cases xs; cases ys) simp_all
 qed
 
 lemma zip_takeWhile_fst: "zip (takeWhile P xs) ys = takeWhile (P \<circ> fst) (zip xs ys)"
 proof (induct xs arbitrary: ys)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases ys) auto
 qed
 
 lemma zip_takeWhile_snd: "zip xs (takeWhile P ys) = takeWhile (P \<circ> snd) (zip xs ys)"
 proof (induct xs arbitrary: ys)
   case Nil
   then show ?case by simp
 next
   case Cons
   then show ?case by (cases ys) auto
 qed
 
 lemma set_zip_leftD: "(x,y)\<in> set (zip xs ys) \<Longrightarrow> x \<in> set xs"
   by (induct xs ys rule:list_induct2') auto
 
 lemma set_zip_rightD: "(x,y)\<in> set (zip xs ys) \<Longrightarrow> y \<in> set ys"
   by (induct xs ys rule:list_induct2') auto
 
 lemma in_set_zipE:
   "(x,y) \<in> set(zip xs ys) \<Longrightarrow> (\<lbrakk> x \<in> set xs; y \<in> set ys \<rbrakk> \<Longrightarrow> R) \<Longrightarrow> R"
   by(blast dest: set_zip_leftD set_zip_rightD)
 
 lemma zip_map_fst_snd: "zip (map fst zs) (map snd zs) = zs"
   by (induct zs) simp_all
 
 lemma zip_eq_conv:
   "length xs = length ys \<Longrightarrow> zip xs ys = zs \<longleftrightarrow> map fst zs = xs \<and> map snd zs = ys"
   by (auto simp add: zip_map_fst_snd)
 
 lemma in_set_zip:
   "p \<in> set (zip xs ys) \<longleftrightarrow> (\<exists>n. xs ! n = fst p \<and> ys ! n = snd p
   \<and> n < length xs \<and> n < length ys)"
   by (cases p) (auto simp add: set_zip)
 
 lemma in_set_impl_in_set_zip1:
   assumes "length xs = length ys"
   assumes "x \<in> set xs"
   obtains y where "(x, y) \<in> set (zip xs ys)"
 proof -
   from assms have "x \<in> set (map fst (zip xs ys))" by simp
   from this that show ?thesis by fastforce
 qed
 
 lemma in_set_impl_in_set_zip2:
   assumes "length xs = length ys"
   assumes "y \<in> set ys"
   obtains x where "(x, y) \<in> set (zip xs ys)"
 proof -
   from assms have "y \<in> set (map snd (zip xs ys))" by simp
   from this that show ?thesis by fastforce
 qed
 
 lemma zip_eq_Nil_iff:
   "zip xs ys = [] \<longleftrightarrow> xs = [] \<or> ys = []"
   by (cases xs; cases ys) simp_all
 
 lemma zip_eq_ConsE:
   assumes "zip xs ys = xy # xys"
   obtains x xs' y ys' where "xs = x # xs'"
     and "ys = y # ys'" and "xy = (x, y)"
     and "xys = zip xs' ys'"
 proof -
   from assms have "xs \<noteq> []" and "ys \<noteq> []"
     using zip_eq_Nil_iff [of xs ys] by simp_all
   then obtain x xs' y ys'  where xs: "xs = x # xs'"
     and ys: "ys = y # ys'"
     by (cases xs; cases ys) auto
   with assms have "xy = (x, y)" and "xys = zip xs' ys'"
     by simp_all
   with xs ys show ?thesis ..
 qed
 
 lemma semilattice_map2:
   "semilattice (map2 (\<^bold>*))" if "semilattice (\<^bold>*)"
     for f (infixl "\<^bold>*" 70)
 proof -
   from that interpret semilattice f .
   show ?thesis
   proof
     show "map2 (\<^bold>*) (map2 (\<^bold>*) xs ys) zs = map2 (\<^bold>*) xs (map2 (\<^bold>*) ys zs)"
       for xs ys zs :: "'a list"
     proof (induction "zip xs (zip ys zs)" arbitrary: xs ys zs)
       case Nil
       from Nil [symmetric] show ?case
         by (auto simp add: zip_eq_Nil_iff)
     next
       case (Cons xyz xyzs)
       from Cons.hyps(2) [symmetric] show ?case
         by (rule zip_eq_ConsE) (erule zip_eq_ConsE,
           auto intro: Cons.hyps(1) simp add: ac_simps)
     qed
     show "map2 (\<^bold>*) xs ys = map2 (\<^bold>*) ys xs"
       for xs ys :: "'a list"
     proof (induction "zip xs ys" arbitrary: xs ys)
       case Nil
       then show ?case
         by (auto simp add: zip_eq_Nil_iff dest: sym)
     next
       case (Cons xy xys)
       from Cons.hyps(2) [symmetric] show ?case
         by (rule zip_eq_ConsE) (auto intro: Cons.hyps(1) simp add: ac_simps)
     qed
     show "map2 (\<^bold>*) xs xs = xs"
       for xs :: "'a list"
       by (induction xs) simp_all
   qed
 qed
 
 lemma pair_list_eqI:
   assumes "map fst xs = map fst ys" and "map snd xs = map snd ys"
   shows "xs = ys"
 proof -
   from assms(1) have "length xs = length ys" by (rule map_eq_imp_length_eq)
   from this assms show ?thesis
     by (induct xs ys rule: list_induct2) (simp_all add: prod_eqI)
 qed
 
 lemma hd_zip:
   \<open>hd (zip xs ys) = (hd xs, hd ys)\<close> if \<open>xs \<noteq> []\<close> and \<open>ys \<noteq> []\<close>
   using that by (cases xs; cases ys) simp_all
 
 lemma last_zip:
   \<open>last (zip xs ys) = (last xs, last ys)\<close> if \<open>xs \<noteq> []\<close> and \<open>ys \<noteq> []\<close>
     and \<open>length xs = length ys\<close>
   using that by (cases xs rule: rev_cases; cases ys rule: rev_cases) simp_all
 
 
 subsubsection \<open>\<^const>\<open>list_all2\<close>\<close>
 
 lemma list_all2_lengthD [intro?]:
   "list_all2 P xs ys \<Longrightarrow> length xs = length ys"
   by (simp add: list_all2_iff)
 
 lemma list_all2_Nil [iff, code]: "list_all2 P [] ys = (ys = [])"
   by (simp add: list_all2_iff)
 
 lemma list_all2_Nil2 [iff, code]: "list_all2 P xs [] = (xs = [])"
   by (simp add: list_all2_iff)
 
 lemma list_all2_Cons [iff, code]:
   "list_all2 P (x # xs) (y # ys) = (P x y \<and> list_all2 P xs ys)"
   by (auto simp add: list_all2_iff)
 
 lemma list_all2_Cons1:
   "list_all2 P (x # xs) ys = (\<exists>z zs. ys = z # zs \<and> P x z \<and> list_all2 P xs zs)"
   by (cases ys) auto
 
 lemma list_all2_Cons2:
   "list_all2 P xs (y # ys) = (\<exists>z zs. xs = z # zs \<and> P z y \<and> list_all2 P zs ys)"
   by (cases xs) auto
 
 lemma list_all2_induct
   [consumes 1, case_names Nil Cons, induct set: list_all2]:
   assumes P: "list_all2 P xs ys"
   assumes Nil: "R [] []"
   assumes Cons: "\<And>x xs y ys.
     \<lbrakk>P x y; list_all2 P xs ys; R xs ys\<rbrakk> \<Longrightarrow> R (x # xs) (y # ys)"
   shows "R xs ys"
   using P
   by (induct xs arbitrary: ys) (auto simp add: list_all2_Cons1 Nil Cons)
 
 lemma list_all2_rev [iff]:
   "list_all2 P (rev xs) (rev ys) = list_all2 P xs ys"
   by (simp add: list_all2_iff zip_rev cong: conj_cong)
 
 lemma list_all2_rev1:
   "list_all2 P (rev xs) ys = list_all2 P xs (rev ys)"
   by (subst list_all2_rev [symmetric]) simp
 
 lemma list_all2_append1:
   "list_all2 P (xs @ ys) zs =
   (\<exists>us vs. zs = us @ vs \<and> length us = length xs \<and> length vs = length ys \<and>
     list_all2 P xs us \<and> list_all2 P ys vs)" (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     apply (rule_tac x = "take (length xs) zs" in exI)
     apply (rule_tac x = "drop (length xs) zs" in exI)
     apply (force split: nat_diff_split simp add: list_all2_iff zip_append1)
     done
 next
   assume ?rhs
   then show ?lhs
     by (auto simp add: list_all2_iff)
 qed
 
 lemma list_all2_append2:
   "list_all2 P xs (ys @ zs) =
   (\<exists>us vs. xs = us @ vs \<and> length us = length ys \<and> length vs = length zs \<and>
     list_all2 P us ys \<and> list_all2 P vs zs)" (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     apply (rule_tac x = "take (length ys) xs" in exI)
     apply (rule_tac x = "drop (length ys) xs" in exI)
     apply (force split: nat_diff_split simp add: list_all2_iff zip_append2)
     done
 next
   assume ?rhs
   then show ?lhs
     by (auto simp add: list_all2_iff)
 qed
 
 lemma list_all2_append:
   "length xs = length ys \<Longrightarrow>
   list_all2 P (xs@us) (ys@vs) = (list_all2 P xs ys \<and> list_all2 P us vs)"
   by (induct rule:list_induct2, simp_all)
 
 lemma list_all2_appendI [intro?, trans]:
   "\<lbrakk> list_all2 P a b; list_all2 P c d \<rbrakk> \<Longrightarrow> list_all2 P (a@c) (b@d)"
   by (simp add: list_all2_append list_all2_lengthD)
 
 lemma list_all2_conv_all_nth:
   "list_all2 P xs ys =
   (length xs = length ys \<and> (\<forall>i < length xs. P (xs!i) (ys!i)))"
   by (force simp add: list_all2_iff set_zip)
 
 lemma list_all2_trans:
   assumes tr: "!!a b c. P1 a b \<Longrightarrow> P2 b c \<Longrightarrow> P3 a c"
   shows "!!bs cs. list_all2 P1 as bs \<Longrightarrow> list_all2 P2 bs cs \<Longrightarrow> list_all2 P3 as cs"
     (is "!!bs cs. PROP ?Q as bs cs")
 proof (induct as)
   fix x xs bs assume I1: "!!bs cs. PROP ?Q xs bs cs"
   show "!!cs. PROP ?Q (x # xs) bs cs"
   proof (induct bs)
     fix y ys cs assume I2: "!!cs. PROP ?Q (x # xs) ys cs"
     show "PROP ?Q (x # xs) (y # ys) cs"
       by (induct cs) (auto intro: tr I1 I2)
   qed simp
 qed simp
 
 lemma list_all2_all_nthI [intro?]:
   "length a = length b \<Longrightarrow> (\<And>n. n < length a \<Longrightarrow> P (a!n) (b!n)) \<Longrightarrow> list_all2 P a b"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2I:
   "\<forall>x \<in> set (zip a b). case_prod P x \<Longrightarrow> length a = length b \<Longrightarrow> list_all2 P a b"
   by (simp add: list_all2_iff)
 
 lemma list_all2_nthD:
   "\<lbrakk> list_all2 P xs ys; p < size xs \<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2_nthD2:
   "\<lbrakk>list_all2 P xs ys; p < size ys\<rbrakk> \<Longrightarrow> P (xs!p) (ys!p)"
   by (frule list_all2_lengthD) (auto intro: list_all2_nthD)
 
 lemma list_all2_map1:
   "list_all2 P (map f as) bs = list_all2 (\<lambda>x y. P (f x) y) as bs"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2_map2:
   "list_all2 P as (map f bs) = list_all2 (\<lambda>x y. P x (f y)) as bs"
   by (auto simp add: list_all2_conv_all_nth)
 
 lemma list_all2_refl [intro?]:
   "(\<And>x. P x x) \<Longrightarrow> list_all2 P xs xs"
   by (simp add: list_all2_conv_all_nth)
 
 lemma list_all2_update_cong:
   "\<lbrakk> list_all2 P xs ys; P x y \<rbrakk> \<Longrightarrow> list_all2 P (xs[i:=x]) (ys[i:=y])"
   by (cases "i < length ys") (auto simp add: list_all2_conv_all_nth nth_list_update)
 
 lemma list_all2_takeI [simp,intro?]:
   "list_all2 P xs ys \<Longrightarrow> list_all2 P (take n xs) (take n ys)"
 proof (induct xs arbitrary: n ys)
   case (Cons x xs)
   then show ?case
     by (cases n) (auto simp: list_all2_Cons1)
 qed auto
 
 lemma list_all2_dropI [simp,intro?]:
   "list_all2 P xs ys \<Longrightarrow> list_all2 P (drop n xs) (drop n ys)"
 proof (induct xs arbitrary: n ys)
   case (Cons x xs)
   then show ?case
     by (cases n) (auto simp: list_all2_Cons1)
 qed auto
 
 lemma list_all2_mono [intro?]:
   "list_all2 P xs ys \<Longrightarrow> (\<And>xs ys. P xs ys \<Longrightarrow> Q xs ys) \<Longrightarrow> list_all2 Q xs ys"
   by (rule list.rel_mono_strong)
 
 lemma list_all2_eq:
   "xs = ys \<longleftrightarrow> list_all2 (=) xs ys"
   by (induct xs ys rule: list_induct2') auto
 
 lemma list_eq_iff_zip_eq:
   "xs = ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>(x,y) \<in> set (zip xs ys). x = y)"
   by(auto simp add: set_zip list_all2_eq list_all2_conv_all_nth cong: conj_cong)
 
 lemma list_all2_same: "list_all2 P xs xs \<longleftrightarrow> (\<forall>x\<in>set xs. P x x)"
   by(auto simp add: list_all2_conv_all_nth set_conv_nth)
 
 lemma zip_assoc:
   "zip xs (zip ys zs) = map (\<lambda>((x, y), z). (x, y, z)) (zip (zip xs ys) zs)"
   by(rule list_all2_all_nthI[where P="(=)", unfolded list.rel_eq]) simp_all
 
 lemma zip_commute: "zip xs ys = map (\<lambda>(x, y). (y, x)) (zip ys xs)"
   by(rule list_all2_all_nthI[where P="(=)", unfolded list.rel_eq]) simp_all
 
 lemma zip_left_commute:
   "zip xs (zip ys zs) = map (\<lambda>(y, (x, z)). (x, y, z)) (zip ys (zip xs zs))"
   by(rule list_all2_all_nthI[where P="(=)", unfolded list.rel_eq]) simp_all
 
 lemma zip_replicate2: "zip xs (replicate n y) = map (\<lambda>x. (x, y)) (take n xs)"
   by(subst zip_commute)(simp add: zip_replicate1)
 
 subsubsection \<open>\<^const>\<open>List.product\<close> and \<^const>\<open>product_lists\<close>\<close>
 
 lemma product_concat_map:
   "List.product xs ys = concat (map (\<lambda>x. map (\<lambda>y. (x,y)) ys) xs)"
   by(induction xs) (simp)+
 
 lemma set_product[simp]: "set (List.product xs ys) = set xs \<times> set ys"
   by (induct xs) auto
 
 lemma length_product [simp]:
   "length (List.product xs ys) = length xs * length ys"
   by (induct xs) simp_all
 
 lemma product_nth:
   assumes "n < length xs * length ys"
   shows "List.product xs ys ! n = (xs ! (n div length ys), ys ! (n mod length ys))"
   using assms proof (induct xs arbitrary: n)
   case Nil then show ?case by simp
 next
   case (Cons x xs n)
   then have "length ys > 0" by auto
   with Cons show ?case
     by (auto simp add: nth_append not_less le_mod_geq le_div_geq)
 qed
 
 lemma in_set_product_lists_length:
   "xs \<in> set (product_lists xss) \<Longrightarrow> length xs = length xss"
   by (induct xss arbitrary: xs) auto
 
 lemma product_lists_set:
   "set (product_lists xss) = {xs. list_all2 (\<lambda>x ys. x \<in> set ys) xs xss}" (is "?L = Collect ?R")
 proof (intro equalityI subsetI, unfold mem_Collect_eq)
   fix xs assume "xs \<in> ?L"
   then have "length xs = length xss" by (rule in_set_product_lists_length)
   from this \<open>xs \<in> ?L\<close> show "?R xs" by (induct xs xss rule: list_induct2) auto
 next
   fix xs assume "?R xs"
   then show "xs \<in> ?L" by induct auto
 qed
 
 
 subsubsection \<open>\<^const>\<open>fold\<close> with natural argument order\<close>
 
 lemma fold_simps [code]: \<comment> \<open>eta-expanded variant for generated code -- enables tail-recursion optimisation in Scala\<close>
   "fold f [] s = s"
   "fold f (x # xs) s = fold f xs (f x s)"
   by simp_all
 
 lemma fold_remove1_split:
   "\<lbrakk> \<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f x \<circ> f y = f y \<circ> f x;
     x \<in> set xs \<rbrakk>
   \<Longrightarrow> fold f xs = fold f (remove1 x xs) \<circ> f x"
   by (induct xs) (auto simp add: comp_assoc)
 
 lemma fold_cong [fundef_cong]:
   "a = b \<Longrightarrow> xs = ys \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)
     \<Longrightarrow> fold f xs a = fold g ys b"
   by (induct ys arbitrary: a b xs) simp_all
 
 lemma fold_id: "(\<And>x. x \<in> set xs \<Longrightarrow> f x = id) \<Longrightarrow> fold f xs = id"
   by (induct xs) simp_all
 
 lemma fold_commute:
   "(\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h) \<Longrightarrow> h \<circ> fold g xs = fold f xs \<circ> h"
   by (induct xs) (simp_all add: fun_eq_iff)
 
 lemma fold_commute_apply:
   assumes "\<And>x. x \<in> set xs \<Longrightarrow> h \<circ> g x = f x \<circ> h"
   shows "h (fold g xs s) = fold f xs (h s)"
 proof -
   from assms have "h \<circ> fold g xs = fold f xs \<circ> h" by (rule fold_commute)
   then show ?thesis by (simp add: fun_eq_iff)
 qed
 
 lemma fold_invariant:
   "\<lbrakk> \<And>x. x \<in> set xs \<Longrightarrow> Q x;  P s;  \<And>x s. Q x \<Longrightarrow> P s \<Longrightarrow> P (f x s) \<rbrakk>
   \<Longrightarrow> P (fold f xs s)"
   by (induct xs arbitrary: s) simp_all
 
 lemma fold_append [simp]: "fold f (xs @ ys) = fold f ys \<circ> fold f xs"
   by (induct xs) simp_all
 
 lemma fold_map [code_unfold]: "fold g (map f xs) = fold (g \<circ> f) xs"
   by (induct xs) simp_all
 
 lemma fold_filter:
   "fold f (filter P xs) = fold (\<lambda>x. if P x then f x else id) xs"
   by (induct xs) simp_all
 
 lemma fold_rev:
   "(\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y)
   \<Longrightarrow> fold f (rev xs) = fold f xs"
   by (induct xs) (simp_all add: fold_commute_apply fun_eq_iff)
 
 lemma fold_Cons_rev: "fold Cons xs = append (rev xs)"
   by (induct xs) simp_all
 
 lemma rev_conv_fold [code]: "rev xs = fold Cons xs []"
   by (simp add: fold_Cons_rev)
 
 lemma fold_append_concat_rev: "fold append xss = append (concat (rev xss))"
   by (induct xss) simp_all
 
 text \<open>\<^const>\<open>Finite_Set.fold\<close> and \<^const>\<open>fold\<close>\<close>
 
-lemma (in comp_fun_commute) fold_set_fold_remdups:
-  "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
-  by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_left_comm insert_absorb)
-
-lemma (in comp_fun_idem) fold_set_fold:
-  "Finite_Set.fold f y (set xs) = fold f xs y"
-  by (rule sym, induct xs arbitrary: y) (simp_all add: fold_fun_left_comm)
+lemma (in comp_fun_commute_on) fold_set_fold_remdups:
+  assumes "set xs \<subseteq> S"
+  shows "Finite_Set.fold f y (set xs) = fold f (remdups xs) y"
+  by (rule sym, use assms in \<open>induct xs arbitrary: y\<close>)
+     (simp_all add: insert_absorb fold_fun_left_comm) 
+
+lemma (in comp_fun_idem_on) fold_set_fold:
+  assumes "set xs \<subseteq> S"
+  shows "Finite_Set.fold f y (set xs) = fold f xs y"
+  by (rule sym, use assms in \<open>induct xs arbitrary: y\<close>) (simp_all add: fold_fun_left_comm)
 
 lemma union_set_fold [code]: "set xs \<union> A = fold Set.insert xs A"
 proof -
   interpret comp_fun_idem Set.insert
     by (fact comp_fun_idem_insert)
   show ?thesis by (simp add: union_fold_insert fold_set_fold)
 qed
 
 lemma union_coset_filter [code]:
   "List.coset xs \<union> A = List.coset (List.filter (\<lambda>x. x \<notin> A) xs)"
   by auto
 
 lemma minus_set_fold [code]: "A - set xs = fold Set.remove xs A"
 proof -
   interpret comp_fun_idem Set.remove
     by (fact comp_fun_idem_remove)
   show ?thesis
     by (simp add: minus_fold_remove [of _ A] fold_set_fold)
 qed
 
 lemma minus_coset_filter [code]:
   "A - List.coset xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
   by auto
 
 lemma inter_set_filter [code]:
   "A \<inter> set xs = set (List.filter (\<lambda>x. x \<in> A) xs)"
   by auto
 
 lemma inter_coset_fold [code]:
   "A \<inter> List.coset xs = fold Set.remove xs A"
   by (simp add: Diff_eq [symmetric] minus_set_fold)
 
 lemma (in semilattice_set) set_eq_fold [code]:
   "F (set (x # xs)) = fold f xs x"
 proof -
   interpret comp_fun_idem f
     by standard (simp_all add: fun_eq_iff left_commute)
   show ?thesis by (simp add: eq_fold fold_set_fold)
 qed
 
 lemma (in complete_lattice) Inf_set_fold:
   "Inf (set xs) = fold inf xs top"
 proof -
   interpret comp_fun_idem "inf :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
     by (fact comp_fun_idem_inf)
   show ?thesis by (simp add: Inf_fold_inf fold_set_fold inf_commute)
 qed
 
 declare Inf_set_fold [where 'a = "'a set", code]
 
 lemma (in complete_lattice) Sup_set_fold:
   "Sup (set xs) = fold sup xs bot"
 proof -
   interpret comp_fun_idem "sup :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"
     by (fact comp_fun_idem_sup)
   show ?thesis by (simp add: Sup_fold_sup fold_set_fold sup_commute)
 qed
 
 declare Sup_set_fold [where 'a = "'a set", code]
 
 lemma (in complete_lattice) INF_set_fold:
   "\<Sqinter>(f ` set xs) = fold (inf \<circ> f) xs top"
   using Inf_set_fold [of "map f xs"] by (simp add: fold_map)
 
 lemma (in complete_lattice) SUP_set_fold:
   "\<Squnion>(f ` set xs) = fold (sup \<circ> f) xs bot"
   using Sup_set_fold [of "map f xs"] by (simp add: fold_map)
 
 
 subsubsection \<open>Fold variants: \<^const>\<open>foldr\<close> and \<^const>\<open>foldl\<close>\<close>
 
 text \<open>Correspondence\<close>
 
 lemma foldr_conv_fold [code_abbrev]: "foldr f xs = fold f (rev xs)"
   by (induct xs) simp_all
 
 lemma foldl_conv_fold: "foldl f s xs = fold (\<lambda>x s. f s x) xs s"
   by (induct xs arbitrary: s) simp_all
 
 lemma foldr_conv_foldl: \<comment> \<open>The ``Third Duality Theorem'' in Bird \& Wadler:\<close>
   "foldr f xs a = foldl (\<lambda>x y. f y x) a (rev xs)"
   by (simp add: foldr_conv_fold foldl_conv_fold)
 
 lemma foldl_conv_foldr:
   "foldl f a xs = foldr (\<lambda>x y. f y x) (rev xs) a"
   by (simp add: foldr_conv_fold foldl_conv_fold)
 
 lemma foldr_fold:
   "(\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> f y \<circ> f x = f x \<circ> f y)
   \<Longrightarrow> foldr f xs = fold f xs"
   unfolding foldr_conv_fold by (rule fold_rev)
 
 lemma foldr_cong [fundef_cong]:
   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f x a = g x a) \<Longrightarrow> foldr f l a = foldr g k b"
   by (auto simp add: foldr_conv_fold intro!: fold_cong)
 
 lemma foldl_cong [fundef_cong]:
   "a = b \<Longrightarrow> l = k \<Longrightarrow> (\<And>a x. x \<in> set l \<Longrightarrow> f a x = g a x) \<Longrightarrow> foldl f a l = foldl g b k"
   by (auto simp add: foldl_conv_fold intro!: fold_cong)
 
 lemma foldr_append [simp]: "foldr f (xs @ ys) a = foldr f xs (foldr f ys a)"
   by (simp add: foldr_conv_fold)
 
 lemma foldl_append [simp]: "foldl f a (xs @ ys) = foldl f (foldl f a xs) ys"
   by (simp add: foldl_conv_fold)
 
 lemma foldr_map [code_unfold]: "foldr g (map f xs) a = foldr (g \<circ> f) xs a"
   by (simp add: foldr_conv_fold fold_map rev_map)
 
 lemma foldr_filter:
   "foldr f (filter P xs) = foldr (\<lambda>x. if P x then f x else id) xs"
   by (simp add: foldr_conv_fold rev_filter fold_filter)
 
 lemma foldl_map [code_unfold]:
   "foldl g a (map f xs) = foldl (\<lambda>a x. g a (f x)) a xs"
   by (simp add: foldl_conv_fold fold_map comp_def)
 
 lemma concat_conv_foldr [code]:
   "concat xss = foldr append xss []"
   by (simp add: fold_append_concat_rev foldr_conv_fold)
 
 
 subsubsection \<open>\<^const>\<open>upt\<close>\<close>
 
 lemma upt_rec[code]: "[i..<j] = (if i<j then i#[Suc i..<j] else [])"
   \<comment> \<open>simp does not terminate!\<close>
   by (induct j) auto
 
 lemmas upt_rec_numeral[simp] = upt_rec[of "numeral m" "numeral n"] for m n
 
 lemma upt_conv_Nil [simp]: "j \<le> i \<Longrightarrow> [i..<j] = []"
   by (subst upt_rec) simp
 
 lemma upt_eq_Nil_conv[simp]: "([i..<j] = []) = (j = 0 \<or> j \<le> i)"
   by(induct j)simp_all
 
 lemma upt_eq_Cons_conv:
   "([i..<j] = x#xs) = (i < j \<and> i = x \<and> [i+1..<j] = xs)"
 proof (induct j arbitrary: x xs)
   case (Suc j)
   then show ?case
     by (simp add: upt_rec)
 qed simp
 
 lemma upt_Suc_append: "i \<le> j \<Longrightarrow> [i..<(Suc j)] = [i..<j]@[j]"
   \<comment> \<open>Only needed if \<open>upt_Suc\<close> is deleted from the simpset.\<close>
   by simp
 
 lemma upt_conv_Cons: "i < j \<Longrightarrow> [i..<j] = i # [Suc i..<j]"
   by (simp add: upt_rec)
 
 lemma upt_conv_Cons_Cons: \<comment> \<open>no precondition\<close>
   "m # n # ns = [m..<q] \<longleftrightarrow> n # ns = [Suc m..<q]"
 proof (cases "m < q")
   case False then show ?thesis by simp
 next
   case True then show ?thesis by (simp add: upt_conv_Cons)
 qed
 
 lemma upt_add_eq_append: "i<=j \<Longrightarrow> [i..<j+k] = [i..<j]@[j..<j+k]"
   \<comment> \<open>LOOPS as a simprule, since \<open>j \<le> j\<close>.\<close>
   by (induct k) auto
 
 lemma length_upt [simp]: "length [i..<j] = j - i"
   by (induct j) (auto simp add: Suc_diff_le)
 
 lemma nth_upt [simp]: "i + k < j \<Longrightarrow> [i..<j] ! k = i + k"
   by (induct j) (auto simp add: less_Suc_eq nth_append split: nat_diff_split)
 
 lemma hd_upt[simp]: "i < j \<Longrightarrow> hd[i..<j] = i"
   by(simp add:upt_conv_Cons)
 
 lemma tl_upt [simp]: "tl [m..<n] = [Suc m..<n]"
   by (simp add: upt_rec)
 
 lemma last_upt[simp]: "i < j \<Longrightarrow> last[i..<j] = j - 1"
   by(cases j)(auto simp: upt_Suc_append)
 
 lemma take_upt [simp]: "i+m \<le> n \<Longrightarrow> take m [i..<n] = [i..<i+m]"
 proof (induct m arbitrary: i)
   case (Suc m)
   then show ?case
     by (subst take_Suc_conv_app_nth) auto
 qed simp
 
 lemma drop_upt[simp]: "drop m [i..<j] = [i+m..<j]"
   by(induct j) auto
 
 lemma map_Suc_upt: "map Suc [m..<n] = [Suc m..<Suc n]"
   by (induct n) auto
 
 lemma map_add_upt: "map (\<lambda>i. i + n) [0..<m] = [n..<m + n]"
   by (induct m) simp_all
 
 lemma nth_map_upt: "i < n-m \<Longrightarrow> (map f [m..<n]) ! i = f(m+i)"
 proof (induct n m  arbitrary: i rule: diff_induct)
   case (3 x y)
   then show ?case
     by (metis add.commute length_upt less_diff_conv nth_map nth_upt)
 qed auto
 
 lemma map_decr_upt: "map (\<lambda>n. n - Suc 0) [Suc m..<Suc n] = [m..<n]"
   by (induct n) simp_all
 
 lemma map_upt_Suc: "map f [0 ..< Suc n] = f 0 # map (\<lambda>i. f (Suc i)) [0 ..< n]"
   by (induct n arbitrary: f) auto
 
 lemma nth_take_lemma:
   "k \<le> length xs \<Longrightarrow> k \<le> length ys \<Longrightarrow>
      (\<And>i. i < k \<longrightarrow> xs!i = ys!i) \<Longrightarrow> take k xs = take k ys"
 proof (induct k arbitrary: xs ys)
   case (Suc k)
   then show ?case
     apply (simp add: less_Suc_eq_0_disj)
     by (simp add: Suc.prems(3) take_Suc_conv_app_nth)
 qed simp
 
 lemma nth_equalityI:
   "\<lbrakk>length xs = length ys; \<And>i. i < length xs \<Longrightarrow> xs!i = ys!i\<rbrakk> \<Longrightarrow> xs = ys"
   by (frule nth_take_lemma [OF le_refl eq_imp_le]) simp_all
 
 lemma map_nth:
   "map (\<lambda>i. xs ! i) [0..<length xs] = xs"
   by (rule nth_equalityI, auto)
 
 lemma list_all2_antisym:
   "\<lbrakk> (\<And>x y. \<lbrakk>P x y; Q y x\<rbrakk> \<Longrightarrow> x = y); list_all2 P xs ys; list_all2 Q ys xs \<rbrakk>
   \<Longrightarrow> xs = ys"
   by (simp add: list_all2_conv_all_nth nth_equalityI)
 
 lemma take_equalityI: "(\<forall>i. take i xs = take i ys) \<Longrightarrow> xs = ys"
 \<comment> \<open>The famous take-lemma.\<close>
   by (metis length_take min.commute order_refl take_all)
 
 lemma take_Cons':
   "take n (x # xs) = (if n = 0 then [] else x # take (n - 1) xs)"
 by (cases n) simp_all
 
 lemma drop_Cons':
   "drop n (x # xs) = (if n = 0 then x # xs else drop (n - 1) xs)"
 by (cases n) simp_all
 
 lemma nth_Cons': "(x # xs)!n = (if n = 0 then x else xs!(n - 1))"
 by (cases n) simp_all
 
 lemma take_Cons_numeral [simp]:
   "take (numeral v) (x # xs) = x # take (numeral v - 1) xs"
 by (simp add: take_Cons')
 
 lemma drop_Cons_numeral [simp]:
   "drop (numeral v) (x # xs) = drop (numeral v - 1) xs"
 by (simp add: drop_Cons')
 
 lemma nth_Cons_numeral [simp]:
   "(x # xs) ! numeral v = xs ! (numeral v - 1)"
   by (simp add: nth_Cons')
 
 lemma map_upt_eqI:
   \<open>map f [m..<n] = xs\<close> if \<open>length xs = n - m\<close>
     \<open>\<And>i. i < length xs \<Longrightarrow> xs ! i = f (m + i)\<close>
 proof (rule nth_equalityI)
   from \<open>length xs = n - m\<close> show \<open>length (map f [m..<n]) = length xs\<close>
     by simp
 next
   fix i
   assume \<open>i < length (map f [m..<n])\<close>
   then have \<open>i < n - m\<close>
     by simp
   with that have \<open>xs ! i = f (m + i)\<close>
     by simp
   with \<open>i < n - m\<close> show \<open>map f [m..<n] ! i = xs ! i\<close>
     by simp
 qed
 
 
 subsubsection \<open>\<open>upto\<close>: interval-list on \<^typ>\<open>int\<close>\<close>
 
 function upto :: "int \<Rightarrow> int \<Rightarrow> int list" ("(1[_../_])") where
   "upto i j = (if i \<le> j then i # [i+1..j] else [])"
 by auto
 termination
 by(relation "measure(%(i::int,j). nat(j - i + 1))") auto
 
 declare upto.simps[simp del]
 
 lemmas upto_rec_numeral [simp] =
   upto.simps[of "numeral m" "numeral n"]
   upto.simps[of "numeral m" "- numeral n"]
   upto.simps[of "- numeral m" "numeral n"]
   upto.simps[of "- numeral m" "- numeral n"] for m n
 
 lemma upto_empty[simp]: "j < i \<Longrightarrow> [i..j] = []"
 by(simp add: upto.simps)
 
 lemma upto_single[simp]: "[i..i] = [i]"
 by(simp add: upto.simps)
 
 lemma upto_Nil[simp]: "[i..j] = [] \<longleftrightarrow> j < i"
 by (simp add: upto.simps)
 
 lemma upto_Nil2[simp]: "[] = [i..j] \<longleftrightarrow> j < i"
 by (simp add: upto.simps)
 
 lemma upto_rec1: "i \<le> j \<Longrightarrow> [i..j] = i#[i+1..j]"
 by(simp add: upto.simps)
 
 lemma upto_rec2: "i \<le> j \<Longrightarrow> [i..j] = [i..j - 1]@[j]"
 proof(induct "nat(j-i)" arbitrary: i j)
   case 0 thus ?case by(simp add: upto.simps)
 next
   case (Suc n)
   hence "n = nat (j - (i + 1))" "i < j" by linarith+
   from this(2) Suc.hyps(1)[OF this(1)] Suc(2,3) upto_rec1 show ?case by simp
 qed
 
 lemma length_upto[simp]: "length [i..j] = nat(j - i + 1)"
 by(induction i j rule: upto.induct) (auto simp: upto.simps)
 
 lemma set_upto[simp]: "set[i..j] = {i..j}"
 proof(induct i j rule:upto.induct)
   case (1 i j)
   from this show ?case
     unfolding upto.simps[of i j] by auto
 qed
 
 lemma nth_upto[simp]: "i + int k \<le> j \<Longrightarrow> [i..j] ! k = i + int k"
 proof(induction i j arbitrary: k rule: upto.induct)
   case (1 i j)
   then show ?case
     by (auto simp add: upto_rec1 [of i j] nth_Cons')
 qed
 
 lemma upto_split1:
   "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> [i..k] = [i..j-1] @ [j..k]"
 proof (induction j rule: int_ge_induct)
   case base thus ?case by (simp add: upto_rec1)
 next
   case step thus ?case using upto_rec1 upto_rec2 by simp
 qed
 
 lemma upto_split2:
   "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> [i..k] = [i..j] @ [j+1..k]"
 using upto_rec1 upto_rec2 upto_split1 by auto
 
 lemma upto_split3: "\<lbrakk> i \<le> j; j \<le> k \<rbrakk> \<Longrightarrow> [i..k] = [i..j-1] @ j # [j+1..k]"
 using upto_rec1 upto_split1 by auto
 
 text\<open>Tail recursive version for code generation:\<close>
 
 definition upto_aux :: "int \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list" where
   "upto_aux i j js = [i..j] @ js"
 
 lemma upto_aux_rec [code]:
   "upto_aux i j js = (if j<i then js else upto_aux i (j - 1) (j#js))"
 by (simp add: upto_aux_def upto_rec2)
 
 lemma upto_code[code]: "[i..j] = upto_aux i j []"
 by(simp add: upto_aux_def)
 
 
 
 subsubsection \<open>\<^const>\<open>successively\<close>\<close>
 
 lemma successively_Cons:
   "successively P (x # xs) \<longleftrightarrow> xs = [] \<or> P x (hd xs) \<and> successively P xs"
 by (cases xs) auto
 
 lemma successively_cong [cong]:
   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> P x y \<longleftrightarrow> Q x y" "xs = ys"
   shows   "successively P xs \<longleftrightarrow> successively Q ys"
   unfolding assms(2) [symmetric] using assms(1)
   by (induction xs) (auto simp: successively_Cons)
 
 
 lemma successively_append_iff:
   "successively P (xs @ ys) \<longleftrightarrow>
      successively P xs \<and> successively P ys \<and> 
      (xs = [] \<or> ys = [] \<or> P (last xs) (hd ys))"
 by (induction xs) (auto simp: successively_Cons)
 
 lemma successively_if_sorted_wrt: "sorted_wrt P xs \<Longrightarrow> successively P xs"
 by (induction xs rule: induct_list012) auto
 
 
 lemma successively_iff_sorted_wrt_strong:
   assumes "\<And>x y z. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> z \<in> set xs \<Longrightarrow>
                      P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
   shows   "successively P xs \<longleftrightarrow> sorted_wrt P xs"
 proof
   assume "successively P xs"
   from this and assms show "sorted_wrt P xs"
   proof (induction xs rule: induct_list012)
     case (3 x y xs)
     from "3.prems" have "P x y"
       by auto
     have IH: "sorted_wrt P (y # xs)"
       using "3.prems"
       by(intro "3.IH"(2) list.set_intros(2))(simp, blast intro: list.set_intros(2))
     have "P x z" if asm: "z \<in> set xs" for z
     proof -
       from IH and asm have "P y z"
         by auto
       with \<open>P x y\<close> show "P x z"
         using "3.prems" asm by auto
     qed
     with IH and \<open>P x y\<close> show ?case by auto
   qed auto
 qed (use successively_if_sorted_wrt in blast)
 
 lemma successively_conv_sorted_wrt:
   assumes "transp P"
   shows   "successively P xs \<longleftrightarrow> sorted_wrt P xs"
   using assms unfolding transp_def
   by (intro successively_iff_sorted_wrt_strong) blast
 
 lemma successively_rev [simp]: "successively P (rev xs) \<longleftrightarrow> successively (\<lambda>x y. P y x) xs"
   by (induction xs rule: remdups_adj.induct)
      (auto simp: successively_append_iff successively_Cons)
 
 lemma successively_map: "successively P (map f xs) \<longleftrightarrow> successively (\<lambda>x y. P (f x) (f y)) xs"
   by (induction xs rule: induct_list012) auto
 
 lemma successively_mono:
   assumes "successively P xs"
   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set xs \<Longrightarrow> P x y \<Longrightarrow> Q x y"
   shows   "successively Q xs"
   using assms by (induction Q xs rule: successively.induct) auto
 
 lemma successively_altdef:
   "successively = (\<lambda>P. rec_list True (\<lambda>x xs b. case xs of [] \<Rightarrow> True | y # _ \<Rightarrow> P x y \<and> b))"
 proof (intro ext)
   fix P and xs :: "'a list"
   show "successively P xs = rec_list True (\<lambda>x xs b. case xs of [] \<Rightarrow> True | y # _ \<Rightarrow> P x y \<and> b) xs"
     by (induction xs) (auto simp: successively_Cons split: list.splits)
 qed
 
 
 subsubsection \<open>\<^const>\<open>distinct\<close> and \<^const>\<open>remdups\<close> and \<^const>\<open>remdups_adj\<close>\<close>
 
 lemma distinct_tl: "distinct xs \<Longrightarrow> distinct (tl xs)"
 by (cases xs) simp_all
 
 lemma distinct_append [simp]:
   "distinct (xs @ ys) = (distinct xs \<and> distinct ys \<and> set xs \<inter> set ys = {})"
 by (induct xs) auto
 
 lemma distinct_rev[simp]: "distinct(rev xs) = distinct xs"
 by(induct xs) auto
 
 lemma set_remdups [simp]: "set (remdups xs) = set xs"
 by (induct xs) (auto simp add: insert_absorb)
 
 lemma distinct_remdups [iff]: "distinct (remdups xs)"
 by (induct xs) auto
 
 lemma distinct_remdups_id: "distinct xs \<Longrightarrow> remdups xs = xs"
 by (induct xs, auto)
 
 lemma remdups_id_iff_distinct [simp]: "remdups xs = xs \<longleftrightarrow> distinct xs"
 by (metis distinct_remdups distinct_remdups_id)
 
 lemma finite_distinct_list: "finite A \<Longrightarrow> \<exists>xs. set xs = A \<and> distinct xs"
 by (metis distinct_remdups finite_list set_remdups)
 
 lemma remdups_eq_nil_iff [simp]: "(remdups x = []) = (x = [])"
 by (induct x, auto)
 
 lemma remdups_eq_nil_right_iff [simp]: "([] = remdups x) = (x = [])"
 by (induct x, auto)
 
 lemma length_remdups_leq[iff]: "length(remdups xs) \<le> length xs"
 by (induct xs) auto
 
 lemma length_remdups_eq[iff]:
   "(length (remdups xs) = length xs) = (remdups xs = xs)"
 proof (induct xs)
   case (Cons a xs)
   then show ?case
     by simp (metis Suc_n_not_le_n impossible_Cons length_remdups_leq)
 qed auto
 
 lemma remdups_filter: "remdups(filter P xs) = filter P (remdups xs)"
 by (induct xs) auto
 
 lemma distinct_map:
   "distinct(map f xs) = (distinct xs \<and> inj_on f (set xs))"
 by (induct xs) auto
 
 lemma distinct_map_filter:
   "distinct (map f xs) \<Longrightarrow> distinct (map f (filter P xs))"
 by (induct xs) auto
 
 lemma distinct_filter [simp]: "distinct xs \<Longrightarrow> distinct (filter P xs)"
 by (induct xs) auto
 
 lemma distinct_upt[simp]: "distinct[i..<j]"
 by (induct j) auto
 
 lemma distinct_upto[simp]: "distinct[i..j]"
 proof (induction i j rule: upto.induct)
   case (1 i j)
   then show ?case
     by (simp add: upto.simps [of i])
 qed
 
 lemma distinct_take[simp]: "distinct xs \<Longrightarrow> distinct (take i xs)"
 proof (induct xs arbitrary: i)
   case (Cons a xs)
   then show ?case
     by (metis Cons.prems append_take_drop_id distinct_append)
 qed auto
 
 lemma distinct_drop[simp]: "distinct xs \<Longrightarrow> distinct (drop i xs)"
 proof (induct xs arbitrary: i)
   case (Cons a xs)
   then show ?case
     by (metis Cons.prems append_take_drop_id distinct_append)
 qed auto
 
 lemma distinct_list_update:
   assumes d: "distinct xs" and a: "a \<notin> set xs - {xs!i}"
   shows "distinct (xs[i:=a])"
 proof (cases "i < length xs")
   case True
   with a have anot: "a \<notin> set (take i xs @ xs ! i # drop (Suc i) xs) - {xs!i}"
     by simp (metis in_set_dropD in_set_takeD)
   show ?thesis
   proof (cases "a = xs!i")
     case True
     with d show ?thesis
       by auto
   next
     case False
     have "set (take i xs) \<inter> set (drop (Suc i) xs) = {}"
       by (metis True d disjoint_insert(1) distinct_append id_take_nth_drop list.set(2))
     then show ?thesis
       using d False anot \<open>i < length xs\<close> by (simp add: upd_conv_take_nth_drop)
   qed
 next
   case False with d show ?thesis by auto
 qed
 
 lemma distinct_concat:
   "\<lbrakk> distinct xs;
      \<And> ys. ys \<in> set xs \<Longrightarrow> distinct ys;
      \<And> ys zs. \<lbrakk> ys \<in> set xs ; zs \<in> set xs ; ys \<noteq> zs \<rbrakk> \<Longrightarrow> set ys \<inter> set zs = {}
    \<rbrakk> \<Longrightarrow> distinct (concat xs)"
 by (induct xs) auto
 
 text \<open>An iff-version of @{thm distinct_concat} is available further down as \<open>distinct_concat_iff\<close>.\<close>
 
 text \<open>It is best to avoid the following indexed version of distinct, but sometimes it is useful.\<close>
 
 lemma distinct_conv_nth: "distinct xs = (\<forall>i < size xs. \<forall>j < size xs. i \<noteq> j \<longrightarrow> xs!i \<noteq> xs!j)"
 proof (induct xs)
   case (Cons x xs)
   show ?case
     apply (auto simp add: Cons nth_Cons split: nat.split_asm)
     apply (metis Suc_less_eq2 in_set_conv_nth less_not_refl zero_less_Suc)+
     done
 qed auto
 
 lemma nth_eq_iff_index_eq:
   "\<lbrakk> distinct xs; i < length xs; j < length xs \<rbrakk> \<Longrightarrow> (xs!i = xs!j) = (i = j)"
 by(auto simp: distinct_conv_nth)
 
 lemma distinct_Ex1:
   "distinct xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> (\<exists>!i. i < length xs \<and> xs ! i = x)"
   by (auto simp: in_set_conv_nth nth_eq_iff_index_eq)
 
 lemma inj_on_nth: "distinct xs \<Longrightarrow> \<forall>i \<in> I. i < length xs \<Longrightarrow> inj_on (nth xs) I"
 by (rule inj_onI) (simp add: nth_eq_iff_index_eq)
 
 lemma bij_betw_nth:
   assumes "distinct xs" "A = {..<length xs}" "B = set xs"
   shows   "bij_betw ((!) xs) A B"
   using assms unfolding bij_betw_def
   by (auto intro!: inj_on_nth simp: set_conv_nth)
 
 lemma set_update_distinct: "\<lbrakk> distinct xs;  n < length xs \<rbrakk> \<Longrightarrow>
   set(xs[n := x]) = insert x (set xs - {xs!n})"
 by(auto simp: set_eq_iff in_set_conv_nth nth_list_update nth_eq_iff_index_eq)
 
 lemma distinct_swap[simp]: "\<lbrakk> i < size xs; j < size xs\<rbrakk> \<Longrightarrow>
   distinct(xs[i := xs!j, j := xs!i]) = distinct xs"
   apply (simp add: distinct_conv_nth nth_list_update)
   apply (safe; metis)
   done
 
 lemma set_swap[simp]:
   "\<lbrakk> i < size xs; j < size xs \<rbrakk> \<Longrightarrow> set(xs[i := xs!j, j := xs!i]) = set xs"
 by(simp add: set_conv_nth nth_list_update) metis
 
 lemma distinct_card: "distinct xs \<Longrightarrow> card (set xs) = size xs"
 by (induct xs) auto
 
 lemma card_distinct: "card (set xs) = size xs \<Longrightarrow> distinct xs"
 proof (induct xs)
   case (Cons x xs)
   show ?case
   proof (cases "x \<in> set xs")
     case False with Cons show ?thesis by simp
   next
     case True with Cons.prems
     have "card (set xs) = Suc (length xs)"
       by (simp add: card_insert_if split: if_split_asm)
     moreover have "card (set xs) \<le> length xs" by (rule card_length)
     ultimately have False by simp
     thus ?thesis ..
   qed
 qed simp
 
 lemma distinct_length_filter: "distinct xs \<Longrightarrow> length (filter P xs) = card ({x. P x} Int set xs)"
 by (induct xs) (auto)
 
 lemma not_distinct_decomp: "\<not> distinct ws \<Longrightarrow> \<exists>xs ys zs y. ws = xs@[y]@ys@[y]@zs"
 proof (induct n == "length ws" arbitrary:ws)
   case (Suc n ws)
   then show ?case
     using length_Suc_conv [of ws n]
     apply (auto simp: eq_commute)
      apply (metis append_Nil in_set_conv_decomp_first)
     by (metis append_Cons)
 qed simp
 
 lemma not_distinct_conv_prefix:
   defines "dec as xs y ys \<equiv> y \<in> set xs \<and> distinct xs \<and> as = xs @ y # ys"
   shows "\<not>distinct as \<longleftrightarrow> (\<exists>xs y ys. dec as xs y ys)" (is "?L = ?R")
 proof
   assume "?L" then show "?R"
   proof (induct "length as" arbitrary: as rule: less_induct)
     case less
     obtain xs ys zs y where decomp: "as = (xs @ y # ys) @ y # zs"
       using not_distinct_decomp[OF less.prems] by auto
     show ?case
     proof (cases "distinct (xs @ y # ys)")
       case True
       with decomp have "dec as (xs @ y # ys) y zs" by (simp add: dec_def)
       then show ?thesis by blast
     next
       case False
       with less decomp obtain xs' y' ys' where "dec (xs @ y # ys) xs' y' ys'"
         by atomize_elim auto
       with decomp have "dec as xs' y' (ys' @ y # zs)" by (simp add: dec_def)
       then show ?thesis by blast
     qed
   qed
 qed (auto simp: dec_def)
 
 lemma distinct_product:
   "distinct xs \<Longrightarrow> distinct ys \<Longrightarrow> distinct (List.product xs ys)"
 by (induct xs) (auto intro: inj_onI simp add: distinct_map)
 
 lemma distinct_product_lists:
   assumes "\<forall>xs \<in> set xss. distinct xs"
   shows "distinct (product_lists xss)"
 using assms proof (induction xss)
   case (Cons xs xss) note * = this
   then show ?case
   proof (cases "product_lists xss")
     case Nil then show ?thesis by (induct xs) simp_all
   next
     case (Cons ps pss) with * show ?thesis
       by (auto intro!: inj_onI distinct_concat simp add: distinct_map)
   qed
 qed simp
 
 lemma length_remdups_concat:
   "length (remdups (concat xss)) = card (\<Union>xs\<in>set xss. set xs)"
 by (simp add: distinct_card [symmetric])
 
 lemma remdups_append2:
   "remdups (xs @ remdups ys) = remdups (xs @ ys)"
 by(induction xs) auto
 
 lemma length_remdups_card_conv: "length(remdups xs) = card(set xs)"
 proof -
   have xs: "concat[xs] = xs" by simp
   from length_remdups_concat[of "[xs]"] show ?thesis unfolding xs by simp
 qed
 
 lemma remdups_remdups: "remdups (remdups xs) = remdups xs"
 by (induct xs) simp_all
 
 lemma distinct_butlast:
   assumes "distinct xs"
   shows "distinct (butlast xs)"
 proof (cases "xs = []")
   case False
     from \<open>xs \<noteq> []\<close> obtain ys y where "xs = ys @ [y]" by (cases xs rule: rev_cases) auto
     with \<open>distinct xs\<close> show ?thesis by simp
 qed (auto)
 
 lemma remdups_map_remdups:
   "remdups (map f (remdups xs)) = remdups (map f xs)"
 by (induct xs) simp_all
 
 lemma distinct_zipI1:
   assumes "distinct xs"
   shows "distinct (zip xs ys)"
 proof (rule zip_obtain_same_length)
   fix xs' :: "'a list" and ys' :: "'b list" and n
   assume "length xs' = length ys'"
   assume "xs' = take n xs"
   with assms have "distinct xs'" by simp
   with \<open>length xs' = length ys'\<close> show "distinct (zip xs' ys')"
     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
 qed
 
 lemma distinct_zipI2:
   assumes "distinct ys"
   shows "distinct (zip xs ys)"
 proof (rule zip_obtain_same_length)
   fix xs' :: "'b list" and ys' :: "'a list" and n
   assume "length xs' = length ys'"
   assume "ys' = take n ys"
   with assms have "distinct ys'" by simp
   with \<open>length xs' = length ys'\<close> show "distinct (zip xs' ys')"
     by (induct xs' ys' rule: list_induct2) (auto elim: in_set_zipE)
 qed
 
 lemma set_take_disj_set_drop_if_distinct:
   "distinct vs \<Longrightarrow> i \<le> j \<Longrightarrow> set (take i vs) \<inter> set (drop j vs) = {}"
 by (auto simp: in_set_conv_nth distinct_conv_nth)
 
 (* The next two lemmas help Sledgehammer. *)
 
 lemma distinct_singleton: "distinct [x]" by simp
 
 lemma distinct_length_2_or_more:
   "distinct (a # b # xs) \<longleftrightarrow> (a \<noteq> b \<and> distinct (a # xs) \<and> distinct (b # xs))"
 by force
 
 lemma remdups_adj_altdef: "(remdups_adj xs = ys) \<longleftrightarrow>
   (\<exists>f::nat => nat. mono f \<and> f ` {0 ..< size xs} = {0 ..< size ys}
     \<and> (\<forall>i < size xs. xs!i = ys!(f i))
     \<and> (\<forall>i. i + 1 < size xs \<longrightarrow> (xs!i = xs!(i+1) \<longleftrightarrow> f i = f(i+1))))" (is "?L \<longleftrightarrow> (\<exists>f. ?p f xs ys)")
 proof
   assume ?L
   then show "\<exists>f. ?p f xs ys"
   proof (induct xs arbitrary: ys rule: remdups_adj.induct)
     case (1 ys)
     thus ?case by (intro exI[of _ id]) (auto simp: mono_def)
   next
     case (2 x ys)
     thus ?case by (intro exI[of _ id]) (auto simp: mono_def)
   next
     case (3 x1 x2 xs ys)
     let ?xs = "x1 # x2 # xs"
     let ?cond = "x1 = x2"
     define zs where "zs = remdups_adj (x2 # xs)"
     from 3(1-2)[of zs]
     obtain f where p: "?p f (x2 # xs) zs" unfolding zs_def by (cases ?cond) auto
     then have f0: "f 0 = 0"
       by (intro mono_image_least[where f=f]) blast+
     from p have mono: "mono f" and f_xs_zs: "f ` {0..<length (x2 # xs)} = {0..<length zs}" by auto
     have ys: "ys = (if x1 = x2 then zs else x1 # zs)"
       unfolding 3(3)[symmetric] zs_def by auto
     have zs0: "zs ! 0 = x2" unfolding zs_def by (induct xs) auto
     have zsne: "zs \<noteq> []" unfolding zs_def by (induct xs) auto
     let ?Succ = "if ?cond then id else Suc"
     let ?x1 = "if ?cond then id else Cons x1"
     let ?f = "\<lambda> i. if i = 0 then 0 else ?Succ (f (i - 1))"
     have ys: "ys = ?x1 zs" unfolding ys by (cases ?cond, auto)
     have mono: "mono ?f" using \<open>mono f\<close> unfolding mono_def by auto
     show ?case unfolding ys
     proof (intro exI[of _ ?f] conjI allI impI)
       show "mono ?f" by fact
     next
       fix i assume i: "i < length ?xs"
       with p show "?xs ! i = ?x1 zs ! (?f i)" using zs0 by auto
     next
       fix i assume i: "i + 1 < length ?xs"
       with p show "(?xs ! i = ?xs ! (i + 1)) = (?f i = ?f (i + 1))"
         by (cases i) (auto simp: f0)
     next
       have id: "{0 ..< length (?x1 zs)} = insert 0 (?Succ ` {0 ..< length zs})"
         using zsne by (cases ?cond, auto)
       { fix i  assume "i < Suc (length xs)"
         hence "Suc i \<in> {0..<Suc (Suc (length xs))} \<inter> Collect ((<) 0)" by auto
         from imageI[OF this, of "\<lambda>i. ?Succ (f (i - Suc 0))"]
         have "?Succ (f i) \<in> (\<lambda>i. ?Succ (f (i - Suc 0))) ` ({0..<Suc (Suc (length xs))} \<inter> Collect ((<) 0))" by auto
       }
       then show "?f ` {0 ..< length ?xs} = {0 ..< length (?x1  zs)}"
         unfolding id f_xs_zs[symmetric] by auto
     qed
   qed
 next
   assume "\<exists> f. ?p f xs ys"
   then show ?L
   proof (induct xs arbitrary: ys rule: remdups_adj.induct)
     case 1 then show ?case by auto
   next
     case (2 x) then obtain f where f_img: "f ` {0 ..< size [x]} = {0 ..< size ys}"
         and f_nth: "\<And>i. i < size [x] \<Longrightarrow> [x]!i = ys!(f i)"
       by blast
 
     have "length ys = card (f ` {0 ..< size [x]})"
       using f_img by auto
     then have *: "length ys = 1" by auto
     then have "f 0 = 0" using f_img by auto
     with * show ?case using f_nth by (cases ys) auto
   next
     case (3 x1 x2 xs)
     from "3.prems" obtain f where f_mono: "mono f"
       and f_img: "f ` {0..<length (x1 # x2 # xs)} = {0..<length ys}"
       and f_nth:
         "\<And>i. i < length (x1 # x2 # xs) \<Longrightarrow> (x1 # x2 # xs) ! i = ys ! f i"
         "\<And>i. i + 1 < length (x1 # x2 #xs) \<Longrightarrow>
           ((x1 # x2 # xs) ! i = (x1 # x2 # xs) ! (i + 1)) = (f i = f (i + 1))"
       by blast
 
     show ?case
     proof cases
       assume "x1 = x2"
 
       let ?f' = "f \<circ> Suc"
 
       have "remdups_adj (x1 # xs) = ys"
       proof (intro "3.hyps" exI conjI impI allI)
         show "mono ?f'"
           using f_mono by (simp add: mono_iff_le_Suc)
       next
         have "?f' ` {0 ..< length (x1 # xs)} = f ` {Suc 0 ..< length (x1 # x2 # xs)}"
           using less_Suc_eq_0_disj by auto
         also have "\<dots> = f ` {0 ..< length (x1 # x2 # xs)}"
         proof -
           have "f 0 = f (Suc 0)" using \<open>x1 = x2\<close> f_nth[of 0] by simp
           then show ?thesis
             using less_Suc_eq_0_disj by auto
         qed
         also have "\<dots> = {0 ..< length ys}" by fact
         finally show  "?f' ` {0 ..< length (x1 # xs)} = {0 ..< length ys}" .
       qed (insert f_nth[of "Suc i" for i], auto simp: \<open>x1 = x2\<close>)
       then show ?thesis using \<open>x1 = x2\<close> by simp
     next
       assume "x1 \<noteq> x2"
 
       have two: "Suc (Suc 0) \<le> length ys"
       proof -
         have "2 = card {f 0, f 1}" using \<open>x1 \<noteq> x2\<close> f_nth[of 0] by auto
         also have "\<dots> \<le> card (f ` {0..< length (x1 # x2 # xs)})"
           by (rule card_mono) auto
         finally show ?thesis using f_img by simp
       qed
 
       have "f 0 = 0" using f_mono f_img by (rule mono_image_least) simp
 
       have "f (Suc 0) = Suc 0"
       proof (rule ccontr)
         assume "f (Suc 0) \<noteq> Suc 0"
         then have "Suc 0 < f (Suc 0)" using f_nth[of 0] \<open>x1 \<noteq> x2\<close> \<open>f 0 = 0\<close> by auto
         then have "\<And>i. Suc 0 < f (Suc i)"
           using f_mono
           by (meson Suc_le_mono le0 less_le_trans monoD)
         then have "Suc 0 \<noteq> f i" for i using \<open>f 0 = 0\<close>
           by (cases i) fastforce+
         then have "Suc 0 \<notin> f ` {0 ..< length (x1 # x2 # xs)}" by auto
         then show False using f_img two by auto
       qed
       obtain ys' where "ys = x1 # x2 # ys'"
         using two f_nth[of 0] f_nth[of 1]
         by (auto simp: Suc_le_length_iff  \<open>f 0 = 0\<close> \<open>f (Suc 0) = Suc 0\<close>)
 
       have Suc0_le_f_Suc: "Suc 0 \<le> f (Suc i)" for i
         by (metis Suc_le_mono \<open>f (Suc 0) = Suc 0\<close> f_mono le0 mono_def)
 
       define f' where "f' x = f (Suc x) - 1" for x
       have f_Suc: "f (Suc i) = Suc (f' i)" for i
           using Suc0_le_f_Suc[of i] by (auto simp: f'_def)
 
       have "remdups_adj (x2 # xs) = (x2 # ys')"
       proof (intro "3.hyps" exI conjI impI allI)
         show "mono f'"
           using Suc0_le_f_Suc f_mono by (auto simp: f'_def mono_iff_le_Suc le_diff_iff)
       next
         have "f' ` {0 ..< length (x2 # xs)} = (\<lambda>x. f x - 1) ` {0 ..< length (x1 # x2 #xs)}"
           by (auto simp: f'_def \<open>f 0 = 0\<close> \<open>f (Suc 0) = Suc 0\<close> image_def Bex_def less_Suc_eq_0_disj)
         also have "\<dots> = (\<lambda>x. x - 1) ` f ` {0 ..< length (x1 # x2 #xs)}"
           by (auto simp: image_comp)
         also have "\<dots> = (\<lambda>x. x - 1) ` {0 ..< length ys}"
           by (simp only: f_img)
         also have "\<dots> = {0 ..< length (x2 # ys')}"
           using \<open>ys = _\<close> by (fastforce intro: rev_image_eqI)
         finally show  "f' ` {0 ..< length (x2 # xs)} = {0 ..< length (x2 # ys')}" .
       qed (insert f_nth[of "Suc i" for i] \<open>x1 \<noteq> x2\<close>, auto simp add: f_Suc \<open>ys = _\<close>)
       then show ?case using \<open>ys = _\<close> \<open>x1 \<noteq> x2\<close> by simp
     qed
   qed
 qed
 
 lemma hd_remdups_adj[simp]: "hd (remdups_adj xs) = hd xs"
   by (induction xs rule: remdups_adj.induct) simp_all
 
 lemma remdups_adj_Cons: "remdups_adj (x # xs) =
   (case remdups_adj xs of [] \<Rightarrow> [x] | y # xs \<Rightarrow> if x = y then y # xs else x # y # xs)"
   by (induct xs arbitrary: x) (auto split: list.splits)
 
 lemma remdups_adj_append_two:
   "remdups_adj (xs @ [x,y]) = remdups_adj (xs @ [x]) @ (if x = y then [] else [y])"
   by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_adjacent:
   "Suc i < length (remdups_adj xs) \<Longrightarrow> remdups_adj xs ! i \<noteq> remdups_adj xs ! Suc i"
 proof (induction xs arbitrary: i rule: remdups_adj.induct)
   case (3 x y xs i)
   thus ?case by (cases i, cases "x = y") (simp, auto simp: hd_conv_nth[symmetric])
 qed simp_all
 
 lemma remdups_adj_rev[simp]: "remdups_adj (rev xs) = rev (remdups_adj xs)"
 by (induct xs rule: remdups_adj.induct, simp_all add: remdups_adj_append_two)
 
 lemma remdups_adj_length[simp]: "length (remdups_adj xs) \<le> length xs"
 by (induct xs rule: remdups_adj.induct, auto)
 
 lemma remdups_adj_length_ge1[simp]: "xs \<noteq> [] \<Longrightarrow> length (remdups_adj xs) \<ge> Suc 0"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_Nil_iff[simp]: "remdups_adj xs = [] \<longleftrightarrow> xs = []"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_set[simp]: "set (remdups_adj xs) = set xs"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma last_remdups_adj [simp]: "last (remdups_adj xs) = last xs"
   by (induction xs rule: remdups_adj.induct) auto
 
 lemma remdups_adj_Cons_alt[simp]: "x # tl (remdups_adj (x # xs)) = remdups_adj (x # xs)"
 by (induct xs rule: remdups_adj.induct, auto)
 
 lemma remdups_adj_distinct: "distinct xs \<Longrightarrow> remdups_adj xs = xs"
 by (induct xs rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_append:
   "remdups_adj (xs\<^sub>1 @ x # xs\<^sub>2) = remdups_adj (xs\<^sub>1 @ [x]) @ tl (remdups_adj (x # xs\<^sub>2))"
 by (induct xs\<^sub>1 rule: remdups_adj.induct, simp_all)
 
 lemma remdups_adj_singleton:
   "remdups_adj xs = [x] \<Longrightarrow> xs = replicate (length xs) x"
 by (induct xs rule: remdups_adj.induct, auto split: if_split_asm)
 
 lemma remdups_adj_map_injective:
   assumes "inj f"
   shows "remdups_adj (map f xs) = map f (remdups_adj xs)"
 by (induct xs rule: remdups_adj.induct) (auto simp add: injD[OF assms])
 
 lemma remdups_adj_replicate:
   "remdups_adj (replicate n x) = (if n = 0 then [] else [x])"
   by (induction n) (auto simp: remdups_adj_Cons)
 
 lemma remdups_upt [simp]: "remdups [m..<n] = [m..<n]"
 proof (cases "m \<le> n")
   case False then show ?thesis by simp
 next
   case True then obtain q where "n = m + q"
     by (auto simp add: le_iff_add)
   moreover have "remdups [m..<m + q] = [m..<m + q]"
     by (induct q) simp_all
   ultimately show ?thesis by simp
 qed
 
 lemma successively_remdups_adjI:
   "successively P xs \<Longrightarrow> successively P (remdups_adj xs)"
 by (induction xs rule: remdups_adj.induct) (auto simp: successively_Cons)
 
 lemma successively_remdups_adj_iff:
   "(\<And>x. x \<in> set xs \<Longrightarrow> P x x) \<Longrightarrow>
   successively P (remdups_adj xs) \<longleftrightarrow> successively P xs"
 by (induction xs rule: remdups_adj.induct)(auto simp: successively_Cons)
 
 lemma remdups_adj_Cons':
   "remdups_adj (x # xs) = x # remdups_adj (dropWhile (\<lambda>y. y = x) xs)"
 by (induction xs) auto
 
 lemma remdups_adj_singleton_iff:
   "length (remdups_adj xs) = Suc 0 \<longleftrightarrow> xs \<noteq> [] \<and> xs = replicate (length xs) (hd xs)"
 proof safe
   assume *: "xs = replicate (length xs) (hd xs)" and [simp]: "xs \<noteq> []"
   show "length (remdups_adj xs) = Suc 0"
     by (subst *) (auto simp: remdups_adj_replicate)
 next
   assume "length (remdups_adj xs) = Suc 0"
   thus "xs = replicate (length xs) (hd xs)"
     by (induction xs rule: remdups_adj.induct) (auto split: if_splits)
 qed auto
 
 lemma tl_remdups_adj:
   "ys \<noteq> [] \<Longrightarrow> tl (remdups_adj ys) = remdups_adj (dropWhile (\<lambda>x. x = hd ys) (tl ys))"
 by (cases ys) (simp_all add: remdups_adj_Cons')
 
 lemma remdups_adj_append_dropWhile:
   "remdups_adj (xs @ y # ys) = remdups_adj (xs @ [y]) @ remdups_adj (dropWhile (\<lambda>x. x = y) ys)"
 by (subst remdups_adj_append) (simp add: tl_remdups_adj)
 
 lemma remdups_adj_append':
   assumes "xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys"
   shows   "remdups_adj (xs @ ys) = remdups_adj xs @ remdups_adj ys"
 proof -
   have ?thesis if [simp]: "xs \<noteq> []" "ys \<noteq> []" and "last xs \<noteq> hd ys"
   proof -
     obtain x xs' where xs: "xs = xs' @ [x]"
       by (cases xs rule: rev_cases) auto
     have "remdups_adj (xs' @ x # ys) = remdups_adj (xs' @ [x]) @ remdups_adj ys"
       using \<open>last xs \<noteq> hd ys\<close> unfolding xs
       by (metis (full_types) dropWhile_eq_self_iff last_snoc remdups_adj_append_dropWhile)
     thus ?thesis by (simp add: xs)
   qed
   thus ?thesis using assms 
     by (cases "xs = []"; cases "ys = []") auto
 qed
 
 lemma remdups_adj_append'': "xs \<noteq> []
   \<Longrightarrow> remdups_adj (xs @ ys) = remdups_adj xs @ remdups_adj (dropWhile (\<lambda>y. y = last xs) ys)"
 by (induction xs rule: remdups_adj.induct) (auto simp: remdups_adj_Cons')
 
 
 subsection \<open>@{const distinct_adj}\<close>
 
 lemma distinct_adj_Nil [simp]: "distinct_adj []"
   and distinct_adj_singleton [simp]: "distinct_adj [x]"
   and distinct_adj_Cons_Cons [simp]: "distinct_adj (x # y # xs) \<longleftrightarrow> x \<noteq> y \<and> distinct_adj (y # xs)"
 by (auto simp: distinct_adj_def)
 
 lemma distinct_adj_Cons: "distinct_adj (x # xs) \<longleftrightarrow> xs = [] \<or> x \<noteq> hd xs \<and> distinct_adj xs"
 by (cases xs) auto
 
 lemma distinct_adj_ConsD: "distinct_adj (x # xs) \<Longrightarrow> distinct_adj xs"
 by (cases xs) auto
 
 lemma distinct_adj_remdups_adj[simp]: "distinct_adj (remdups_adj xs)"
 by (induction xs rule: remdups_adj.induct) (auto simp: distinct_adj_Cons)
 
 lemma distinct_adj_altdef: "distinct_adj xs \<longleftrightarrow> remdups_adj xs = xs"
 proof
   assume "remdups_adj xs = xs"
   with distinct_adj_remdups_adj[of xs] show "distinct_adj xs"
     by simp
 next
   assume "distinct_adj xs"
   thus "remdups_adj xs = xs"
     by (induction xs rule: induct_list012) auto
 qed
 
 lemma distinct_adj_rev [simp]: "distinct_adj (rev xs) \<longleftrightarrow> distinct_adj xs"
 by (simp add: distinct_adj_def eq_commute)
 
 lemma distinct_adj_append_iff:
   "distinct_adj (xs @ ys) \<longleftrightarrow>
      distinct_adj xs \<and> distinct_adj ys \<and> (xs = [] \<or> ys = [] \<or> last xs \<noteq> hd ys)"
 by (auto simp: distinct_adj_def successively_append_iff)
 
 lemma distinct_adj_appendD1 [dest]: "distinct_adj (xs @ ys) \<Longrightarrow> distinct_adj xs"
   and distinct_adj_appendD2 [dest]: "distinct_adj (xs @ ys) \<Longrightarrow> distinct_adj ys"
   by (auto simp: distinct_adj_append_iff)
 
 lemma distinct_adj_mapI: "distinct_adj xs \<Longrightarrow> inj_on f (set xs) \<Longrightarrow> distinct_adj (map f xs)"
   unfolding distinct_adj_def successively_map
   by (erule successively_mono) (auto simp: inj_on_def)
 
 lemma distinct_adj_mapD: "distinct_adj (map f xs) \<Longrightarrow> distinct_adj xs"
 unfolding distinct_adj_def successively_map by (erule successively_mono) auto
 
 lemma distinct_adj_map_iff: "inj_on f (set xs) \<Longrightarrow> distinct_adj (map f xs) \<longleftrightarrow> distinct_adj xs"
 using distinct_adj_mapD distinct_adj_mapI by blast
 
 
 subsubsection \<open>\<^const>\<open>insert\<close>\<close>
 
 lemma in_set_insert [simp]:
   "x \<in> set xs \<Longrightarrow> List.insert x xs = xs"
 by (simp add: List.insert_def)
 
 lemma not_in_set_insert [simp]:
   "x \<notin> set xs \<Longrightarrow> List.insert x xs = x # xs"
 by (simp add: List.insert_def)
 
 lemma insert_Nil [simp]: "List.insert x [] = [x]"
 by simp
 
 lemma set_insert [simp]: "set (List.insert x xs) = insert x (set xs)"
 by (auto simp add: List.insert_def)
 
 lemma distinct_insert [simp]: "distinct (List.insert x xs) = distinct xs"
 by (simp add: List.insert_def)
 
 lemma insert_remdups:
   "List.insert x (remdups xs) = remdups (List.insert x xs)"
 by (simp add: List.insert_def)
 
 
 subsubsection \<open>\<^const>\<open>List.union\<close>\<close>
 
 text\<open>This is all one should need to know about union:\<close>
 lemma set_union[simp]: "set (List.union xs ys) = set xs \<union> set ys"
 unfolding List.union_def
 by(induct xs arbitrary: ys) simp_all
 
 lemma distinct_union[simp]: "distinct(List.union xs ys) = distinct ys"
 unfolding List.union_def
 by(induct xs arbitrary: ys) simp_all
 
 
 subsubsection \<open>\<^const>\<open>List.find\<close>\<close>
 
 lemma find_None_iff: "List.find P xs = None \<longleftrightarrow> \<not> (\<exists>x. x \<in> set xs \<and> P x)"
 proof (induction xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case by (fastforce split: if_splits)
 qed
 
 lemma find_Some_iff:
   "List.find P xs = Some x \<longleftrightarrow>
   (\<exists>i<length xs. P (xs!i) \<and> x = xs!i \<and> (\<forall>j<i. \<not> P (xs!j)))"
 proof (induction xs)
   case Nil thus ?case by simp
 next
   case (Cons x xs) thus ?case
     apply(auto simp: nth_Cons' split: if_splits)
     using diff_Suc_1[unfolded One_nat_def] less_Suc_eq_0_disj by fastforce
 qed
 
 lemma find_cong[fundef_cong]:
   assumes "xs = ys" and "\<And>x. x \<in> set ys \<Longrightarrow> P x = Q x"
   shows "List.find P xs = List.find Q ys"
 proof (cases "List.find P xs")
   case None thus ?thesis by (metis find_None_iff assms)
 next
   case (Some x)
   hence "List.find Q ys = Some x" using assms
     by (auto simp add: find_Some_iff)
   thus ?thesis using Some by auto
 qed
 
 lemma find_dropWhile:
   "List.find P xs = (case dropWhile (Not \<circ> P) xs
    of [] \<Rightarrow> None
     | x # _ \<Rightarrow> Some x)"
 by (induct xs) simp_all
 
 
 subsubsection \<open>\<^const>\<open>count_list\<close>\<close>
 
 lemma count_notin[simp]: "x \<notin> set xs \<Longrightarrow> count_list xs x = 0"
 by (induction xs) auto
 
 lemma count_le_length: "count_list xs x \<le> length xs"
 by (induction xs) auto
 
 lemma sum_count_set:
   "set xs \<subseteq> X \<Longrightarrow> finite X \<Longrightarrow> sum (count_list xs) X = length xs"
 proof (induction xs arbitrary: X)
   case (Cons x xs)
   then show ?case
     using sum.remove [of X x "count_list xs"]
     by (auto simp: sum.If_cases simp flip: diff_eq)
 qed simp
 
 
 subsubsection \<open>\<^const>\<open>List.extract\<close>\<close>
 
 lemma extract_None_iff: "List.extract P xs = None \<longleftrightarrow> \<not> (\<exists> x\<in>set xs. P x)"
 by(auto simp: extract_def dropWhile_eq_Cons_conv split: list.splits)
   (metis in_set_conv_decomp)
 
 lemma extract_SomeE:
  "List.extract P xs = Some (ys, y, zs) \<Longrightarrow>
   xs = ys @ y # zs \<and> P y \<and> \<not> (\<exists> y \<in> set ys. P y)"
 by(auto simp: extract_def dropWhile_eq_Cons_conv split: list.splits)
 
 lemma extract_Some_iff:
   "List.extract P xs = Some (ys, y, zs) \<longleftrightarrow>
    xs = ys @ y # zs \<and> P y \<and> \<not> (\<exists> y \<in> set ys. P y)"
 by(auto simp: extract_def dropWhile_eq_Cons_conv dest: set_takeWhileD split: list.splits)
 
 lemma extract_Nil_code[code]: "List.extract P [] = None"
 by(simp add: extract_def)
 
 lemma extract_Cons_code[code]:
   "List.extract P (x # xs) = (if P x then Some ([], x, xs) else
    (case List.extract P xs of
       None \<Rightarrow> None |
       Some (ys, y, zs) \<Rightarrow> Some (x#ys, y, zs)))"
 by(auto simp add: extract_def comp_def split: list.splits)
   (metis dropWhile_eq_Nil_conv list.distinct(1))
 
 
 subsubsection \<open>\<^const>\<open>remove1\<close>\<close>
 
 lemma remove1_append:
   "remove1 x (xs @ ys) =
   (if x \<in> set xs then remove1 x xs @ ys else xs @ remove1 x ys)"
 by (induct xs) auto
 
 lemma remove1_commute: "remove1 x (remove1 y zs) = remove1 y (remove1 x zs)"
 by (induct zs) auto
 
 lemma in_set_remove1[simp]:
   "a \<noteq> b \<Longrightarrow> a \<in> set(remove1 b xs) = (a \<in> set xs)"
   by (induct xs) auto
 
 lemma set_remove1_subset: "set(remove1 x xs) \<subseteq> set xs"
   by (induct xs) auto
 
 lemma set_remove1_eq [simp]: "distinct xs \<Longrightarrow> set(remove1 x xs) = set xs - {x}"
   by (induct xs) auto
 
 lemma length_remove1:
   "length(remove1 x xs) = (if x \<in> set xs then length xs - 1 else length xs)"
 by (induct xs) (auto dest!:length_pos_if_in_set)
 
 lemma remove1_filter_not[simp]:
   "\<not> P x \<Longrightarrow> remove1 x (filter P xs) = filter P xs"
 by(induct xs) auto
 
 lemma filter_remove1:
   "filter Q (remove1 x xs) = remove1 x (filter Q xs)"
 by (induct xs) auto
 
 lemma notin_set_remove1[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(remove1 y xs)"
 by(insert set_remove1_subset) fast
 
 lemma distinct_remove1[simp]: "distinct xs \<Longrightarrow> distinct(remove1 x xs)"
 by (induct xs) simp_all
 
 lemma remove1_remdups:
   "distinct xs \<Longrightarrow> remove1 x (remdups xs) = remdups (remove1 x xs)"
 by (induct xs) simp_all
 
 lemma remove1_idem: "x \<notin> set xs \<Longrightarrow> remove1 x xs = xs"
 by (induct xs) simp_all
 
 lemma remove1_split:
   "a \<in> set xs \<Longrightarrow> remove1 a xs = ys \<longleftrightarrow> (\<exists>ls rs. xs = ls @ a # rs \<and> a \<notin> set ls \<and> ys = ls @ rs)"
 by (metis remove1.simps(2) remove1_append split_list_first)
 
 
 subsubsection \<open>\<^const>\<open>removeAll\<close>\<close>
 
 lemma removeAll_filter_not_eq:
   "removeAll x = filter (\<lambda>y. x \<noteq> y)"
 proof
   fix xs
   show "removeAll x xs = filter (\<lambda>y. x \<noteq> y) xs"
     by (induct xs) auto
 qed
 
 lemma removeAll_append[simp]:
   "removeAll x (xs @ ys) = removeAll x xs @ removeAll x ys"
 by (induct xs) auto
 
 lemma set_removeAll[simp]: "set(removeAll x xs) = set xs - {x}"
 by (induct xs) auto
 
 lemma removeAll_id[simp]: "x \<notin> set xs \<Longrightarrow> removeAll x xs = xs"
 by (induct xs) auto
 
 (* Needs count:: 'a \<Rightarrow> 'a list \<Rightarrow> nat
 lemma length_removeAll:
   "length(removeAll x xs) = length xs - count x xs"
 *)
 
 lemma removeAll_filter_not[simp]:
   "\<not> P x \<Longrightarrow> removeAll x (filter P xs) = filter P xs"
 by(induct xs) auto
 
 lemma distinct_removeAll:
   "distinct xs \<Longrightarrow> distinct (removeAll x xs)"
 by (simp add: removeAll_filter_not_eq)
 
 lemma distinct_remove1_removeAll:
   "distinct xs \<Longrightarrow> remove1 x xs = removeAll x xs"
 by (induct xs) simp_all
 
 lemma map_removeAll_inj_on: "inj_on f (insert x (set xs)) \<Longrightarrow>
   map f (removeAll x xs) = removeAll (f x) (map f xs)"
 by (induct xs) (simp_all add:inj_on_def)
 
 lemma map_removeAll_inj: "inj f \<Longrightarrow>
   map f (removeAll x xs) = removeAll (f x) (map f xs)"
 by (rule map_removeAll_inj_on, erule subset_inj_on, rule subset_UNIV)
 
 lemma length_removeAll_less_eq [simp]:
   "length (removeAll x xs) \<le> length xs"
   by (simp add: removeAll_filter_not_eq)
 
 lemma length_removeAll_less [termination_simp]:
   "x \<in> set xs \<Longrightarrow> length (removeAll x xs) < length xs"
   by (auto dest: length_filter_less simp add: removeAll_filter_not_eq)
 
 lemma distinct_concat_iff: "distinct (concat xs) \<longleftrightarrow>
   distinct (removeAll [] xs) \<and> 
   (\<forall>ys. ys \<in> set xs \<longrightarrow> distinct ys) \<and>
   (\<forall>ys zs. ys \<in> set xs \<and> zs \<in> set xs \<and> ys \<noteq> zs \<longrightarrow> set ys \<inter> set zs = {})"
 apply (induct xs)
  apply(simp_all, safe, auto)
 by (metis Int_iff UN_I empty_iff equals0I set_empty)
 
 
 subsubsection \<open>\<^const>\<open>replicate\<close>\<close>
 
 lemma length_replicate [simp]: "length (replicate n x) = n"
 by (induct n) auto
 
 lemma replicate_eqI:
   assumes "length xs = n" and "\<And>y. y \<in> set xs \<Longrightarrow> y = x"
   shows "xs = replicate n x"
   using assms
 proof (induct xs arbitrary: n)
   case Nil then show ?case by simp
 next
   case (Cons x xs) then show ?case by (cases n) simp_all
 qed
 
 lemma Ex_list_of_length: "\<exists>xs. length xs = n"
 by (rule exI[of _ "replicate n undefined"]) simp
 
 lemma map_replicate [simp]: "map f (replicate n x) = replicate n (f x)"
 by (induct n) auto
 
 lemma map_replicate_const:
   "map (\<lambda> x. k) lst = replicate (length lst) k"
 by (induct lst) auto
 
 lemma replicate_app_Cons_same:
 "(replicate n x) @ (x # xs) = x # replicate n x @ xs"
 by (induct n) auto
 
 lemma rev_replicate [simp]: "rev (replicate n x) = replicate n x"
 by (induct n) (auto simp: replicate_app_Cons_same)
 
 lemma replicate_add: "replicate (n + m) x = replicate n x @ replicate m x"
 by (induct n) auto
 
 text\<open>Courtesy of Matthias Daum:\<close>
 lemma append_replicate_commute:
   "replicate n x @ replicate k x = replicate k x @ replicate n x"
   by (metis add.commute replicate_add)
 
 text\<open>Courtesy of Andreas Lochbihler:\<close>
 lemma filter_replicate:
   "filter P (replicate n x) = (if P x then replicate n x else [])"
 by(induct n) auto
 
 lemma hd_replicate [simp]: "n \<noteq> 0 \<Longrightarrow> hd (replicate n x) = x"
 by (induct n) auto
 
 lemma tl_replicate [simp]: "tl (replicate n x) = replicate (n - 1) x"
 by (induct n) auto
 
 lemma last_replicate [simp]: "n \<noteq> 0 \<Longrightarrow> last (replicate n x) = x"
 by (atomize (full), induct n) auto
 
 lemma nth_replicate[simp]: "i < n \<Longrightarrow> (replicate n x)!i = x"
 by (induct n arbitrary: i)(auto simp: nth_Cons split: nat.split)
 
 text\<open>Courtesy of Matthias Daum (2 lemmas):\<close>
 lemma take_replicate[simp]: "take i (replicate k x) = replicate (min i k) x"
 proof (cases "k \<le> i")
   case True
   then show ?thesis
     by (simp add: min_def)
 next
   case False
   then have "replicate k x = replicate i x @ replicate (k - i) x"
     by (simp add: replicate_add [symmetric])
   then show ?thesis
     by (simp add: min_def)
 qed
 
 lemma drop_replicate[simp]: "drop i (replicate k x) = replicate (k-i) x"
 proof (induct k arbitrary: i)
   case (Suc k)
   then show ?case
     by (simp add: drop_Cons')
 qed simp
 
 lemma set_replicate_Suc: "set (replicate (Suc n) x) = {x}"
 by (induct n) auto
 
 lemma set_replicate [simp]: "n \<noteq> 0 \<Longrightarrow> set (replicate n x) = {x}"
 by (fast dest!: not0_implies_Suc intro!: set_replicate_Suc)
 
 lemma set_replicate_conv_if: "set (replicate n x) = (if n = 0 then {} else {x})"
 by auto
 
 lemma in_set_replicate[simp]: "(x \<in> set (replicate n y)) = (x = y \<and> n \<noteq> 0)"
 by (simp add: set_replicate_conv_if)
 
 lemma Ball_set_replicate[simp]:
   "(\<forall>x \<in> set(replicate n a). P x) = (P a \<or> n=0)"
 by(simp add: set_replicate_conv_if)
 
 lemma Bex_set_replicate[simp]:
   "(\<exists>x \<in> set(replicate n a). P x) = (P a \<and> n\<noteq>0)"
 by(simp add: set_replicate_conv_if)
 
 lemma replicate_append_same:
   "replicate i x @ [x] = x # replicate i x"
   by (induct i) simp_all
 
 lemma map_replicate_trivial:
   "map (\<lambda>i. x) [0..<i] = replicate i x"
 by (induct i) (simp_all add: replicate_append_same)
 
 lemma concat_replicate_trivial[simp]:
   "concat (replicate i []) = []"
   by (induct i) (auto simp add: map_replicate_const)
 
 lemma replicate_empty[simp]: "(replicate n x = []) \<longleftrightarrow> n=0"
 by (induct n) auto
 
 lemma empty_replicate[simp]: "([] = replicate n x) \<longleftrightarrow> n=0"
 by (induct n) auto
 
 lemma replicate_eq_replicate[simp]:
   "(replicate m x = replicate n y) \<longleftrightarrow> (m=n \<and> (m\<noteq>0 \<longrightarrow> x=y))"
 proof (induct m arbitrary: n)
   case (Suc m n)
   then show ?case
     by (induct n) auto
 qed simp
 
 lemma takeWhile_replicate[simp]:
   "takeWhile P (replicate n x) = (if P x then replicate n x else [])"
 using takeWhile_eq_Nil_iff by fastforce
 
 lemma dropWhile_replicate[simp]:
   "dropWhile P (replicate n x) = (if P x then [] else replicate n x)"
 using dropWhile_eq_self_iff by fastforce
 
 lemma replicate_length_filter:
   "replicate (length (filter (\<lambda>y. x = y) xs)) x = filter (\<lambda>y. x = y) xs"
   by (induct xs) auto
 
 lemma comm_append_are_replicate:
   "xs @ ys = ys @ xs \<Longrightarrow> \<exists>m n zs. concat (replicate m zs) = xs \<and> concat (replicate n zs) = ys"
 proof (induction "length (xs @ ys) + length xs" arbitrary: xs ys rule: less_induct)
   case less
   consider (1) "length ys < length xs" | (2) "xs = []" | (3) "length xs \<le> length ys \<and> xs \<noteq> []"
     by linarith
   then show ?case
   proof (cases)
     case 1
     then show ?thesis
       using less.hyps[OF _ less.prems[symmetric]] nat_add_left_cancel_less by auto
   next
     case 2
     then have "concat (replicate 0 ys) = xs \<and> concat (replicate 1 ys) = ys"
       by simp
     then show ?thesis
       by blast
   next
     case 3
     then have "length xs \<le> length ys" and "xs \<noteq> []"
       by blast+
     from \<open>length xs \<le> length ys\<close> and  \<open>xs @ ys = ys @ xs\<close>
     obtain ws where "ys = xs @ ws"
       by (auto simp: append_eq_append_conv2)
     from this and \<open>xs \<noteq> []\<close>
     have "length ws < length ys"
       by simp
     from \<open>xs @ ys = ys @ xs\<close>[unfolded \<open>ys = xs @ ws\<close>]
     have "xs @ ws = ws @ xs"
       by simp
     from less.hyps[OF _ this] \<open>length ws < length ys\<close>
     obtain m n' zs where "concat (replicate m zs) = xs" and  "concat (replicate n' zs) = ws"
       by auto
     then have "concat (replicate (m+n') zs) = ys"
       using \<open>ys = xs @ ws\<close>
       by (simp add: replicate_add)
     then show ?thesis
       using \<open>concat (replicate m zs) = xs\<close> by blast
   qed
 qed
 
 lemma comm_append_is_replicate:
   fixes xs ys :: "'a list"
   assumes "xs \<noteq> []" "ys \<noteq> []"
   assumes "xs @ ys = ys @ xs"
   shows "\<exists>n zs. n > 1 \<and> concat (replicate n zs) = xs @ ys"
 proof -
   obtain m n zs where "concat (replicate m zs) = xs"
     and "concat (replicate n zs) = ys"
     using comm_append_are_replicate[OF assms(3)] by blast
   then have "m + n > 1" and "concat (replicate (m+n) zs) = xs @ ys"
     using \<open>xs \<noteq> []\<close> and \<open>ys \<noteq> []\<close>
     by (auto simp: replicate_add)
   then show ?thesis by blast
 qed
 
 lemma Cons_replicate_eq:
   "x # xs = replicate n y \<longleftrightarrow> x = y \<and> n > 0 \<and> xs = replicate (n - 1) x"
 by (induct n) auto
 
 lemma replicate_length_same:
   "(\<forall>y\<in>set xs. y = x) \<Longrightarrow> replicate (length xs) x = xs"
 by (induct xs) simp_all
 
 lemma foldr_replicate [simp]:
   "foldr f (replicate n x) = f x ^^ n"
 by (induct n) (simp_all)
 
 lemma fold_replicate [simp]:
   "fold f (replicate n x) = f x ^^ n"
 by (subst foldr_fold [symmetric]) simp_all
 
 
 subsubsection \<open>\<^const>\<open>enumerate\<close>\<close>
 
 lemma enumerate_simps [simp, code]:
   "enumerate n [] = []"
   "enumerate n (x # xs) = (n, x) # enumerate (Suc n) xs"
   by (simp_all add: enumerate_eq_zip upt_rec)
 
 lemma length_enumerate [simp]:
   "length (enumerate n xs) = length xs"
 by (simp add: enumerate_eq_zip)
 
 lemma map_fst_enumerate [simp]:
   "map fst (enumerate n xs) = [n..<n + length xs]"
 by (simp add: enumerate_eq_zip)
 
 lemma map_snd_enumerate [simp]:
   "map snd (enumerate n xs) = xs"
 by (simp add: enumerate_eq_zip)
 
 lemma in_set_enumerate_eq:
   "p \<in> set (enumerate n xs) \<longleftrightarrow> n \<le> fst p \<and> fst p < length xs + n \<and> nth xs (fst p - n) = snd p"
 proof -
   { fix m
     assume "n \<le> m"
     moreover assume "m < length xs + n"
     ultimately have "[n..<n + length xs] ! (m - n) = m \<and>
       xs ! (m - n) = xs ! (m - n) \<and> m - n < length xs" by auto
     then have "\<exists>q. [n..<n + length xs] ! q = m \<and>
         xs ! q = xs ! (m - n) \<and> q < length xs" ..
   } then show ?thesis by (cases p) (auto simp add: enumerate_eq_zip in_set_zip)
 qed
 
 lemma nth_enumerate_eq: "m < length xs \<Longrightarrow> enumerate n xs ! m = (n + m, xs ! m)"
 by (simp add: enumerate_eq_zip)
 
 lemma enumerate_replicate_eq:
   "enumerate n (replicate m a) = map (\<lambda>q. (q, a)) [n..<n + m]"
 by (rule pair_list_eqI)
    (simp_all add: enumerate_eq_zip comp_def map_replicate_const)
 
 lemma enumerate_Suc_eq:
   "enumerate (Suc n) xs = map (apfst Suc) (enumerate n xs)"
 by (rule pair_list_eqI)
    (simp_all add: not_le, simp del: map_map add: map_Suc_upt map_map [symmetric])
 
 lemma distinct_enumerate [simp]:
   "distinct (enumerate n xs)"
 by (simp add: enumerate_eq_zip distinct_zipI1)
 
 lemma enumerate_append_eq:
   "enumerate n (xs @ ys) = enumerate n xs @ enumerate (n + length xs) ys"
   by (simp add: enumerate_eq_zip add.assoc zip_append2)
 
 lemma enumerate_map_upt:
   "enumerate n (map f [n..<m]) = map (\<lambda>k. (k, f k)) [n..<m]"
 by (cases "n \<le> m") (simp_all add: zip_map2 zip_same_conv_map enumerate_eq_zip)
 
 
 subsubsection \<open>\<^const>\<open>rotate1\<close> and \<^const>\<open>rotate\<close>\<close>
 
 lemma rotate0[simp]: "rotate 0 = id"
 by(simp add:rotate_def)
 
 lemma rotate_Suc[simp]: "rotate (Suc n) xs = rotate1(rotate n xs)"
 by(simp add:rotate_def)
 
 lemma rotate_add:
   "rotate (m+n) = rotate m \<circ> rotate n"
 by(simp add:rotate_def funpow_add)
 
 lemma rotate_rotate: "rotate m (rotate n xs) = rotate (m+n) xs"
 by(simp add:rotate_add)
 
 lemma rotate1_map: "rotate1 (map f xs) = map f (rotate1 xs)"
 by(cases xs) simp_all
 
 lemma rotate1_rotate_swap: "rotate1 (rotate n xs) = rotate n (rotate1 xs)"
 by(simp add:rotate_def funpow_swap1)
 
 lemma rotate1_length01[simp]: "length xs \<le> 1 \<Longrightarrow> rotate1 xs = xs"
 by(cases xs) simp_all
 
 lemma rotate_length01[simp]: "length xs \<le> 1 \<Longrightarrow> rotate n xs = xs"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate1 xs = tl xs @ [hd xs]"
 by (cases xs) simp_all
 
 lemma rotate_drop_take:
   "rotate n xs = drop (n mod length xs) xs @ take (n mod length xs) xs"
 proof (induct n)
   case (Suc n)
   show ?case
   proof (cases "xs = []")
     case False
     then show ?thesis
     proof (cases "n mod length xs = 0")
       case True
       then show ?thesis
         by (auto simp add: mod_Suc False Suc.hyps drop_Suc rotate1_hd_tl take_Suc Suc_length_conv)
     next
       case False
       with \<open>xs \<noteq> []\<close> Suc
       show ?thesis
         by (simp add: rotate_def mod_Suc rotate1_hd_tl drop_Suc[symmetric] drop_tl[symmetric]
             take_hd_drop linorder_not_le)
     qed
   qed simp
 qed simp
 
 lemma rotate_conv_mod: "rotate n xs = rotate (n mod length xs) xs"
   by(simp add:rotate_drop_take)
 
 lemma rotate_id[simp]: "n mod length xs = 0 \<Longrightarrow> rotate n xs = xs"
   by(simp add:rotate_drop_take)
 
 lemma length_rotate1[simp]: "length(rotate1 xs) = length xs"
   by (cases xs) simp_all
 
 lemma length_rotate[simp]: "length(rotate n xs) = length xs"
   by (induct n arbitrary: xs) (simp_all add:rotate_def)
 
 lemma distinct1_rotate[simp]: "distinct(rotate1 xs) = distinct xs"
   by (cases xs) auto
 
 lemma distinct_rotate[simp]: "distinct(rotate n xs) = distinct xs"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate_map: "rotate n (map f xs) = map f (rotate n xs)"
   by(simp add:rotate_drop_take take_map drop_map)
 
 lemma set_rotate1[simp]: "set(rotate1 xs) = set xs"
   by (cases xs) auto
 
 lemma set_rotate[simp]: "set(rotate n xs) = set xs"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate1_is_Nil_conv[simp]: "(rotate1 xs = []) = (xs = [])"
   by (cases xs) auto
 
 lemma rotate_is_Nil_conv[simp]: "(rotate n xs = []) = (xs = [])"
   by (induct n) (simp_all add:rotate_def)
 
 lemma rotate_rev:
   "rotate n (rev xs) = rev(rotate (length xs - (n mod length xs)) xs)"
 proof (cases "length xs = 0 \<or> n mod length xs = 0")
   case False
   then show ?thesis
     by(simp add:rotate_drop_take rev_drop rev_take)
 qed force
 
 lemma hd_rotate_conv_nth:
   assumes "xs \<noteq> []" shows "hd(rotate n xs) = xs!(n mod length xs)"
 proof -
   have "n mod length xs < length xs"
     using assms by simp
   then show ?thesis
     by (metis drop_eq_Nil hd_append2 hd_drop_conv_nth leD rotate_drop_take)
 qed
 
 lemma rotate_append: "rotate (length l) (l @ q) = q @ l"
   by (induct l arbitrary: q) (auto simp add: rotate1_rotate_swap)
 
 lemma nth_rotate:
   \<open>rotate m xs ! n = xs ! ((m + n) mod length xs)\<close> if \<open>n < length xs\<close>
   using that apply (auto simp add: rotate_drop_take nth_append not_less less_diff_conv ac_simps dest!: le_Suc_ex)
    apply (metis add.commute mod_add_right_eq mod_less)
   apply (metis (no_types, lifting) Nat.diff_diff_right add.commute add_diff_cancel_right' diff_le_self dual_order.strict_trans2 length_greater_0_conv less_nat_zero_code list.size(3) mod_add_right_eq mod_add_self2 mod_le_divisor mod_less)
   done
 
 lemma nth_rotate1:
   \<open>rotate1 xs ! n = xs ! (Suc n mod length xs)\<close> if \<open>n < length xs\<close>
   using that nth_rotate [of n xs 1] by simp
 
 
 subsubsection \<open>\<^const>\<open>nths\<close> --- a generalization of \<^const>\<open>nth\<close> to sets\<close>
 
 lemma nths_empty [simp]: "nths xs {} = []"
   by (auto simp add: nths_def)
 
 lemma nths_nil [simp]: "nths [] A = []"
   by (auto simp add: nths_def)
 
 lemma nths_all: "\<forall>i < length xs. i \<in> I \<Longrightarrow> nths xs I = xs"
 apply (simp add: nths_def)
 apply (subst filter_True)
  apply (auto simp: in_set_zip subset_iff)
 done
 
 lemma length_nths:
   "length (nths xs I) = card{i. i < length xs \<and> i \<in> I}"
   by(simp add: nths_def length_filter_conv_card cong:conj_cong)
 
 lemma nths_shift_lemma_Suc:
   "map fst (filter (\<lambda>p. P(Suc(snd p))) (zip xs is)) =
    map fst (filter (\<lambda>p. P(snd p)) (zip xs (map Suc is)))"
 proof (induct xs arbitrary: "is")
   case (Cons x xs "is")
   show ?case
     by (cases "is") (auto simp add: Cons.hyps)
 qed simp
 
 lemma nths_shift_lemma:
   "map fst (filter (\<lambda>p. snd p \<in> A) (zip xs [i..<i + length xs])) =
    map fst (filter (\<lambda>p. snd p + i \<in> A) (zip xs [0..<length xs]))"
 by (induct xs rule: rev_induct) (simp_all add: add.commute)
 
 lemma nths_append:
   "nths (l @ l') A = nths l A @ nths l' {j. j + length l \<in> A}"
   unfolding nths_def
 proof (induct l' rule: rev_induct)
   case (snoc x xs)
   then show ?case
     by (simp add: upt_add_eq_append[of 0] nths_shift_lemma add.commute)
 qed auto
 
 lemma nths_Cons:
   "nths (x # l) A = (if 0 \<in> A then [x] else []) @ nths l {j. Suc j \<in> A}"
 proof (induct l rule: rev_induct)
   case (snoc x xs)
   then show ?case
     by (simp flip: append_Cons add: nths_append)
 qed (auto simp: nths_def)
 
 lemma nths_map: "nths (map f xs) I = map f (nths xs I)"
   by(induction xs arbitrary: I) (simp_all add: nths_Cons)
 
 lemma set_nths: "set(nths xs I) = {xs!i|i. i<size xs \<and> i \<in> I}"
   by (induct xs arbitrary: I) (auto simp: nths_Cons nth_Cons split:nat.split dest!: gr0_implies_Suc)
 
 lemma set_nths_subset: "set(nths xs I) \<subseteq> set xs"
   by(auto simp add:set_nths)
 
 lemma notin_set_nthsI[simp]: "x \<notin> set xs \<Longrightarrow> x \<notin> set(nths xs I)"
   by(auto simp add:set_nths)
 
 lemma in_set_nthsD: "x \<in> set(nths xs I) \<Longrightarrow> x \<in> set xs"
   by(auto simp add:set_nths)
 
 lemma nths_singleton [simp]: "nths [x] A = (if 0 \<in> A then [x] else [])"
   by (simp add: nths_Cons)
 
 lemma distinct_nthsI[simp]: "distinct xs \<Longrightarrow> distinct (nths xs I)"
   by (induct xs arbitrary: I) (auto simp: nths_Cons)
 
 lemma nths_upt_eq_take [simp]: "nths l {..<n} = take n l"
   by (induct l rule: rev_induct) (simp_all split: nat_diff_split add: nths_append)
 
 lemma nths_nths: "nths (nths xs A) B = nths xs {i \<in> A. \<exists>j \<in> B. card {i' \<in> A. i' < i} = j}"
   by (induction xs arbitrary: A B) (auto simp add: nths_Cons card_less_Suc card_less_Suc2)
 
 lemma drop_eq_nths: "drop n xs = nths xs {i. i \<ge> n}"
   by (induction xs arbitrary: n) (auto simp add: nths_Cons nths_all drop_Cons' intro: arg_cong2[where f=nths, OF refl])
 
 lemma nths_drop: "nths (drop n xs) I = nths xs ((+) n ` I)"
 by(force simp: drop_eq_nths nths_nths simp flip: atLeastLessThan_iff
          intro: arg_cong2[where f=nths, OF refl])
 
 lemma filter_eq_nths: "filter P xs = nths xs {i. i<length xs \<and> P(xs!i)}"
   by(induction xs) (auto simp: nths_Cons)
 
 lemma filter_in_nths:
   "distinct xs \<Longrightarrow> filter (%x. x \<in> set (nths xs s)) xs = nths xs s"
 proof (induct xs arbitrary: s)
   case Nil thus ?case by simp
 next
   case (Cons a xs)
   then have "\<forall>x. x \<in> set xs \<longrightarrow> x \<noteq> a" by auto
   with Cons show ?case by(simp add: nths_Cons cong:filter_cong)
 qed
 
 
 subsubsection \<open>\<^const>\<open>subseqs\<close> and \<^const>\<open>List.n_lists\<close>\<close>
 
 lemma length_subseqs: "length (subseqs xs) = 2 ^ length xs"
   by (induct xs) (simp_all add: Let_def)
 
 lemma subseqs_powset: "set ` set (subseqs xs) = Pow (set xs)"
 proof -
   have aux: "\<And>x A. set ` Cons x ` A = insert x ` set ` A"
     by (auto simp add: image_def)
   have "set (map set (subseqs xs)) = Pow (set xs)"
     by (induct xs) (simp_all add: aux Let_def Pow_insert Un_commute comp_def del: map_map)
   then show ?thesis by simp
 qed
 
 lemma distinct_set_subseqs:
   assumes "distinct xs"
   shows "distinct (map set (subseqs xs))"
 proof (rule card_distinct)
   have "finite (set xs)" ..
   then have "card (Pow (set xs)) = 2 ^ card (set xs)"
     by (rule card_Pow)
   with assms distinct_card [of xs] have "card (Pow (set xs)) = 2 ^ length xs"
     by simp
   then show "card (set (map set (subseqs xs))) = length (map set (subseqs xs))"
     by (simp add: subseqs_powset length_subseqs)
 qed
 
 lemma n_lists_Nil [simp]: "List.n_lists n [] = (if n = 0 then [[]] else [])"
   by (induct n) simp_all
 
 lemma length_n_lists_elem: "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
   by (induct n arbitrary: ys) auto
 
 lemma set_n_lists: "set (List.n_lists n xs) = {ys. length ys = n \<and> set ys \<subseteq> set xs}"
 proof (rule set_eqI)
   fix ys :: "'a list"
   show "ys \<in> set (List.n_lists n xs) \<longleftrightarrow> ys \<in> {ys. length ys = n \<and> set ys \<subseteq> set xs}"
   proof -
     have "ys \<in> set (List.n_lists n xs) \<Longrightarrow> length ys = n"
       by (induct n arbitrary: ys) auto
     moreover have "\<And>x. ys \<in> set (List.n_lists n xs) \<Longrightarrow> x \<in> set ys \<Longrightarrow> x \<in> set xs"
       by (induct n arbitrary: ys) auto
     moreover have "set ys \<subseteq> set xs \<Longrightarrow> ys \<in> set (List.n_lists (length ys) xs)"
       by (induct ys) auto
     ultimately show ?thesis by auto
   qed
 qed
 
 lemma subseqs_refl: "xs \<in> set (subseqs xs)"
   by (induct xs) (simp_all add: Let_def)
 
 lemma subset_subseqs: "X \<subseteq> set xs \<Longrightarrow> X \<in> set ` set (subseqs xs)"
   unfolding subseqs_powset by simp
 
 lemma Cons_in_subseqsD: "y # ys \<in> set (subseqs xs) \<Longrightarrow> ys \<in> set (subseqs xs)"
   by (induct xs) (auto simp: Let_def)
 
 lemma subseqs_distinctD: "\<lbrakk> ys \<in> set (subseqs xs); distinct xs \<rbrakk> \<Longrightarrow> distinct ys"
 proof (induct xs arbitrary: ys)
   case (Cons x xs ys)
   then show ?case
     by (auto simp: Let_def) (metis Pow_iff contra_subsetD image_eqI subseqs_powset)
 qed simp
 
 
 subsubsection \<open>\<^const>\<open>splice\<close>\<close>
 
 lemma splice_Nil2 [simp]: "splice xs [] = xs"
   by (cases xs) simp_all
 
 lemma length_splice[simp]: "length(splice xs ys) = length xs + length ys"
   by (induct xs ys rule: splice.induct) auto
 
 lemma split_Nil_iff[simp]: "splice xs ys = [] \<longleftrightarrow> xs = [] \<and> ys = []"
   by (induct xs ys rule: splice.induct) auto
 
 lemma splice_replicate[simp]: "splice (replicate m x) (replicate n x) = replicate (m+n) x"
 proof (induction "replicate m x" "replicate n x" arbitrary: m n rule: splice.induct)
   case (2 x xs)
   then show ?case 
     by (auto simp add: Cons_replicate_eq dest: gr0_implies_Suc)
 qed auto
 
 subsubsection \<open>\<^const>\<open>shuffles\<close>\<close>
 
 lemma shuffles_commutes: "shuffles xs ys = shuffles ys xs"
 by (induction xs ys rule: shuffles.induct) (simp_all add: Un_commute)
 
 lemma Nil_in_shuffles[simp]: "[] \<in> shuffles xs ys \<longleftrightarrow> xs = [] \<and> ys = []"
   by (induct xs ys rule: shuffles.induct) auto
 
 lemma shufflesE:
   "zs \<in> shuffles xs ys \<Longrightarrow>
     (zs = xs \<Longrightarrow> ys = [] \<Longrightarrow> P) \<Longrightarrow>
     (zs = ys \<Longrightarrow> xs = [] \<Longrightarrow> P) \<Longrightarrow>
     (\<And>x xs' z zs'. xs = x # xs' \<Longrightarrow> zs = z # zs' \<Longrightarrow> x = z \<Longrightarrow> zs' \<in> shuffles xs' ys \<Longrightarrow> P) \<Longrightarrow>
     (\<And>y ys' z zs'. ys = y # ys' \<Longrightarrow> zs = z # zs' \<Longrightarrow> y = z \<Longrightarrow> zs' \<in> shuffles xs ys' \<Longrightarrow> P) \<Longrightarrow> P"
   by (induct xs ys rule: shuffles.induct) auto
 
 lemma Cons_in_shuffles_iff:
   "z # zs \<in> shuffles xs ys \<longleftrightarrow>
     (xs \<noteq> [] \<and> hd xs = z \<and> zs \<in> shuffles (tl xs) ys \<or>
      ys \<noteq> [] \<and> hd ys = z \<and> zs \<in> shuffles xs (tl ys))"
   by (induct xs ys rule: shuffles.induct) auto
 
 lemma splice_in_shuffles [simp, intro]: "splice xs ys \<in> shuffles xs ys"
   by (induction xs ys rule: splice.induct) (simp_all add: Cons_in_shuffles_iff shuffles_commutes)
 
 lemma Nil_in_shufflesI: "xs = [] \<Longrightarrow> ys = [] \<Longrightarrow> [] \<in> shuffles xs ys"
   by simp
 
 lemma Cons_in_shuffles_leftI: "zs \<in> shuffles xs ys \<Longrightarrow> z # zs \<in> shuffles (z # xs) ys"
   by (cases ys) auto
 
 lemma Cons_in_shuffles_rightI: "zs \<in> shuffles xs ys \<Longrightarrow> z # zs \<in> shuffles xs (z # ys)"
   by (cases xs) auto
 
 lemma finite_shuffles [simp, intro]: "finite (shuffles xs ys)"
   by (induction xs ys rule: shuffles.induct) simp_all
 
 lemma length_shuffles: "zs \<in> shuffles xs ys \<Longrightarrow> length zs = length xs + length ys"
   by (induction xs ys arbitrary: zs rule: shuffles.induct) auto
 
 lemma set_shuffles: "zs \<in> shuffles xs ys \<Longrightarrow> set zs = set xs \<union> set ys"
   by (induction xs ys arbitrary: zs rule: shuffles.induct) auto
 
 lemma distinct_disjoint_shuffles:
   assumes "distinct xs" "distinct ys" "set xs \<inter> set ys = {}" "zs \<in> shuffles xs ys"
   shows   "distinct zs"
 using assms
 proof (induction xs ys arbitrary: zs rule: shuffles.induct)
   case (3 x xs y ys)
   show ?case
   proof (cases zs)
     case (Cons z zs')
     with "3.prems" and "3.IH"[of zs'] show ?thesis by (force dest: set_shuffles)
   qed simp_all
 qed simp_all
 
 lemma Cons_shuffles_subset1: "(#) x ` shuffles xs ys \<subseteq> shuffles (x # xs) ys"
   by (cases ys) auto
 
 lemma Cons_shuffles_subset2: "(#) y ` shuffles xs ys \<subseteq> shuffles xs (y # ys)"
   by (cases xs) auto
 
 lemma filter_shuffles:
   "filter P ` shuffles xs ys = shuffles (filter P xs) (filter P ys)"
 proof -
   have *: "filter P ` (#) x ` A = (if P x then (#) x ` filter P ` A else filter P ` A)" for x A
     by (auto simp: image_image)
   show ?thesis
   by (induction xs ys rule: shuffles.induct)
      (simp_all split: if_splits add: image_Un * Un_absorb1 Un_absorb2
            Cons_shuffles_subset1 Cons_shuffles_subset2)
 qed
 
 lemma filter_shuffles_disjoint1:
   assumes "set xs \<inter> set ys = {}" "zs \<in> shuffles xs ys"
   shows   "filter (\<lambda>x. x \<in> set xs) zs = xs" (is "filter ?P _ = _")
     and   "filter (\<lambda>x. x \<notin> set xs) zs = ys" (is "filter ?Q _ = _")
   using assms
 proof -
   from assms have "filter ?P zs \<in> filter ?P ` shuffles xs ys" by blast
   also have "filter ?P ` shuffles xs ys = shuffles (filter ?P xs) (filter ?P ys)"
     by (rule filter_shuffles)
   also have "filter ?P xs = xs" by (rule filter_True) simp_all
   also have "filter ?P ys = []" by (rule filter_False) (insert assms(1), auto)
   also have "shuffles xs [] = {xs}" by simp
   finally show "filter ?P zs = xs" by simp
 next
   from assms have "filter ?Q zs \<in> filter ?Q ` shuffles xs ys" by blast
   also have "filter ?Q ` shuffles xs ys = shuffles (filter ?Q xs) (filter ?Q ys)"
     by (rule filter_shuffles)
   also have "filter ?Q ys = ys" by (rule filter_True) (insert assms(1), auto)
   also have "filter ?Q xs = []" by (rule filter_False) (insert assms(1), auto)
   also have "shuffles [] ys = {ys}" by simp
   finally show "filter ?Q zs = ys" by simp
 qed
 
 lemma filter_shuffles_disjoint2:
   assumes "set xs \<inter> set ys = {}" "zs \<in> shuffles xs ys"
   shows   "filter (\<lambda>x. x \<in> set ys) zs = ys" "filter (\<lambda>x. x \<notin> set ys) zs = xs"
   using filter_shuffles_disjoint1[of ys xs zs] assms
   by (simp_all add: shuffles_commutes Int_commute)
 
 lemma partition_in_shuffles:
   "xs \<in> shuffles (filter P xs) (filter (\<lambda>x. \<not>P x) xs)"
 proof (induction xs)
   case (Cons x xs)
   show ?case
   proof (cases "P x")
     case True
     hence "x # xs \<in> (#) x ` shuffles (filter P xs) (filter (\<lambda>x. \<not>P x) xs)"
       by (intro imageI Cons.IH)
     also have "\<dots> \<subseteq> shuffles (filter P (x # xs)) (filter (\<lambda>x. \<not>P x) (x # xs))"
       by (simp add: True Cons_shuffles_subset1)
     finally show ?thesis .
   next
     case False
     hence "x # xs \<in> (#) x ` shuffles (filter P xs) (filter (\<lambda>x. \<not>P x) xs)"
       by (intro imageI Cons.IH)
     also have "\<dots> \<subseteq> shuffles (filter P (x # xs)) (filter (\<lambda>x. \<not>P x) (x # xs))"
       by (simp add: False Cons_shuffles_subset2)
     finally show ?thesis .
   qed
 qed auto
 
 lemma inv_image_partition:
   assumes "\<And>x. x \<in> set xs \<Longrightarrow> P x" "\<And>y. y \<in> set ys \<Longrightarrow> \<not>P y"
   shows   "partition P -` {(xs, ys)} = shuffles xs ys"
 proof (intro equalityI subsetI)
   fix zs assume zs: "zs \<in> shuffles xs ys"
   hence [simp]: "set zs = set xs \<union> set ys" by (rule set_shuffles)
   from assms have "filter P zs = filter (\<lambda>x. x \<in> set xs) zs"
                   "filter (\<lambda>x. \<not>P x) zs = filter (\<lambda>x. x \<in> set ys) zs"
     by (intro filter_cong refl; force)+
   moreover from assms have "set xs \<inter> set ys = {}" by auto
   ultimately show "zs \<in> partition P -` {(xs, ys)}" using zs
     by (simp add: o_def filter_shuffles_disjoint1 filter_shuffles_disjoint2)
 next
   fix zs assume "zs \<in> partition P -` {(xs, ys)}"
   thus "zs \<in> shuffles xs ys" using partition_in_shuffles[of zs] by (auto simp: o_def)
 qed
 
 
 subsubsection \<open>Transpose\<close>
 
 function transpose where
 "transpose []             = []" |
 "transpose ([]     # xss) = transpose xss" |
 "transpose ((x#xs) # xss) =
   (x # [h. (h#t) \<leftarrow> xss]) # transpose (xs # [t. (h#t) \<leftarrow> xss])"
 by pat_completeness auto
 
 lemma transpose_aux_filter_head:
   "concat (map (case_list [] (\<lambda>h t. [h])) xss) =
   map (\<lambda>xs. hd xs) (filter (\<lambda>ys. ys \<noteq> []) xss)"
   by (induct xss) (auto split: list.split)
 
 lemma transpose_aux_filter_tail:
   "concat (map (case_list [] (\<lambda>h t. [t])) xss) =
   map (\<lambda>xs. tl xs) (filter (\<lambda>ys. ys \<noteq> []) xss)"
   by (induct xss) (auto split: list.split)
 
 lemma transpose_aux_max:
   "max (Suc (length xs)) (foldr (\<lambda>xs. max (length xs)) xss 0) =
   Suc (max (length xs) (foldr (\<lambda>x. max (length x - Suc 0)) (filter (\<lambda>ys. ys \<noteq> []) xss) 0))"
   (is "max _ ?foldB = Suc (max _ ?foldA)")
 proof (cases "(filter (\<lambda>ys. ys \<noteq> []) xss) = []")
   case True
   hence "foldr (\<lambda>xs. max (length xs)) xss 0 = 0"
   proof (induct xss)
     case (Cons x xs)
     then have "x = []" by (cases x) auto
     with Cons show ?case by auto
   qed simp
   thus ?thesis using True by simp
 next
   case False
 
   have foldA: "?foldA = foldr (\<lambda>x. max (length x)) (filter (\<lambda>ys. ys \<noteq> []) xss) 0 - 1"
     by (induct xss) auto
   have foldB: "?foldB = foldr (\<lambda>x. max (length x)) (filter (\<lambda>ys. ys \<noteq> []) xss) 0"
     by (induct xss) auto
 
   have "0 < ?foldB"
   proof -
     from False
     obtain z zs where zs: "(filter (\<lambda>ys. ys \<noteq> []) xss) = z#zs" by (auto simp: neq_Nil_conv)
     hence "z \<in> set (filter (\<lambda>ys. ys \<noteq> []) xss)" by auto
     hence "z \<noteq> []" by auto
     thus ?thesis
       unfolding foldB zs
       by (auto simp: max_def intro: less_le_trans)
   qed
   thus ?thesis
     unfolding foldA foldB max_Suc_Suc[symmetric]
     by simp
 qed
 
 termination transpose
   by (relation "measure (\<lambda>xs. foldr (\<lambda>xs. max (length xs)) xs 0 + length xs)")
      (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max less_Suc_eq_le)
 
 lemma transpose_empty: "(transpose xs = []) \<longleftrightarrow> (\<forall>x \<in> set xs. x = [])"
   by (induct rule: transpose.induct) simp_all
 
 lemma length_transpose:
   fixes xs :: "'a list list"
   shows "length (transpose xs) = foldr (\<lambda>xs. max (length xs)) xs 0"
   by (induct rule: transpose.induct)
     (auto simp: transpose_aux_filter_tail foldr_map comp_def transpose_aux_max
                 max_Suc_Suc[symmetric] simp del: max_Suc_Suc)
 
 lemma nth_transpose:
   fixes xs :: "'a list list"
   assumes "i < length (transpose xs)"
   shows "transpose xs ! i = map (\<lambda>xs. xs ! i) (filter (\<lambda>ys. i < length ys) xs)"
 using assms proof (induct arbitrary: i rule: transpose.induct)
   case (3 x xs xss)
   define XS where "XS = (x # xs) # xss"
   hence [simp]: "XS \<noteq> []" by auto
   thus ?case
   proof (cases i)
     case 0
     thus ?thesis by (simp add: transpose_aux_filter_head hd_conv_nth)
   next
     case (Suc j)
     have *: "\<And>xss. xs # map tl xss = map tl ((x#xs)#xss)" by simp
     have **: "\<And>xss. (x#xs) # filter (\<lambda>ys. ys \<noteq> []) xss = filter (\<lambda>ys. ys \<noteq> []) ((x#xs)#xss)" by simp
     { fix x have "Suc j < length x \<longleftrightarrow> x \<noteq> [] \<and> j < length x - Suc 0"
       by (cases x) simp_all
     } note *** = this
 
     have j_less: "j < length (transpose (xs # concat (map (case_list [] (\<lambda>h t. [t])) xss)))"
       using "3.prems" by (simp add: transpose_aux_filter_tail length_transpose Suc)
 
     show ?thesis
       unfolding transpose.simps \<open>i = Suc j\<close> nth_Cons_Suc "3.hyps"[OF j_less]
       apply (auto simp: transpose_aux_filter_tail filter_map comp_def length_transpose * ** *** XS_def[symmetric])
       by (simp add: nth_tl)
   qed
 qed simp_all
 
 lemma transpose_map_map:
   "transpose (map (map f) xs) = map (map f) (transpose xs)"
 proof (rule nth_equalityI)
   have [simp]: "length (transpose (map (map f) xs)) = length (transpose xs)"
     by (simp add: length_transpose foldr_map comp_def)
   show "length (transpose (map (map f) xs)) = length (map (map f) (transpose xs))" by simp
 
   fix i assume "i < length (transpose (map (map f) xs))"
   thus "transpose (map (map f) xs) ! i = map (map f) (transpose xs) ! i"
     by (simp add: nth_transpose filter_map comp_def)
 qed
 
 subsubsection \<open>\<^const>\<open>min\<close> and \<^const>\<open>arg_min\<close>\<close>
 
 lemma min_list_Min: "xs \<noteq> [] \<Longrightarrow> min_list xs = Min (set xs)"
   by (induction xs rule: induct_list012)(auto)
 
 lemma f_arg_min_list_f: "xs \<noteq> [] \<Longrightarrow> f (arg_min_list f xs) = Min (f ` (set xs))"
   by(induction f xs rule: arg_min_list.induct) (auto simp: min_def intro!: antisym)
 
 lemma arg_min_list_in: "xs \<noteq> [] \<Longrightarrow> arg_min_list f xs \<in> set xs"
   by(induction xs rule: induct_list012) (auto simp: Let_def)
 
 
 subsubsection \<open>(In)finiteness\<close>
 
 lemma finite_maxlen:
   "finite (M::'a list set) \<Longrightarrow> \<exists>n. \<forall>s\<in>M. size s < n"
 proof (induct rule: finite.induct)
   case emptyI show ?case by simp
 next
   case (insertI M xs)
   then obtain n where "\<forall>s\<in>M. length s < n" by blast
   hence "\<forall>s\<in>insert xs M. size s < max n (size xs) + 1" by auto
   thus ?case ..
 qed
 
 lemma lists_length_Suc_eq:
   "{xs. set xs \<subseteq> A \<and> length xs = Suc n} =
     (\<lambda>(xs, n). n#xs) ` ({xs. set xs \<subseteq> A \<and> length xs = n} \<times> A)"
   by (auto simp: length_Suc_conv)
 
 lemma
   assumes "finite A"
   shows finite_lists_length_eq: "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
   and card_lists_length_eq: "card {xs. set xs \<subseteq> A \<and> length xs = n} = (card A)^n"
   using \<open>finite A\<close>
   by (induct n)
      (auto simp: card_image inj_split_Cons lists_length_Suc_eq cong: conj_cong)
 
 lemma finite_lists_length_le:
   assumes "finite A" shows "finite {xs. set xs \<subseteq> A \<and> length xs \<le> n}"
  (is "finite ?S")
 proof-
   have "?S = (\<Union>n\<in>{0..n}. {xs. set xs \<subseteq> A \<and> length xs = n})" by auto
   thus ?thesis by (auto intro!: finite_lists_length_eq[OF \<open>finite A\<close>] simp only:)
 qed
 
 lemma card_lists_length_le:
   assumes "finite A" shows "card {xs. set xs \<subseteq> A \<and> length xs \<le> n} = (\<Sum>i\<le>n. card A^i)"
 proof -
   have "(\<Sum>i\<le>n. card A^i) = card (\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i})"
     using \<open>finite A\<close>
     by (subst card_UN_disjoint)
        (auto simp add: card_lists_length_eq finite_lists_length_eq)
   also have "(\<Union>i\<le>n. {xs. set xs \<subseteq> A \<and> length xs = i}) = {xs. set xs \<subseteq> A \<and> length xs \<le> n}"
     by auto
   finally show ?thesis by simp
 qed
 
 lemma finite_lists_distinct_length_eq [intro]:
   assumes "finite A"
   shows "finite {xs. length xs = n \<and> distinct xs \<and> set xs \<subseteq> A}" (is "finite ?S")
 proof -
   have "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
     using \<open>finite A\<close> by (rule finite_lists_length_eq)
   moreover have "?S \<subseteq> {xs. set xs \<subseteq> A \<and> length xs = n}" by auto
   ultimately show ?thesis using finite_subset by auto
 qed
 
 lemma card_lists_distinct_length_eq:
   assumes "finite A" "k \<le> card A"
   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"
 using assms
 proof (induct k)
   case 0
   then have "{xs. length xs = 0 \<and> distinct xs \<and> set xs \<subseteq> A} = {[]}" by auto
   then show ?case by simp
 next
   case (Suc k)
   let "?k_list" = "\<lambda>k xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A"
   have inj_Cons: "\<And>A. inj_on (\<lambda>(xs, n). n # xs) A"  by (rule inj_onI) auto
 
   from Suc have "k \<le> card A" by simp
   moreover note \<open>finite A\<close>
   moreover have "finite {xs. ?k_list k xs}"
     by (rule finite_subset) (use finite_lists_length_eq[OF \<open>finite A\<close>, of k] in auto)
   moreover have "\<And>i j. i \<noteq> j \<longrightarrow> {i} \<times> (A - set i) \<inter> {j} \<times> (A - set j) = {}"
     by auto
   moreover have "\<And>i. i \<in> {xs. ?k_list k xs} \<Longrightarrow> card (A - set i) = card A - k"
     by (simp add: card_Diff_subset distinct_card)
   moreover have "{xs. ?k_list (Suc k) xs} =
       (\<lambda>(xs, n). n#xs) ` \<Union>((\<lambda>xs. {xs} \<times> (A - set xs)) ` {xs. ?k_list k xs})"
     by (auto simp: length_Suc_conv)
   moreover have "Suc (card A - Suc k) = card A - k" using Suc.prems by simp
   then have "(card A - k) * \<Prod>{Suc (card A - k)..card A} = \<Prod>{Suc (card A - Suc k)..card A}"
     by (subst prod.insert[symmetric]) (simp add: atLeastAtMost_insertL)+
   ultimately show ?case
     by (simp add: card_image inj_Cons card_UN_disjoint Suc.hyps algebra_simps)
 qed
 
 lemma card_lists_distinct_length_eq':
   assumes "k < card A"
   shows "card {xs. length xs = k \<and> distinct xs \<and> set xs \<subseteq> A} = \<Prod>{card A - k + 1 .. card A}"
 proof -
   from \<open>k < card A\<close> have "finite A" and "k \<le> card A" using card.infinite by force+
   from this show ?thesis by (rule card_lists_distinct_length_eq)
 qed
 
 lemma infinite_UNIV_listI: "\<not> finite(UNIV::'a list set)"
   by (metis UNIV_I finite_maxlen length_replicate less_irrefl)
 
 lemma same_length_different: 
   assumes "xs \<noteq> ys" and "length xs = length ys"
   shows "\<exists>pre x xs' y ys'. x\<noteq>y \<and> xs = pre @ [x] @ xs' \<and> ys = pre @ [y] @ ys'"
   using assms
 proof (induction xs arbitrary: ys)
   case Nil
   then show ?case by auto
 next
   case (Cons x xs)
   then obtain z zs where ys: "ys = Cons z zs"
     by (metis length_Suc_conv)
   show ?case
   proof (cases "x=z")
     case True
     then have "xs \<noteq> zs" "length xs = length zs"
       using Cons.prems ys by auto
     then obtain pre u xs' v ys' where "u\<noteq>v" and xs: "xs = pre @ [u] @ xs'" and zs: "zs = pre @ [v] @ys'"
       using Cons.IH by meson
     then have "x # xs = (z#pre) @ [u] @ xs' \<and> ys = (z#pre) @ [v] @ ys'"
       by (simp add: True ys)
     with \<open>u\<noteq>v\<close> show ?thesis
       by blast
   next
     case False
     then have "x # xs = [] @ [x] @ xs \<and> ys = [] @ [z] @ zs"
       by (simp add: ys)
     then show ?thesis
       using False by blast
   qed
 qed
 
 subsection \<open>Sorting\<close>
 
 subsubsection \<open>\<^const>\<open>sorted_wrt\<close>\<close>
 
 text \<open>Sometimes the second equation in the definition of \<^const>\<open>sorted_wrt\<close> is too aggressive
 because it relates each list element to \emph{all} its successors. Then this equation
 should be removed and \<open>sorted_wrt2_simps\<close> should be added instead.\<close>
 
 lemma sorted_wrt1: "sorted_wrt P [x] = True"
 by(simp)
 
 lemma sorted_wrt2: "transp P \<Longrightarrow> sorted_wrt P (x # y # zs) = (P x y \<and> sorted_wrt P (y # zs))"
 proof (induction zs arbitrary: x y)
   case (Cons z zs)
   then show ?case
     by simp (meson transpD)+
 qed auto
 
 lemmas sorted_wrt2_simps = sorted_wrt1 sorted_wrt2
 
 lemma sorted_wrt_true [simp]:
   "sorted_wrt (\<lambda>_ _. True) xs"
 by (induction xs) simp_all
 
 lemma sorted_wrt_append:
   "sorted_wrt P (xs @ ys) \<longleftrightarrow>
   sorted_wrt P xs \<and> sorted_wrt P ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. P x y)"
 by (induction xs) auto
 
 lemma sorted_wrt_map:
   "sorted_wrt R (map f xs) = sorted_wrt (\<lambda>x y. R (f x) (f y)) xs"
 by (induction xs) simp_all
 
 lemma
   assumes "sorted_wrt f xs"
   shows sorted_wrt_take: "sorted_wrt f (take n xs)"
   and   sorted_wrt_drop: "sorted_wrt f (drop n xs)"
 proof -
   from assms have "sorted_wrt f (take n xs @ drop n xs)" by simp
   thus "sorted_wrt f (take n xs)" and "sorted_wrt f (drop n xs)"
     unfolding sorted_wrt_append by simp_all
 qed
 
 lemma sorted_wrt_filter:
   "sorted_wrt f xs \<Longrightarrow> sorted_wrt f (filter P xs)"
 by (induction xs) auto
 
 lemma sorted_wrt_rev:
   "sorted_wrt P (rev xs) = sorted_wrt (\<lambda>x y. P y x) xs"
 by (induction xs) (auto simp add: sorted_wrt_append)
 
 lemma sorted_wrt_mono_rel:
   "(\<And>x y. \<lbrakk> x \<in> set xs; y \<in> set xs; P x y \<rbrakk> \<Longrightarrow> Q x y) \<Longrightarrow> sorted_wrt P xs \<Longrightarrow> sorted_wrt Q xs"
 by(induction xs)(auto)
 
 lemma sorted_wrt01: "length xs \<le> 1 \<Longrightarrow> sorted_wrt P xs"
 by(auto simp: le_Suc_eq length_Suc_conv)
 
 lemma sorted_wrt_iff_nth_less:
   "sorted_wrt P xs = (\<forall>i j. i < j \<longrightarrow> j < length xs \<longrightarrow> P (xs ! i) (xs ! j))"
   by (induction xs) (auto simp add: in_set_conv_nth Ball_def nth_Cons split: nat.split)
 
 lemma sorted_wrt_nth_less:
   "\<lbrakk> sorted_wrt P xs; i < j; j < length xs \<rbrakk> \<Longrightarrow> P (xs ! i) (xs ! j)"
 by(auto simp: sorted_wrt_iff_nth_less)
 
 lemma sorted_wrt_iff_nth_Suc_transp: assumes "transp P"
   shows "sorted_wrt P xs \<longleftrightarrow> (\<forall>i.  Suc i < length xs \<longrightarrow> P (xs!i) (xs!(Suc i)))" (is "?L = ?R")
 proof
   assume ?L
   thus ?R
     by (simp add: sorted_wrt_iff_nth_less) 
 next
   assume ?R
   have "i < j \<Longrightarrow> j < length xs \<Longrightarrow> P (xs ! i) (xs ! j)" for i j
     by(induct i j rule: less_Suc_induct)(simp add: \<open>?R\<close>, meson assms transpE transp_less)
   thus ?L
     by (simp add: sorted_wrt_iff_nth_less)
 qed
 
 lemma sorted_wrt_upt[simp]: "sorted_wrt (<) [m..<n]"
 by(induction n) (auto simp: sorted_wrt_append)
 
 lemma sorted_wrt_upto[simp]: "sorted_wrt (<) [i..j]"
 proof(induct i j rule:upto.induct)
   case (1 i j)
   from this show ?case
     unfolding upto.simps[of i j] by auto
 qed
 
 text \<open>Each element is greater or equal to its index:\<close>
 
 lemma sorted_wrt_less_idx:
   "sorted_wrt (<) ns \<Longrightarrow> i < length ns \<Longrightarrow> i \<le> ns!i"
 proof (induction ns arbitrary: i rule: rev_induct)
   case Nil thus ?case by simp
 next
   case snoc
   thus ?case
     by (auto simp: nth_append sorted_wrt_append)
        (metis less_antisym not_less nth_mem)
 qed
 
 
 subsubsection \<open>\<^const>\<open>sorted\<close>\<close>
 
 context linorder
 begin
 
 text \<open>Sometimes the second equation in the definition of \<^const>\<open>sorted\<close> is too aggressive
 because it relates each list element to \emph{all} its successors. Then this equation
 should be removed and \<open>sorted2_simps\<close> should be added instead.
 Executable code is one such use case.\<close>
 
 lemma sorted0: "sorted [] = True"
   by simp
 
 lemma sorted1: "sorted [x] = True"
   by simp
 
 lemma sorted2: "sorted (x # y # zs) = (x \<le> y \<and> sorted (y # zs))"
   by(induction zs) auto
 
 lemmas sorted2_simps = sorted1 sorted2
 
 lemmas [code] = sorted0 sorted2_simps
 
 lemma sorted_append:
   "sorted (xs@ys) = (sorted xs \<and> sorted ys \<and> (\<forall>x \<in> set xs. \<forall>y \<in> set ys. x\<le>y))"
 by (simp add: sorted_wrt_append)
 
 lemma sorted_map:
   "sorted (map f xs) = sorted_wrt (\<lambda>x y. f x \<le> f y) xs"
   by (simp add: sorted_wrt_map)
 
 lemma sorted01: "length xs \<le> 1 \<Longrightarrow> sorted xs"
   by (simp add: sorted_wrt01)
 
 lemma sorted_tl:
   "sorted xs \<Longrightarrow> sorted (tl xs)"
   by (cases xs) (simp_all)
 
 lemma sorted_iff_nth_mono_less:
   "sorted xs = (\<forall>i j. i < j \<longrightarrow> j < length xs \<longrightarrow> xs ! i \<le> xs ! j)"
   by (simp add: sorted_wrt_iff_nth_less)
 
 lemma sorted_iff_nth_mono:
   "sorted xs = (\<forall>i j. i \<le> j \<longrightarrow> j < length xs \<longrightarrow> xs ! i \<le> xs ! j)"
   by (auto simp: sorted_iff_nth_mono_less nat_less_le)
 
 lemma sorted_nth_mono:
   "sorted xs \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!i \<le> xs!j"
   by (auto simp: sorted_iff_nth_mono)
 
 lemma sorted_iff_nth_Suc: 
   "sorted xs \<longleftrightarrow> (\<forall>i.  Suc i < length xs \<longrightarrow> xs!i \<le> xs!(Suc i))"
   by(simp add: sorted_wrt_iff_nth_Suc_transp)
 
 lemma sorted_rev_nth_mono:
   "sorted (rev xs) \<Longrightarrow> i \<le> j \<Longrightarrow> j < length xs \<Longrightarrow> xs!j \<le> xs!i"
   using sorted_nth_mono[ of "rev xs" "length xs - j - 1" "length xs - i - 1"]
     rev_nth[of "length xs - i - 1" "xs"] rev_nth[of "length xs - j - 1" "xs"]
   by auto
 
 lemma sorted_rev_iff_nth_mono:
   "sorted (rev xs) \<longleftrightarrow> (\<forall> i j. i \<le> j \<longrightarrow> j < length xs \<longrightarrow> xs!j \<le> xs!i)" (is "?L = ?R")
 proof
   assume ?L thus ?R
     by (blast intro: sorted_rev_nth_mono)
 next
   assume ?R
   have "rev xs ! k \<le> rev xs ! l" if asms: "k \<le> l" "l < length(rev xs)" for k l
   proof -
     have "k < length xs"  "l < length xs"
       "length xs - Suc l \<le> length xs - Suc k" "length xs - Suc k < length xs"
       using asms by auto
     thus "rev xs ! k \<le> rev xs ! l"
       using \<open>?R\<close> \<open>k \<le> l\<close> unfolding rev_nth[OF \<open>k < length xs\<close>] rev_nth[OF \<open>l < length xs\<close>] by blast
   qed
   thus ?L by (simp add: sorted_iff_nth_mono)
 qed
 
 lemma sorted_rev_iff_nth_Suc: 
   "sorted (rev xs) \<longleftrightarrow> (\<forall>i.  Suc i < length xs \<longrightarrow> xs!(Suc i) \<le> xs!i)"
 proof-
   interpret dual: linorder "(\<lambda>x y. y \<le> x)" "(\<lambda>x y. y < x)"
     using dual_linorder .
   show ?thesis
     using dual_linorder dual.sorted_iff_nth_Suc dual.sorted_iff_nth_mono 
     unfolding sorted_rev_iff_nth_mono by simp
 qed
 
 lemma sorted_map_remove1:
   "sorted (map f xs) \<Longrightarrow> sorted (map f (remove1 x xs))"
 by (induct xs) (auto)
 
 lemma sorted_remove1: "sorted xs \<Longrightarrow> sorted (remove1 a xs)"
 using sorted_map_remove1 [of "\<lambda>x. x"] by simp
 
 lemma sorted_butlast:
   assumes "xs \<noteq> []" and "sorted xs"
   shows "sorted (butlast xs)"
 proof -
   from \<open>xs \<noteq> []\<close> obtain ys y where "xs = ys @ [y]"
     by (cases xs rule: rev_cases) auto
   with \<open>sorted xs\<close> show ?thesis by (simp add: sorted_append)
 qed
 
 lemma sorted_replicate [simp]: "sorted(replicate n x)"
 by(induction n) (auto)
 
 lemma sorted_remdups[simp]:
   "sorted xs \<Longrightarrow> sorted (remdups xs)"
 by (induct xs) (auto)
 
 lemma sorted_remdups_adj[simp]:
   "sorted xs \<Longrightarrow> sorted (remdups_adj xs)"
 by (induct xs rule: remdups_adj.induct, simp_all split: if_split_asm)
 
 lemma sorted_nths: "sorted xs \<Longrightarrow> sorted (nths xs I)"
 by(induction xs arbitrary: I)(auto simp: nths_Cons)
 
 lemma sorted_distinct_set_unique:
 assumes "sorted xs" "distinct xs" "sorted ys" "distinct ys" "set xs = set ys"
 shows "xs = ys"
 proof -
   from assms have 1: "length xs = length ys" by (auto dest!: distinct_card)
   from assms show ?thesis
   proof(induct rule:list_induct2[OF 1])
     case 1 show ?case by simp
   next
     case (2 x xs y ys)
     then show ?case
       by (cases \<open>x = y\<close>) (auto simp add: insert_eq_iff)
   qed
 qed
 
 lemma map_sorted_distinct_set_unique:
   assumes "inj_on f (set xs \<union> set ys)"
   assumes "sorted (map f xs)" "distinct (map f xs)"
     "sorted (map f ys)" "distinct (map f ys)"
   assumes "set xs = set ys"
   shows "xs = ys"
 proof -
   from assms have "map f xs = map f ys"
     by (simp add: sorted_distinct_set_unique)
   with \<open>inj_on f (set xs \<union> set ys)\<close> show "xs = ys"
     by (blast intro: map_inj_on)
 qed
 
 lemma
   assumes "sorted xs"
   shows sorted_take: "sorted (take n xs)"
   and sorted_drop: "sorted (drop n xs)"
 proof -
   from assms have "sorted (take n xs @ drop n xs)" by simp
   then show "sorted (take n xs)" and "sorted (drop n xs)"
     unfolding sorted_append by simp_all
 qed
 
 lemma sorted_dropWhile: "sorted xs \<Longrightarrow> sorted (dropWhile P xs)"
   by (auto dest: sorted_drop simp add: dropWhile_eq_drop)
 
 lemma sorted_takeWhile: "sorted xs \<Longrightarrow> sorted (takeWhile P xs)"
   by (subst takeWhile_eq_take) (auto dest: sorted_take)
 
 lemma sorted_filter:
   "sorted (map f xs) \<Longrightarrow> sorted (map f (filter P xs))"
   by (induct xs) simp_all
 
 lemma foldr_max_sorted:
   assumes "sorted (rev xs)"
   shows "foldr max xs y = (if xs = [] then y else max (xs ! 0) y)"
   using assms
 proof (induct xs)
   case (Cons x xs)
   then have "sorted (rev xs)" using sorted_append by auto
   with Cons show ?case
     by (cases xs) (auto simp add: sorted_append max_def)
 qed simp
 
 lemma filter_equals_takeWhile_sorted_rev:
   assumes sorted: "sorted (rev (map f xs))"
   shows "filter (\<lambda>x. t < f x) xs = takeWhile (\<lambda> x. t < f x) xs"
     (is "filter ?P xs = ?tW")
 proof (rule takeWhile_eq_filter[symmetric])
   let "?dW" = "dropWhile ?P xs"
   fix x assume "x \<in> set ?dW"
   then obtain i where i: "i < length ?dW" and nth_i: "x = ?dW ! i"
     unfolding in_set_conv_nth by auto
   hence "length ?tW + i < length (?tW @ ?dW)"
     unfolding length_append by simp
   hence i': "length (map f ?tW) + i < length (map f xs)" by simp
   have "(map f ?tW @ map f ?dW) ! (length (map f ?tW) + i) \<le>
         (map f ?tW @ map f ?dW) ! (length (map f ?tW) + 0)"
     using sorted_rev_nth_mono[OF sorted _ i', of "length ?tW"]
     unfolding map_append[symmetric] by simp
   hence "f x \<le> f (?dW ! 0)"
     unfolding nth_append_length_plus nth_i
     using i preorder_class.le_less_trans[OF le0 i] by simp
   also have "... \<le> t"
     using hd_dropWhile[of "?P" xs] le0[THEN preorder_class.le_less_trans, OF i]
     using hd_conv_nth[of "?dW"] by simp
   finally show "\<not> t < f x" by simp
 qed
 
 lemma sorted_map_same:
   "sorted (map f (filter (\<lambda>x. f x = g xs) xs))"
 proof (induct xs arbitrary: g)
   case Nil then show ?case by simp
 next
   case (Cons x xs)
   then have "sorted (map f (filter (\<lambda>y. f y = (\<lambda>xs. f x) xs) xs))" .
   moreover from Cons have "sorted (map f (filter (\<lambda>y. f y = (g \<circ> Cons x) xs) xs))" .
   ultimately show ?case by simp_all
 qed
 
 lemma sorted_same:
   "sorted (filter (\<lambda>x. x = g xs) xs)"
 using sorted_map_same [of "\<lambda>x. x"] by simp
 
 end
 
 lemma sorted_upt[simp]: "sorted [m..<n]"
   by(simp add: sorted_wrt_mono_rel[OF _ sorted_wrt_upt])
 
 lemma sorted_upto[simp]: "sorted [m..n]"
   by(simp add: sorted_wrt_mono_rel[OF _ sorted_wrt_upto])
 
 
 subsubsection \<open>Sorting functions\<close>
 
 text\<open>Currently it is not shown that \<^const>\<open>sort\<close> returns a
 permutation of its input because the nicest proof is via multisets,
 which are not part of Main. Alternatively one could define a function
 that counts the number of occurrences of an element in a list and use
 that instead of multisets to state the correctness property.\<close>
 
 context linorder
 begin
 
 lemma set_insort_key:
   "set (insort_key f x xs) = insert x (set xs)"
 by (induct xs) auto
 
 lemma length_insort [simp]:
   "length (insort_key f x xs) = Suc (length xs)"
 by (induct xs) simp_all
 
 lemma insort_key_left_comm:
   assumes "f x \<noteq> f y"
   shows "insort_key f y (insort_key f x xs) = insort_key f x (insort_key f y xs)"
 by (induct xs) (auto simp add: assms dest: order.antisym)
 
 lemma insort_left_comm:
   "insort x (insort y xs) = insort y (insort x xs)"
 by (cases "x = y") (auto intro: insort_key_left_comm)
 
 lemma comp_fun_commute_insort: "comp_fun_commute insort"
 proof
 qed (simp add: insort_left_comm fun_eq_iff)
 
 lemma sort_key_simps [simp]:
   "sort_key f [] = []"
   "sort_key f (x#xs) = insort_key f x (sort_key f xs)"
 by (simp_all add: sort_key_def)
 
 lemma sort_key_conv_fold:
   assumes "inj_on f (set xs)"
   shows "sort_key f xs = fold (insort_key f) xs []"
 proof -
   have "fold (insort_key f) (rev xs) = fold (insort_key f) xs"
   proof (rule fold_rev, rule ext)
     fix zs
     fix x y
     assume "x \<in> set xs" "y \<in> set xs"
     with assms have *: "f y = f x \<Longrightarrow> y = x" by (auto dest: inj_onD)
     have **: "x = y \<longleftrightarrow> y = x" by auto
     show "(insort_key f y \<circ> insort_key f x) zs = (insort_key f x \<circ> insort_key f y) zs"
       by (induct zs) (auto intro: * simp add: **)
   qed
   then show ?thesis by (simp add: sort_key_def foldr_conv_fold)
 qed
 
 lemma sort_conv_fold:
   "sort xs = fold insort xs []"
 by (rule sort_key_conv_fold) simp
 
 lemma length_sort[simp]: "length (sort_key f xs) = length xs"
 by (induct xs, auto)
 
 lemma set_sort[simp]: "set(sort_key f xs) = set xs"
 by (induct xs) (simp_all add: set_insort_key)
 
 lemma distinct_insort: "distinct (insort_key f x xs) = (x \<notin> set xs \<and> distinct xs)"
 by(induct xs)(auto simp: set_insort_key)
 
+lemma distinct_insort_key:
+  "distinct (map f (insort_key f x xs)) = (f x \<notin> f ` set xs \<and> (distinct (map f xs)))"
+by (induct xs) (auto simp: set_insort_key)
+
 lemma distinct_sort[simp]: "distinct (sort_key f xs) = distinct xs"
 by (induct xs) (simp_all add: distinct_insort)
 
 lemma sorted_insort_key: "sorted (map f (insort_key f x xs)) = sorted (map f xs)"
 by (induct xs) (auto simp: set_insort_key)
 
 lemma sorted_insort: "sorted (insort x xs) = sorted xs"
 using sorted_insort_key [where f="\<lambda>x. x"] by simp
 
 theorem sorted_sort_key [simp]: "sorted (map f (sort_key f xs))"
 by (induct xs) (auto simp:sorted_insort_key)
 
 theorem sorted_sort [simp]: "sorted (sort xs)"
 using sorted_sort_key [where f="\<lambda>x. x"] by simp
 
 lemma insort_not_Nil [simp]:
   "insort_key f a xs \<noteq> []"
 by (induction xs) simp_all
 
 lemma insort_is_Cons: "\<forall>x\<in>set xs. f a \<le> f x \<Longrightarrow> insort_key f a xs = a # xs"
 by (cases xs) auto
 
 lemma sorted_sort_id: "sorted xs \<Longrightarrow> sort xs = xs"
 by (induct xs) (auto simp add: insort_is_Cons)
 
 lemma insort_key_remove1:
   assumes "a \<in> set xs" and "sorted (map f xs)" and "hd (filter (\<lambda>x. f a = f x) xs) = a"
   shows "insort_key f a (remove1 a xs) = xs"
 using assms proof (induct xs)
   case (Cons x xs)
   then show ?case
   proof (cases "x = a")
     case False
     then have "f x \<noteq> f a" using Cons.prems by auto
     then have "f x < f a" using Cons.prems by auto
     with \<open>f x \<noteq> f a\<close> show ?thesis using Cons by (auto simp: insort_is_Cons)
   qed (auto simp: insort_is_Cons)
 qed simp
 
 lemma insort_remove1:
   assumes "a \<in> set xs" and "sorted xs"
   shows "insort a (remove1 a xs) = xs"
 proof (rule insort_key_remove1)
   define n where "n = length (filter ((=) a) xs) - 1"
   from \<open>a \<in> set xs\<close> show "a \<in> set xs" .
   from \<open>sorted xs\<close> show "sorted (map (\<lambda>x. x) xs)" by simp
   from \<open>a \<in> set xs\<close> have "a \<in> set (filter ((=) a) xs)" by auto
   then have "set (filter ((=) a) xs) \<noteq> {}" by auto
   then have "filter ((=) a) xs \<noteq> []" by (auto simp only: set_empty)
   then have "length (filter ((=) a) xs) > 0" by simp
   then have n: "Suc n = length (filter ((=) a) xs)" by (simp add: n_def)
   moreover have "replicate (Suc n) a = a # replicate n a"
     by simp
   ultimately show "hd (filter ((=) a) xs) = a" by (simp add: replicate_length_filter)
 qed
 
 lemma finite_sorted_distinct_unique:
   assumes "finite A" shows "\<exists>!xs. set xs = A \<and> sorted xs \<and> distinct xs"
 proof -
   obtain xs where "distinct xs" "A = set xs"
     using finite_distinct_list [OF assms] by metis
   then show ?thesis
     by (rule_tac a="sort xs" in ex1I) (auto simp: sorted_distinct_set_unique)
 qed
 
 lemma insort_insert_key_triv:
   "f x \<in> f ` set xs \<Longrightarrow> insort_insert_key f x xs = xs"
   by (simp add: insort_insert_key_def)
 
 lemma insort_insert_triv:
   "x \<in> set xs \<Longrightarrow> insort_insert x xs = xs"
   using insort_insert_key_triv [of "\<lambda>x. x"] by simp
 
 lemma insort_insert_insort_key:
   "f x \<notin> f ` set xs \<Longrightarrow> insort_insert_key f x xs = insort_key f x xs"
   by (simp add: insort_insert_key_def)
 
 lemma insort_insert_insort:
   "x \<notin> set xs \<Longrightarrow> insort_insert x xs = insort x xs"
   using insort_insert_insort_key [of "\<lambda>x. x"] by simp
 
 lemma set_insort_insert:
   "set (insort_insert x xs) = insert x (set xs)"
   by (auto simp add: insort_insert_key_def set_insort_key)
 
 lemma distinct_insort_insert:
   assumes "distinct xs"
   shows "distinct (insort_insert_key f x xs)"
 using assms by (induct xs) (auto simp add: insort_insert_key_def set_insort_key)
 
 lemma sorted_insort_insert_key:
   assumes "sorted (map f xs)"
   shows "sorted (map f (insort_insert_key f x xs))"
   using assms by (simp add: insort_insert_key_def sorted_insort_key)
 
 lemma sorted_insort_insert:
   assumes "sorted xs"
   shows "sorted (insort_insert x xs)"
   using assms sorted_insort_insert_key [of "\<lambda>x. x"] by simp
 
 lemma filter_insort_triv:
   "\<not> P x \<Longrightarrow> filter P (insort_key f x xs) = filter P xs"
   by (induct xs) simp_all
 
 lemma filter_insort:
   "sorted (map f xs) \<Longrightarrow> P x \<Longrightarrow> filter P (insort_key f x xs) = insort_key f x (filter P xs)"
   by (induct xs) (auto, subst insort_is_Cons, auto)
 
 lemma filter_sort:
   "filter P (sort_key f xs) = sort_key f (filter P xs)"
   by (induct xs) (simp_all add: filter_insort_triv filter_insort)
 
-lemma remove1_insort [simp]:
-  "remove1 x (insort x xs) = xs"
+lemma remove1_insort_key [simp]:
+  "remove1 x (insort_key f x xs) = xs"
   by (induct xs) simp_all
 
 end
 
 lemma sort_upt [simp]: "sort [m..<n] = [m..<n]"
 by (rule sorted_sort_id) simp
 
 lemma sort_upto [simp]: "sort [i..j] = [i..j]"
 by (rule sorted_sort_id) simp
 
 lemma sorted_find_Min:
   "sorted xs \<Longrightarrow> \<exists>x \<in> set xs. P x \<Longrightarrow> List.find P xs = Some (Min {x\<in>set xs. P x})"
 proof (induct xs)
   case Nil then show ?case by simp
 next
   case (Cons x xs) show ?case proof (cases "P x")
     case True
     with Cons show ?thesis by (auto intro: Min_eqI [symmetric])
   next
     case False then have "{y. (y = x \<or> y \<in> set xs) \<and> P y} = {y \<in> set xs. P y}"
       by auto
     with Cons False show ?thesis by (simp_all)
   qed
 qed
 
 lemma sorted_enumerate [simp]: "sorted (map fst (enumerate n xs))"
 by (simp add: enumerate_eq_zip)
 
 text \<open>Stability of \<^const>\<open>sort_key\<close>:\<close>
 
 lemma sort_key_stable: "filter (\<lambda>y. f y = k) (sort_key f xs) = filter (\<lambda>y. f y = k) xs"
 by (induction xs) (auto simp: filter_insort insort_is_Cons filter_insort_triv)
 
 corollary stable_sort_key_sort_key: "stable_sort_key sort_key"
 by(simp add: stable_sort_key_def sort_key_stable)
 
 lemma sort_key_const: "sort_key (\<lambda>x. c) xs = xs"
 by (metis (mono_tags) filter_True sort_key_stable)
 
 
 subsubsection \<open>\<^const>\<open>transpose\<close> on sorted lists\<close>
 
 lemma sorted_transpose[simp]: "sorted (rev (map length (transpose xs)))"
 by (auto simp: sorted_iff_nth_mono rev_nth nth_transpose
     length_filter_conv_card intro: card_mono)
 
 lemma transpose_max_length:
   "foldr (\<lambda>xs. max (length xs)) (transpose xs) 0 = length (filter (\<lambda>x. x \<noteq> []) xs)"
   (is "?L = ?R")
 proof (cases "transpose xs = []")
   case False
   have "?L = foldr max (map length (transpose xs)) 0"
     by (simp add: foldr_map comp_def)
   also have "... = length (transpose xs ! 0)"
     using False sorted_transpose by (simp add: foldr_max_sorted)
   finally show ?thesis
     using False by (simp add: nth_transpose)
 next
   case True
   hence "filter (\<lambda>x. x \<noteq> []) xs = []"
     by (auto intro!: filter_False simp: transpose_empty)
   thus ?thesis by (simp add: transpose_empty True)
 qed
 
 lemma length_transpose_sorted:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))"
   shows "length (transpose xs) = (if xs = [] then 0 else length (xs ! 0))"
 proof (cases "xs = []")
   case False
   thus ?thesis
     using foldr_max_sorted[OF sorted] False
     unfolding length_transpose foldr_map comp_def
     by simp
 qed simp
 
 lemma nth_nth_transpose_sorted[simp]:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))"
   and i: "i < length (transpose xs)"
   and j: "j < length (filter (\<lambda>ys. i < length ys) xs)"
   shows "transpose xs ! i ! j = xs ! j  ! i"
 using j filter_equals_takeWhile_sorted_rev[OF sorted, of i]
     nth_transpose[OF i] nth_map[OF j]
 by (simp add: takeWhile_nth)
 
 lemma transpose_column_length:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
   shows "length (filter (\<lambda>ys. i < length ys) (transpose xs)) = length (xs ! i)"
 proof -
   have "xs \<noteq> []" using \<open>i < length xs\<close> by auto
   note filter_equals_takeWhile_sorted_rev[OF sorted, simp]
   { fix j assume "j \<le> i"
     note sorted_rev_nth_mono[OF sorted, of j i, simplified, OF this \<open>i < length xs\<close>]
   } note sortedE = this[consumes 1]
 
   have "{j. j < length (transpose xs) \<and> i < length (transpose xs ! j)}
     = {..< length (xs ! i)}"
   proof safe
     fix j
     assume "j < length (transpose xs)" and "i < length (transpose xs ! j)"
     with this(2) nth_transpose[OF this(1)]
     have "i < length (takeWhile (\<lambda>ys. j < length ys) xs)" by simp
     from nth_mem[OF this] takeWhile_nth[OF this]
     show "j < length (xs ! i)" by (auto dest: set_takeWhileD)
   next
     fix j assume "j < length (xs ! i)"
     thus "j < length (transpose xs)"
       using foldr_max_sorted[OF sorted] \<open>xs \<noteq> []\<close> sortedE[OF le0]
       by (auto simp: length_transpose comp_def foldr_map)
 
     have "Suc i \<le> length (takeWhile (\<lambda>ys. j < length ys) xs)"
       using \<open>i < length xs\<close> \<open>j < length (xs ! i)\<close> less_Suc_eq_le
       by (auto intro!: length_takeWhile_less_P_nth dest!: sortedE)
     with nth_transpose[OF \<open>j < length (transpose xs)\<close>]
     show "i < length (transpose xs ! j)" by simp
   qed
   thus ?thesis by (simp add: length_filter_conv_card)
 qed
 
 lemma transpose_column:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))" and "i < length xs"
   shows "map (\<lambda>ys. ys ! i) (filter (\<lambda>ys. i < length ys) (transpose xs))
     = xs ! i" (is "?R = _")
 proof (rule nth_equalityI)
   show length: "length ?R = length (xs ! i)"
     using transpose_column_length[OF assms] by simp
 
   fix j assume j: "j < length ?R"
   note * = less_le_trans[OF this, unfolded length_map, OF length_filter_le]
   from j have j_less: "j < length (xs ! i)" using length by simp
   have i_less_tW: "Suc i \<le> length (takeWhile (\<lambda>ys. Suc j \<le> length ys) xs)"
   proof (rule length_takeWhile_less_P_nth)
     show "Suc i \<le> length xs" using \<open>i < length xs\<close> by simp
     fix k assume "k < Suc i"
     hence "k \<le> i" by auto
     with sorted_rev_nth_mono[OF sorted this] \<open>i < length xs\<close>
     have "length (xs ! i) \<le> length (xs ! k)" by simp
     thus "Suc j \<le> length (xs ! k)" using j_less by simp
   qed
   have i_less_filter: "i < length (filter (\<lambda>ys. j < length ys) xs) "
     unfolding filter_equals_takeWhile_sorted_rev[OF sorted, of j]
     using i_less_tW by (simp_all add: Suc_le_eq)
   from j show "?R ! j = xs ! i ! j"
     unfolding filter_equals_takeWhile_sorted_rev[OF sorted_transpose, of i]
     by (simp add: takeWhile_nth nth_nth_transpose_sorted[OF sorted * i_less_filter])
 qed
 
 lemma transpose_transpose:
   fixes xs :: "'a list list"
   assumes sorted: "sorted (rev (map length xs))"
   shows "transpose (transpose xs) = takeWhile (\<lambda>x. x \<noteq> []) xs" (is "?L = ?R")
 proof -
   have len: "length ?L = length ?R"
     unfolding length_transpose transpose_max_length
     using filter_equals_takeWhile_sorted_rev[OF sorted, of 0]
     by simp
 
   { fix i assume "i < length ?R"
     with less_le_trans[OF _ length_takeWhile_le[of _ xs]]
     have "i < length xs" by simp
   } note * = this
   show ?thesis
     by (rule nth_equalityI)
        (simp_all add: len nth_transpose transpose_column[OF sorted] * takeWhile_nth)
 qed
 
 theorem transpose_rectangle:
   assumes "xs = [] \<Longrightarrow> n = 0"
   assumes rect: "\<And> i. i < length xs \<Longrightarrow> length (xs ! i) = n"
   shows "transpose xs = map (\<lambda> i. map (\<lambda> j. xs ! j ! i) [0..<length xs]) [0..<n]"
     (is "?trans = ?map")
 proof (rule nth_equalityI)
   have "sorted (rev (map length xs))"
     by (auto simp: rev_nth rect sorted_iff_nth_mono)
   from foldr_max_sorted[OF this] assms
   show len: "length ?trans = length ?map"
     by (simp_all add: length_transpose foldr_map comp_def)
   moreover
   { fix i assume "i < n" hence "filter (\<lambda>ys. i < length ys) xs = xs"
       using rect by (auto simp: in_set_conv_nth intro!: filter_True) }
   ultimately show "\<And>i. i < length (transpose xs) \<Longrightarrow> ?trans ! i = ?map ! i"
     by (auto simp: nth_transpose intro: nth_equalityI)
 qed
 
 
-subsubsection \<open>\<open>sorted_list_of_set\<close>\<close>
-
-text\<open>This function maps (finite) linearly ordered sets to sorted
-lists. Warning: in most cases it is not a good idea to convert from
-sets to lists but one should convert in the other direction (via
-\<^const>\<open>set\<close>).\<close>
-
-context linorder
+subsubsection \<open>\<open>sorted_key_list_of_set\<close>\<close>
+
+text\<open>
+  This function maps (finite) linearly ordered sets to sorted lists.
+  The linear order is obtained by a key function that maps the elements of the set to a type
+  that is linearly ordered.
+  Warning: in most cases it is not a good idea to convert from
+  sets to lists but one should convert in the other direction (via \<^const>\<open>set\<close>).
+
+  Note: this is a generalisation of the older \<open>sorted_list_of_set\<close> that is obtained by setting
+  the key function to the identity. Consequently, new theorems should be added to the locale
+  below. They should also be aliased to more convenient names for use with \<open>sorted_list_of_set\<close>
+  as seen further below.
+\<close>
+
+definition (in linorder) sorted_key_list_of_set :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'b list"
+  where "sorted_key_list_of_set f \<equiv> folding_on.F (insort_key f) []"
+
+locale folding_insort_key = lo?: linorder "less_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool" less
+  for less_eq (infix "\<preceq>" 50) and less (infix "\<prec>" 50) +
+  fixes S
+  fixes f :: "'b \<Rightarrow> 'a"
+  assumes inj_on: "inj_on f S"
 begin
 
-definition sorted_list_of_set :: "'a set \<Rightarrow> 'a list" where
-  "sorted_list_of_set = folding.F insort []"
-
-sublocale sorted_list_of_set: folding insort Nil
-rewrites
-  "folding.F insort [] = sorted_list_of_set"
+lemma insort_key_commute:
+  "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> insort_key f y o insort_key f x = insort_key f x o insort_key f y"
+proof(rule ext, goal_cases)
+  case (1 xs)
+  with inj_on show ?case by (induction xs) (auto simp: inj_onD)
+qed
+
+sublocale fold_insort_key: folding_on S "insort_key f" "[]"
+  rewrites "folding_on.F (insort_key f) [] = sorted_key_list_of_set f"
 proof -
-  interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
-  show "folding insort" by standard (fact comp_fun_commute)
-  show "folding.F insort [] = sorted_list_of_set" by (simp only: sorted_list_of_set_def)
-qed
-
-lemma sorted_list_of_set_empty:
-  "sorted_list_of_set {} = []"
-  by (fact sorted_list_of_set.empty)
-
-lemma sorted_list_of_set_insert [simp]:
-  "finite A \<Longrightarrow> sorted_list_of_set (insert x A) = insort x (sorted_list_of_set (A - {x}))"
-  by (fact sorted_list_of_set.insert_remove)
-
-lemma sorted_list_of_set_eq_Nil_iff [simp]:
-  "finite A \<Longrightarrow> sorted_list_of_set A = [] \<longleftrightarrow> A = {}"
-  by (auto simp: sorted_list_of_set.remove)
-
-lemma set_sorted_list_of_set [simp]:
-  "finite A \<Longrightarrow> set (sorted_list_of_set A) = A"
-  by(induct A rule: finite_induct) (simp_all add: set_insort_key)
-
-lemma sorted_sorted_list_of_set [simp]: "sorted (sorted_list_of_set A)"
+  show "folding_on S (insort_key f)"
+    by standard (simp add: insort_key_commute)
+qed (simp add: sorted_key_list_of_set_def)
+
+lemma idem_if_sorted_distinct:
+  assumes "set xs \<subseteq> S" and "sorted (map f xs)" "distinct xs"
+  shows "sorted_key_list_of_set f (set xs) = xs"
+proof(cases "S = {}")
+  case True
+  then show ?thesis using \<open>set xs \<subseteq> S\<close> by auto
+next
+  case False
+  with assms show ?thesis
+  proof(induction xs)
+    case (Cons a xs)
+    with Cons show ?case by (cases xs) auto
+  qed simp
+qed
+
+lemma sorted_key_list_of_set_empty:
+  "sorted_key_list_of_set f {} = []"
+  by (fact fold_insort_key.empty)
+
+lemma sorted_key_list_of_set_insert:
+  assumes "insert x A \<subseteq> S" and "finite A" "x \<notin> A"
+  shows "sorted_key_list_of_set f (insert x A)
+        = insort_key f x (sorted_key_list_of_set f A)"
+  using assms by (fact fold_insort_key.insert)
+
+lemma sorted_key_list_of_set_insert_remove [simp]:
+  assumes "insert x A \<subseteq> S" and "finite A"
+  shows "sorted_key_list_of_set f (insert x A)
+        = insort_key f x (sorted_key_list_of_set f (A - {x}))"
+  using assms by (fact fold_insort_key.insert_remove)
+
+lemma sorted_key_list_of_set_eq_Nil_iff [simp]:
+  assumes "A \<subseteq> S" and "finite A"
+  shows "sorted_key_list_of_set f A = [] \<longleftrightarrow> A = {}"
+  using assms by (auto simp: fold_insort_key.remove)
+
+lemma set_sorted_key_list_of_set [simp]:
+  assumes "A \<subseteq> S" and "finite A"
+  shows "set (sorted_key_list_of_set f A) = A"
+  using assms(2,1)
+  by (induct A rule: finite_induct) (simp_all add: set_insort_key)
+
+lemma sorted_sorted_key_list_of_set [simp]:
+  assumes "A \<subseteq> S"
+  shows "sorted (map f (sorted_key_list_of_set f A))"
 proof (cases "finite A")
-  case True thus ?thesis by(induction A) (simp_all add: sorted_insort)
+  case True thus ?thesis using \<open>A \<subseteq> S\<close>
+    by (induction A) (simp_all add: sorted_insort_key)
 next
   case False thus ?thesis by simp
 qed
 
-lemma distinct_sorted_list_of_set [simp]: "distinct (sorted_list_of_set A)"
+lemma distinct_if_distinct_map: "distinct (map f xs) \<Longrightarrow> distinct xs"
+  using inj_on by (simp add: distinct_map)
+
+lemma distinct_sorted_key_list_of_set [simp]:
+  assumes "A \<subseteq> S"
+  shows "distinct (map f (sorted_key_list_of_set f A))"
 proof (cases "finite A")
-  case True thus ?thesis by(induction A) (simp_all add: distinct_insort)
-next
+  case True thus ?thesis using \<open>A \<subseteq> S\<close> inj_on
+    by (induction A) (force simp: distinct_insort_key dest: inj_onD)+
+  next
   case False thus ?thesis by simp
 qed
 
-lemma length_sorted_list_of_set [simp]: "length (sorted_list_of_set A) = card A"
+lemma length_sorted_key_list_of_set [simp]:
+  assumes "A \<subseteq> S"
+  shows "length (sorted_key_list_of_set f A) = card A"
 proof (cases "finite A")
   case True
-  then show ?thesis 
-    by(metis distinct_card distinct_sorted_list_of_set set_sorted_list_of_set)
+  with assms inj_on show ?thesis
+    using distinct_card[symmetric, OF distinct_sorted_key_list_of_set]
+    by (auto simp: subset_inj_on intro!: card_image)
 qed auto
 
-lemmas sorted_list_of_set = set_sorted_list_of_set sorted_sorted_list_of_set distinct_sorted_list_of_set
-
-lemma sorted_list_of_set_sort_remdups [code]:
-  "sorted_list_of_set (set xs) = sort (remdups xs)"
-proof -
-  interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
-  show ?thesis by (simp add: sorted_list_of_set.eq_fold sort_conv_fold fold_set_fold_remdups)
-qed
-
-lemma sorted_list_of_set_remove:
-  assumes "finite A"
-  shows "sorted_list_of_set (A - {x}) = remove1 x (sorted_list_of_set A)"
+lemmas sorted_key_list_of_set =
+  set_sorted_key_list_of_set sorted_sorted_key_list_of_set distinct_sorted_key_list_of_set
+
+lemma sorted_key_list_of_set_remove:
+  assumes "insert x A \<subseteq> S" and "finite A"
+  shows "sorted_key_list_of_set f (A - {x}) = remove1 x (sorted_key_list_of_set f A)"
 proof (cases "x \<in> A")
-  case False with assms have "x \<notin> set (sorted_list_of_set A)" by simp
+  case False with assms have "x \<notin> set (sorted_key_list_of_set f A)" by simp
   with False show ?thesis by (simp add: remove1_idem)
 next
   case True then obtain B where A: "A = insert x B" by (rule Set.set_insert)
   with assms show ?thesis by simp
 qed
 
-lemma strict_sorted_list_of_set [simp]: "sorted_wrt (<) (sorted_list_of_set A)"
-  by (simp add: strict_sorted_iff)
+lemma strict_sorted_key_list_of_set [simp]:
+  "A \<subseteq> S \<Longrightarrow> sorted_wrt (\<prec>) (map f (sorted_key_list_of_set f A))"
+  by (cases "finite A") (auto simp: strict_sorted_iff subset_inj_on[OF inj_on])
 
 lemma finite_set_strict_sorted:
-  assumes "finite A"
-  obtains l where "sorted_wrt (<) l" "set l = A" "length l = card A"
-  by (metis assms distinct_card distinct_sorted_list_of_set set_sorted_list_of_set strict_sorted_list_of_set)
-
-lemma strict_sorted_equal:
+  assumes "A \<subseteq> S" and "finite A"
+  obtains l where "sorted_wrt (\<prec>) (map f l)" "set l = A" "length l = card A"
+  using assms
+  by (meson length_sorted_key_list_of_set set_sorted_key_list_of_set strict_sorted_key_list_of_set)
+
+lemma (in linorder) strict_sorted_equal:
   assumes "sorted_wrt (<) xs"
-      and "sorted_wrt (<) ys"
-      and "set ys = set xs"
-    shows "ys = xs"
+    and "sorted_wrt (<) ys"
+    and "set ys = set xs"
+  shows "ys = xs"
   using assms
 proof (induction xs arbitrary: ys)
   case (Cons x xs)
   show ?case
   proof (cases ys)
     case Nil
     then show ?thesis
       using Cons.prems by auto 
   next
     case (Cons y ys')
     then have "xs = ys'"
       by (metis Cons.prems list.inject sorted_distinct_set_unique strict_sorted_iff)
     moreover have "x = y"
       using Cons.prems \<open>xs = ys'\<close> local.Cons by fastforce
     ultimately show ?thesis
       using local.Cons by blast
   qed
 qed auto
-
-lemma strict_sorted_equal_Uniq: "\<exists>\<^sub>\<le>\<^sub>1xs. sorted_wrt (<) xs \<and> set xs = A"
+	
+lemma (in linorder) strict_sorted_equal_Uniq: "\<exists>\<^sub>\<le>\<^sub>1xs. sorted_wrt (<) xs \<and> set xs = A"
   by (simp add: Uniq_def strict_sorted_equal)
 
-lemma sorted_list_of_set_inject:
-  assumes "sorted_list_of_set A = sorted_list_of_set B" "finite A" "finite B" 
+lemma sorted_key_list_of_set_inject:
+  assumes "A \<subseteq> S" "B \<subseteq> S"
+  assumes "sorted_key_list_of_set f A = sorted_key_list_of_set f B" "finite A" "finite B" 
   shows "A = B"
-  using assms set_sorted_list_of_set by fastforce
-
-lemma sorted_list_of_set_unique:
-  assumes "finite A"
-  shows "sorted_wrt (<) l \<and> set l = A \<and> length l = card A \<longleftrightarrow> sorted_list_of_set A = l"
-  using assms strict_sorted_equal by force
+  using assms set_sorted_key_list_of_set by metis
+
+lemma sorted_key_list_of_set_unique:
+  assumes "A \<subseteq> S" and "finite A"
+  shows "sorted_wrt (\<prec>) (map f l) \<and> set l = A \<and> length l = card A
+        \<longleftrightarrow> sorted_key_list_of_set f A = l"
+  using assms
+  by (auto simp: strict_sorted_iff card_distinct idem_if_sorted_distinct)
 
 end
 
+context linorder
+begin
+
+definition "sorted_list_of_set \<equiv> sorted_key_list_of_set (\<lambda>x::'a. x)"
+
+text \<open>
+  We abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that result
+  from instantiating the key function to the identity.
+\<close>
+sublocale sorted_list_of_set: folding_insort_key "(\<le>)" "(<)" UNIV "(\<lambda>x. x)"
+  rewrites "sorted_key_list_of_set (\<lambda>x. x) = sorted_list_of_set"
+       and "\<And>xs. map (\<lambda>x. x) xs \<equiv> xs"
+       and "\<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_insort_key (\<le>) (<) UNIV (\<lambda>x. x)"
+    by standard simp
+qed (simp_all add: sorted_list_of_set_def)
+
+text \<open>Alias theorems for backwards compatibility and ease of use.\<close>
+lemmas sorted_list_of_set = sorted_list_of_set.sorted_key_list_of_set and
+       sorted_list_of_set_empty = sorted_list_of_set.sorted_key_list_of_set_empty and
+       sorted_list_of_set_insert = sorted_list_of_set.sorted_key_list_of_set_insert and
+       sorted_list_of_set_insert_remove = sorted_list_of_set.sorted_key_list_of_set_insert_remove and
+       sorted_list_of_set_eq_Nil_iff = sorted_list_of_set.sorted_key_list_of_set_eq_Nil_iff and
+       set_sorted_list_of_set = sorted_list_of_set.set_sorted_key_list_of_set and
+       sorted_sorted_list_of_set = sorted_list_of_set.sorted_sorted_key_list_of_set and
+       distinct_sorted_list_of_set = sorted_list_of_set.distinct_sorted_key_list_of_set and
+       length_sorted_list_of_set = sorted_list_of_set.length_sorted_key_list_of_set and
+       sorted_list_of_set_remove = sorted_list_of_set.sorted_key_list_of_set_remove and
+       strict_sorted_list_of_set = sorted_list_of_set.strict_sorted_key_list_of_set and
+       sorted_list_of_set_inject = sorted_list_of_set.sorted_key_list_of_set_inject and
+       sorted_list_of_set_unique = sorted_list_of_set.sorted_key_list_of_set_unique and
+       finite_set_strict_sorted = sorted_list_of_set.finite_set_strict_sorted
+
+lemma sorted_list_of_set_sort_remdups [code]:
+  "sorted_list_of_set (set xs) = sort (remdups xs)"
+proof -
+  interpret comp_fun_commute insort by (fact comp_fun_commute_insort)
+  show ?thesis
+    by (simp add: sorted_list_of_set.fold_insort_key.eq_fold sort_conv_fold fold_set_fold_remdups)
+qed
+
+end
+
+
 lemma sorted_list_of_set_range [simp]:
   "sorted_list_of_set {m..<n} = [m..<n]"
 by (rule sorted_distinct_set_unique) simp_all
 
 lemma sorted_list_of_set_lessThan_Suc [simp]: 
   "sorted_list_of_set {..<Suc k} = sorted_list_of_set {..<k} @ [k]"
   using le0 lessThan_atLeast0 sorted_list_of_set_range upt_Suc_append by presburger
 
 lemma sorted_list_of_set_atMost_Suc [simp]:
   "sorted_list_of_set {..Suc k} = sorted_list_of_set {..k} @ [Suc k]"
   using lessThan_Suc_atMost sorted_list_of_set_lessThan_Suc by fastforce
 
 lemma sorted_list_of_set_nonempty:
   assumes "finite A" "A \<noteq> {}"
   shows "sorted_list_of_set A = Min A # sorted_list_of_set (A - {Min A})"
-  using assms by (auto simp: less_le simp flip: sorted_list_of_set_unique intro: Min_in)
+  using assms
+  by (auto simp: less_le simp flip: sorted_list_of_set.sorted_key_list_of_set_unique intro: Min_in)
 
 lemma sorted_list_of_set_greaterThanLessThan:
   assumes "Suc i < j" 
     shows "sorted_list_of_set {i<..<j} = Suc i # sorted_list_of_set {Suc i<..<j}"
 proof -
   have "{i<..<j} = insert (Suc i) {Suc i<..<j}"
     using assms by auto
   then show ?thesis
     by (metis assms atLeastSucLessThan_greaterThanLessThan sorted_list_of_set_range upt_conv_Cons)
 qed
 
 lemma sorted_list_of_set_greaterThanAtMost:
   assumes "Suc i \<le> j" 
     shows "sorted_list_of_set {i<..j} = Suc i # sorted_list_of_set {Suc i<..j}"
   using sorted_list_of_set_greaterThanLessThan [of i "Suc j"]
   by (metis assms greaterThanAtMost_def greaterThanLessThan_eq le_imp_less_Suc lessThan_Suc_atMost)
 
 lemma nth_sorted_list_of_set_greaterThanLessThan: 
   "n < j - Suc i \<Longrightarrow> sorted_list_of_set {i<..<j} ! n = Suc (i+n)"
   by (induction n arbitrary: i) (auto simp: sorted_list_of_set_greaterThanLessThan)
 
 lemma nth_sorted_list_of_set_greaterThanAtMost: 
   "n < j - i \<Longrightarrow> sorted_list_of_set {i<..j} ! n = Suc (i+n)"
   using nth_sorted_list_of_set_greaterThanLessThan [of n "Suc j" i]
   by (simp add: greaterThanAtMost_def greaterThanLessThan_eq lessThan_Suc_atMost)
 
 
 subsubsection \<open>\<open>lists\<close>: the list-forming operator over sets\<close>
 
 inductive_set
   lists :: "'a set => 'a list set"
   for A :: "'a set"
 where
     Nil [intro!, simp]: "[] \<in> lists A"
   | Cons [intro!, simp]: "\<lbrakk>a \<in> A; l \<in> lists A\<rbrakk> \<Longrightarrow> a#l \<in> lists A"
 
 inductive_cases listsE [elim!]: "x#l \<in> lists A"
 inductive_cases listspE [elim!]: "listsp A (x # l)"
 
 inductive_simps listsp_simps[code]:
   "listsp A []"
   "listsp A (x # xs)"
 
 lemma listsp_mono [mono]: "A \<le> B \<Longrightarrow> listsp A \<le> listsp B"
 by (rule predicate1I, erule listsp.induct, blast+)
 
 lemmas lists_mono = listsp_mono [to_set]
 
 lemma listsp_infI:
   assumes l: "listsp A l" shows "listsp B l \<Longrightarrow> listsp (inf A B) l" using l
 by induct blast+
 
 lemmas lists_IntI = listsp_infI [to_set]
 
 lemma listsp_inf_eq [simp]: "listsp (inf A B) = inf (listsp A) (listsp B)"
 proof (rule mono_inf [where f=listsp, THEN order_antisym])
   show "mono listsp" by (simp add: mono_def listsp_mono)
   show "inf (listsp A) (listsp B) \<le> listsp (inf A B)" by (blast intro!: listsp_infI)
 qed
 
 lemmas listsp_conj_eq [simp] = listsp_inf_eq [simplified inf_fun_def inf_bool_def]
 
 lemmas lists_Int_eq [simp] = listsp_inf_eq [to_set]
 
 lemma Cons_in_lists_iff[simp]: "x#xs \<in> lists A \<longleftrightarrow> x \<in> A \<and> xs \<in> lists A"
 by auto
 
 lemma append_in_listsp_conv [iff]:
      "(listsp A (xs @ ys)) = (listsp A xs \<and> listsp A ys)"
 by (induct xs) auto
 
 lemmas append_in_lists_conv [iff] = append_in_listsp_conv [to_set]
 
 lemma in_listsp_conv_set: "(listsp A xs) = (\<forall>x \<in> set xs. A x)"
 \<comment> \<open>eliminate \<open>listsp\<close> in favour of \<open>set\<close>\<close>
 by (induct xs) auto
 
 lemmas in_lists_conv_set [code_unfold] = in_listsp_conv_set [to_set]
 
 lemma in_listspD [dest!]: "listsp A xs \<Longrightarrow> \<forall>x\<in>set xs. A x"
 by (rule in_listsp_conv_set [THEN iffD1])
 
 lemmas in_listsD [dest!] = in_listspD [to_set]
 
 lemma in_listspI [intro!]: "\<forall>x\<in>set xs. A x \<Longrightarrow> listsp A xs"
 by (rule in_listsp_conv_set [THEN iffD2])
 
 lemmas in_listsI [intro!] = in_listspI [to_set]
 
 lemma lists_eq_set: "lists A = {xs. set xs \<le> A}"
 by auto
 
 lemma lists_empty [simp]: "lists {} = {[]}"
 by auto
 
 lemma lists_UNIV [simp]: "lists UNIV = UNIV"
 by auto
 
 lemma lists_image: "lists (f`A) = map f ` lists A"
 proof -
   { fix xs have "\<forall>x\<in>set xs. x \<in> f ` A \<Longrightarrow> xs \<in> map f ` lists A"
       by (induct xs) (auto simp del: list.map simp add: list.map[symmetric] intro!: imageI) }
   then show ?thesis by auto
 qed
 
 subsubsection \<open>Inductive definition for membership\<close>
 
 inductive ListMem :: "'a \<Rightarrow> 'a list \<Rightarrow> bool"
 where
     elem:  "ListMem x (x # xs)"
   | insert:  "ListMem x xs \<Longrightarrow> ListMem x (y # xs)"
 
 lemma ListMem_iff: "(ListMem x xs) = (x \<in> set xs)"
 proof
   show "ListMem x xs \<Longrightarrow> x \<in> set xs"
     by (induct set: ListMem) auto
   show "x \<in> set xs \<Longrightarrow> ListMem x xs"
     by (induct xs) (auto intro: ListMem.intros)
 qed
 
 
 subsubsection \<open>Lists as Cartesian products\<close>
 
 text\<open>\<open>set_Cons A Xs\<close>: the set of lists with head drawn from
 \<^term>\<open>A\<close> and tail drawn from \<^term>\<open>Xs\<close>.\<close>
 
 definition set_Cons :: "'a set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" where
 "set_Cons A XS = {z. \<exists>x xs. z = x # xs \<and> x \<in> A \<and> xs \<in> XS}"
 
 lemma set_Cons_sing_Nil [simp]: "set_Cons A {[]} = (%x. [x])`A"
 by (auto simp add: set_Cons_def)
 
 text\<open>Yields the set of lists, all of the same length as the argument and
 with elements drawn from the corresponding element of the argument.\<close>
 
 primrec listset :: "'a set list \<Rightarrow> 'a list set" where
 "listset [] = {[]}" |
 "listset (A # As) = set_Cons A (listset As)"
 
 
 subsection \<open>Relations on Lists\<close>
 
 subsubsection \<open>Length Lexicographic Ordering\<close>
 
 text\<open>These orderings preserve well-foundedness: shorter lists
   precede longer lists. These ordering are not used in dictionaries.\<close>
 
 primrec \<comment> \<open>The lexicographic ordering for lists of the specified length\<close>
   lexn :: "('a \<times> 'a) set \<Rightarrow> nat \<Rightarrow> ('a list \<times> 'a list) set" where
 "lexn r 0 = {}" |
 "lexn r (Suc n) =
   (map_prod (%(x, xs). x#xs) (%(x, xs). x#xs) ` (r <*lex*> lexn r n)) Int
   {(xs, ys). length xs = Suc n \<and> length ys = Suc n}"
 
 definition lex :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
 "lex r = (\<Union>n. lexn r n)" \<comment> \<open>Holds only between lists of the same length\<close>
 
 definition lenlex :: "('a \<times> 'a) set => ('a list \<times> 'a list) set" where
 "lenlex r = inv_image (less_than <*lex*> lex r) (\<lambda>xs. (length xs, xs))"
         \<comment> \<open>Compares lists by their length and then lexicographically\<close>
 
 lemma wf_lexn: assumes "wf r" shows "wf (lexn r n)"
 proof (induct n)
   case (Suc n)
   have inj: "inj (\<lambda>(x, xs). x # xs)"
     using assms by (auto simp: inj_on_def)
   have wf: "wf (map_prod (\<lambda>(x, xs). x # xs) (\<lambda>(x, xs). x # xs) ` (r <*lex*> lexn r n))"
     by (simp add: Suc.hyps assms wf_lex_prod wf_map_prod_image [OF _ inj])
   then show ?case
     by (rule wf_subset) auto
 qed auto
 
 lemma lexn_length:
   "(xs, ys) \<in> lexn r n \<Longrightarrow> length xs = n \<and> length ys = n"
   by (induct n arbitrary: xs ys) auto
 
 lemma wf_lex [intro!]: 
   assumes "wf r" shows "wf (lex r)"
   unfolding lex_def
 proof (rule wf_UN)
   show "wf (lexn r i)" for i
     by (simp add: assms wf_lexn)
   show "\<And>i j. lexn r i \<noteq> lexn r j \<Longrightarrow> Domain (lexn r i) \<inter> Range (lexn r j) = {}"
     by (metis DomainE Int_emptyI RangeE lexn_length)
 qed
 
 lemma lexn_conv:
   "lexn r n =
     {(xs,ys). length xs = n \<and> length ys = n \<and>
     (\<exists>xys x y xs' ys'. xs= xys @ x#xs' \<and> ys= xys @ y # ys' \<and> (x, y) \<in> r)}"
 proof (induction n)
   case (Suc n)
   then show ?case
     apply (simp add: image_Collect lex_prod_def, safe, blast)
      apply (rule_tac x = "ab # xys" in exI, simp)
     apply (case_tac xys; force)
     done
 qed auto
 
 text\<open>By Mathias Fleury:\<close>
 proposition lexn_transI:
   assumes "trans r" shows "trans (lexn r n)"
 unfolding trans_def
 proof (intro allI impI)
   fix as bs cs
   assume asbs: "(as, bs) \<in> lexn r n" and bscs: "(bs, cs) \<in> lexn r n"
   obtain abs a b as' bs' where
     n: "length as = n" and "length bs = n" and
     as: "as = abs @ a # as'" and
     bs: "bs = abs @ b # bs'" and
     abr: "(a, b) \<in> r"
     using asbs unfolding lexn_conv by blast
   obtain bcs b' c' cs' bs' where
     n': "length cs = n" and "length bs = n" and
     bs': "bs = bcs @ b' # bs'" and
     cs: "cs = bcs @ c' # cs'" and
     b'c'r: "(b', c') \<in> r"
     using bscs unfolding lexn_conv by blast
   consider (le) "length bcs < length abs"
     | (eq) "length bcs = length abs"
     | (ge) "length bcs > length abs" by linarith
   thus "(as, cs) \<in> lexn r n"
   proof cases
     let ?k = "length bcs"
     case le
     hence "as ! ?k = bs ! ?k" unfolding as bs by (simp add: nth_append)
     hence "(as ! ?k, cs ! ?k) \<in> r" using b'c'r unfolding bs' cs by auto
     moreover
     have "length bcs < length as" using le unfolding as by simp
     from id_take_nth_drop[OF this]
     have "as = take ?k as @ as ! ?k # drop (Suc ?k) as" .
     moreover
     have "length bcs < length cs" unfolding cs by simp
     from id_take_nth_drop[OF this]
     have "cs = take ?k cs @ cs ! ?k # drop (Suc ?k) cs" .
     moreover have "take ?k as = take ?k cs"
       using le arg_cong[OF bs, of "take (length bcs)"]
       unfolding cs as bs' by auto
     ultimately show ?thesis using n n' unfolding lexn_conv by auto
   next
     let ?k = "length abs"
     case ge
     hence "bs ! ?k = cs ! ?k" unfolding bs' cs by (simp add: nth_append)
     hence "(as ! ?k, cs ! ?k) \<in> r" using abr unfolding as bs by auto
     moreover
     have "length abs < length as" using ge unfolding as by simp
     from id_take_nth_drop[OF this]
     have "as = take ?k as @ as ! ?k # drop (Suc ?k) as" .
     moreover have "length abs < length cs" using n n' unfolding as by simp
     from id_take_nth_drop[OF this]
     have "cs = take ?k cs @ cs ! ?k # drop (Suc ?k) cs" .
     moreover have "take ?k as = take ?k cs"
       using ge arg_cong[OF bs', of "take (length abs)"]
       unfolding cs as bs by auto
     ultimately show ?thesis using n n' unfolding lexn_conv by auto
   next
     let ?k = "length abs"
     case eq
     hence *: "abs = bcs" "b = b'" using bs bs' by auto
     hence "(a, c') \<in> r"
       using abr b'c'r assms unfolding trans_def by blast
     with * show ?thesis using n n' unfolding lexn_conv as bs cs by auto
   qed
 qed
 
 corollary lex_transI:
     assumes "trans r" shows "trans (lex r)"
   using lexn_transI [OF assms]
   by (clarsimp simp add: lex_def trans_def) (metis lexn_length)
 
 lemma lex_conv:
   "lex r =
     {(xs,ys). length xs = length ys \<and>
     (\<exists>xys x y xs' ys'. xs = xys @ x # xs' \<and> ys = xys @ y # ys' \<and> (x, y) \<in> r)}"
 by (force simp add: lex_def lexn_conv)
 
 lemma wf_lenlex [intro!]: "wf r \<Longrightarrow> wf (lenlex r)"
 by (unfold lenlex_def) blast
 
 lemma lenlex_conv:
     "lenlex r = {(xs,ys). length xs < length ys \<or>
                  length xs = length ys \<and> (xs, ys) \<in> lex r}"
   by (auto simp add: lenlex_def Id_on_def lex_prod_def inv_image_def)
 
 lemma total_lenlex:
   assumes "total r"
   shows "total (lenlex r)"
 proof -
   have "(xs,ys) \<in> lexn r (length xs) \<or> (ys,xs) \<in> lexn r (length xs)"
     if "xs \<noteq> ys" and len: "length xs = length ys" for xs ys
   proof -
     obtain pre x xs' y ys' where "x\<noteq>y" and xs: "xs = pre @ [x] @ xs'" and ys: "ys = pre @ [y] @ys'"
       by (meson len \<open>xs \<noteq> ys\<close> same_length_different) 
     then consider "(x,y) \<in> r" | "(y,x) \<in> r"
       by (meson UNIV_I assms total_on_def)
     then show ?thesis
     by cases (use len in \<open>(force simp add: lexn_conv xs ys)+\<close>)
 qed
   then show ?thesis
     by (fastforce simp: lenlex_def total_on_def lex_def)
 qed
 
 lemma lenlex_transI [intro]: "trans r \<Longrightarrow> trans (lenlex r)"
   unfolding lenlex_def
   by (meson lex_transI trans_inv_image trans_less_than trans_lex_prod)
 
 lemma Nil_notin_lex [iff]: "([], ys) \<notin> lex r"
   by (simp add: lex_conv)
 
 lemma Nil2_notin_lex [iff]: "(xs, []) \<notin> lex r"
   by (simp add:lex_conv)
 
 lemma Cons_in_lex [simp]:
   "(x # xs, y # ys) \<in> lex r \<longleftrightarrow> (x, y) \<in> r \<and> length xs = length ys \<or> x = y \<and> (xs, ys) \<in> lex r"
  (is "?lhs = ?rhs")
 proof
   assume ?lhs then show ?rhs
     by (simp add: lex_conv) (metis hd_append list.sel(1) list.sel(3) tl_append2)
 next
   assume ?rhs then show ?lhs
     by (simp add: lex_conv) (blast intro: Cons_eq_appendI)
 qed
 
 lemma Nil_lenlex_iff1 [simp]: "([], ns) \<in> lenlex r \<longleftrightarrow> ns \<noteq> []" 
   and Nil_lenlex_iff2 [simp]: "(ns,[]) \<notin> lenlex r"
   by (auto simp: lenlex_def)
 
 lemma Cons_lenlex_iff: 
   "((m # ms, n # ns) \<in> lenlex r) \<longleftrightarrow> 
     length ms < length ns 
   \<or> length ms = length ns \<and> (m,n) \<in> r 
   \<or> (m = n \<and> (ms,ns) \<in> lenlex r)"
   by (auto simp: lenlex_def)
 
 lemma lenlex_irreflexive: "(\<And>x. (x,x) \<notin> r) \<Longrightarrow> (xs,xs) \<notin> lenlex r"
   by (induction xs) (auto simp add: Cons_lenlex_iff)
 
 lemma lenlex_trans:
     "\<lbrakk>(x,y) \<in> lenlex r; (y,z) \<in> lenlex r; trans r\<rbrakk> \<Longrightarrow> (x,z) \<in> lenlex r"
   by (meson lenlex_transI transD)
 
 lemma lenlex_length: "(ms, ns) \<in> lenlex r \<Longrightarrow> length ms \<le> length ns"
   by (auto simp: lenlex_def)
 
 lemma lex_append_rightI:
   "(xs, ys) \<in> lex r \<Longrightarrow> length vs = length us \<Longrightarrow> (xs @ us, ys @ vs) \<in> lex r"
   by (fastforce simp: lex_def lexn_conv)
 
 lemma lex_append_leftI:
   "(ys, zs) \<in> lex r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lex r"
   by (induct xs) auto
 
 lemma lex_append_leftD:
   "\<forall>x. (x,x) \<notin> r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lex r \<Longrightarrow> (ys, zs) \<in> lex r"
   by (induct xs) auto
 
 lemma lex_append_left_iff:
   "\<forall>x. (x,x) \<notin> r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lex r \<longleftrightarrow> (ys, zs) \<in> lex r"
   by(metis lex_append_leftD lex_append_leftI)
 
 lemma lex_take_index:
   assumes "(xs, ys) \<in> lex r"
   obtains i where "i < length xs" and "i < length ys" and "take i xs = take i ys"
     and "(xs ! i, ys ! i) \<in> r"
 proof -
   obtain n us x xs' y ys' where "(xs, ys) \<in> lexn r n" and "length xs = n" and "length ys = n"
     and "xs = us @ x # xs'" and "ys = us @ y # ys'" and "(x, y) \<in> r"
     using assms by (fastforce simp: lex_def lexn_conv)
   then show ?thesis by (intro that [of "length us"]) auto
 qed
 
 lemma irrefl_lex: "irrefl r \<Longrightarrow> irrefl (lex r)"
   by (meson irrefl_def lex_take_index)
 
 lemma lexl_not_refl [simp]: "irrefl r \<Longrightarrow> (x,x) \<notin> lex r"
   by (meson irrefl_def lex_take_index)
 
 
 subsubsection \<open>Lexicographic Ordering\<close>
 
 text \<open>Classical lexicographic ordering on lists, ie. "a" < "ab" < "b".
     This ordering does \emph{not} preserve well-foundedness.
      Author: N. Voelker, March 2005.\<close>
 
 definition lexord :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
 "lexord r = {(x,y). \<exists> a v. y = x @ a # v \<or>
             (\<exists> u a b v w. (a,b) \<in> r \<and> x = u @ (a # v) \<and> y = u @ (b # w))}"
 
 lemma lexord_Nil_left[simp]:  "([],y) \<in> lexord r = (\<exists> a x. y = a # x)"
 by (unfold lexord_def, induct_tac y, auto)
 
 lemma lexord_Nil_right[simp]: "(x,[]) \<notin> lexord r"
 by (unfold lexord_def, induct_tac x, auto)
 
 lemma lexord_cons_cons[simp]:
   "(a # x, b # y) \<in> lexord r \<longleftrightarrow> (a,b)\<in> r \<or> (a = b \<and> (x,y)\<in> lexord r)"  (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     apply (simp add: lexord_def)
     apply (metis hd_append list.sel(1) list.sel(3) tl_append2)
     done
 qed (auto simp add: lexord_def; (blast | meson Cons_eq_appendI))
 
 lemmas lexord_simps = lexord_Nil_left lexord_Nil_right lexord_cons_cons
 
 lemma lexord_same_pref_iff:
   "(xs @ ys, xs @ zs) \<in> lexord r \<longleftrightarrow> (\<exists>x \<in> set xs. (x,x) \<in> r) \<or> (ys, zs) \<in> lexord r"
 by(induction xs) auto
 
 lemma lexord_same_pref_if_irrefl[simp]:
   "irrefl r \<Longrightarrow> (xs @ ys, xs @ zs) \<in> lexord r \<longleftrightarrow> (ys, zs) \<in> lexord r"
 by (simp add: irrefl_def lexord_same_pref_iff)
 
 lemma lexord_append_rightI: "\<exists> b z. y = b # z \<Longrightarrow> (x, x @ y) \<in> lexord r"
 by (metis append_Nil2 lexord_Nil_left lexord_same_pref_iff)
 
 lemma lexord_append_left_rightI:
   "(a,b) \<in> r \<Longrightarrow> (u @ a # x, u @ b # y) \<in> lexord r"
 by (simp add: lexord_same_pref_iff)
 
 lemma lexord_append_leftI: "(u,v) \<in> lexord r \<Longrightarrow> (x @ u, x @ v) \<in> lexord r"
 by (simp add: lexord_same_pref_iff)
 
 lemma lexord_append_leftD:
   "\<lbrakk>(x @ u, x @ v) \<in> lexord r; (\<forall>a. (a,a) \<notin> r) \<rbrakk> \<Longrightarrow> (u,v) \<in> lexord r"
 by (simp add: lexord_same_pref_iff)
 
 lemma lexord_take_index_conv:
    "((x,y) \<in> lexord r) =
     ((length x < length y \<and> take (length x) y = x) \<or>
      (\<exists>i. i < min(length x)(length y) \<and> take i x = take i y \<and> (x!i,y!i) \<in> r))"
 proof -
   have "(\<exists>a v. y = x @ a # v) = (length x < length y \<and> take (length x) y = x)"
     by (metis Cons_nth_drop_Suc append_eq_conv_conj drop_all list.simps(3) not_le)
   moreover
   have "(\<exists>u a b. (a, b) \<in> r \<and> (\<exists>v. x = u @ a # v) \<and> (\<exists>w. y = u @ b # w)) =
         (\<exists>i<length x. i < length y \<and> take i x = take i y \<and> (x ! i, y ! i) \<in> r)"
     apply safe
     using less_iff_Suc_add apply auto[1]
     by (metis id_take_nth_drop)
   ultimately show ?thesis
     by (auto simp: lexord_def Let_def)
 qed
 
 \<comment> \<open>lexord is extension of partial ordering List.lex\<close>
 lemma lexord_lex: "(x,y) \<in> lex r = ((x,y) \<in> lexord r \<and> length x = length y)"
 proof (induction x arbitrary: y)
   case (Cons a x y) then show ?case
     by (cases y) (force+)
 qed auto
 
 lemma lexord_sufI:
   assumes "(u,w) \<in> lexord r" "length w \<le> length u"
   shows "(u@v,w@z) \<in> lexord r"
 proof-
   from leD[OF assms(2)] assms(1)[unfolded lexord_take_index_conv[of u w r] min_absorb2[OF assms(2)]]
   obtain i where "take i u = take i w" and "(u!i,w!i) \<in> r" and "i < length w"
     by blast   
   hence "((u@v)!i, (w@z)!i) \<in> r"
     unfolding nth_append using less_le_trans[OF \<open>i < length w\<close> assms(2)] \<open>(u!i,w!i) \<in> r\<close>
     by presburger
   moreover have "i < min (length (u@v)) (length (w@z))"
     using assms(2) \<open>i < length w\<close> by simp
   moreover have "take i (u@v) = take i (w@z)"
     using assms(2) \<open>i < length w\<close> \<open>take i u = take i w\<close> by simp 
   ultimately show ?thesis
     using lexord_take_index_conv by blast
 qed
 
 lemma lexord_sufE: 
   assumes "(xs@zs,ys@qs) \<in> lexord r" "xs \<noteq> ys" "length xs = length ys" "length zs = length qs"
   shows "(xs,ys) \<in> lexord r"
 proof-
   obtain i where "i < length (xs@zs)" and "i < length (ys@qs)" and "take i (xs@zs) = take i (ys@qs)"
   and "((xs@zs) ! i, (ys@qs) ! i) \<in> r"
     using assms(1) lex_take_index[unfolded lexord_lex,of "xs @ zs" "ys @ qs" r]
       length_append[of xs zs, unfolded assms(3,4), folded length_append[of ys qs]]
     by blast
   have "length (take i xs) = length (take i ys)"
     by (simp add: assms(3))
   have "i < length xs"
     using assms(2,3) le_less_linear take_all[of xs i] take_all[of ys i]
       \<open>take i (xs @ zs) = take i (ys @ qs)\<close> append_eq_append_conv take_append
     by metis
   hence "(xs ! i, ys ! i) \<in> r"
     using \<open>((xs @ zs) ! i, (ys @ qs) ! i) \<in> r\<close> assms(3) by (simp add: nth_append)
   moreover have "take i xs = take i ys"
     using assms(3) \<open>take i (xs @ zs) = take i (ys @ qs)\<close> by auto
   ultimately show ?thesis
     unfolding lexord_take_index_conv using \<open>i < length xs\<close> assms(3) by fastforce
 qed
 
 lemma lexord_irreflexive: "\<forall>x. (x,x) \<notin> r \<Longrightarrow> (xs,xs) \<notin> lexord r"
 by (induct xs) auto
 
 text\<open>By Ren\'e Thiemann:\<close>
 lemma lexord_partial_trans:
   "(\<And>x y z. x \<in> set xs \<Longrightarrow> (x,y) \<in> r \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> (x,z) \<in> r)
    \<Longrightarrow>  (xs,ys) \<in> lexord r  \<Longrightarrow>  (ys,zs) \<in> lexord r \<Longrightarrow>  (xs,zs) \<in> lexord r"
 proof (induct xs arbitrary: ys zs)
   case Nil
   from Nil(3) show ?case unfolding lexord_def by (cases zs, auto)
 next
   case (Cons x xs yys zzs)
   from Cons(3) obtain y ys where yys: "yys = y # ys" unfolding lexord_def
     by (cases yys, auto)
   note Cons = Cons[unfolded yys]
   from Cons(3) have one: "(x,y) \<in> r \<or> x = y \<and> (xs,ys) \<in> lexord r" by auto
   from Cons(4) obtain z zs where zzs: "zzs = z # zs" unfolding lexord_def
     by (cases zzs, auto)
   note Cons = Cons[unfolded zzs]
   from Cons(4) have two: "(y,z) \<in> r \<or> y = z \<and> (ys,zs) \<in> lexord r" by auto
   {
     assume "(xs,ys) \<in> lexord r" and "(ys,zs) \<in> lexord r"
     from Cons(1)[OF _ this] Cons(2)
     have "(xs,zs) \<in> lexord r" by auto
   } note ind1 = this
   {
     assume "(x,y) \<in> r" and "(y,z) \<in> r"
     from Cons(2)[OF _ this] have "(x,z) \<in> r" by auto
   } note ind2 = this
   from one two ind1 ind2
   have "(x,z) \<in> r \<or> x = z \<and> (xs,zs) \<in> lexord r" by blast
   thus ?case unfolding zzs by auto
 qed
 
 lemma lexord_trans:
   "\<lbrakk> (x, y) \<in> lexord r; (y, z) \<in> lexord r; trans r \<rbrakk> \<Longrightarrow> (x, z) \<in> lexord r"
   by(auto simp: trans_def intro:lexord_partial_trans)
 
 lemma lexord_transI:  "trans r \<Longrightarrow> trans (lexord r)"
   by (meson lexord_trans transI)
 
 lemma total_lexord: "total r \<Longrightarrow> total (lexord r)"
   unfolding total_on_def
 proof clarsimp
   fix x y
   assume "\<forall>x y. x \<noteq> y \<longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r"
     and "(x::'a list) \<noteq> y"
     and "(y, x) \<notin> lexord r"
   then
   show "(x, y) \<in> lexord r"
   proof (induction x arbitrary: y)
     case Nil
     then show ?case
       by (metis lexord_Nil_left list.exhaust)
   next
     case (Cons a x y) then show ?case
       by (cases y) (force+)
   qed
 qed
 
 corollary lexord_linear: "(\<forall>a b. (a,b) \<in> r \<or> a = b \<or> (b,a) \<in> r) \<Longrightarrow> (x,y) \<in> lexord r \<or> x = y \<or> (y,x) \<in> lexord r"
   using total_lexord by (metis UNIV_I total_on_def) 
 
 lemma lexord_irrefl:
   "irrefl R \<Longrightarrow> irrefl (lexord R)"
 by (simp add: irrefl_def lexord_irreflexive)
 
 lemma lexord_asym:
   assumes "asym R"
   shows "asym (lexord R)"
 proof 
   fix xs ys
   assume "(xs, ys) \<in> lexord R"
   then show "(ys, xs) \<notin> lexord R"
   proof (induct xs arbitrary: ys)
     case Nil
     then show ?case by simp
   next
     case (Cons x xs)
     then obtain z zs where ys: "ys = z # zs" by (cases ys) auto
     with assms Cons show ?case by (auto elim: asym.cases)
   qed
 qed
 
 lemma lexord_asymmetric:
   assumes "asym R"
   assumes hyp: "(a, b) \<in> lexord R"
   shows "(b, a) \<notin> lexord R"
 proof -
   from \<open>asym R\<close> have "asym (lexord R)" by (rule lexord_asym)
   then show ?thesis by (rule asym.cases) (auto simp add: hyp)
 qed
 
 lemma asym_lex: "asym R \<Longrightarrow> asym (lex R)"
   by (meson asym.simps irrefl_lex lexord_asym lexord_lex)
 
 lemma asym_lenlex: "asym R \<Longrightarrow> asym (lenlex R)"
   by (simp add: lenlex_def asym_inv_image asym_less_than asym_lex asym_lex_prod)
 
 lemma lenlex_append1:
   assumes len: "(us,xs) \<in> lenlex R" and eq: "length vs = length ys" 
   shows "(us @ vs, xs @ ys) \<in> lenlex R"
   using len
 proof (induction us)
   case Nil
   then show ?case 
     by (simp add: lenlex_def eq)
 next
   case (Cons u us)
   with lex_append_rightI show ?case
     by (fastforce simp add: lenlex_def eq)
 qed
 
 lemma lenlex_append2 [simp]:
   assumes "irrefl R"
   shows "(us @ xs, us @ ys) \<in> lenlex R \<longleftrightarrow> (xs, ys) \<in> lenlex R"
 proof (induction us)
   case Nil
   then show ?case 
     by (simp add: lenlex_def)
 next
   case (Cons u us)
   with assms show ?case
     by (auto simp: lenlex_def irrefl_def)
 qed
 
 text \<open>
   Predicate version of lexicographic order integrated with Isabelle's order type classes.
   Author: Andreas Lochbihler
 \<close>
 
 context ord
 begin
 
 context
   notes [[inductive_internals]]
 begin
 
 inductive lexordp :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
 where
   Nil: "lexordp [] (y # ys)"
 | Cons: "x < y \<Longrightarrow> lexordp (x # xs) (y # ys)"
 | Cons_eq:
   "\<lbrakk> \<not> x < y; \<not> y < x; lexordp xs ys \<rbrakk> \<Longrightarrow> lexordp (x # xs) (y # ys)"
 
 end
 
 lemma lexordp_simps [simp]:
   "lexordp [] ys = (ys \<noteq> [])"
   "lexordp xs [] = False"
   "lexordp (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp xs ys"
 by(subst lexordp.simps, fastforce simp add: neq_Nil_conv)+
 
 inductive lexordp_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   Nil: "lexordp_eq [] ys"
 | Cons: "x < y \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
 | Cons_eq: "\<lbrakk> \<not> x < y; \<not> y < x; lexordp_eq xs ys \<rbrakk> \<Longrightarrow> lexordp_eq (x # xs) (y # ys)"
 
 lemma lexordp_eq_simps [simp]:
   "lexordp_eq [] ys = True"
   "lexordp_eq xs [] \<longleftrightarrow> xs = []"
   "lexordp_eq (x # xs) [] = False"
   "lexordp_eq (x # xs) (y # ys) \<longleftrightarrow> x < y \<or> \<not> y < x \<and> lexordp_eq xs ys"
 by(subst lexordp_eq.simps, fastforce)+
 
 lemma lexordp_append_rightI: "ys \<noteq> Nil \<Longrightarrow> lexordp xs (xs @ ys)"
 by(induct xs)(auto simp add: neq_Nil_conv)
 
 lemma lexordp_append_left_rightI: "x < y \<Longrightarrow> lexordp (us @ x # xs) (us @ y # ys)"
 by(induct us) auto
 
 lemma lexordp_eq_refl: "lexordp_eq xs xs"
 by(induct xs) simp_all
 
 lemma lexordp_append_leftI: "lexordp us vs \<Longrightarrow> lexordp (xs @ us) (xs @ vs)"
 by(induct xs) auto
 
 lemma lexordp_append_leftD: "\<lbrakk> lexordp (xs @ us) (xs @ vs); \<forall>a. \<not> a < a \<rbrakk> \<Longrightarrow> lexordp us vs"
 by(induct xs) auto
 
 lemma lexordp_irreflexive:
   assumes irrefl: "\<forall>x. \<not> x < x"
   shows "\<not> lexordp xs xs"
 proof
   assume "lexordp xs xs"
   thus False by(induct xs ys\<equiv>xs)(simp_all add: irrefl)
 qed
 
 lemma lexordp_into_lexordp_eq:
   "lexordp xs ys \<Longrightarrow> lexordp_eq xs ys"
 by (induction rule: lexordp.induct) simp_all
 
 lemma lexordp_eq_pref: "lexordp_eq u (u @ v)"
 by (metis append_Nil2 lexordp_append_rightI lexordp_eq_refl lexordp_into_lexordp_eq)
 
 end
 
 declare ord.lexordp_simps [simp, code]
 declare ord.lexordp_eq_simps [code, simp]
 
 context order
 begin
 
 lemma lexordp_antisym:
   assumes "lexordp xs ys" "lexordp ys xs"
   shows False
   using assms by induct auto
 
 lemma lexordp_irreflexive': "\<not> lexordp xs xs"
 by(rule lexordp_irreflexive) simp
 
 end
 
 context linorder begin
 
 lemma lexordp_cases [consumes 1, case_names Nil Cons Cons_eq, cases pred: lexordp]:
   assumes "lexordp xs ys"
   obtains (Nil) y ys' where "xs = []" "ys = y # ys'"
   | (Cons) x xs' y ys' where "xs = x # xs'" "ys = y # ys'" "x < y"
   | (Cons_eq) x xs' ys' where "xs = x # xs'" "ys = x # ys'" "lexordp xs' ys'"
 using assms by cases (fastforce simp add: not_less_iff_gr_or_eq)+
 
 lemma lexordp_induct [consumes 1, case_names Nil Cons Cons_eq, induct pred: lexordp]:
   assumes major: "lexordp xs ys"
   and Nil: "\<And>y ys. P [] (y # ys)"
   and Cons: "\<And>x xs y ys. x < y \<Longrightarrow> P (x # xs) (y # ys)"
   and Cons_eq: "\<And>x xs ys. \<lbrakk> lexordp xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x # xs) (x # ys)"
   shows "P xs ys"
 using major by induct (simp_all add: Nil Cons not_less_iff_gr_or_eq Cons_eq)
 
 lemma lexordp_iff:
   "lexordp xs ys \<longleftrightarrow> (\<exists>x vs. ys = xs @ x # vs) \<or> (\<exists>us a b vs ws. a < b \<and> xs = us @ a # vs \<and> ys = us @ b # ws)"
   (is "?lhs = ?rhs")
 proof
   assume ?lhs thus ?rhs
   proof induct
     case Cons_eq thus ?case by simp (metis append.simps(2))
   qed(fastforce intro: disjI2 del: disjCI intro: exI[where x="[]"])+
 next
   assume ?rhs thus ?lhs
     by(auto intro: lexordp_append_leftI[where us="[]", simplified] lexordp_append_leftI)
 qed
 
 lemma lexordp_conv_lexord:
   "lexordp xs ys \<longleftrightarrow> (xs, ys) \<in> lexord {(x, y). x < y}"
 by(simp add: lexordp_iff lexord_def)
 
 lemma lexordp_eq_antisym:
   assumes "lexordp_eq xs ys" "lexordp_eq ys xs"
   shows "xs = ys"
 using assms by induct simp_all
 
 lemma lexordp_eq_trans:
   assumes "lexordp_eq xs ys" and "lexordp_eq ys zs"
   shows "lexordp_eq xs zs"
   using assms
   by (induct arbitrary: zs) (case_tac zs; auto)+
 
 lemma lexordp_trans:
   assumes "lexordp xs ys" "lexordp ys zs"
   shows "lexordp xs zs"
   using assms
   by (induct arbitrary: zs) (case_tac zs; auto)+
 
 lemma lexordp_linear: "lexordp xs ys \<or> xs = ys \<or> lexordp ys xs"
   by(induct xs arbitrary: ys; case_tac ys; fastforce)
 
 lemma lexordp_conv_lexordp_eq: "lexordp xs ys \<longleftrightarrow> lexordp_eq xs ys \<and> \<not> lexordp_eq ys xs"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   hence "\<not> lexordp_eq ys xs" by induct simp_all
   with \<open>?lhs\<close> show ?rhs by (simp add: lexordp_into_lexordp_eq)
 next
   assume ?rhs
   hence "lexordp_eq xs ys" "\<not> lexordp_eq ys xs" by simp_all
   thus ?lhs by induct simp_all
 qed
 
 lemma lexordp_eq_conv_lexord: "lexordp_eq xs ys \<longleftrightarrow> xs = ys \<or> lexordp xs ys"
 by(auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl dest: lexordp_eq_antisym)
 
 lemma lexordp_eq_linear: "lexordp_eq xs ys \<or> lexordp_eq ys xs"
   by (induct xs arbitrary: ys) (case_tac ys; auto)+
 
 lemma lexordp_linorder: "class.linorder lexordp_eq lexordp"
   by unfold_locales
      (auto simp add: lexordp_conv_lexordp_eq lexordp_eq_refl lexordp_eq_antisym intro: lexordp_eq_trans del: disjCI intro: lexordp_eq_linear)
 
 end
 
 lemma sorted_insort_is_snoc: "sorted xs \<Longrightarrow> \<forall>x \<in> set xs. a \<ge> x \<Longrightarrow> insort a xs = xs @ [a]"
  by (induct xs) (auto dest!: insort_is_Cons)
 
 
 subsubsection \<open>Lexicographic combination of measure functions\<close>
 
 text \<open>These are useful for termination proofs\<close>
 
 definition "measures fs = inv_image (lex less_than) (%a. map (%f. f a) fs)"
 
 lemma wf_measures[simp]: "wf (measures fs)"
 unfolding measures_def
 by blast
 
 lemma in_measures[simp]:
   "(x, y) \<in> measures [] = False"
   "(x, y) \<in> measures (f # fs)
          = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"
 unfolding measures_def
 by auto
 
 lemma measures_less: "f x < f y \<Longrightarrow> (x, y) \<in> measures (f#fs)"
 by simp
 
 lemma measures_lesseq: "f x \<le> f y \<Longrightarrow> (x, y) \<in> measures fs \<Longrightarrow> (x, y) \<in> measures (f#fs)"
 by auto
 
 
 subsubsection \<open>Lifting Relations to Lists: one element\<close>
 
 definition listrel1 :: "('a \<times> 'a) set \<Rightarrow> ('a list \<times> 'a list) set" where
 "listrel1 r = {(xs,ys).
    \<exists>us z z' vs. xs = us @ z # vs \<and> (z,z') \<in> r \<and> ys = us @ z' # vs}"
 
 lemma listrel1I:
   "\<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow>
   (xs, ys) \<in> listrel1 r"
 unfolding listrel1_def by auto
 
 lemma listrel1E:
   "\<lbrakk> (xs, ys) \<in> listrel1 r;
      !!x y us vs. \<lbrakk> (x, y) \<in> r;  xs = us @ x # vs;  ys = us @ y # vs \<rbrakk> \<Longrightarrow> P
    \<rbrakk> \<Longrightarrow> P"
 unfolding listrel1_def by auto
 
 lemma not_Nil_listrel1 [iff]: "([], xs) \<notin> listrel1 r"
 unfolding listrel1_def by blast
 
 lemma not_listrel1_Nil [iff]: "(xs, []) \<notin> listrel1 r"
 unfolding listrel1_def by blast
 
 lemma Cons_listrel1_Cons [iff]:
   "(x # xs, y # ys) \<in> listrel1 r \<longleftrightarrow>
    (x,y) \<in> r \<and> xs = ys \<or> x = y \<and> (xs, ys) \<in> listrel1 r"
 by (simp add: listrel1_def Cons_eq_append_conv) (blast)
 
 lemma listrel1I1: "(x,y) \<in> r \<Longrightarrow> (x # xs, y # xs) \<in> listrel1 r"
 by fast
 
 lemma listrel1I2: "(xs, ys) \<in> listrel1 r \<Longrightarrow> (x # xs, x # ys) \<in> listrel1 r"
 by fast
 
 lemma append_listrel1I:
   "(xs, ys) \<in> listrel1 r \<and> us = vs \<or> xs = ys \<and> (us, vs) \<in> listrel1 r
     \<Longrightarrow> (xs @ us, ys @ vs) \<in> listrel1 r"
 unfolding listrel1_def
 by auto (blast intro: append_eq_appendI)+
 
 lemma Cons_listrel1E1[elim!]:
   assumes "(x # xs, ys) \<in> listrel1 r"
     and "\<And>y. ys = y # xs \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
     and "\<And>zs. ys = x # zs \<Longrightarrow> (xs, zs) \<in> listrel1 r \<Longrightarrow> R"
   shows R
 using assms by (cases ys) blast+
 
 lemma Cons_listrel1E2[elim!]:
   assumes "(xs, y # ys) \<in> listrel1 r"
     and "\<And>x. xs = x # ys \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> R"
     and "\<And>zs. xs = y # zs \<Longrightarrow> (zs, ys) \<in> listrel1 r \<Longrightarrow> R"
   shows R
 using assms by (cases xs) blast+
 
 lemma snoc_listrel1_snoc_iff:
   "(xs @ [x], ys @ [y]) \<in> listrel1 r
     \<longleftrightarrow> (xs, ys) \<in> listrel1 r \<and> x = y \<or> xs = ys \<and> (x,y) \<in> r" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L thus ?R
     by (fastforce simp: listrel1_def snoc_eq_iff_butlast butlast_append)
 next
   assume ?R then show ?L unfolding listrel1_def by force
 qed
 
 lemma listrel1_eq_len: "(xs,ys) \<in> listrel1 r \<Longrightarrow> length xs = length ys"
 unfolding listrel1_def by auto
 
 lemma listrel1_mono:
   "r \<subseteq> s \<Longrightarrow> listrel1 r \<subseteq> listrel1 s"
 unfolding listrel1_def by blast
 
 
 lemma listrel1_converse: "listrel1 (r\<inverse>) = (listrel1 r)\<inverse>"
 unfolding listrel1_def by blast
 
 lemma in_listrel1_converse:
   "(x,y) \<in> listrel1 (r\<inverse>) \<longleftrightarrow> (x,y) \<in> (listrel1 r)\<inverse>"
 unfolding listrel1_def by blast
 
 lemma listrel1_iff_update:
   "(xs,ys) \<in> (listrel1 r)
    \<longleftrightarrow> (\<exists>y n. (xs ! n, y) \<in> r \<and> n < length xs \<and> ys = xs[n:=y])" (is "?L \<longleftrightarrow> ?R")
 proof
   assume "?L"
   then obtain x y u v where "xs = u @ x # v"  "ys = u @ y # v"  "(x,y) \<in> r"
     unfolding listrel1_def by auto
   then have "ys = xs[length u := y]" and "length u < length xs"
     and "(xs ! length u, y) \<in> r" by auto
   then show "?R" by auto
 next
   assume "?R"
   then obtain x y n where "(xs!n, y) \<in> r" "n < size xs" "ys = xs[n:=y]" "x = xs!n"
     by auto
   then obtain u v where "xs = u @ x # v" and "ys = u @ y # v" and "(x, y) \<in> r"
     by (auto intro: upd_conv_take_nth_drop id_take_nth_drop)
   then show "?L" by (auto simp: listrel1_def)
 qed
 
 
 text\<open>Accessible part and wellfoundedness:\<close>
 
 lemma Cons_acc_listrel1I [intro!]:
   "x \<in> Wellfounded.acc r \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> (x # xs) \<in> Wellfounded.acc (listrel1 r)"
 apply (induct arbitrary: xs set: Wellfounded.acc)
 apply (erule thin_rl)
 apply (erule acc_induct)
   apply (rule accI)
 apply (blast)
 done
 
 lemma lists_accD: "xs \<in> lists (Wellfounded.acc r) \<Longrightarrow> xs \<in> Wellfounded.acc (listrel1 r)"
 proof (induct set: lists)
   case Nil
   then show ?case
     by (meson acc.intros not_listrel1_Nil)
 next
   case (Cons a l)
   then show ?case
     by blast
 qed
 
 lemma lists_accI: "xs \<in> Wellfounded.acc (listrel1 r) \<Longrightarrow> xs \<in> lists (Wellfounded.acc r)"
 apply (induct set: Wellfounded.acc)
 apply clarify
 apply (rule accI)
 apply (fastforce dest!: in_set_conv_decomp[THEN iffD1] simp: listrel1_def)
 done
 
 lemma wf_listrel1_iff[simp]: "wf(listrel1 r) = wf r"
 by (auto simp: wf_acc_iff
       intro: lists_accD lists_accI[THEN Cons_in_lists_iff[THEN iffD1, THEN conjunct1]])
 
 subsubsection \<open>Lifting Relations to Lists: all elements\<close>
 
 inductive_set
   listrel :: "('a \<times> 'b) set \<Rightarrow> ('a list \<times> 'b list) set"
   for r :: "('a \<times> 'b) set"
 where
     Nil:  "([],[]) \<in> listrel r"
   | Cons: "\<lbrakk>(x,y) \<in> r; (xs,ys) \<in> listrel r\<rbrakk> \<Longrightarrow> (x#xs, y#ys) \<in> listrel r"
 
 inductive_cases listrel_Nil1 [elim!]: "([],xs) \<in> listrel r"
 inductive_cases listrel_Nil2 [elim!]: "(xs,[]) \<in> listrel r"
 inductive_cases listrel_Cons1 [elim!]: "(y#ys,xs) \<in> listrel r"
 inductive_cases listrel_Cons2 [elim!]: "(xs,y#ys) \<in> listrel r"
 
 
 lemma listrel_eq_len:  "(xs, ys) \<in> listrel r \<Longrightarrow> length xs = length ys"
   by(induct rule: listrel.induct) auto
 
 lemma listrel_iff_zip [code_unfold]: "(xs,ys) \<in> listrel r \<longleftrightarrow>
   length xs = length ys \<and> (\<forall>(x,y) \<in> set(zip xs ys). (x,y) \<in> r)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L thus ?R by induct (auto intro: listrel_eq_len)
 next
   assume ?R thus ?L
     apply (clarify)
     by (induct rule: list_induct2) (auto intro: listrel.intros)
 qed
 
 lemma listrel_iff_nth: "(xs,ys) \<in> listrel r \<longleftrightarrow>
   length xs = length ys \<and> (\<forall>n < length xs. (xs!n, ys!n) \<in> r)" (is "?L \<longleftrightarrow> ?R")
   by (auto simp add: all_set_conv_all_nth listrel_iff_zip)
 
 lemma listrel_mono: "r \<subseteq> s \<Longrightarrow> listrel r \<subseteq> listrel s"
   by (meson listrel_iff_nth subrelI subset_eq)
 
 lemma listrel_subset:
   assumes "r \<subseteq> A \<times> A" shows "listrel r \<subseteq> lists A \<times> lists A"
 proof clarify
   show "a \<in> lists A \<and> b \<in> lists A" if "(a, b) \<in> listrel r" for a b
     using that assms by (induction rule: listrel.induct, auto)
 qed
 
 lemma listrel_refl_on:
   assumes "refl_on A r" shows "refl_on (lists A) (listrel r)"
 proof -
   have "l \<in> lists A \<Longrightarrow> (l, l) \<in> listrel r" for l
     using assms unfolding refl_on_def
     by (induction l, auto intro: listrel.intros)
   then show ?thesis
     by (meson assms listrel_subset refl_on_def)
 qed
 
 lemma listrel_sym: "sym r \<Longrightarrow> sym (listrel r)"
   by (simp add: listrel_iff_nth sym_def)
 
 lemma listrel_trans:
   assumes "trans r" shows "trans (listrel r)"
 proof -
   have "(x, z) \<in> listrel r" if "(x, y) \<in> listrel r" "(y, z) \<in> listrel r" for x y z
     using that
   proof induction
     case (Cons x y xs ys)
     then show ?case
       by clarsimp (metis assms listrel.Cons listrel_iff_nth transD)
   qed auto
   then show ?thesis
     using transI by blast
 qed
 
 theorem equiv_listrel: "equiv A r \<Longrightarrow> equiv (lists A) (listrel r)"
   by (simp add: equiv_def listrel_refl_on listrel_sym listrel_trans)
 
 lemma listrel_rtrancl_refl[iff]: "(xs,xs) \<in> listrel(r\<^sup>*)"
   using listrel_refl_on[of UNIV, OF refl_rtrancl]
   by(auto simp: refl_on_def)
 
 lemma listrel_rtrancl_trans:
   "\<lbrakk>(xs,ys) \<in> listrel(r\<^sup>*);  (ys,zs) \<in> listrel(r\<^sup>*)\<rbrakk> \<Longrightarrow> (xs,zs) \<in> listrel(r\<^sup>*)"
   by (metis listrel_trans trans_def trans_rtrancl)
 
 lemma listrel_Nil [simp]: "listrel r `` {[]} = {[]}"
   by (blast intro: listrel.intros)
 
 lemma listrel_Cons:
   "listrel r `` {x#xs} = set_Cons (r``{x}) (listrel r `` {xs})"
   by (auto simp add: set_Cons_def intro: listrel.intros)
 
 text \<open>Relating \<^term>\<open>listrel1\<close>, \<^term>\<open>listrel\<close> and closures:\<close>
 
 lemma listrel1_rtrancl_subset_rtrancl_listrel1: "listrel1 (r\<^sup>*) \<subseteq> (listrel1 r)\<^sup>*"
 proof (rule subrelI)
   fix xs ys assume 1: "(xs,ys) \<in> listrel1 (r\<^sup>*)"
   { fix x y us vs
     have "(x,y) \<in> r\<^sup>* \<Longrightarrow> (us @ x # vs, us @ y # vs) \<in> (listrel1 r)\<^sup>*"
     proof(induct rule: rtrancl.induct)
       case rtrancl_refl show ?case by simp
     next
       case rtrancl_into_rtrancl thus ?case
         by (metis listrel1I rtrancl.rtrancl_into_rtrancl)
     qed }
   thus "(xs,ys) \<in> (listrel1 r)\<^sup>*" using 1 by(blast elim: listrel1E)
 qed
 
 lemma rtrancl_listrel1_eq_len: "(x,y) \<in> (listrel1 r)\<^sup>* \<Longrightarrow> length x = length y"
   by (induct rule: rtrancl.induct) (auto intro: listrel1_eq_len)
 
 lemma rtrancl_listrel1_ConsI1:
   "(xs,ys) \<in> (listrel1 r)\<^sup>* \<Longrightarrow> (x#xs,x#ys) \<in> (listrel1 r)\<^sup>*"
 proof (induction rule: rtrancl.induct)
   case (rtrancl_into_rtrancl a b c)
   then show ?case
     by (metis listrel1I2 rtrancl.rtrancl_into_rtrancl)
 qed auto
 
 lemma rtrancl_listrel1_ConsI2:
   "(x,y) \<in> r\<^sup>* \<Longrightarrow> (xs, ys) \<in> (listrel1 r)\<^sup>* \<Longrightarrow> (x # xs, y # ys) \<in> (listrel1 r)\<^sup>*"
   by (meson in_mono listrel1I1 listrel1_rtrancl_subset_rtrancl_listrel1 rtrancl_listrel1_ConsI1 rtrancl_trans)
 
 lemma listrel1_subset_listrel:
   "r \<subseteq> r' \<Longrightarrow> refl r' \<Longrightarrow> listrel1 r \<subseteq> listrel(r')"
   by(auto elim!: listrel1E simp add: listrel_iff_zip set_zip refl_on_def)
 
 lemma listrel_reflcl_if_listrel1:
   "(xs,ys) \<in> listrel1 r \<Longrightarrow> (xs,ys) \<in> listrel(r\<^sup>*)"
   by(erule listrel1E)(auto simp add: listrel_iff_zip set_zip)
 
 lemma listrel_rtrancl_eq_rtrancl_listrel1: "listrel (r\<^sup>*) = (listrel1 r)\<^sup>*"
 proof
   { fix x y assume "(x,y) \<in> listrel (r\<^sup>*)"
     then have "(x,y) \<in> (listrel1 r)\<^sup>*"
     by induct (auto intro: rtrancl_listrel1_ConsI2) }
   then show "listrel (r\<^sup>*) \<subseteq> (listrel1 r)\<^sup>*"
     by (rule subrelI)
 next
   show "listrel (r\<^sup>*) \<supseteq> (listrel1 r)\<^sup>*"
   proof(rule subrelI)
     fix xs ys assume "(xs,ys) \<in> (listrel1 r)\<^sup>*"
     then show "(xs,ys) \<in> listrel (r\<^sup>*)"
     proof induct
       case base show ?case by(auto simp add: listrel_iff_zip set_zip)
     next
       case (step ys zs)
       thus ?case by (metis listrel_reflcl_if_listrel1 listrel_rtrancl_trans)
     qed
   qed
 qed
 
 lemma rtrancl_listrel1_if_listrel:
   "(xs,ys) \<in> listrel r \<Longrightarrow> (xs,ys) \<in> (listrel1 r)\<^sup>*"
   by(metis listrel_rtrancl_eq_rtrancl_listrel1 subsetD[OF listrel_mono] r_into_rtrancl subsetI)
 
 lemma listrel_subset_rtrancl_listrel1: "listrel r \<subseteq> (listrel1 r)\<^sup>*"
   by(fast intro:rtrancl_listrel1_if_listrel)
 
 
 subsection \<open>Size function\<close>
 
 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (size_list f)"
   by (rule is_measure_trivial)
 
 lemma [measure_function]: "is_measure f \<Longrightarrow> is_measure (size_option f)"
   by (rule is_measure_trivial)
 
 lemma size_list_estimation[termination_simp]:
   "x \<in> set xs \<Longrightarrow> y < f x \<Longrightarrow> y < size_list f xs"
   by (induct xs) auto
 
 lemma size_list_estimation'[termination_simp]:
   "x \<in> set xs \<Longrightarrow> y \<le> f x \<Longrightarrow> y \<le> size_list f xs"
   by (induct xs) auto
 
 lemma size_list_map[simp]: "size_list f (map g xs) = size_list (f \<circ> g) xs"
   by (induct xs) auto
 
 lemma size_list_append[simp]: "size_list f (xs @ ys) = size_list f xs + size_list f ys"
   by (induct xs, auto)
 
 lemma size_list_pointwise[termination_simp]:
   "(\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> g x) \<Longrightarrow> size_list f xs \<le> size_list g xs"
   by (induct xs) force+
 
 
 subsection \<open>Monad operation\<close>
 
 definition bind :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'b list" where
 "bind xs f = concat (map f xs)"
 
 hide_const (open) bind
 
 lemma bind_simps [simp]:
   "List.bind [] f = []"
   "List.bind (x # xs) f = f x @ List.bind xs f"
   by (simp_all add: bind_def)
 
 lemma list_bind_cong [fundef_cong]:
   assumes "xs = ys" "(\<And>x. x \<in> set xs \<Longrightarrow> f x = g x)"
   shows   "List.bind xs f = List.bind ys g"
 proof -
   from assms(2) have "List.bind xs f = List.bind xs g"
     by (induction xs) simp_all
   with assms(1) show ?thesis by simp
 qed
 
 lemma set_list_bind: "set (List.bind xs f) = (\<Union>x\<in>set xs. set (f x))"
   by (induction xs) simp_all
 
 
 subsection \<open>Code generation\<close>
 
 text\<open>Optional tail recursive version of \<^const>\<open>map\<close>. Can avoid
 stack overflow in some target languages.\<close>
 
 fun map_tailrec_rev ::  "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'b list" where
 "map_tailrec_rev f [] bs = bs" |
 "map_tailrec_rev f (a#as) bs = map_tailrec_rev f as (f a # bs)"
 
 lemma map_tailrec_rev:
   "map_tailrec_rev f as bs = rev(map f as) @ bs"
 by(induction as arbitrary: bs) simp_all
 
 definition map_tailrec :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
 "map_tailrec f as = rev (map_tailrec_rev f as [])"
 
 text\<open>Code equation:\<close>
 lemma map_eq_map_tailrec: "map = map_tailrec"
 by(simp add: fun_eq_iff map_tailrec_def map_tailrec_rev)
 
 
 subsubsection \<open>Counterparts for set-related operations\<close>
 
 definition member :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
 [code_abbrev]: "member xs x \<longleftrightarrow> x \<in> set xs"
 
 text \<open>
   Use \<open>member\<close> only for generating executable code.  Otherwise use
   \<^prop>\<open>x \<in> set xs\<close> instead --- it is much easier to reason about.
 \<close>
 
 lemma member_rec [code]:
   "member (x # xs) y \<longleftrightarrow> x = y \<or> member xs y"
   "member [] y \<longleftrightarrow> False"
   by (auto simp add: member_def)
 
 lemma in_set_member (* FIXME delete candidate *):
   "x \<in> set xs \<longleftrightarrow> member xs x"
   by (simp add: member_def)
 
 lemmas list_all_iff [code_abbrev] = fun_cong[OF list.pred_set]
 
 definition list_ex :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 list_ex_iff [code_abbrev]: "list_ex P xs \<longleftrightarrow> Bex (set xs) P"
 
 definition list_ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
 list_ex1_iff [code_abbrev]: "list_ex1 P xs \<longleftrightarrow> (\<exists>! x. x \<in> set xs \<and> P x)"
 
 text \<open>
   Usually you should prefer \<open>\<forall>x\<in>set xs\<close>, \<open>\<exists>x\<in>set xs\<close>
   and \<open>\<exists>!x. x\<in>set xs \<and> _\<close> over \<^const>\<open>list_all\<close>, \<^const>\<open>list_ex\<close>
   and \<^const>\<open>list_ex1\<close> in specifications.
 \<close>
 
 lemma list_all_simps [code]:
   "list_all P (x # xs) \<longleftrightarrow> P x \<and> list_all P xs"
   "list_all P [] \<longleftrightarrow> True"
   by (simp_all add: list_all_iff)
 
 lemma list_ex_simps [simp, code]:
   "list_ex P (x # xs) \<longleftrightarrow> P x \<or> list_ex P xs"
   "list_ex P [] \<longleftrightarrow> False"
   by (simp_all add: list_ex_iff)
 
 lemma list_ex1_simps [simp, code]:
   "list_ex1 P [] = False"
   "list_ex1 P (x # xs) = (if P x then list_all (\<lambda>y. \<not> P y \<or> x = y) xs else list_ex1 P xs)"
   by (auto simp add: list_ex1_iff list_all_iff)
 
 lemma Ball_set_list_all: (* FIXME delete candidate *)
   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
   by (simp add: list_all_iff)
 
 lemma Bex_set_list_ex: (* FIXME delete candidate *)
   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
   by (simp add: list_ex_iff)
 
 lemma list_all_append [simp]:
   "list_all P (xs @ ys) \<longleftrightarrow> list_all P xs \<and> list_all P ys"
   by (auto simp add: list_all_iff)
 
 lemma list_ex_append [simp]:
   "list_ex P (xs @ ys) \<longleftrightarrow> list_ex P xs \<or> list_ex P ys"
   by (auto simp add: list_ex_iff)
 
 lemma list_all_rev [simp]:
   "list_all P (rev xs) \<longleftrightarrow> list_all P xs"
   by (simp add: list_all_iff)
 
 lemma list_ex_rev [simp]:
   "list_ex P (rev xs) \<longleftrightarrow> list_ex P xs"
   by (simp add: list_ex_iff)
 
 lemma list_all_length:
   "list_all P xs \<longleftrightarrow> (\<forall>n < length xs. P (xs ! n))"
   by (auto simp add: list_all_iff set_conv_nth)
 
 lemma list_ex_length:
   "list_ex P xs \<longleftrightarrow> (\<exists>n < length xs. P (xs ! n))"
   by (auto simp add: list_ex_iff set_conv_nth)
 
 lemmas list_all_cong [fundef_cong] = list.pred_cong
 
 lemma list_ex_cong [fundef_cong]:
   "xs = ys \<Longrightarrow> (\<And>x. x \<in> set ys \<Longrightarrow> f x = g x) \<Longrightarrow> list_ex f xs = list_ex g ys"
 by (simp add: list_ex_iff)
 
 definition can_select :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool" where
 [code_abbrev]: "can_select P A = (\<exists>!x\<in>A. P x)"
 
 lemma can_select_set_list_ex1 [code]:
   "can_select P (set A) = list_ex1 P A"
   by (simp add: list_ex1_iff can_select_def)
 
 
 text \<open>Executable checks for relations on sets\<close>
 
 definition listrel1p :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
 "listrel1p r xs ys = ((xs, ys) \<in> listrel1 {(x, y). r x y})"
 
 lemma [code_unfold]:
   "(xs, ys) \<in> listrel1 r = listrel1p (\<lambda>x y. (x, y) \<in> r) xs ys"
 unfolding listrel1p_def by auto
 
 lemma [code]:
   "listrel1p r [] xs = False"
   "listrel1p r xs [] =  False"
   "listrel1p r (x # xs) (y # ys) \<longleftrightarrow>
      r x y \<and> xs = ys \<or> x = y \<and> listrel1p r xs ys"
 by (simp add: listrel1p_def)+
 
 definition
   lexordp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
   "lexordp r xs ys = ((xs, ys) \<in> lexord {(x, y). r x y})"
 
 lemma [code_unfold]:
   "(xs, ys) \<in> lexord r = lexordp (\<lambda>x y. (x, y) \<in> r) xs ys"
 unfolding lexordp_def by auto
 
 lemma [code]:
   "lexordp r xs [] = False"
   "lexordp r [] (y#ys) = True"
   "lexordp r (x # xs) (y # ys) = (r x y \<or> (x = y \<and> lexordp r xs ys))"
 unfolding lexordp_def by auto
 
 text \<open>Bounded quantification and summation over nats.\<close>
 
 lemma atMost_upto [code_unfold]:
   "{..n} = set [0..<Suc n]"
   by auto
 
 lemma atLeast_upt [code_unfold]:
   "{..<n} = set [0..<n]"
   by auto
 
 lemma greaterThanLessThan_upt [code_unfold]:
   "{n<..<m} = set [Suc n..<m]"
   by auto
 
 lemmas atLeastLessThan_upt [code_unfold] = set_upt [symmetric]
 
 lemma greaterThanAtMost_upt [code_unfold]:
   "{n<..m} = set [Suc n..<Suc m]"
   by auto
 
 lemma atLeastAtMost_upt [code_unfold]:
   "{n..m} = set [n..<Suc m]"
   by auto
 
 lemma all_nat_less_eq [code_unfold]:
   "(\<forall>m<n::nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..<n}. P m)"
   by auto
 
 lemma ex_nat_less_eq [code_unfold]:
   "(\<exists>m<n::nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..<n}. P m)"
   by auto
 
 lemma all_nat_less [code_unfold]:
   "(\<forall>m\<le>n::nat. P m) \<longleftrightarrow> (\<forall>m \<in> {0..n}. P m)"
   by auto
 
 lemma ex_nat_less [code_unfold]:
   "(\<exists>m\<le>n::nat. P m) \<longleftrightarrow> (\<exists>m \<in> {0..n}. P m)"
   by auto
 
 text\<open>Bounded \<open>LEAST\<close> operator:\<close>
 
 definition "Bleast S P = (LEAST x. x \<in> S \<and> P x)"
 
 definition "abort_Bleast S P = (LEAST x. x \<in> S \<and> P x)"
 
 declare [[code abort: abort_Bleast]]
 
 lemma Bleast_code [code]:
  "Bleast (set xs) P = (case filter P (sort xs) of
     x#xs \<Rightarrow> x |
     [] \<Rightarrow> abort_Bleast (set xs) P)"
 proof (cases "filter P (sort xs)")
   case Nil thus ?thesis by (simp add: Bleast_def abort_Bleast_def)
 next
   case (Cons x ys)
   have "(LEAST x. x \<in> set xs \<and> P x) = x"
   proof (rule Least_equality)
     show "x \<in> set xs \<and> P x"
       by (metis Cons Cons_eq_filter_iff in_set_conv_decomp set_sort)
     next
       fix y assume "y \<in> set xs \<and> P y"
       hence "y \<in> set (filter P xs)" by auto
       thus "x \<le> y"
         by (metis Cons eq_iff filter_sort set_ConsD set_sort sorted_wrt.simps(2) sorted_sort)
   qed
   thus ?thesis using Cons by (simp add: Bleast_def)
 qed
 
 declare Bleast_def[symmetric, code_unfold]
 
 text \<open>Summation over ints.\<close>
 
 lemma greaterThanLessThan_upto [code_unfold]:
   "{i<..<j::int} = set [i+1..j - 1]"
 by auto
 
 lemma atLeastLessThan_upto [code_unfold]:
   "{i..<j::int} = set [i..j - 1]"
 by auto
 
 lemma greaterThanAtMost_upto [code_unfold]:
   "{i<..j::int} = set [i+1..j]"
 by auto
 
 lemmas atLeastAtMost_upto [code_unfold] = set_upto [symmetric]
 
 
 subsubsection \<open>Optimizing by rewriting\<close>
 
 definition null :: "'a list \<Rightarrow> bool" where
   [code_abbrev]: "null xs \<longleftrightarrow> xs = []"
 
 text \<open>
   Efficient emptyness check is implemented by \<^const>\<open>null\<close>.
 \<close>
 
 lemma null_rec [code]:
   "null (x # xs) \<longleftrightarrow> False"
   "null [] \<longleftrightarrow> True"
   by (simp_all add: null_def)
 
 lemma eq_Nil_null: (* FIXME delete candidate *)
   "xs = [] \<longleftrightarrow> null xs"
   by (simp add: null_def)
 
 lemma equal_Nil_null [code_unfold]:
   "HOL.equal xs [] \<longleftrightarrow> null xs"
   "HOL.equal [] = null"
   by (auto simp add: equal null_def)
 
 definition maps :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
   [code_abbrev]: "maps f xs = concat (map f xs)"
 
 definition map_filter :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
   [code_post]: "map_filter f xs = map (the \<circ> f) (filter (\<lambda>x. f x \<noteq> None) xs)"
 
 text \<open>
   Operations \<^const>\<open>maps\<close> and \<^const>\<open>map_filter\<close> avoid
   intermediate lists on execution -- do not use for proving.
 \<close>
 
 lemma maps_simps [code]:
   "maps f (x # xs) = f x @ maps f xs"
   "maps f [] = []"
   by (simp_all add: maps_def)
 
 lemma map_filter_simps [code]:
   "map_filter f (x # xs) = (case f x of None \<Rightarrow> map_filter f xs | Some y \<Rightarrow> y # map_filter f xs)"
   "map_filter f [] = []"
   by (simp_all add: map_filter_def split: option.split)
 
 lemma concat_map_maps: (* FIXME delete candidate *)
   "concat (map f xs) = maps f xs"
   by (simp add: maps_def)
 
 lemma map_filter_map_filter [code_unfold]:
   "map f (filter P xs) = map_filter (\<lambda>x. if P x then Some (f x) else None) xs"
   by (simp add: map_filter_def)
 
 text \<open>Optimized code for \<open>\<forall>i\<in>{a..b::int}\<close> and \<open>\<forall>n:{a..<b::nat}\<close>
 and similiarly for \<open>\<exists>\<close>.\<close>
 
 definition all_interval_nat :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
   "all_interval_nat P i j \<longleftrightarrow> (\<forall>n \<in> {i..<j}. P n)"
 
 lemma [code]:
   "all_interval_nat P i j \<longleftrightarrow> i \<ge> j \<or> P i \<and> all_interval_nat P (Suc i) j"
 proof -
   have *: "\<And>n. P i \<Longrightarrow> \<forall>n\<in>{Suc i..<j}. P n \<Longrightarrow> i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n"
   proof -
     fix n
     assume "P i" "\<forall>n\<in>{Suc i..<j}. P n" "i \<le> n" "n < j"
     then show "P n" by (cases "n = i") simp_all
   qed
   show ?thesis by (auto simp add: all_interval_nat_def intro: *)
 qed
 
 lemma list_all_iff_all_interval_nat [code_unfold]:
   "list_all P [i..<j] \<longleftrightarrow> all_interval_nat P i j"
   by (simp add: list_all_iff all_interval_nat_def)
 
 lemma list_ex_iff_not_all_inverval_nat [code_unfold]:
   "list_ex P [i..<j] \<longleftrightarrow> \<not> (all_interval_nat (Not \<circ> P) i j)"
   by (simp add: list_ex_iff all_interval_nat_def)
 
 definition all_interval_int :: "(int \<Rightarrow> bool) \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
   "all_interval_int P i j \<longleftrightarrow> (\<forall>k \<in> {i..j}. P k)"
 
 lemma [code]:
   "all_interval_int P i j \<longleftrightarrow> i > j \<or> P i \<and> all_interval_int P (i + 1) j"
 proof -
   have *: "\<And>k. P i \<Longrightarrow> \<forall>k\<in>{i+1..j}. P k \<Longrightarrow> i \<le> k \<Longrightarrow> k \<le> j \<Longrightarrow> P k"
   proof -
     fix k
     assume "P i" "\<forall>k\<in>{i+1..j}. P k" "i \<le> k" "k \<le> j"
     then show "P k" by (cases "k = i") simp_all
   qed
   show ?thesis by (auto simp add: all_interval_int_def intro: *)
 qed
 
 lemma list_all_iff_all_interval_int [code_unfold]:
   "list_all P [i..j] \<longleftrightarrow> all_interval_int P i j"
   by (simp add: list_all_iff all_interval_int_def)
 
 lemma list_ex_iff_not_all_inverval_int [code_unfold]:
   "list_ex P [i..j] \<longleftrightarrow> \<not> (all_interval_int (Not \<circ> P) i j)"
   by (simp add: list_ex_iff all_interval_int_def)
 
 text \<open>optimized code (tail-recursive) for \<^term>\<open>length\<close>\<close>
 
 definition gen_length :: "nat \<Rightarrow> 'a list \<Rightarrow> nat"
 where "gen_length n xs = n + length xs"
 
 lemma gen_length_code [code]:
   "gen_length n [] = n"
   "gen_length n (x # xs) = gen_length (Suc n) xs"
 by(simp_all add: gen_length_def)
 
 declare list.size(3-4)[code del]
 
 lemma length_code [code]: "length = gen_length 0"
 by(simp add: gen_length_def fun_eq_iff)
 
 hide_const (open) member null maps map_filter all_interval_nat all_interval_int gen_length
 
 
 subsubsection \<open>Pretty lists\<close>
 
 ML \<open>
 (* Code generation for list literals. *)
 
 signature LIST_CODE =
 sig
   val add_literal_list: string -> theory -> theory
 end;
 
 structure List_Code : LIST_CODE =
 struct
 
 open Basic_Code_Thingol;
 
 fun implode_list t =
   let
     fun dest_cons (IConst { sym = Code_Symbol.Constant \<^const_name>\<open>Cons\<close>, ... } `$ t1 `$ t2) = SOME (t1, t2)
       | dest_cons _ = NONE;
     val (ts, t') = Code_Thingol.unfoldr dest_cons t;
   in case t'
    of IConst { sym = Code_Symbol.Constant \<^const_name>\<open>Nil\<close>, ... } => SOME ts
     | _ => NONE
   end;
 
 fun print_list (target_fxy, target_cons) pr fxy t1 t2 =
   Code_Printer.brackify_infix (target_fxy, Code_Printer.R) fxy (
     pr (Code_Printer.INFX (target_fxy, Code_Printer.X)) t1,
     Code_Printer.str target_cons,
     pr (Code_Printer.INFX (target_fxy, Code_Printer.R)) t2
   );
 
 fun add_literal_list target =
   let
     fun pretty literals pr _ vars fxy [(t1, _), (t2, _)] =
       case Option.map (cons t1) (implode_list t2)
        of SOME ts =>
             Code_Printer.literal_list literals (map (pr vars Code_Printer.NOBR) ts)
         | NONE =>
             print_list (Code_Printer.infix_cons literals) (pr vars) fxy t1 t2;
   in
     Code_Target.set_printings (Code_Symbol.Constant (\<^const_name>\<open>Cons\<close>,
       [(target, SOME (Code_Printer.complex_const_syntax (2, pretty)))]))
   end
 
 end;
 \<close>
 
 code_printing
   type_constructor list \<rightharpoonup>
     (SML) "_ list"
     and (OCaml) "_ list"
     and (Haskell) "![(_)]"
     and (Scala) "List[(_)]"
 | constant Nil \<rightharpoonup>
     (SML) "[]"
     and (OCaml) "[]"
     and (Haskell) "[]"
     and (Scala) "!Nil"
 | class_instance list :: equal \<rightharpoonup>
     (Haskell) -
 | constant "HOL.equal :: 'a list \<Rightarrow> 'a list \<Rightarrow> bool" \<rightharpoonup>
     (Haskell) infix 4 "=="
 
 setup \<open>fold (List_Code.add_literal_list) ["SML", "OCaml", "Haskell", "Scala"]\<close>
 
 code_reserved SML
   list
 
 code_reserved OCaml
   list
 
 
 subsubsection \<open>Use convenient predefined operations\<close>
 
 code_printing
   constant "(@)" \<rightharpoonup>
     (SML) infixr 7 "@"
     and (OCaml) infixr 6 "@"
     and (Haskell) infixr 5 "++"
     and (Scala) infixl 7 "++"
 | constant map \<rightharpoonup>
     (Haskell) "map"
 | constant filter \<rightharpoonup>
     (Haskell) "filter"
 | constant concat \<rightharpoonup>
     (Haskell) "concat"
 | constant List.maps \<rightharpoonup>
     (Haskell) "concatMap"
 | constant rev \<rightharpoonup>
     (Haskell) "reverse"
 | constant zip \<rightharpoonup>
     (Haskell) "zip"
 | constant List.null \<rightharpoonup>
     (Haskell) "null"
 | constant takeWhile \<rightharpoonup>
     (Haskell) "takeWhile"
 | constant dropWhile \<rightharpoonup>
     (Haskell) "dropWhile"
 | constant list_all \<rightharpoonup>
     (Haskell) "all"
 | constant list_ex \<rightharpoonup>
     (Haskell) "any"
 
 
 subsubsection \<open>Implementation of sets by lists\<close>
 
 lemma is_empty_set [code]:
   "Set.is_empty (set xs) \<longleftrightarrow> List.null xs"
   by (simp add: Set.is_empty_def null_def)
 
 lemma empty_set [code]:
   "{} = set []"
   by simp
 
 lemma UNIV_coset [code]:
   "UNIV = List.coset []"
   by simp
 
 lemma compl_set [code]:
   "- set xs = List.coset xs"
   by simp
 
 lemma compl_coset [code]:
   "- List.coset xs = set xs"
   by simp
 
 lemma [code]:
   "x \<in> set xs \<longleftrightarrow> List.member xs x"
   "x \<in> List.coset xs \<longleftrightarrow> \<not> List.member xs x"
   by (simp_all add: member_def)
 
 lemma insert_code [code]:
   "insert x (set xs) = set (List.insert x xs)"
   "insert x (List.coset xs) = List.coset (removeAll x xs)"
   by simp_all
 
 lemma remove_code [code]:
   "Set.remove x (set xs) = set (removeAll x xs)"
   "Set.remove x (List.coset xs) = List.coset (List.insert x xs)"
   by (simp_all add: remove_def Compl_insert)
 
 lemma filter_set [code]:
   "Set.filter P (set xs) = set (filter P xs)"
   by auto
 
 lemma image_set [code]:
   "image f (set xs) = set (map f xs)"
   by simp
 
 lemma subset_code [code]:
   "set xs \<le> B \<longleftrightarrow> (\<forall>x\<in>set xs. x \<in> B)"
   "A \<le> List.coset ys \<longleftrightarrow> (\<forall>y\<in>set ys. y \<notin> A)"
   "List.coset [] \<subseteq> set [] \<longleftrightarrow> False"
   by auto
 
 text \<open>A frequent case -- avoid intermediate sets\<close>
 lemma [code_unfold]:
   "set xs \<subseteq> set ys \<longleftrightarrow> list_all (\<lambda>x. x \<in> set ys) xs"
   by (auto simp: list_all_iff)
 
 lemma Ball_set [code]:
   "Ball (set xs) P \<longleftrightarrow> list_all P xs"
   by (simp add: list_all_iff)
 
 lemma Bex_set [code]:
   "Bex (set xs) P \<longleftrightarrow> list_ex P xs"
   by (simp add: list_ex_iff)
 
 lemma card_set [code]:
   "card (set xs) = length (remdups xs)"
 proof -
   have "card (set (remdups xs)) = length (remdups xs)"
     by (rule distinct_card) simp
   then show ?thesis by simp
 qed
 
 lemma the_elem_set [code]:
   "the_elem (set [x]) = x"
   by simp
 
 lemma Pow_set [code]:
   "Pow (set []) = {{}}"
   "Pow (set (x # xs)) = (let A = Pow (set xs) in A \<union> insert x ` A)"
   by (simp_all add: Pow_insert Let_def)
 
 definition map_project :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a set \<Rightarrow> 'b set" where
   "map_project f A = {b. \<exists> a \<in> A. f a = Some b}"
 
 lemma [code]:
   "map_project f (set xs) = set (List.map_filter f xs)"
   by (auto simp add: map_project_def map_filter_def image_def)
 
 hide_const (open) map_project
 
 
 text \<open>Operations on relations\<close>
 
 lemma product_code [code]:
   "Product_Type.product (set xs) (set ys) = set [(x, y). x \<leftarrow> xs, y \<leftarrow> ys]"
   by (auto simp add: Product_Type.product_def)
 
 lemma Id_on_set [code]:
   "Id_on (set xs) = set [(x, x). x \<leftarrow> xs]"
   by (auto simp add: Id_on_def)
 
 lemma [code]:
   "R `` S = List.map_project (\<lambda>(x, y). if x \<in> S then Some y else None) R"
 unfolding map_project_def by (auto split: prod.split if_split_asm)
 
 lemma trancl_set_ntrancl [code]:
   "trancl (set xs) = ntrancl (card (set xs) - 1) (set xs)"
   by (simp add: finite_trancl_ntranl)
 
 lemma set_relcomp [code]:
   "set xys O set yzs = set ([(fst xy, snd yz). xy \<leftarrow> xys, yz \<leftarrow> yzs, snd xy = fst yz])"
   by auto (auto simp add: Bex_def image_def)
 
 lemma wf_set [code]:
   "wf (set xs) = acyclic (set xs)"
   by (simp add: wf_iff_acyclic_if_finite)
 
 
 subsection \<open>Setup for Lifting/Transfer\<close>
 
 subsubsection \<open>Transfer rules for the Transfer package\<close>
 
 context includes lifting_syntax
 begin
 
 lemma tl_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) tl tl"
   unfolding tl_def[abs_def] by transfer_prover
 
 lemma butlast_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) butlast butlast"
   by (rule rel_funI, erule list_all2_induct, auto)
 
 lemma map_rec: "map f xs = rec_list Nil (%x _ y. Cons (f x) y) xs"
   by (induct xs) auto
 
 lemma append_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A ===> list_all2 A) append append"
   unfolding List.append_def by transfer_prover
 
 lemma rev_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) rev rev"
   unfolding List.rev_def by transfer_prover
 
 lemma filter_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> list_all2 A) filter filter"
   unfolding List.filter_def by transfer_prover
 
 lemma fold_transfer [transfer_rule]:
   "((A ===> B ===> B) ===> list_all2 A ===> B ===> B) fold fold"
   unfolding List.fold_def by transfer_prover
 
 lemma foldr_transfer [transfer_rule]:
   "((A ===> B ===> B) ===> list_all2 A ===> B ===> B) foldr foldr"
   unfolding List.foldr_def by transfer_prover
 
 lemma foldl_transfer [transfer_rule]:
   "((B ===> A ===> B) ===> B ===> list_all2 A ===> B) foldl foldl"
   unfolding List.foldl_def by transfer_prover
 
 lemma concat_transfer [transfer_rule]:
   "(list_all2 (list_all2 A) ===> list_all2 A) concat concat"
   unfolding List.concat_def by transfer_prover
 
 lemma drop_transfer [transfer_rule]:
   "((=) ===> list_all2 A ===> list_all2 A) drop drop"
   unfolding List.drop_def by transfer_prover
 
 lemma take_transfer [transfer_rule]:
   "((=) ===> list_all2 A ===> list_all2 A) take take"
   unfolding List.take_def by transfer_prover
 
 lemma list_update_transfer [transfer_rule]:
   "(list_all2 A ===> (=) ===> A ===> list_all2 A) list_update list_update"
   unfolding list_update_def by transfer_prover
 
 lemma takeWhile_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> list_all2 A) takeWhile takeWhile"
   unfolding takeWhile_def by transfer_prover
 
 lemma dropWhile_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> list_all2 A) dropWhile dropWhile"
   unfolding dropWhile_def by transfer_prover
 
 lemma zip_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 B ===> list_all2 (rel_prod A B)) zip zip"
   unfolding zip_def by transfer_prover
 
 lemma product_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 B ===> list_all2 (rel_prod A B)) List.product List.product"
   unfolding List.product_def by transfer_prover
 
 lemma product_lists_transfer [transfer_rule]:
   "(list_all2 (list_all2 A) ===> list_all2 (list_all2 A)) product_lists product_lists"
   unfolding product_lists_def by transfer_prover
 
 lemma insert_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> list_all2 A ===> list_all2 A) List.insert List.insert"
   unfolding List.insert_def [abs_def] by transfer_prover
 
 lemma find_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> rel_option A) List.find List.find"
   unfolding List.find_def by transfer_prover
 
 lemma those_transfer [transfer_rule]:
   "(list_all2 (rel_option P) ===> rel_option (list_all2 P)) those those"
   unfolding List.those_def by transfer_prover
 
 lemma remove1_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> list_all2 A ===> list_all2 A) remove1 remove1"
   unfolding remove1_def by transfer_prover
 
 lemma removeAll_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(A ===> list_all2 A ===> list_all2 A) removeAll removeAll"
   unfolding removeAll_def by transfer_prover
 
 lemma successively_transfer [transfer_rule]:
   "((A ===> A ===> (=)) ===> list_all2 A ===> (=)) successively successively"
   unfolding successively_altdef by transfer_prover
 
 lemma distinct_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> (=)) distinct distinct"
   unfolding distinct_def by transfer_prover
 
 lemma distinct_adj_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(list_all2 A ===> (=)) distinct_adj distinct_adj"
   unfolding rel_fun_def
 proof (intro allI impI)
   fix xs ys assume "list_all2 A xs ys"
   thus "distinct_adj xs \<longleftrightarrow> distinct_adj ys"
   proof (induction rule: list_all2_induct)
     case (Cons x xs y ys)
     note * = this
     show ?case
     proof (cases xs)
       case [simp]: (Cons x' xs')
       with * obtain y' ys' where [simp]: "ys = y' # ys'"
         by (cases ys) auto
       from * show ?thesis
         using assms by (auto simp: distinct_adj_Cons bi_unique_def)
     qed (use * in auto)
   qed auto
 qed
 
 lemma remdups_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> list_all2 A) remdups remdups"
   unfolding remdups_def by transfer_prover
 
 lemma remdups_adj_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "(list_all2 A ===> list_all2 A) remdups_adj remdups_adj"
   proof (rule rel_funI, erule list_all2_induct)
   qed (auto simp: remdups_adj_Cons assms[unfolded bi_unique_def] split: list.splits)
 
 lemma replicate_transfer [transfer_rule]:
   "((=) ===> A ===> list_all2 A) replicate replicate"
   unfolding replicate_def by transfer_prover
 
 lemma length_transfer [transfer_rule]:
   "(list_all2 A ===> (=)) length length"
   unfolding size_list_overloaded_def size_list_def by transfer_prover
 
 lemma rotate1_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A) rotate1 rotate1"
   unfolding rotate1_def by transfer_prover
 
 lemma rotate_transfer [transfer_rule]:
   "((=) ===> list_all2 A ===> list_all2 A) rotate rotate"
   unfolding rotate_def [abs_def] by transfer_prover
 
 lemma nths_transfer [transfer_rule]:
   "(list_all2 A ===> rel_set (=) ===> list_all2 A) nths nths"
   unfolding nths_def [abs_def] by transfer_prover
 
 lemma subseqs_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 (list_all2 A)) subseqs subseqs"
   unfolding subseqs_def [abs_def] by transfer_prover
 
 lemma partition_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> rel_prod (list_all2 A) (list_all2 A))
     partition partition"
   unfolding partition_def by transfer_prover
 
 lemma lists_transfer [transfer_rule]:
   "(rel_set A ===> rel_set (list_all2 A)) lists lists"
 proof (rule rel_funI, rule rel_setI)
   show "\<lbrakk>l \<in> lists X; rel_set A X Y\<rbrakk> \<Longrightarrow> \<exists>y\<in>lists Y. list_all2 A l y" for X Y l
   proof (induction l rule: lists.induct)
     case (Cons a l)
     then show ?case
       by (simp only: rel_set_def list_all2_Cons1, metis lists.Cons)
   qed auto
   show "\<lbrakk>l \<in> lists Y; rel_set A X Y\<rbrakk> \<Longrightarrow> \<exists>x\<in>lists X. list_all2 A x l" for X Y l
   proof (induction l rule: lists.induct)
     case (Cons a l)
     then show ?case
       by (simp only: rel_set_def list_all2_Cons2, metis lists.Cons)
   qed auto
 qed
 
 lemma set_Cons_transfer [transfer_rule]:
   "(rel_set A ===> rel_set (list_all2 A) ===> rel_set (list_all2 A))
     set_Cons set_Cons"
   unfolding rel_fun_def rel_set_def set_Cons_def
   by (fastforce simp add: list_all2_Cons1 list_all2_Cons2)
 
 lemma listset_transfer [transfer_rule]:
   "(list_all2 (rel_set A) ===> rel_set (list_all2 A)) listset listset"
   unfolding listset_def by transfer_prover
 
 lemma null_transfer [transfer_rule]:
   "(list_all2 A ===> (=)) List.null List.null"
   unfolding rel_fun_def List.null_def by auto
 
 lemma list_all_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> (=)) list_all list_all"
   unfolding list_all_iff [abs_def] by transfer_prover
 
 lemma list_ex_transfer [transfer_rule]:
   "((A ===> (=)) ===> list_all2 A ===> (=)) list_ex list_ex"
   unfolding list_ex_iff [abs_def] by transfer_prover
 
 lemma splice_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A ===> list_all2 A) splice splice"
   apply (rule rel_funI, erule list_all2_induct, simp add: rel_fun_def, simp)
   apply (rule rel_funI)
   apply (erule_tac xs=x in list_all2_induct, simp, simp add: rel_fun_def)
   done
 
 lemma shuffles_transfer [transfer_rule]:
   "(list_all2 A ===> list_all2 A ===> rel_set (list_all2 A)) shuffles shuffles"
 proof (intro rel_funI, goal_cases)
   case (1 xs xs' ys ys')
   thus ?case
   proof (induction xs ys arbitrary: xs' ys' rule: shuffles.induct)
     case (3 x xs y ys xs' ys')
     from "3.prems" obtain x' xs'' where xs': "xs' = x' # xs''" by (cases xs') auto
     from "3.prems" obtain y' ys'' where ys': "ys' = y' # ys''" by (cases ys') auto
     have [transfer_rule]: "A x x'" "A y y'" "list_all2 A xs xs''" "list_all2 A ys ys''"
       using "3.prems" by (simp_all add: xs' ys')
     have [transfer_rule]: "rel_set (list_all2 A) (shuffles xs (y # ys)) (shuffles xs'' ys')" and
          [transfer_rule]: "rel_set (list_all2 A) (shuffles (x # xs) ys) (shuffles xs' ys'')"
       using "3.prems" by (auto intro!: "3.IH" simp: xs' ys')
     have "rel_set (list_all2 A) ((#) x ` shuffles xs (y # ys) \<union> (#) y ` shuffles (x # xs) ys)
                ((#) x' ` shuffles xs'' ys' \<union> (#) y' ` shuffles xs' ys'')" by transfer_prover
     thus ?case by (simp add: xs' ys')
   qed (auto simp: rel_set_def)
 qed
 
 lemma rtrancl_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "bi_total A"
   shows "(rel_set (rel_prod A A) ===> rel_set (rel_prod A A)) rtrancl rtrancl"
 unfolding rtrancl_def by transfer_prover
 
 lemma monotone_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A"
   shows "((A ===> A ===> (=)) ===> (B ===> B ===> (=)) ===> (A ===> B) ===> (=)) monotone monotone"
 unfolding monotone_def[abs_def] by transfer_prover
 
 lemma fun_ord_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total C"
   shows "((A ===> B ===> (=)) ===> (C ===> A) ===> (C ===> B) ===> (=)) fun_ord fun_ord"
 unfolding fun_ord_def[abs_def] by transfer_prover
 
 lemma fun_lub_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A"  "bi_unique A"
   shows "((rel_set A ===> B) ===> rel_set (C ===> A) ===> C ===> B) fun_lub fun_lub"
 unfolding fun_lub_def[abs_def] by transfer_prover
 
 end
 
 end
diff --git a/src/HOL/Map.thy b/src/HOL/Map.thy
--- a/src/HOL/Map.thy
+++ b/src/HOL/Map.thy
@@ -1,862 +1,942 @@
 (*  Title:      HOL/Map.thy
     Author:     Tobias Nipkow, based on a theory by David von Oheimb
     Copyright   1997-2003 TU Muenchen
 
 The datatype of "maps"; strongly resembles maps in VDM.
 *)
 
 section \<open>Maps\<close>
 
 theory Map
   imports List
   abbrevs "(=" = "\<subseteq>\<^sub>m"
 begin
 
 type_synonym ('a, 'b) "map" = "'a \<Rightarrow> 'b option" (infixr "\<rightharpoonup>" 0)
 
 abbreviation
   empty :: "'a \<rightharpoonup> 'b" where
   "empty \<equiv> \<lambda>x. None"
 
 definition
   map_comp :: "('b \<rightharpoonup> 'c) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'c)"  (infixl "\<circ>\<^sub>m" 55) where
   "f \<circ>\<^sub>m g = (\<lambda>k. case g k of None \<Rightarrow> None | Some v \<Rightarrow> f v)"
 
 definition
   map_add :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "++" 100) where
   "m1 ++ m2 = (\<lambda>x. case m2 x of None \<Rightarrow> m1 x | Some y \<Rightarrow> Some y)"
 
 definition
   restrict_map :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set \<Rightarrow> ('a \<rightharpoonup> 'b)"  (infixl "|`"  110) where
   "m|`A = (\<lambda>x. if x \<in> A then m x else None)"
 
 notation (latex output)
   restrict_map  ("_\<restriction>\<^bsub>_\<^esub>" [111,110] 110)
 
 definition
   dom :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a set" where
   "dom m = {a. m a \<noteq> None}"
 
 definition
   ran :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'b set" where
   "ran m = {b. \<exists>a. m a = Some b}"
 
 definition
+  graph :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b) set" where
+  "graph m = {(a, b) | a b. m a = Some b}"
+
+definition
   map_le :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> bool"  (infix "\<subseteq>\<^sub>m" 50) where
   "(m\<^sub>1 \<subseteq>\<^sub>m m\<^sub>2) \<longleftrightarrow> (\<forall>a \<in> dom m\<^sub>1. m\<^sub>1 a = m\<^sub>2 a)"
 
 nonterminal maplets and maplet
 
 syntax
   "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /\<mapsto>/ _")
   "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[\<mapsto>]/ _")
   ""         :: "maplet \<Rightarrow> maplets"             ("_")
   "_Maplets" :: "[maplet, maplets] \<Rightarrow> maplets" ("_,/ _")
   "_MapUpd"  :: "['a \<rightharpoonup> 'b, maplets] \<Rightarrow> 'a \<rightharpoonup> 'b" ("_/'(_')" [900, 0] 900)
   "_Map"     :: "maplets \<Rightarrow> 'a \<rightharpoonup> 'b"            ("(1[_])")
 
 syntax (ASCII)
   "_maplet"  :: "['a, 'a] \<Rightarrow> maplet"             ("_ /|->/ _")
   "_maplets" :: "['a, 'a] \<Rightarrow> maplet"             ("_ /[|->]/ _")
 
 translations
   "_MapUpd m (_Maplets xy ms)"  \<rightleftharpoons> "_MapUpd (_MapUpd m xy) ms"
   "_MapUpd m (_maplet  x y)"    \<rightleftharpoons> "m(x := CONST Some y)"
   "_Map ms"                     \<rightleftharpoons> "_MapUpd (CONST empty) ms"
   "_Map (_Maplets ms1 ms2)"     \<leftharpoondown> "_MapUpd (_Map ms1) ms2"
   "_Maplets ms1 (_Maplets ms2 ms3)" \<leftharpoondown> "_Maplets (_Maplets ms1 ms2) ms3"
 
 primrec map_of :: "('a \<times> 'b) list \<Rightarrow> 'a \<rightharpoonup> 'b"
 where
   "map_of [] = empty"
 | "map_of (p # ps) = (map_of ps)(fst p \<mapsto> snd p)"
 
 definition map_upds :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a \<rightharpoonup> 'b"
   where "map_upds m xs ys = m ++ map_of (rev (zip xs ys))"
 translations
   "_MapUpd m (_maplets x y)" \<rightleftharpoons> "CONST map_upds m x y"
 
 lemma map_of_Cons_code [code]:
   "map_of [] k = None"
   "map_of ((l, v) # ps) k = (if l = k then Some v else map_of ps k)"
   by simp_all
 
 
 subsection \<open>@{term [source] empty}\<close>
 
 lemma empty_upd_none [simp]: "empty(x := None) = empty"
   by (rule ext) simp
 
 
 subsection \<open>@{term [source] map_upd}\<close>
 
 lemma map_upd_triv: "t k = Some x \<Longrightarrow> t(k\<mapsto>x) = t"
   by (rule ext) simp
 
 lemma map_upd_nonempty [simp]: "t(k\<mapsto>x) \<noteq> empty"
 proof
   assume "t(k \<mapsto> x) = empty"
   then have "(t(k \<mapsto> x)) k = None" by simp
   then show False by simp
 qed
 
 lemma map_upd_eqD1:
   assumes "m(a\<mapsto>x) = n(a\<mapsto>y)"
   shows "x = y"
 proof -
   from assms have "(m(a\<mapsto>x)) a = (n(a\<mapsto>y)) a" by simp
   then show ?thesis by simp
 qed
 
 lemma map_upd_Some_unfold:
   "((m(a\<mapsto>b)) x = Some y) = (x = a \<and> b = y \<or> x \<noteq> a \<and> m x = Some y)"
   by auto
 
 lemma image_map_upd [simp]: "x \<notin> A \<Longrightarrow> m(x \<mapsto> y) ` A = m ` A"
   by auto
 
 lemma finite_range_updI:
   assumes "finite (range f)" shows "finite (range (f(a\<mapsto>b)))"
 proof -
   have "range (f(a\<mapsto>b)) \<subseteq> insert (Some b) (range f)"
     by auto
   then show ?thesis
     by (rule finite_subset) (use assms in auto)
 qed
 
 
 subsection \<open>@{term [source] map_of}\<close>
 
 lemma map_of_eq_empty_iff [simp]:
   "map_of xys = empty \<longleftrightarrow> xys = []"
 proof
   show "map_of xys = empty \<Longrightarrow> xys = []"
     by (induction xys) simp_all
 qed simp
 
 lemma empty_eq_map_of_iff [simp]:
   "empty = map_of xys \<longleftrightarrow> xys = []"
 by(subst eq_commute) simp
 
 lemma map_of_eq_None_iff:
   "(map_of xys x = None) = (x \<notin> fst ` (set xys))"
 by (induct xys) simp_all
 
 lemma map_of_eq_Some_iff [simp]:
   "distinct(map fst xys) \<Longrightarrow> (map_of xys x = Some y) = ((x,y) \<in> set xys)"
 proof (induct xys)
   case (Cons xy xys)
   then show ?case
     by (cases xy) (auto simp flip: map_of_eq_None_iff)
 qed auto
 
 lemma Some_eq_map_of_iff [simp]:
   "distinct(map fst xys) \<Longrightarrow> (Some y = map_of xys x) = ((x,y) \<in> set xys)"
 by (auto simp del: map_of_eq_Some_iff simp: map_of_eq_Some_iff [symmetric])
 
 lemma map_of_is_SomeI [simp]: 
   "\<lbrakk>distinct(map fst xys); (x,y) \<in> set xys\<rbrakk> \<Longrightarrow> map_of xys x = Some y"
   by simp
 
 lemma map_of_zip_is_None [simp]:
   "length xs = length ys \<Longrightarrow> (map_of (zip xs ys) x = None) = (x \<notin> set xs)"
 by (induct rule: list_induct2) simp_all
 
 lemma map_of_zip_is_Some:
   assumes "length xs = length ys"
   shows "x \<in> set xs \<longleftrightarrow> (\<exists>y. map_of (zip xs ys) x = Some y)"
 using assms by (induct rule: list_induct2) simp_all
 
 lemma map_of_zip_upd:
   fixes x :: 'a and xs :: "'a list" and ys zs :: "'b list"
   assumes "length ys = length xs"
     and "length zs = length xs"
     and "x \<notin> set xs"
     and "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)"
   shows "map_of (zip xs ys) = map_of (zip xs zs)"
 proof
   fix x' :: 'a
   show "map_of (zip xs ys) x' = map_of (zip xs zs) x'"
   proof (cases "x = x'")
     case True
     from assms True map_of_zip_is_None [of xs ys x']
       have "map_of (zip xs ys) x' = None" by simp
     moreover from assms True map_of_zip_is_None [of xs zs x']
       have "map_of (zip xs zs) x' = None" by simp
     ultimately show ?thesis by simp
   next
     case False from assms
       have "(map_of (zip xs ys)(x \<mapsto> y)) x' = (map_of (zip xs zs)(x \<mapsto> z)) x'" by auto
     with False show ?thesis by simp
   qed
 qed
 
 lemma map_of_zip_inject:
   assumes "length ys = length xs"
     and "length zs = length xs"
     and dist: "distinct xs"
     and map_of: "map_of (zip xs ys) = map_of (zip xs zs)"
   shows "ys = zs"
   using assms(1) assms(2)[symmetric]
   using dist map_of
 proof (induct ys xs zs rule: list_induct3)
   case Nil show ?case by simp
 next
   case (Cons y ys x xs z zs)
   from \<open>map_of (zip (x#xs) (y#ys)) = map_of (zip (x#xs) (z#zs))\<close>
     have map_of: "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)" by simp
   from Cons have "length ys = length xs" and "length zs = length xs"
     and "x \<notin> set xs" by simp_all
   then have "map_of (zip xs ys) = map_of (zip xs zs)" using map_of by (rule map_of_zip_upd)
   with Cons.hyps \<open>distinct (x # xs)\<close> have "ys = zs" by simp
   moreover from map_of have "y = z" by (rule map_upd_eqD1)
   ultimately show ?case by simp
 qed
 
 lemma map_of_zip_nth:
   assumes "length xs = length ys"
   assumes "distinct xs"
   assumes "i < length ys"
   shows "map_of (zip xs ys) (xs ! i) = Some (ys ! i)"
 using assms proof (induct arbitrary: i rule: list_induct2)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs y ys)
   then show ?case
     using less_Suc_eq_0_disj by auto
 qed
 
 lemma map_of_zip_map:
   "map_of (zip xs (map f xs)) = (\<lambda>x. if x \<in> set xs then Some (f x) else None)"
   by (induct xs) (simp_all add: fun_eq_iff)
 
 lemma finite_range_map_of: "finite (range (map_of xys))"
 proof (induct xys)
   case (Cons a xys)
   then show ?case
     using finite_range_updI by fastforce
 qed auto
 
 lemma map_of_SomeD: "map_of xs k = Some y \<Longrightarrow> (k, y) \<in> set xs"
   by (induct xs) (auto split: if_splits)
 
 lemma map_of_mapk_SomeI:
   "inj f \<Longrightarrow> map_of t k = Some x \<Longrightarrow>
    map_of (map (case_prod (\<lambda>k. Pair (f k))) t) (f k) = Some x"
 by (induct t) (auto simp: inj_eq)
 
 lemma weak_map_of_SomeI: "(k, x) \<in> set l \<Longrightarrow> \<exists>x. map_of l k = Some x"
 by (induct l) auto
 
 lemma map_of_filter_in:
   "map_of xs k = Some z \<Longrightarrow> P k z \<Longrightarrow> map_of (filter (case_prod P) xs) k = Some z"
 by (induct xs) auto
 
 lemma map_of_map:
   "map_of (map (\<lambda>(k, v). (k, f v)) xs) = map_option f \<circ> map_of xs"
   by (induct xs) (auto simp: fun_eq_iff)
 
 lemma dom_map_option:
   "dom (\<lambda>k. map_option (f k) (m k)) = dom m"
   by (simp add: dom_def)
 
 lemma dom_map_option_comp [simp]:
   "dom (map_option g \<circ> m) = dom m"
   using dom_map_option [of "\<lambda>_. g" m] by (simp add: comp_def)
 
 
 subsection \<open>\<^const>\<open>map_option\<close> related\<close>
 
 lemma map_option_o_empty [simp]: "map_option f \<circ> empty = empty"
 by (rule ext) simp
 
 lemma map_option_o_map_upd [simp]:
   "map_option f \<circ> m(a\<mapsto>b) = (map_option f \<circ> m)(a\<mapsto>f b)"
 by (rule ext) simp
 
 
 subsection \<open>@{term [source] map_comp} related\<close>
 
 lemma map_comp_empty [simp]:
   "m \<circ>\<^sub>m empty = empty"
   "empty \<circ>\<^sub>m m = empty"
 by (auto simp: map_comp_def split: option.splits)
 
 lemma map_comp_simps [simp]:
   "m2 k = None \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = None"
   "m2 k = Some k' \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = m1 k'"
 by (auto simp: map_comp_def)
 
 lemma map_comp_Some_iff:
   "((m1 \<circ>\<^sub>m m2) k = Some v) = (\<exists>k'. m2 k = Some k' \<and> m1 k' = Some v)"
 by (auto simp: map_comp_def split: option.splits)
 
 lemma map_comp_None_iff:
   "((m1 \<circ>\<^sub>m m2) k = None) = (m2 k = None \<or> (\<exists>k'. m2 k = Some k' \<and> m1 k' = None)) "
 by (auto simp: map_comp_def split: option.splits)
 
 
 subsection \<open>\<open>++\<close>\<close>
 
 lemma map_add_empty[simp]: "m ++ empty = m"
 by(simp add: map_add_def)
 
 lemma empty_map_add[simp]: "empty ++ m = m"
 by (rule ext) (simp add: map_add_def split: option.split)
 
 lemma map_add_assoc[simp]: "m1 ++ (m2 ++ m3) = (m1 ++ m2) ++ m3"
 by (rule ext) (simp add: map_add_def split: option.split)
 
 lemma map_add_Some_iff:
   "((m ++ n) k = Some x) = (n k = Some x \<or> n k = None \<and> m k = Some x)"
 by (simp add: map_add_def split: option.split)
 
 lemma map_add_SomeD [dest!]:
   "(m ++ n) k = Some x \<Longrightarrow> n k = Some x \<or> n k = None \<and> m k = Some x"
 by (rule map_add_Some_iff [THEN iffD1])
 
 lemma map_add_find_right [simp]: "n k = Some xx \<Longrightarrow> (m ++ n) k = Some xx"
 by (subst map_add_Some_iff) fast
 
 lemma map_add_None [iff]: "((m ++ n) k = None) = (n k = None \<and> m k = None)"
 by (simp add: map_add_def split: option.split)
 
 lemma map_add_upd[simp]: "f ++ g(x\<mapsto>y) = (f ++ g)(x\<mapsto>y)"
 by (rule ext) (simp add: map_add_def)
 
 lemma map_add_upds[simp]: "m1 ++ (m2(xs[\<mapsto>]ys)) = (m1++m2)(xs[\<mapsto>]ys)"
 by (simp add: map_upds_def)
 
 lemma map_add_upd_left: "m\<notin>dom e2 \<Longrightarrow> e1(m \<mapsto> u1) ++ e2 = (e1 ++ e2)(m \<mapsto> u1)"
 by (rule ext) (auto simp: map_add_def dom_def split: option.split)
 
 lemma map_of_append[simp]: "map_of (xs @ ys) = map_of ys ++ map_of xs"
   unfolding map_add_def
 proof (induct xs)
   case (Cons a xs)
   then show ?case
     by (force split: option.split)
 qed auto
 
 lemma finite_range_map_of_map_add:
   "finite (range f) \<Longrightarrow> finite (range (f ++ map_of l))"
 proof (induct l)
 case (Cons a l)
   then show ?case
     by (metis finite_range_updI map_add_upd map_of.simps(2))
 qed auto
 
 lemma inj_on_map_add_dom [iff]:
   "inj_on (m ++ m') (dom m') = inj_on m' (dom m')"
   by (fastforce simp: map_add_def dom_def inj_on_def split: option.splits)
 
 lemma map_upds_fold_map_upd:
   "m(ks[\<mapsto>]vs) = foldl (\<lambda>m (k, v). m(k \<mapsto> v)) m (zip ks vs)"
 unfolding map_upds_def proof (rule sym, rule zip_obtain_same_length)
   fix ks :: "'a list" and vs :: "'b list"
   assume "length ks = length vs"
   then show "foldl (\<lambda>m (k, v). m(k\<mapsto>v)) m (zip ks vs) = m ++ map_of (rev (zip ks vs))"
     by(induct arbitrary: m rule: list_induct2) simp_all
 qed
 
 lemma map_add_map_of_foldr:
   "m ++ map_of ps = foldr (\<lambda>(k, v) m. m(k \<mapsto> v)) ps m"
   by (induct ps) (auto simp: fun_eq_iff map_add_def)
 
 
 subsection \<open>@{term [source] restrict_map}\<close>
 
 lemma restrict_map_to_empty [simp]: "m|`{} = empty"
   by (simp add: restrict_map_def)
 
 lemma restrict_map_insert: "f |` (insert a A) = (f |` A)(a := f a)"
   by (auto simp: restrict_map_def)
 
 lemma restrict_map_empty [simp]: "empty|`D = empty"
   by (simp add: restrict_map_def)
 
 lemma restrict_in [simp]: "x \<in> A \<Longrightarrow> (m|`A) x = m x"
   by (simp add: restrict_map_def)
 
 lemma restrict_out [simp]: "x \<notin> A \<Longrightarrow> (m|`A) x = None"
   by (simp add: restrict_map_def)
 
 lemma ran_restrictD: "y \<in> ran (m|`A) \<Longrightarrow> \<exists>x\<in>A. m x = Some y"
   by (auto simp: restrict_map_def ran_def split: if_split_asm)
 
 lemma dom_restrict [simp]: "dom (m|`A) = dom m \<inter> A"
   by (auto simp: restrict_map_def dom_def split: if_split_asm)
 
 lemma restrict_upd_same [simp]: "m(x\<mapsto>y)|`(-{x}) = m|`(-{x})"
   by (rule ext) (auto simp: restrict_map_def)
 
 lemma restrict_restrict [simp]: "m|`A|`B = m|`(A\<inter>B)"
   by (rule ext) (auto simp: restrict_map_def)
 
 lemma restrict_fun_upd [simp]:
   "m(x := y)|`D = (if x \<in> D then (m|`(D-{x}))(x := y) else m|`D)"
   by (simp add: restrict_map_def fun_eq_iff)
 
 lemma fun_upd_None_restrict [simp]:
   "(m|`D)(x := None) = (if x \<in> D then m|`(D - {x}) else m|`D)"
   by (simp add: restrict_map_def fun_eq_iff)
 
 lemma fun_upd_restrict: "(m|`D)(x := y) = (m|`(D-{x}))(x := y)"
   by (simp add: restrict_map_def fun_eq_iff)
 
 lemma fun_upd_restrict_conv [simp]:
   "x \<in> D \<Longrightarrow> (m|`D)(x := y) = (m|`(D-{x}))(x := y)"
   by (rule fun_upd_restrict)
 
 lemma map_of_map_restrict:
   "map_of (map (\<lambda>k. (k, f k)) ks) = (Some \<circ> f) |` set ks"
   by (induct ks) (simp_all add: fun_eq_iff restrict_map_insert)
 
 lemma restrict_complement_singleton_eq:
   "f |` (- {x}) = f(x := None)"
   by auto
 
 
 subsection \<open>@{term [source] map_upds}\<close>
 
 lemma map_upds_Nil1 [simp]: "m([] [\<mapsto>] bs) = m"
   by (simp add: map_upds_def)
 
 lemma map_upds_Nil2 [simp]: "m(as [\<mapsto>] []) = m"
   by (simp add:map_upds_def)
 
 lemma map_upds_Cons [simp]: "m(a#as [\<mapsto>] b#bs) = (m(a\<mapsto>b))(as[\<mapsto>]bs)"
   by (simp add:map_upds_def)
 
 lemma map_upds_append1 [simp]:
   "size xs < size ys \<Longrightarrow> m(xs@[x] [\<mapsto>] ys) = m(xs [\<mapsto>] ys)(x \<mapsto> ys!size xs)"
 proof (induct xs arbitrary: ys m)
   case Nil
   then show ?case
     by (auto simp: neq_Nil_conv)
 next
   case (Cons a xs)
   then show ?case
     by (cases ys) auto
 qed
 
 lemma map_upds_list_update2_drop [simp]:
   "size xs \<le> i \<Longrightarrow> m(xs[\<mapsto>]ys[i:=y]) = m(xs[\<mapsto>]ys)"
 proof (induct xs arbitrary: m ys i)
   case Nil
   then show ?case
     by auto
 next
   case (Cons a xs)
   then show ?case
     by (cases ys) (use Cons in \<open>auto split: nat.split\<close>)
 qed
 
 text \<open>Something weirdly sensitive about this proof, which needs only four lines in apply style\<close>
 lemma map_upd_upds_conv_if:
   "(f(x\<mapsto>y))(xs [\<mapsto>] ys) =
    (if x \<in> set(take (length ys) xs) then f(xs [\<mapsto>] ys)
                                     else (f(xs [\<mapsto>] ys))(x\<mapsto>y))"
 proof (induct xs arbitrary: x y ys f)
   case (Cons a xs)
   show ?case
   proof (cases ys)
     case (Cons z zs)
     then show ?thesis
       using Cons.hyps
       apply (auto split: if_split simp: fun_upd_twist)
       using Cons.hyps apply fastforce+
       done
   qed auto
 qed auto
 
 
 lemma map_upds_twist [simp]:
   "a \<notin> set as \<Longrightarrow> m(a\<mapsto>b)(as[\<mapsto>]bs) = m(as[\<mapsto>]bs)(a\<mapsto>b)"
 using set_take_subset by (fastforce simp add: map_upd_upds_conv_if)
 
 lemma map_upds_apply_nontin [simp]:
   "x \<notin> set xs \<Longrightarrow> (f(xs[\<mapsto>]ys)) x = f x"
 proof (induct xs arbitrary: ys)
   case (Cons a xs)
   then show ?case
     by (cases ys) (auto simp: map_upd_upds_conv_if)
 qed auto
 
 lemma fun_upds_append_drop [simp]:
   "size xs = size ys \<Longrightarrow> m(xs@zs[\<mapsto>]ys) = m(xs[\<mapsto>]ys)"
 proof (induct xs arbitrary: ys)
   case (Cons a xs)
   then show ?case
     by (cases ys) (auto simp: map_upd_upds_conv_if)
 qed auto
 
 lemma fun_upds_append2_drop [simp]:
   "size xs = size ys \<Longrightarrow> m(xs[\<mapsto>]ys@zs) = m(xs[\<mapsto>]ys)"
 proof (induct xs arbitrary: ys)
   case (Cons a xs)
   then show ?case
     by (cases ys) (auto simp: map_upd_upds_conv_if)
 qed auto
 
 lemma restrict_map_upds[simp]:
   "\<lbrakk> length xs = length ys; set xs \<subseteq> D \<rbrakk>
     \<Longrightarrow> m(xs [\<mapsto>] ys)|`D = (m|`(D - set xs))(xs [\<mapsto>] ys)"
 proof (induct xs arbitrary: m ys)
   case (Cons a xs)
   then show ?case
   proof (cases ys)
     case (Cons z zs)
     with Cons.hyps Cons.prems show ?thesis
       apply (simp add: insert_absorb flip: Diff_insert)
       apply (auto simp add: map_upd_upds_conv_if)
       done
   qed auto
 qed auto
 
 
 subsection \<open>@{term [source] dom}\<close>
 
 lemma dom_eq_empty_conv [simp]: "dom f = {} \<longleftrightarrow> f = empty"
   by (auto simp: dom_def)
 
 lemma domI: "m a = Some b \<Longrightarrow> a \<in> dom m"
   by (simp add: dom_def)
 (* declare domI [intro]? *)
 
 lemma domD: "a \<in> dom m \<Longrightarrow> \<exists>b. m a = Some b"
   by (cases "m a") (auto simp add: dom_def)
 
 lemma domIff [iff, simp del, code_unfold]: "a \<in> dom m \<longleftrightarrow> m a \<noteq> None"
   by (simp add: dom_def)
 
 lemma dom_empty [simp]: "dom empty = {}"
   by (simp add: dom_def)
 
 lemma dom_fun_upd [simp]:
   "dom(f(x := y)) = (if y = None then dom f - {x} else insert x (dom f))"
   by (auto simp: dom_def)
 
 lemma dom_if:
   "dom (\<lambda>x. if P x then f x else g x) = dom f \<inter> {x. P x} \<union> dom g \<inter> {x. \<not> P x}"
   by (auto split: if_splits)
 
 lemma dom_map_of_conv_image_fst:
   "dom (map_of xys) = fst ` set xys"
   by (induct xys) (auto simp add: dom_if)
 
 lemma dom_map_of_zip [simp]: "length xs = length ys \<Longrightarrow> dom (map_of (zip xs ys)) = set xs"
   by (induct rule: list_induct2) (auto simp: dom_if)
 
 lemma finite_dom_map_of: "finite (dom (map_of l))"
   by (induct l) (auto simp: dom_def insert_Collect [symmetric])
 
 lemma dom_map_upds [simp]:
   "dom(m(xs[\<mapsto>]ys)) = set(take (length ys) xs) \<union> dom m"
 proof (induct xs arbitrary: ys)
   case (Cons a xs)
   then show ?case
     by (cases ys) (auto simp: map_upd_upds_conv_if)
 qed auto
 
 
 lemma dom_map_add [simp]: "dom (m ++ n) = dom n \<union> dom m"
   by (auto simp: dom_def)
 
 lemma dom_override_on [simp]:
   "dom (override_on f g A) =
     (dom f  - {a. a \<in> A - dom g}) \<union> {a. a \<in> A \<inter> dom g}"
   by (auto simp: dom_def override_on_def)
 
 lemma map_add_comm: "dom m1 \<inter> dom m2 = {} \<Longrightarrow> m1 ++ m2 = m2 ++ m1"
   by (rule ext) (force simp: map_add_def dom_def split: option.split)
 
 lemma map_add_dom_app_simps:
   "m \<in> dom l2 \<Longrightarrow> (l1 ++ l2) m = l2 m"
   "m \<notin> dom l1 \<Longrightarrow> (l1 ++ l2) m = l2 m"
   "m \<notin> dom l2 \<Longrightarrow> (l1 ++ l2) m = l1 m"
   by (auto simp add: map_add_def split: option.split_asm)
 
 lemma dom_const [simp]:
   "dom (\<lambda>x. Some (f x)) = UNIV"
   by auto
 
 (* Due to John Matthews - could be rephrased with dom *)
 lemma finite_map_freshness:
   "finite (dom (f :: 'a \<rightharpoonup> 'b)) \<Longrightarrow> \<not> finite (UNIV :: 'a set) \<Longrightarrow>
    \<exists>x. f x = None"
   by (bestsimp dest: ex_new_if_finite)
 
 lemma dom_minus:
   "f x = None \<Longrightarrow> dom f - insert x A = dom f - A"
   unfolding dom_def by simp
 
 lemma insert_dom:
   "f x = Some y \<Longrightarrow> insert x (dom f) = dom f"
   unfolding dom_def by auto
 
 lemma map_of_map_keys:
   "set xs = dom m \<Longrightarrow> map_of (map (\<lambda>k. (k, the (m k))) xs) = m"
   by (rule ext) (auto simp add: map_of_map_restrict restrict_map_def)
 
 lemma map_of_eqI:
   assumes set_eq: "set (map fst xs) = set (map fst ys)"
   assumes map_eq: "\<forall>k\<in>set (map fst xs). map_of xs k = map_of ys k"
   shows "map_of xs = map_of ys"
 proof (rule ext)
   fix k show "map_of xs k = map_of ys k"
   proof (cases "map_of xs k")
     case None
     then have "k \<notin> set (map fst xs)" by (simp add: map_of_eq_None_iff)
     with set_eq have "k \<notin> set (map fst ys)" by simp
     then have "map_of ys k = None" by (simp add: map_of_eq_None_iff)
     with None show ?thesis by simp
   next
     case (Some v)
     then have "k \<in> set (map fst xs)" by (auto simp add: dom_map_of_conv_image_fst [symmetric])
     with map_eq show ?thesis by auto
   qed
 qed
 
 lemma map_of_eq_dom:
   assumes "map_of xs = map_of ys"
   shows "fst ` set xs = fst ` set ys"
 proof -
   from assms have "dom (map_of xs) = dom (map_of ys)" by simp
   then show ?thesis by (simp add: dom_map_of_conv_image_fst)
 qed
 
 lemma finite_set_of_finite_maps:
   assumes "finite A" "finite B"
   shows "finite {m. dom m = A \<and> ran m \<subseteq> B}" (is "finite ?S")
 proof -
   let ?S' = "{m. \<forall>x. (x \<in> A \<longrightarrow> m x \<in> Some ` B) \<and> (x \<notin> A \<longrightarrow> m x = None)}"
   have "?S = ?S'"
   proof
     show "?S \<subseteq> ?S'" by (auto simp: dom_def ran_def image_def)
     show "?S' \<subseteq> ?S"
     proof
       fix m assume "m \<in> ?S'"
       hence 1: "dom m = A" by force
       hence 2: "ran m \<subseteq> B" using \<open>m \<in> ?S'\<close> by (auto simp: dom_def ran_def)
       from 1 2 show "m \<in> ?S" by blast
     qed
   qed
   with assms show ?thesis by(simp add: finite_set_of_finite_funs)
 qed
 
 
 subsection \<open>@{term [source] ran}\<close>
 
 lemma ranI: "m a = Some b \<Longrightarrow> b \<in> ran m"
   by (auto simp: ran_def)
 (* declare ranI [intro]? *)
 
 lemma ran_empty [simp]: "ran empty = {}"
   by (auto simp: ran_def)
 
 lemma ran_map_upd [simp]:  "m a = None \<Longrightarrow> ran(m(a\<mapsto>b)) = insert b (ran m)"
   unfolding ran_def
   by force
 
+lemma fun_upd_None_if_notin_dom[simp]: "k \<notin> dom m \<Longrightarrow> m(k := None) = m"
+  by auto
+
 lemma ran_map_add:
   assumes "dom m1 \<inter> dom m2 = {}"
   shows "ran (m1 ++ m2) = ran m1 \<union> ran m2"
 proof
   show "ran (m1 ++ m2) \<subseteq> ran m1 \<union> ran m2"
     unfolding ran_def by auto
 next
   show "ran m1 \<union> ran m2 \<subseteq> ran (m1 ++ m2)"
   proof -
     have "(m1 ++ m2) x = Some y" if "m1 x = Some y" for x y
       using assms map_add_comm that by fastforce
     moreover have "(m1 ++ m2) x = Some y" if "m2 x = Some y" for x y
       using assms that by auto
     ultimately show ?thesis
       unfolding ran_def by blast
   qed
 qed
 
 lemma finite_ran:
   assumes "finite (dom p)"
   shows "finite (ran p)"
 proof -
   have "ran p = (\<lambda>x. the (p x)) ` dom p"
     unfolding ran_def by force
   from this \<open>finite (dom p)\<close> show ?thesis by auto
 qed
 
 lemma ran_distinct:
   assumes dist: "distinct (map fst al)"
   shows "ran (map_of al) = snd ` set al"
   using assms
 proof (induct al)
   case Nil
   then show ?case by simp
 next
   case (Cons kv al)
   then have "ran (map_of al) = snd ` set al" by simp
   moreover from Cons.prems have "map_of al (fst kv) = None"
     by (simp add: map_of_eq_None_iff)
   ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
 qed
 
 lemma ran_map_of_zip:
   assumes "length xs = length ys" "distinct xs"
   shows "ran (map_of (zip xs ys)) = set ys"
 using assms by (simp add: ran_distinct set_map[symmetric])
 
 lemma ran_map_option: "ran (\<lambda>x. map_option f (m x)) = f ` ran m"
   by (auto simp add: ran_def)
 
+subsection \<open>@{term [source] graph}\<close>
+
+lemma graph_empty[simp]: "graph empty = {}"
+  unfolding graph_def by simp
+
+lemma in_graphI: "m k = Some v \<Longrightarrow> (k, v) \<in> graph m"
+  unfolding graph_def by blast
+
+lemma in_graphD: "(k, v) \<in> graph m \<Longrightarrow> m k = Some v"
+  unfolding graph_def by blast
+
+lemma graph_map_upd[simp]: "graph (m(k \<mapsto> v)) = insert (k, v) (graph (m(k := None)))"
+  unfolding graph_def by (auto split: if_splits)
+
+lemma graph_fun_upd_None: "graph (m(k := None)) = {e \<in> graph m. fst e \<noteq> k}"
+  unfolding graph_def by (auto split: if_splits)
+
+lemma graph_restrictD:
+  assumes "(k, v) \<in> graph (m |` A)"
+  shows "k \<in> A" and "m k = Some v"
+  using assms unfolding graph_def
+  by (auto simp: restrict_map_def split: if_splits)
+
+lemma graph_map_comp[simp]: "graph (m1 \<circ>\<^sub>m m2) = graph m2 O graph m1"
+  unfolding graph_def by (auto simp: map_comp_Some_iff relcomp_unfold)
+
+lemma graph_map_add: "dom m1 \<inter> dom m2 = {} \<Longrightarrow> graph (m1 ++ m2) = graph m1 \<union> graph m2"
+  unfolding graph_def using map_add_comm by force
+
+lemma graph_eq_to_snd_dom: "graph m = (\<lambda>x. (x, the (m x))) ` dom m"
+  unfolding graph_def dom_def by force
+
+lemma fst_graph_eq_dom: "fst ` graph m = dom m"
+  unfolding graph_eq_to_snd_dom by force
+
+lemma graph_domD: "x \<in> graph m \<Longrightarrow> fst x \<in> dom m"
+  using fst_graph_eq_dom by (metis imageI)
+
+lemma snd_graph_ran: "snd ` graph m = ran m"
+  unfolding graph_def ran_def by force
+
+lemma graph_ranD: "x \<in> graph m \<Longrightarrow> snd x \<in> ran m"
+  using snd_graph_ran by (metis imageI)
+
+lemma finite_graph_map_of: "finite (graph (map_of al))"
+  unfolding graph_eq_to_snd_dom finite_dom_map_of
+  using finite_dom_map_of by blast
+
+lemma graph_map_of_if_distinct_ran: "distinct (map fst al) \<Longrightarrow> graph (map_of al) = set al"
+  unfolding graph_def by auto
+
+lemma finite_graph_iff_finite_dom[simp]: "finite (graph m) = finite (dom m)"
+  by (metis graph_eq_to_snd_dom finite_imageI fst_graph_eq_dom)
+
+lemma inj_on_fst_graph: "inj_on fst (graph m)"
+  unfolding graph_def inj_on_def by force
 
 subsection \<open>\<open>map_le\<close>\<close>
 
 lemma map_le_empty [simp]: "empty \<subseteq>\<^sub>m g"
   by (simp add: map_le_def)
 
 lemma upd_None_map_le [simp]: "f(x := None) \<subseteq>\<^sub>m f"
   by (force simp add: map_le_def)
 
 lemma map_le_upd[simp]: "f \<subseteq>\<^sub>m g ==> f(a := b) \<subseteq>\<^sub>m g(a := b)"
   by (fastforce simp add: map_le_def)
 
 lemma map_le_imp_upd_le [simp]: "m1 \<subseteq>\<^sub>m m2 \<Longrightarrow> m1(x := None) \<subseteq>\<^sub>m m2(x \<mapsto> y)"
   by (force simp add: map_le_def)
 
 lemma map_le_upds [simp]:
   "f \<subseteq>\<^sub>m g \<Longrightarrow> f(as [\<mapsto>] bs) \<subseteq>\<^sub>m g(as [\<mapsto>] bs)"
 proof (induct as arbitrary: f g bs)
   case (Cons a as)
   then show ?case
     by (cases bs) (use Cons in auto)
 qed auto
 
 lemma map_le_implies_dom_le: "(f \<subseteq>\<^sub>m g) \<Longrightarrow> (dom f \<subseteq> dom g)"
   by (fastforce simp add: map_le_def dom_def)
 
 lemma map_le_refl [simp]: "f \<subseteq>\<^sub>m f"
   by (simp add: map_le_def)
 
 lemma map_le_trans[trans]: "\<lbrakk> m1 \<subseteq>\<^sub>m m2; m2 \<subseteq>\<^sub>m m3\<rbrakk> \<Longrightarrow> m1 \<subseteq>\<^sub>m m3"
   by (auto simp add: map_le_def dom_def)
 
 lemma map_le_antisym: "\<lbrakk> f \<subseteq>\<^sub>m g; g \<subseteq>\<^sub>m f \<rbrakk> \<Longrightarrow> f = g"
   unfolding map_le_def
   by (metis ext domIff)
 
 lemma map_le_map_add [simp]: "f \<subseteq>\<^sub>m g ++ f"
   by (fastforce simp: map_le_def)
 
 lemma map_le_iff_map_add_commute: "f \<subseteq>\<^sub>m f ++ g \<longleftrightarrow> f ++ g = g ++ f"
   by (fastforce simp: map_add_def map_le_def fun_eq_iff split: option.splits)
 
 lemma map_add_le_mapE: "f ++ g \<subseteq>\<^sub>m h \<Longrightarrow> g \<subseteq>\<^sub>m h"
   by (fastforce simp: map_le_def map_add_def dom_def)
 
 lemma map_add_le_mapI: "\<lbrakk> f \<subseteq>\<^sub>m h; g \<subseteq>\<^sub>m h \<rbrakk> \<Longrightarrow> f ++ g \<subseteq>\<^sub>m h"
   by (auto simp: map_le_def map_add_def dom_def split: option.splits)
 
 lemma map_add_subsumed1: "f \<subseteq>\<^sub>m g \<Longrightarrow> f++g = g"
 by (simp add: map_add_le_mapI map_le_antisym)
 
 lemma map_add_subsumed2: "f \<subseteq>\<^sub>m g \<Longrightarrow> g++f = g"
 by (metis map_add_subsumed1 map_le_iff_map_add_commute)
 
 lemma dom_eq_singleton_conv: "dom f = {x} \<longleftrightarrow> (\<exists>v. f = [x \<mapsto> v])"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs by (auto split: if_split_asm)
 next
   assume ?lhs
   then obtain v where v: "f x = Some v" by auto
   show ?rhs
   proof
     show "f = [x \<mapsto> v]"
     proof (rule map_le_antisym)
       show "[x \<mapsto> v] \<subseteq>\<^sub>m f"
         using v by (auto simp add: map_le_def)
       show "f \<subseteq>\<^sub>m [x \<mapsto> v]"
         using \<open>dom f = {x}\<close> \<open>f x = Some v\<close> by (auto simp add: map_le_def)
     qed
   qed
 qed
 
 lemma map_add_eq_empty_iff[simp]:
   "(f++g = empty) \<longleftrightarrow> f = empty \<and> g = empty"
 by (metis map_add_None)
 
 lemma empty_eq_map_add_iff[simp]:
   "(empty = f++g) \<longleftrightarrow> f = empty \<and> g = empty"
 by(subst map_add_eq_empty_iff[symmetric])(rule eq_commute)
 
 
 subsection \<open>Various\<close>
 
 lemma set_map_of_compr:
   assumes distinct: "distinct (map fst xs)"
   shows "set xs = {(k, v). map_of xs k = Some v}"
   using assms
 proof (induct xs)
   case Nil
   then show ?case by simp
 next
   case (Cons x xs)
   obtain k v where "x = (k, v)" by (cases x) blast
   with Cons.prems have "k \<notin> dom (map_of xs)"
     by (simp add: dom_map_of_conv_image_fst)
   then have *: "insert (k, v) {(k, v). map_of xs k = Some v} =
     {(k', v'). (map_of xs(k \<mapsto> v)) k' = Some v'}"
     by (auto split: if_splits)
   from Cons have "set xs = {(k, v). map_of xs k = Some v}" by simp
   with * \<open>x = (k, v)\<close> show ?case by simp
 qed
 
 lemma eq_key_imp_eq_value:
   "v1 = v2"
   if "distinct (map fst xs)" "(k, v1) \<in> set xs" "(k, v2) \<in> set xs"
 proof -
   from that have "inj_on fst (set xs)"
     by (simp add: distinct_map)
   moreover have "fst (k, v1) = fst (k, v2)"
     by simp
   ultimately have "(k, v1) = (k, v2)"
     by (rule inj_onD) (fact that)+
   then show ?thesis
     by simp
 qed
 
 lemma map_of_inject_set:
   assumes distinct: "distinct (map fst xs)" "distinct (map fst ys)"
   shows "map_of xs = map_of ys \<longleftrightarrow> set xs = set ys" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   moreover from \<open>distinct (map fst xs)\<close> have "set xs = {(k, v). map_of xs k = Some v}"
     by (rule set_map_of_compr)
   moreover from \<open>distinct (map fst ys)\<close> have "set ys = {(k, v). map_of ys k = Some v}"
     by (rule set_map_of_compr)
   ultimately show ?rhs by simp
 next
   assume ?rhs show ?lhs
   proof
     fix k
     show "map_of xs k = map_of ys k"
     proof (cases "map_of xs k")
       case None
       with \<open>?rhs\<close> have "map_of ys k = None"
         by (simp add: map_of_eq_None_iff)
       with None show ?thesis by simp
     next
       case (Some v)
       with distinct \<open>?rhs\<close> have "map_of ys k = Some v"
         by simp
       with Some show ?thesis by simp
     qed
   qed
 qed
 
-hide_const (open) Map.empty
+lemma finite_Map_induct[consumes 1, case_names empty update]:
+  assumes "finite (dom m)"
+  assumes "P Map.empty"
+  assumes "\<And>k v m. finite (dom m) \<Longrightarrow> k \<notin> dom m \<Longrightarrow> P m \<Longrightarrow> P (m(k \<mapsto> v))"
+  shows "P m"
+  using assms(1)
+proof(induction "dom m" arbitrary: m rule: finite_induct)
+  case empty
+  then show ?case using assms(2) unfolding dom_def by simp
+next
+  case (insert x F) 
+  then have "finite (dom (m(x:=None)))" "x \<notin> dom (m(x:=None))" "P (m(x:=None))"
+    by (metis Diff_insert_absorb dom_fun_upd)+
+  with assms(3)[OF this] show ?case
+    by (metis fun_upd_triv fun_upd_upd option.exhaust)
+qed
+
+hide_const (open) Map.empty Map.graph
 
 end
diff --git a/src/HOL/Relation.thy b/src/HOL/Relation.thy
--- a/src/HOL/Relation.thy
+++ b/src/HOL/Relation.thy
@@ -1,1250 +1,1253 @@
 (*  Title:      HOL/Relation.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Author:     Stefan Berghofer, TU Muenchen
 *)
 
 section \<open>Relations -- as sets of pairs, and binary predicates\<close>
 
 theory Relation
   imports Finite_Set
 begin
 
 text \<open>A preliminary: classical rules for reasoning on predicates\<close>
 
 declare predicate1I [Pure.intro!, intro!]
 declare predicate1D [Pure.dest, dest]
 declare predicate2I [Pure.intro!, intro!]
 declare predicate2D [Pure.dest, dest]
 declare bot1E [elim!]
 declare bot2E [elim!]
 declare top1I [intro!]
 declare top2I [intro!]
 declare inf1I [intro!]
 declare inf2I [intro!]
 declare inf1E [elim!]
 declare inf2E [elim!]
 declare sup1I1 [intro?]
 declare sup2I1 [intro?]
 declare sup1I2 [intro?]
 declare sup2I2 [intro?]
 declare sup1E [elim!]
 declare sup2E [elim!]
 declare sup1CI [intro!]
 declare sup2CI [intro!]
 declare Inf1_I [intro!]
 declare INF1_I [intro!]
 declare Inf2_I [intro!]
 declare INF2_I [intro!]
 declare Inf1_D [elim]
 declare INF1_D [elim]
 declare Inf2_D [elim]
 declare INF2_D [elim]
 declare Inf1_E [elim]
 declare INF1_E [elim]
 declare Inf2_E [elim]
 declare INF2_E [elim]
 declare Sup1_I [intro]
 declare SUP1_I [intro]
 declare Sup2_I [intro]
 declare SUP2_I [intro]
 declare Sup1_E [elim!]
 declare SUP1_E [elim!]
 declare Sup2_E [elim!]
 declare SUP2_E [elim!]
 
 
 subsection \<open>Fundamental\<close>
 
 subsubsection \<open>Relations as sets of pairs\<close>
 
 type_synonym 'a rel = "('a \<times> 'a) set"
 
 lemma subrelI: "(\<And>x y. (x, y) \<in> r \<Longrightarrow> (x, y) \<in> s) \<Longrightarrow> r \<subseteq> s"
   \<comment> \<open>Version of @{thm [source] subsetI} for binary relations\<close>
   by auto
 
 lemma lfp_induct2:
   "(a, b) \<in> lfp f \<Longrightarrow> mono f \<Longrightarrow>
     (\<And>a b. (a, b) \<in> f (lfp f \<inter> {(x, y). P x y}) \<Longrightarrow> P a b) \<Longrightarrow> P a b"
   \<comment> \<open>Version of @{thm [source] lfp_induct} for binary relations\<close>
   using lfp_induct_set [of "(a, b)" f "case_prod P"] by auto
 
 
 subsubsection \<open>Conversions between set and predicate relations\<close>
 
 lemma pred_equals_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) = (\<lambda>x. x \<in> S) \<longleftrightarrow> R = S"
   by (simp add: set_eq_iff fun_eq_iff)
 
 lemma pred_equals_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) = (\<lambda>x y. (x, y) \<in> S) \<longleftrightarrow> R = S"
   by (simp add: set_eq_iff fun_eq_iff)
 
 lemma pred_subset_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) \<le> (\<lambda>x. x \<in> S) \<longleftrightarrow> R \<subseteq> S"
   by (simp add: subset_iff le_fun_def)
 
 lemma pred_subset_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) \<le> (\<lambda>x y. (x, y) \<in> S) \<longleftrightarrow> R \<subseteq> S"
   by (simp add: subset_iff le_fun_def)
 
 lemma bot_empty_eq [pred_set_conv]: "\<bottom> = (\<lambda>x. x \<in> {})"
   by (auto simp add: fun_eq_iff)
 
 lemma bot_empty_eq2 [pred_set_conv]: "\<bottom> = (\<lambda>x y. (x, y) \<in> {})"
   by (auto simp add: fun_eq_iff)
 
 lemma top_empty_eq [pred_set_conv]: "\<top> = (\<lambda>x. x \<in> UNIV)"
   by (auto simp add: fun_eq_iff)
 
 lemma top_empty_eq2 [pred_set_conv]: "\<top> = (\<lambda>x y. (x, y) \<in> UNIV)"
   by (auto simp add: fun_eq_iff)
 
 lemma inf_Int_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) \<sqinter> (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<inter> S)"
   by (simp add: inf_fun_def)
 
 lemma inf_Int_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) \<sqinter> (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<inter> S)"
   by (simp add: inf_fun_def)
 
 lemma sup_Un_eq [pred_set_conv]: "(\<lambda>x. x \<in> R) \<squnion> (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<union> S)"
   by (simp add: sup_fun_def)
 
 lemma sup_Un_eq2 [pred_set_conv]: "(\<lambda>x y. (x, y) \<in> R) \<squnion> (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<union> S)"
   by (simp add: sup_fun_def)
 
 lemma INF_INT_eq [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (\<Inter>i\<in>S. r i))"
   by (simp add: fun_eq_iff)
 
 lemma INF_INT_eq2 [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (\<Inter>i\<in>S. r i))"
   by (simp add: fun_eq_iff)
 
 lemma SUP_UN_eq [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (\<Union>i\<in>S. r i))"
   by (simp add: fun_eq_iff)
 
 lemma SUP_UN_eq2 [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (\<Union>i\<in>S. r i))"
   by (simp add: fun_eq_iff)
 
 lemma Inf_INT_eq [pred_set_conv]: "\<Sqinter>S = (\<lambda>x. x \<in> (\<Inter>(Collect ` S)))"
   by (simp add: fun_eq_iff)
 
 lemma INF_Int_eq [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x. x \<in> i)) = (\<lambda>x. x \<in> \<Inter>S)"
   by (simp add: fun_eq_iff)
 
 lemma Inf_INT_eq2 [pred_set_conv]: "\<Sqinter>S = (\<lambda>x y. (x, y) \<in> (\<Inter>(Collect ` case_prod ` S)))"
   by (simp add: fun_eq_iff)
 
 lemma INF_Int_eq2 [pred_set_conv]: "(\<Sqinter>i\<in>S. (\<lambda>x y. (x, y) \<in> i)) = (\<lambda>x y. (x, y) \<in> \<Inter>S)"
   by (simp add: fun_eq_iff)
 
 lemma Sup_SUP_eq [pred_set_conv]: "\<Squnion>S = (\<lambda>x. x \<in> \<Union>(Collect ` S))"
   by (simp add: fun_eq_iff)
 
 lemma SUP_Sup_eq [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x. x \<in> i)) = (\<lambda>x. x \<in> \<Union>S)"
   by (simp add: fun_eq_iff)
 
 lemma Sup_SUP_eq2 [pred_set_conv]: "\<Squnion>S = (\<lambda>x y. (x, y) \<in> (\<Union>(Collect ` case_prod ` S)))"
   by (simp add: fun_eq_iff)
 
 lemma SUP_Sup_eq2 [pred_set_conv]: "(\<Squnion>i\<in>S. (\<lambda>x y. (x, y) \<in> i)) = (\<lambda>x y. (x, y) \<in> \<Union>S)"
   by (simp add: fun_eq_iff)
 
 
 subsection \<open>Properties of relations\<close>
 
 subsubsection \<open>Reflexivity\<close>
 
 definition refl_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> bool"
   where "refl_on A r \<longleftrightarrow> r \<subseteq> A \<times> A \<and> (\<forall>x\<in>A. (x, x) \<in> r)"
 
 abbreviation refl :: "'a rel \<Rightarrow> bool" \<comment> \<open>reflexivity over a type\<close>
   where "refl \<equiv> refl_on UNIV"
 
 definition reflp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "reflp r \<longleftrightarrow> (\<forall>x. r x x)"
 
 lemma reflp_refl_eq [pred_set_conv]: "reflp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> refl r"
   by (simp add: refl_on_def reflp_def)
 
 lemma refl_onI [intro?]: "r \<subseteq> A \<times> A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> (x, x) \<in> r) \<Longrightarrow> refl_on A r"
   unfolding refl_on_def by (iprover intro!: ballI)
 
 lemma refl_onD: "refl_on A r \<Longrightarrow> a \<in> A \<Longrightarrow> (a, a) \<in> r"
   unfolding refl_on_def by blast
 
 lemma refl_onD1: "refl_on A r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> x \<in> A"
   unfolding refl_on_def by blast
 
 lemma refl_onD2: "refl_on A r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> A"
   unfolding refl_on_def by blast
 
 lemma reflpI [intro?]: "(\<And>x. r x x) \<Longrightarrow> reflp r"
   by (auto intro: refl_onI simp add: reflp_def)
 
 lemma reflpE:
   assumes "reflp r"
   obtains "r x x"
   using assms by (auto dest: refl_onD simp add: reflp_def)
 
 lemma reflpD [dest?]:
   assumes "reflp r"
   shows "r x x"
   using assms by (auto elim: reflpE)
 
 lemma refl_on_Int: "refl_on A r \<Longrightarrow> refl_on B s \<Longrightarrow> refl_on (A \<inter> B) (r \<inter> s)"
   unfolding refl_on_def by blast
 
 lemma reflp_inf: "reflp r \<Longrightarrow> reflp s \<Longrightarrow> reflp (r \<sqinter> s)"
   by (auto intro: reflpI elim: reflpE)
 
 lemma refl_on_Un: "refl_on A r \<Longrightarrow> refl_on B s \<Longrightarrow> refl_on (A \<union> B) (r \<union> s)"
   unfolding refl_on_def by blast
 
 lemma reflp_sup: "reflp r \<Longrightarrow> reflp s \<Longrightarrow> reflp (r \<squnion> s)"
   by (auto intro: reflpI elim: reflpE)
 
 lemma refl_on_INTER: "\<forall>x\<in>S. refl_on (A x) (r x) \<Longrightarrow> refl_on (\<Inter>(A ` S)) (\<Inter>(r ` S))"
   unfolding refl_on_def by fast
 
 lemma refl_on_UNION: "\<forall>x\<in>S. refl_on (A x) (r x) \<Longrightarrow> refl_on (\<Union>(A ` S)) (\<Union>(r ` S))"
   unfolding refl_on_def by blast
 
 lemma refl_on_empty [simp]: "refl_on {} {}"
   by (simp add: refl_on_def)
 
 lemma refl_on_singleton [simp]: "refl_on {x} {(x, x)}"
 by (blast intro: refl_onI)
 
 lemma refl_on_def' [nitpick_unfold, code]:
   "refl_on A r \<longleftrightarrow> (\<forall>(x, y) \<in> r. x \<in> A \<and> y \<in> A) \<and> (\<forall>x \<in> A. (x, x) \<in> r)"
   by (auto intro: refl_onI dest: refl_onD refl_onD1 refl_onD2)
 
 lemma reflp_equality [simp]: "reflp (=)"
   by (simp add: reflp_def)
 
 lemma reflp_mono: "reflp R \<Longrightarrow> (\<And>x y. R x y \<longrightarrow> Q x y) \<Longrightarrow> reflp Q"
   by (auto intro: reflpI dest: reflpD)
 
 
 subsubsection \<open>Irreflexivity\<close>
 
 definition irrefl :: "'a rel \<Rightarrow> bool"
   where "irrefl r \<longleftrightarrow> (\<forall>a. (a, a) \<notin> r)"
 
 definition irreflp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "irreflp R \<longleftrightarrow> (\<forall>a. \<not> R a a)"
 
 lemma irreflp_irrefl_eq [pred_set_conv]: "irreflp (\<lambda>a b. (a, b) \<in> R) \<longleftrightarrow> irrefl R"
   by (simp add: irrefl_def irreflp_def)
 
 lemma irreflI [intro?]: "(\<And>a. (a, a) \<notin> R) \<Longrightarrow> irrefl R"
   by (simp add: irrefl_def)
 
 lemma irreflpI [intro?]: "(\<And>a. \<not> R a a) \<Longrightarrow> irreflp R"
   by (fact irreflI [to_pred])
 
 lemma irrefl_distinct [code]: "irrefl r \<longleftrightarrow> (\<forall>(a, b) \<in> r. a \<noteq> b)"
   by (auto simp add: irrefl_def)
 
 
 subsubsection \<open>Asymmetry\<close>
 
 inductive asym :: "'a rel \<Rightarrow> bool"
   where asymI: "(\<And>a b. (a, b) \<in> R \<Longrightarrow> (b, a) \<notin> R) \<Longrightarrow> asym R"
 
 inductive asymp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where asympI: "(\<And>a b. R a b \<Longrightarrow> \<not> R b a) \<Longrightarrow> asymp R"
 
 lemma asymp_asym_eq [pred_set_conv]: "asymp (\<lambda>a b. (a, b) \<in> R) \<longleftrightarrow> asym R"
   by (auto intro!: asymI asympI elim: asym.cases asymp.cases simp add: irreflp_irrefl_eq)
 
 lemma asymD: "\<lbrakk>asym R; (x,y) \<in> R\<rbrakk> \<Longrightarrow> (y,x) \<notin> R"
   by (simp add: asym.simps)
 
 lemma asym_iff: "asym R \<longleftrightarrow> (\<forall>x y. (x,y) \<in> R \<longrightarrow> (y,x) \<notin> R)"
   by (blast intro: asymI dest: asymD)
 
 subsubsection \<open>Symmetry\<close>
 
 definition sym :: "'a rel \<Rightarrow> bool"
   where "sym r \<longleftrightarrow> (\<forall>x y. (x, y) \<in> r \<longrightarrow> (y, x) \<in> r)"
 
 definition symp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "symp r \<longleftrightarrow> (\<forall>x y. r x y \<longrightarrow> r y x)"
 
 lemma symp_sym_eq [pred_set_conv]: "symp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> sym r"
   by (simp add: sym_def symp_def)
 
 lemma symI [intro?]: "(\<And>a b. (a, b) \<in> r \<Longrightarrow> (b, a) \<in> r) \<Longrightarrow> sym r"
   by (unfold sym_def) iprover
 
 lemma sympI [intro?]: "(\<And>a b. r a b \<Longrightarrow> r b a) \<Longrightarrow> symp r"
   by (fact symI [to_pred])
 
 lemma symE:
   assumes "sym r" and "(b, a) \<in> r"
   obtains "(a, b) \<in> r"
   using assms by (simp add: sym_def)
 
 lemma sympE:
   assumes "symp r" and "r b a"
   obtains "r a b"
   using assms by (rule symE [to_pred])
 
 lemma symD [dest?]:
   assumes "sym r" and "(b, a) \<in> r"
   shows "(a, b) \<in> r"
   using assms by (rule symE)
 
 lemma sympD [dest?]:
   assumes "symp r" and "r b a"
   shows "r a b"
   using assms by (rule symD [to_pred])
 
 lemma sym_Int: "sym r \<Longrightarrow> sym s \<Longrightarrow> sym (r \<inter> s)"
   by (fast intro: symI elim: symE)
 
 lemma symp_inf: "symp r \<Longrightarrow> symp s \<Longrightarrow> symp (r \<sqinter> s)"
   by (fact sym_Int [to_pred])
 
 lemma sym_Un: "sym r \<Longrightarrow> sym s \<Longrightarrow> sym (r \<union> s)"
   by (fast intro: symI elim: symE)
 
 lemma symp_sup: "symp r \<Longrightarrow> symp s \<Longrightarrow> symp (r \<squnion> s)"
   by (fact sym_Un [to_pred])
 
 lemma sym_INTER: "\<forall>x\<in>S. sym (r x) \<Longrightarrow> sym (\<Inter>(r ` S))"
   by (fast intro: symI elim: symE)
 
 lemma symp_INF: "\<forall>x\<in>S. symp (r x) \<Longrightarrow> symp (\<Sqinter>(r ` S))"
   by (fact sym_INTER [to_pred])
 
 lemma sym_UNION: "\<forall>x\<in>S. sym (r x) \<Longrightarrow> sym (\<Union>(r ` S))"
   by (fast intro: symI elim: symE)
 
 lemma symp_SUP: "\<forall>x\<in>S. symp (r x) \<Longrightarrow> symp (\<Squnion>(r ` S))"
   by (fact sym_UNION [to_pred])
 
 
 subsubsection \<open>Antisymmetry\<close>
 
 definition antisym :: "'a rel \<Rightarrow> bool"
   where "antisym r \<longleftrightarrow> (\<forall>x y. (x, y) \<in> r \<longrightarrow> (y, x) \<in> r \<longrightarrow> x = y)"
 
 definition antisymp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "antisymp r \<longleftrightarrow> (\<forall>x y. r x y \<longrightarrow> r y x \<longrightarrow> x = y)"
 
 lemma antisymp_antisym_eq [pred_set_conv]: "antisymp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> antisym r"
   by (simp add: antisym_def antisymp_def)
 
 lemma antisymI [intro?]:
   "(\<And>x y. (x, y) \<in> r \<Longrightarrow> (y, x) \<in> r \<Longrightarrow> x = y) \<Longrightarrow> antisym r"
   unfolding antisym_def by iprover
 
 lemma antisympI [intro?]:
   "(\<And>x y. r x y \<Longrightarrow> r y x \<Longrightarrow> x = y) \<Longrightarrow> antisymp r"
   by (fact antisymI [to_pred])
     
 lemma antisymD [dest?]:
   "antisym r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> (b, a) \<in> r \<Longrightarrow> a = b"
   unfolding antisym_def by iprover
 
 lemma antisympD [dest?]:
   "antisymp r \<Longrightarrow> r a b \<Longrightarrow> r b a \<Longrightarrow> a = b"
   by (fact antisymD [to_pred])
 
 lemma antisym_subset:
   "r \<subseteq> s \<Longrightarrow> antisym s \<Longrightarrow> antisym r"
   unfolding antisym_def by blast
 
 lemma antisymp_less_eq:
   "r \<le> s \<Longrightarrow> antisymp s \<Longrightarrow> antisymp r"
   by (fact antisym_subset [to_pred])
     
 lemma antisym_empty [simp]:
   "antisym {}"
   unfolding antisym_def by blast
 
 lemma antisym_bot [simp]:
   "antisymp \<bottom>"
   by (fact antisym_empty [to_pred])
     
 lemma antisymp_equality [simp]:
   "antisymp HOL.eq"
   by (auto intro: antisympI)
 
 lemma antisym_singleton [simp]:
   "antisym {x}"
   by (blast intro: antisymI)
 
 
 subsubsection \<open>Transitivity\<close>
 
 definition trans :: "'a rel \<Rightarrow> bool"
   where "trans r \<longleftrightarrow> (\<forall>x y z. (x, y) \<in> r \<longrightarrow> (y, z) \<in> r \<longrightarrow> (x, z) \<in> r)"
 
 definition transp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "transp r \<longleftrightarrow> (\<forall>x y z. r x y \<longrightarrow> r y z \<longrightarrow> r x z)"
 
 lemma transp_trans_eq [pred_set_conv]: "transp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> trans r"
   by (simp add: trans_def transp_def)
 
 lemma transI [intro?]: "(\<And>x y z. (x, y) \<in> r \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> (x, z) \<in> r) \<Longrightarrow> trans r"
   by (unfold trans_def) iprover
 
 lemma transpI [intro?]: "(\<And>x y z. r x y \<Longrightarrow> r y z \<Longrightarrow> r x z) \<Longrightarrow> transp r"
   by (fact transI [to_pred])
 
 lemma transE:
   assumes "trans r" and "(x, y) \<in> r" and "(y, z) \<in> r"
   obtains "(x, z) \<in> r"
   using assms by (unfold trans_def) iprover
 
 lemma transpE:
   assumes "transp r" and "r x y" and "r y z"
   obtains "r x z"
   using assms by (rule transE [to_pred])
 
 lemma transD [dest?]:
   assumes "trans r" and "(x, y) \<in> r" and "(y, z) \<in> r"
   shows "(x, z) \<in> r"
   using assms by (rule transE)
 
 lemma transpD [dest?]:
   assumes "transp r" and "r x y" and "r y z"
   shows "r x z"
   using assms by (rule transD [to_pred])
 
 lemma trans_Int: "trans r \<Longrightarrow> trans s \<Longrightarrow> trans (r \<inter> s)"
   by (fast intro: transI elim: transE)
 
 lemma transp_inf: "transp r \<Longrightarrow> transp s \<Longrightarrow> transp (r \<sqinter> s)"
   by (fact trans_Int [to_pred])
 
 lemma trans_INTER: "\<forall>x\<in>S. trans (r x) \<Longrightarrow> trans (\<Inter>(r ` S))"
   by (fast intro: transI elim: transD)
 
 lemma transp_INF: "\<forall>x\<in>S. transp (r x) \<Longrightarrow> transp (\<Sqinter>(r ` S))"
   by (fact trans_INTER [to_pred])
     
 lemma trans_join [code]: "trans r \<longleftrightarrow> (\<forall>(x, y1) \<in> r. \<forall>(y2, z) \<in> r. y1 = y2 \<longrightarrow> (x, z) \<in> r)"
   by (auto simp add: trans_def)
 
 lemma transp_trans: "transp r \<longleftrightarrow> trans {(x, y). r x y}"
   by (simp add: trans_def transp_def)
 
 lemma transp_equality [simp]: "transp (=)"
   by (auto intro: transpI)
 
 lemma trans_empty [simp]: "trans {}"
   by (blast intro: transI)
 
 lemma transp_empty [simp]: "transp (\<lambda>x y. False)"
   using trans_empty[to_pred] by (simp add: bot_fun_def)
 
 lemma trans_singleton [simp]: "trans {(a, a)}"
   by (blast intro: transI)
 
 lemma transp_singleton [simp]: "transp (\<lambda>x y. x = a \<and> y = a)"
   by (simp add: transp_def)
 
 context preorder
 begin
 
 lemma transp_le[simp]: "transp (\<le>)"
 by(auto simp add: transp_def intro: order_trans)
 
 lemma transp_less[simp]: "transp (<)"
 by(auto simp add: transp_def intro: less_trans)
 
 lemma transp_ge[simp]: "transp (\<ge>)"
 by(auto simp add: transp_def intro: order_trans)
 
 lemma transp_gr[simp]: "transp (>)"
 by(auto simp add: transp_def intro: less_trans)
 
 end
 
 subsubsection \<open>Totality\<close>
 
 definition total_on :: "'a set \<Rightarrow> 'a rel \<Rightarrow> bool"
   where "total_on A r \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. x \<noteq> y \<longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r)"
 
 lemma total_onI [intro?]:
   "(\<And>x y. \<lbrakk>x \<in> A; y \<in> A; x \<noteq> y\<rbrakk> \<Longrightarrow> (x, y) \<in> r \<or> (y, x) \<in> r) \<Longrightarrow> total_on A r"
   unfolding total_on_def by blast
 
 abbreviation "total \<equiv> total_on UNIV"
 
 lemma total_on_empty [simp]: "total_on {} r"
   by (simp add: total_on_def)
 
 lemma total_on_singleton [simp]: "total_on {x} {(x, x)}"
   unfolding total_on_def by blast
 
 
 subsubsection \<open>Single valued relations\<close>
 
 definition single_valued :: "('a \<times> 'b) set \<Rightarrow> bool"
   where "single_valued r \<longleftrightarrow> (\<forall>x y. (x, y) \<in> r \<longrightarrow> (\<forall>z. (x, z) \<in> r \<longrightarrow> y = z))"
 
 definition single_valuedp :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
   where "single_valuedp r \<longleftrightarrow> (\<forall>x y. r x y \<longrightarrow> (\<forall>z. r x z \<longrightarrow> y = z))"
 
 lemma single_valuedp_single_valued_eq [pred_set_conv]:
   "single_valuedp (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> single_valued r"
   by (simp add: single_valued_def single_valuedp_def)
 
 lemma single_valuedp_iff_Uniq:
   "single_valuedp r \<longleftrightarrow> (\<forall>x. \<exists>\<^sub>\<le>\<^sub>1y. r x y)"
   unfolding Uniq_def single_valuedp_def by auto
 
 lemma single_valuedI:
   "(\<And>x y. (x, y) \<in> r \<Longrightarrow> (\<And>z. (x, z) \<in> r \<Longrightarrow> y = z)) \<Longrightarrow> single_valued r"
   unfolding single_valued_def by blast
 
 lemma single_valuedpI:
   "(\<And>x y. r x y \<Longrightarrow> (\<And>z. r x z \<Longrightarrow> y = z)) \<Longrightarrow> single_valuedp r"
   by (fact single_valuedI [to_pred])
 
 lemma single_valuedD:
   "single_valued r \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> (x, z) \<in> r \<Longrightarrow> y = z"
   by (simp add: single_valued_def)
 
 lemma single_valuedpD:
   "single_valuedp r \<Longrightarrow> r x y \<Longrightarrow> r x z \<Longrightarrow> y = z"
   by (fact single_valuedD [to_pred])
 
 lemma single_valued_empty [simp]:
   "single_valued {}"
   by (simp add: single_valued_def)
 
 lemma single_valuedp_bot [simp]:
   "single_valuedp \<bottom>"
   by (fact single_valued_empty [to_pred])
 
 lemma single_valued_subset:
   "r \<subseteq> s \<Longrightarrow> single_valued s \<Longrightarrow> single_valued r"
   unfolding single_valued_def by blast
 
 lemma single_valuedp_less_eq:
   "r \<le> s \<Longrightarrow> single_valuedp s \<Longrightarrow> single_valuedp r"
   by (fact single_valued_subset [to_pred])
 
 
 subsection \<open>Relation operations\<close>
 
 subsubsection \<open>The identity relation\<close>
 
 definition Id :: "'a rel"
   where "Id = {p. \<exists>x. p = (x, x)}"
 
 lemma IdI [intro]: "(a, a) \<in> Id"
   by (simp add: Id_def)
 
 lemma IdE [elim!]: "p \<in> Id \<Longrightarrow> (\<And>x. p = (x, x) \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding Id_def by (iprover elim: CollectE)
 
 lemma pair_in_Id_conv [iff]: "(a, b) \<in> Id \<longleftrightarrow> a = b"
   unfolding Id_def by blast
 
 lemma refl_Id: "refl Id"
   by (simp add: refl_on_def)
 
 lemma antisym_Id: "antisym Id"
   \<comment> \<open>A strange result, since \<open>Id\<close> is also symmetric.\<close>
   by (simp add: antisym_def)
 
 lemma sym_Id: "sym Id"
   by (simp add: sym_def)
 
 lemma trans_Id: "trans Id"
   by (simp add: trans_def)
 
 lemma single_valued_Id [simp]: "single_valued Id"
   by (unfold single_valued_def) blast
 
 lemma irrefl_diff_Id [simp]: "irrefl (r - Id)"
   by (simp add: irrefl_def)
 
 lemma trans_diff_Id: "trans r \<Longrightarrow> antisym r \<Longrightarrow> trans (r - Id)"
   unfolding antisym_def trans_def by blast
 
 lemma total_on_diff_Id [simp]: "total_on A (r - Id) = total_on A r"
   by (simp add: total_on_def)
 
 lemma Id_fstsnd_eq: "Id = {x. fst x = snd x}"
   by force
 
 
 subsubsection \<open>Diagonal: identity over a set\<close>
 
 definition Id_on :: "'a set \<Rightarrow> 'a rel"
   where "Id_on A = (\<Union>x\<in>A. {(x, x)})"
 
 lemma Id_on_empty [simp]: "Id_on {} = {}"
   by (simp add: Id_on_def)
 
 lemma Id_on_eqI: "a = b \<Longrightarrow> a \<in> A \<Longrightarrow> (a, b) \<in> Id_on A"
   by (simp add: Id_on_def)
 
 lemma Id_onI [intro!]: "a \<in> A \<Longrightarrow> (a, a) \<in> Id_on A"
   by (rule Id_on_eqI) (rule refl)
 
 lemma Id_onE [elim!]: "c \<in> Id_on A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> c = (x, x) \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>The general elimination rule.\<close>
   unfolding Id_on_def by (iprover elim!: UN_E singletonE)
 
 lemma Id_on_iff: "(x, y) \<in> Id_on A \<longleftrightarrow> x = y \<and> x \<in> A"
   by blast
 
 lemma Id_on_def' [nitpick_unfold]: "Id_on {x. A x} = Collect (\<lambda>(x, y). x = y \<and> A x)"
   by auto
 
 lemma Id_on_subset_Times: "Id_on A \<subseteq> A \<times> A"
   by blast
 
 lemma refl_on_Id_on: "refl_on A (Id_on A)"
   by (rule refl_onI [OF Id_on_subset_Times Id_onI])
 
 lemma antisym_Id_on [simp]: "antisym (Id_on A)"
   unfolding antisym_def by blast
 
 lemma sym_Id_on [simp]: "sym (Id_on A)"
   by (rule symI) clarify
 
 lemma trans_Id_on [simp]: "trans (Id_on A)"
   by (fast intro: transI elim: transD)
 
 lemma single_valued_Id_on [simp]: "single_valued (Id_on A)"
   unfolding single_valued_def by blast
 
 
 subsubsection \<open>Composition\<close>
 
 inductive_set relcomp  :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set"  (infixr "O" 75)
   for r :: "('a \<times> 'b) set" and s :: "('b \<times> 'c) set"
   where relcompI [intro]: "(a, b) \<in> r \<Longrightarrow> (b, c) \<in> s \<Longrightarrow> (a, c) \<in> r O s"
 
 notation relcompp (infixr "OO" 75)
 
 lemmas relcomppI = relcompp.intros
 
 text \<open>
   For historic reasons, the elimination rules are not wholly corresponding.
   Feel free to consolidate this.
 \<close>
 
 inductive_cases relcompEpair: "(a, c) \<in> r O s"
 inductive_cases relcomppE [elim!]: "(r OO s) a c"
 
 lemma relcompE [elim!]: "xz \<in> r O s \<Longrightarrow>
   (\<And>x y z. xz = (x, z) \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> (y, z) \<in> s  \<Longrightarrow> P) \<Longrightarrow> P"
   apply (cases xz)
   apply simp
   apply (erule relcompEpair)
   apply iprover
   done
 
 lemma R_O_Id [simp]: "R O Id = R"
   by fast
 
 lemma Id_O_R [simp]: "Id O R = R"
   by fast
 
 lemma relcomp_empty1 [simp]: "{} O R = {}"
   by blast
 
 lemma relcompp_bot1 [simp]: "\<bottom> OO R = \<bottom>"
   by (fact relcomp_empty1 [to_pred])
 
 lemma relcomp_empty2 [simp]: "R O {} = {}"
   by blast
 
 lemma relcompp_bot2 [simp]: "R OO \<bottom> = \<bottom>"
   by (fact relcomp_empty2 [to_pred])
 
 lemma O_assoc: "(R O S) O T = R O (S O T)"
   by blast
 
 lemma relcompp_assoc: "(r OO s) OO t = r OO (s OO t)"
   by (fact O_assoc [to_pred])
 
 lemma trans_O_subset: "trans r \<Longrightarrow> r O r \<subseteq> r"
   by (unfold trans_def) blast
 
 lemma transp_relcompp_less_eq: "transp r \<Longrightarrow> r OO r \<le> r "
   by (fact trans_O_subset [to_pred])
 
 lemma relcomp_mono: "r' \<subseteq> r \<Longrightarrow> s' \<subseteq> s \<Longrightarrow> r' O s' \<subseteq> r O s"
   by blast
 
 lemma relcompp_mono: "r' \<le> r \<Longrightarrow> s' \<le> s \<Longrightarrow> r' OO s' \<le> r OO s "
   by (fact relcomp_mono [to_pred])
 
 lemma relcomp_subset_Sigma: "r \<subseteq> A \<times> B \<Longrightarrow> s \<subseteq> B \<times> C \<Longrightarrow> r O s \<subseteq> A \<times> C"
   by blast
 
 lemma relcomp_distrib [simp]: "R O (S \<union> T) = (R O S) \<union> (R O T)"
   by auto
 
 lemma relcompp_distrib [simp]: "R OO (S \<squnion> T) = R OO S \<squnion> R OO T"
   by (fact relcomp_distrib [to_pred])
 
 lemma relcomp_distrib2 [simp]: "(S \<union> T) O R = (S O R) \<union> (T O R)"
   by auto
 
 lemma relcompp_distrib2 [simp]: "(S \<squnion> T) OO R = S OO R \<squnion> T OO R"
   by (fact relcomp_distrib2 [to_pred])
 
 lemma relcomp_UNION_distrib: "s O \<Union>(r ` I) = (\<Union>i\<in>I. s O r i) "
   by auto
 
 lemma relcompp_SUP_distrib: "s OO \<Squnion>(r ` I) = (\<Squnion>i\<in>I. s OO r i)"
   by (fact relcomp_UNION_distrib [to_pred])
     
 lemma relcomp_UNION_distrib2: "\<Union>(r ` I) O s = (\<Union>i\<in>I. r i O s) "
   by auto
 
 lemma relcompp_SUP_distrib2: "\<Squnion>(r ` I) OO s = (\<Squnion>i\<in>I. r i OO s)"
   by (fact relcomp_UNION_distrib2 [to_pred])
     
 lemma single_valued_relcomp: "single_valued r \<Longrightarrow> single_valued s \<Longrightarrow> single_valued (r O s)"
   unfolding single_valued_def by blast
 
 lemma relcomp_unfold: "r O s = {(x, z). \<exists>y. (x, y) \<in> r \<and> (y, z) \<in> s}"
   by (auto simp add: set_eq_iff)
 
 lemma relcompp_apply: "(R OO S) a c \<longleftrightarrow> (\<exists>b. R a b \<and> S b c)"
   unfolding relcomp_unfold [to_pred] ..
 
 lemma eq_OO: "(=) OO R = R"
   by blast
 
 lemma OO_eq: "R OO (=) = R"
   by blast
 
 
 subsubsection \<open>Converse\<close>
 
 inductive_set converse :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'a) set"  ("(_\<inverse>)" [1000] 999)
   for r :: "('a \<times> 'b) set"
   where "(a, b) \<in> r \<Longrightarrow> (b, a) \<in> r\<inverse>"
 
 notation conversep  ("(_\<inverse>\<inverse>)" [1000] 1000)
 
 notation (ASCII)
   converse  ("(_^-1)" [1000] 999) and
   conversep ("(_^--1)" [1000] 1000)
 
 lemma converseI [sym]: "(a, b) \<in> r \<Longrightarrow> (b, a) \<in> r\<inverse>"
   by (fact converse.intros)
 
 lemma conversepI (* CANDIDATE [sym] *): "r a b \<Longrightarrow> r\<inverse>\<inverse> b a"
   by (fact conversep.intros)
 
 lemma converseD [sym]: "(a, b) \<in> r\<inverse> \<Longrightarrow> (b, a) \<in> r"
   by (erule converse.cases) iprover
 
 lemma conversepD (* CANDIDATE [sym] *): "r\<inverse>\<inverse> b a \<Longrightarrow> r a b"
   by (fact converseD [to_pred])
 
 lemma converseE [elim!]: "yx \<in> r\<inverse> \<Longrightarrow> (\<And>x y. yx = (y, x) \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>More general than \<open>converseD\<close>, as it ``splits'' the member of the relation.\<close>
   apply (cases yx)
   apply simp
   apply (erule converse.cases)
   apply iprover
   done
 
 lemmas conversepE [elim!] = conversep.cases
 
 lemma converse_iff [iff]: "(a, b) \<in> r\<inverse> \<longleftrightarrow> (b, a) \<in> r"
   by (auto intro: converseI)
 
 lemma conversep_iff [iff]: "r\<inverse>\<inverse> a b = r b a"
   by (fact converse_iff [to_pred])
 
 lemma converse_converse [simp]: "(r\<inverse>)\<inverse> = r"
   by (simp add: set_eq_iff)
 
 lemma conversep_conversep [simp]: "(r\<inverse>\<inverse>)\<inverse>\<inverse> = r"
   by (fact converse_converse [to_pred])
 
 lemma converse_empty[simp]: "{}\<inverse> = {}"
   by auto
 
 lemma converse_UNIV[simp]: "UNIV\<inverse> = UNIV"
   by auto
 
 lemma converse_relcomp: "(r O s)\<inverse> = s\<inverse> O r\<inverse>"
   by blast
 
 lemma converse_relcompp: "(r OO s)\<inverse>\<inverse> = s\<inverse>\<inverse> OO r\<inverse>\<inverse>"
   by (iprover intro: order_antisym conversepI relcomppI elim: relcomppE dest: conversepD)
 
 lemma converse_Int: "(r \<inter> s)\<inverse> = r\<inverse> \<inter> s\<inverse>"
   by blast
 
 lemma converse_meet: "(r \<sqinter> s)\<inverse>\<inverse> = r\<inverse>\<inverse> \<sqinter> s\<inverse>\<inverse>"
   by (simp add: inf_fun_def) (iprover intro: conversepI ext dest: conversepD)
 
 lemma converse_Un: "(r \<union> s)\<inverse> = r\<inverse> \<union> s\<inverse>"
   by blast
 
 lemma converse_join: "(r \<squnion> s)\<inverse>\<inverse> = r\<inverse>\<inverse> \<squnion> s\<inverse>\<inverse>"
   by (simp add: sup_fun_def) (iprover intro: conversepI ext dest: conversepD)
 
 lemma converse_INTER: "(\<Inter>(r ` S))\<inverse> = (\<Inter>x\<in>S. (r x)\<inverse>)"
   by fast
 
 lemma converse_UNION: "(\<Union>(r ` S))\<inverse> = (\<Union>x\<in>S. (r x)\<inverse>)"
   by blast
 
 lemma converse_mono[simp]: "r\<inverse> \<subseteq> s \<inverse> \<longleftrightarrow> r \<subseteq> s"
   by auto
 
 lemma conversep_mono[simp]: "r\<inverse>\<inverse> \<le> s \<inverse>\<inverse> \<longleftrightarrow> r \<le> s"
   by (fact converse_mono[to_pred])
 
 lemma converse_inject[simp]: "r\<inverse> = s \<inverse> \<longleftrightarrow> r = s"
   by auto
 
 lemma conversep_inject[simp]: "r\<inverse>\<inverse> = s \<inverse>\<inverse> \<longleftrightarrow> r = s"
   by (fact converse_inject[to_pred])
 
 lemma converse_subset_swap: "r \<subseteq> s \<inverse> \<longleftrightarrow> r \<inverse> \<subseteq> s"
   by auto
 
 lemma conversep_le_swap: "r \<le> s \<inverse>\<inverse> \<longleftrightarrow> r \<inverse>\<inverse> \<le> s"
   by (fact converse_subset_swap[to_pred])
 
 lemma converse_Id [simp]: "Id\<inverse> = Id"
   by blast
 
 lemma converse_Id_on [simp]: "(Id_on A)\<inverse> = Id_on A"
   by blast
 
 lemma refl_on_converse [simp]: "refl_on A (converse r) = refl_on A r"
   by (auto simp: refl_on_def)
 
 lemma sym_converse [simp]: "sym (converse r) = sym r"
   unfolding sym_def by blast
 
 lemma antisym_converse [simp]: "antisym (converse r) = antisym r"
   unfolding antisym_def by blast
 
 lemma trans_converse [simp]: "trans (converse r) = trans r"
   unfolding trans_def by blast
 
 lemma sym_conv_converse_eq: "sym r \<longleftrightarrow> r\<inverse> = r"
   unfolding sym_def by fast
 
 lemma sym_Un_converse: "sym (r \<union> r\<inverse>)"
   unfolding sym_def by blast
 
 lemma sym_Int_converse: "sym (r \<inter> r\<inverse>)"
   unfolding sym_def by blast
 
 lemma total_on_converse [simp]: "total_on A (r\<inverse>) = total_on A r"
   by (auto simp: total_on_def)
 
 lemma finite_converse [iff]: "finite (r\<inverse>) = finite r"
 unfolding converse_def conversep_iff using [[simproc add: finite_Collect]]
 by (auto elim: finite_imageD simp: inj_on_def)
 
 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  
 
 lemma conversep_noteq [simp]: "(\<noteq>)\<inverse>\<inverse> = (\<noteq>)"
   by (auto simp add: fun_eq_iff)
 
 lemma conversep_eq [simp]: "(=)\<inverse>\<inverse> = (=)"
   by (auto simp add: fun_eq_iff)
 
 lemma converse_unfold [code]: "r\<inverse> = {(y, x). (x, y) \<in> r}"
   by (simp add: set_eq_iff)
 
 
 subsubsection \<open>Domain, range and field\<close>
 
 inductive_set Domain :: "('a \<times> 'b) set \<Rightarrow> 'a set" for r :: "('a \<times> 'b) set"
   where DomainI [intro]: "(a, b) \<in> r \<Longrightarrow> a \<in> Domain r"
 
 lemmas DomainPI = Domainp.DomainI
 
 inductive_cases DomainE [elim!]: "a \<in> Domain r"
 inductive_cases DomainpE [elim!]: "Domainp r a"
 
 inductive_set Range :: "('a \<times> 'b) set \<Rightarrow> 'b set" for r :: "('a \<times> 'b) set"
   where RangeI [intro]: "(a, b) \<in> r \<Longrightarrow> b \<in> Range r"
 
 lemmas RangePI = Rangep.RangeI
 
 inductive_cases RangeE [elim!]: "b \<in> Range r"
 inductive_cases RangepE [elim!]: "Rangep r b"
 
 definition Field :: "'a rel \<Rightarrow> 'a set"
   where "Field r = Domain r \<union> Range r"
 
 lemma FieldI1: "(i, j) \<in> R \<Longrightarrow> i \<in> Field R"
   unfolding Field_def by blast
 
 lemma FieldI2: "(i, j) \<in> R \<Longrightarrow> j \<in> Field R"
   unfolding Field_def by auto
 
 lemma Domain_fst [code]: "Domain r = fst ` r"
   by force
 
 lemma Range_snd [code]: "Range r = snd ` r"
   by force
 
 lemma fst_eq_Domain: "fst ` R = Domain R"
   by force
 
 lemma snd_eq_Range: "snd ` R = Range R"
   by force
 
 lemma range_fst [simp]: "range fst = UNIV"
   by (auto simp: fst_eq_Domain)
 
 lemma range_snd [simp]: "range snd = UNIV"
   by (auto simp: snd_eq_Range)
 
 lemma Domain_empty [simp]: "Domain {} = {}"
   by auto
 
 lemma Range_empty [simp]: "Range {} = {}"
   by auto
 
 lemma Field_empty [simp]: "Field {} = {}"
   by (simp add: Field_def)
 
 lemma Domain_empty_iff: "Domain r = {} \<longleftrightarrow> r = {}"
   by auto
 
 lemma Range_empty_iff: "Range r = {} \<longleftrightarrow> r = {}"
   by auto
 
 lemma Domain_insert [simp]: "Domain (insert (a, b) r) = insert a (Domain r)"
   by blast
 
 lemma Range_insert [simp]: "Range (insert (a, b) r) = insert b (Range r)"
   by blast
 
 lemma Field_insert [simp]: "Field (insert (a, b) r) = {a, b} \<union> Field r"
   by (auto simp add: Field_def)
 
 lemma Domain_iff: "a \<in> Domain r \<longleftrightarrow> (\<exists>y. (a, y) \<in> r)"
   by blast
 
 lemma Range_iff: "a \<in> Range r \<longleftrightarrow> (\<exists>y. (y, a) \<in> r)"
   by blast
 
 lemma Domain_Id [simp]: "Domain Id = UNIV"
   by blast
 
 lemma Range_Id [simp]: "Range Id = UNIV"
   by blast
 
 lemma Domain_Id_on [simp]: "Domain (Id_on A) = A"
   by blast
 
 lemma Range_Id_on [simp]: "Range (Id_on A) = A"
   by blast
 
 lemma Domain_Un_eq: "Domain (A \<union> B) = Domain A \<union> Domain B"
   by blast
 
 lemma Range_Un_eq: "Range (A \<union> B) = Range A \<union> Range B"
   by blast
 
 lemma Field_Un [simp]: "Field (r \<union> s) = Field r \<union> Field s"
   by (auto simp: Field_def)
 
 lemma Domain_Int_subset: "Domain (A \<inter> B) \<subseteq> Domain A \<inter> Domain B"
   by blast
 
 lemma Range_Int_subset: "Range (A \<inter> B) \<subseteq> Range A \<inter> Range B"
   by blast
 
 lemma Domain_Diff_subset: "Domain A - Domain B \<subseteq> Domain (A - B)"
   by blast
 
 lemma Range_Diff_subset: "Range A - Range B \<subseteq> Range (A - B)"
   by blast
 
 lemma Domain_Union: "Domain (\<Union>S) = (\<Union>A\<in>S. Domain A)"
   by blast
 
 lemma Range_Union: "Range (\<Union>S) = (\<Union>A\<in>S. Range A)"
   by blast
 
 lemma Field_Union [simp]: "Field (\<Union>R) = \<Union>(Field ` R)"
   by (auto simp: Field_def)
 
 lemma Domain_converse [simp]: "Domain (r\<inverse>) = Range r"
   by auto
 
 lemma Range_converse [simp]: "Range (r\<inverse>) = Domain r"
   by blast
 
 lemma Field_converse [simp]: "Field (r\<inverse>) = Field r"
   by (auto simp: Field_def)
 
 lemma Domain_Collect_case_prod [simp]: "Domain {(x, y). P x y} = {x. \<exists>y. P x y}"
   by auto
 
 lemma Range_Collect_case_prod [simp]: "Range {(x, y). P x y} = {y. \<exists>x. P x y}"
   by auto
 
 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 Domain_mono: "r \<subseteq> s \<Longrightarrow> Domain r \<subseteq> Domain s"
   by blast
 
 lemma Range_mono: "r \<subseteq> s \<Longrightarrow> Range r \<subseteq> Range s"
   by blast
 
 lemma mono_Field: "r \<subseteq> s \<Longrightarrow> Field r \<subseteq> Field s"
   by (auto simp: Field_def Domain_def Range_def)
 
 lemma Domain_unfold: "Domain r = {x. \<exists>y. (x, y) \<in> r}"
   by blast
 
 lemma Field_square [simp]: "Field (x \<times> x) = x"
   unfolding Field_def by blast
 
 
 subsubsection \<open>Image of a set under a relation\<close>
 
 definition Image :: "('a \<times> 'b) set \<Rightarrow> 'a set \<Rightarrow> 'b set"  (infixr "``" 90)
   where "r `` s = {y. \<exists>x\<in>s. (x, y) \<in> r}"
 
 lemma Image_iff: "b \<in> r``A \<longleftrightarrow> (\<exists>x\<in>A. (x, b) \<in> r)"
   by (simp add: Image_def)
 
 lemma Image_singleton: "r``{a} = {b. (a, b) \<in> r}"
   by (simp add: Image_def)
 
 lemma Image_singleton_iff [iff]: "b \<in> r``{a} \<longleftrightarrow> (a, b) \<in> r"
   by (rule Image_iff [THEN trans]) simp
 
 lemma ImageI [intro]: "(a, b) \<in> r \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> r``A"
   unfolding Image_def by blast
 
 lemma ImageE [elim!]: "b \<in> r `` A \<Longrightarrow> (\<And>x. (x, b) \<in> r \<Longrightarrow> x \<in> A \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding Image_def by (iprover elim!: CollectE bexE)
 
 lemma rev_ImageI: "a \<in> A \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> b \<in> r `` A"
   \<comment> \<open>This version's more effective when we already have the required \<open>a\<close>\<close>
   by blast
 
 lemma Image_empty1 [simp]: "{} `` X = {}"
 by auto
 
 lemma Image_empty2 [simp]: "R``{} = {}"
 by blast
 
 lemma Image_Id [simp]: "Id `` A = A"
   by blast
 
 lemma Image_Id_on [simp]: "Id_on A `` B = A \<inter> B"
   by blast
 
 lemma Image_Int_subset: "R `` (A \<inter> B) \<subseteq> R `` A \<inter> R `` B"
   by blast
 
 lemma Image_Int_eq: "single_valued (converse R) \<Longrightarrow> R `` (A \<inter> B) = R `` A \<inter> R `` B"
   by (auto simp: single_valued_def)
 
 lemma Image_Un: "R `` (A \<union> B) = R `` A \<union> R `` B"
   by blast
 
 lemma Un_Image: "(R \<union> S) `` A = R `` A \<union> S `` A"
   by blast
 
 lemma Image_subset: "r \<subseteq> A \<times> B \<Longrightarrow> r``C \<subseteq> B"
   by (iprover intro!: subsetI elim!: ImageE dest!: subsetD SigmaD2)
 
 lemma Image_eq_UN: "r``B = (\<Union>y\<in> B. r``{y})"
   \<comment> \<open>NOT suitable for rewriting\<close>
   by blast
 
 lemma Image_mono: "r' \<subseteq> r \<Longrightarrow> A' \<subseteq> A \<Longrightarrow> (r' `` A') \<subseteq> (r `` A)"
   by blast
 
 lemma Image_UN: "r `` (\<Union>(B ` A)) = (\<Union>x\<in>A. r `` (B x))"
   by blast
 
 lemma UN_Image: "(\<Union>i\<in>I. X i) `` S = (\<Union>i\<in>I. X i `` S)"
   by auto
 
 lemma Image_INT_subset: "(r `` (\<Inter>(B ` A))) \<subseteq> (\<Inter>x\<in>A. r `` (B x))"
   by blast
 
 text \<open>Converse inclusion requires some assumptions\<close>
 lemma Image_INT_eq: "single_valued (r\<inverse>) \<Longrightarrow> A \<noteq> {} \<Longrightarrow> r `` (\<Inter>(B ` A)) = (\<Inter>x\<in>A. r `` B x)"
   apply (rule equalityI)
    apply (rule Image_INT_subset)
   apply (auto simp add: single_valued_def)
   apply blast
   done
 
 lemma Image_subset_eq: "r``A \<subseteq> B \<longleftrightarrow> A \<subseteq> - ((r\<inverse>) `` (- B))"
   by blast
 
 lemma Image_Collect_case_prod [simp]: "{(x, y). P x y} `` A = {y. \<exists>x\<in>A. P x y}"
   by auto
 
 lemma Sigma_Image: "(SIGMA x:A. B x) `` X = (\<Union>x\<in>X \<inter> A. B x)"
   by auto
 
 lemma relcomp_Image: "(X O Y) `` Z = Y `` (X `` Z)"
   by auto
 
 lemma finite_Image[simp]: assumes "finite R" shows "finite (R `` A)"
 by(rule finite_subset[OF _ finite_Range[OF assms]]) auto
 
 
 subsubsection \<open>Inverse image\<close>
 
 definition inv_image :: "'b rel \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a rel"
   where "inv_image r f = {(x, y). (f x, f y) \<in> r}"
 
 definition inv_imagep :: "('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "inv_imagep r f = (\<lambda>x y. r (f x) (f y))"
 
 lemma [pred_set_conv]: "inv_imagep (\<lambda>x y. (x, y) \<in> r) f = (\<lambda>x y. (x, y) \<in> inv_image r f)"
   by (simp add: inv_image_def inv_imagep_def)
 
 lemma sym_inv_image: "sym r \<Longrightarrow> sym (inv_image r f)"
   unfolding sym_def inv_image_def by blast
 
 lemma trans_inv_image: "trans r \<Longrightarrow> trans (inv_image r f)"
   unfolding trans_def inv_image_def
   by (simp (no_asm)) blast
 
 lemma total_inv_image: "\<lbrakk>inj f; total r\<rbrakk> \<Longrightarrow> total (inv_image r f)"
   unfolding inv_image_def total_on_def by (auto simp: inj_eq)
 
 lemma asym_inv_image: "asym R \<Longrightarrow> asym (inv_image R f)"
   by (simp add: inv_image_def asym_iff)
 
 lemma in_inv_image[simp]: "(x, y) \<in> inv_image r f \<longleftrightarrow> (f x, f y) \<in> r"
   by (auto simp: inv_image_def)
 
 lemma converse_inv_image[simp]: "(inv_image R f)\<inverse> = inv_image (R\<inverse>) f"
   unfolding inv_image_def converse_unfold by auto
 
 lemma in_inv_imagep [simp]: "inv_imagep r f x y = r (f x) (f y)"
   by (simp add: inv_imagep_def)
 
 
 subsubsection \<open>Powerset\<close>
 
 definition Powp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> bool"
   where "Powp A = (\<lambda>B. \<forall>x \<in> B. A x)"
 
 lemma Powp_Pow_eq [pred_set_conv]: "Powp (\<lambda>x. x \<in> A) = (\<lambda>x. x \<in> Pow A)"
   by (auto simp add: Powp_def fun_eq_iff)
 
 lemmas Powp_mono [mono] = Pow_mono [to_pred]
 
 
 subsubsection \<open>Expressing relation operations via \<^const>\<open>Finite_Set.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"
-  using assms
-  by (induct R)
-    (auto simp: comp_fun_commute.fold_insert comp_fun_commute_relcomp_fold insert_relcomp_fold
-      cong: if_cong)
+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
 
 end
diff --git a/src/HOL/Topological_Spaces.thy b/src/HOL/Topological_Spaces.thy
--- a/src/HOL/Topological_Spaces.thy
+++ b/src/HOL/Topological_Spaces.thy
@@ -1,3836 +1,3836 @@
 (*  Title:      HOL/Topological_Spaces.thy
     Author:     Brian Huffman
     Author:     Johannes Hölzl
 *)
 
 section \<open>Topological Spaces\<close>
 
 theory Topological_Spaces
   imports Main
 begin
 
 named_theorems continuous_intros "structural introduction rules for continuity"
 
 subsection \<open>Topological space\<close>
 
 class "open" =
   fixes "open" :: "'a set \<Rightarrow> bool"
 
 class topological_space = "open" +
   assumes open_UNIV [simp, intro]: "open UNIV"
   assumes open_Int [intro]: "open S \<Longrightarrow> open T \<Longrightarrow> open (S \<inter> T)"
   assumes open_Union [intro]: "\<forall>S\<in>K. open S \<Longrightarrow> open (\<Union>K)"
 begin
 
 definition closed :: "'a set \<Rightarrow> bool"
   where "closed S \<longleftrightarrow> open (- S)"
 
 lemma open_empty [continuous_intros, intro, simp]: "open {}"
   using open_Union [of "{}"] by simp
 
 lemma open_Un [continuous_intros, intro]: "open S \<Longrightarrow> open T \<Longrightarrow> open (S \<union> T)"
   using open_Union [of "{S, T}"] by simp
 
 lemma open_UN [continuous_intros, intro]: "\<forall>x\<in>A. open (B x) \<Longrightarrow> open (\<Union>x\<in>A. B x)"
   using open_Union [of "B ` A"] by simp
 
 lemma open_Inter [continuous_intros, intro]: "finite S \<Longrightarrow> \<forall>T\<in>S. open T \<Longrightarrow> open (\<Inter>S)"
-  by (induct set: finite) auto
+  by (induction set: finite) auto
 
 lemma open_INT [continuous_intros, intro]: "finite A \<Longrightarrow> \<forall>x\<in>A. open (B x) \<Longrightarrow> open (\<Inter>x\<in>A. B x)"
   using open_Inter [of "B ` A"] by simp
 
 lemma openI:
   assumes "\<And>x. x \<in> S \<Longrightarrow> \<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> S"
   shows "open S"
 proof -
   have "open (\<Union>{T. open T \<and> T \<subseteq> S})" by auto
   moreover have "\<Union>{T. open T \<and> T \<subseteq> S} = S" by (auto dest!: assms)
   ultimately show "open S" by simp
 qed
 
 lemma open_subopen: "open S \<longleftrightarrow> (\<forall>x\<in>S. \<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> S)"
 by (auto intro: openI)
 
 lemma closed_empty [continuous_intros, intro, simp]: "closed {}"
   unfolding closed_def by simp
 
 lemma closed_Un [continuous_intros, intro]: "closed S \<Longrightarrow> closed T \<Longrightarrow> closed (S \<union> T)"
   unfolding closed_def by auto
 
 lemma closed_UNIV [continuous_intros, intro, simp]: "closed UNIV"
   unfolding closed_def by simp
 
 lemma closed_Int [continuous_intros, intro]: "closed S \<Longrightarrow> closed T \<Longrightarrow> closed (S \<inter> T)"
   unfolding closed_def by auto
 
 lemma closed_INT [continuous_intros, intro]: "\<forall>x\<in>A. closed (B x) \<Longrightarrow> closed (\<Inter>x\<in>A. B x)"
   unfolding closed_def by auto
 
 lemma closed_Inter [continuous_intros, intro]: "\<forall>S\<in>K. closed S \<Longrightarrow> closed (\<Inter>K)"
   unfolding closed_def uminus_Inf by auto
 
 lemma closed_Union [continuous_intros, intro]: "finite S \<Longrightarrow> \<forall>T\<in>S. closed T \<Longrightarrow> closed (\<Union>S)"
   by (induct set: finite) auto
 
 lemma closed_UN [continuous_intros, intro]:
   "finite A \<Longrightarrow> \<forall>x\<in>A. closed (B x) \<Longrightarrow> closed (\<Union>x\<in>A. B x)"
   using closed_Union [of "B ` A"] by simp
 
 lemma open_closed: "open S \<longleftrightarrow> closed (- S)"
   by (simp add: closed_def)
 
 lemma closed_open: "closed S \<longleftrightarrow> open (- S)"
   by (rule closed_def)
 
 lemma open_Diff [continuous_intros, intro]: "open S \<Longrightarrow> closed T \<Longrightarrow> open (S - T)"
   by (simp add: closed_open Diff_eq open_Int)
 
 lemma closed_Diff [continuous_intros, intro]: "closed S \<Longrightarrow> open T \<Longrightarrow> closed (S - T)"
   by (simp add: open_closed Diff_eq closed_Int)
 
 lemma open_Compl [continuous_intros, intro]: "closed S \<Longrightarrow> open (- S)"
   by (simp add: closed_open)
 
 lemma closed_Compl [continuous_intros, intro]: "open S \<Longrightarrow> closed (- S)"
   by (simp add: open_closed)
 
 lemma open_Collect_neg: "closed {x. P x} \<Longrightarrow> open {x. \<not> P x}"
   unfolding Collect_neg_eq by (rule open_Compl)
 
 lemma open_Collect_conj:
   assumes "open {x. P x}" "open {x. Q x}"
   shows "open {x. P x \<and> Q x}"
   using open_Int[OF assms] by (simp add: Int_def)
 
 lemma open_Collect_disj:
   assumes "open {x. P x}" "open {x. Q x}"
   shows "open {x. P x \<or> Q x}"
   using open_Un[OF assms] by (simp add: Un_def)
 
 lemma open_Collect_ex: "(\<And>i. open {x. P i x}) \<Longrightarrow> open {x. \<exists>i. P i x}"
   using open_UN[of UNIV "\<lambda>i. {x. P i x}"] unfolding Collect_ex_eq by simp
 
 lemma open_Collect_imp: "closed {x. P x} \<Longrightarrow> open {x. Q x} \<Longrightarrow> open {x. P x \<longrightarrow> Q x}"
   unfolding imp_conv_disj by (intro open_Collect_disj open_Collect_neg)
 
 lemma open_Collect_const: "open {x. P}"
   by (cases P) auto
 
 lemma closed_Collect_neg: "open {x. P x} \<Longrightarrow> closed {x. \<not> P x}"
   unfolding Collect_neg_eq by (rule closed_Compl)
 
 lemma closed_Collect_conj:
   assumes "closed {x. P x}" "closed {x. Q x}"
   shows "closed {x. P x \<and> Q x}"
   using closed_Int[OF assms] by (simp add: Int_def)
 
 lemma closed_Collect_disj:
   assumes "closed {x. P x}" "closed {x. Q x}"
   shows "closed {x. P x \<or> Q x}"
   using closed_Un[OF assms] by (simp add: Un_def)
 
 lemma closed_Collect_all: "(\<And>i. closed {x. P i x}) \<Longrightarrow> closed {x. \<forall>i. P i x}"
   using closed_INT[of UNIV "\<lambda>i. {x. P i x}"] by (simp add: Collect_all_eq)
 
 lemma closed_Collect_imp: "open {x. P x} \<Longrightarrow> closed {x. Q x} \<Longrightarrow> closed {x. P x \<longrightarrow> Q x}"
   unfolding imp_conv_disj by (intro closed_Collect_disj closed_Collect_neg)
 
 lemma closed_Collect_const: "closed {x. P}"
   by (cases P) auto
 
 end
 
 
 subsection \<open>Hausdorff and other separation properties\<close>
 
 class t0_space = topological_space +
   assumes t0_space: "x \<noteq> y \<Longrightarrow> \<exists>U. open U \<and> \<not> (x \<in> U \<longleftrightarrow> y \<in> U)"
 
 class t1_space = topological_space +
   assumes t1_space: "x \<noteq> y \<Longrightarrow> \<exists>U. open U \<and> x \<in> U \<and> y \<notin> U"
 
 instance t1_space \<subseteq> t0_space
   by standard (fast dest: t1_space)
 
 context t1_space begin
 
 lemma separation_t1: "x \<noteq> y \<longleftrightarrow> (\<exists>U. open U \<and> x \<in> U \<and> y \<notin> U)"
   using t1_space[of x y] by blast
 
 lemma closed_singleton [iff]: "closed {a}"
 proof -
   let ?T = "\<Union>{S. open S \<and> a \<notin> S}"
   have "open ?T"
     by (simp add: open_Union)
   also have "?T = - {a}"
     by (auto simp add: set_eq_iff separation_t1)
   finally show "closed {a}"
     by (simp only: closed_def)
 qed
 
 lemma closed_insert [continuous_intros, simp]:
   assumes "closed S"
   shows "closed (insert a S)"
 proof -
   from closed_singleton assms have "closed ({a} \<union> S)"
     by (rule closed_Un)
   then show "closed (insert a S)"
     by simp
 qed
 
 lemma finite_imp_closed: "finite S \<Longrightarrow> closed S"
   by (induct pred: finite) simp_all
 
 end
 
 text \<open>T2 spaces are also known as Hausdorff spaces.\<close>
 
 class t2_space = topological_space +
   assumes hausdorff: "x \<noteq> y \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
 
 instance t2_space \<subseteq> t1_space
   by standard (fast dest: hausdorff)
 
 lemma (in t2_space) separation_t2: "x \<noteq> y \<longleftrightarrow> (\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {})"
   using hausdorff [of x y] by blast
 
 lemma (in t0_space) separation_t0: "x \<noteq> y \<longleftrightarrow> (\<exists>U. open U \<and> \<not> (x \<in> U \<longleftrightarrow> y \<in> U))"
   using t0_space [of x y] by blast
 
 
 text \<open>A classical separation axiom for topological space, the T3 axiom -- also called regularity:
 if a point is not in a closed set, then there are open sets separating them.\<close>
 
 class t3_space = t2_space +
   assumes t3_space: "closed S \<Longrightarrow> y \<notin> S \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> y \<in> U \<and> S \<subseteq> V \<and> U \<inter> V = {}"
 
 text \<open>A classical separation axiom for topological space, the T4 axiom -- also called normality:
 if two closed sets are disjoint, then there are open sets separating them.\<close>
 
 class t4_space = t2_space +
   assumes t4_space: "closed S \<Longrightarrow> closed T \<Longrightarrow> S \<inter> T = {} \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> S \<subseteq> U \<and> T \<subseteq> V \<and> U \<inter> V = {}"
 
 text \<open>T4 is stronger than T3, and weaker than metric.\<close>
 
 instance t4_space \<subseteq> t3_space
 proof
   fix S and y::'a assume "closed S" "y \<notin> S"
   then show "\<exists>U V. open U \<and> open V \<and> y \<in> U \<and> S \<subseteq> V \<and> U \<inter> V = {}"
     using t4_space[of "{y}" S] by auto
 qed
 
 text \<open>A perfect space is a topological space with no isolated points.\<close>
 
 class perfect_space = topological_space +
   assumes not_open_singleton: "\<not> open {x}"
 
 lemma (in perfect_space) UNIV_not_singleton: "UNIV \<noteq> {x}"
   for x::'a
   by (metis (no_types) open_UNIV not_open_singleton)
 
 
 subsection \<open>Generators for toplogies\<close>
 
 inductive generate_topology :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" for S :: "'a set set"
   where
     UNIV: "generate_topology S UNIV"
   | Int: "generate_topology S (a \<inter> b)" if "generate_topology S a" and "generate_topology S b"
   | UN: "generate_topology S (\<Union>K)" if "(\<And>k. k \<in> K \<Longrightarrow> generate_topology S k)"
   | Basis: "generate_topology S s" if "s \<in> S"
 
 hide_fact (open) UNIV Int UN Basis
 
 lemma generate_topology_Union:
   "(\<And>k. k \<in> I \<Longrightarrow> generate_topology S (K k)) \<Longrightarrow> generate_topology S (\<Union>k\<in>I. K k)"
   using generate_topology.UN [of "K ` I"] by auto
 
 lemma topological_space_generate_topology: "class.topological_space (generate_topology S)"
   by standard (auto intro: generate_topology.intros)
 
 
 subsection \<open>Order topologies\<close>
 
 class order_topology = order + "open" +
   assumes open_generated_order: "open = generate_topology (range (\<lambda>a. {..< a}) \<union> range (\<lambda>a. {a <..}))"
 begin
 
 subclass topological_space
   unfolding open_generated_order
   by (rule topological_space_generate_topology)
 
 lemma open_greaterThan [continuous_intros, simp]: "open {a <..}"
   unfolding open_generated_order by (auto intro: generate_topology.Basis)
 
 lemma open_lessThan [continuous_intros, simp]: "open {..< a}"
   unfolding open_generated_order by (auto intro: generate_topology.Basis)
 
 lemma open_greaterThanLessThan [continuous_intros, simp]: "open {a <..< b}"
    unfolding greaterThanLessThan_eq by (simp add: open_Int)
 
 end
 
 class linorder_topology = linorder + order_topology
 
 lemma closed_atMost [continuous_intros, simp]: "closed {..a}"
   for a :: "'a::linorder_topology"
   by (simp add: closed_open)
 
 lemma closed_atLeast [continuous_intros, simp]: "closed {a..}"
   for a :: "'a::linorder_topology"
   by (simp add: closed_open)
 
 lemma closed_atLeastAtMost [continuous_intros, simp]: "closed {a..b}"
   for a b :: "'a::linorder_topology"
 proof -
   have "{a .. b} = {a ..} \<inter> {.. b}"
     by auto
   then show ?thesis
     by (simp add: closed_Int)
 qed
 
 lemma (in order) less_separate:
   assumes "x < y"
   shows "\<exists>a b. x \<in> {..< a} \<and> y \<in> {b <..} \<and> {..< a} \<inter> {b <..} = {}"
 proof (cases "\<exists>z. x < z \<and> z < y")
   case True
   then obtain z where "x < z \<and> z < y" ..
   then have "x \<in> {..< z} \<and> y \<in> {z <..} \<and> {z <..} \<inter> {..< z} = {}"
     by auto
   then show ?thesis by blast
 next
   case False
   with \<open>x < y\<close> have "x \<in> {..< y}" "y \<in> {x <..}" "{x <..} \<inter> {..< y} = {}"
     by auto
   then show ?thesis by blast
 qed
 
 instance linorder_topology \<subseteq> t2_space
 proof
   fix x y :: 'a
   show "x \<noteq> y \<Longrightarrow> \<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
     using less_separate [of x y] less_separate [of y x]
     by (elim neqE; metis open_lessThan open_greaterThan Int_commute)
 qed
 
 lemma (in linorder_topology) open_right:
   assumes "open S" "x \<in> S"
     and gt_ex: "x < y"
   shows "\<exists>b>x. {x ..< b} \<subseteq> S"
   using assms unfolding open_generated_order
 proof induct
   case UNIV
   then show ?case by blast
 next
   case (Int A B)
   then obtain a b where "a > x" "{x ..< a} \<subseteq> A"  "b > x" "{x ..< b} \<subseteq> B"
     by auto
   then show ?case
     by (auto intro!: exI[of _ "min a b"])
 next
   case UN
   then show ?case by blast
 next
   case Basis
   then show ?case
     by (fastforce intro: exI[of _ y] gt_ex)
 qed
 
 lemma (in linorder_topology) open_left:
   assumes "open S" "x \<in> S"
     and lt_ex: "y < x"
   shows "\<exists>b<x. {b <.. x} \<subseteq> S"
   using assms unfolding open_generated_order
 proof induction
   case UNIV
   then show ?case by blast
 next
   case (Int A B)
   then obtain a b where "a < x" "{a <.. x} \<subseteq> A"  "b < x" "{b <.. x} \<subseteq> B"
     by auto
   then show ?case
     by (auto intro!: exI[of _ "max a b"])
 next
   case UN
   then show ?case by blast
 next
   case Basis
   then show ?case
     by (fastforce intro: exI[of _ y] lt_ex)
 qed
 
 
 subsection \<open>Setup some topologies\<close>
 
 subsubsection \<open>Boolean is an order topology\<close>
 
 class discrete_topology = topological_space +
   assumes open_discrete: "\<And>A. open A"
 
 instance discrete_topology < t2_space
 proof
   fix x y :: 'a
   assume "x \<noteq> y"
   then show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
     by (intro exI[of _ "{_}"]) (auto intro!: open_discrete)
 qed
 
 instantiation bool :: linorder_topology
 begin
 
 definition open_bool :: "bool set \<Rightarrow> bool"
   where "open_bool = generate_topology (range (\<lambda>a. {..< a}) \<union> range (\<lambda>a. {a <..}))"
 
 instance
   by standard (rule open_bool_def)
 
 end
 
 instance bool :: discrete_topology
 proof
   fix A :: "bool set"
   have *: "{False <..} = {True}" "{..< True} = {False}"
     by auto
   have "A = UNIV \<or> A = {} \<or> A = {False <..} \<or> A = {..< True}"
     using subset_UNIV[of A] unfolding UNIV_bool * by blast
   then show "open A"
     by auto
 qed
 
 instantiation nat :: linorder_topology
 begin
 
 definition open_nat :: "nat set \<Rightarrow> bool"
   where "open_nat = generate_topology (range (\<lambda>a. {..< a}) \<union> range (\<lambda>a. {a <..}))"
 
 instance
   by standard (rule open_nat_def)
 
 end
 
 instance nat :: discrete_topology
 proof
   fix A :: "nat set"
   have "open {n}" for n :: nat
   proof (cases n)
     case 0
     moreover have "{0} = {..<1::nat}"
       by auto
     ultimately show ?thesis
        by auto
   next
     case (Suc n')
     then have "{n} = {..<Suc n} \<inter> {n' <..}"
       by auto
     with Suc show ?thesis
       by (auto intro: open_lessThan open_greaterThan)
   qed
   then have "open (\<Union>a\<in>A. {a})"
     by (intro open_UN) auto
   then show "open A"
     by simp
 qed
 
 instantiation int :: linorder_topology
 begin
 
 definition open_int :: "int set \<Rightarrow> bool"
   where "open_int = generate_topology (range (\<lambda>a. {..< a}) \<union> range (\<lambda>a. {a <..}))"
 
 instance
   by standard (rule open_int_def)
 
 end
 
 instance int :: discrete_topology
 proof
   fix A :: "int set"
   have "{..<i + 1} \<inter> {i-1 <..} = {i}" for i :: int
     by auto
   then have "open {i}" for i :: int
     using open_Int[OF open_lessThan[of "i + 1"] open_greaterThan[of "i - 1"]] by auto
   then have "open (\<Union>a\<in>A. {a})"
     by (intro open_UN) auto
   then show "open A"
     by simp
 qed
 
 
 subsubsection \<open>Topological filters\<close>
 
 definition (in topological_space) nhds :: "'a \<Rightarrow> 'a filter"
   where "nhds a = (INF S\<in>{S. open S \<and> a \<in> S}. principal S)"
 
 definition (in topological_space) at_within :: "'a \<Rightarrow> 'a set \<Rightarrow> 'a filter"
     ("at (_)/ within (_)" [1000, 60] 60)
   where "at a within s = inf (nhds a) (principal (s - {a}))"
 
 abbreviation (in topological_space) at :: "'a \<Rightarrow> 'a filter"  ("at")
   where "at x \<equiv> at x within (CONST UNIV)"
 
 abbreviation (in order_topology) at_right :: "'a \<Rightarrow> 'a filter"
   where "at_right x \<equiv> at x within {x <..}"
 
 abbreviation (in order_topology) at_left :: "'a \<Rightarrow> 'a filter"
   where "at_left x \<equiv> at x within {..< x}"
 
 lemma (in topological_space) nhds_generated_topology:
   "open = generate_topology T \<Longrightarrow> nhds x = (INF S\<in>{S\<in>T. x \<in> S}. principal S)"
   unfolding nhds_def
 proof (safe intro!: antisym INF_greatest)
   fix S
   assume "generate_topology T S" "x \<in> S"
   then show "(INF S\<in>{S \<in> T. x \<in> S}. principal S) \<le> principal S"
     by induct
       (auto intro: INF_lower order_trans simp: inf_principal[symmetric] simp del: inf_principal)
 qed (auto intro!: INF_lower intro: generate_topology.intros)
 
 lemma (in topological_space) eventually_nhds:
   "eventually P (nhds a) \<longleftrightarrow> (\<exists>S. open S \<and> a \<in> S \<and> (\<forall>x\<in>S. P x))"
   unfolding nhds_def by (subst eventually_INF_base) (auto simp: eventually_principal)
 
 lemma eventually_eventually:
   "eventually (\<lambda>y. eventually P (nhds y)) (nhds x) = eventually P (nhds x)"
   by (auto simp: eventually_nhds)
 
 lemma (in topological_space) eventually_nhds_in_open:
   "open s \<Longrightarrow> x \<in> s \<Longrightarrow> eventually (\<lambda>y. y \<in> s) (nhds x)"
   by (subst eventually_nhds) blast
 
 lemma (in topological_space) eventually_nhds_x_imp_x: "eventually P (nhds x) \<Longrightarrow> P x"
   by (subst (asm) eventually_nhds) blast
 
 lemma (in topological_space) nhds_neq_bot [simp]: "nhds a \<noteq> bot"
   by (simp add: trivial_limit_def eventually_nhds)
 
 lemma (in t1_space) t1_space_nhds: "x \<noteq> y \<Longrightarrow> (\<forall>\<^sub>F x in nhds x. x \<noteq> y)"
   by (drule t1_space) (auto simp: eventually_nhds)
 
 lemma (in topological_space) nhds_discrete_open: "open {x} \<Longrightarrow> nhds x = principal {x}"
   by (auto simp: nhds_def intro!: antisym INF_greatest INF_lower2[of "{x}"])
 
 lemma (in discrete_topology) nhds_discrete: "nhds x = principal {x}"
   by (simp add: nhds_discrete_open open_discrete)
 
 lemma (in discrete_topology) at_discrete: "at x within S = bot"
   unfolding at_within_def nhds_discrete by simp
 
 lemma (in discrete_topology) tendsto_discrete:
   "filterlim (f :: 'b \<Rightarrow> 'a) (nhds y) F \<longleftrightarrow> eventually (\<lambda>x. f x = y) F"
   by (auto simp: nhds_discrete filterlim_principal)
 
 lemma (in topological_space) at_within_eq:
   "at x within s = (INF S\<in>{S. open S \<and> x \<in> S}. principal (S \<inter> s - {x}))"
   unfolding nhds_def at_within_def
   by (subst INF_inf_const2[symmetric]) (auto simp: Diff_Int_distrib)
 
 lemma (in topological_space) eventually_at_filter:
   "eventually P (at a within s) \<longleftrightarrow> eventually (\<lambda>x. x \<noteq> a \<longrightarrow> x \<in> s \<longrightarrow> P x) (nhds a)"
   by (simp add: at_within_def eventually_inf_principal imp_conjL[symmetric] conj_commute)
 
 lemma (in topological_space) at_le: "s \<subseteq> t \<Longrightarrow> at x within s \<le> at x within t"
   unfolding at_within_def by (intro inf_mono) auto
 
 lemma (in topological_space) eventually_at_topological:
   "eventually P (at a within s) \<longleftrightarrow> (\<exists>S. open S \<and> a \<in> S \<and> (\<forall>x\<in>S. x \<noteq> a \<longrightarrow> x \<in> s \<longrightarrow> P x))"
   by (simp add: eventually_nhds eventually_at_filter)
 
 lemma (in topological_space) at_within_open: "a \<in> S \<Longrightarrow> open S \<Longrightarrow> at a within S = at a"
   unfolding filter_eq_iff eventually_at_topological by (metis open_Int Int_iff UNIV_I)
 
 lemma (in topological_space) at_within_open_NO_MATCH:
   "a \<in> s \<Longrightarrow> open s \<Longrightarrow> NO_MATCH UNIV s \<Longrightarrow> at a within s = at a"
   by (simp only: at_within_open)
 
 lemma (in topological_space) at_within_open_subset:
   "a \<in> S \<Longrightarrow> open S \<Longrightarrow> S \<subseteq> T \<Longrightarrow> at a within T = at a"
   by (metis at_le at_within_open dual_order.antisym subset_UNIV)
 
 lemma (in topological_space) at_within_nhd:
   assumes "x \<in> S" "open S" "T \<inter> S - {x} = U \<inter> S - {x}"
   shows "at x within T = at x within U"
   unfolding filter_eq_iff eventually_at_filter
 proof (intro allI eventually_subst)
   have "eventually (\<lambda>x. x \<in> S) (nhds x)"
     using \<open>x \<in> S\<close> \<open>open S\<close> by (auto simp: eventually_nhds)
   then show "\<forall>\<^sub>F n in nhds x. (n \<noteq> x \<longrightarrow> n \<in> T \<longrightarrow> P n) = (n \<noteq> x \<longrightarrow> n \<in> U \<longrightarrow> P n)" for P
     by eventually_elim (insert \<open>T \<inter> S - {x} = U \<inter> S - {x}\<close>, blast)
 qed
 
 lemma (in topological_space) at_within_empty [simp]: "at a within {} = bot"
   unfolding at_within_def by simp
 
 lemma (in topological_space) at_within_union:
   "at x within (S \<union> T) = sup (at x within S) (at x within T)"
   unfolding filter_eq_iff eventually_sup eventually_at_filter
   by (auto elim!: eventually_rev_mp)
 
 lemma (in topological_space) at_eq_bot_iff: "at a = bot \<longleftrightarrow> open {a}"
   unfolding trivial_limit_def eventually_at_topological
   apply safe
    apply (case_tac "S = {a}")
     apply simp
    apply fast
   apply fast
   done
 
 lemma (in perfect_space) at_neq_bot [simp]: "at a \<noteq> bot"
   by (simp add: at_eq_bot_iff not_open_singleton)
 
 lemma (in order_topology) nhds_order:
   "nhds x = inf (INF a\<in>{x <..}. principal {..< a}) (INF a\<in>{..< x}. principal {a <..})"
 proof -
   have 1: "{S \<in> range lessThan \<union> range greaterThan. x \<in> S} =
       (\<lambda>a. {..< a}) ` {x <..} \<union> (\<lambda>a. {a <..}) ` {..< x}"
     by auto
   show ?thesis
     by (simp only: nhds_generated_topology[OF open_generated_order] INF_union 1 INF_image comp_def)
 qed
 
 lemma (in topological_space) filterlim_at_within_If:
   assumes "filterlim f G (at x within (A \<inter> {x. P x}))"
     and "filterlim g G (at x within (A \<inter> {x. \<not>P x}))"
   shows "filterlim (\<lambda>x. if P x then f x else g x) G (at x within A)"
 proof (rule filterlim_If)
   note assms(1)
   also have "at x within (A \<inter> {x. P x}) = inf (nhds x) (principal (A \<inter> Collect P - {x}))"
     by (simp add: at_within_def)
   also have "A \<inter> Collect P - {x} = (A - {x}) \<inter> Collect P"
     by blast
   also have "inf (nhds x) (principal \<dots>) = inf (at x within A) (principal (Collect P))"
     by (simp add: at_within_def inf_assoc)
   finally show "filterlim f G (inf (at x within A) (principal (Collect P)))" .
 next
   note assms(2)
   also have "at x within (A \<inter> {x. \<not> P x}) = inf (nhds x) (principal (A \<inter> {x. \<not> P x} - {x}))"
     by (simp add: at_within_def)
   also have "A \<inter> {x. \<not> P x} - {x} = (A - {x}) \<inter> {x. \<not> P x}"
     by blast
   also have "inf (nhds x) (principal \<dots>) = inf (at x within A) (principal {x. \<not> P x})"
     by (simp add: at_within_def inf_assoc)
   finally show "filterlim g G (inf (at x within A) (principal {x. \<not> P x}))" .
 qed
 
 lemma (in topological_space) filterlim_at_If:
   assumes "filterlim f G (at x within {x. P x})"
     and "filterlim g G (at x within {x. \<not>P x})"
   shows "filterlim (\<lambda>x. if P x then f x else g x) G (at x)"
   using assms by (intro filterlim_at_within_If) simp_all
 lemma (in linorder_topology) at_within_order:
   assumes "UNIV \<noteq> {x}"
   shows "at x within s =
     inf (INF a\<in>{x <..}. principal ({..< a} \<inter> s - {x}))
         (INF a\<in>{..< x}. principal ({a <..} \<inter> s - {x}))"
 proof (cases "{x <..} = {}" "{..< x} = {}" rule: case_split [case_product case_split])
   case True_True
   have "UNIV = {..< x} \<union> {x} \<union> {x <..}"
     by auto
   with assms True_True show ?thesis
     by auto
 qed (auto simp del: inf_principal simp: at_within_def nhds_order Int_Diff
       inf_principal[symmetric] INF_inf_const2 inf_sup_aci[where 'a="'a filter"])
 
 lemma (in linorder_topology) at_left_eq:
   "y < x \<Longrightarrow> at_left x = (INF a\<in>{..< x}. principal {a <..< x})"
   by (subst at_within_order)
      (auto simp: greaterThan_Int_greaterThan greaterThanLessThan_eq[symmetric] min.absorb2 INF_constant
            intro!: INF_lower2 inf_absorb2)
 
 lemma (in linorder_topology) eventually_at_left:
   "y < x \<Longrightarrow> eventually P (at_left x) \<longleftrightarrow> (\<exists>b<x. \<forall>y>b. y < x \<longrightarrow> P y)"
   unfolding at_left_eq
   by (subst eventually_INF_base) (auto simp: eventually_principal Ball_def)
 
 lemma (in linorder_topology) at_right_eq:
   "x < y \<Longrightarrow> at_right x = (INF a\<in>{x <..}. principal {x <..< a})"
   by (subst at_within_order)
      (auto simp: lessThan_Int_lessThan greaterThanLessThan_eq[symmetric] max.absorb2 INF_constant Int_commute
            intro!: INF_lower2 inf_absorb1)
 
 lemma (in linorder_topology) eventually_at_right:
   "x < y \<Longrightarrow> eventually P (at_right x) \<longleftrightarrow> (\<exists>b>x. \<forall>y>x. y < b \<longrightarrow> P y)"
   unfolding at_right_eq
   by (subst eventually_INF_base) (auto simp: eventually_principal Ball_def)
 
 lemma eventually_at_right_less: "\<forall>\<^sub>F y in at_right (x::'a::{linorder_topology, no_top}). x < y"
   using gt_ex[of x] eventually_at_right[of x] by auto
 
 lemma trivial_limit_at_right_top: "at_right (top::_::{order_top,linorder_topology}) = bot"
   by (auto simp: filter_eq_iff eventually_at_topological)
 
 lemma trivial_limit_at_left_bot: "at_left (bot::_::{order_bot,linorder_topology}) = bot"
   by (auto simp: filter_eq_iff eventually_at_topological)
 
 lemma trivial_limit_at_left_real [simp]: "\<not> trivial_limit (at_left x)"
   for x :: "'a::{no_bot,dense_order,linorder_topology}"
   using lt_ex [of x]
   by safe (auto simp add: trivial_limit_def eventually_at_left dest: dense)
 
 lemma trivial_limit_at_right_real [simp]: "\<not> trivial_limit (at_right x)"
   for x :: "'a::{no_top,dense_order,linorder_topology}"
   using gt_ex[of x]
   by safe (auto simp add: trivial_limit_def eventually_at_right dest: dense)
 
 lemma (in linorder_topology) at_eq_sup_left_right: "at x = sup (at_left x) (at_right x)"
   by (auto simp: eventually_at_filter filter_eq_iff eventually_sup
       elim: eventually_elim2 eventually_mono)
 
 lemma (in linorder_topology) eventually_at_split:
   "eventually P (at x) \<longleftrightarrow> eventually P (at_left x) \<and> eventually P (at_right x)"
   by (subst at_eq_sup_left_right) (simp add: eventually_sup)
 
 lemma (in order_topology) eventually_at_leftI:
   assumes "\<And>x. x \<in> {a<..<b} \<Longrightarrow> P x" "a < b"
   shows   "eventually P (at_left b)"
   using assms unfolding eventually_at_topological by (intro exI[of _ "{a<..}"]) auto
 
 lemma (in order_topology) eventually_at_rightI:
   assumes "\<And>x. x \<in> {a<..<b} \<Longrightarrow> P x" "a < b"
   shows   "eventually P (at_right a)"
   using assms unfolding eventually_at_topological by (intro exI[of _ "{..<b}"]) auto
 
 lemma eventually_filtercomap_nhds:
   "eventually P (filtercomap f (nhds x)) \<longleftrightarrow> (\<exists>S. open S \<and> x \<in> S \<and> (\<forall>x. f x \<in> S \<longrightarrow> P x))"
   unfolding eventually_filtercomap eventually_nhds by auto
 
 lemma eventually_filtercomap_at_topological:
   "eventually P (filtercomap f (at A within B)) \<longleftrightarrow> 
      (\<exists>S. open S \<and> A \<in> S \<and> (\<forall>x. f x \<in> S \<inter> B - {A} \<longrightarrow> P x))" (is "?lhs = ?rhs")
   unfolding at_within_def filtercomap_inf eventually_inf_principal filtercomap_principal 
           eventually_filtercomap_nhds eventually_principal by blast
 
 lemma eventually_at_right_field:
   "eventually P (at_right x) \<longleftrightarrow> (\<exists>b>x. \<forall>y>x. y < b \<longrightarrow> P y)"
   for x :: "'a::{linordered_field, linorder_topology}"
   using linordered_field_no_ub[rule_format, of x]
   by (auto simp: eventually_at_right)
 
 lemma eventually_at_left_field:
   "eventually P (at_left x) \<longleftrightarrow> (\<exists>b<x. \<forall>y>b. y < x \<longrightarrow> P y)"
   for x :: "'a::{linordered_field, linorder_topology}"
   using linordered_field_no_lb[rule_format, of x]
   by (auto simp: eventually_at_left)
 
 
 subsubsection \<open>Tendsto\<close>
 
 abbreviation (in topological_space)
   tendsto :: "('b \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'b filter \<Rightarrow> bool"  (infixr "\<longlongrightarrow>" 55)
   where "(f \<longlongrightarrow> l) F \<equiv> filterlim f (nhds l) F"
 
 definition (in t2_space) Lim :: "'f filter \<Rightarrow> ('f \<Rightarrow> 'a) \<Rightarrow> 'a"
   where "Lim A f = (THE l. (f \<longlongrightarrow> l) A)"
 
 lemma (in topological_space) tendsto_eq_rhs: "(f \<longlongrightarrow> x) F \<Longrightarrow> x = y \<Longrightarrow> (f \<longlongrightarrow> y) F"
   by simp
 
 named_theorems tendsto_intros "introduction rules for tendsto"
 setup \<open>
   Global_Theory.add_thms_dynamic (\<^binding>\<open>tendsto_eq_intros\<close>,
     fn context =>
       Named_Theorems.get (Context.proof_of context) \<^named_theorems>\<open>tendsto_intros\<close>
       |> map_filter (try (fn thm => @{thm tendsto_eq_rhs} OF [thm])))
 \<close>
 
 context topological_space begin
 
 lemma tendsto_def:
    "(f \<longlongrightarrow> l) F \<longleftrightarrow> (\<forall>S. open S \<longrightarrow> l \<in> S \<longrightarrow> eventually (\<lambda>x. f x \<in> S) F)"
    unfolding nhds_def filterlim_INF filterlim_principal by auto
 
 lemma tendsto_cong: "(f \<longlongrightarrow> c) F \<longleftrightarrow> (g \<longlongrightarrow> c) F" if "eventually (\<lambda>x. f x = g x) F"
   by (rule filterlim_cong [OF refl refl that])
 
 lemma tendsto_mono: "F \<le> F' \<Longrightarrow> (f \<longlongrightarrow> l) F' \<Longrightarrow> (f \<longlongrightarrow> l) F"
   unfolding tendsto_def le_filter_def by fast
 
 lemma tendsto_ident_at [tendsto_intros, simp, intro]: "((\<lambda>x. x) \<longlongrightarrow> a) (at a within s)"
   by (auto simp: tendsto_def eventually_at_topological)
 
 lemma tendsto_const [tendsto_intros, simp, intro]: "((\<lambda>x. k) \<longlongrightarrow> k) F"
   by (simp add: tendsto_def)
 
 lemma filterlim_at:
   "(LIM x F. f x :> at b within s) \<longleftrightarrow> eventually (\<lambda>x. f x \<in> s \<and> f x \<noteq> b) F \<and> (f \<longlongrightarrow> b) F"
   by (simp add: at_within_def filterlim_inf filterlim_principal conj_commute)
 
 lemma (in -)
   assumes "filterlim f (nhds L) F"
   shows tendsto_imp_filterlim_at_right:
           "eventually (\<lambda>x. f x > L) F \<Longrightarrow> filterlim f (at_right L) F"
     and tendsto_imp_filterlim_at_left:
           "eventually (\<lambda>x. f x < L) F \<Longrightarrow> filterlim f (at_left L) F"
   using assms by (auto simp: filterlim_at elim: eventually_mono)
 
 lemma  filterlim_at_withinI:
   assumes "filterlim f (nhds c) F"
   assumes "eventually (\<lambda>x. f x \<in> A - {c}) F"
   shows   "filterlim f (at c within A) F"
   using assms by (simp add: filterlim_at)
 
 lemma filterlim_atI:
   assumes "filterlim f (nhds c) F"
   assumes "eventually (\<lambda>x. f x \<noteq> c) F"
   shows   "filterlim f (at c) F"
   using assms by (intro filterlim_at_withinI) simp_all
 
 lemma topological_tendstoI:
   "(\<And>S. open S \<Longrightarrow> l \<in> S \<Longrightarrow> eventually (\<lambda>x. f x \<in> S) F) \<Longrightarrow> (f \<longlongrightarrow> l) F"
   by (auto simp: tendsto_def)
 
 lemma topological_tendstoD:
   "(f \<longlongrightarrow> l) F \<Longrightarrow> open S \<Longrightarrow> l \<in> S \<Longrightarrow> eventually (\<lambda>x. f x \<in> S) F"
   by (auto simp: tendsto_def)
 
 lemma tendsto_bot [simp]: "(f \<longlongrightarrow> a) bot"
   by (simp add: tendsto_def)
 
 lemma tendsto_eventually: "eventually (\<lambda>x. f x = l) net \<Longrightarrow> ((\<lambda>x. f x) \<longlongrightarrow> l) net"
   by (rule topological_tendstoI) (auto elim: eventually_mono)
 
 end
 
 lemma (in topological_space) filterlim_within_subset:
   "filterlim f l (at x within S) \<Longrightarrow> T \<subseteq> S \<Longrightarrow> filterlim f l (at x within T)"
   by (blast intro: filterlim_mono at_le)
 
 lemmas tendsto_within_subset = filterlim_within_subset
 
 lemma (in order_topology) order_tendsto_iff:
   "(f \<longlongrightarrow> x) F \<longleftrightarrow> (\<forall>l<x. eventually (\<lambda>x. l < f x) F) \<and> (\<forall>u>x. eventually (\<lambda>x. f x < u) F)"
   by (auto simp: nhds_order filterlim_inf filterlim_INF filterlim_principal)
 
 lemma (in order_topology) order_tendstoI:
   "(\<And>a. a < y \<Longrightarrow> eventually (\<lambda>x. a < f x) F) \<Longrightarrow> (\<And>a. y < a \<Longrightarrow> eventually (\<lambda>x. f x < a) F) \<Longrightarrow>
     (f \<longlongrightarrow> y) F"
   by (auto simp: order_tendsto_iff)
 
 lemma (in order_topology) order_tendstoD:
   assumes "(f \<longlongrightarrow> y) F"
   shows "a < y \<Longrightarrow> eventually (\<lambda>x. a < f x) F"
     and "y < a \<Longrightarrow> eventually (\<lambda>x. f x < a) F"
   using assms by (auto simp: order_tendsto_iff)
 
 lemma (in linorder_topology) tendsto_max[tendsto_intros]:
   assumes X: "(X \<longlongrightarrow> x) net"
     and Y: "(Y \<longlongrightarrow> y) net"
   shows "((\<lambda>x. max (X x) (Y x)) \<longlongrightarrow> max x y) net"
 proof (rule order_tendstoI)
   fix a
   assume "a < max x y"
   then show "eventually (\<lambda>x. a < max (X x) (Y x)) net"
     using order_tendstoD(1)[OF X, of a] order_tendstoD(1)[OF Y, of a]
     by (auto simp: less_max_iff_disj elim: eventually_mono)
 next
   fix a
   assume "max x y < a"
   then show "eventually (\<lambda>x. max (X x) (Y x) < a) net"
     using order_tendstoD(2)[OF X, of a] order_tendstoD(2)[OF Y, of a]
     by (auto simp: eventually_conj_iff)
 qed
 
 lemma (in linorder_topology) tendsto_min[tendsto_intros]:
   assumes X: "(X \<longlongrightarrow> x) net"
     and Y: "(Y \<longlongrightarrow> y) net"
   shows "((\<lambda>x. min (X x) (Y x)) \<longlongrightarrow> min x y) net"
 proof (rule order_tendstoI)
   fix a
   assume "a < min x y"
   then show "eventually (\<lambda>x. a < min (X x) (Y x)) net"
     using order_tendstoD(1)[OF X, of a] order_tendstoD(1)[OF Y, of a]
     by (auto simp: eventually_conj_iff)
 next
   fix a
   assume "min x y < a"
   then show "eventually (\<lambda>x. min (X x) (Y x) < a) net"
     using order_tendstoD(2)[OF X, of a] order_tendstoD(2)[OF Y, of a]
     by (auto simp: min_less_iff_disj elim: eventually_mono)
 qed
 
 lemma (in order_topology)
   assumes "a < b"
   shows at_within_Icc_at_right: "at a within {a..b} = at_right a"
     and at_within_Icc_at_left:  "at b within {a..b} = at_left b"
   using order_tendstoD(2)[OF tendsto_ident_at assms, of "{a<..}"]
   using order_tendstoD(1)[OF tendsto_ident_at assms, of "{..<b}"]
   by (auto intro!: order_class.order_antisym filter_leI
       simp: eventually_at_filter less_le
       elim: eventually_elim2)
 
 lemma (in order_topology) at_within_Icc_at: "a < x \<Longrightarrow> x < b \<Longrightarrow> at x within {a..b} = at x"
   by (rule at_within_open_subset[where S="{a<..<b}"]) auto
 
 lemma (in t2_space) tendsto_unique:
   assumes "F \<noteq> bot"
     and "(f \<longlongrightarrow> a) F"
     and "(f \<longlongrightarrow> b) F"
   shows "a = b"
 proof (rule ccontr)
   assume "a \<noteq> b"
   obtain U V where "open U" "open V" "a \<in> U" "b \<in> V" "U \<inter> V = {}"
     using hausdorff [OF \<open>a \<noteq> b\<close>] by fast
   have "eventually (\<lambda>x. f x \<in> U) F"
     using \<open>(f \<longlongrightarrow> a) F\<close> \<open>open U\<close> \<open>a \<in> U\<close> by (rule topological_tendstoD)
   moreover
   have "eventually (\<lambda>x. f x \<in> V) F"
     using \<open>(f \<longlongrightarrow> b) F\<close> \<open>open V\<close> \<open>b \<in> V\<close> by (rule topological_tendstoD)
   ultimately
   have "eventually (\<lambda>x. False) F"
   proof eventually_elim
     case (elim x)
     then have "f x \<in> U \<inter> V" by simp
     with \<open>U \<inter> V = {}\<close> show ?case by simp
   qed
   with \<open>\<not> trivial_limit F\<close> show "False"
     by (simp add: trivial_limit_def)
 qed
 
 lemma (in t2_space) tendsto_const_iff:
   fixes a b :: 'a
   assumes "\<not> trivial_limit F"
   shows "((\<lambda>x. a) \<longlongrightarrow> b) F \<longleftrightarrow> a = b"
   by (auto intro!: tendsto_unique [OF assms tendsto_const])
 
 lemma (in t2_space) tendsto_unique':
  assumes "F \<noteq> bot"
  shows "\<exists>\<^sub>\<le>\<^sub>1l. (f \<longlongrightarrow> l) F"
  using Uniq_def assms local.tendsto_unique by fastforce
 
 lemma Lim_in_closed_set:
   assumes "closed S" "eventually (\<lambda>x. f(x) \<in> S) F" "F \<noteq> bot" "(f \<longlongrightarrow> l) F"
   shows "l \<in> S"
 proof (rule ccontr)
   assume "l \<notin> S"
   with \<open>closed S\<close> have "open (- S)" "l \<in> - S"
     by (simp_all add: open_Compl)
   with assms(4) have "eventually (\<lambda>x. f x \<in> - S) F"
     by (rule topological_tendstoD)
   with assms(2) have "eventually (\<lambda>x. False) F"
     by (rule eventually_elim2) simp
   with assms(3) show "False"
     by (simp add: eventually_False)
 qed
 
 lemma (in t3_space) nhds_closed:
   assumes "x \<in> A" and "open A"
   shows   "\<exists>A'. x \<in> A' \<and> closed A' \<and> A' \<subseteq> A \<and> eventually (\<lambda>y. y \<in> A') (nhds x)"
 proof -
   from assms have "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> - A \<subseteq> V \<and> U \<inter> V = {}"
     by (intro t3_space) auto
   then obtain U V where UV: "open U" "open V" "x \<in> U" "-A \<subseteq> V" "U \<inter> V = {}"
     by auto
   have "eventually (\<lambda>y. y \<in> U) (nhds x)"
     using \<open>open U\<close> and \<open>x \<in> U\<close> by (intro eventually_nhds_in_open)
   hence "eventually (\<lambda>y. y \<in> -V) (nhds x)"
     by eventually_elim (use UV in auto)
   with UV show ?thesis by (intro exI[of _ "-V"]) auto
 qed
 
 lemma (in order_topology) increasing_tendsto:
   assumes bdd: "eventually (\<lambda>n. f n \<le> l) F"
     and en: "\<And>x. x < l \<Longrightarrow> eventually (\<lambda>n. x < f n) F"
   shows "(f \<longlongrightarrow> l) F"
   using assms by (intro order_tendstoI) (auto elim!: eventually_mono)
 
 lemma (in order_topology) decreasing_tendsto:
   assumes bdd: "eventually (\<lambda>n. l \<le> f n) F"
     and en: "\<And>x. l < x \<Longrightarrow> eventually (\<lambda>n. f n < x) F"
   shows "(f \<longlongrightarrow> l) F"
   using assms by (intro order_tendstoI) (auto elim!: eventually_mono)
 
 lemma (in order_topology) tendsto_sandwich:
   assumes ev: "eventually (\<lambda>n. f n \<le> g n) net" "eventually (\<lambda>n. g n \<le> h n) net"
   assumes lim: "(f \<longlongrightarrow> c) net" "(h \<longlongrightarrow> c) net"
   shows "(g \<longlongrightarrow> c) net"
 proof (rule order_tendstoI)
   fix a
   show "a < c \<Longrightarrow> eventually (\<lambda>x. a < g x) net"
     using order_tendstoD[OF lim(1), of a] ev by (auto elim: eventually_elim2)
 next
   fix a
   show "c < a \<Longrightarrow> eventually (\<lambda>x. g x < a) net"
     using order_tendstoD[OF lim(2), of a] ev by (auto elim: eventually_elim2)
 qed
 
 lemma (in t1_space) limit_frequently_eq:
   assumes "F \<noteq> bot"
     and "frequently (\<lambda>x. f x = c) F"
     and "(f \<longlongrightarrow> d) F"
   shows "d = c"
 proof (rule ccontr)
   assume "d \<noteq> c"
   from t1_space[OF this] obtain U where "open U" "d \<in> U" "c \<notin> U"
     by blast
   with assms have "eventually (\<lambda>x. f x \<in> U) F"
     unfolding tendsto_def by blast
   then have "eventually (\<lambda>x. f x \<noteq> c) F"
     by eventually_elim (insert \<open>c \<notin> U\<close>, blast)
   with assms(2) show False
     unfolding frequently_def by contradiction
 qed
 
 lemma (in t1_space) tendsto_imp_eventually_ne:
   assumes  "(f \<longlongrightarrow> c) F" "c \<noteq> c'"
   shows "eventually (\<lambda>z. f z \<noteq> c') F"
 proof (cases "F=bot")
   case True
   thus ?thesis by auto
 next
   case False
   show ?thesis
   proof (rule ccontr)
     assume "\<not> eventually (\<lambda>z. f z \<noteq> c') F"
     then have "frequently (\<lambda>z. f z = c') F"
       by (simp add: frequently_def)
     from limit_frequently_eq[OF False this \<open>(f \<longlongrightarrow> c) F\<close>] and \<open>c \<noteq> c'\<close> show False
       by contradiction
   qed
 qed
 
 lemma (in linorder_topology) tendsto_le:
   assumes F: "\<not> trivial_limit F"
     and x: "(f \<longlongrightarrow> x) F"
     and y: "(g \<longlongrightarrow> y) F"
     and ev: "eventually (\<lambda>x. g x \<le> f x) F"
   shows "y \<le> x"
 proof (rule ccontr)
   assume "\<not> y \<le> x"
   with less_separate[of x y] obtain a b where xy: "x < a" "b < y" "{..<a} \<inter> {b<..} = {}"
     by (auto simp: not_le)
   then have "eventually (\<lambda>x. f x < a) F" "eventually (\<lambda>x. b < g x) F"
     using x y by (auto intro: order_tendstoD)
   with ev have "eventually (\<lambda>x. False) F"
     by eventually_elim (insert xy, fastforce)
   with F show False
     by (simp add: eventually_False)
 qed
 
 lemma (in linorder_topology) tendsto_lowerbound:
   assumes x: "(f \<longlongrightarrow> x) F"
       and ev: "eventually (\<lambda>i. a \<le> f i) F"
       and F: "\<not> trivial_limit F"
   shows "a \<le> x"
   using F x tendsto_const ev by (rule tendsto_le)
 
 lemma (in linorder_topology) tendsto_upperbound:
   assumes x: "(f \<longlongrightarrow> x) F"
       and ev: "eventually (\<lambda>i. a \<ge> f i) F"
       and F: "\<not> trivial_limit F"
   shows "a \<ge> x"
   by (rule tendsto_le [OF F tendsto_const x ev])
 
 lemma filterlim_at_within_not_equal:
   fixes f::"'a \<Rightarrow> 'b::t2_space"
   assumes "filterlim f (at a within s) F"
   shows "eventually (\<lambda>w. f w\<in>s \<and> f w \<noteq>b) F"
 proof (cases "a=b")
   case True
   then show ?thesis using assms by (simp add: filterlim_at)
 next
   case False
   from hausdorff[OF this] obtain U V where UV:"open U" "open V" "a \<in> U" "b \<in> V" "U \<inter> V = {}"
     by auto  
   have "(f \<longlongrightarrow> a) F" using assms filterlim_at by auto
   then have "\<forall>\<^sub>F x in F. f x \<in> U" using UV unfolding tendsto_def by auto
   moreover have  "\<forall>\<^sub>F x in F. f x \<in> s \<and> f x\<noteq>a" using assms filterlim_at by auto
   ultimately show ?thesis 
     apply eventually_elim
     using UV by auto
 qed
 
 subsubsection \<open>Rules about \<^const>\<open>Lim\<close>\<close>
 
 lemma tendsto_Lim: "\<not> trivial_limit net \<Longrightarrow> (f \<longlongrightarrow> l) net \<Longrightarrow> Lim net f = l"
   unfolding Lim_def using tendsto_unique [of net f] by auto
 
 lemma Lim_ident_at: "\<not> trivial_limit (at x within s) \<Longrightarrow> Lim (at x within s) (\<lambda>x. x) = x"
   by (rule tendsto_Lim[OF _ tendsto_ident_at]) auto
 
 lemma eventually_Lim_ident_at:
   "(\<forall>\<^sub>F y in at x within X. P (Lim (at x within X) (\<lambda>x. x)) y) \<longleftrightarrow>
     (\<forall>\<^sub>F y in at x within X. P x y)" for x::"'a::t2_space"
   by (cases "at x within X = bot") (auto simp: Lim_ident_at)
 
 lemma filterlim_at_bot_at_right:
   fixes f :: "'a::linorder_topology \<Rightarrow> 'b::linorder"
   assumes mono: "\<And>x y. Q x \<Longrightarrow> Q y \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
     and bij: "\<And>x. P x \<Longrightarrow> f (g x) = x" "\<And>x. P x \<Longrightarrow> Q (g x)"
     and Q: "eventually Q (at_right a)"
     and bound: "\<And>b. Q b \<Longrightarrow> a < b"
     and P: "eventually P at_bot"
   shows "filterlim f at_bot (at_right a)"
 proof -
   from P obtain x where x: "\<And>y. y \<le> x \<Longrightarrow> P y"
     unfolding eventually_at_bot_linorder by auto
   show ?thesis
   proof (intro filterlim_at_bot_le[THEN iffD2] allI impI)
     fix z
     assume "z \<le> x"
     with x have "P z" by auto
     have "eventually (\<lambda>x. x \<le> g z) (at_right a)"
       using bound[OF bij(2)[OF \<open>P z\<close>]]
       unfolding eventually_at_right[OF bound[OF bij(2)[OF \<open>P z\<close>]]]
       by (auto intro!: exI[of _ "g z"])
     with Q show "eventually (\<lambda>x. f x \<le> z) (at_right a)"
       by eventually_elim (metis bij \<open>P z\<close> mono)
   qed
 qed
 
 lemma filterlim_at_top_at_left:
   fixes f :: "'a::linorder_topology \<Rightarrow> 'b::linorder"
   assumes mono: "\<And>x y. Q x \<Longrightarrow> Q y \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
     and bij: "\<And>x. P x \<Longrightarrow> f (g x) = x" "\<And>x. P x \<Longrightarrow> Q (g x)"
     and Q: "eventually Q (at_left a)"
     and bound: "\<And>b. Q b \<Longrightarrow> b < a"
     and P: "eventually P at_top"
   shows "filterlim f at_top (at_left a)"
 proof -
   from P obtain x where x: "\<And>y. x \<le> y \<Longrightarrow> P y"
     unfolding eventually_at_top_linorder by auto
   show ?thesis
   proof (intro filterlim_at_top_ge[THEN iffD2] allI impI)
     fix z
     assume "x \<le> z"
     with x have "P z" by auto
     have "eventually (\<lambda>x. g z \<le> x) (at_left a)"
       using bound[OF bij(2)[OF \<open>P z\<close>]]
       unfolding eventually_at_left[OF bound[OF bij(2)[OF \<open>P z\<close>]]]
       by (auto intro!: exI[of _ "g z"])
     with Q show "eventually (\<lambda>x. z \<le> f x) (at_left a)"
       by eventually_elim (metis bij \<open>P z\<close> mono)
   qed
 qed
 
 lemma filterlim_split_at:
   "filterlim f F (at_left x) \<Longrightarrow> filterlim f F (at_right x) \<Longrightarrow>
     filterlim f F (at x)"
   for x :: "'a::linorder_topology"
   by (subst at_eq_sup_left_right) (rule filterlim_sup)
 
 lemma filterlim_at_split:
   "filterlim f F (at x) \<longleftrightarrow> filterlim f F (at_left x) \<and> filterlim f F (at_right x)"
   for x :: "'a::linorder_topology"
   by (subst at_eq_sup_left_right) (simp add: filterlim_def filtermap_sup)
 
 lemma eventually_nhds_top:
   fixes P :: "'a :: {order_top,linorder_topology} \<Rightarrow> bool"
     and b :: 'a
   assumes "b < top"
   shows "eventually P (nhds top) \<longleftrightarrow> (\<exists>b<top. (\<forall>z. b < z \<longrightarrow> P z))"
   unfolding eventually_nhds
 proof safe
   fix S :: "'a set"
   assume "open S" "top \<in> S"
   note open_left[OF this \<open>b < top\<close>]
   moreover assume "\<forall>s\<in>S. P s"
   ultimately show "\<exists>b<top. \<forall>z>b. P z"
     by (auto simp: subset_eq Ball_def)
 next
   fix b
   assume "b < top" "\<forall>z>b. P z"
   then show "\<exists>S. open S \<and> top \<in> S \<and> (\<forall>xa\<in>S. P xa)"
     by (intro exI[of _ "{b <..}"]) auto
 qed
 
 lemma tendsto_at_within_iff_tendsto_nhds:
   "(g \<longlongrightarrow> g l) (at l within S) \<longleftrightarrow> (g \<longlongrightarrow> g l) (inf (nhds l) (principal S))"
   unfolding tendsto_def eventually_at_filter eventually_inf_principal
   by (intro ext all_cong imp_cong) (auto elim!: eventually_mono)
 
 
 subsection \<open>Limits on sequences\<close>
 
 abbreviation (in topological_space)
   LIMSEQ :: "[nat \<Rightarrow> 'a, 'a] \<Rightarrow> bool"  ("((_)/ \<longlonglongrightarrow> (_))" [60, 60] 60)
   where "X \<longlonglongrightarrow> L \<equiv> (X \<longlongrightarrow> L) sequentially"
 
 abbreviation (in t2_space) lim :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
   where "lim X \<equiv> Lim sequentially X"
 
 definition (in topological_space) convergent :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
   where "convergent X = (\<exists>L. X \<longlonglongrightarrow> L)"
 
 lemma lim_def: "lim X = (THE L. X \<longlonglongrightarrow> L)"
   unfolding Lim_def ..
 
 lemma lim_explicit:
   "f \<longlonglongrightarrow> f0 \<longleftrightarrow> (\<forall>S. open S \<longrightarrow> f0 \<in> S \<longrightarrow> (\<exists>N. \<forall>n\<ge>N. f n \<in> S))"
   unfolding tendsto_def eventually_sequentially by auto
 
 
 subsection \<open>Monotone sequences and subsequences\<close>
 
 text \<open>
   Definition of monotonicity.
   The use of disjunction here complicates proofs considerably.
   One alternative is to add a Boolean argument to indicate the direction.
   Another is to develop the notions of increasing and decreasing first.
 \<close>
 definition monoseq :: "(nat \<Rightarrow> 'a::order) \<Rightarrow> bool"
   where "monoseq X \<longleftrightarrow> (\<forall>m. \<forall>n\<ge>m. X m \<le> X n) \<or> (\<forall>m. \<forall>n\<ge>m. X n \<le> X m)"
 
 abbreviation incseq :: "(nat \<Rightarrow> 'a::order) \<Rightarrow> bool"
   where "incseq X \<equiv> mono X"
 
 lemma incseq_def: "incseq X \<longleftrightarrow> (\<forall>m. \<forall>n\<ge>m. X n \<ge> X m)"
   unfolding mono_def ..
 
 abbreviation decseq :: "(nat \<Rightarrow> 'a::order) \<Rightarrow> bool"
   where "decseq X \<equiv> antimono X"
 
 lemma decseq_def: "decseq X \<longleftrightarrow> (\<forall>m. \<forall>n\<ge>m. X n \<le> X m)"
   unfolding antimono_def ..
 
 subsubsection \<open>Definition of subsequence.\<close>
 
 (* For compatibility with the old "subseq" *)
 lemma strict_mono_leD: "strict_mono r \<Longrightarrow> m \<le> n \<Longrightarrow> r m \<le> r n"
   by (erule (1) monoD [OF strict_mono_mono])
 
 lemma strict_mono_id: "strict_mono id"
   by (simp add: strict_mono_def)
 
 lemma incseq_SucI: "(\<And>n. X n \<le> X (Suc n)) \<Longrightarrow> incseq X"
   using lift_Suc_mono_le[of X] by (auto simp: incseq_def)
 
 lemma incseqD: "incseq f \<Longrightarrow> i \<le> j \<Longrightarrow> f i \<le> f j"
   by (auto simp: incseq_def)
 
 lemma incseq_SucD: "incseq A \<Longrightarrow> A i \<le> A (Suc i)"
   using incseqD[of A i "Suc i"] by auto
 
 lemma incseq_Suc_iff: "incseq f \<longleftrightarrow> (\<forall>n. f n \<le> f (Suc n))"
   by (auto intro: incseq_SucI dest: incseq_SucD)
 
 lemma incseq_const[simp, intro]: "incseq (\<lambda>x. k)"
   unfolding incseq_def by auto
 
 lemma decseq_SucI: "(\<And>n. X (Suc n) \<le> X n) \<Longrightarrow> decseq X"
   using order.lift_Suc_mono_le[OF dual_order, of X] by (auto simp: decseq_def)
 
 lemma decseqD: "decseq f \<Longrightarrow> i \<le> j \<Longrightarrow> f j \<le> f i"
   by (auto simp: decseq_def)
 
 lemma decseq_SucD: "decseq A \<Longrightarrow> A (Suc i) \<le> A i"
   using decseqD[of A i "Suc i"] by auto
 
 lemma decseq_Suc_iff: "decseq f \<longleftrightarrow> (\<forall>n. f (Suc n) \<le> f n)"
   by (auto intro: decseq_SucI dest: decseq_SucD)
 
 lemma decseq_const[simp, intro]: "decseq (\<lambda>x. k)"
   unfolding decseq_def by auto
 
 lemma monoseq_iff: "monoseq X \<longleftrightarrow> incseq X \<or> decseq X"
   unfolding monoseq_def incseq_def decseq_def ..
 
 lemma monoseq_Suc: "monoseq X \<longleftrightarrow> (\<forall>n. X n \<le> X (Suc n)) \<or> (\<forall>n. X (Suc n) \<le> X n)"
   unfolding monoseq_iff incseq_Suc_iff decseq_Suc_iff ..
 
 lemma monoI1: "\<forall>m. \<forall>n \<ge> m. X m \<le> X n \<Longrightarrow> monoseq X"
   by (simp add: monoseq_def)
 
 lemma monoI2: "\<forall>m. \<forall>n \<ge> m. X n \<le> X m \<Longrightarrow> monoseq X"
   by (simp add: monoseq_def)
 
 lemma mono_SucI1: "\<forall>n. X n \<le> X (Suc n) \<Longrightarrow> monoseq X"
   by (simp add: monoseq_Suc)
 
 lemma mono_SucI2: "\<forall>n. X (Suc n) \<le> X n \<Longrightarrow> monoseq X"
   by (simp add: monoseq_Suc)
 
 lemma monoseq_minus:
   fixes a :: "nat \<Rightarrow> 'a::ordered_ab_group_add"
   assumes "monoseq a"
   shows "monoseq (\<lambda> n. - a n)"
 proof (cases "\<forall>m. \<forall>n \<ge> m. a m \<le> a n")
   case True
   then have "\<forall>m. \<forall>n \<ge> m. - a n \<le> - a m" by auto
   then show ?thesis by (rule monoI2)
 next
   case False
   then have "\<forall>m. \<forall>n \<ge> m. - a m \<le> - a n"
     using \<open>monoseq a\<close>[unfolded monoseq_def] by auto
   then show ?thesis by (rule monoI1)
 qed
 
 
 subsubsection \<open>Subsequence (alternative definition, (e.g. Hoskins)\<close>
 
 lemma strict_mono_Suc_iff: "strict_mono f \<longleftrightarrow> (\<forall>n. f n < f (Suc n))"
 proof (intro iffI strict_monoI)
   assume *: "\<forall>n. f n < f (Suc n)"
   fix m n :: nat assume "m < n"
   thus "f m < f n"
     by (induction rule: less_Suc_induct) (use * in auto)
 qed (auto simp: strict_mono_def)
 
 lemma strict_mono_add: "strict_mono (\<lambda>n::'a::linordered_semidom. n + k)"
   by (auto simp: strict_mono_def)
 
 text \<open>For any sequence, there is a monotonic subsequence.\<close>
 lemma seq_monosub:
   fixes s :: "nat \<Rightarrow> 'a::linorder"
   shows "\<exists>f. strict_mono f \<and> monoseq (\<lambda>n. (s (f n)))"
 proof (cases "\<forall>n. \<exists>p>n. \<forall>m\<ge>p. s m \<le> s p")
   case True
   then have "\<exists>f. \<forall>n. (\<forall>m\<ge>f n. s m \<le> s (f n)) \<and> f n < f (Suc n)"
     by (intro dependent_nat_choice) (auto simp: conj_commute)
   then obtain f :: "nat \<Rightarrow> nat" 
     where f: "strict_mono f" and mono: "\<And>n m. f n \<le> m \<Longrightarrow> s m \<le> s (f n)"
     by (auto simp: strict_mono_Suc_iff)
   then have "incseq f"
     unfolding strict_mono_Suc_iff incseq_Suc_iff by (auto intro: less_imp_le)
   then have "monoseq (\<lambda>n. s (f n))"
     by (auto simp add: incseq_def intro!: mono monoI2)
   with f show ?thesis
     by auto
 next
   case False
   then obtain N where N: "p > N \<Longrightarrow> \<exists>m>p. s p < s m" for p
     by (force simp: not_le le_less)
   have "\<exists>f. \<forall>n. N < f n \<and> f n < f (Suc n) \<and> s (f n) \<le> s (f (Suc n))"
   proof (intro dependent_nat_choice)
     fix x
     assume "N < x" with N[of x]
     show "\<exists>y>N. x < y \<and> s x \<le> s y"
       by (auto intro: less_trans)
   qed auto
   then show ?thesis
     by (auto simp: monoseq_iff incseq_Suc_iff strict_mono_Suc_iff)
 qed
 
 lemma seq_suble:
   assumes sf: "strict_mono (f :: nat \<Rightarrow> nat)"
   shows "n \<le> f n"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case (Suc n)
   with sf [unfolded strict_mono_Suc_iff, rule_format, of n] have "n < f (Suc n)"
      by arith
   then show ?case by arith
 qed
 
 lemma eventually_subseq:
   "strict_mono r \<Longrightarrow> eventually P sequentially \<Longrightarrow> eventually (\<lambda>n. P (r n)) sequentially"
   unfolding eventually_sequentially by (metis seq_suble le_trans)
 
 lemma not_eventually_sequentiallyD:
   assumes "\<not> eventually P sequentially"
   shows "\<exists>r::nat\<Rightarrow>nat. strict_mono r \<and> (\<forall>n. \<not> P (r n))"
 proof -
   from assms have "\<forall>n. \<exists>m\<ge>n. \<not> P m"
     unfolding eventually_sequentially by (simp add: not_less)
   then obtain r where "\<And>n. r n \<ge> n" "\<And>n. \<not> P (r n)"
     by (auto simp: choice_iff)
   then show ?thesis
     by (auto intro!: exI[of _ "\<lambda>n. r (((Suc \<circ> r) ^^ Suc n) 0)"]
              simp: less_eq_Suc_le strict_mono_Suc_iff)
 qed
 
 lemma sequentially_offset: 
   assumes "eventually (\<lambda>i. P i) sequentially"
   shows "eventually (\<lambda>i. P (i + k)) sequentially"
   using assms by (rule eventually_sequentially_seg [THEN iffD2])
 
 lemma seq_offset_neg: 
   "(f \<longlongrightarrow> l) sequentially \<Longrightarrow> ((\<lambda>i. f(i - k)) \<longlongrightarrow> l) sequentially"
   apply (erule filterlim_compose)
   apply (simp add: filterlim_def le_sequentially eventually_filtermap eventually_sequentially, arith)
   done
 
 lemma filterlim_subseq: "strict_mono f \<Longrightarrow> filterlim f sequentially sequentially"
   unfolding filterlim_iff by (metis eventually_subseq)
 
 lemma strict_mono_o: "strict_mono r \<Longrightarrow> strict_mono s \<Longrightarrow> strict_mono (r \<circ> s)"
   unfolding strict_mono_def by simp
 
 lemma strict_mono_compose: "strict_mono r \<Longrightarrow> strict_mono s \<Longrightarrow> strict_mono (\<lambda>x. r (s x))"
   using strict_mono_o[of r s] by (simp add: o_def)
 
 lemma incseq_imp_monoseq:  "incseq X \<Longrightarrow> monoseq X"
   by (simp add: incseq_def monoseq_def)
 
 lemma decseq_imp_monoseq:  "decseq X \<Longrightarrow> monoseq X"
   by (simp add: decseq_def monoseq_def)
 
 lemma decseq_eq_incseq: "decseq X = incseq (\<lambda>n. - X n)"
   for X :: "nat \<Rightarrow> 'a::ordered_ab_group_add"
   by (simp add: decseq_def incseq_def)
 
 lemma INT_decseq_offset:
   assumes "decseq F"
   shows "(\<Inter>i. F i) = (\<Inter>i\<in>{n..}. F i)"
 proof safe
   fix x i
   assume x: "x \<in> (\<Inter>i\<in>{n..}. F i)"
   show "x \<in> F i"
   proof cases
     from x have "x \<in> F n" by auto
     also assume "i \<le> n" with \<open>decseq F\<close> have "F n \<subseteq> F i"
       unfolding decseq_def by simp
     finally show ?thesis .
   qed (insert x, simp)
 qed auto
 
 lemma LIMSEQ_const_iff: "(\<lambda>n. k) \<longlonglongrightarrow> l \<longleftrightarrow> k = l"
   for k l :: "'a::t2_space"
   using trivial_limit_sequentially by (rule tendsto_const_iff)
 
 lemma LIMSEQ_SUP: "incseq X \<Longrightarrow> X \<longlonglongrightarrow> (SUP i. X i :: 'a::{complete_linorder,linorder_topology})"
   by (intro increasing_tendsto)
     (auto simp: SUP_upper less_SUP_iff incseq_def eventually_sequentially intro: less_le_trans)
 
 lemma LIMSEQ_INF: "decseq X \<Longrightarrow> X \<longlonglongrightarrow> (INF i. X i :: 'a::{complete_linorder,linorder_topology})"
   by (intro decreasing_tendsto)
     (auto simp: INF_lower INF_less_iff decseq_def eventually_sequentially intro: le_less_trans)
 
 lemma LIMSEQ_ignore_initial_segment: "f \<longlonglongrightarrow> a \<Longrightarrow> (\<lambda>n. f (n + k)) \<longlonglongrightarrow> a"
   unfolding tendsto_def by (subst eventually_sequentially_seg[where k=k])
 
 lemma LIMSEQ_offset: "(\<lambda>n. f (n + k)) \<longlonglongrightarrow> a \<Longrightarrow> f \<longlonglongrightarrow> a"
   unfolding tendsto_def
   by (subst (asm) eventually_sequentially_seg[where k=k])
 
 lemma LIMSEQ_Suc: "f \<longlonglongrightarrow> l \<Longrightarrow> (\<lambda>n. f (Suc n)) \<longlonglongrightarrow> l"
   by (drule LIMSEQ_ignore_initial_segment [where k="Suc 0"]) simp
 
 lemma LIMSEQ_imp_Suc: "(\<lambda>n. f (Suc n)) \<longlonglongrightarrow> l \<Longrightarrow> f \<longlonglongrightarrow> l"
   by (rule LIMSEQ_offset [where k="Suc 0"]) simp
 
 lemma LIMSEQ_lessThan_iff_atMost:
   shows "(\<lambda>n. f {..<n}) \<longlonglongrightarrow> x \<longleftrightarrow> (\<lambda>n. f {..n}) \<longlonglongrightarrow> x"
   apply (subst filterlim_sequentially_Suc [symmetric])
   apply (simp only: lessThan_Suc_atMost)
   done
 
 lemma (in t2_space) LIMSEQ_Uniq: "\<exists>\<^sub>\<le>\<^sub>1l. X \<longlonglongrightarrow> l"
  by (simp add: tendsto_unique')
 
 lemma (in t2_space) LIMSEQ_unique: "X \<longlonglongrightarrow> a \<Longrightarrow> X \<longlonglongrightarrow> b \<Longrightarrow> a = b"
   using trivial_limit_sequentially by (rule tendsto_unique)
 
 lemma LIMSEQ_le_const: "X \<longlonglongrightarrow> x \<Longrightarrow> \<exists>N. \<forall>n\<ge>N. a \<le> X n \<Longrightarrow> a \<le> x"
   for a x :: "'a::linorder_topology"
   by (simp add: eventually_at_top_linorder tendsto_lowerbound)
 
 lemma LIMSEQ_le: "X \<longlonglongrightarrow> x \<Longrightarrow> Y \<longlonglongrightarrow> y \<Longrightarrow> \<exists>N. \<forall>n\<ge>N. X n \<le> Y n \<Longrightarrow> x \<le> y"
   for x y :: "'a::linorder_topology"
   using tendsto_le[of sequentially Y y X x] by (simp add: eventually_sequentially)
 
 lemma LIMSEQ_le_const2: "X \<longlonglongrightarrow> x \<Longrightarrow> \<exists>N. \<forall>n\<ge>N. X n \<le> a \<Longrightarrow> x \<le> a"
   for a x :: "'a::linorder_topology"
   by (rule LIMSEQ_le[of X x "\<lambda>n. a"]) auto
 
 lemma Lim_bounded: "f \<longlonglongrightarrow> l \<Longrightarrow> \<forall>n\<ge>M. f n \<le> C \<Longrightarrow> l \<le> C"
   for l :: "'a::linorder_topology"
   by (intro LIMSEQ_le_const2) auto
 
 lemma Lim_bounded2:
   fixes f :: "nat \<Rightarrow> 'a::linorder_topology"
   assumes lim:"f \<longlonglongrightarrow> l" and ge: "\<forall>n\<ge>N. f n \<ge> C"
   shows "l \<ge> C"
   using ge
   by (intro tendsto_le[OF trivial_limit_sequentially lim tendsto_const])
      (auto simp: eventually_sequentially)
 
 lemma lim_mono:
   fixes X Y :: "nat \<Rightarrow> 'a::linorder_topology"
   assumes "\<And>n. N \<le> n \<Longrightarrow> X n \<le> Y n"
     and "X \<longlonglongrightarrow> x"
     and "Y \<longlonglongrightarrow> y"
   shows "x \<le> y"
   using assms(1) by (intro LIMSEQ_le[OF assms(2,3)]) auto
 
 lemma Sup_lim:
   fixes a :: "'a::{complete_linorder,linorder_topology}"
   assumes "\<And>n. b n \<in> s"
     and "b \<longlonglongrightarrow> a"
   shows "a \<le> Sup s"
   by (metis Lim_bounded assms complete_lattice_class.Sup_upper)
 
 lemma Inf_lim:
   fixes a :: "'a::{complete_linorder,linorder_topology}"
   assumes "\<And>n. b n \<in> s"
     and "b \<longlonglongrightarrow> a"
   shows "Inf s \<le> a"
   by (metis Lim_bounded2 assms complete_lattice_class.Inf_lower)
 
 lemma SUP_Lim:
   fixes X :: "nat \<Rightarrow> 'a::{complete_linorder,linorder_topology}"
   assumes inc: "incseq X"
     and l: "X \<longlonglongrightarrow> l"
   shows "(SUP n. X n) = l"
   using LIMSEQ_SUP[OF inc] tendsto_unique[OF trivial_limit_sequentially l]
   by simp
 
 lemma INF_Lim:
   fixes X :: "nat \<Rightarrow> 'a::{complete_linorder,linorder_topology}"
   assumes dec: "decseq X"
     and l: "X \<longlonglongrightarrow> l"
   shows "(INF n. X n) = l"
   using LIMSEQ_INF[OF dec] tendsto_unique[OF trivial_limit_sequentially l]
   by simp
 
 lemma convergentD: "convergent X \<Longrightarrow> \<exists>L. X \<longlonglongrightarrow> L"
   by (simp add: convergent_def)
 
 lemma convergentI: "X \<longlonglongrightarrow> L \<Longrightarrow> convergent X"
   by (auto simp add: convergent_def)
 
 lemma convergent_LIMSEQ_iff: "convergent X \<longleftrightarrow> X \<longlonglongrightarrow> lim X"
   by (auto intro: theI LIMSEQ_unique simp add: convergent_def lim_def)
 
 lemma convergent_const: "convergent (\<lambda>n. c)"
   by (rule convergentI) (rule tendsto_const)
 
 lemma monoseq_le:
   "monoseq a \<Longrightarrow> a \<longlonglongrightarrow> x \<Longrightarrow>
     (\<forall>n. a n \<le> x) \<and> (\<forall>m. \<forall>n\<ge>m. a m \<le> a n) \<or>
     (\<forall>n. x \<le> a n) \<and> (\<forall>m. \<forall>n\<ge>m. a n \<le> a m)"
   for x :: "'a::linorder_topology"
   by (metis LIMSEQ_le_const LIMSEQ_le_const2 decseq_def incseq_def monoseq_iff)
 
 lemma LIMSEQ_subseq_LIMSEQ: "X \<longlonglongrightarrow> L \<Longrightarrow> strict_mono f \<Longrightarrow> (X \<circ> f) \<longlonglongrightarrow> L"
   unfolding comp_def by (rule filterlim_compose [of X, OF _ filterlim_subseq])
 
 lemma convergent_subseq_convergent: "convergent X \<Longrightarrow> strict_mono f \<Longrightarrow> convergent (X \<circ> f)"
   by (auto simp: convergent_def intro: LIMSEQ_subseq_LIMSEQ)
 
 lemma limI: "X \<longlonglongrightarrow> L \<Longrightarrow> lim X = L"
   by (rule tendsto_Lim) (rule trivial_limit_sequentially)
 
 lemma lim_le: "convergent f \<Longrightarrow> (\<And>n. f n \<le> x) \<Longrightarrow> lim f \<le> x"
   for x :: "'a::linorder_topology"
   using LIMSEQ_le_const2[of f "lim f" x] by (simp add: convergent_LIMSEQ_iff)
 
 lemma lim_const [simp]: "lim (\<lambda>m. a) = a"
   by (simp add: limI)
 
 
 subsubsection \<open>Increasing and Decreasing Series\<close>
 
 lemma incseq_le: "incseq X \<Longrightarrow> X \<longlonglongrightarrow> L \<Longrightarrow> X n \<le> L"
   for L :: "'a::linorder_topology"
   by (metis incseq_def LIMSEQ_le_const)
 
 lemma decseq_ge: "decseq X \<Longrightarrow> X \<longlonglongrightarrow> L \<Longrightarrow> L \<le> X n"
   for L :: "'a::linorder_topology"
   by (metis decseq_def LIMSEQ_le_const2)
 
 
 subsection \<open>First countable topologies\<close>
 
 class first_countable_topology = topological_space +
   assumes first_countable_basis:
     "\<exists>A::nat \<Rightarrow> 'a set. (\<forall>i. x \<in> A i \<and> open (A i)) \<and> (\<forall>S. open S \<and> x \<in> S \<longrightarrow> (\<exists>i. A i \<subseteq> S))"
 
 lemma (in first_countable_topology) countable_basis_at_decseq:
   obtains A :: "nat \<Rightarrow> 'a set" where
     "\<And>i. open (A i)" "\<And>i. x \<in> (A i)"
     "\<And>S. open S \<Longrightarrow> x \<in> S \<Longrightarrow> eventually (\<lambda>i. A i \<subseteq> S) sequentially"
 proof atomize_elim
   from first_countable_basis[of x] obtain A :: "nat \<Rightarrow> 'a set"
     where nhds: "\<And>i. open (A i)" "\<And>i. x \<in> A i"
       and incl: "\<And>S. open S \<Longrightarrow> x \<in> S \<Longrightarrow> \<exists>i. A i \<subseteq> S"
     by auto
   define F where "F n = (\<Inter>i\<le>n. A i)" for n
   show "\<exists>A. (\<forall>i. open (A i)) \<and> (\<forall>i. x \<in> A i) \<and>
     (\<forall>S. open S \<longrightarrow> x \<in> S \<longrightarrow> eventually (\<lambda>i. A i \<subseteq> S) sequentially)"
   proof (safe intro!: exI[of _ F])
     fix i
     show "open (F i)"
       using nhds(1) by (auto simp: F_def)
     show "x \<in> F i"
       using nhds(2) by (auto simp: F_def)
   next
     fix S
     assume "open S" "x \<in> S"
     from incl[OF this] obtain i where "F i \<subseteq> S"
       unfolding F_def by auto
     moreover have "\<And>j. i \<le> j \<Longrightarrow> F j \<subseteq> F i"
       by (simp add: Inf_superset_mono F_def image_mono)
     ultimately show "eventually (\<lambda>i. F i \<subseteq> S) sequentially"
       by (auto simp: eventually_sequentially)
   qed
 qed
 
 lemma (in first_countable_topology) nhds_countable:
   obtains X :: "nat \<Rightarrow> 'a set"
   where "decseq X" "\<And>n. open (X n)" "\<And>n. x \<in> X n" "nhds x = (INF n. principal (X n))"
 proof -
   from first_countable_basis obtain A :: "nat \<Rightarrow> 'a set"
     where *: "\<And>n. x \<in> A n" "\<And>n. open (A n)" "\<And>S. open S \<Longrightarrow> x \<in> S \<Longrightarrow> \<exists>i. A i \<subseteq> S"
     by metis
   show thesis
   proof
     show "decseq (\<lambda>n. \<Inter>i\<le>n. A i)"
       by (simp add: antimono_iff_le_Suc atMost_Suc)
     show "x \<in> (\<Inter>i\<le>n. A i)" "\<And>n. open (\<Inter>i\<le>n. A i)" for n
       using * by auto
     show "nhds x = (INF n. principal (\<Inter>i\<le>n. A i))"
       using *
       unfolding nhds_def
       apply -
       apply (rule INF_eq)
        apply simp_all
        apply fastforce
       apply (intro exI [of _ "\<Inter>i\<le>n. A i" for n] conjI open_INT)
          apply auto
       done
   qed
 qed
 
 lemma (in first_countable_topology) countable_basis:
   obtains A :: "nat \<Rightarrow> 'a set" where
     "\<And>i. open (A i)" "\<And>i. x \<in> A i"
     "\<And>F. (\<forall>n. F n \<in> A n) \<Longrightarrow> F \<longlonglongrightarrow> x"
 proof atomize_elim
   obtain A :: "nat \<Rightarrow> 'a set" where *:
     "\<And>i. open (A i)"
     "\<And>i. x \<in> A i"
     "\<And>S. open S \<Longrightarrow> x \<in> S \<Longrightarrow> eventually (\<lambda>i. A i \<subseteq> S) sequentially"
     by (rule countable_basis_at_decseq) blast
   have "eventually (\<lambda>n. F n \<in> S) sequentially"
     if "\<forall>n. F n \<in> A n" "open S" "x \<in> S" for F S
     using *(3)[of S] that by (auto elim: eventually_mono simp: subset_eq)
   with * show "\<exists>A. (\<forall>i. open (A i)) \<and> (\<forall>i. x \<in> A i) \<and> (\<forall>F. (\<forall>n. F n \<in> A n) \<longrightarrow> F \<longlonglongrightarrow> x)"
     by (intro exI[of _ A]) (auto simp: tendsto_def)
 qed
 
 lemma (in first_countable_topology) sequentially_imp_eventually_nhds_within:
   assumes "\<forall>f. (\<forall>n. f n \<in> s) \<and> f \<longlonglongrightarrow> a \<longrightarrow> eventually (\<lambda>n. P (f n)) sequentially"
   shows "eventually P (inf (nhds a) (principal s))"
 proof (rule ccontr)
   obtain A :: "nat \<Rightarrow> 'a set" where *:
     "\<And>i. open (A i)"
     "\<And>i. a \<in> A i"
     "\<And>F. \<forall>n. F n \<in> A n \<Longrightarrow> F \<longlonglongrightarrow> a"
     by (rule countable_basis) blast
   assume "\<not> ?thesis"
   with * have "\<exists>F. \<forall>n. F n \<in> s \<and> F n \<in> A n \<and> \<not> P (F n)"
     unfolding eventually_inf_principal eventually_nhds
     by (intro choice) fastforce
   then obtain F where F: "\<forall>n. F n \<in> s" and "\<forall>n. F n \<in> A n" and F': "\<forall>n. \<not> P (F n)"
     by blast
   with * have "F \<longlonglongrightarrow> a"
     by auto
   then have "eventually (\<lambda>n. P (F n)) sequentially"
     using assms F by simp
   then show False
     by (simp add: F')
 qed
 
 lemma (in first_countable_topology) eventually_nhds_within_iff_sequentially:
   "eventually P (inf (nhds a) (principal s)) \<longleftrightarrow>
     (\<forall>f. (\<forall>n. f n \<in> s) \<and> f \<longlonglongrightarrow> a \<longrightarrow> eventually (\<lambda>n. P (f n)) sequentially)"
 proof (safe intro!: sequentially_imp_eventually_nhds_within)
   assume "eventually P (inf (nhds a) (principal s))"
   then obtain S where "open S" "a \<in> S" "\<forall>x\<in>S. x \<in> s \<longrightarrow> P x"
     by (auto simp: eventually_inf_principal eventually_nhds)
   moreover
   fix f
   assume "\<forall>n. f n \<in> s" "f \<longlonglongrightarrow> a"
   ultimately show "eventually (\<lambda>n. P (f n)) sequentially"
     by (auto dest!: topological_tendstoD elim: eventually_mono)
 qed
 
 lemma (in first_countable_topology) eventually_nhds_iff_sequentially:
   "eventually P (nhds a) \<longleftrightarrow> (\<forall>f. f \<longlonglongrightarrow> a \<longrightarrow> eventually (\<lambda>n. P (f n)) sequentially)"
   using eventually_nhds_within_iff_sequentially[of P a UNIV] by simp
 
 (*Thanks to Sébastien Gouëzel*)
 lemma Inf_as_limit:
   fixes A::"'a::{linorder_topology, first_countable_topology, complete_linorder} set"
   assumes "A \<noteq> {}"
   shows "\<exists>u. (\<forall>n. u n \<in> A) \<and> u \<longlonglongrightarrow> Inf A"
 proof (cases "Inf A \<in> A")
   case True
   show ?thesis
     by (rule exI[of _ "\<lambda>n. Inf A"], auto simp add: True)
 next
   case False
   obtain y where "y \<in> A" using assms by auto
   then have "Inf A < y" using False Inf_lower less_le by auto
   obtain F :: "nat \<Rightarrow> 'a set" where F: "\<And>i. open (F i)" "\<And>i. Inf A \<in> F i"
                                        "\<And>u. (\<forall>n. u n \<in> F n) \<Longrightarrow> u \<longlonglongrightarrow> Inf A"
     by (metis first_countable_topology_class.countable_basis)
   define u where "u = (\<lambda>n. SOME z. z \<in> F n \<and> z \<in> A)"
   have "\<exists>z. z \<in> U \<and> z \<in> A" if "Inf A \<in> U" "open U" for U
   proof -
     obtain b where "b > Inf A" "{Inf A ..<b} \<subseteq> U"
       using open_right[OF \<open>open U\<close> \<open>Inf A \<in> U\<close> \<open>Inf A < y\<close>] by auto
     obtain z where "z < b" "z \<in> A"
       using \<open>Inf A < b\<close> Inf_less_iff by auto
     then have "z \<in> {Inf A ..<b}"
       by (simp add: Inf_lower)
     then show ?thesis using \<open>z \<in> A\<close> \<open>{Inf A ..<b} \<subseteq> U\<close> by auto
   qed
   then have *: "u n \<in> F n \<and> u n \<in> A" for n
     using \<open>Inf A \<in> F n\<close> \<open>open (F n)\<close> unfolding u_def by (metis (no_types, lifting) someI_ex)
   then have "u \<longlonglongrightarrow> Inf A" using F(3) by simp
   then show ?thesis using * by auto
 qed
 
 lemma tendsto_at_iff_sequentially:
   "(f \<longlongrightarrow> a) (at x within s) \<longleftrightarrow> (\<forall>X. (\<forall>i. X i \<in> s - {x}) \<longrightarrow> X \<longlonglongrightarrow> x \<longrightarrow> ((f \<circ> X) \<longlonglongrightarrow> a))"
   for f :: "'a::first_countable_topology \<Rightarrow> _"
   unfolding filterlim_def[of _ "nhds a"] le_filter_def eventually_filtermap
     at_within_def eventually_nhds_within_iff_sequentially comp_def
   by metis
 
 lemma approx_from_above_dense_linorder:
   fixes x::"'a::{dense_linorder, linorder_topology, first_countable_topology}"
   assumes "x < y"
   shows "\<exists>u. (\<forall>n. u n > x) \<and> (u \<longlonglongrightarrow> x)"
 proof -
   obtain A :: "nat \<Rightarrow> 'a set" where A: "\<And>i. open (A i)" "\<And>i. x \<in> A i"
                                       "\<And>F. (\<forall>n. F n \<in> A n) \<Longrightarrow> F \<longlonglongrightarrow> x"
     by (metis first_countable_topology_class.countable_basis)
   define u where "u = (\<lambda>n. SOME z. z \<in> A n \<and> z > x)"
   have "\<exists>z. z \<in> U \<and> x < z" if "x \<in> U" "open U" for U
     using open_right[OF \<open>open U\<close> \<open>x \<in> U\<close> \<open>x < y\<close>]
     by (meson atLeastLessThan_iff dense less_imp_le subset_eq)
   then have *: "u n \<in> A n \<and> x < u n" for n
     using \<open>x \<in> A n\<close> \<open>open (A n)\<close> unfolding u_def by (metis (no_types, lifting) someI_ex)
   then have "u \<longlonglongrightarrow> x" using A(3) by simp
   then show ?thesis using * by auto
 qed
 
 lemma approx_from_below_dense_linorder:
   fixes x::"'a::{dense_linorder, linorder_topology, first_countable_topology}"
   assumes "x > y"
   shows "\<exists>u. (\<forall>n. u n < x) \<and> (u \<longlonglongrightarrow> x)"
 proof -
   obtain A :: "nat \<Rightarrow> 'a set" where A: "\<And>i. open (A i)" "\<And>i. x \<in> A i"
                                       "\<And>F. (\<forall>n. F n \<in> A n) \<Longrightarrow> F \<longlonglongrightarrow> x"
     by (metis first_countable_topology_class.countable_basis)
   define u where "u = (\<lambda>n. SOME z. z \<in> A n \<and> z < x)"
   have "\<exists>z. z \<in> U \<and> z < x" if "x \<in> U" "open U" for U
     using open_left[OF \<open>open U\<close> \<open>x \<in> U\<close> \<open>x > y\<close>]
     by (meson dense greaterThanAtMost_iff less_imp_le subset_eq)
   then have *: "u n \<in> A n \<and> u n < x" for n
     using \<open>x \<in> A n\<close> \<open>open (A n)\<close> unfolding u_def by (metis (no_types, lifting) someI_ex)
   then have "u \<longlonglongrightarrow> x" using A(3) by simp
   then show ?thesis using * by auto
 qed
 
 
 subsection \<open>Function limit at a point\<close>
 
 abbreviation LIM :: "('a::topological_space \<Rightarrow> 'b::topological_space) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
     ("((_)/ \<midarrow>(_)/\<rightarrow> (_))" [60, 0, 60] 60)
   where "f \<midarrow>a\<rightarrow> L \<equiv> (f \<longlongrightarrow> L) (at a)"
 
 lemma tendsto_within_open: "a \<in> S \<Longrightarrow> open S \<Longrightarrow> (f \<longlongrightarrow> l) (at a within S) \<longleftrightarrow> (f \<midarrow>a\<rightarrow> l)"
   by (simp add: tendsto_def at_within_open[where S = S])
 
 lemma tendsto_within_open_NO_MATCH:
   "a \<in> S \<Longrightarrow> NO_MATCH UNIV S \<Longrightarrow> open S \<Longrightarrow> (f \<longlongrightarrow> l)(at a within S) \<longleftrightarrow> (f \<longlongrightarrow> l)(at a)"
   for f :: "'a::topological_space \<Rightarrow> 'b::topological_space"
   using tendsto_within_open by blast
 
 lemma LIM_const_not_eq[tendsto_intros]: "k \<noteq> L \<Longrightarrow> \<not> (\<lambda>x. k) \<midarrow>a\<rightarrow> L"
   for a :: "'a::perfect_space" and k L :: "'b::t2_space"
   by (simp add: tendsto_const_iff)
 
 lemmas LIM_not_zero = LIM_const_not_eq [where L = 0]
 
 lemma LIM_const_eq: "(\<lambda>x. k) \<midarrow>a\<rightarrow> L \<Longrightarrow> k = L"
   for a :: "'a::perfect_space" and k L :: "'b::t2_space"
   by (simp add: tendsto_const_iff)
 
 lemma LIM_unique: "f \<midarrow>a\<rightarrow> L \<Longrightarrow> f \<midarrow>a\<rightarrow> M \<Longrightarrow> L = M"
   for a :: "'a::perfect_space" and L M :: "'b::t2_space"
   using at_neq_bot by (rule tendsto_unique)
 
 lemma LIM_Uniq: "\<exists>\<^sub>\<le>\<^sub>1L::'b::t2_space. f \<midarrow>a\<rightarrow> L"
   for a :: "'a::perfect_space"
  by (auto simp add: Uniq_def LIM_unique)
 
 
 text \<open>Limits are equal for functions equal except at limit point.\<close>
 lemma LIM_equal: "\<forall>x. x \<noteq> a \<longrightarrow> f x = g x \<Longrightarrow> (f \<midarrow>a\<rightarrow> l) \<longleftrightarrow> (g \<midarrow>a\<rightarrow> l)"
   by (simp add: tendsto_def eventually_at_topological)
 
 lemma LIM_cong: "a = b \<Longrightarrow> (\<And>x. x \<noteq> b \<Longrightarrow> f x = g x) \<Longrightarrow> l = m \<Longrightarrow> (f \<midarrow>a\<rightarrow> l) \<longleftrightarrow> (g \<midarrow>b\<rightarrow> m)"
   by (simp add: LIM_equal)
 
 lemma tendsto_cong_limit: "(f \<longlongrightarrow> l) F \<Longrightarrow> k = l \<Longrightarrow> (f \<longlongrightarrow> k) F"
   by simp
 
 lemma tendsto_at_iff_tendsto_nhds: "g \<midarrow>l\<rightarrow> g l \<longleftrightarrow> (g \<longlongrightarrow> g l) (nhds l)"
   unfolding tendsto_def eventually_at_filter
   by (intro ext all_cong imp_cong) (auto elim!: eventually_mono)
 
 lemma tendsto_compose: "g \<midarrow>l\<rightarrow> g l \<Longrightarrow> (f \<longlongrightarrow> l) F \<Longrightarrow> ((\<lambda>x. g (f x)) \<longlongrightarrow> g l) F"
   unfolding tendsto_at_iff_tendsto_nhds by (rule filterlim_compose[of g])
 
 lemma tendsto_compose_eventually:
   "g \<midarrow>l\<rightarrow> m \<Longrightarrow> (f \<longlongrightarrow> l) F \<Longrightarrow> eventually (\<lambda>x. f x \<noteq> l) F \<Longrightarrow> ((\<lambda>x. g (f x)) \<longlongrightarrow> m) F"
   by (rule filterlim_compose[of g _ "at l"]) (auto simp add: filterlim_at)
 
 lemma LIM_compose_eventually:
   assumes "f \<midarrow>a\<rightarrow> b"
     and "g \<midarrow>b\<rightarrow> c"
     and "eventually (\<lambda>x. f x \<noteq> b) (at a)"
   shows "(\<lambda>x. g (f x)) \<midarrow>a\<rightarrow> c"
   using assms(2,1,3) by (rule tendsto_compose_eventually)
 
 lemma tendsto_compose_filtermap: "((g \<circ> f) \<longlongrightarrow> T) F \<longleftrightarrow> (g \<longlongrightarrow> T) (filtermap f F)"
   by (simp add: filterlim_def filtermap_filtermap comp_def)
 
 lemma tendsto_compose_at:
   assumes f: "(f \<longlongrightarrow> y) F" and g: "(g \<longlongrightarrow> z) (at y)" and fg: "eventually (\<lambda>w. f w = y \<longrightarrow> g y = z) F"
   shows "((g \<circ> f) \<longlongrightarrow> z) F"
 proof -
   have "(\<forall>\<^sub>F a in F. f a \<noteq> y) \<or> g y = z"
     using fg by force
   moreover have "(g \<longlongrightarrow> z) (filtermap f F) \<or> \<not> (\<forall>\<^sub>F a in F. f a \<noteq> y)"
     by (metis (no_types) filterlim_atI filterlim_def tendsto_mono f g)
   ultimately show ?thesis
     by (metis (no_types) f filterlim_compose filterlim_filtermap g tendsto_at_iff_tendsto_nhds tendsto_compose_filtermap)
 qed
 
 
 subsubsection \<open>Relation of \<open>LIM\<close> and \<open>LIMSEQ\<close>\<close>
 
 lemma (in first_countable_topology) sequentially_imp_eventually_within:
   "(\<forall>f. (\<forall>n. f n \<in> s \<and> f n \<noteq> a) \<and> f \<longlonglongrightarrow> a \<longrightarrow> eventually (\<lambda>n. P (f n)) sequentially) \<Longrightarrow>
     eventually P (at a within s)"
   unfolding at_within_def
   by (intro sequentially_imp_eventually_nhds_within) auto
 
 lemma (in first_countable_topology) sequentially_imp_eventually_at:
   "(\<forall>f. (\<forall>n. f n \<noteq> a) \<and> f \<longlonglongrightarrow> a \<longrightarrow> eventually (\<lambda>n. P (f n)) sequentially) \<Longrightarrow> eventually P (at a)"
   using sequentially_imp_eventually_within [where s=UNIV] by simp
 
 lemma LIMSEQ_SEQ_conv1:
   fixes f :: "'a::topological_space \<Rightarrow> 'b::topological_space"
   assumes f: "f \<midarrow>a\<rightarrow> l"
   shows "\<forall>S. (\<forall>n. S n \<noteq> a) \<and> S \<longlonglongrightarrow> a \<longrightarrow> (\<lambda>n. f (S n)) \<longlonglongrightarrow> l"
   using tendsto_compose_eventually [OF f, where F=sequentially] by simp
 
 lemma LIMSEQ_SEQ_conv2:
   fixes f :: "'a::first_countable_topology \<Rightarrow> 'b::topological_space"
   assumes "\<forall>S. (\<forall>n. S n \<noteq> a) \<and> S \<longlonglongrightarrow> a \<longrightarrow> (\<lambda>n. f (S n)) \<longlonglongrightarrow> l"
   shows "f \<midarrow>a\<rightarrow> l"
   using assms unfolding tendsto_def [where l=l] by (simp add: sequentially_imp_eventually_at)
 
 lemma LIMSEQ_SEQ_conv: "(\<forall>S. (\<forall>n. S n \<noteq> a) \<and> S \<longlonglongrightarrow> a \<longrightarrow> (\<lambda>n. X (S n)) \<longlonglongrightarrow> L) \<longleftrightarrow> X \<midarrow>a\<rightarrow> L"
   for a :: "'a::first_countable_topology" and L :: "'b::topological_space"
   using LIMSEQ_SEQ_conv2 LIMSEQ_SEQ_conv1 ..
 
 lemma sequentially_imp_eventually_at_left:
   fixes a :: "'a::{linorder_topology,first_countable_topology}"
   assumes b[simp]: "b < a"
     and *: "\<And>f. (\<And>n. b < f n) \<Longrightarrow> (\<And>n. f n < a) \<Longrightarrow> incseq f \<Longrightarrow> f \<longlonglongrightarrow> a \<Longrightarrow>
       eventually (\<lambda>n. P (f n)) sequentially"
   shows "eventually P (at_left a)"
 proof (safe intro!: sequentially_imp_eventually_within)
   fix X
   assume X: "\<forall>n. X n \<in> {..< a} \<and> X n \<noteq> a" "X \<longlonglongrightarrow> a"
   show "eventually (\<lambda>n. P (X n)) sequentially"
   proof (rule ccontr)
     assume neg: "\<not> ?thesis"
     have "\<exists>s. \<forall>n. (\<not> P (X (s n)) \<and> b < X (s n)) \<and> (X (s n) \<le> X (s (Suc n)) \<and> Suc (s n) \<le> s (Suc n))"
       (is "\<exists>s. ?P s")
     proof (rule dependent_nat_choice)
       have "\<not> eventually (\<lambda>n. b < X n \<longrightarrow> P (X n)) sequentially"
         by (intro not_eventually_impI neg order_tendstoD(1) [OF X(2) b])
       then show "\<exists>x. \<not> P (X x) \<and> b < X x"
         by (auto dest!: not_eventuallyD)
     next
       fix x n
       have "\<not> eventually (\<lambda>n. Suc x \<le> n \<longrightarrow> b < X n \<longrightarrow> X x < X n \<longrightarrow> P (X n)) sequentially"
         using X
         by (intro not_eventually_impI order_tendstoD(1)[OF X(2)] eventually_ge_at_top neg) auto
       then show "\<exists>n. (\<not> P (X n) \<and> b < X n) \<and> (X x \<le> X n \<and> Suc x \<le> n)"
         by (auto dest!: not_eventuallyD)
     qed
     then obtain s where "?P s" ..
     with X have "b < X (s n)"
       and "X (s n) < a"
       and "incseq (\<lambda>n. X (s n))"
       and "(\<lambda>n. X (s n)) \<longlonglongrightarrow> a"
       and "\<not> P (X (s n))"
       for n
       by (auto simp: strict_mono_Suc_iff Suc_le_eq incseq_Suc_iff
           intro!: LIMSEQ_subseq_LIMSEQ[OF \<open>X \<longlonglongrightarrow> a\<close>, unfolded comp_def])
     from *[OF this(1,2,3,4)] this(5) show False
       by auto
   qed
 qed
 
 lemma tendsto_at_left_sequentially:
   fixes a b :: "'b::{linorder_topology,first_countable_topology}"
   assumes "b < a"
   assumes *: "\<And>S. (\<And>n. S n < a) \<Longrightarrow> (\<And>n. b < S n) \<Longrightarrow> incseq S \<Longrightarrow> S \<longlonglongrightarrow> a \<Longrightarrow>
     (\<lambda>n. X (S n)) \<longlonglongrightarrow> L"
   shows "(X \<longlongrightarrow> L) (at_left a)"
   using assms by (simp add: tendsto_def [where l=L] sequentially_imp_eventually_at_left)
 
 lemma sequentially_imp_eventually_at_right:
   fixes a b :: "'a::{linorder_topology,first_countable_topology}"
   assumes b[simp]: "a < b"
   assumes *: "\<And>f. (\<And>n. a < f n) \<Longrightarrow> (\<And>n. f n < b) \<Longrightarrow> decseq f \<Longrightarrow> f \<longlonglongrightarrow> a \<Longrightarrow>
     eventually (\<lambda>n. P (f n)) sequentially"
   shows "eventually P (at_right a)"
 proof (safe intro!: sequentially_imp_eventually_within)
   fix X
   assume X: "\<forall>n. X n \<in> {a <..} \<and> X n \<noteq> a" "X \<longlonglongrightarrow> a"
   show "eventually (\<lambda>n. P (X n)) sequentially"
   proof (rule ccontr)
     assume neg: "\<not> ?thesis"
     have "\<exists>s. \<forall>n. (\<not> P (X (s n)) \<and> X (s n) < b) \<and> (X (s (Suc n)) \<le> X (s n) \<and> Suc (s n) \<le> s (Suc n))"
       (is "\<exists>s. ?P s")
     proof (rule dependent_nat_choice)
       have "\<not> eventually (\<lambda>n. X n < b \<longrightarrow> P (X n)) sequentially"
         by (intro not_eventually_impI neg order_tendstoD(2) [OF X(2) b])
       then show "\<exists>x. \<not> P (X x) \<and> X x < b"
         by (auto dest!: not_eventuallyD)
     next
       fix x n
       have "\<not> eventually (\<lambda>n. Suc x \<le> n \<longrightarrow> X n < b \<longrightarrow> X n < X x \<longrightarrow> P (X n)) sequentially"
         using X
         by (intro not_eventually_impI order_tendstoD(2)[OF X(2)] eventually_ge_at_top neg) auto
       then show "\<exists>n. (\<not> P (X n) \<and> X n < b) \<and> (X n \<le> X x \<and> Suc x \<le> n)"
         by (auto dest!: not_eventuallyD)
     qed
     then obtain s where "?P s" ..
     with X have "a < X (s n)"
       and "X (s n) < b"
       and "decseq (\<lambda>n. X (s n))"
       and "(\<lambda>n. X (s n)) \<longlonglongrightarrow> a"
       and "\<not> P (X (s n))"
       for n
       by (auto simp: strict_mono_Suc_iff Suc_le_eq decseq_Suc_iff
           intro!: LIMSEQ_subseq_LIMSEQ[OF \<open>X \<longlonglongrightarrow> a\<close>, unfolded comp_def])
     from *[OF this(1,2,3,4)] this(5) show False
       by auto
   qed
 qed
 
 lemma tendsto_at_right_sequentially:
   fixes a :: "_ :: {linorder_topology, first_countable_topology}"
   assumes "a < b"
     and *: "\<And>S. (\<And>n. a < S n) \<Longrightarrow> (\<And>n. S n < b) \<Longrightarrow> decseq S \<Longrightarrow> S \<longlonglongrightarrow> a \<Longrightarrow>
       (\<lambda>n. X (S n)) \<longlonglongrightarrow> L"
   shows "(X \<longlongrightarrow> L) (at_right a)"
   using assms by (simp add: tendsto_def [where l=L] sequentially_imp_eventually_at_right)
 
 
 subsection \<open>Continuity\<close>
 
 subsubsection \<open>Continuity on a set\<close>
 
 definition continuous_on :: "'a set \<Rightarrow> ('a::topological_space \<Rightarrow> 'b::topological_space) \<Rightarrow> bool"
   where "continuous_on s f \<longleftrightarrow> (\<forall>x\<in>s. (f \<longlongrightarrow> f x) (at x within s))"
 
 lemma continuous_on_cong [cong]:
   "s = t \<Longrightarrow> (\<And>x. x \<in> t \<Longrightarrow> f x = g x) \<Longrightarrow> continuous_on s f \<longleftrightarrow> continuous_on t g"
   unfolding continuous_on_def
   by (intro ball_cong filterlim_cong) (auto simp: eventually_at_filter)
 
 lemma continuous_on_cong_simp:
   "s = t \<Longrightarrow> (\<And>x. x \<in> t =simp=> f x = g x) \<Longrightarrow> continuous_on s f \<longleftrightarrow> continuous_on t g"
   unfolding simp_implies_def by (rule continuous_on_cong)
 
 lemma continuous_on_topological:
   "continuous_on s f \<longleftrightarrow>
     (\<forall>x\<in>s. \<forall>B. open B \<longrightarrow> f x \<in> B \<longrightarrow> (\<exists>A. open A \<and> x \<in> A \<and> (\<forall>y\<in>s. y \<in> A \<longrightarrow> f y \<in> B)))"
   unfolding continuous_on_def tendsto_def eventually_at_topological by metis
 
 lemma continuous_on_open_invariant:
   "continuous_on s f \<longleftrightarrow> (\<forall>B. open B \<longrightarrow> (\<exists>A. open A \<and> A \<inter> s = f -` B \<inter> s))"
 proof safe
   fix B :: "'b set"
   assume "continuous_on s f" "open B"
   then have "\<forall>x\<in>f -` B \<inter> s. (\<exists>A. open A \<and> x \<in> A \<and> s \<inter> A \<subseteq> f -` B)"
     by (auto simp: continuous_on_topological subset_eq Ball_def imp_conjL)
   then obtain A where "\<forall>x\<in>f -` B \<inter> s. open (A x) \<and> x \<in> A x \<and> s \<inter> A x \<subseteq> f -` B"
     unfolding bchoice_iff ..
   then show "\<exists>A. open A \<and> A \<inter> s = f -` B \<inter> s"
     by (intro exI[of _ "\<Union>x\<in>f -` B \<inter> s. A x"]) auto
 next
   assume B: "\<forall>B. open B \<longrightarrow> (\<exists>A. open A \<and> A \<inter> s = f -` B \<inter> s)"
   show "continuous_on s f"
     unfolding continuous_on_topological
   proof safe
     fix x B
     assume "x \<in> s" "open B" "f x \<in> B"
     with B obtain A where A: "open A" "A \<inter> s = f -` B \<inter> s"
       by auto
     with \<open>x \<in> s\<close> \<open>f x \<in> B\<close> show "\<exists>A. open A \<and> x \<in> A \<and> (\<forall>y\<in>s. y \<in> A \<longrightarrow> f y \<in> B)"
       by (intro exI[of _ A]) auto
   qed
 qed
 
 lemma continuous_on_open_vimage:
   "open s \<Longrightarrow> continuous_on s f \<longleftrightarrow> (\<forall>B. open B \<longrightarrow> open (f -` B \<inter> s))"
   unfolding continuous_on_open_invariant
   by (metis open_Int Int_absorb Int_commute[of s] Int_assoc[of _ _ s])
 
 corollary continuous_imp_open_vimage:
   assumes "continuous_on s f" "open s" "open B" "f -` B \<subseteq> s"
   shows "open (f -` B)"
   by (metis assms continuous_on_open_vimage le_iff_inf)
 
 corollary open_vimage[continuous_intros]:
   assumes "open s"
     and "continuous_on UNIV f"
   shows "open (f -` s)"
   using assms by (simp add: continuous_on_open_vimage [OF open_UNIV])
 
 lemma continuous_on_closed_invariant:
   "continuous_on s f \<longleftrightarrow> (\<forall>B. closed B \<longrightarrow> (\<exists>A. closed A \<and> A \<inter> s = f -` B \<inter> s))"
 proof -
   have *: "(\<And>A. P A \<longleftrightarrow> Q (- A)) \<Longrightarrow> (\<forall>A. P A) \<longleftrightarrow> (\<forall>A. Q A)"
     for P Q :: "'b set \<Rightarrow> bool"
     by (metis double_compl)
   show ?thesis
     unfolding continuous_on_open_invariant
     by (intro *) (auto simp: open_closed[symmetric])
 qed
 
 lemma continuous_on_closed_vimage:
   "closed s \<Longrightarrow> continuous_on s f \<longleftrightarrow> (\<forall>B. closed B \<longrightarrow> closed (f -` B \<inter> s))"
   unfolding continuous_on_closed_invariant
   by (metis closed_Int Int_absorb Int_commute[of s] Int_assoc[of _ _ s])
 
 corollary closed_vimage_Int[continuous_intros]:
   assumes "closed s"
     and "continuous_on t f"
     and t: "closed t"
   shows "closed (f -` s \<inter> t)"
   using assms by (simp add: continuous_on_closed_vimage [OF t])
 
 corollary closed_vimage[continuous_intros]:
   assumes "closed s"
     and "continuous_on UNIV f"
   shows "closed (f -` s)"
   using closed_vimage_Int [OF assms] by simp
 
 lemma continuous_on_empty [simp]: "continuous_on {} f"
   by (simp add: continuous_on_def)
 
 lemma continuous_on_sing [simp]: "continuous_on {x} f"
   by (simp add: continuous_on_def at_within_def)
 
 lemma continuous_on_open_Union:
   "(\<And>s. s \<in> S \<Longrightarrow> open s) \<Longrightarrow> (\<And>s. s \<in> S \<Longrightarrow> continuous_on s f) \<Longrightarrow> continuous_on (\<Union>S) f"
   unfolding continuous_on_def
   by safe (metis open_Union at_within_open UnionI)
 
 lemma continuous_on_open_UN:
   "(\<And>s. s \<in> S \<Longrightarrow> open (A s)) \<Longrightarrow> (\<And>s. s \<in> S \<Longrightarrow> continuous_on (A s) f) \<Longrightarrow>
     continuous_on (\<Union>s\<in>S. A s) f"
   by (rule continuous_on_open_Union) auto
 
 lemma continuous_on_open_Un:
   "open s \<Longrightarrow> open t \<Longrightarrow> continuous_on s f \<Longrightarrow> continuous_on t f \<Longrightarrow> continuous_on (s \<union> t) f"
   using continuous_on_open_Union [of "{s,t}"] by auto
 
 lemma continuous_on_closed_Un:
   "closed s \<Longrightarrow> closed t \<Longrightarrow> continuous_on s f \<Longrightarrow> continuous_on t f \<Longrightarrow> continuous_on (s \<union> t) f"
   by (auto simp add: continuous_on_closed_vimage closed_Un Int_Un_distrib)
 
 lemma continuous_on_closed_Union:
   assumes "finite I"
     "\<And>i. i \<in> I \<Longrightarrow> closed (U i)"
     "\<And>i. i \<in> I \<Longrightarrow> continuous_on (U i) f"
   shows "continuous_on (\<Union> i \<in> I. U i) f"
   using assms
   by (induction I) (auto intro!: continuous_on_closed_Un)
 
 lemma continuous_on_If:
   assumes closed: "closed s" "closed t"
     and cont: "continuous_on s f" "continuous_on t g"
     and P: "\<And>x. x \<in> s \<Longrightarrow> \<not> P x \<Longrightarrow> f x = g x" "\<And>x. x \<in> t \<Longrightarrow> P x \<Longrightarrow> f x = g x"
   shows "continuous_on (s \<union> t) (\<lambda>x. if P x then f x else g x)"
     (is "continuous_on _ ?h")
 proof-
   from P have "\<forall>x\<in>s. f x = ?h x" "\<forall>x\<in>t. g x = ?h x"
     by auto
   with cont have "continuous_on s ?h" "continuous_on t ?h"
     by simp_all
   with closed show ?thesis
     by (rule continuous_on_closed_Un)
 qed
 
 lemma continuous_on_cases:
   "closed s \<Longrightarrow> closed t \<Longrightarrow> continuous_on s f \<Longrightarrow> continuous_on t g \<Longrightarrow>
     \<forall>x. (x\<in>s \<and> \<not> P x) \<or> (x \<in> t \<and> P x) \<longrightarrow> f x = g x \<Longrightarrow>
     continuous_on (s \<union> t) (\<lambda>x. if P x then f x else g x)"
   by (rule continuous_on_If) auto
 
 lemma continuous_on_id[continuous_intros,simp]: "continuous_on s (\<lambda>x. x)"
   unfolding continuous_on_def by fast
 
 lemma continuous_on_id'[continuous_intros,simp]: "continuous_on s id"
   unfolding continuous_on_def id_def by fast
 
 lemma continuous_on_const[continuous_intros,simp]: "continuous_on s (\<lambda>x. c)"
   unfolding continuous_on_def by auto
 
 lemma continuous_on_subset: "continuous_on s f \<Longrightarrow> t \<subseteq> s \<Longrightarrow> continuous_on t f"
   unfolding continuous_on_def
   by (metis subset_eq tendsto_within_subset)
 
 lemma continuous_on_compose[continuous_intros]:
   "continuous_on s f \<Longrightarrow> continuous_on (f ` s) g \<Longrightarrow> continuous_on s (g \<circ> f)"
   unfolding continuous_on_topological by simp metis
 
 lemma continuous_on_compose2:
   "continuous_on t g \<Longrightarrow> continuous_on s f \<Longrightarrow> f ` s \<subseteq> t \<Longrightarrow> continuous_on s (\<lambda>x. g (f x))"
   using continuous_on_compose[of s f g] continuous_on_subset by (force simp add: comp_def)
 
 lemma continuous_on_generate_topology:
   assumes *: "open = generate_topology X"
     and **: "\<And>B. B \<in> X \<Longrightarrow> \<exists>C. open C \<and> C \<inter> A = f -` B \<inter> A"
   shows "continuous_on A f"
   unfolding continuous_on_open_invariant
 proof safe
   fix B :: "'a set"
   assume "open B"
   then show "\<exists>C. open C \<and> C \<inter> A = f -` B \<inter> A"
     unfolding *
   proof induct
     case (UN K)
     then obtain C where "\<And>k. k \<in> K \<Longrightarrow> open (C k)" "\<And>k. k \<in> K \<Longrightarrow> C k \<inter> A = f -` k \<inter> A"
       by metis
     then show ?case
       by (intro exI[of _ "\<Union>k\<in>K. C k"]) blast
   qed (auto intro: **)
 qed
 
 lemma continuous_onI_mono:
   fixes f :: "'a::linorder_topology \<Rightarrow> 'b::{dense_order,linorder_topology}"
   assumes "open (f`A)"
     and mono: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
   shows "continuous_on A f"
 proof (rule continuous_on_generate_topology[OF open_generated_order], safe)
   have monoD: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x < f y \<Longrightarrow> x < y"
     by (auto simp: not_le[symmetric] mono)
   have "\<exists>x. x \<in> A \<and> f x < b \<and> a < x" if a: "a \<in> A" and fa: "f a < b" for a b
   proof -
     obtain y where "f a < y" "{f a ..< y} \<subseteq> f`A"
       using open_right[OF \<open>open (f`A)\<close>, of "f a" b] a fa
       by auto
     obtain z where z: "f a < z" "z < min b y"
       using dense[of "f a" "min b y"] \<open>f a < y\<close> \<open>f a < b\<close> by auto
     then obtain c where "z = f c" "c \<in> A"
       using \<open>{f a ..< y} \<subseteq> f`A\<close>[THEN subsetD, of z] by (auto simp: less_imp_le)
     with a z show ?thesis
       by (auto intro!: exI[of _ c] simp: monoD)
   qed
   then show "\<exists>C. open C \<and> C \<inter> A = f -` {..<b} \<inter> A" for b
     by (intro exI[of _ "(\<Union>x\<in>{x\<in>A. f x < b}. {..< x})"])
        (auto intro: le_less_trans[OF mono] less_imp_le)
 
   have "\<exists>x. x \<in> A \<and> b < f x \<and> x < a" if a: "a \<in> A" and fa: "b < f a" for a b
   proof -
     note a fa
     moreover
     obtain y where "y < f a" "{y <.. f a} \<subseteq> f`A"
       using open_left[OF \<open>open (f`A)\<close>, of "f a" b]  a fa
       by auto
     then obtain z where z: "max b y < z" "z < f a"
       using dense[of "max b y" "f a"] \<open>y < f a\<close> \<open>b < f a\<close> by auto
     then obtain c where "z = f c" "c \<in> A"
       using \<open>{y <.. f a} \<subseteq> f`A\<close>[THEN subsetD, of z] by (auto simp: less_imp_le)
     with a z show ?thesis
       by (auto intro!: exI[of _ c] simp: monoD)
   qed
   then show "\<exists>C. open C \<and> C \<inter> A = f -` {b <..} \<inter> A" for b
     by (intro exI[of _ "(\<Union>x\<in>{x\<in>A. b < f x}. {x <..})"])
        (auto intro: less_le_trans[OF _ mono] less_imp_le)
 qed
 
 lemma continuous_on_IccI:
   "\<lbrakk>(f \<longlongrightarrow> f a) (at_right a);
     (f \<longlongrightarrow> f b) (at_left b);
     (\<And>x. a < x \<Longrightarrow> x < b \<Longrightarrow> f \<midarrow>x\<rightarrow> f x); a < b\<rbrakk> \<Longrightarrow>
     continuous_on {a .. b} f"
   for a::"'a::linorder_topology"
   using at_within_open[of _ "{a<..<b}"]
   by (auto simp: continuous_on_def at_within_Icc_at_right at_within_Icc_at_left le_less
       at_within_Icc_at)
 
 lemma
   fixes a b::"'a::linorder_topology"
   assumes "continuous_on {a .. b} f" "a < b"
   shows continuous_on_Icc_at_rightD: "(f \<longlongrightarrow> f a) (at_right a)"
     and continuous_on_Icc_at_leftD: "(f \<longlongrightarrow> f b) (at_left b)"
   using assms
   by (auto simp: at_within_Icc_at_right at_within_Icc_at_left continuous_on_def
       dest: bspec[where x=a] bspec[where x=b])
 
 lemma continuous_on_discrete [simp]:
   "continuous_on A (f :: 'a :: discrete_topology \<Rightarrow> _)"
   by (auto simp: continuous_on_def at_discrete)
 
 subsubsection \<open>Continuity at a point\<close>
 
 definition continuous :: "'a::t2_space filter \<Rightarrow> ('a \<Rightarrow> 'b::topological_space) \<Rightarrow> bool"
   where "continuous F f \<longleftrightarrow> (f \<longlongrightarrow> f (Lim F (\<lambda>x. x))) F"
 
 lemma continuous_bot[continuous_intros, simp]: "continuous bot f"
   unfolding continuous_def by auto
 
 lemma continuous_trivial_limit: "trivial_limit net \<Longrightarrow> continuous net f"
   by simp
 
 lemma continuous_within: "continuous (at x within s) f \<longleftrightarrow> (f \<longlongrightarrow> f x) (at x within s)"
   by (cases "trivial_limit (at x within s)") (auto simp add: Lim_ident_at continuous_def)
 
 lemma continuous_within_topological:
   "continuous (at x within s) f \<longleftrightarrow>
     (\<forall>B. open B \<longrightarrow> f x \<in> B \<longrightarrow> (\<exists>A. open A \<and> x \<in> A \<and> (\<forall>y\<in>s. y \<in> A \<longrightarrow> f y \<in> B)))"
   unfolding continuous_within tendsto_def eventually_at_topological by metis
 
 lemma continuous_within_compose[continuous_intros]:
   "continuous (at x within s) f \<Longrightarrow> continuous (at (f x) within f ` s) g \<Longrightarrow>
     continuous (at x within s) (g \<circ> f)"
   by (simp add: continuous_within_topological) metis
 
 lemma continuous_within_compose2:
   "continuous (at x within s) f \<Longrightarrow> continuous (at (f x) within f ` s) g \<Longrightarrow>
     continuous (at x within s) (\<lambda>x. g (f x))"
   using continuous_within_compose[of x s f g] by (simp add: comp_def)
 
 lemma continuous_at: "continuous (at x) f \<longleftrightarrow> f \<midarrow>x\<rightarrow> f x"
   using continuous_within[of x UNIV f] by simp
 
 lemma continuous_ident[continuous_intros, simp]: "continuous (at x within S) (\<lambda>x. x)"
   unfolding continuous_within by (rule tendsto_ident_at)
 
 lemma continuous_id[continuous_intros, simp]: "continuous (at x within S) id"
   by (simp add: id_def)
 
 lemma continuous_const[continuous_intros, simp]: "continuous F (\<lambda>x. c)"
   unfolding continuous_def by (rule tendsto_const)
 
 lemma continuous_on_eq_continuous_within:
   "continuous_on s f \<longleftrightarrow> (\<forall>x\<in>s. continuous (at x within s) f)"
   unfolding continuous_on_def continuous_within ..
 
 lemma continuous_discrete [simp]:
   "continuous (at x within A) (f :: 'a :: discrete_topology \<Rightarrow> _)"
   by (auto simp: continuous_def at_discrete)
 
 abbreviation isCont :: "('a::t2_space \<Rightarrow> 'b::topological_space) \<Rightarrow> 'a \<Rightarrow> bool"
   where "isCont f a \<equiv> continuous (at a) f"
 
 lemma isCont_def: "isCont f a \<longleftrightarrow> f \<midarrow>a\<rightarrow> f a"
   by (rule continuous_at)
 
 lemma isContD: "isCont f x \<Longrightarrow> f \<midarrow>x\<rightarrow> f x"
   by (simp add: isCont_def)
 
 lemma isCont_cong:
   assumes "eventually (\<lambda>x. f x = g x) (nhds x)"
   shows "isCont f x \<longleftrightarrow> isCont g x"
 proof -
   from assms have [simp]: "f x = g x"
     by (rule eventually_nhds_x_imp_x)
   from assms have "eventually (\<lambda>x. f x = g x) (at x)"
     by (auto simp: eventually_at_filter elim!: eventually_mono)
   with assms have "isCont f x \<longleftrightarrow> isCont g x" unfolding isCont_def
     by (intro filterlim_cong) (auto elim!: eventually_mono)
   with assms show ?thesis by simp
 qed
 
 lemma continuous_at_imp_continuous_at_within: "isCont f x \<Longrightarrow> continuous (at x within s) f"
   by (auto intro: tendsto_mono at_le simp: continuous_at continuous_within)
 
 lemma continuous_on_eq_continuous_at: "open s \<Longrightarrow> continuous_on s f \<longleftrightarrow> (\<forall>x\<in>s. isCont f x)"
   by (simp add: continuous_on_def continuous_at at_within_open[of _ s])
 
 lemma continuous_within_open: "a \<in> A \<Longrightarrow> open A \<Longrightarrow> continuous (at a within A) f \<longleftrightarrow> isCont f a"
   by (simp add: at_within_open_NO_MATCH)
 
 lemma continuous_at_imp_continuous_on: "\<forall>x\<in>s. isCont f x \<Longrightarrow> continuous_on s f"
   by (auto intro: continuous_at_imp_continuous_at_within simp: continuous_on_eq_continuous_within)
 
 lemma isCont_o2: "isCont f a \<Longrightarrow> isCont g (f a) \<Longrightarrow> isCont (\<lambda>x. g (f x)) a"
   unfolding isCont_def by (rule tendsto_compose)
 
 lemma continuous_at_compose[continuous_intros]: "isCont f a \<Longrightarrow> isCont g (f a) \<Longrightarrow> isCont (g \<circ> f) a"
   unfolding o_def by (rule isCont_o2)
 
 lemma isCont_tendsto_compose: "isCont g l \<Longrightarrow> (f \<longlongrightarrow> l) F \<Longrightarrow> ((\<lambda>x. g (f x)) \<longlongrightarrow> g l) F"
   unfolding isCont_def by (rule tendsto_compose)
 
 lemma continuous_on_tendsto_compose:
   assumes f_cont: "continuous_on s f"
     and g: "(g \<longlongrightarrow> l) F"
     and l: "l \<in> s"
     and ev: "\<forall>\<^sub>Fx in F. g x \<in> s"
   shows "((\<lambda>x. f (g x)) \<longlongrightarrow> f l) F"
 proof -
   from f_cont l have f: "(f \<longlongrightarrow> f l) (at l within s)"
     by (simp add: continuous_on_def)
   have i: "((\<lambda>x. if g x = l then f l else f (g x)) \<longlongrightarrow> f l) F"
     by (rule filterlim_If)
        (auto intro!: filterlim_compose[OF f] eventually_conj tendsto_mono[OF _ g]
              simp: filterlim_at eventually_inf_principal eventually_mono[OF ev])
   show ?thesis
     by (rule filterlim_cong[THEN iffD1[OF _ i]]) auto
 qed
 
 lemma continuous_within_compose3:
   "isCont g (f x) \<Longrightarrow> continuous (at x within s) f \<Longrightarrow> continuous (at x within s) (\<lambda>x. g (f x))"
   using continuous_at_imp_continuous_at_within continuous_within_compose2 by blast
 
 lemma filtermap_nhds_open_map:
   assumes cont: "isCont f a"
     and open_map: "\<And>S. open S \<Longrightarrow> open (f`S)"
   shows "filtermap f (nhds a) = nhds (f a)"
   unfolding filter_eq_iff
 proof safe
   fix P
   assume "eventually P (filtermap f (nhds a))"
   then obtain S where "open S" "a \<in> S" "\<forall>x\<in>S. P (f x)"
     by (auto simp: eventually_filtermap eventually_nhds)
   then show "eventually P (nhds (f a))"
     unfolding eventually_nhds by (intro exI[of _ "f`S"]) (auto intro!: open_map)
 qed (metis filterlim_iff tendsto_at_iff_tendsto_nhds isCont_def eventually_filtermap cont)
 
 lemma continuous_at_split:
   "continuous (at x) f \<longleftrightarrow> continuous (at_left x) f \<and> continuous (at_right x) f"
   for x :: "'a::linorder_topology"
   by (simp add: continuous_within filterlim_at_split)
 
 lemma continuous_on_max [continuous_intros]:
   fixes f g :: "'a::topological_space \<Rightarrow> 'b::linorder_topology"
   shows "continuous_on A f \<Longrightarrow> continuous_on A g \<Longrightarrow> continuous_on A (\<lambda>x. max (f x) (g x))"
   by (auto simp: continuous_on_def intro!: tendsto_max)
 
 lemma continuous_on_min [continuous_intros]:
   fixes f g :: "'a::topological_space \<Rightarrow> 'b::linorder_topology"
   shows "continuous_on A f \<Longrightarrow> continuous_on A g \<Longrightarrow> continuous_on A (\<lambda>x. min (f x) (g x))"
   by (auto simp: continuous_on_def intro!: tendsto_min)
 
 lemma continuous_max [continuous_intros]:
   fixes f :: "'a::t2_space \<Rightarrow> 'b::linorder_topology"
   shows "\<lbrakk>continuous F f; continuous F g\<rbrakk> \<Longrightarrow> continuous F (\<lambda>x. (max (f x) (g x)))"
   by (simp add: tendsto_max continuous_def)
 
 lemma continuous_min [continuous_intros]:
   fixes f :: "'a::t2_space \<Rightarrow> 'b::linorder_topology"
   shows "\<lbrakk>continuous F f; continuous F g\<rbrakk> \<Longrightarrow> continuous F (\<lambda>x. (min (f x) (g x)))"
   by (simp add: tendsto_min continuous_def)
 
 text \<open>
   The following open/closed Collect lemmas are ported from
   Sébastien Gouëzel's \<open>Ergodic_Theory\<close>.
 \<close>
 lemma open_Collect_neq:
   fixes f g :: "'a::topological_space \<Rightarrow> 'b::t2_space"
   assumes f: "continuous_on UNIV f" and g: "continuous_on UNIV g"
   shows "open {x. f x \<noteq> g x}"
 proof (rule openI)
   fix t
   assume "t \<in> {x. f x \<noteq> g x}"
   then obtain U V where *: "open U" "open V" "f t \<in> U" "g t \<in> V" "U \<inter> V = {}"
     by (auto simp add: separation_t2)
   with open_vimage[OF \<open>open U\<close> f] open_vimage[OF \<open>open V\<close> g]
   show "\<exists>T. open T \<and> t \<in> T \<and> T \<subseteq> {x. f x \<noteq> g x}"
     by (intro exI[of _ "f -` U \<inter> g -` V"]) auto
 qed
 
 lemma closed_Collect_eq:
   fixes f g :: "'a::topological_space \<Rightarrow> 'b::t2_space"
   assumes f: "continuous_on UNIV f" and g: "continuous_on UNIV g"
   shows "closed {x. f x = g x}"
   using open_Collect_neq[OF f g] by (simp add: closed_def Collect_neg_eq)
 
 lemma open_Collect_less:
   fixes f g :: "'a::topological_space \<Rightarrow> 'b::linorder_topology"
   assumes f: "continuous_on UNIV f" and g: "continuous_on UNIV g"
   shows "open {x. f x < g x}"
 proof (rule openI)
   fix t
   assume t: "t \<in> {x. f x < g x}"
   show "\<exists>T. open T \<and> t \<in> T \<and> T \<subseteq> {x. f x < g x}"
   proof (cases "\<exists>z. f t < z \<and> z < g t")
     case True
     then obtain z where "f t < z \<and> z < g t" by blast
     then show ?thesis
       using open_vimage[OF _ f, of "{..< z}"] open_vimage[OF _ g, of "{z <..}"]
       by (intro exI[of _ "f -` {..<z} \<inter> g -` {z<..}"]) auto
   next
     case False
     then have *: "{g t ..} = {f t <..}" "{..< g t} = {.. f t}"
       using t by (auto intro: leI)
     show ?thesis
       using open_vimage[OF _ f, of "{..< g t}"] open_vimage[OF _ g, of "{f t <..}"] t
       apply (intro exI[of _ "f -` {..< g t} \<inter> g -` {f t<..}"])
       apply (simp add: open_Int)
       apply (auto simp add: *)
       done
   qed
 qed
 
 lemma closed_Collect_le:
   fixes f g :: "'a :: topological_space \<Rightarrow> 'b::linorder_topology"
   assumes f: "continuous_on UNIV f"
     and g: "continuous_on UNIV g"
   shows "closed {x. f x \<le> g x}"
   using open_Collect_less [OF g f]
   by (simp add: closed_def Collect_neg_eq[symmetric] not_le)
 
 
 subsubsection \<open>Open-cover compactness\<close>
 
 context topological_space
 begin
 
 definition compact :: "'a set \<Rightarrow> bool" where
 compact_eq_Heine_Borel:  (* This name is used for backwards compatibility *)
     "compact S \<longleftrightarrow> (\<forall>C. (\<forall>c\<in>C. open c) \<and> S \<subseteq> \<Union>C \<longrightarrow> (\<exists>D\<subseteq>C. finite D \<and> S \<subseteq> \<Union>D))"
 
 lemma compactI:
   assumes "\<And>C. \<forall>t\<in>C. open t \<Longrightarrow> s \<subseteq> \<Union>C \<Longrightarrow> \<exists>C'. C' \<subseteq> C \<and> finite C' \<and> s \<subseteq> \<Union>C'"
   shows "compact s"
   unfolding compact_eq_Heine_Borel using assms by metis
 
 lemma compact_empty[simp]: "compact {}"
   by (auto intro!: compactI)
 
 lemma compactE: (*related to COMPACT_IMP_HEINE_BOREL in HOL Light*)
   assumes "compact S" "S \<subseteq> \<Union>\<T>" "\<And>B. B \<in> \<T> \<Longrightarrow> open B"
   obtains \<T>' where "\<T>' \<subseteq> \<T>" "finite \<T>'" "S \<subseteq> \<Union>\<T>'"
   by (meson assms compact_eq_Heine_Borel)
 
 lemma compactE_image:
   assumes "compact S"
     and opn: "\<And>T. T \<in> C \<Longrightarrow> open (f T)"
     and S: "S \<subseteq> (\<Union>c\<in>C. f c)"
   obtains C' where "C' \<subseteq> C" and "finite C'" and "S \<subseteq> (\<Union>c\<in>C'. f c)"
     apply (rule compactE[OF \<open>compact S\<close> S])
     using opn apply force
     by (metis finite_subset_image)
 
 lemma compact_Int_closed [intro]:
   assumes "compact S"
     and "closed T"
   shows "compact (S \<inter> T)"
 proof (rule compactI)
   fix C
   assume C: "\<forall>c\<in>C. open c"
   assume cover: "S \<inter> T \<subseteq> \<Union>C"
   from C \<open>closed T\<close> have "\<forall>c\<in>C \<union> {- T}. open c"
     by auto
   moreover from cover have "S \<subseteq> \<Union>(C \<union> {- T})"
     by auto
   ultimately have "\<exists>D\<subseteq>C \<union> {- T}. finite D \<and> S \<subseteq> \<Union>D"
     using \<open>compact S\<close> unfolding compact_eq_Heine_Borel by auto
   then obtain D where "D \<subseteq> C \<union> {- T} \<and> finite D \<and> S \<subseteq> \<Union>D" ..
   then show "\<exists>D\<subseteq>C. finite D \<and> S \<inter> T \<subseteq> \<Union>D"
     by (intro exI[of _ "D - {-T}"]) auto
 qed
 
 lemma compact_diff: "\<lbrakk>compact S; open T\<rbrakk> \<Longrightarrow> compact(S - T)"
   by (simp add: Diff_eq compact_Int_closed open_closed)
 
 lemma inj_setminus: "inj_on uminus (A::'a set set)"
   by (auto simp: inj_on_def)
 
 
 subsection \<open>Finite intersection property\<close>
 
 lemma compact_fip:
   "compact U \<longleftrightarrow>
     (\<forall>A. (\<forall>a\<in>A. closed a) \<longrightarrow> (\<forall>B \<subseteq> A. finite B \<longrightarrow> U \<inter> \<Inter>B \<noteq> {}) \<longrightarrow> U \<inter> \<Inter>A \<noteq> {})"
   (is "_ \<longleftrightarrow> ?R")
 proof (safe intro!: compact_eq_Heine_Borel[THEN iffD2])
   fix A
   assume "compact U"
   assume A: "\<forall>a\<in>A. closed a" "U \<inter> \<Inter>A = {}"
   assume fin: "\<forall>B \<subseteq> A. finite B \<longrightarrow> U \<inter> \<Inter>B \<noteq> {}"
   from A have "(\<forall>a\<in>uminus`A. open a) \<and> U \<subseteq> \<Union>(uminus`A)"
     by auto
   with \<open>compact U\<close> obtain B where "B \<subseteq> A" "finite (uminus`B)" "U \<subseteq> \<Union>(uminus`B)"
     unfolding compact_eq_Heine_Borel by (metis subset_image_iff)
   with fin[THEN spec, of B] show False
     by (auto dest: finite_imageD intro: inj_setminus)
 next
   fix A
   assume ?R
   assume "\<forall>a\<in>A. open a" "U \<subseteq> \<Union>A"
   then have "U \<inter> \<Inter>(uminus`A) = {}" "\<forall>a\<in>uminus`A. closed a"
     by auto
   with \<open>?R\<close> obtain B where "B \<subseteq> A" "finite (uminus`B)" "U \<inter> \<Inter>(uminus`B) = {}"
     by (metis subset_image_iff)
   then show "\<exists>T\<subseteq>A. finite T \<and> U \<subseteq> \<Union>T"
     by (auto intro!: exI[of _ B] inj_setminus dest: finite_imageD)
 qed
 
 lemma compact_imp_fip:
   assumes "compact S"
     and "\<And>T. T \<in> F \<Longrightarrow> closed T"
     and "\<And>F'. finite F' \<Longrightarrow> F' \<subseteq> F \<Longrightarrow> S \<inter> (\<Inter>F') \<noteq> {}"
   shows "S \<inter> (\<Inter>F) \<noteq> {}"
   using assms unfolding compact_fip by auto
 
 lemma compact_imp_fip_image:
   assumes "compact s"
     and P: "\<And>i. i \<in> I \<Longrightarrow> closed (f i)"
     and Q: "\<And>I'. finite I' \<Longrightarrow> I' \<subseteq> I \<Longrightarrow> (s \<inter> (\<Inter>i\<in>I'. f i) \<noteq> {})"
   shows "s \<inter> (\<Inter>i\<in>I. f i) \<noteq> {}"
 proof -
   note \<open>compact s\<close>
   moreover from P have "\<forall>i \<in> f ` I. closed i"
     by blast
   moreover have "\<forall>A. finite A \<and> A \<subseteq> f ` I \<longrightarrow> (s \<inter> (\<Inter>A) \<noteq> {})"
     apply rule
     apply rule
     apply (erule conjE)
   proof -
     fix A :: "'a set set"
     assume "finite A" and "A \<subseteq> f ` I"
     then obtain B where "B \<subseteq> I" and "finite B" and "A = f ` B"
       using finite_subset_image [of A f I] by blast
     with Q [of B] show "s \<inter> \<Inter>A \<noteq> {}"
       by simp
   qed
   ultimately have "s \<inter> (\<Inter>(f ` I)) \<noteq> {}"
     by (metis compact_imp_fip)
   then show ?thesis by simp
 qed
 
 end
 
 lemma (in t2_space) compact_imp_closed:
   assumes "compact s"
   shows "closed s"
   unfolding closed_def
 proof (rule openI)
   fix y
   assume "y \<in> - s"
   let ?C = "\<Union>x\<in>s. {u. open u \<and> x \<in> u \<and> eventually (\<lambda>y. y \<notin> u) (nhds y)}"
   have "s \<subseteq> \<Union>?C"
   proof
     fix x
     assume "x \<in> s"
     with \<open>y \<in> - s\<close> have "x \<noteq> y" by clarsimp
     then have "\<exists>u v. open u \<and> open v \<and> x \<in> u \<and> y \<in> v \<and> u \<inter> v = {}"
       by (rule hausdorff)
     with \<open>x \<in> s\<close> show "x \<in> \<Union>?C"
       unfolding eventually_nhds by auto
   qed
   then obtain D where "D \<subseteq> ?C" and "finite D" and "s \<subseteq> \<Union>D"
     by (rule compactE [OF \<open>compact s\<close>]) auto
   from \<open>D \<subseteq> ?C\<close> have "\<forall>x\<in>D. eventually (\<lambda>y. y \<notin> x) (nhds y)"
     by auto
   with \<open>finite D\<close> have "eventually (\<lambda>y. y \<notin> \<Union>D) (nhds y)"
     by (simp add: eventually_ball_finite)
   with \<open>s \<subseteq> \<Union>D\<close> have "eventually (\<lambda>y. y \<notin> s) (nhds y)"
     by (auto elim!: eventually_mono)
   then show "\<exists>t. open t \<and> y \<in> t \<and> t \<subseteq> - s"
     by (simp add: eventually_nhds subset_eq)
 qed
 
 lemma compact_continuous_image:
   assumes f: "continuous_on s f"
     and s: "compact s"
   shows "compact (f ` s)"
 proof (rule compactI)
   fix C
   assume "\<forall>c\<in>C. open c" and cover: "f`s \<subseteq> \<Union>C"
   with f have "\<forall>c\<in>C. \<exists>A. open A \<and> A \<inter> s = f -` c \<inter> s"
     unfolding continuous_on_open_invariant by blast
   then obtain A where A: "\<forall>c\<in>C. open (A c) \<and> A c \<inter> s = f -` c \<inter> s"
     unfolding bchoice_iff ..
   with cover have "\<And>c. c \<in> C \<Longrightarrow> open (A c)" "s \<subseteq> (\<Union>c\<in>C. A c)"
     by (fastforce simp add: subset_eq set_eq_iff)+
   from compactE_image[OF s this] obtain D where "D \<subseteq> C" "finite D" "s \<subseteq> (\<Union>c\<in>D. A c)" .
   with A show "\<exists>D \<subseteq> C. finite D \<and> f`s \<subseteq> \<Union>D"
     by (intro exI[of _ D]) (fastforce simp add: subset_eq set_eq_iff)+
 qed
 
 lemma continuous_on_inv:
   fixes f :: "'a::topological_space \<Rightarrow> 'b::t2_space"
   assumes "continuous_on s f"
     and "compact s"
     and "\<forall>x\<in>s. g (f x) = x"
   shows "continuous_on (f ` s) g"
   unfolding continuous_on_topological
 proof (clarsimp simp add: assms(3))
   fix x :: 'a and B :: "'a set"
   assume "x \<in> s" and "open B" and "x \<in> B"
   have 1: "\<forall>x\<in>s. f x \<in> f ` (s - B) \<longleftrightarrow> x \<in> s - B"
     using assms(3) by (auto, metis)
   have "continuous_on (s - B) f"
     using \<open>continuous_on s f\<close> Diff_subset
     by (rule continuous_on_subset)
   moreover have "compact (s - B)"
     using \<open>open B\<close> and \<open>compact s\<close>
     unfolding Diff_eq by (intro compact_Int_closed closed_Compl)
   ultimately have "compact (f ` (s - B))"
     by (rule compact_continuous_image)
   then have "closed (f ` (s - B))"
     by (rule compact_imp_closed)
   then have "open (- f ` (s - B))"
     by (rule open_Compl)
   moreover have "f x \<in> - f ` (s - B)"
     using \<open>x \<in> s\<close> and \<open>x \<in> B\<close> by (simp add: 1)
   moreover have "\<forall>y\<in>s. f y \<in> - f ` (s - B) \<longrightarrow> y \<in> B"
     by (simp add: 1)
   ultimately show "\<exists>A. open A \<and> f x \<in> A \<and> (\<forall>y\<in>s. f y \<in> A \<longrightarrow> y \<in> B)"
     by fast
 qed
 
 lemma continuous_on_inv_into:
   fixes f :: "'a::topological_space \<Rightarrow> 'b::t2_space"
   assumes s: "continuous_on s f" "compact s"
     and f: "inj_on f s"
   shows "continuous_on (f ` s) (the_inv_into s f)"
   by (rule continuous_on_inv[OF s]) (auto simp: the_inv_into_f_f[OF f])
 
 lemma (in linorder_topology) compact_attains_sup:
   assumes "compact S" "S \<noteq> {}"
   shows "\<exists>s\<in>S. \<forall>t\<in>S. t \<le> s"
 proof (rule classical)
   assume "\<not> (\<exists>s\<in>S. \<forall>t\<in>S. t \<le> s)"
   then obtain t where t: "\<forall>s\<in>S. t s \<in> S" and "\<forall>s\<in>S. s < t s"
     by (metis not_le)
   then have "\<And>s. s\<in>S \<Longrightarrow> open {..< t s}" "S \<subseteq> (\<Union>s\<in>S. {..< t s})"
     by auto
   with \<open>compact S\<close> obtain C where "C \<subseteq> S" "finite C" and C: "S \<subseteq> (\<Union>s\<in>C. {..< t s})"
     by (metis compactE_image)
   with \<open>S \<noteq> {}\<close> have Max: "Max (t`C) \<in> t`C" and "\<forall>s\<in>t`C. s \<le> Max (t`C)"
     by (auto intro!: Max_in)
   with C have "S \<subseteq> {..< Max (t`C)}"
     by (auto intro: less_le_trans simp: subset_eq)
   with t Max \<open>C \<subseteq> S\<close> show ?thesis
     by fastforce
 qed
 
 lemma (in linorder_topology) compact_attains_inf:
   assumes "compact S" "S \<noteq> {}"
   shows "\<exists>s\<in>S. \<forall>t\<in>S. s \<le> t"
 proof (rule classical)
   assume "\<not> (\<exists>s\<in>S. \<forall>t\<in>S. s \<le> t)"
   then obtain t where t: "\<forall>s\<in>S. t s \<in> S" and "\<forall>s\<in>S. t s < s"
     by (metis not_le)
   then have "\<And>s. s\<in>S \<Longrightarrow> open {t s <..}" "S \<subseteq> (\<Union>s\<in>S. {t s <..})"
     by auto
   with \<open>compact S\<close> obtain C where "C \<subseteq> S" "finite C" and C: "S \<subseteq> (\<Union>s\<in>C. {t s <..})"
     by (metis compactE_image)
   with \<open>S \<noteq> {}\<close> have Min: "Min (t`C) \<in> t`C" and "\<forall>s\<in>t`C. Min (t`C) \<le> s"
     by (auto intro!: Min_in)
   with C have "S \<subseteq> {Min (t`C) <..}"
     by (auto intro: le_less_trans simp: subset_eq)
   with t Min \<open>C \<subseteq> S\<close> show ?thesis
     by fastforce
 qed
 
 lemma continuous_attains_sup:
   fixes f :: "'a::topological_space \<Rightarrow> 'b::linorder_topology"
   shows "compact s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> continuous_on s f \<Longrightarrow> (\<exists>x\<in>s. \<forall>y\<in>s.  f y \<le> f x)"
   using compact_attains_sup[of "f ` s"] compact_continuous_image[of s f] by auto
 
 lemma continuous_attains_inf:
   fixes f :: "'a::topological_space \<Rightarrow> 'b::linorder_topology"
   shows "compact s \<Longrightarrow> s \<noteq> {} \<Longrightarrow> continuous_on s f \<Longrightarrow> (\<exists>x\<in>s. \<forall>y\<in>s. f x \<le> f y)"
   using compact_attains_inf[of "f ` s"] compact_continuous_image[of s f] by auto
 
 
 subsection \<open>Connectedness\<close>
 
 context topological_space
 begin
 
 definition "connected S \<longleftrightarrow>
   \<not> (\<exists>A B. open A \<and> open B \<and> S \<subseteq> A \<union> B \<and> A \<inter> B \<inter> S = {} \<and> A \<inter> S \<noteq> {} \<and> B \<inter> S \<noteq> {})"
 
 lemma connectedI:
   "(\<And>A B. open A \<Longrightarrow> open B \<Longrightarrow> A \<inter> U \<noteq> {} \<Longrightarrow> B \<inter> U \<noteq> {} \<Longrightarrow> A \<inter> B \<inter> U = {} \<Longrightarrow> U \<subseteq> A \<union> B \<Longrightarrow> False)
   \<Longrightarrow> connected U"
   by (auto simp: connected_def)
 
 lemma connected_empty [simp]: "connected {}"
   by (auto intro!: connectedI)
 
 lemma connected_sing [simp]: "connected {x}"
   by (auto intro!: connectedI)
 
 lemma connectedD:
   "connected A \<Longrightarrow> open U \<Longrightarrow> open V \<Longrightarrow> U \<inter> V \<inter> A = {} \<Longrightarrow> A \<subseteq> U \<union> V \<Longrightarrow> U \<inter> A = {} \<or> V \<inter> A = {}"
   by (auto simp: connected_def)
 
 end
 
 lemma connected_closed:
   "connected s \<longleftrightarrow>
     \<not> (\<exists>A B. closed A \<and> closed B \<and> s \<subseteq> A \<union> B \<and> A \<inter> B \<inter> s = {} \<and> A \<inter> s \<noteq> {} \<and> B \<inter> s \<noteq> {})"
   apply (simp add: connected_def del: ex_simps, safe)
    apply (drule_tac x="-A" in spec)
    apply (drule_tac x="-B" in spec)
    apply (fastforce simp add: closed_def [symmetric])
   apply (drule_tac x="-A" in spec)
   apply (drule_tac x="-B" in spec)
   apply (fastforce simp add: open_closed [symmetric])
   done
 
 lemma connected_closedD:
   "\<lbrakk>connected s; A \<inter> B \<inter> s = {}; s \<subseteq> A \<union> B; closed A; closed B\<rbrakk> \<Longrightarrow> A \<inter> s = {} \<or> B \<inter> s = {}"
   by (simp add: connected_closed)
 
 lemma connected_Union:
   assumes cs: "\<And>s. s \<in> S \<Longrightarrow> connected s"
     and ne: "\<Inter>S \<noteq> {}"
   shows "connected(\<Union>S)"
 proof (rule connectedI)
   fix A B
   assume A: "open A" and B: "open B" and Alap: "A \<inter> \<Union>S \<noteq> {}" and Blap: "B \<inter> \<Union>S \<noteq> {}"
     and disj: "A \<inter> B \<inter> \<Union>S = {}" and cover: "\<Union>S \<subseteq> A \<union> B"
   have disjs:"\<And>s. s \<in> S \<Longrightarrow> A \<inter> B \<inter> s = {}"
     using disj by auto
   obtain sa where sa: "sa \<in> S" "A \<inter> sa \<noteq> {}"
     using Alap by auto
   obtain sb where sb: "sb \<in> S" "B \<inter> sb \<noteq> {}"
     using Blap by auto
   obtain x where x: "\<And>s. s \<in> S \<Longrightarrow> x \<in> s"
     using ne by auto
   then have "x \<in> \<Union>S"
     using \<open>sa \<in> S\<close> by blast
   then have "x \<in> A \<or> x \<in> B"
     using cover by auto
   then show False
     using cs [unfolded connected_def]
     by (metis A B IntI Sup_upper sa sb disjs x cover empty_iff subset_trans)
 qed
 
 lemma connected_Un: "connected s \<Longrightarrow> connected t \<Longrightarrow> s \<inter> t \<noteq> {} \<Longrightarrow> connected (s \<union> t)"
   using connected_Union [of "{s,t}"] by auto
 
 lemma connected_diff_open_from_closed:
   assumes st: "s \<subseteq> t"
     and tu: "t \<subseteq> u"
     and s: "open s"
     and t: "closed t"
     and u: "connected u"
     and ts: "connected (t - s)"
   shows "connected(u - s)"
 proof (rule connectedI)
   fix A B
   assume AB: "open A" "open B" "A \<inter> (u - s) \<noteq> {}" "B \<inter> (u - s) \<noteq> {}"
     and disj: "A \<inter> B \<inter> (u - s) = {}"
     and cover: "u - s \<subseteq> A \<union> B"
   then consider "A \<inter> (t - s) = {}" | "B \<inter> (t - s) = {}"
     using st ts tu connectedD [of "t-s" "A" "B"] by auto
   then show False
   proof cases
     case 1
     then have "(A - t) \<inter> (B \<union> s) \<inter> u = {}"
       using disj st by auto
     moreover have "u \<subseteq> (A - t) \<union> (B \<union> s)"
       using 1 cover by auto
     ultimately show False
       using connectedD [of u "A - t" "B \<union> s"] AB s t 1 u by auto
   next
     case 2
     then have "(A \<union> s) \<inter> (B - t) \<inter> u = {}"
       using disj st by auto
     moreover have "u \<subseteq> (A \<union> s) \<union> (B - t)"
       using 2 cover by auto
     ultimately show False
       using connectedD [of u "A \<union> s" "B - t"] AB s t 2 u by auto
   qed
 qed
 
 lemma connected_iff_const:
   fixes S :: "'a::topological_space set"
   shows "connected S \<longleftrightarrow> (\<forall>P::'a \<Rightarrow> bool. continuous_on S P \<longrightarrow> (\<exists>c. \<forall>s\<in>S. P s = c))"
 proof safe
   fix P :: "'a \<Rightarrow> bool"
   assume "connected S" "continuous_on S P"
   then have "\<And>b. \<exists>A. open A \<and> A \<inter> S = P -` {b} \<inter> S"
     unfolding continuous_on_open_invariant by (simp add: open_discrete)
   from this[of True] this[of False]
   obtain t f where "open t" "open f" and *: "f \<inter> S = P -` {False} \<inter> S" "t \<inter> S = P -` {True} \<inter> S"
     by meson
   then have "t \<inter> S = {} \<or> f \<inter> S = {}"
     by (intro connectedD[OF \<open>connected S\<close>])  auto
   then show "\<exists>c. \<forall>s\<in>S. P s = c"
   proof (rule disjE)
     assume "t \<inter> S = {}"
     then show ?thesis
       unfolding * by (intro exI[of _ False]) auto
   next
     assume "f \<inter> S = {}"
     then show ?thesis
       unfolding * by (intro exI[of _ True]) auto
   qed
 next
   assume P: "\<forall>P::'a \<Rightarrow> bool. continuous_on S P \<longrightarrow> (\<exists>c. \<forall>s\<in>S. P s = c)"
   show "connected S"
   proof (rule connectedI)
     fix A B
     assume *: "open A" "open B" "A \<inter> S \<noteq> {}" "B \<inter> S \<noteq> {}" "A \<inter> B \<inter> S = {}" "S \<subseteq> A \<union> B"
     have "continuous_on S (\<lambda>x. x \<in> A)"
       unfolding continuous_on_open_invariant
     proof safe
       fix C :: "bool set"
       have "C = UNIV \<or> C = {True} \<or> C = {False} \<or> C = {}"
         using subset_UNIV[of C] unfolding UNIV_bool by auto
       with * show "\<exists>T. open T \<and> T \<inter> S = (\<lambda>x. x \<in> A) -` C \<inter> S"
         by (intro exI[of _ "(if True \<in> C then A else {}) \<union> (if False \<in> C then B else {})"]) auto
     qed
     from P[rule_format, OF this] obtain c where "\<And>s. s \<in> S \<Longrightarrow> (s \<in> A) = c"
       by blast
     with * show False
       by (cases c) auto
   qed
 qed
 
 lemma connectedD_const: "connected S \<Longrightarrow> continuous_on S P \<Longrightarrow> \<exists>c. \<forall>s\<in>S. P s = c"
   for P :: "'a::topological_space \<Rightarrow> bool"
   by (auto simp: connected_iff_const)
 
 lemma connectedI_const:
   "(\<And>P::'a::topological_space \<Rightarrow> bool. continuous_on S P \<Longrightarrow> \<exists>c. \<forall>s\<in>S. P s = c) \<Longrightarrow> connected S"
   by (auto simp: connected_iff_const)
 
 lemma connected_local_const:
   assumes "connected A" "a \<in> A" "b \<in> A"
     and *: "\<forall>a\<in>A. eventually (\<lambda>b. f a = f b) (at a within A)"
   shows "f a = f b"
 proof -
   obtain S where S: "\<And>a. a \<in> A \<Longrightarrow> a \<in> S a" "\<And>a. a \<in> A \<Longrightarrow> open (S a)"
     "\<And>a x. a \<in> A \<Longrightarrow> x \<in> S a \<Longrightarrow> x \<in> A \<Longrightarrow> f a = f x"
     using * unfolding eventually_at_topological by metis
   let ?P = "\<Union>b\<in>{b\<in>A. f a = f b}. S b" and ?N = "\<Union>b\<in>{b\<in>A. f a \<noteq> f b}. S b"
   have "?P \<inter> A = {} \<or> ?N \<inter> A = {}"
     using \<open>connected A\<close> S \<open>a\<in>A\<close>
     by (intro connectedD) (auto, metis)
   then show "f a = f b"
   proof
     assume "?N \<inter> A = {}"
     then have "\<forall>x\<in>A. f a = f x"
       using S(1) by auto
     with \<open>b\<in>A\<close> show ?thesis by auto
   next
     assume "?P \<inter> A = {}" then show ?thesis
       using \<open>a \<in> A\<close> S(1)[of a] by auto
   qed
 qed
 
 lemma (in linorder_topology) connectedD_interval:
   assumes "connected U"
     and xy: "x \<in> U" "y \<in> U"
     and "x \<le> z" "z \<le> y"
   shows "z \<in> U"
 proof -
   have eq: "{..<z} \<union> {z<..} = - {z}"
     by auto
   have "\<not> connected U" if "z \<notin> U" "x < z" "z < y"
     using xy that
     apply (simp only: connected_def simp_thms)
     apply (rule_tac exI[of _ "{..< z}"])
     apply (rule_tac exI[of _ "{z <..}"])
     apply (auto simp add: eq)
     done
   with assms show "z \<in> U"
     by (metis less_le)
 qed
 
 lemma (in linorder_topology) not_in_connected_cases:
   assumes conn: "connected S"
   assumes nbdd: "x \<notin> S"
   assumes ne: "S \<noteq> {}"
   obtains "bdd_above S" "\<And>y. y \<in> S \<Longrightarrow> x \<ge> y" | "bdd_below S" "\<And>y. y \<in> S \<Longrightarrow> x \<le> y"
 proof -
   obtain s where "s \<in> S" using ne by blast
   {
     assume "s \<le> x"
     have "False" if "x \<le> y" "y \<in> S" for y
       using connectedD_interval[OF conn \<open>s \<in> S\<close> \<open>y \<in> S\<close> \<open>s \<le> x\<close> \<open>x \<le> y\<close>] \<open>x \<notin> S\<close>
       by simp
     then have wit: "y \<in> S \<Longrightarrow> x \<ge> y" for y
       using le_cases by blast
     then have "bdd_above S"
       by (rule local.bdd_aboveI)
     note this wit
   } moreover {
     assume "x \<le> s"
     have "False" if "x \<ge> y" "y \<in> S" for y
       using connectedD_interval[OF conn \<open>y \<in> S\<close> \<open>s \<in> S\<close> \<open>x \<ge> y\<close> \<open>s \<ge> x\<close> ] \<open>x \<notin> S\<close>
       by simp
     then have wit: "y \<in> S \<Longrightarrow> x \<le> y" for y
       using le_cases by blast
     then have "bdd_below S"
       by (rule bdd_belowI)
     note this wit
   } ultimately show ?thesis
     by (meson le_cases that)
 qed
 
 lemma connected_continuous_image:
   assumes *: "continuous_on s f"
     and "connected s"
   shows "connected (f ` s)"
 proof (rule connectedI_const)
   fix P :: "'b \<Rightarrow> bool"
   assume "continuous_on (f ` s) P"
   then have "continuous_on s (P \<circ> f)"
     by (rule continuous_on_compose[OF *])
   from connectedD_const[OF \<open>connected s\<close> this] show "\<exists>c. \<forall>s\<in>f ` s. P s = c"
     by auto
 qed
 
 
 section \<open>Linear Continuum Topologies\<close>
 
 class linear_continuum_topology = linorder_topology + linear_continuum
 begin
 
 lemma Inf_notin_open:
   assumes A: "open A"
     and bnd: "\<forall>a\<in>A. x < a"
   shows "Inf A \<notin> A"
 proof
   assume "Inf A \<in> A"
   then obtain b where "b < Inf A" "{b <.. Inf A} \<subseteq> A"
     using open_left[of A "Inf A" x] assms by auto
   with dense[of b "Inf A"] obtain c where "c < Inf A" "c \<in> A"
     by (auto simp: subset_eq)
   then show False
     using cInf_lower[OF \<open>c \<in> A\<close>] bnd
     by (metis not_le less_imp_le bdd_belowI)
 qed
 
 lemma Sup_notin_open:
   assumes A: "open A"
     and bnd: "\<forall>a\<in>A. a < x"
   shows "Sup A \<notin> A"
 proof
   assume "Sup A \<in> A"
   with assms obtain b where "Sup A < b" "{Sup A ..< b} \<subseteq> A"
     using open_right[of A "Sup A" x] by auto
   with dense[of "Sup A" b] obtain c where "Sup A < c" "c \<in> A"
     by (auto simp: subset_eq)
   then show False
     using cSup_upper[OF \<open>c \<in> A\<close>] bnd
     by (metis less_imp_le not_le bdd_aboveI)
 qed
 
 end
 
 instance linear_continuum_topology \<subseteq> perfect_space
 proof
   fix x :: 'a
   obtain y where "x < y \<or> y < x"
     using ex_gt_or_lt [of x] ..
   with Inf_notin_open[of "{x}" y] Sup_notin_open[of "{x}" y] show "\<not> open {x}"
     by auto
 qed
 
 lemma connectedI_interval:
   fixes U :: "'a :: linear_continuum_topology set"
   assumes *: "\<And>x y z. x \<in> U \<Longrightarrow> y \<in> U \<Longrightarrow> x \<le> z \<Longrightarrow> z \<le> y \<Longrightarrow> z \<in> U"
   shows "connected U"
 proof (rule connectedI)
   {
     fix A B
     assume "open A" "open B" "A \<inter> B \<inter> U = {}" "U \<subseteq> A \<union> B"
     fix x y
     assume "x < y" "x \<in> A" "y \<in> B" "x \<in> U" "y \<in> U"
 
     let ?z = "Inf (B \<inter> {x <..})"
 
     have "x \<le> ?z" "?z \<le> y"
       using \<open>y \<in> B\<close> \<open>x < y\<close> by (auto intro: cInf_lower cInf_greatest)
     with \<open>x \<in> U\<close> \<open>y \<in> U\<close> have "?z \<in> U"
       by (rule *)
     moreover have "?z \<notin> B \<inter> {x <..}"
       using \<open>open B\<close> by (intro Inf_notin_open) auto
     ultimately have "?z \<in> A"
       using \<open>x \<le> ?z\<close> \<open>A \<inter> B \<inter> U = {}\<close> \<open>x \<in> A\<close> \<open>U \<subseteq> A \<union> B\<close> by auto
     have "\<exists>b\<in>B. b \<in> A \<and> b \<in> U" if "?z < y"
     proof -
       obtain a where "?z < a" "{?z ..< a} \<subseteq> A"
         using open_right[OF \<open>open A\<close> \<open>?z \<in> A\<close> \<open>?z < y\<close>] by auto
       moreover obtain b where "b \<in> B" "x < b" "b < min a y"
         using cInf_less_iff[of "B \<inter> {x <..}" "min a y"] \<open>?z < a\<close> \<open>?z < y\<close> \<open>x < y\<close> \<open>y \<in> B\<close>
         by auto
       moreover have "?z \<le> b"
         using \<open>b \<in> B\<close> \<open>x < b\<close>
         by (intro cInf_lower) auto
       moreover have "b \<in> U"
         using \<open>x \<le> ?z\<close> \<open>?z \<le> b\<close> \<open>b < min a y\<close>
         by (intro *[OF \<open>x \<in> U\<close> \<open>y \<in> U\<close>]) (auto simp: less_imp_le)
       ultimately show ?thesis
         by (intro bexI[of _ b]) auto
     qed
     then have False
       using \<open>?z \<le> y\<close> \<open>?z \<in> A\<close> \<open>y \<in> B\<close> \<open>y \<in> U\<close> \<open>A \<inter> B \<inter> U = {}\<close>
       unfolding le_less by blast
   }
   note not_disjoint = this
 
   fix A B assume AB: "open A" "open B" "U \<subseteq> A \<union> B" "A \<inter> B \<inter> U = {}"
   moreover assume "A \<inter> U \<noteq> {}" then obtain x where x: "x \<in> U" "x \<in> A" by auto
   moreover assume "B \<inter> U \<noteq> {}" then obtain y where y: "y \<in> U" "y \<in> B" by auto
   moreover note not_disjoint[of B A y x] not_disjoint[of A B x y]
   ultimately show False
     by (cases x y rule: linorder_cases) auto
 qed
 
 lemma connected_iff_interval: "connected U \<longleftrightarrow> (\<forall>x\<in>U. \<forall>y\<in>U. \<forall>z. x \<le> z \<longrightarrow> z \<le> y \<longrightarrow> z \<in> U)"
   for U :: "'a::linear_continuum_topology set"
   by (auto intro: connectedI_interval dest: connectedD_interval)
 
 lemma connected_UNIV[simp]: "connected (UNIV::'a::linear_continuum_topology set)"
   by (simp add: connected_iff_interval)
 
 lemma connected_Ioi[simp]: "connected {a<..}"
   for a :: "'a::linear_continuum_topology"
   by (auto simp: connected_iff_interval)
 
 lemma connected_Ici[simp]: "connected {a..}"
   for a :: "'a::linear_continuum_topology"
   by (auto simp: connected_iff_interval)
 
 lemma connected_Iio[simp]: "connected {..<a}"
   for a :: "'a::linear_continuum_topology"
   by (auto simp: connected_iff_interval)
 
 lemma connected_Iic[simp]: "connected {..a}"
   for a :: "'a::linear_continuum_topology"
   by (auto simp: connected_iff_interval)
 
 lemma connected_Ioo[simp]: "connected {a<..<b}"
   for a b :: "'a::linear_continuum_topology"
   unfolding connected_iff_interval by auto
 
 lemma connected_Ioc[simp]: "connected {a<..b}"
   for a b :: "'a::linear_continuum_topology"
   by (auto simp: connected_iff_interval)
 
 lemma connected_Ico[simp]: "connected {a..<b}"
   for a b :: "'a::linear_continuum_topology"
   by (auto simp: connected_iff_interval)
 
 lemma connected_Icc[simp]: "connected {a..b}"
   for a b :: "'a::linear_continuum_topology"
   by (auto simp: connected_iff_interval)
 
 lemma connected_contains_Ioo:
   fixes A :: "'a :: linorder_topology set"
   assumes "connected A" "a \<in> A" "b \<in> A" shows "{a <..< b} \<subseteq> A"
   using connectedD_interval[OF assms] by (simp add: subset_eq Ball_def less_imp_le)
 
 lemma connected_contains_Icc:
   fixes A :: "'a::linorder_topology set"
   assumes "connected A" "a \<in> A" "b \<in> A"
   shows "{a..b} \<subseteq> A"
 proof
   fix x assume "x \<in> {a..b}"
   then have "x = a \<or> x = b \<or> x \<in> {a<..<b}"
     by auto
   then show "x \<in> A"
     using assms connected_contains_Ioo[of A a b] by auto
 qed
 
 
 subsection \<open>Intermediate Value Theorem\<close>
 
 lemma IVT':
   fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
   assumes y: "f a \<le> y" "y \<le> f b" "a \<le> b"
     and *: "continuous_on {a .. b} f"
   shows "\<exists>x. a \<le> x \<and> x \<le> b \<and> f x = y"
 proof -
   have "connected {a..b}"
     unfolding connected_iff_interval by auto
   from connected_continuous_image[OF * this, THEN connectedD_interval, of "f a" "f b" y] y
   show ?thesis
     by (auto simp add: atLeastAtMost_def atLeast_def atMost_def)
 qed
 
 lemma IVT2':
   fixes f :: "'a :: linear_continuum_topology \<Rightarrow> 'b :: linorder_topology"
   assumes y: "f b \<le> y" "y \<le> f a" "a \<le> b"
     and *: "continuous_on {a .. b} f"
   shows "\<exists>x. a \<le> x \<and> x \<le> b \<and> f x = y"
 proof -
   have "connected {a..b}"
     unfolding connected_iff_interval by auto
   from connected_continuous_image[OF * this, THEN connectedD_interval, of "f b" "f a" y] y
   show ?thesis
     by (auto simp add: atLeastAtMost_def atLeast_def atMost_def)
 qed
 
 lemma IVT:
   fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
   shows "f a \<le> y \<Longrightarrow> y \<le> f b \<Longrightarrow> a \<le> b \<Longrightarrow> (\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> isCont f x) \<Longrightarrow>
     \<exists>x. a \<le> x \<and> x \<le> b \<and> f x = y"
   by (rule IVT') (auto intro: continuous_at_imp_continuous_on)
 
 lemma IVT2:
   fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
   shows "f b \<le> y \<Longrightarrow> y \<le> f a \<Longrightarrow> a \<le> b \<Longrightarrow> (\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> isCont f x) \<Longrightarrow>
     \<exists>x. a \<le> x \<and> x \<le> b \<and> f x = y"
   by (rule IVT2') (auto intro: continuous_at_imp_continuous_on)
 
 lemma continuous_inj_imp_mono:
   fixes f :: "'a::linear_continuum_topology \<Rightarrow> 'b::linorder_topology"
   assumes x: "a < x" "x < b"
     and cont: "continuous_on {a..b} f"
     and inj: "inj_on f {a..b}"
   shows "(f a < f x \<and> f x < f b) \<or> (f b < f x \<and> f x < f a)"
 proof -
   note I = inj_on_eq_iff[OF inj]
   {
     assume "f x < f a" "f x < f b"
     then obtain s t where "x \<le> s" "s \<le> b" "a \<le> t" "t \<le> x" "f s = f t" "f x < f s"
       using IVT'[of f x "min (f a) (f b)" b] IVT2'[of f x "min (f a) (f b)" a] x
       by (auto simp: continuous_on_subset[OF cont] less_imp_le)
     with x I have False by auto
   }
   moreover
   {
     assume "f a < f x" "f b < f x"
     then obtain s t where "x \<le> s" "s \<le> b" "a \<le> t" "t \<le> x" "f s = f t" "f s < f x"
       using IVT'[of f a "max (f a) (f b)" x] IVT2'[of f b "max (f a) (f b)" x] x
       by (auto simp: continuous_on_subset[OF cont] less_imp_le)
     with x I have False by auto
   }
   ultimately show ?thesis
     using I[of a x] I[of x b] x less_trans[OF x]
     by (auto simp add: le_less less_imp_neq neq_iff)
 qed
 
 lemma continuous_at_Sup_mono:
   fixes f :: "'a::{linorder_topology,conditionally_complete_linorder} \<Rightarrow>
     'b::{linorder_topology,conditionally_complete_linorder}"
   assumes "mono f"
     and cont: "continuous (at_left (Sup S)) f"
     and S: "S \<noteq> {}" "bdd_above S"
   shows "f (Sup S) = (SUP s\<in>S. f s)"
 proof (rule antisym)
   have f: "(f \<longlongrightarrow> f (Sup S)) (at_left (Sup S))"
     using cont unfolding continuous_within .
   show "f (Sup S) \<le> (SUP s\<in>S. f s)"
   proof cases
     assume "Sup S \<in> S"
     then show ?thesis
       by (rule cSUP_upper) (auto intro: bdd_above_image_mono S \<open>mono f\<close>)
   next
     assume "Sup S \<notin> S"
     from \<open>S \<noteq> {}\<close> obtain s where "s \<in> S"
       by auto
     with \<open>Sup S \<notin> S\<close> S have "s < Sup S"
       unfolding less_le by (blast intro: cSup_upper)
     show ?thesis
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with order_tendstoD(1)[OF f, of "SUP s\<in>S. f s"] obtain b where "b < Sup S"
         and *: "\<And>y. b < y \<Longrightarrow> y < Sup S \<Longrightarrow> (SUP s\<in>S. f s) < f y"
         by (auto simp: not_le eventually_at_left[OF \<open>s < Sup S\<close>])
       with \<open>S \<noteq> {}\<close> obtain c where "c \<in> S" "b < c"
         using less_cSupD[of S b] by auto
       with \<open>Sup S \<notin> S\<close> S have "c < Sup S"
         unfolding less_le by (blast intro: cSup_upper)
       from *[OF \<open>b < c\<close> \<open>c < Sup S\<close>] cSUP_upper[OF \<open>c \<in> S\<close> bdd_above_image_mono[of f]]
       show False
         by (auto simp: assms)
     qed
   qed
 qed (intro cSUP_least \<open>mono f\<close>[THEN monoD] cSup_upper S)
 
 lemma continuous_at_Sup_antimono:
   fixes f :: "'a::{linorder_topology,conditionally_complete_linorder} \<Rightarrow>
     'b::{linorder_topology,conditionally_complete_linorder}"
   assumes "antimono f"
     and cont: "continuous (at_left (Sup S)) f"
     and S: "S \<noteq> {}" "bdd_above S"
   shows "f (Sup S) = (INF s\<in>S. f s)"
 proof (rule antisym)
   have f: "(f \<longlongrightarrow> f (Sup S)) (at_left (Sup S))"
     using cont unfolding continuous_within .
   show "(INF s\<in>S. f s) \<le> f (Sup S)"
   proof cases
     assume "Sup S \<in> S"
     then show ?thesis
       by (intro cINF_lower) (auto intro: bdd_below_image_antimono S \<open>antimono f\<close>)
   next
     assume "Sup S \<notin> S"
     from \<open>S \<noteq> {}\<close> obtain s where "s \<in> S"
       by auto
     with \<open>Sup S \<notin> S\<close> S have "s < Sup S"
       unfolding less_le by (blast intro: cSup_upper)
     show ?thesis
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with order_tendstoD(2)[OF f, of "INF s\<in>S. f s"] obtain b where "b < Sup S"
         and *: "\<And>y. b < y \<Longrightarrow> y < Sup S \<Longrightarrow> f y < (INF s\<in>S. f s)"
         by (auto simp: not_le eventually_at_left[OF \<open>s < Sup S\<close>])
       with \<open>S \<noteq> {}\<close> obtain c where "c \<in> S" "b < c"
         using less_cSupD[of S b] by auto
       with \<open>Sup S \<notin> S\<close> S have "c < Sup S"
         unfolding less_le by (blast intro: cSup_upper)
       from *[OF \<open>b < c\<close> \<open>c < Sup S\<close>] cINF_lower[OF bdd_below_image_antimono, of f S c] \<open>c \<in> S\<close>
       show False
         by (auto simp: assms)
     qed
   qed
 qed (intro cINF_greatest \<open>antimono f\<close>[THEN antimonoD] cSup_upper S)
 
 lemma continuous_at_Inf_mono:
   fixes f :: "'a::{linorder_topology,conditionally_complete_linorder} \<Rightarrow>
     'b::{linorder_topology,conditionally_complete_linorder}"
   assumes "mono f"
     and cont: "continuous (at_right (Inf S)) f"
     and S: "S \<noteq> {}" "bdd_below S"
   shows "f (Inf S) = (INF s\<in>S. f s)"
 proof (rule antisym)
   have f: "(f \<longlongrightarrow> f (Inf S)) (at_right (Inf S))"
     using cont unfolding continuous_within .
   show "(INF s\<in>S. f s) \<le> f (Inf S)"
   proof cases
     assume "Inf S \<in> S"
     then show ?thesis
       by (rule cINF_lower[rotated]) (auto intro: bdd_below_image_mono S \<open>mono f\<close>)
   next
     assume "Inf S \<notin> S"
     from \<open>S \<noteq> {}\<close> obtain s where "s \<in> S"
       by auto
     with \<open>Inf S \<notin> S\<close> S have "Inf S < s"
       unfolding less_le by (blast intro: cInf_lower)
     show ?thesis
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with order_tendstoD(2)[OF f, of "INF s\<in>S. f s"] obtain b where "Inf S < b"
         and *: "\<And>y. Inf S < y \<Longrightarrow> y < b \<Longrightarrow> f y < (INF s\<in>S. f s)"
         by (auto simp: not_le eventually_at_right[OF \<open>Inf S < s\<close>])
       with \<open>S \<noteq> {}\<close> obtain c where "c \<in> S" "c < b"
         using cInf_lessD[of S b] by auto
       with \<open>Inf S \<notin> S\<close> S have "Inf S < c"
         unfolding less_le by (blast intro: cInf_lower)
       from *[OF \<open>Inf S < c\<close> \<open>c < b\<close>] cINF_lower[OF bdd_below_image_mono[of f] \<open>c \<in> S\<close>]
       show False
         by (auto simp: assms)
     qed
   qed
 qed (intro cINF_greatest \<open>mono f\<close>[THEN monoD] cInf_lower \<open>bdd_below S\<close> \<open>S \<noteq> {}\<close>)
 
 lemma continuous_at_Inf_antimono:
   fixes f :: "'a::{linorder_topology,conditionally_complete_linorder} \<Rightarrow>
     'b::{linorder_topology,conditionally_complete_linorder}"
   assumes "antimono f"
     and cont: "continuous (at_right (Inf S)) f"
     and S: "S \<noteq> {}" "bdd_below S"
   shows "f (Inf S) = (SUP s\<in>S. f s)"
 proof (rule antisym)
   have f: "(f \<longlongrightarrow> f (Inf S)) (at_right (Inf S))"
     using cont unfolding continuous_within .
   show "f (Inf S) \<le> (SUP s\<in>S. f s)"
   proof cases
     assume "Inf S \<in> S"
     then show ?thesis
       by (rule cSUP_upper) (auto intro: bdd_above_image_antimono S \<open>antimono f\<close>)
   next
     assume "Inf S \<notin> S"
     from \<open>S \<noteq> {}\<close> obtain s where "s \<in> S"
       by auto
     with \<open>Inf S \<notin> S\<close> S have "Inf S < s"
       unfolding less_le by (blast intro: cInf_lower)
     show ?thesis
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with order_tendstoD(1)[OF f, of "SUP s\<in>S. f s"] obtain b where "Inf S < b"
         and *: "\<And>y. Inf S < y \<Longrightarrow> y < b \<Longrightarrow> (SUP s\<in>S. f s) < f y"
         by (auto simp: not_le eventually_at_right[OF \<open>Inf S < s\<close>])
       with \<open>S \<noteq> {}\<close> obtain c where "c \<in> S" "c < b"
         using cInf_lessD[of S b] by auto
       with \<open>Inf S \<notin> S\<close> S have "Inf S < c"
         unfolding less_le by (blast intro: cInf_lower)
       from *[OF \<open>Inf S < c\<close> \<open>c < b\<close>] cSUP_upper[OF \<open>c \<in> S\<close> bdd_above_image_antimono[of f]]
       show False
         by (auto simp: assms)
     qed
   qed
 qed (intro cSUP_least \<open>antimono f\<close>[THEN antimonoD] cInf_lower S)
 
 
 subsection \<open>Uniform spaces\<close>
 
 class uniformity =
   fixes uniformity :: "('a \<times> 'a) filter"
 begin
 
 abbreviation uniformity_on :: "'a set \<Rightarrow> ('a \<times> 'a) filter"
   where "uniformity_on s \<equiv> inf uniformity (principal (s\<times>s))"
 
 end
 
 lemma uniformity_Abort:
   "uniformity =
     Filter.abstract_filter (\<lambda>u. Code.abort (STR ''uniformity is not executable'') (\<lambda>u. uniformity))"
   by simp
 
 class open_uniformity = "open" + uniformity +
   assumes open_uniformity:
     "\<And>U. open U \<longleftrightarrow> (\<forall>x\<in>U. eventually (\<lambda>(x', y). x' = x \<longrightarrow> y \<in> U) uniformity)"
 begin
 
 subclass topological_space
   by standard (force elim: eventually_mono eventually_elim2 simp: split_beta' open_uniformity)+
 
 end
 
 class uniform_space = open_uniformity +
   assumes uniformity_refl: "eventually E uniformity \<Longrightarrow> E (x, x)"
     and uniformity_sym: "eventually E uniformity \<Longrightarrow> eventually (\<lambda>(x, y). E (y, x)) uniformity"
     and uniformity_trans:
       "eventually E uniformity \<Longrightarrow>
         \<exists>D. eventually D uniformity \<and> (\<forall>x y z. D (x, y) \<longrightarrow> D (y, z) \<longrightarrow> E (x, z))"
 begin
 
 lemma uniformity_bot: "uniformity \<noteq> bot"
   using uniformity_refl by auto
 
 lemma uniformity_trans':
   "eventually E uniformity \<Longrightarrow>
     eventually (\<lambda>((x, y), (y', z)). y = y' \<longrightarrow> E (x, z)) (uniformity \<times>\<^sub>F uniformity)"
   by (drule uniformity_trans) (auto simp add: eventually_prod_same)
 
 lemma uniformity_transE:
   assumes "eventually E uniformity"
   obtains D where "eventually D uniformity" "\<And>x y z. D (x, y) \<Longrightarrow> D (y, z) \<Longrightarrow> E (x, z)"
   using uniformity_trans [OF assms] by auto
 
 lemma eventually_nhds_uniformity:
   "eventually P (nhds x) \<longleftrightarrow> eventually (\<lambda>(x', y). x' = x \<longrightarrow> P y) uniformity"
   (is "_ \<longleftrightarrow> ?N P x")
   unfolding eventually_nhds
 proof safe
   assume *: "?N P x"
   have "?N (?N P) x" if "?N P x" for x
   proof -
     from that obtain D where ev: "eventually D uniformity"
       and D: "D (a, b) \<Longrightarrow> D (b, c) \<Longrightarrow> case (a, c) of (x', y) \<Rightarrow> x' = x \<longrightarrow> P y" for a b c
       by (rule uniformity_transE) simp
     from ev show ?thesis
       by eventually_elim (insert ev D, force elim: eventually_mono split: prod.split)
   qed
   then have "open {x. ?N P x}"
     by (simp add: open_uniformity)
   then show "\<exists>S. open S \<and> x \<in> S \<and> (\<forall>x\<in>S. P x)"
     by (intro exI[of _ "{x. ?N P x}"]) (auto dest: uniformity_refl simp: *)
 qed (force simp add: open_uniformity elim: eventually_mono)
 
 
 subsubsection \<open>Totally bounded sets\<close>
 
 definition totally_bounded :: "'a set \<Rightarrow> bool"
   where "totally_bounded S \<longleftrightarrow>
     (\<forall>E. eventually E uniformity \<longrightarrow> (\<exists>X. finite X \<and> (\<forall>s\<in>S. \<exists>x\<in>X. E (x, s))))"
 
 lemma totally_bounded_empty[iff]: "totally_bounded {}"
   by (auto simp add: totally_bounded_def)
 
 lemma totally_bounded_subset: "totally_bounded S \<Longrightarrow> T \<subseteq> S \<Longrightarrow> totally_bounded T"
   by (fastforce simp add: totally_bounded_def)
 
 lemma totally_bounded_Union[intro]:
   assumes M: "finite M" "\<And>S. S \<in> M \<Longrightarrow> totally_bounded S"
   shows "totally_bounded (\<Union>M)"
   unfolding totally_bounded_def
 proof safe
   fix E
   assume "eventually E uniformity"
   with M obtain X where "\<forall>S\<in>M. finite (X S) \<and> (\<forall>s\<in>S. \<exists>x\<in>X S. E (x, s))"
     by (metis totally_bounded_def)
   with \<open>finite M\<close> show "\<exists>X. finite X \<and> (\<forall>s\<in>\<Union>M. \<exists>x\<in>X. E (x, s))"
     by (intro exI[of _ "\<Union>S\<in>M. X S"]) force
 qed
 
 
 subsubsection \<open>Cauchy filter\<close>
 
 definition cauchy_filter :: "'a filter \<Rightarrow> bool"
   where "cauchy_filter F \<longleftrightarrow> F \<times>\<^sub>F F \<le> uniformity"
 
 definition Cauchy :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool"
   where Cauchy_uniform: "Cauchy X = cauchy_filter (filtermap X sequentially)"
 
 lemma Cauchy_uniform_iff:
   "Cauchy X \<longleftrightarrow> (\<forall>P. eventually P uniformity \<longrightarrow> (\<exists>N. \<forall>n\<ge>N. \<forall>m\<ge>N. P (X n, X m)))"
   unfolding Cauchy_uniform cauchy_filter_def le_filter_def eventually_prod_same
     eventually_filtermap eventually_sequentially
 proof safe
   let ?U = "\<lambda>P. eventually P uniformity"
   {
     fix P
     assume "?U P" "\<forall>P. ?U P \<longrightarrow> (\<exists>Q. (\<exists>N. \<forall>n\<ge>N. Q (X n)) \<and> (\<forall>x y. Q x \<longrightarrow> Q y \<longrightarrow> P (x, y)))"
     then obtain Q N where "\<And>n. n \<ge> N \<Longrightarrow> Q (X n)" "\<And>x y. Q x \<Longrightarrow> Q y \<Longrightarrow> P (x, y)"
       by metis
     then show "\<exists>N. \<forall>n\<ge>N. \<forall>m\<ge>N. P (X n, X m)"
       by blast
   next
     fix P
     assume "?U P" and P: "\<forall>P. ?U P \<longrightarrow> (\<exists>N. \<forall>n\<ge>N. \<forall>m\<ge>N. P (X n, X m))"
     then obtain Q where "?U Q" and Q: "\<And>x y z. Q (x, y) \<Longrightarrow> Q (y, z) \<Longrightarrow> P (x, z)"
       by (auto elim: uniformity_transE)
     then have "?U (\<lambda>x. Q x \<and> (\<lambda>(x, y). Q (y, x)) x)"
       unfolding eventually_conj_iff by (simp add: uniformity_sym)
     from P[rule_format, OF this]
     obtain N where N: "\<And>n m. n \<ge> N \<Longrightarrow> m \<ge> N \<Longrightarrow> Q (X n, X m) \<and> Q (X m, X n)"
       by auto
     show "\<exists>Q. (\<exists>N. \<forall>n\<ge>N. Q (X n)) \<and> (\<forall>x y. Q x \<longrightarrow> Q y \<longrightarrow> P (x, y))"
     proof (safe intro!: exI[of _ "\<lambda>x. \<forall>n\<ge>N. Q (x, X n) \<and> Q (X n, x)"] exI[of _ N] N)
       fix x y
       assume "\<forall>n\<ge>N. Q (x, X n) \<and> Q (X n, x)" "\<forall>n\<ge>N. Q (y, X n) \<and> Q (X n, y)"
       then have "Q (x, X N)" "Q (X N, y)" by auto
       then show "P (x, y)"
         by (rule Q)
     qed
   }
 qed
 
 lemma nhds_imp_cauchy_filter:
   assumes *: "F \<le> nhds x"
   shows "cauchy_filter F"
 proof -
   have "F \<times>\<^sub>F F \<le> nhds x \<times>\<^sub>F nhds x"
     by (intro prod_filter_mono *)
   also have "\<dots> \<le> uniformity"
     unfolding le_filter_def eventually_nhds_uniformity eventually_prod_same
   proof safe
     fix P
     assume "eventually P uniformity"
     then obtain Ql where ev: "eventually Ql uniformity"
       and "Ql (x, y) \<Longrightarrow> Ql (y, z) \<Longrightarrow> P (x, z)" for x y z
       by (rule uniformity_transE) simp
     with ev[THEN uniformity_sym]
     show "\<exists>Q. eventually (\<lambda>(x', y). x' = x \<longrightarrow> Q y) uniformity \<and>
         (\<forall>x y. Q x \<longrightarrow> Q y \<longrightarrow> P (x, y))"
       by (rule_tac exI[of _ "\<lambda>y. Ql (y, x) \<and> Ql (x, y)"]) (fastforce elim: eventually_elim2)
   qed
   finally show ?thesis
     by (simp add: cauchy_filter_def)
 qed
 
 lemma LIMSEQ_imp_Cauchy: "X \<longlonglongrightarrow> x \<Longrightarrow> Cauchy X"
   unfolding Cauchy_uniform filterlim_def by (intro nhds_imp_cauchy_filter)
 
 lemma Cauchy_subseq_Cauchy:
   assumes "Cauchy X" "strict_mono f"
   shows "Cauchy (X \<circ> f)"
   unfolding Cauchy_uniform comp_def filtermap_filtermap[symmetric] cauchy_filter_def
   by (rule order_trans[OF _ \<open>Cauchy X\<close>[unfolded Cauchy_uniform cauchy_filter_def]])
      (intro prod_filter_mono filtermap_mono filterlim_subseq[OF \<open>strict_mono f\<close>, unfolded filterlim_def])
 
 lemma convergent_Cauchy: "convergent X \<Longrightarrow> Cauchy X"
   unfolding convergent_def by (erule exE, erule LIMSEQ_imp_Cauchy)
 
 definition complete :: "'a set \<Rightarrow> bool"
   where complete_uniform: "complete S \<longleftrightarrow>
     (\<forall>F \<le> principal S. F \<noteq> bot \<longrightarrow> cauchy_filter F \<longrightarrow> (\<exists>x\<in>S. F \<le> nhds x))"
 
 end
 
 
 subsubsection \<open>Uniformly continuous functions\<close>
 
 definition uniformly_continuous_on :: "'a set \<Rightarrow> ('a::uniform_space \<Rightarrow> 'b::uniform_space) \<Rightarrow> bool"
   where uniformly_continuous_on_uniformity: "uniformly_continuous_on s f \<longleftrightarrow>
     (LIM (x, y) (uniformity_on s). (f x, f y) :> uniformity)"
 
 lemma uniformly_continuous_onD:
   "uniformly_continuous_on s f \<Longrightarrow> eventually E uniformity \<Longrightarrow>
     eventually (\<lambda>(x, y). x \<in> s \<longrightarrow> y \<in> s \<longrightarrow> E (f x, f y)) uniformity"
   by (simp add: uniformly_continuous_on_uniformity filterlim_iff
       eventually_inf_principal split_beta' mem_Times_iff imp_conjL)
 
 lemma uniformly_continuous_on_const[continuous_intros]: "uniformly_continuous_on s (\<lambda>x. c)"
   by (auto simp: uniformly_continuous_on_uniformity filterlim_iff uniformity_refl)
 
 lemma uniformly_continuous_on_id[continuous_intros]: "uniformly_continuous_on s (\<lambda>x. x)"
   by (auto simp: uniformly_continuous_on_uniformity filterlim_def)
 
 lemma uniformly_continuous_on_compose[continuous_intros]:
   "uniformly_continuous_on s g \<Longrightarrow> uniformly_continuous_on (g`s) f \<Longrightarrow>
     uniformly_continuous_on s (\<lambda>x. f (g x))"
   using filterlim_compose[of "\<lambda>(x, y). (f x, f y)" uniformity
       "uniformity_on (g`s)"  "\<lambda>(x, y). (g x, g y)" "uniformity_on s"]
   by (simp add: split_beta' uniformly_continuous_on_uniformity
       filterlim_inf filterlim_principal eventually_inf_principal mem_Times_iff)
 
 lemma uniformly_continuous_imp_continuous:
   assumes f: "uniformly_continuous_on s f"
   shows "continuous_on s f"
   by (auto simp: filterlim_iff eventually_at_filter eventually_nhds_uniformity continuous_on_def
            elim: eventually_mono dest!: uniformly_continuous_onD[OF f])
 
 
 section \<open>Product Topology\<close>
 
 subsection \<open>Product is a topological space\<close>
 
 instantiation prod :: (topological_space, topological_space) topological_space
 begin
 
 definition open_prod_def[code del]:
   "open (S :: ('a \<times> 'b) set) \<longleftrightarrow>
     (\<forall>x\<in>S. \<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S)"
 
 lemma open_prod_elim:
   assumes "open S" and "x \<in> S"
   obtains A B where "open A" and "open B" and "x \<in> A \<times> B" and "A \<times> B \<subseteq> S"
   using assms unfolding open_prod_def by fast
 
 lemma open_prod_intro:
   assumes "\<And>x. x \<in> S \<Longrightarrow> \<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S"
   shows "open S"
   using assms unfolding open_prod_def by fast
 
 instance
 proof
   show "open (UNIV :: ('a \<times> 'b) set)"
     unfolding open_prod_def by auto
 next
   fix S T :: "('a \<times> 'b) set"
   assume "open S" "open T"
   show "open (S \<inter> T)"
   proof (rule open_prod_intro)
     fix x
     assume x: "x \<in> S \<inter> T"
     from x have "x \<in> S" by simp
     obtain Sa Sb where A: "open Sa" "open Sb" "x \<in> Sa \<times> Sb" "Sa \<times> Sb \<subseteq> S"
       using \<open>open S\<close> and \<open>x \<in> S\<close> by (rule open_prod_elim)
     from x have "x \<in> T" by simp
     obtain Ta Tb where B: "open Ta" "open Tb" "x \<in> Ta \<times> Tb" "Ta \<times> Tb \<subseteq> T"
       using \<open>open T\<close> and \<open>x \<in> T\<close> by (rule open_prod_elim)
     let ?A = "Sa \<inter> Ta" and ?B = "Sb \<inter> Tb"
     have "open ?A \<and> open ?B \<and> x \<in> ?A \<times> ?B \<and> ?A \<times> ?B \<subseteq> S \<inter> T"
       using A B by (auto simp add: open_Int)
     then show "\<exists>A B. open A \<and> open B \<and> x \<in> A \<times> B \<and> A \<times> B \<subseteq> S \<inter> T"
       by fast
   qed
 next
   fix K :: "('a \<times> 'b) set set"
   assume "\<forall>S\<in>K. open S"
   then show "open (\<Union>K)"
     unfolding open_prod_def by fast
 qed
 
 end
 
 declare [[code abort: "open :: ('a::topological_space \<times> 'b::topological_space) set \<Rightarrow> bool"]]
 
 lemma open_Times: "open S \<Longrightarrow> open T \<Longrightarrow> open (S \<times> T)"
   unfolding open_prod_def by auto
 
 lemma fst_vimage_eq_Times: "fst -` S = S \<times> UNIV"
   by auto
 
 lemma snd_vimage_eq_Times: "snd -` S = UNIV \<times> S"
   by auto
 
 lemma open_vimage_fst: "open S \<Longrightarrow> open (fst -` S)"
   by (simp add: fst_vimage_eq_Times open_Times)
 
 lemma open_vimage_snd: "open S \<Longrightarrow> open (snd -` S)"
   by (simp add: snd_vimage_eq_Times open_Times)
 
 lemma closed_vimage_fst: "closed S \<Longrightarrow> closed (fst -` S)"
   unfolding closed_open vimage_Compl [symmetric]
   by (rule open_vimage_fst)
 
 lemma closed_vimage_snd: "closed S \<Longrightarrow> closed (snd -` S)"
   unfolding closed_open vimage_Compl [symmetric]
   by (rule open_vimage_snd)
 
 lemma closed_Times: "closed S \<Longrightarrow> closed T \<Longrightarrow> closed (S \<times> T)"
 proof -
   have "S \<times> T = (fst -` S) \<inter> (snd -` T)"
     by auto
   then show "closed S \<Longrightarrow> closed T \<Longrightarrow> closed (S \<times> T)"
     by (simp add: closed_vimage_fst closed_vimage_snd closed_Int)
 qed
 
 lemma subset_fst_imageI: "A \<times> B \<subseteq> S \<Longrightarrow> y \<in> B \<Longrightarrow> A \<subseteq> fst ` S"
   unfolding image_def subset_eq by force
 
 lemma subset_snd_imageI: "A \<times> B \<subseteq> S \<Longrightarrow> x \<in> A \<Longrightarrow> B \<subseteq> snd ` S"
   unfolding image_def subset_eq by force
 
 lemma open_image_fst:
   assumes "open S"
   shows "open (fst ` S)"
 proof (rule openI)
   fix x
   assume "x \<in> fst ` S"
   then obtain y where "(x, y) \<in> S"
     by auto
   then obtain A B where "open A" "open B" "x \<in> A" "y \<in> B" "A \<times> B \<subseteq> S"
     using \<open>open S\<close> unfolding open_prod_def by auto
   from \<open>A \<times> B \<subseteq> S\<close> \<open>y \<in> B\<close> have "A \<subseteq> fst ` S"
     by (rule subset_fst_imageI)
   with \<open>open A\<close> \<open>x \<in> A\<close> have "open A \<and> x \<in> A \<and> A \<subseteq> fst ` S"
     by simp
   then show "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> fst ` S" ..
 qed
 
 lemma open_image_snd:
   assumes "open S"
   shows "open (snd ` S)"
 proof (rule openI)
   fix y
   assume "y \<in> snd ` S"
   then obtain x where "(x, y) \<in> S"
     by auto
   then obtain A B where "open A" "open B" "x \<in> A" "y \<in> B" "A \<times> B \<subseteq> S"
     using \<open>open S\<close> unfolding open_prod_def by auto
   from \<open>A \<times> B \<subseteq> S\<close> \<open>x \<in> A\<close> have "B \<subseteq> snd ` S"
     by (rule subset_snd_imageI)
   with \<open>open B\<close> \<open>y \<in> B\<close> have "open B \<and> y \<in> B \<and> B \<subseteq> snd ` S"
     by simp
   then show "\<exists>T. open T \<and> y \<in> T \<and> T \<subseteq> snd ` S" ..
 qed
 
 lemma nhds_prod: "nhds (a, b) = nhds a \<times>\<^sub>F nhds b"
   unfolding nhds_def
 proof (subst prod_filter_INF, auto intro!: antisym INF_greatest simp: principal_prod_principal)
   fix S T
   assume "open S" "a \<in> S" "open T" "b \<in> T"
   then show "(INF x \<in> {S. open S \<and> (a, b) \<in> S}. principal x) \<le> principal (S \<times> T)"
     by (intro INF_lower) (auto intro!: open_Times)
 next
   fix S'
   assume "open S'" "(a, b) \<in> S'"
   then obtain S T where "open S" "a \<in> S" "open T" "b \<in> T" "S \<times> T \<subseteq> S'"
     by (auto elim: open_prod_elim)
   then show "(INF x \<in> {S. open S \<and> a \<in> S}. INF y \<in> {S. open S \<and> b \<in> S}.
       principal (x \<times> y)) \<le> principal S'"
     by (auto intro!: INF_lower2)
 qed
 
 
 subsubsection \<open>Continuity of operations\<close>
 
 lemma tendsto_fst [tendsto_intros]:
   assumes "(f \<longlongrightarrow> a) F"
   shows "((\<lambda>x. fst (f x)) \<longlongrightarrow> fst a) F"
 proof (rule topological_tendstoI)
   fix S
   assume "open S" and "fst a \<in> S"
   then have "open (fst -` S)" and "a \<in> fst -` S"
     by (simp_all add: open_vimage_fst)
   with assms have "eventually (\<lambda>x. f x \<in> fst -` S) F"
     by (rule topological_tendstoD)
   then show "eventually (\<lambda>x. fst (f x) \<in> S) F"
     by simp
 qed
 
 lemma tendsto_snd [tendsto_intros]:
   assumes "(f \<longlongrightarrow> a) F"
   shows "((\<lambda>x. snd (f x)) \<longlongrightarrow> snd a) F"
 proof (rule topological_tendstoI)
   fix S
   assume "open S" and "snd a \<in> S"
   then have "open (snd -` S)" and "a \<in> snd -` S"
     by (simp_all add: open_vimage_snd)
   with assms have "eventually (\<lambda>x. f x \<in> snd -` S) F"
     by (rule topological_tendstoD)
   then show "eventually (\<lambda>x. snd (f x) \<in> S) F"
     by simp
 qed
 
 lemma tendsto_Pair [tendsto_intros]:
   assumes "(f \<longlongrightarrow> a) F" and "(g \<longlongrightarrow> b) F"
   shows "((\<lambda>x. (f x, g x)) \<longlongrightarrow> (a, b)) F"
   unfolding nhds_prod using assms by (rule filterlim_Pair)
 
 lemma continuous_fst[continuous_intros]: "continuous F f \<Longrightarrow> continuous F (\<lambda>x. fst (f x))"
   unfolding continuous_def by (rule tendsto_fst)
 
 lemma continuous_snd[continuous_intros]: "continuous F f \<Longrightarrow> continuous F (\<lambda>x. snd (f x))"
   unfolding continuous_def by (rule tendsto_snd)
 
 lemma continuous_Pair[continuous_intros]:
   "continuous F f \<Longrightarrow> continuous F g \<Longrightarrow> continuous F (\<lambda>x. (f x, g x))"
   unfolding continuous_def by (rule tendsto_Pair)
 
 lemma continuous_on_fst[continuous_intros]:
   "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. fst (f x))"
   unfolding continuous_on_def by (auto intro: tendsto_fst)
 
 lemma continuous_on_snd[continuous_intros]:
   "continuous_on s f \<Longrightarrow> continuous_on s (\<lambda>x. snd (f x))"
   unfolding continuous_on_def by (auto intro: tendsto_snd)
 
 lemma continuous_on_Pair[continuous_intros]:
   "continuous_on s f \<Longrightarrow> continuous_on s g \<Longrightarrow> continuous_on s (\<lambda>x. (f x, g x))"
   unfolding continuous_on_def by (auto intro: tendsto_Pair)
 
 lemma continuous_on_swap[continuous_intros]: "continuous_on A prod.swap"
   by (simp add: prod.swap_def continuous_on_fst continuous_on_snd
       continuous_on_Pair continuous_on_id)
 
 lemma continuous_on_swap_args:
   assumes "continuous_on (A\<times>B) (\<lambda>(x,y). d x y)"
     shows "continuous_on (B\<times>A) (\<lambda>(x,y). d y x)"
 proof -
   have "(\<lambda>(x,y). d y x) = (\<lambda>(x,y). d x y) \<circ> prod.swap"
     by force
   then show ?thesis
     by (metis assms continuous_on_compose continuous_on_swap product_swap)
 qed
 
 lemma isCont_fst [simp]: "isCont f a \<Longrightarrow> isCont (\<lambda>x. fst (f x)) a"
   by (fact continuous_fst)
 
 lemma isCont_snd [simp]: "isCont f a \<Longrightarrow> isCont (\<lambda>x. snd (f x)) a"
   by (fact continuous_snd)
 
 lemma isCont_Pair [simp]: "\<lbrakk>isCont f a; isCont g a\<rbrakk> \<Longrightarrow> isCont (\<lambda>x. (f x, g x)) a"
   by (fact continuous_Pair)
 
 lemma continuous_on_compose_Pair:
   assumes f: "continuous_on (Sigma A B) (\<lambda>(a, b). f a b)"
   assumes g: "continuous_on C g"
   assumes h: "continuous_on C h"
   assumes subset: "\<And>c. c \<in> C \<Longrightarrow> g c \<in> A" "\<And>c. c \<in> C \<Longrightarrow> h c \<in> B (g c)"
   shows "continuous_on C (\<lambda>c. f (g c) (h c))"
   using continuous_on_compose2[OF f continuous_on_Pair[OF g h]] subset
   by auto
 
 
 subsubsection \<open>Connectedness of products\<close>
 
 proposition connected_Times:
   assumes S: "connected S" and T: "connected T"
   shows "connected (S \<times> T)"
 proof (rule connectedI_const)
   fix P::"'a \<times> 'b \<Rightarrow> bool"
   assume P[THEN continuous_on_compose2, continuous_intros]: "continuous_on (S \<times> T) P"
   have "continuous_on S (\<lambda>s. P (s, t))" if "t \<in> T" for t
     by (auto intro!: continuous_intros that)
   from connectedD_const[OF S this]
   obtain c1 where c1: "\<And>s t. t \<in> T \<Longrightarrow> s \<in> S \<Longrightarrow> P (s, t) = c1 t"
     by metis
   moreover
   have "continuous_on T (\<lambda>t. P (s, t))" if "s \<in> S" for s
     by (auto intro!: continuous_intros that)
   from connectedD_const[OF T this]
   obtain c2 where "\<And>s t. t \<in> T \<Longrightarrow> s \<in> S \<Longrightarrow> P (s, t) = c2 s"
     by metis
   ultimately show "\<exists>c. \<forall>s\<in>S \<times> T. P s = c"
     by auto
 qed
 
 corollary connected_Times_eq [simp]:
    "connected (S \<times> T) \<longleftrightarrow> S = {} \<or> T = {} \<or> connected S \<and> connected T"  (is "?lhs = ?rhs")
 proof
   assume L: ?lhs
   show ?rhs
   proof cases
     assume "S \<noteq> {} \<and> T \<noteq> {}"
     moreover
     have "connected (fst ` (S \<times> T))" "connected (snd ` (S \<times> T))"
       using continuous_on_fst continuous_on_snd continuous_on_id
       by (blast intro: connected_continuous_image [OF _ L])+
     ultimately show ?thesis
       by auto
   qed auto
 qed (auto simp: connected_Times)
 
 
 subsubsection \<open>Separation axioms\<close>
 
 instance prod :: (t0_space, t0_space) t0_space
 proof
   fix x y :: "'a \<times> 'b"
   assume "x \<noteq> y"
   then have "fst x \<noteq> fst y \<or> snd x \<noteq> snd y"
     by (simp add: prod_eq_iff)
   then show "\<exists>U. open U \<and> (x \<in> U) \<noteq> (y \<in> U)"
     by (fast dest: t0_space elim: open_vimage_fst open_vimage_snd)
 qed
 
 instance prod :: (t1_space, t1_space) t1_space
 proof
   fix x y :: "'a \<times> 'b"
   assume "x \<noteq> y"
   then have "fst x \<noteq> fst y \<or> snd x \<noteq> snd y"
     by (simp add: prod_eq_iff)
   then show "\<exists>U. open U \<and> x \<in> U \<and> y \<notin> U"
     by (fast dest: t1_space elim: open_vimage_fst open_vimage_snd)
 qed
 
 instance prod :: (t2_space, t2_space) t2_space
 proof
   fix x y :: "'a \<times> 'b"
   assume "x \<noteq> y"
   then have "fst x \<noteq> fst y \<or> snd x \<noteq> snd y"
     by (simp add: prod_eq_iff)
   then show "\<exists>U V. open U \<and> open V \<and> x \<in> U \<and> y \<in> V \<and> U \<inter> V = {}"
     by (fast dest: hausdorff elim: open_vimage_fst open_vimage_snd)
 qed
 
 lemma isCont_swap[continuous_intros]: "isCont prod.swap a"
   using continuous_on_eq_continuous_within continuous_on_swap by blast
 
 lemma open_diagonal_complement:
   "open {(x,y) |x y. x \<noteq> (y::('a::t2_space))}"
 proof -
   have "open {(x, y). x \<noteq> (y::'a)}"
     unfolding split_def by (intro open_Collect_neq continuous_intros)
   also have "{(x, y). x \<noteq> (y::'a)} = {(x, y) |x y. x \<noteq> (y::'a)}"
     by auto
   finally show ?thesis .
 qed
 
 lemma closed_diagonal:
   "closed {y. \<exists> x::('a::t2_space). y = (x,x)}"
 proof -
   have "{y. \<exists> x::'a. y = (x,x)} = UNIV - {(x,y) | x y. x \<noteq> y}" by auto
   then show ?thesis using open_diagonal_complement closed_Diff by auto
 qed
 
 lemma open_superdiagonal:
   "open {(x,y) | x y. x > (y::'a::{linorder_topology})}"
 proof -
   have "open {(x, y). x > (y::'a)}"
     unfolding split_def by (intro open_Collect_less continuous_intros)
   also have "{(x, y). x > (y::'a)} = {(x, y) |x y. x > (y::'a)}"
     by auto
   finally show ?thesis .
 qed
 
 lemma closed_subdiagonal:
   "closed {(x,y) | x y. x \<le> (y::'a::{linorder_topology})}"
 proof -
   have "{(x,y) | x y. x \<le> (y::'a)} = UNIV - {(x,y) | x y. x > (y::'a)}" by auto
   then show ?thesis using open_superdiagonal closed_Diff by auto
 qed
 
 lemma open_subdiagonal:
   "open {(x,y) | x y. x < (y::'a::{linorder_topology})}"
 proof -
   have "open {(x, y). x < (y::'a)}"
     unfolding split_def by (intro open_Collect_less continuous_intros)
   also have "{(x, y). x < (y::'a)} = {(x, y) |x y. x < (y::'a)}"
     by auto
   finally show ?thesis .
 qed
 
 lemma closed_superdiagonal:
   "closed {(x,y) | x y. x \<ge> (y::('a::{linorder_topology}))}"
 proof -
   have "{(x,y) | x y. x \<ge> (y::'a)} = UNIV - {(x,y) | x y. x < y}" by auto
   then show ?thesis using open_subdiagonal closed_Diff by auto
 qed
 
 
 end