diff --git a/src/HOL/BNF_Wellorder_Constructions.thy b/src/HOL/BNF_Wellorder_Constructions.thy
--- a/src/HOL/BNF_Wellorder_Constructions.thy
+++ b/src/HOL/BNF_Wellorder_Constructions.thy
@@ -1,1667 +1,1681 @@
 (*  Title:      HOL/BNF_Wellorder_Constructions.thy
     Author:     Andrei Popescu, TU Muenchen
     Copyright   2012
 
 Constructions on wellorders as needed by bounded natural functors.
 *)
 
 section \<open>Constructions on Wellorders as Needed by Bounded Natural Functors\<close>
 
 theory BNF_Wellorder_Constructions
 imports BNF_Wellorder_Embedding
 begin
 
 text \<open>In this section, we study basic constructions on well-orders, such as restriction to
 a set/order filter, copy via direct images, ordinal-like sum of disjoint well-orders,
 and bounded square.  We also define between well-orders
 the relations \<open>ordLeq\<close>, of being embedded (abbreviated \<open>\<le>o\<close>),
 \<open>ordLess\<close>, of being strictly embedded (abbreviated \<open><o\<close>), and
 \<open>ordIso\<close>, of being isomorphic (abbreviated \<open>=o\<close>).  We study the
 connections between these relations, order filters, and the aforementioned constructions.
 A main result of this section is that \<open><o\<close> is well-founded.\<close>
 
 
 subsection \<open>Restriction to a set\<close>
 
 abbreviation Restr :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a rel"
   where "Restr r A \<equiv> r Int (A \<times> A)"
 
 lemma Restr_subset:
   "A \<le> B \<Longrightarrow> Restr (Restr r B) A = Restr r A"
   by blast
 
 lemma Restr_Field: "Restr r (Field r) = r"
   unfolding Field_def by auto
 
 lemma Refl_Restr: "Refl r \<Longrightarrow> Refl(Restr r A)"
   unfolding refl_on_def Field_def by auto
 
 lemma linear_order_on_Restr:
   "linear_order_on A r \<Longrightarrow> linear_order_on (A \<inter> above r x) (Restr r (above r x))"
   by(simp add: order_on_defs refl_on_def trans_def antisym_def total_on_def)(safe; blast)
 
 lemma antisym_Restr:
   "antisym r \<Longrightarrow> antisym(Restr r A)"
   unfolding antisym_def Field_def by auto
 
 lemma Total_Restr:
   "Total r \<Longrightarrow> Total(Restr r A)"
   unfolding total_on_def Field_def by auto
 
 lemma total_on_imp_Total_Restr: "total_on A r \<Longrightarrow> Total (Restr r A)"
   by (auto simp: Field_def total_on_def)
 
 lemma trans_Restr:
   "trans r \<Longrightarrow> trans(Restr r A)"
   unfolding trans_def Field_def by blast
 
 lemma Preorder_Restr:
   "Preorder r \<Longrightarrow> Preorder(Restr r A)"
   unfolding preorder_on_def by (simp add: Refl_Restr trans_Restr)
 
 lemma Partial_order_Restr:
   "Partial_order r \<Longrightarrow> Partial_order(Restr r A)"
   unfolding partial_order_on_def by (simp add: Preorder_Restr antisym_Restr)
 
 lemma Linear_order_Restr:
   "Linear_order r \<Longrightarrow> Linear_order(Restr r A)"
   unfolding linear_order_on_def by (simp add: Partial_order_Restr Total_Restr)
 
 lemma Well_order_Restr:
   assumes "Well_order r"
   shows "Well_order(Restr r A)"
 proof-
   have "Restr r A - Id \<le> r - Id" using Restr_subset by blast
   hence "wf(Restr r A - Id)" using assms
     using well_order_on_def wf_subset by blast
   thus ?thesis using assms unfolding well_order_on_def
     by (simp add: Linear_order_Restr)
 qed
 
 lemma Field_Restr_subset: "Field(Restr r A) \<le> A"
   by (auto simp add: Field_def)
 
 lemma Refl_Field_Restr:
   "Refl r \<Longrightarrow> Field(Restr r A) = (Field r) Int A"
   unfolding refl_on_def Field_def by blast
 
 lemma Refl_Field_Restr2:
   "\<lbrakk>Refl r; A \<le> Field r\<rbrakk> \<Longrightarrow> Field(Restr r A) = A"
   by (auto simp add: Refl_Field_Restr)
 
 lemma well_order_on_Restr:
   assumes WELL: "Well_order r" and SUB: "A \<le> Field r"
   shows "well_order_on A (Restr r A)"
   using assms
   using Well_order_Restr[of r A] Refl_Field_Restr2[of r A]
     order_on_defs[of "Field r" r] by auto
 
 
 subsection \<open>Order filters versus restrictions and embeddings\<close>
 
 lemma Field_Restr_ofilter:
 "\<lbrakk>Well_order r; wo_rel.ofilter r A\<rbrakk> \<Longrightarrow> Field(Restr r A) = A"
 by (auto simp add: wo_rel_def wo_rel.ofilter_def wo_rel.REFL Refl_Field_Restr2)
 
 lemma ofilter_Restr_under:
 assumes WELL: "Well_order r" and OF: "wo_rel.ofilter r A" and IN: "a \<in> A"
 shows "under (Restr r A) a = under r a"
-using assms wo_rel_def
-proof(auto simp add: wo_rel.ofilter_def under_def)
-  fix b assume *: "a \<in> A" and "(b,a) \<in> r"
-  hence "b \<in> under r a \<and> a \<in> Field r"
-  unfolding under_def using Field_def by fastforce
-  thus "b \<in> A" using * assms by (auto simp add: wo_rel_def wo_rel.ofilter_def)
+  unfolding wo_rel.ofilter_def under_def
+proof
+  show "{b. (b, a) \<in> Restr r A} \<subseteq> {b. (b, a) \<in> r}"
+    by auto
+next
+  have "under r a \<subseteq> A"
+  proof
+    fix x
+    assume *: "x \<in> under r a"
+    then have "a \<in> Field r"
+      unfolding under_def using Field_def by fastforce
+    then show "x \<in> A" using IN assms *
+      by (auto simp add: wo_rel_def wo_rel.ofilter_def)
+  qed
+  then show "{b. (b, a) \<in> r} \<subseteq> {b. (b, a) \<in> Restr r A}"
+    unfolding under_def using assms by auto
 qed
 
 lemma ofilter_embed:
 assumes "Well_order r"
 shows "wo_rel.ofilter r A = (A \<le> Field r \<and> embed (Restr r A) r id)"
 proof
   assume *: "wo_rel.ofilter r A"
   show "A \<le> Field r \<and> embed (Restr r A) r id"
-  proof(unfold embed_def, auto)
+  unfolding embed_def
+  proof safe
     fix a assume "a \<in> A" thus "a \<in> Field r" using assms *
     by (auto simp add: wo_rel_def wo_rel.ofilter_def)
   next
     fix a assume "a \<in> Field (Restr r A)"
-    thus "bij_betw id (under (Restr r A) a) (under r a)" using assms *
+    thus "bij_betw id (under (Restr r A) a) (under r (id a))" using assms *
     by (simp add: ofilter_Restr_under Field_Restr_ofilter)
   qed
 next
   assume *: "A \<le> Field r \<and> embed (Restr r A) r id"
   hence "Field(Restr r A) \<le> Field r"
   using assms  embed_Field[of "Restr r A" r id] id_def
         Well_order_Restr[of r] by auto
   {fix a assume "a \<in> A"
    hence "a \<in> Field(Restr r A)" using * assms
    by (simp add: order_on_defs Refl_Field_Restr2)
    hence "bij_betw id (under (Restr r A) a) (under r a)"
    using * unfolding embed_def by auto
    hence "under r a \<le> under (Restr r A) a"
    unfolding bij_betw_def by auto
    also have "\<dots> \<le> Field(Restr r A)" by (simp add: under_Field)
    also have "\<dots> \<le> A" by (simp add: Field_Restr_subset)
    finally have "under r a \<le> A" .
   }
   thus "wo_rel.ofilter r A" using assms * by (simp add: wo_rel_def wo_rel.ofilter_def)
 qed
 
 lemma ofilter_Restr_Int:
 assumes WELL: "Well_order r" and OFA: "wo_rel.ofilter r A"
 shows "wo_rel.ofilter (Restr r B) (A Int B)"
 proof-
   let ?rB = "Restr r B"
   have Well: "wo_rel r" unfolding wo_rel_def using WELL .
   hence Refl: "Refl r" by (simp add: wo_rel.REFL)
   hence Field: "Field ?rB = Field r Int B"
   using Refl_Field_Restr by blast
   have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
   by (simp add: Well_order_Restr wo_rel_def)
   (* Main proof *)
   show ?thesis using WellB assms
-  proof(auto simp add: wo_rel.ofilter_def under_def)
+    unfolding wo_rel.ofilter_def under_def ofilter_def
+  proof safe
     fix a assume "a \<in> A" and *: "a \<in> B"
     hence "a \<in> Field r" using OFA Well by (auto simp add: wo_rel.ofilter_def)
     with * show "a \<in> Field ?rB" using Field by auto
   next
     fix a b assume "a \<in> A" and "(b,a) \<in> r"
     thus "b \<in> A" using Well OFA by (auto simp add: wo_rel.ofilter_def under_def)
   qed
 qed
 
 lemma ofilter_Restr_subset:
 assumes WELL: "Well_order r" and OFA: "wo_rel.ofilter r A" and SUB: "A \<le> B"
 shows "wo_rel.ofilter (Restr r B) A"
 proof-
   have "A Int B = A" using SUB by blast
   thus ?thesis using assms ofilter_Restr_Int[of r A B] by auto
 qed
 
 lemma ofilter_subset_embed:
 assumes WELL: "Well_order r" and
         OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
 shows "(A \<le> B) = (embed (Restr r A) (Restr r B) id)"
 proof-
   let ?rA = "Restr r A"  let ?rB = "Restr r B"
   have Well: "wo_rel r" unfolding wo_rel_def using WELL .
   hence Refl: "Refl r" by (simp add: wo_rel.REFL)
   hence FieldA: "Field ?rA = Field r Int A"
   using Refl_Field_Restr by blast
   have FieldB: "Field ?rB = Field r Int B"
   using Refl Refl_Field_Restr by blast
   have WellA: "wo_rel ?rA \<and> Well_order ?rA" using WELL
   by (simp add: Well_order_Restr wo_rel_def)
   have WellB: "wo_rel ?rB \<and> Well_order ?rB" using WELL
   by (simp add: Well_order_Restr wo_rel_def)
   (* Main proof *)
   show ?thesis
   proof
     assume *: "A \<le> B"
     hence "wo_rel.ofilter (Restr r B) A" using assms
     by (simp add: ofilter_Restr_subset)
     hence "embed (Restr ?rB A) (Restr r B) id"
     using WellB ofilter_embed[of "?rB" A] by auto
     thus "embed (Restr r A) (Restr r B) id"
     using * by (simp add: Restr_subset)
   next
     assume *: "embed (Restr r A) (Restr r B) id"
     {fix a assume **: "a \<in> A"
      hence "a \<in> Field r" using Well OFA by (auto simp add: wo_rel.ofilter_def)
      with ** FieldA have "a \<in> Field ?rA" by auto
      hence "a \<in> Field ?rB" using * WellA embed_Field[of ?rA ?rB id] by auto
      hence "a \<in> B" using FieldB by auto
     }
     thus "A \<le> B" by blast
   qed
 qed
 
 lemma ofilter_subset_embedS_iso:
 assumes WELL: "Well_order r" and
         OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
 shows "((A < B) = (embedS (Restr r A) (Restr r B) id)) \<and>
        ((A = B) = (iso (Restr r A) (Restr r B) id))"
 proof-
   let ?rA = "Restr r A"  let ?rB = "Restr r B"
   have Well: "wo_rel r" unfolding wo_rel_def using WELL .
   hence Refl: "Refl r" by (simp add: wo_rel.REFL)
   hence "Field ?rA = Field r Int A"
   using Refl_Field_Restr by blast
   hence FieldA: "Field ?rA = A" using OFA Well
   by (auto simp add: wo_rel.ofilter_def)
   have "Field ?rB = Field r Int B"
   using Refl Refl_Field_Restr by blast
   hence FieldB: "Field ?rB = B" using OFB Well
   by (auto simp add: wo_rel.ofilter_def)
   (* Main proof *)
   show ?thesis unfolding embedS_def iso_def
   using assms ofilter_subset_embed[of r A B]
         FieldA FieldB bij_betw_id_iff[of A B] by auto
 qed
 
 lemma ofilter_subset_embedS:
 assumes WELL: "Well_order r" and
         OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
 shows "(A < B) = embedS (Restr r A) (Restr r B) id"
 using assms by (simp add: ofilter_subset_embedS_iso)
 
 lemma embed_implies_iso_Restr:
 assumes WELL: "Well_order r" and WELL': "Well_order r'" and
         EMB: "embed r' r f"
 shows "iso r' (Restr r (f ` (Field r'))) f"
 proof-
   let ?A' = "Field r'"
   let ?r'' = "Restr r (f ` ?A')"
   have 0: "Well_order ?r''" using WELL Well_order_Restr by blast
   have 1: "wo_rel.ofilter r (f ` ?A')" using assms embed_Field_ofilter  by blast
   hence "Field ?r'' = f ` (Field r')" using WELL Field_Restr_ofilter by blast
   hence "bij_betw f ?A' (Field ?r'')"
   using EMB embed_inj_on WELL' unfolding bij_betw_def by blast
   moreover
   {have "\<forall>a b. (a,b) \<in> r' \<longrightarrow> a \<in> Field r' \<and> b \<in> Field r'"
    unfolding Field_def by auto
    hence "compat r' ?r'' f"
    using assms embed_iff_compat_inj_on_ofilter
    unfolding compat_def by blast
   }
   ultimately show ?thesis using WELL' 0 iso_iff3 by blast
 qed
 
 
 subsection \<open>The strict inclusion on proper ofilters is well-founded\<close>
 
 definition ofilterIncl :: "'a rel \<Rightarrow> 'a set rel"
 where
 "ofilterIncl r \<equiv> {(A,B). wo_rel.ofilter r A \<and> A \<noteq> Field r \<and>
                          wo_rel.ofilter r B \<and> B \<noteq> Field r \<and> A < B}"
 
 lemma wf_ofilterIncl:
 assumes WELL: "Well_order r"
 shows "wf(ofilterIncl r)"
 proof-
   have Well: "wo_rel r" using WELL by (simp add: wo_rel_def)
   hence Lo: "Linear_order r" by (simp add: wo_rel.LIN)
   let ?h = "(\<lambda> A. wo_rel.suc r A)"
   let ?rS = "r - Id"
   have "wf ?rS" using WELL by (simp add: order_on_defs)
   moreover
   have "compat (ofilterIncl r) ?rS ?h"
   proof(unfold compat_def ofilterIncl_def,
         intro allI impI, simp, elim conjE)
     fix A B
     assume *: "wo_rel.ofilter r A" "A \<noteq> Field r" and
            **: "wo_rel.ofilter r B" "B \<noteq> Field r" and ***: "A < B"
     then obtain a and b where 0: "a \<in> Field r \<and> b \<in> Field r" and
                          1: "A = underS r a \<and> B = underS r b"
     using Well by (auto simp add: wo_rel.ofilter_underS_Field)
     hence "a \<noteq> b" using *** by auto
     moreover
     have "(a,b) \<in> r" using 0 1 Lo ***
     by (auto simp add: underS_incl_iff)
     moreover
     have "a = wo_rel.suc r A \<and> b = wo_rel.suc r B"
     using Well 0 1 by (simp add: wo_rel.suc_underS)
     ultimately
     show "(wo_rel.suc r A, wo_rel.suc r B) \<in> r \<and> wo_rel.suc r A \<noteq> wo_rel.suc r B"
     by simp
   qed
   ultimately show "wf (ofilterIncl r)" by (simp add: compat_wf)
 qed
 
 
 subsection \<open>Ordering the well-orders by existence of embeddings\<close>
 
 text \<open>We define three relations between well-orders:
 \begin{itemize}
 \item \<open>ordLeq\<close>, of being embedded (abbreviated \<open>\<le>o\<close>);
 \item \<open>ordLess\<close>, of being strictly embedded (abbreviated \<open><o\<close>);
 \item \<open>ordIso\<close>, of being isomorphic (abbreviated \<open>=o\<close>).
 \end{itemize}
 %
 The prefix "ord" and the index "o" in these names stand for "ordinal-like".
 These relations shall be proved to be inter-connected in a similar fashion as the trio
 \<open>\<le>\<close>, \<open><\<close>, \<open>=\<close> associated to a total order on a set.
 \<close>
 
 definition ordLeq :: "('a rel * 'a' rel) set"
 where
 "ordLeq = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. embed r r' f)}"
 
 abbreviation ordLeq2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "<=o" 50)
 where "r <=o r' \<equiv> (r,r') \<in> ordLeq"
 
 abbreviation ordLeq3 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "\<le>o" 50)
 where "r \<le>o r' \<equiv> r <=o r'"
 
 definition ordLess :: "('a rel * 'a' rel) set"
 where
 "ordLess = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. embedS r r' f)}"
 
 abbreviation ordLess2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "<o" 50)
 where "r <o r' \<equiv> (r,r') \<in> ordLess"
 
 definition ordIso :: "('a rel * 'a' rel) set"
 where
 "ordIso = {(r,r'). Well_order r \<and> Well_order r' \<and> (\<exists>f. iso r r' f)}"
 
 abbreviation ordIso2 :: "'a rel \<Rightarrow> 'a' rel \<Rightarrow> bool" (infix "=o" 50)
 where "r =o r' \<equiv> (r,r') \<in> ordIso"
 
 lemmas ordRels_def = ordLeq_def ordLess_def ordIso_def
 
 lemma ordLeq_Well_order_simp:
 assumes "r \<le>o r'"
 shows "Well_order r \<and> Well_order r'"
 using assms unfolding ordLeq_def by simp
 
 text\<open>Notice that the relations \<open>\<le>o\<close>, \<open><o\<close>, \<open>=o\<close> connect well-orders
 on potentially {\em distinct} types. However, some of the lemmas below, including the next one,
 restrict implicitly the type of these relations to \<open>(('a rel) * ('a rel)) set\<close> , i.e.,
 to \<open>'a rel rel\<close>.\<close>
 
 lemma ordLeq_reflexive:
 "Well_order r \<Longrightarrow> r \<le>o r"
 unfolding ordLeq_def using id_embed[of r] by blast
 
 lemma ordLeq_transitive[trans]:
 assumes *: "r \<le>o r'" and **: "r' \<le>o r''"
 shows "r \<le>o r''"
 proof-
   obtain f and f'
   where 1: "Well_order r \<and> Well_order r' \<and> Well_order r''" and
         "embed r r' f" and "embed r' r'' f'"
   using * ** unfolding ordLeq_def by blast
   hence "embed r r'' (f' \<circ> f)"
   using comp_embed[of r r' f r'' f'] by auto
   thus "r \<le>o r''" unfolding ordLeq_def using 1 by auto
 qed
 
 lemma ordLeq_total:
 "\<lbrakk>Well_order r; Well_order r'\<rbrakk> \<Longrightarrow> r \<le>o r' \<or> r' \<le>o r"
 unfolding ordLeq_def using wellorders_totally_ordered by blast
 
 lemma ordIso_reflexive:
 "Well_order r \<Longrightarrow> r =o r"
 unfolding ordIso_def using id_iso[of r] by blast
 
 lemma ordIso_transitive[trans]:
 assumes *: "r =o r'" and **: "r' =o r''"
 shows "r =o r''"
 proof-
   obtain f and f'
   where 1: "Well_order r \<and> Well_order r' \<and> Well_order r''" and
         "iso r r' f" and 3: "iso r' r'' f'"
   using * ** unfolding ordIso_def by auto
   hence "iso r r'' (f' \<circ> f)"
   using comp_iso[of r r' f r'' f'] by auto
   thus "r =o r''" unfolding ordIso_def using 1 by auto
 qed
 
 lemma ordIso_symmetric:
 assumes *: "r =o r'"
 shows "r' =o r"
 proof-
   obtain f where 1: "Well_order r \<and> Well_order r'" and
                  2: "embed r r' f \<and> bij_betw f (Field r) (Field r')"
   using * by (auto simp add: ordIso_def iso_def)
   let ?f' = "inv_into (Field r) f"
   have "embed r' r ?f' \<and> bij_betw ?f' (Field r') (Field r)"
   using 1 2 by (simp add: bij_betw_inv_into inv_into_Field_embed_bij_betw)
   thus "r' =o r" unfolding ordIso_def using 1 by (auto simp add: iso_def)
 qed
 
 lemma ordLeq_ordLess_trans[trans]:
 assumes "r \<le>o r'" and " r' <o r''"
 shows "r <o r''"
 proof-
   have "Well_order r \<and> Well_order r''"
   using assms unfolding ordLeq_def ordLess_def by auto
   thus ?thesis using assms unfolding ordLeq_def ordLess_def
   using embed_comp_embedS by blast
 qed
 
 lemma ordLess_ordLeq_trans[trans]:
 assumes "r <o r'" and " r' \<le>o r''"
 shows "r <o r''"
 proof-
   have "Well_order r \<and> Well_order r''"
   using assms unfolding ordLeq_def ordLess_def by auto
   thus ?thesis using assms unfolding ordLeq_def ordLess_def
   using embedS_comp_embed by blast
 qed
 
 lemma ordLeq_ordIso_trans[trans]:
 assumes "r \<le>o r'" and " r' =o r''"
 shows "r \<le>o r''"
 proof-
   have "Well_order r \<and> Well_order r''"
   using assms unfolding ordLeq_def ordIso_def by auto
   thus ?thesis using assms unfolding ordLeq_def ordIso_def
   using embed_comp_iso by blast
 qed
 
 lemma ordIso_ordLeq_trans[trans]:
 assumes "r =o r'" and " r' \<le>o r''"
 shows "r \<le>o r''"
 proof-
   have "Well_order r \<and> Well_order r''"
   using assms unfolding ordLeq_def ordIso_def by auto
   thus ?thesis using assms unfolding ordLeq_def ordIso_def
   using iso_comp_embed by blast
 qed
 
 lemma ordLess_ordIso_trans[trans]:
 assumes "r <o r'" and " r' =o r''"
 shows "r <o r''"
 proof-
   have "Well_order r \<and> Well_order r''"
   using assms unfolding ordLess_def ordIso_def by auto
   thus ?thesis using assms unfolding ordLess_def ordIso_def
   using embedS_comp_iso by blast
 qed
 
 lemma ordIso_ordLess_trans[trans]:
 assumes "r =o r'" and " r' <o r''"
 shows "r <o r''"
 proof-
   have "Well_order r \<and> Well_order r''"
   using assms unfolding ordLess_def ordIso_def by auto
   thus ?thesis using assms unfolding ordLess_def ordIso_def
   using iso_comp_embedS by blast
 qed
 
 lemma ordLess_not_embed:
 assumes "r <o r'"
 shows "\<not>(\<exists>f'. embed r' r f')"
 proof-
   obtain f where 1: "Well_order r \<and> Well_order r'" and 2: "embed r r' f" and
                  3: " \<not> bij_betw f (Field r) (Field r')"
   using assms unfolding ordLess_def by (auto simp add: embedS_def)
   {fix f' assume *: "embed r' r f'"
    hence "bij_betw f (Field r) (Field r')" using 1 2
    by (simp add: embed_bothWays_Field_bij_betw)
    with 3 have False by contradiction
   }
   thus ?thesis by blast
 qed
 
 lemma ordLess_Field:
 assumes OL: "r1 <o r2" and EMB: "embed r1 r2 f"
 shows "\<not> (f`(Field r1) = Field r2)"
 proof-
   let ?A1 = "Field r1"  let ?A2 = "Field r2"
   obtain g where
   0: "Well_order r1 \<and> Well_order r2" and
   1: "embed r1 r2 g \<and> \<not>(bij_betw g ?A1 ?A2)"
   using OL unfolding ordLess_def by (auto simp add: embedS_def)
   hence "\<forall>a \<in> ?A1. f a = g a"
   using 0 EMB embed_unique[of r1] by auto
   hence "\<not>(bij_betw f ?A1 ?A2)"
   using 1 bij_betw_cong[of ?A1] by blast
   moreover
   have "inj_on f ?A1" using EMB 0 by (simp add: embed_inj_on)
   ultimately show ?thesis by (simp add: bij_betw_def)
 qed
 
 lemma ordLess_iff:
 "r <o r' = (Well_order r \<and> Well_order r' \<and> \<not>(\<exists>f'. embed r' r f'))"
 proof
   assume *: "r <o r'"
   hence "\<not>(\<exists>f'. embed r' r f')" using ordLess_not_embed[of r r'] by simp
   with * show "Well_order r \<and> Well_order r' \<and> \<not> (\<exists>f'. embed r' r f')"
   unfolding ordLess_def by auto
 next
   assume *: "Well_order r \<and> Well_order r' \<and> \<not> (\<exists>f'. embed r' r f')"
   then obtain f where 1: "embed r r' f"
   using wellorders_totally_ordered[of r r'] by blast
   moreover
   {assume "bij_betw f (Field r) (Field r')"
    with * 1 have "embed r' r (inv_into (Field r) f) "
    using inv_into_Field_embed_bij_betw[of r r' f] by auto
    with * have False by blast
   }
   ultimately show "(r,r') \<in> ordLess"
   unfolding ordLess_def using * by (fastforce simp add: embedS_def)
 qed
 
 lemma ordLess_irreflexive: "\<not> r <o r"
 proof
   assume "r <o r"
   hence "Well_order r \<and>  \<not>(\<exists>f. embed r r f)"
   unfolding ordLess_iff ..
   moreover have "embed r r id" using id_embed[of r] .
   ultimately show False by blast
 qed
 
 lemma ordLeq_iff_ordLess_or_ordIso:
 "r \<le>o r' = (r <o r' \<or> r =o r')"
 unfolding ordRels_def embedS_defs iso_defs by blast
 
 lemma ordIso_iff_ordLeq:
 "(r =o r') = (r \<le>o r' \<and> r' \<le>o r)"
 proof
   assume "r =o r'"
   then obtain f where 1: "Well_order r \<and> Well_order r' \<and>
                      embed r r' f \<and> bij_betw f (Field r) (Field r')"
   unfolding ordIso_def iso_defs by auto
   hence "embed r r' f \<and> embed r' r (inv_into (Field r) f)"
   by (simp add: inv_into_Field_embed_bij_betw)
   thus  "r \<le>o r' \<and> r' \<le>o r"
   unfolding ordLeq_def using 1 by auto
 next
   assume "r \<le>o r' \<and> r' \<le>o r"
   then obtain f and g where 1: "Well_order r \<and> Well_order r' \<and>
                            embed r r' f \<and> embed r' r g"
   unfolding ordLeq_def by auto
   hence "iso r r' f" by (auto simp add: embed_bothWays_iso)
   thus "r =o r'" unfolding ordIso_def using 1 by auto
 qed
 
 lemma not_ordLess_ordLeq:
 "r <o r' \<Longrightarrow> \<not> r' \<le>o r"
 using ordLess_ordLeq_trans ordLess_irreflexive by blast
 
 lemma not_ordLeq_ordLess:
 "r \<le>o r' \<Longrightarrow> \<not> r' <o r"
 using not_ordLess_ordLeq by blast
 
 lemma ordLess_or_ordLeq:
 assumes WELL: "Well_order r" and WELL': "Well_order r'"
 shows "r <o r' \<or> r' \<le>o r"
 proof-
   have "r \<le>o r' \<or> r' \<le>o r"
   using assms by (simp add: ordLeq_total)
   moreover
   {assume "\<not> r <o r' \<and> r \<le>o r'"
    hence "r =o r'" using ordLeq_iff_ordLess_or_ordIso by blast
    hence "r' \<le>o r" using ordIso_symmetric ordIso_iff_ordLeq by blast
   }
   ultimately show ?thesis by blast
 qed
 
 lemma not_ordLess_ordIso:
 "r <o r' \<Longrightarrow> \<not> r =o r'"
 using ordLess_ordIso_trans ordIso_symmetric ordLess_irreflexive by blast
 
 lemma not_ordLeq_iff_ordLess:
 assumes WELL: "Well_order r" and WELL': "Well_order r'"
 shows "(\<not> r' \<le>o r) = (r <o r')"
 using assms not_ordLess_ordLeq ordLess_or_ordLeq by blast
 
 lemma not_ordLess_iff_ordLeq:
 assumes WELL: "Well_order r" and WELL': "Well_order r'"
 shows "(\<not> r' <o r) = (r \<le>o r')"
 using assms not_ordLess_ordLeq ordLess_or_ordLeq by blast
 
 lemma ordLess_transitive[trans]:
 "\<lbrakk>r <o r'; r' <o r''\<rbrakk> \<Longrightarrow> r <o r''"
 using ordLess_ordLeq_trans ordLeq_iff_ordLess_or_ordIso by blast
 
 corollary ordLess_trans: "trans ordLess"
 unfolding trans_def using ordLess_transitive by blast
 
 lemmas ordIso_equivalence = ordIso_transitive ordIso_reflexive ordIso_symmetric
 
 lemma ordIso_imp_ordLeq:
 "r =o r' \<Longrightarrow> r \<le>o r'"
 using ordIso_iff_ordLeq by blast
 
 lemma ordLess_imp_ordLeq:
 "r <o r' \<Longrightarrow> r \<le>o r'"
 using ordLeq_iff_ordLess_or_ordIso by blast
 
 lemma ofilter_subset_ordLeq:
 assumes WELL: "Well_order r" and
         OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
 shows "(A \<le> B) = (Restr r A \<le>o Restr r B)"
 proof
   assume "A \<le> B"
   thus "Restr r A \<le>o Restr r B"
   unfolding ordLeq_def using assms
   Well_order_Restr Well_order_Restr ofilter_subset_embed by blast
 next
   assume *: "Restr r A \<le>o Restr r B"
   then obtain f where "embed (Restr r A) (Restr r B) f"
   unfolding ordLeq_def by blast
   {assume "B < A"
    hence "Restr r B <o Restr r A"
    unfolding ordLess_def using assms
    Well_order_Restr Well_order_Restr ofilter_subset_embedS by blast
    hence False using * not_ordLess_ordLeq by blast
   }
   thus "A \<le> B" using OFA OFB WELL
   wo_rel_def[of r] wo_rel.ofilter_linord[of r A B] by blast
 qed
 
 lemma ofilter_subset_ordLess:
 assumes WELL: "Well_order r" and
         OFA: "wo_rel.ofilter r A" and OFB: "wo_rel.ofilter r B"
 shows "(A < B) = (Restr r A <o Restr r B)"
 proof-
   let ?rA = "Restr r A" let ?rB = "Restr r B"
   have 1: "Well_order ?rA \<and> Well_order ?rB"
   using WELL Well_order_Restr by blast
   have "(A < B) = (\<not> B \<le> A)" using assms
   wo_rel_def wo_rel.ofilter_linord[of r A B] by blast
   also have "\<dots> = (\<not> Restr r B \<le>o Restr r A)"
   using assms ofilter_subset_ordLeq by blast
   also have "\<dots> = (Restr r A <o Restr r B)"
   using 1 not_ordLeq_iff_ordLess by blast
   finally show ?thesis .
 qed
 
 lemma ofilter_ordLess:
 "\<lbrakk>Well_order r; wo_rel.ofilter r A\<rbrakk> \<Longrightarrow> (A < Field r) = (Restr r A <o r)"
 by (simp add: ofilter_subset_ordLess wo_rel.Field_ofilter
     wo_rel_def Restr_Field)
 
 corollary underS_Restr_ordLess:
 assumes "Well_order r" and "Field r \<noteq> {}"
 shows "Restr r (underS r a) <o r"
 proof-
   have "underS r a < Field r" using assms
   by (simp add: underS_Field3)
   thus ?thesis using assms
   by (simp add: ofilter_ordLess wo_rel.underS_ofilter wo_rel_def)
 qed
 
 lemma embed_ordLess_ofilterIncl:
 assumes
   OL12: "r1 <o r2" and OL23: "r2 <o r3" and
   EMB13: "embed r1 r3 f13" and EMB23: "embed r2 r3 f23"
 shows "(f13`(Field r1), f23`(Field r2)) \<in> (ofilterIncl r3)"
 proof-
   have OL13: "r1 <o r3"
   using OL12 OL23 using ordLess_transitive by auto
   let ?A1 = "Field r1"  let ?A2 ="Field r2" let ?A3 ="Field r3"
   obtain f12 g23 where
   0: "Well_order r1 \<and> Well_order r2 \<and> Well_order r3" and
   1: "embed r1 r2 f12 \<and> \<not>(bij_betw f12 ?A1 ?A2)" and
   2: "embed r2 r3 g23 \<and> \<not>(bij_betw g23 ?A2 ?A3)"
   using OL12 OL23 by (auto simp add: ordLess_def embedS_def)
   hence "\<forall>a \<in> ?A2. f23 a = g23 a"
   using EMB23 embed_unique[of r2 r3] by blast
   hence 3: "\<not>(bij_betw f23 ?A2 ?A3)"
   using 2 bij_betw_cong[of ?A2 f23 g23] by blast
   (*  *)
   have 4: "wo_rel.ofilter r2 (f12 ` ?A1) \<and> f12 ` ?A1 \<noteq> ?A2"
   using 0 1 OL12 by (simp add: embed_Field_ofilter ordLess_Field)
   have 5: "wo_rel.ofilter r3 (f23 ` ?A2) \<and> f23 ` ?A2 \<noteq> ?A3"
   using 0 EMB23 OL23 by (simp add: embed_Field_ofilter ordLess_Field)
   have 6: "wo_rel.ofilter r3 (f13 ` ?A1)  \<and> f13 ` ?A1 \<noteq> ?A3"
   using 0 EMB13 OL13 by (simp add: embed_Field_ofilter ordLess_Field)
   (*  *)
   have "f12 ` ?A1 < ?A2"
   using 0 4 by (auto simp add: wo_rel_def wo_rel.ofilter_def)
   moreover have "inj_on f23 ?A2"
   using EMB23 0 by (simp add: wo_rel_def embed_inj_on)
   ultimately
   have "f23 ` (f12 ` ?A1) < f23 ` ?A2" by (simp add: inj_on_strict_subset)
   moreover
   {have "embed r1 r3 (f23 \<circ> f12)"
    using 1 EMB23 0 by (auto simp add: comp_embed)
    hence "\<forall>a \<in> ?A1. f23(f12 a) = f13 a"
    using EMB13 0 embed_unique[of r1 r3 "f23 \<circ> f12" f13] by auto
    hence "f23 ` (f12 ` ?A1) = f13 ` ?A1" by force
   }
   ultimately
   have "f13 ` ?A1 < f23 ` ?A2" by simp
   (*  *)
   with 5 6 show ?thesis
   unfolding ofilterIncl_def by auto
 qed
 
 lemma ordLess_iff_ordIso_Restr:
 assumes WELL: "Well_order r" and WELL': "Well_order r'"
 shows "(r' <o r) = (\<exists>a \<in> Field r. r' =o Restr r (underS r a))"
-proof(auto)
+proof safe
   fix a assume *: "a \<in> Field r" and **: "r' =o Restr r (underS r a)"
   hence "Restr r (underS r a) <o r" using WELL underS_Restr_ordLess[of r] by blast
   thus "r' <o r" using ** ordIso_ordLess_trans by blast
 next
   assume "r' <o r"
   then obtain f where 1: "Well_order r \<and> Well_order r'" and
                       2: "embed r' r f \<and> f ` (Field r') \<noteq> Field r"
   unfolding ordLess_def embedS_def[abs_def] bij_betw_def using embed_inj_on by blast
   hence "wo_rel.ofilter r (f ` (Field r'))" using embed_Field_ofilter by blast
   then obtain a where 3: "a \<in> Field r" and 4: "underS r a = f ` (Field r')"
   using 1 2 by (auto simp add: wo_rel.ofilter_underS_Field wo_rel_def)
   have "iso r' (Restr r (f ` (Field r'))) f"
   using embed_implies_iso_Restr 2 assms by blast
   moreover have "Well_order (Restr r (f ` (Field r')))"
   using WELL Well_order_Restr by blast
   ultimately have "r' =o Restr r (f ` (Field r'))"
   using WELL' unfolding ordIso_def by auto
   hence "r' =o Restr r (underS r a)" using 4 by auto
   thus "\<exists>a \<in> Field r. r' =o Restr r (underS r a)" using 3 by auto
 qed
 
 lemma internalize_ordLess:
 "(r' <o r) = (\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r)"
 proof
   assume *: "r' <o r"
   hence 0: "Well_order r \<and> Well_order r'" unfolding ordLess_def by auto
   with * obtain a where 1: "a \<in> Field r" and 2: "r' =o Restr r (underS r a)"
   using ordLess_iff_ordIso_Restr by blast
   let ?p = "Restr r (underS r a)"
   have "wo_rel.ofilter r (underS r a)" using 0
   by (simp add: wo_rel_def wo_rel.underS_ofilter)
   hence "Field ?p = underS r a" using 0 Field_Restr_ofilter by blast
   hence "Field ?p < Field r" using underS_Field2 1 by fast
   moreover have "?p <o r" using underS_Restr_ordLess[of r a] 0 1 by blast
   ultimately
   show "\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r" using 2 by blast
 next
   assume "\<exists>p. Field p < Field r \<and> r' =o p \<and> p <o r"
   thus "r' <o r" using ordIso_ordLess_trans by blast
 qed
 
 lemma internalize_ordLeq:
 "(r' \<le>o r) = (\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r)"
 proof
   assume *: "r' \<le>o r"
   moreover
   {assume "r' <o r"
    then obtain p where "Field p < Field r \<and> r' =o p \<and> p <o r"
    using internalize_ordLess[of r' r] by blast
    hence "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
    using ordLeq_iff_ordLess_or_ordIso by blast
   }
   moreover
   have "r \<le>o r" using * ordLeq_def ordLeq_reflexive by blast
   ultimately show "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
   using ordLeq_iff_ordLess_or_ordIso by blast
 next
   assume "\<exists>p. Field p \<le> Field r \<and> r' =o p \<and> p \<le>o r"
   thus "r' \<le>o r" using ordIso_ordLeq_trans by blast
 qed
 
 lemma ordLeq_iff_ordLess_Restr:
 assumes WELL: "Well_order r" and WELL': "Well_order r'"
 shows "(r \<le>o r') = (\<forall>a \<in> Field r. Restr r (underS r a) <o r')"
-proof(auto)
+proof safe
   assume *: "r \<le>o r'"
   fix a assume "a \<in> Field r"
   hence "Restr r (underS r a) <o r"
   using WELL underS_Restr_ordLess[of r] by blast
   thus "Restr r (underS r a) <o r'"
   using * ordLess_ordLeq_trans by blast
 next
   assume *: "\<forall>a \<in> Field r. Restr r (underS r a) <o r'"
   {assume "r' <o r"
    then obtain a where "a \<in> Field r \<and> r' =o Restr r (underS r a)"
    using assms ordLess_iff_ordIso_Restr by blast
    hence False using * not_ordLess_ordIso ordIso_symmetric by blast
   }
   thus "r \<le>o r'" using ordLess_or_ordLeq assms by blast
 qed
 
 lemma finite_ordLess_infinite:
 assumes WELL: "Well_order r" and WELL': "Well_order r'" and
         FIN: "finite(Field r)" and INF: "\<not>finite(Field r')"
 shows "r <o r'"
 proof-
   {assume "r' \<le>o r"
    then obtain h where "inj_on h (Field r') \<and> h ` (Field r') \<le> Field r"
    unfolding ordLeq_def using assms embed_inj_on embed_Field by blast
    hence False using finite_imageD finite_subset FIN INF by blast
   }
   thus ?thesis using WELL WELL' ordLess_or_ordLeq by blast
 qed
 
 lemma finite_well_order_on_ordIso:
 assumes FIN: "finite A" and
         WELL: "well_order_on A r" and WELL': "well_order_on A r'"
 shows "r =o r'"
 proof-
   have 0: "Well_order r \<and> Well_order r' \<and> Field r = A \<and> Field r' = A"
   using assms well_order_on_Well_order by blast
   moreover
   have "\<forall>r r'. well_order_on A r \<and> well_order_on A r' \<and> r \<le>o r'
                   \<longrightarrow> r =o r'"
   proof(clarify)
     fix r r' assume *: "well_order_on A r" and **: "well_order_on A r'"
     have 2: "Well_order r \<and> Well_order r' \<and> Field r = A \<and> Field r' = A"
     using * ** well_order_on_Well_order by blast
     assume "r \<le>o r'"
     then obtain f where 1: "embed r r' f" and
                         "inj_on f A \<and> f ` A \<le> A"
     unfolding ordLeq_def using 2 embed_inj_on embed_Field by blast
     hence "bij_betw f A A" unfolding bij_betw_def using FIN endo_inj_surj by blast
     thus "r =o r'" unfolding ordIso_def iso_def[abs_def] using 1 2 by auto
   qed
   ultimately show ?thesis using assms ordLeq_total ordIso_symmetric by blast
 qed
 
 subsection\<open>\<open><o\<close> is well-founded\<close>
 
 text \<open>Of course, it only makes sense to state that the \<open><o\<close> is well-founded
 on the restricted type \<open>'a rel rel\<close>.  We prove this by first showing that, for any set
 of well-orders all embedded in a fixed well-order, the function mapping each well-order
 in the set to an order filter of the fixed well-order is compatible w.r.t. to \<open><o\<close> versus
 {\em strict inclusion}; and we already know that strict inclusion of order filters is well-founded.\<close>
 
 definition ord_to_filter :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a set"
 where "ord_to_filter r0 r \<equiv> (SOME f. embed r r0 f) ` (Field r)"
 
 lemma ord_to_filter_compat:
 "compat (ordLess Int (ordLess\<inverse>``{r0} \<times> ordLess\<inverse>``{r0}))
         (ofilterIncl r0)
         (ord_to_filter r0)"
 proof(unfold compat_def ord_to_filter_def, clarify)
   fix r1::"'a rel" and r2::"'a rel"
   let ?A1 = "Field r1"  let ?A2 ="Field r2" let ?A0 ="Field r0"
   let ?phi10 = "\<lambda> f10. embed r1 r0 f10" let ?f10 = "SOME f. ?phi10 f"
   let ?phi20 = "\<lambda> f20. embed r2 r0 f20" let ?f20 = "SOME f. ?phi20 f"
   assume *: "r1 <o r0" "r2 <o r0" and **: "r1 <o r2"
   hence "(\<exists>f. ?phi10 f) \<and> (\<exists>f. ?phi20 f)"
   by (auto simp add: ordLess_def embedS_def)
   hence "?phi10 ?f10 \<and> ?phi20 ?f20" by (auto simp add: someI_ex)
   thus "(?f10 ` ?A1, ?f20 ` ?A2) \<in> ofilterIncl r0"
   using * ** by (simp add: embed_ordLess_ofilterIncl)
 qed
 
 theorem wf_ordLess: "wf ordLess"
 proof-
   {fix r0 :: "('a \<times> 'a) set"
    (* need to annotate here!*)
    let ?ordLess = "ordLess::('d rel * 'd rel) set"
    let ?R = "?ordLess Int (?ordLess\<inverse>``{r0} \<times> ?ordLess\<inverse>``{r0})"
    {assume Case1: "Well_order r0"
     hence "wf ?R"
     using wf_ofilterIncl[of r0]
           compat_wf[of ?R "ofilterIncl r0" "ord_to_filter r0"]
           ord_to_filter_compat[of r0] by auto
    }
    moreover
    {assume Case2: "\<not> Well_order r0"
     hence "?R = {}" unfolding ordLess_def by auto
     hence "wf ?R" using wf_empty by simp
    }
    ultimately have "wf ?R" by blast
   }
   thus ?thesis by (simp add: trans_wf_iff ordLess_trans)
 qed
 
 corollary exists_minim_Well_order:
 assumes NE: "R \<noteq> {}" and WELL: "\<forall>r \<in> R. Well_order r"
 shows "\<exists>r \<in> R. \<forall>r' \<in> R. r \<le>o r'"
 proof-
   obtain r where "r \<in> R \<and> (\<forall>r' \<in> R. \<not> r' <o r)"
   using NE spec[OF spec[OF subst[OF wf_eq_minimal, of "%x. x", OF wf_ordLess]], of _ R]
     equals0I[of R] by blast
   with not_ordLeq_iff_ordLess WELL show ?thesis by blast
 qed
 
 
 subsection \<open>Copy via direct images\<close>
 
 text\<open>The direct image operator is the dual of the inverse image operator \<open>inv_image\<close>
 from \<open>Relation.thy\<close>.  It is useful for transporting a well-order between
 different types.\<close>
 
 definition dir_image :: "'a rel \<Rightarrow> ('a \<Rightarrow> 'a') \<Rightarrow> 'a' rel"
 where
 "dir_image r f = {(f a, f b)| a b. (a,b) \<in> r}"
 
 lemma dir_image_Field:
 "Field(dir_image r f) = f ` (Field r)"
 unfolding dir_image_def Field_def Range_def Domain_def by fast
 
 lemma dir_image_minus_Id:
 "inj_on f (Field r) \<Longrightarrow> (dir_image r f) - Id = dir_image (r - Id) f"
 unfolding inj_on_def Field_def dir_image_def by auto
 
 lemma Refl_dir_image:
 assumes "Refl r"
 shows "Refl(dir_image r f)"
 proof-
   {fix a' b'
    assume "(a',b') \<in> dir_image r f"
    then obtain a b where 1: "a' = f a \<and> b' = f b \<and> (a,b) \<in> r"
    unfolding dir_image_def by blast
    hence "a \<in> Field r \<and> b \<in> Field r" using Field_def by fastforce
    hence "(a,a) \<in> r \<and> (b,b) \<in> r" using assms by (simp add: refl_on_def)
    with 1 have "(a',a') \<in> dir_image r f \<and> (b',b') \<in> dir_image r f"
    unfolding dir_image_def by auto
   }
   thus ?thesis
   by(unfold refl_on_def Field_def Domain_def Range_def, auto)
 qed
 
 lemma trans_dir_image:
 assumes TRANS: "trans r" and INJ: "inj_on f (Field r)"
 shows "trans(dir_image r f)"
-proof(unfold trans_def, auto)
+unfolding trans_def
+proof safe
   fix a' b' c'
   assume "(a',b') \<in> dir_image r f" "(b',c') \<in> dir_image r f"
   then obtain a b1 b2 c where 1: "a' = f a \<and> b' = f b1 \<and> b' = f b2 \<and> c' = f c" and
                          2: "(a,b1) \<in> r \<and> (b2,c) \<in> r"
   unfolding dir_image_def by blast
   hence "b1 \<in> Field r \<and> b2 \<in> Field r"
   unfolding Field_def by auto
   hence "b1 = b2" using 1 INJ unfolding inj_on_def by auto
   hence "(a,c) \<in> r" using 2 TRANS unfolding trans_def by blast
   thus "(a',c') \<in> dir_image r f"
   unfolding dir_image_def using 1 by auto
 qed
 
 lemma Preorder_dir_image:
 "\<lbrakk>Preorder r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Preorder (dir_image r f)"
 by (simp add: preorder_on_def Refl_dir_image trans_dir_image)
 
 lemma antisym_dir_image:
 assumes AN: "antisym r" and INJ: "inj_on f (Field r)"
 shows "antisym(dir_image r f)"
-proof(unfold antisym_def, auto)
+unfolding antisym_def
+proof safe
   fix a' b'
   assume "(a',b') \<in> dir_image r f" "(b',a') \<in> dir_image r f"
   then obtain a1 b1 a2 b2 where 1: "a' = f a1 \<and> a' = f a2 \<and> b' = f b1 \<and> b' = f b2" and
                            2: "(a1,b1) \<in> r \<and> (b2,a2) \<in> r " and
                            3: "{a1,a2,b1,b2} \<le> Field r"
   unfolding dir_image_def Field_def by blast
   hence "a1 = a2 \<and> b1 = b2" using INJ unfolding inj_on_def by auto
   hence "a1 = b2" using 2 AN unfolding antisym_def by auto
   thus "a' = b'" using 1 by auto
 qed
 
 lemma Partial_order_dir_image:
 "\<lbrakk>Partial_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Partial_order (dir_image r f)"
 by (simp add: partial_order_on_def Preorder_dir_image antisym_dir_image)
 
 lemma Total_dir_image:
 assumes TOT: "Total r" and INJ: "inj_on f (Field r)"
 shows "Total(dir_image r f)"
 proof(unfold total_on_def, intro ballI impI)
   fix a' b'
   assume "a' \<in> Field (dir_image r f)" "b' \<in> Field (dir_image r f)"
   then obtain a and b where 1: "a \<in> Field r \<and> b \<in> Field r \<and> f a = a' \<and> f b = b'"
     unfolding dir_image_Field[of r f] by blast
   moreover assume "a' \<noteq> b'"
   ultimately have "a \<noteq> b" using INJ unfolding inj_on_def by auto
   hence "(a,b) \<in> r \<or> (b,a) \<in> r" using 1 TOT unfolding total_on_def by auto
   thus "(a',b') \<in> dir_image r f \<or> (b',a') \<in> dir_image r f"
   using 1 unfolding dir_image_def by auto
 qed
 
 lemma Linear_order_dir_image:
 "\<lbrakk>Linear_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Linear_order (dir_image r f)"
 by (simp add: linear_order_on_def Partial_order_dir_image Total_dir_image)
 
 lemma wf_dir_image:
 assumes WF: "wf r" and INJ: "inj_on f (Field r)"
 shows "wf(dir_image r f)"
 proof(unfold wf_eq_minimal2, intro allI impI, elim conjE)
   fix A'::"'b set"
   assume SUB: "A' \<le> Field(dir_image r f)" and NE: "A' \<noteq> {}"
   obtain A where A_def: "A = {a \<in> Field r. f a \<in> A'}" by blast
   have "A \<noteq> {} \<and> A \<le> Field r" using A_def SUB NE by (auto simp: dir_image_Field)
   then obtain a where 1: "a \<in> A \<and> (\<forall>b \<in> A. (b,a) \<notin> r)"
   using spec[OF WF[unfolded wf_eq_minimal2], of A] by blast
   have "\<forall>b' \<in> A'. (b',f a) \<notin> dir_image r f"
   proof(clarify)
     fix b' assume *: "b' \<in> A'" and **: "(b',f a) \<in> dir_image r f"
     obtain b1 a1 where 2: "b' = f b1 \<and> f a = f a1" and
                        3: "(b1,a1) \<in> r \<and> {a1,b1} \<le> Field r"
     using ** unfolding dir_image_def Field_def by blast
     hence "a = a1" using 1 A_def INJ unfolding inj_on_def by auto
     hence "b1 \<in> A \<and> (b1,a) \<in> r" using 2 3 A_def * by auto
     with 1 show False by auto
   qed
   thus "\<exists>a'\<in>A'. \<forall>b'\<in>A'. (b', a') \<notin> dir_image r f"
   using A_def 1 by blast
 qed
 
 lemma Well_order_dir_image:
 "\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk> \<Longrightarrow> Well_order (dir_image r f)"
 unfolding well_order_on_def
 using Linear_order_dir_image[of r f] wf_dir_image[of "r - Id" f]
   dir_image_minus_Id[of f r]
   subset_inj_on[of f "Field r" "Field(r - Id)"]
   mono_Field[of "r - Id" r] by auto
 
 lemma dir_image_bij_betw:
 "\<lbrakk>inj_on f (Field r)\<rbrakk> \<Longrightarrow> bij_betw f (Field r) (Field (dir_image r f))"
 unfolding bij_betw_def by (simp add: dir_image_Field order_on_defs)
 
 lemma dir_image_compat:
 "compat r (dir_image r f) f"
 unfolding compat_def dir_image_def by auto
 
 lemma dir_image_iso:
 "\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk>  \<Longrightarrow> iso r (dir_image r f) f"
 using iso_iff3 dir_image_compat dir_image_bij_betw Well_order_dir_image by blast
 
 lemma dir_image_ordIso:
 "\<lbrakk>Well_order r; inj_on f (Field r)\<rbrakk>  \<Longrightarrow> r =o dir_image r f"
 unfolding ordIso_def using dir_image_iso Well_order_dir_image by blast
 
 lemma Well_order_iso_copy:
 assumes WELL: "well_order_on A r" and BIJ: "bij_betw f A A'"
 shows "\<exists>r'. well_order_on A' r' \<and> r =o r'"
 proof-
    let ?r' = "dir_image r f"
    have 1: "A = Field r \<and> Well_order r"
    using WELL well_order_on_Well_order by blast
    hence 2: "iso r ?r' f"
    using dir_image_iso using BIJ unfolding bij_betw_def by auto
    hence "f ` (Field r) = Field ?r'" using 1 iso_iff[of r ?r'] by blast
    hence "Field ?r' = A'"
    using 1 BIJ unfolding bij_betw_def by auto
    moreover have "Well_order ?r'"
    using 1 Well_order_dir_image BIJ unfolding bij_betw_def by blast
    ultimately show ?thesis unfolding ordIso_def using 1 2 by blast
 qed
 
 
 subsection \<open>Bounded square\<close>
 
 text\<open>This construction essentially defines, for an order relation \<open>r\<close>, a lexicographic
 order \<open>bsqr r\<close> on \<open>(Field r) \<times> (Field r)\<close>, applying the
 following criteria (in this order):
 \begin{itemize}
 \item compare the maximums;
 \item compare the first components;
 \item compare the second components.
 \end{itemize}
 %
 The only application of this construction that we are aware of is
 at proving that the square of an infinite set has the same cardinal
 as that set. The essential property required there (and which is ensured by this
 construction) is that any proper order filter of the product order is included in a rectangle, i.e.,
 in a product of proper filters on the original relation (assumed to be a well-order).\<close>
 
 definition bsqr :: "'a rel => ('a * 'a)rel"
 where
 "bsqr r = {((a1,a2),(b1,b2)).
            {a1,a2,b1,b2} \<le> Field r \<and>
            (a1 = b1 \<and> a2 = b2 \<or>
             (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
             wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
             wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1  \<and> (a2,b2) \<in> r - Id
            )}"
 
 lemma Field_bsqr:
 "Field (bsqr r) = Field r \<times> Field r"
 proof
   show "Field (bsqr r) \<le> Field r \<times> Field r"
   proof-
     {fix a1 a2 assume "(a1,a2) \<in> Field (bsqr r)"
      moreover
      have "\<And> b1 b2. ((a1,a2),(b1,b2)) \<in> bsqr r \<or> ((b1,b2),(a1,a2)) \<in> bsqr r \<Longrightarrow>
                       a1 \<in> Field r \<and> a2 \<in> Field r" unfolding bsqr_def by auto
      ultimately have "a1 \<in> Field r \<and> a2 \<in> Field r" unfolding Field_def by auto
     }
     thus ?thesis unfolding Field_def by force
   qed
 next
   show "Field r \<times> Field r \<le> Field (bsqr r)"
-  proof(auto)
+  proof safe
     fix a1 a2 assume "a1 \<in> Field r" and "a2 \<in> Field r"
     hence "((a1,a2),(a1,a2)) \<in> bsqr r" unfolding bsqr_def by blast
     thus "(a1,a2) \<in> Field (bsqr r)" unfolding Field_def by auto
   qed
 qed
 
 lemma bsqr_Refl: "Refl(bsqr r)"
 by(unfold refl_on_def Field_bsqr, auto simp add: bsqr_def)
 
 lemma bsqr_Trans:
 assumes "Well_order r"
 shows "trans (bsqr r)"
-proof(unfold trans_def, auto)
+unfolding trans_def
+proof safe
   (* Preliminary facts *)
   have Well: "wo_rel r" using assms wo_rel_def by auto
   hence Trans: "trans r" using wo_rel.TRANS by auto
   have Anti: "antisym r" using wo_rel.ANTISYM Well by auto
   hence TransS: "trans(r - Id)" using Trans by (simp add: trans_diff_Id)
   (* Main proof *)
   fix a1 a2 b1 b2 c1 c2
   assume *: "((a1,a2),(b1,b2)) \<in> bsqr r" and **: "((b1,b2),(c1,c2)) \<in> bsqr r"
   hence 0: "{a1,a2,b1,b2,c1,c2} \<le> Field r" unfolding bsqr_def by auto
   have 1: "a1 = b1 \<and> a2 = b2 \<or> (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
            wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
            wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
   using * unfolding bsqr_def by auto
   have 2: "b1 = c1 \<and> b2 = c2 \<or> (wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id \<or>
            wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id \<or>
            wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1 \<and> (b2,c2) \<in> r - Id"
   using ** unfolding bsqr_def by auto
   show "((a1,a2),(c1,c2)) \<in> bsqr r"
   proof-
     {assume Case1: "a1 = b1 \<and> a2 = b2"
      hence ?thesis using ** by simp
     }
     moreover
     {assume Case2: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id"
      {assume Case21: "b1 = c1 \<and> b2 = c2"
       hence ?thesis using * by simp
      }
      moreover
      {assume Case22: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
       hence "(wo_rel.max2 r a1 a2, wo_rel.max2 r c1 c2) \<in> r - Id"
       using Case2 TransS trans_def[of "r - Id"] by blast
       hence ?thesis using 0 unfolding bsqr_def by auto
      }
      moreover
      {assume Case23_4: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2"
       hence ?thesis using Case2 0 unfolding bsqr_def by auto
      }
      ultimately have ?thesis using 0 2 by auto
     }
     moreover
     {assume Case3: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id"
      {assume Case31: "b1 = c1 \<and> b2 = c2"
       hence ?thesis using * by simp
      }
      moreover
      {assume Case32: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
       hence ?thesis using Case3 0 unfolding bsqr_def by auto
      }
      moreover
      {assume Case33: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id"
       hence "(a1,c1) \<in> r - Id"
       using Case3 TransS trans_def[of "r - Id"] by blast
       hence ?thesis using Case3 Case33 0 unfolding bsqr_def by auto
      }
      moreover
      {assume Case33: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1"
       hence ?thesis using Case3 0 unfolding bsqr_def by auto
      }
      ultimately have ?thesis using 0 2 by auto
     }
     moreover
     {assume Case4: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
      {assume Case41: "b1 = c1 \<and> b2 = c2"
       hence ?thesis using * by simp
      }
      moreover
      {assume Case42: "(wo_rel.max2 r b1 b2, wo_rel.max2 r c1 c2) \<in> r - Id"
       hence ?thesis using Case4 0 unfolding bsqr_def by force
      }
      moreover
      {assume Case43: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> (b1,c1) \<in> r - Id"
       hence ?thesis using Case4 0 unfolding bsqr_def by auto
      }
      moreover
      {assume Case44: "wo_rel.max2 r b1 b2 = wo_rel.max2 r c1 c2 \<and> b1 = c1 \<and> (b2,c2) \<in> r - Id"
       hence "(a2,c2) \<in> r - Id"
       using Case4 TransS trans_def[of "r - Id"] by blast
       hence ?thesis using Case4 Case44 0 unfolding bsqr_def by auto
      }
      ultimately have ?thesis using 0 2 by auto
     }
     ultimately show ?thesis using 0 1 by auto
   qed
 qed
 
 lemma bsqr_antisym:
 assumes "Well_order r"
 shows "antisym (bsqr r)"
 proof(unfold antisym_def, clarify)
   (* Preliminary facts *)
   have Well: "wo_rel r" using assms wo_rel_def by auto
   hence Trans: "trans r" using wo_rel.TRANS by auto
   have Anti: "antisym r" using wo_rel.ANTISYM Well by auto
   hence TransS: "trans(r - Id)" using Trans by (simp add: trans_diff_Id)
   hence IrrS: "\<forall>a b. \<not>((a,b) \<in> r - Id \<and> (b,a) \<in> r - Id)"
   using Anti trans_def[of "r - Id"] antisym_def[of "r - Id"] by blast
   (* Main proof *)
   fix a1 a2 b1 b2
   assume *: "((a1,a2),(b1,b2)) \<in> bsqr r" and **: "((b1,b2),(a1,a2)) \<in> bsqr r"
   hence 0: "{a1,a2,b1,b2} \<le> Field r" unfolding bsqr_def by auto
   have 1: "a1 = b1 \<and> a2 = b2 \<or> (wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id \<or>
            wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id \<or>
            wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
   using * unfolding bsqr_def by auto
   have 2: "b1 = a1 \<and> b2 = a2 \<or> (wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id \<or>
            wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2 \<and> (b1,a1) \<in> r - Id \<or>
            wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2 \<and> b1 = a1 \<and> (b2,a2) \<in> r - Id"
   using ** unfolding bsqr_def by auto
   show "a1 = b1 \<and> a2 = b2"
   proof-
     {assume Case1: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r - Id"
      {assume Case11: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
       hence False using Case1 IrrS by blast
      }
      moreover
      {assume Case12_3: "wo_rel.max2 r b1 b2 = wo_rel.max2 r a1 a2"
       hence False using Case1 by auto
      }
      ultimately have ?thesis using 0 2 by auto
     }
     moreover
     {assume Case2: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> (a1,b1) \<in> r - Id"
      {assume Case21: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
        hence False using Case2 by auto
      }
      moreover
      {assume Case22: "(b1,a1) \<in> r - Id"
       hence False using Case2 IrrS by blast
      }
      moreover
      {assume Case23: "b1 = a1"
       hence False using Case2 by auto
      }
      ultimately have ?thesis using 0 2 by auto
     }
     moreover
     {assume Case3: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2 \<and> a1 = b1 \<and> (a2,b2) \<in> r - Id"
      moreover
      {assume Case31: "(wo_rel.max2 r b1 b2, wo_rel.max2 r a1 a2) \<in> r - Id"
       hence False using Case3 by auto
      }
      moreover
      {assume Case32: "(b1,a1) \<in> r - Id"
       hence False using Case3 by auto
      }
      moreover
      {assume Case33: "(b2,a2) \<in> r - Id"
       hence False using Case3 IrrS by blast
      }
      ultimately have ?thesis using 0 2 by auto
     }
     ultimately show ?thesis using 0 1 by blast
   qed
 qed
 
 lemma bsqr_Total:
 assumes "Well_order r"
 shows "Total(bsqr r)"
 proof-
   (* Preliminary facts *)
   have Well: "wo_rel r" using assms wo_rel_def by auto
   hence Total: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
   using wo_rel.TOTALS by auto
   (* Main proof *)
   {fix a1 a2 b1 b2 assume "{(a1,a2), (b1,b2)} \<le> Field(bsqr r)"
    hence 0: "a1 \<in> Field r \<and> a2 \<in> Field r \<and> b1 \<in> Field r \<and> b2 \<in> Field r"
    using Field_bsqr by blast
    have "((a1,a2) = (b1,b2) \<or> ((a1,a2),(b1,b2)) \<in> bsqr r \<or> ((b1,b2),(a1,a2)) \<in> bsqr r)"
    proof(rule wo_rel.cases_Total[of r a1 a2], clarsimp simp add: Well, simp add: 0)
        (* Why didn't clarsimp simp add: Well 0 do the same job? *)
      assume Case1: "(a1,a2) \<in> r"
      hence 1: "wo_rel.max2 r a1 a2 = a2"
      using Well 0 by (simp add: wo_rel.max2_equals2)
      show ?thesis
      proof(rule wo_rel.cases_Total[of r b1 b2], clarsimp simp add: Well, simp add: 0)
        assume Case11: "(b1,b2) \<in> r"
        hence 2: "wo_rel.max2 r b1 b2 = b2"
        using Well 0 by (simp add: wo_rel.max2_equals2)
        show ?thesis
        proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
          assume Case111: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
          thus ?thesis using 0 1 2 unfolding bsqr_def by auto
        next
          assume Case112: "a2 = b2"
          show ?thesis
          proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
            assume Case1121: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
            thus ?thesis using 0 1 2 Case112 unfolding bsqr_def by auto
          next
            assume Case1122: "a1 = b1"
            thus ?thesis using Case112 by auto
          qed
        qed
      next
        assume Case12: "(b2,b1) \<in> r"
        hence 3: "wo_rel.max2 r b1 b2 = b1" using Well 0 by (simp add: wo_rel.max2_equals1)
        show ?thesis
        proof(rule wo_rel.cases_Total3[of r a2 b1], clarsimp simp add: Well, simp add: 0)
          assume Case121: "(a2,b1) \<in> r - Id \<or> (b1,a2) \<in> r - Id"
          thus ?thesis using 0 1 3 unfolding bsqr_def by auto
        next
          assume Case122: "a2 = b1"
          show ?thesis
          proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
            assume Case1221: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
            thus ?thesis using 0 1 3 Case122 unfolding bsqr_def by auto
          next
            assume Case1222: "a1 = b1"
            show ?thesis
            proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
              assume Case12221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
              thus ?thesis using 0 1 3 Case122 Case1222 unfolding bsqr_def by auto
            next
              assume Case12222: "a2 = b2"
              thus ?thesis using Case122 Case1222 by auto
            qed
          qed
        qed
      qed
    next
      assume Case2: "(a2,a1) \<in> r"
      hence 1: "wo_rel.max2 r a1 a2 = a1" using Well 0 by (simp add: wo_rel.max2_equals1)
      show ?thesis
      proof(rule wo_rel.cases_Total[of r b1 b2], clarsimp simp add: Well, simp add: 0)
        assume Case21: "(b1,b2) \<in> r"
        hence 2: "wo_rel.max2 r b1 b2 = b2" using Well 0 by (simp add: wo_rel.max2_equals2)
        show ?thesis
        proof(rule wo_rel.cases_Total3[of r a1 b2], clarsimp simp add: Well, simp add: 0)
          assume Case211: "(a1,b2) \<in> r - Id \<or> (b2,a1) \<in> r - Id"
          thus ?thesis using 0 1 2 unfolding bsqr_def by auto
        next
          assume Case212: "a1 = b2"
          show ?thesis
          proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
            assume Case2121: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
            thus ?thesis using 0 1 2 Case212 unfolding bsqr_def by auto
          next
            assume Case2122: "a1 = b1"
            show ?thesis
            proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
              assume Case21221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
              thus ?thesis using 0 1 2 Case212 Case2122 unfolding bsqr_def by auto
            next
              assume Case21222: "a2 = b2"
              thus ?thesis using Case2122 Case212 by auto
            qed
          qed
        qed
      next
        assume Case22: "(b2,b1) \<in> r"
        hence 3: "wo_rel.max2 r b1 b2 = b1"  using Well 0 by (simp add: wo_rel.max2_equals1)
        show ?thesis
        proof(rule wo_rel.cases_Total3[of r a1 b1], clarsimp simp add: Well, simp add: 0)
          assume Case221: "(a1,b1) \<in> r - Id \<or> (b1,a1) \<in> r - Id"
          thus ?thesis using 0 1 3 unfolding bsqr_def by auto
        next
          assume Case222: "a1 = b1"
          show ?thesis
          proof(rule wo_rel.cases_Total3[of r a2 b2], clarsimp simp add: Well, simp add: 0)
            assume Case2221: "(a2,b2) \<in> r - Id \<or> (b2,a2) \<in> r - Id"
            thus ?thesis using 0 1 3 Case222 unfolding bsqr_def by auto
          next
            assume Case2222: "a2 = b2"
            thus ?thesis using Case222 by auto
          qed
        qed
      qed
    qed
   }
   thus ?thesis unfolding total_on_def by fast
 qed
 
 lemma bsqr_Linear_order:
 assumes "Well_order r"
 shows "Linear_order(bsqr r)"
 unfolding order_on_defs
 using assms bsqr_Refl bsqr_Trans bsqr_antisym bsqr_Total by blast
 
 lemma bsqr_Well_order:
 assumes "Well_order r"
 shows "Well_order(bsqr r)"
 using assms
 proof(simp add: bsqr_Linear_order Linear_order_Well_order_iff, intro allI impI)
   have 0: "\<forall>A \<le> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r)"
   using assms well_order_on_def Linear_order_Well_order_iff by blast
   fix D assume *: "D \<le> Field (bsqr r)" and **: "D \<noteq> {}"
   hence 1: "D \<le> Field r \<times> Field r" unfolding Field_bsqr by simp
   (*  *)
   obtain M where M_def: "M = {wo_rel.max2 r a1 a2| a1 a2. (a1,a2) \<in> D}" by blast
   have "M \<noteq> {}" using 1 M_def ** by auto
   moreover
   have "M \<le> Field r" unfolding M_def
   using 1 assms wo_rel_def[of r] wo_rel.max2_among[of r] by fastforce
   ultimately obtain m where m_min: "m \<in> M \<and> (\<forall>a \<in> M. (m,a) \<in> r)"
   using 0 by blast
   (*  *)
   obtain A1 where A1_def: "A1 = {a1. \<exists>a2. (a1,a2) \<in> D \<and> wo_rel.max2 r a1 a2 = m}" by blast
   have "A1 \<le> Field r" unfolding A1_def using 1 by auto
   moreover have "A1 \<noteq> {}" unfolding A1_def using m_min unfolding M_def by blast
   ultimately obtain a1 where a1_min: "a1 \<in> A1 \<and> (\<forall>a \<in> A1. (a1,a) \<in> r)"
   using 0 by blast
   (*  *)
   obtain A2 where A2_def: "A2 = {a2. (a1,a2) \<in> D \<and> wo_rel.max2 r a1 a2 = m}" by blast
   have "A2 \<le> Field r" unfolding A2_def using 1 by auto
   moreover have "A2 \<noteq> {}" unfolding A2_def
   using m_min a1_min unfolding A1_def M_def by blast
   ultimately obtain a2 where a2_min: "a2 \<in> A2 \<and> (\<forall>a \<in> A2. (a2,a) \<in> r)"
   using 0 by blast
   (*   *)
   have 2: "wo_rel.max2 r a1 a2 = m"
   using a1_min a2_min unfolding A1_def A2_def by auto
   have 3: "(a1,a2) \<in> D" using a2_min unfolding A2_def by auto
   (*  *)
   moreover
   {fix b1 b2 assume ***: "(b1,b2) \<in> D"
    hence 4: "{a1,a2,b1,b2} \<le> Field r" using 1 3 by blast
    have 5: "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r"
    using *** a1_min a2_min m_min unfolding A1_def A2_def M_def by auto
    have "((a1,a2),(b1,b2)) \<in> bsqr r"
    proof(cases "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2")
      assume Case1: "wo_rel.max2 r a1 a2 \<noteq> wo_rel.max2 r b1 b2"
      thus ?thesis unfolding bsqr_def using 4 5 by auto
    next
      assume Case2: "wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2"
      hence "b1 \<in> A1" unfolding A1_def using 2 *** by auto
      hence 6: "(a1,b1) \<in> r" using a1_min by auto
      show ?thesis
      proof(cases "a1 = b1")
        assume Case21: "a1 \<noteq> b1"
        thus ?thesis unfolding bsqr_def using 4 Case2 6 by auto
      next
        assume Case22: "a1 = b1"
        hence "b2 \<in> A2" unfolding A2_def using 2 *** Case2 by auto
        hence 7: "(a2,b2) \<in> r" using a2_min by auto
        thus ?thesis unfolding bsqr_def using 4 7 Case2 Case22 by auto
      qed
    qed
   }
   (*  *)
   ultimately show "\<exists>d \<in> D. \<forall>d' \<in> D. (d,d') \<in> bsqr r" by fastforce
 qed
 
 lemma bsqr_max2:
 assumes WELL: "Well_order r" and LEQ: "((a1,a2),(b1,b2)) \<in> bsqr r"
 shows "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r"
 proof-
   have "{(a1,a2),(b1,b2)} \<le> Field(bsqr r)"
   using LEQ unfolding Field_def by auto
   hence "{a1,a2,b1,b2} \<le> Field r" unfolding Field_bsqr by auto
   hence "{wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2} \<le> Field r"
   using WELL wo_rel_def[of r] wo_rel.max2_among[of r] by fastforce
   moreover have "(wo_rel.max2 r a1 a2, wo_rel.max2 r b1 b2) \<in> r \<or> wo_rel.max2 r a1 a2 = wo_rel.max2 r b1 b2"
   using LEQ unfolding bsqr_def by auto
   ultimately show ?thesis using WELL unfolding order_on_defs refl_on_def by auto
 qed
 
 lemma bsqr_ofilter:
 assumes WELL: "Well_order r" and
         OF: "wo_rel.ofilter (bsqr r) D" and SUB: "D < Field r \<times> Field r" and
         NE: "\<not> (\<exists>a. Field r = under r a)"
 shows "\<exists>A. wo_rel.ofilter r A \<and> A < Field r \<and> D \<le> A \<times> A"
 proof-
   let ?r' = "bsqr r"
   have Well: "wo_rel r" using WELL wo_rel_def by blast
   hence Trans: "trans r" using wo_rel.TRANS by blast
   have Well': "Well_order ?r' \<and> wo_rel ?r'"
   using WELL bsqr_Well_order wo_rel_def by blast
   (*  *)
   have "D < Field ?r'" unfolding Field_bsqr using SUB .
   with OF obtain a1 and a2 where
   "(a1,a2) \<in> Field ?r'" and 1: "D = underS ?r' (a1,a2)"
   using Well' wo_rel.ofilter_underS_Field[of ?r' D] by auto
   hence 2: "{a1,a2} \<le> Field r" unfolding Field_bsqr by auto
   let ?m = "wo_rel.max2 r a1 a2"
   have "D \<le> (under r ?m) \<times> (under r ?m)"
   proof(unfold 1)
     {fix b1 b2
      let ?n = "wo_rel.max2 r b1 b2"
      assume "(b1,b2) \<in> underS ?r' (a1,a2)"
      hence 3: "((b1,b2),(a1,a2)) \<in> ?r'"
      unfolding underS_def by blast
      hence "(?n,?m) \<in> r" using WELL by (simp add: bsqr_max2)
      moreover
      {have "(b1,b2) \<in> Field ?r'" using 3 unfolding Field_def by auto
       hence "{b1,b2} \<le> Field r" unfolding Field_bsqr by auto
       hence "(b1,?n) \<in> r \<and> (b2,?n) \<in> r"
       using Well by (simp add: wo_rel.max2_greater)
      }
      ultimately have "(b1,?m) \<in> r \<and> (b2,?m) \<in> r"
      using Trans trans_def[of r] by blast
      hence "(b1,b2) \<in> (under r ?m) \<times> (under r ?m)" unfolding under_def by simp}
      thus "underS ?r' (a1,a2) \<le> (under r ?m) \<times> (under r ?m)" by auto
   qed
   moreover have "wo_rel.ofilter r (under r ?m)"
   using Well by (simp add: wo_rel.under_ofilter)
   moreover have "under r ?m < Field r"
   using NE under_Field[of r ?m] by blast
   ultimately show ?thesis by blast
 qed
 
 definition Func where
 "Func A B = {f . (\<forall> a \<in> A. f a \<in> B) \<and> (\<forall> a. a \<notin> A \<longrightarrow> f a = undefined)}"
 
 lemma Func_empty:
 "Func {} B = {\<lambda>x. undefined}"
 unfolding Func_def by auto
 
 lemma Func_elim:
 assumes "g \<in> Func A B" and "a \<in> A"
 shows "\<exists> b. b \<in> B \<and> g a = b"
 using assms unfolding Func_def by (cases "g a = undefined") auto
 
 definition curr where
 "curr A f \<equiv> \<lambda> a. if a \<in> A then \<lambda>b. f (a,b) else undefined"
 
 lemma curr_in:
 assumes f: "f \<in> Func (A \<times> B) C"
 shows "curr A f \<in> Func A (Func B C)"
 using assms unfolding curr_def Func_def by auto
 
 lemma curr_inj:
 assumes "f1 \<in> Func (A \<times> B) C" and "f2 \<in> Func (A \<times> B) C"
 shows "curr A f1 = curr A f2 \<longleftrightarrow> f1 = f2"
 proof safe
   assume c: "curr A f1 = curr A f2"
   show "f1 = f2"
   proof (rule ext, clarify)
     fix a b show "f1 (a, b) = f2 (a, b)"
     proof (cases "(a,b) \<in> A \<times> B")
       case False
       thus ?thesis using assms unfolding Func_def by auto
     next
       case True hence a: "a \<in> A" and b: "b \<in> B" by auto
       thus ?thesis
       using c unfolding curr_def fun_eq_iff by(elim allE[of _ a]) simp
     qed
   qed
 qed
 
 lemma curr_surj:
 assumes "g \<in> Func A (Func B C)"
 shows "\<exists> f \<in> Func (A \<times> B) C. curr A f = g"
 proof
   let ?f = "\<lambda> ab. if fst ab \<in> A \<and> snd ab \<in> B then g (fst ab) (snd ab) else undefined"
   show "curr A ?f = g"
   proof (rule ext)
     fix a show "curr A ?f a = g a"
     proof (cases "a \<in> A")
       case False
       hence "g a = undefined" using assms unfolding Func_def by auto
       thus ?thesis unfolding curr_def using False by simp
     next
       case True
       obtain g1 where "g1 \<in> Func B C" and "g a = g1"
       using assms using Func_elim[OF assms True] by blast
       thus ?thesis using True unfolding Func_def curr_def by auto
     qed
   qed
   show "?f \<in> Func (A \<times> B) C" using assms unfolding Func_def mem_Collect_eq by auto
 qed
 
 lemma bij_betw_curr:
 "bij_betw (curr A) (Func (A \<times> B) C) (Func A (Func B C))"
-unfolding bij_betw_def inj_on_def image_def
-apply (intro impI conjI ballI)
-apply (erule curr_inj[THEN iffD1], assumption+)
-apply auto
-apply (erule curr_in)
-using curr_surj by blast
+  unfolding bij_betw_def inj_on_def image_def
+  apply (intro impI conjI ballI)
+   apply (erule curr_inj[THEN iffD1], assumption+, safe)
+  using curr_surj curr_in apply blast+
+  done
 
 definition Func_map where
 "Func_map B2 f1 f2 g b2 \<equiv> if b2 \<in> B2 then f1 (g (f2 b2)) else undefined"
 
 lemma Func_map:
 assumes g: "g \<in> Func A2 A1" and f1: "f1 ` A1 \<subseteq> B1" and f2: "f2 ` B2 \<subseteq> A2"
 shows "Func_map B2 f1 f2 g \<in> Func B2 B1"
 using assms unfolding Func_def Func_map_def mem_Collect_eq by auto
 
 lemma Func_non_emp:
 assumes "B \<noteq> {}"
 shows "Func A B \<noteq> {}"
 proof-
   obtain b where b: "b \<in> B" using assms by auto
   hence "(\<lambda> a. if a \<in> A then b else undefined) \<in> Func A B" unfolding Func_def by auto
   thus ?thesis by blast
 qed
 
 lemma Func_is_emp:
 "Func A B = {} \<longleftrightarrow> A \<noteq> {} \<and> B = {}" (is "?L \<longleftrightarrow> ?R")
 proof
   assume L: ?L
   moreover {assume "A = {}" hence False using L Func_empty by auto}
   moreover {assume "B \<noteq> {}" hence False using L Func_non_emp[of B A] by simp }
   ultimately show ?R by blast
 next
   assume R: ?R
   moreover
   {fix f assume "f \<in> Func A B"
    moreover obtain a where "a \<in> A" using R by blast
    ultimately obtain b where "b \<in> B" unfolding Func_def by blast
    with R have False by blast
   }
   thus ?L by blast
 qed
 
 lemma Func_map_surj:
 assumes B1: "f1 ` A1 = B1" and A2: "inj_on f2 B2" "f2 ` B2 \<subseteq> A2"
 and B2A2: "B2 = {} \<Longrightarrow> A2 = {}"
 shows "Func B2 B1 = Func_map B2 f1 f2 ` Func A2 A1"
 proof(cases "B2 = {}")
   case True
   thus ?thesis using B2A2 by (auto simp: Func_empty Func_map_def)
 next
   case False note B2 = False
   show ?thesis
   proof safe
     fix h assume h: "h \<in> Func B2 B1"
     define j1 where "j1 = inv_into A1 f1"
     have "\<forall> a2 \<in> f2 ` B2. \<exists> b2. b2 \<in> B2 \<and> f2 b2 = a2" by blast
     then obtain k where k: "\<forall> a2 \<in> f2 ` B2. k a2 \<in> B2 \<and> f2 (k a2) = a2"
       by atomize_elim (rule bchoice)
     {fix b2 assume b2: "b2 \<in> B2"
      hence "f2 (k (f2 b2)) = f2 b2" using k A2(2) by auto
      moreover have "k (f2 b2) \<in> B2" using b2 A2(2) k by auto
      ultimately have "k (f2 b2) = b2" using b2 A2(1) unfolding inj_on_def by blast
     } note kk = this
     obtain b22 where b22: "b22 \<in> B2" using B2 by auto
     define j2 where [abs_def]: "j2 a2 = (if a2 \<in> f2 ` B2 then k a2 else b22)" for a2
     have j2A2: "j2 ` A2 \<subseteq> B2" unfolding j2_def using k b22 by auto
     have j2: "\<And> b2. b2 \<in> B2 \<Longrightarrow> j2 (f2 b2) = b2"
     using kk unfolding j2_def by auto
     define g where "g = Func_map A2 j1 j2 h"
     have "Func_map B2 f1 f2 g = h"
     proof (rule ext)
       fix b2 show "Func_map B2 f1 f2 g b2 = h b2"
       proof(cases "b2 \<in> B2")
         case True
         show ?thesis
         proof (cases "h b2 = undefined")
           case True
           hence b1: "h b2 \<in> f1 ` A1" using h \<open>b2 \<in> B2\<close> unfolding B1 Func_def by auto
           show ?thesis using A2 f_inv_into_f[OF b1]
             unfolding True g_def Func_map_def j1_def j2[OF \<open>b2 \<in> B2\<close>] by auto
         qed(insert A2 True j2[OF True] h B1, unfold j1_def g_def Func_def Func_map_def,
           auto intro: f_inv_into_f)
       qed(insert h, unfold Func_def Func_map_def, auto)
     qed
     moreover have "g \<in> Func A2 A1" unfolding g_def apply(rule Func_map[OF h])
     using j2A2 B1 A2 unfolding j1_def by (fast intro: inv_into_into)+
     ultimately show "h \<in> Func_map B2 f1 f2 ` Func A2 A1"
     unfolding Func_map_def[abs_def] by auto
-  qed(insert B1 Func_map[OF _ _ A2(2)], auto)
+  qed(use B1 Func_map[OF _ _ A2(2)] in auto)
 qed
 
 end
diff --git a/src/HOL/BNF_Wellorder_Relation.thy b/src/HOL/BNF_Wellorder_Relation.thy
--- a/src/HOL/BNF_Wellorder_Relation.thy
+++ b/src/HOL/BNF_Wellorder_Relation.thy
@@ -1,589 +1,607 @@
 (*  Title:      HOL/BNF_Wellorder_Relation.thy
     Author:     Andrei Popescu, TU Muenchen
     Copyright   2012
 
 Well-order relations as needed by bounded natural functors.
 *)
 
 section \<open>Well-Order Relations as Needed by Bounded Natural Functors\<close>
 
 theory BNF_Wellorder_Relation
 imports Order_Relation
 begin
 
 text\<open>In this section, we develop basic concepts and results pertaining
 to well-order relations.  Note that we consider well-order relations
 as {\em non-strict relations},
 i.e., as containing the diagonals of their fields.\<close>
 
 locale wo_rel =
   fixes r :: "'a rel"
   assumes WELL: "Well_order r"
 begin
 
 text\<open>The following context encompasses all this section. In other words,
 for the whole section, we consider a fixed well-order relation \<^term>\<open>r\<close>.\<close>
 
 (* context wo_rel  *)
 
 abbreviation under where "under \<equiv> Order_Relation.under r"
 abbreviation underS where "underS \<equiv> Order_Relation.underS r"
 abbreviation Under where "Under \<equiv> Order_Relation.Under r"
 abbreviation UnderS where "UnderS \<equiv> Order_Relation.UnderS r"
 abbreviation above where "above \<equiv> Order_Relation.above r"
 abbreviation aboveS where "aboveS \<equiv> Order_Relation.aboveS r"
 abbreviation Above where "Above \<equiv> Order_Relation.Above r"
 abbreviation AboveS where "AboveS \<equiv> Order_Relation.AboveS r"
 abbreviation ofilter where "ofilter \<equiv> Order_Relation.ofilter r"
 lemmas ofilter_def = Order_Relation.ofilter_def[of r]
 
 
 subsection \<open>Auxiliaries\<close>
 
 lemma REFL: "Refl r"
 using WELL order_on_defs[of _ r] by auto
 
 lemma TRANS: "trans r"
 using WELL order_on_defs[of _ r] by auto
 
 lemma ANTISYM: "antisym r"
 using WELL order_on_defs[of _ r] by auto
 
 lemma TOTAL: "Total r"
 using WELL order_on_defs[of _ r] by auto
 
 lemma TOTALS: "\<forall>a \<in> Field r. \<forall>b \<in> Field r. (a,b) \<in> r \<or> (b,a) \<in> r"
 using REFL TOTAL refl_on_def[of _ r] total_on_def[of _ r] by force
 
 lemma LIN: "Linear_order r"
 using WELL well_order_on_def[of _ r] by auto
 
 lemma WF: "wf (r - Id)"
 using WELL well_order_on_def[of _ r] by auto
 
 lemma cases_Total:
 "\<And> phi a b. \<lbrakk>{a,b} <= Field r; ((a,b) \<in> r \<Longrightarrow> phi a b); ((b,a) \<in> r \<Longrightarrow> phi a b)\<rbrakk>
              \<Longrightarrow> phi a b"
 using TOTALS by auto
 
 lemma cases_Total3:
 "\<And> phi a b. \<lbrakk>{a,b} \<le> Field r; ((a,b) \<in> r - Id \<or> (b,a) \<in> r - Id \<Longrightarrow> phi a b);
               (a = b \<Longrightarrow> phi a b)\<rbrakk>  \<Longrightarrow> phi a b"
 using TOTALS by auto
 
 
 subsection \<open>Well-founded induction and recursion adapted to non-strict well-order relations\<close>
 
 text\<open>Here we provide induction and recursion principles specific to {\em non-strict}
 well-order relations.
 Although minor variations of those for well-founded relations, they will be useful
 for doing away with the tediousness of
 having to take out the diagonal each time in order to switch to a well-founded relation.\<close>
 
 lemma well_order_induct:
 assumes IND: "\<And>x. \<forall>y. y \<noteq> x \<and> (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
 shows "P a"
 proof-
   have "\<And>x. \<forall>y. (y, x) \<in> r - Id \<longrightarrow> P y \<Longrightarrow> P x"
   using IND by blast
   thus "P a" using WF wf_induct[of "r - Id" P a] by blast
 qed
 
 definition
 worec :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
 where
 "worec F \<equiv> wfrec (r - Id) F"
 
 definition
 adm_wo :: "(('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> bool"
 where
 "adm_wo H \<equiv> \<forall>f g x. (\<forall>y \<in> underS x. f y = g y) \<longrightarrow> H f x = H g x"
 
 lemma worec_fixpoint:
 assumes ADM: "adm_wo H"
 shows "worec H = H (worec H)"
 proof-
   let ?rS = "r - Id"
   have "adm_wf (r - Id) H"
   unfolding adm_wf_def
   using ADM adm_wo_def[of H] underS_def[of r] by auto
   hence "wfrec ?rS H = H (wfrec ?rS H)"
   using WF wfrec_fixpoint[of ?rS H] by simp
   thus ?thesis unfolding worec_def .
 qed
 
 
 subsection \<open>The notions of maximum, minimum, supremum, successor and order filter\<close>
 
 text\<open>
 We define the successor {\em of a set}, and not of an element (the latter is of course
 a particular case).  Also, we define the maximum {\em of two elements}, \<open>max2\<close>,
 and the minimum {\em of a set}, \<open>minim\<close> -- we chose these variants since we
 consider them the most useful for well-orders.  The minimum is defined in terms of the
 auxiliary relational operator \<open>isMinim\<close>.  Then, supremum and successor are
 defined in terms of minimum as expected.
 The minimum is only meaningful for non-empty sets, and the successor is only
 meaningful for sets for which strict upper bounds exist.
 Order filters for well-orders are also known as ``initial segments".\<close>
 
 definition max2 :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
 where "max2 a b \<equiv> if (a,b) \<in> r then b else a"
 
 definition isMinim :: "'a set \<Rightarrow> 'a \<Rightarrow> bool"
 where "isMinim A b \<equiv> b \<in> A \<and> (\<forall>a \<in> A. (b,a) \<in> r)"
 
 definition minim :: "'a set \<Rightarrow> 'a"
 where "minim A \<equiv> THE b. isMinim A b"
 
 definition supr :: "'a set \<Rightarrow> 'a"
 where "supr A \<equiv> minim (Above A)"
 
 definition suc :: "'a set \<Rightarrow> 'a"
 where "suc A \<equiv> minim (AboveS A)"
 
 
 subsubsection \<open>Properties of max2\<close>
 
 lemma max2_greater_among:
 assumes "a \<in> Field r" and "b \<in> Field r"
 shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r \<and> max2 a b \<in> {a,b}"
 proof-
   {assume "(a,b) \<in> r"
    hence ?thesis using max2_def assms REFL refl_on_def
    by (auto simp add: refl_on_def)
   }
   moreover
   {assume "a = b"
    hence "(a,b) \<in> r" using REFL  assms
    by (auto simp add: refl_on_def)
   }
   moreover
   {assume *: "a \<noteq> b \<and> (b,a) \<in> r"
    hence "(a,b) \<notin> r" using ANTISYM
    by (auto simp add: antisym_def)
    hence ?thesis using * max2_def assms REFL refl_on_def
    by (auto simp add: refl_on_def)
   }
   ultimately show ?thesis using assms TOTAL
   total_on_def[of "Field r" r] by blast
 qed
 
 lemma max2_greater:
 assumes "a \<in> Field r" and "b \<in> Field r"
 shows "(a, max2 a b) \<in> r \<and> (b, max2 a b) \<in> r"
 using assms by (auto simp add: max2_greater_among)
 
 lemma max2_among:
 assumes "a \<in> Field r" and "b \<in> Field r"
 shows "max2 a b \<in> {a, b}"
 using assms max2_greater_among[of a b] by simp
 
 lemma max2_equals1:
 assumes "a \<in> Field r" and "b \<in> Field r"
 shows "(max2 a b = a) = ((b,a) \<in> r)"
 using assms ANTISYM unfolding antisym_def using TOTALS
 by(auto simp add: max2_def max2_among)
 
 lemma max2_equals2:
 assumes "a \<in> Field r" and "b \<in> Field r"
 shows "(max2 a b = b) = ((a,b) \<in> r)"
 using assms ANTISYM unfolding antisym_def using TOTALS
 unfolding max2_def by auto
 
 lemma in_notinI:
 assumes "(j,i) \<notin> r \<or> j = i" and "i \<in> Field r" and "j \<in> Field r"
 shows "(i,j) \<in> r" using assms max2_def max2_greater_among by fastforce
 
 subsubsection \<open>Existence and uniqueness for isMinim and well-definedness of minim\<close>
 
 lemma isMinim_unique:
 assumes MINIM: "isMinim B a" and MINIM': "isMinim B a'"
 shows "a = a'"
 proof-
   {have "a \<in> B"
    using MINIM isMinim_def by simp
    hence "(a',a) \<in> r"
    using MINIM' isMinim_def by simp
   }
   moreover
   {have "a' \<in> B"
    using MINIM' isMinim_def by simp
    hence "(a,a') \<in> r"
    using MINIM isMinim_def by simp
   }
   ultimately
   show ?thesis using ANTISYM antisym_def[of r] by blast
 qed
 
 lemma Well_order_isMinim_exists:
 assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
 shows "\<exists>b. isMinim B b"
 proof-
   from spec[OF WF[unfolded wf_eq_minimal[of "r - Id"]], of B] NE obtain b where
-  *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
-  show ?thesis
-  proof(simp add: isMinim_def, rule exI[of _ b], auto)
-    show "b \<in> B" using * by simp
-  next
-    fix b' assume As: "b' \<in> B"
-    hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
-    (*  *)
-    from As  * have "b' = b \<or> (b',b) \<notin> r" by auto
-    moreover
-    {assume "b' = b"
-     hence "(b,b') \<in> r"
-     using ** REFL by (auto simp add: refl_on_def)
-    }
-    moreover
-    {assume "b' \<noteq> b \<and> (b',b) \<notin> r"
-     hence "(b,b') \<in> r"
-     using ** TOTAL by (auto simp add: total_on_def)
-    }
-    ultimately show "(b,b') \<in> r" by blast
+    *: "b \<in> B \<and> (\<forall>b'. b' \<noteq> b \<and> (b',b) \<in> r \<longrightarrow> b' \<notin> B)" by auto
+  have "\<forall>b'. b' \<in> B \<longrightarrow> (b, b') \<in> r"
+  proof
+    fix b'
+    show "b' \<in> B \<longrightarrow> (b, b') \<in> r"
+    proof
+      assume As: "b' \<in> B"
+      hence **: "b \<in> Field r \<and> b' \<in> Field r" using As SUB * by auto
+      from As  * have "b' = b \<or> (b',b) \<notin> r" by auto
+      moreover have "b' = b \<Longrightarrow> (b, b') \<in> r"
+        using ** REFL by (auto simp add: refl_on_def)
+      moreover have "b' \<noteq> b \<and> (b',b) \<notin> r \<Longrightarrow> (b,b') \<in> r"
+         using ** TOTAL by (auto simp add: total_on_def)
+      ultimately show "(b,b') \<in> r" by blast
+    qed
   qed
+  then have "isMinim B b"
+    unfolding isMinim_def using * by auto
+  then show ?thesis
+    by auto
 qed
 
 lemma minim_isMinim:
 assumes SUB: "B \<le> Field r" and NE: "B \<noteq> {}"
 shows "isMinim B (minim B)"
 proof-
   let ?phi = "(\<lambda> b. isMinim B b)"
   from assms Well_order_isMinim_exists
   obtain b where *: "?phi b" by blast
   moreover
   have "\<And> b'. ?phi b' \<Longrightarrow> b' = b"
   using isMinim_unique * by auto
   ultimately show ?thesis
   unfolding minim_def using theI[of ?phi b] by blast
 qed
 
 subsubsection\<open>Properties of minim\<close>
 
 lemma minim_in:
 assumes "B \<le> Field r" and "B \<noteq> {}"
 shows "minim B \<in> B"
 proof-
   from minim_isMinim[of B] assms
   have "isMinim B (minim B)" by simp
   thus ?thesis by (simp add: isMinim_def)
 qed
 
 lemma minim_inField:
 assumes "B \<le> Field r" and "B \<noteq> {}"
 shows "minim B \<in> Field r"
 proof-
   have "minim B \<in> B" using assms by (simp add: minim_in)
   thus ?thesis using assms by blast
 qed
 
 lemma minim_least:
 assumes  SUB: "B \<le> Field r" and IN: "b \<in> B"
 shows "(minim B, b) \<in> r"
 proof-
   from minim_isMinim[of B] assms
   have "isMinim B (minim B)" by auto
   thus ?thesis by (auto simp add: isMinim_def IN)
 qed
 
 lemma equals_minim:
 assumes SUB: "B \<le> Field r" and IN: "a \<in> B" and
         LEAST: "\<And> b. b \<in> B \<Longrightarrow> (a,b) \<in> r"
 shows "a = minim B"
 proof-
   from minim_isMinim[of B] assms
   have "isMinim B (minim B)" by auto
   moreover have "isMinim B a" using IN LEAST isMinim_def by auto
   ultimately show ?thesis
   using isMinim_unique by auto
 qed
 
 subsubsection\<open>Properties of successor\<close>
 
 lemma suc_AboveS:
 assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}"
 shows "suc B \<in> AboveS B"
 proof(unfold suc_def)
   have "AboveS B \<le> Field r"
   using AboveS_Field[of r] by auto
   thus "minim (AboveS B) \<in> AboveS B"
   using assms by (simp add: minim_in)
 qed
 
 lemma suc_greater:
 assumes SUB: "B \<le> Field r" and ABOVES: "AboveS B \<noteq> {}" and
         IN: "b \<in> B"
 shows "suc B \<noteq> b \<and> (b,suc B) \<in> r"
 proof-
   from assms suc_AboveS
   have "suc B \<in> AboveS B" by simp
   with IN AboveS_def[of r] show ?thesis by simp
 qed
 
 lemma suc_least_AboveS:
 assumes ABOVES: "a \<in> AboveS B"
 shows "(suc B,a) \<in> r"
 proof(unfold suc_def)
   have "AboveS B \<le> Field r"
   using AboveS_Field[of r] by auto
   thus "(minim (AboveS B),a) \<in> r"
   using assms minim_least by simp
 qed
 
 lemma suc_inField:
 assumes "B \<le> Field r" and "AboveS B \<noteq> {}"
 shows "suc B \<in> Field r"
 proof-
   have "suc B \<in> AboveS B" using suc_AboveS assms by simp
   thus ?thesis
   using assms AboveS_Field[of r] by auto
 qed
 
 lemma equals_suc_AboveS:
 assumes SUB: "B \<le> Field r" and ABV: "a \<in> AboveS B" and
         MINIM: "\<And> a'. a' \<in> AboveS B \<Longrightarrow> (a,a') \<in> r"
 shows "a = suc B"
 proof(unfold suc_def)
   have "AboveS B \<le> Field r"
   using AboveS_Field[of r B] by auto
   thus "a = minim (AboveS B)"
   using assms equals_minim
   by simp
 qed
 
 lemma suc_underS:
 assumes IN: "a \<in> Field r"
 shows "a = suc (underS a)"
 proof-
   have "underS a \<le> Field r"
   using underS_Field[of r] by auto
   moreover
   have "a \<in> AboveS (underS a)"
   using in_AboveS_underS IN by fast
   moreover
   have "\<forall>a' \<in> AboveS (underS a). (a,a') \<in> r"
   proof(clarify)
     fix a'
     assume *: "a' \<in> AboveS (underS a)"
     hence **: "a' \<in> Field r"
     using AboveS_Field by fast
     {assume "(a,a') \<notin> r"
      hence "a' = a \<or> (a',a) \<in> r"
      using TOTAL IN ** by (auto simp add: total_on_def)
      moreover
      {assume "a' = a"
       hence "(a,a') \<in> r"
       using REFL IN ** by (auto simp add: refl_on_def)
      }
      moreover
      {assume "a' \<noteq> a \<and> (a',a) \<in> r"
       hence "a' \<in> underS a"
       unfolding underS_def by simp
       hence "a' \<notin> AboveS (underS a)"
       using AboveS_disjoint by fast
       with * have False by simp
      }
      ultimately have "(a,a') \<in> r" by blast
     }
     thus  "(a, a') \<in> r" by blast
   qed
   ultimately show ?thesis
   using equals_suc_AboveS by auto
 qed
 
 
 subsubsection \<open>Properties of order filters\<close>
 
 lemma under_ofilter:
 "ofilter (under a)"
-proof(unfold ofilter_def under_def, auto simp add: Field_def)
-  fix aa x
-  assume "(aa,a) \<in> r" "(x,aa) \<in> r"
-  thus "(x,a) \<in> r"
-  using TRANS trans_def[of r] by blast
+proof -
+  have "\<And>aa x. (aa, a) \<in> r \<Longrightarrow> (x, aa) \<in> r \<Longrightarrow> (x, a) \<in> r"
+  proof -
+    fix aa x
+    assume "(aa,a) \<in> r" "(x,aa) \<in> r"
+    then show "(x,a) \<in> r"
+      using TRANS trans_def[of r] by blast
+  qed
+  then show ?thesis unfolding ofilter_def under_def
+    by (auto simp add: Field_def)
 qed
 
 lemma underS_ofilter:
 "ofilter (underS a)"
-proof(unfold ofilter_def underS_def under_def, auto simp add: Field_def)
+  unfolding ofilter_def underS_def under_def
+proof safe
   fix aa assume "(a, aa) \<in> r" "(aa, a) \<in> r" and DIFF: "aa \<noteq> a"
   thus False
   using ANTISYM antisym_def[of r] by blast
 next
   fix aa x
   assume "(aa,a) \<in> r" "aa \<noteq> a" "(x,aa) \<in> r"
   thus "(x,a) \<in> r"
-  using TRANS trans_def[of r] by blast
+    using TRANS trans_def[of r] by blast
+next
+  fix x
+  assume "x \<noteq> a" and "(x, a) \<in> r"
+  then show "x \<in> Field r"
+    unfolding Field_def
+    by auto
 qed
 
 lemma Field_ofilter:
 "ofilter (Field r)"
 by(unfold ofilter_def under_def, auto simp add: Field_def)
 
 lemma ofilter_underS_Field:
 "ofilter A = ((\<exists>a \<in> Field r. A = underS a) \<or> (A = Field r))"
 proof
   assume "(\<exists>a\<in>Field r. A = underS a) \<or> A = Field r"
   thus "ofilter A"
   by (auto simp: underS_ofilter Field_ofilter)
 next
   assume *: "ofilter A"
   let ?One = "(\<exists>a\<in>Field r. A = underS a)"
   let ?Two = "(A = Field r)"
   show "?One \<or> ?Two"
-  proof(cases ?Two, simp)
+  proof(cases ?Two)
     let ?B = "(Field r) - A"
     let ?a = "minim ?B"
     assume "A \<noteq> Field r"
     moreover have "A \<le> Field r" using * ofilter_def by simp
     ultimately have 1: "?B \<noteq> {}" by blast
     hence 2: "?a \<in> Field r" using minim_inField[of ?B] by blast
     have 3: "?a \<in> ?B" using minim_in[of ?B] 1 by blast
     hence 4: "?a \<notin> A" by blast
     have 5: "A \<le> Field r" using * ofilter_def by auto
     (*  *)
     moreover
     have "A = underS ?a"
     proof
       show "A \<le> underS ?a"
-      proof(unfold underS_def, auto simp add: 4)
+      proof
         fix x assume **: "x \<in> A"
         hence 11: "x \<in> Field r" using 5 by auto
         have 12: "x \<noteq> ?a" using 4 ** by auto
         have 13: "under x \<le> A" using * ofilter_def ** by auto
         {assume "(x,?a) \<notin> r"
          hence "(?a,x) \<in> r"
          using TOTAL total_on_def[of "Field r" r]
                2 4 11 12 by auto
          hence "?a \<in> under x" using under_def[of r] by auto
          hence "?a \<in> A" using ** 13 by blast
          with 4 have False by simp
         }
-        thus "(x,?a) \<in> r" by blast
+        then have "(x,?a) \<in> r" by blast
+        thus "x \<in> underS ?a"
+          unfolding underS_def by (auto simp add: 12)
       qed
     next
       show "underS ?a \<le> A"
-      proof(unfold underS_def, auto)
+      proof
         fix x
-        assume **: "x \<noteq> ?a" and ***: "(x,?a) \<in> r"
-        hence 11: "x \<in> Field r" using Field_def by fastforce
+        assume **: "x \<in> underS ?a"
+        hence 11: "x \<in> Field r"
+         using Field_def unfolding underS_def by fastforce
          {assume "x \<notin> A"
           hence "x \<in> ?B" using 11 by auto
           hence "(?a,x) \<in> r" using 3 minim_least[of ?B x] by blast
           hence False
-          using ANTISYM antisym_def[of r] ** *** by auto
+          using ANTISYM antisym_def[of r] ** unfolding underS_def by auto
          }
         thus "x \<in> A" by blast
       qed
     qed
     ultimately have ?One using 2 by blast
     thus ?thesis by simp
+  next
+    assume "A = Field r"
+    then show ?thesis
+      by simp
   qed
 qed
 
 lemma ofilter_UNION:
 "(\<And> i. i \<in> I \<Longrightarrow> ofilter(A i)) \<Longrightarrow> ofilter (\<Union>i \<in> I. A i)"
 unfolding ofilter_def by blast
 
 lemma ofilter_under_UNION:
 assumes "ofilter A"
 shows "A = (\<Union>a \<in> A. under a)"
 proof
   have "\<forall>a \<in> A. under a \<le> A"
   using assms ofilter_def by auto
   thus "(\<Union>a \<in> A. under a) \<le> A" by blast
 next
   have "\<forall>a \<in> A. a \<in> under a"
   using REFL Refl_under_in[of r] assms ofilter_def[of A] by blast
   thus "A \<le> (\<Union>a \<in> A. under a)" by blast
 qed
 
 subsubsection\<open>Other properties\<close>
 
 lemma ofilter_linord:
 assumes OF1: "ofilter A" and OF2: "ofilter B"
 shows "A \<le> B \<or> B \<le> A"
 proof(cases "A = Field r")
   assume Case1: "A = Field r"
   hence "B \<le> A" using OF2 ofilter_def by auto
   thus ?thesis by simp
 next
   assume Case2: "A \<noteq> Field r"
   with ofilter_underS_Field OF1 obtain a where
   1: "a \<in> Field r \<and> A = underS a" by auto
   show ?thesis
   proof(cases "B = Field r")
     assume Case21: "B = Field r"
     hence "A \<le> B" using OF1 ofilter_def by auto
     thus ?thesis by simp
   next
     assume Case22: "B \<noteq> Field r"
     with ofilter_underS_Field OF2 obtain b where
     2: "b \<in> Field r \<and> B = underS b" by auto
     have "a = b \<or> (a,b) \<in> r \<or> (b,a) \<in> r"
     using 1 2 TOTAL total_on_def[of _ r] by auto
     moreover
     {assume "a = b" with 1 2 have ?thesis by auto
     }
     moreover
     {assume "(a,b) \<in> r"
      with underS_incr[of r] TRANS ANTISYM 1 2
      have "A \<le> B" by auto
      hence ?thesis by auto
     }
     moreover
      {assume "(b,a) \<in> r"
      with underS_incr[of r] TRANS ANTISYM 1 2
      have "B \<le> A" by auto
      hence ?thesis by auto
     }
     ultimately show ?thesis by blast
   qed
 qed
 
 lemma ofilter_AboveS_Field:
 assumes "ofilter A"
 shows "A \<union> (AboveS A) = Field r"
 proof
   show "A \<union> (AboveS A) \<le> Field r"
   using assms ofilter_def AboveS_Field[of r] by auto
 next
   {fix x assume *: "x \<in> Field r" and **: "x \<notin> A"
    {fix y assume ***: "y \<in> A"
     with ** have 1: "y \<noteq> x" by auto
     {assume "(y,x) \<notin> r"
      moreover
      have "y \<in> Field r" using assms ofilter_def *** by auto
      ultimately have "(x,y) \<in> r"
      using 1 * TOTAL total_on_def[of _ r] by auto
      with *** assms ofilter_def under_def[of r] have "x \<in> A" by auto
      with ** have False by contradiction
     }
     hence "(y,x) \<in> r" by blast
     with 1 have "y \<noteq> x \<and> (y,x) \<in> r" by auto
    }
    with * have "x \<in> AboveS A" unfolding AboveS_def by auto
   }
   thus "Field r \<le> A \<union> (AboveS A)" by blast
 qed
 
 lemma suc_ofilter_in:
 assumes OF: "ofilter A" and ABOVE_NE: "AboveS A \<noteq> {}" and
         REL: "(b,suc A) \<in> r" and DIFF: "b \<noteq> suc A"
 shows "b \<in> A"
 proof-
   have *: "suc A \<in> Field r \<and> b \<in> Field r"
   using WELL REL well_order_on_domain[of "Field r"] by auto
   {assume **: "b \<notin> A"
    hence "b \<in> AboveS A"
    using OF * ofilter_AboveS_Field by auto
    hence "(suc A, b) \<in> r"
    using suc_least_AboveS by auto
    hence False using REL DIFF ANTISYM *
    by (auto simp add: antisym_def)
   }
   thus ?thesis by blast
 qed
 
 end (* context wo_rel *)
 
 end
diff --git a/src/HOL/Complete_Lattices.thy b/src/HOL/Complete_Lattices.thy
--- a/src/HOL/Complete_Lattices.thy
+++ b/src/HOL/Complete_Lattices.thy
@@ -1,1364 +1,1364 @@
 (*  Title:      HOL/Complete_Lattices.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Florian Haftmann
     Author:     Viorel Preoteasa (Complete Distributive Lattices)     
 *)
 
 section \<open>Complete lattices\<close>
 
 theory Complete_Lattices
   imports Fun
 begin
 
 subsection \<open>Syntactic infimum and supremum operations\<close>
 
 class Inf =
   fixes Inf :: "'a set \<Rightarrow> 'a"  ("\<Sqinter> _" [900] 900)
 
 class Sup =
   fixes Sup :: "'a set \<Rightarrow> 'a"  ("\<Squnion> _" [900] 900)
 
 syntax
   "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3INF _./ _)" [0, 10] 10)
   "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3INF _\<in>_./ _)" [0, 0, 10] 10)
   "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3SUP _./ _)" [0, 10] 10)
   "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3SUP _\<in>_./ _)" [0, 0, 10] 10)
 
 syntax
   "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
   "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
   "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
   "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
 
 translations
   "\<Sqinter>x y. f"   \<rightleftharpoons> "\<Sqinter>x. \<Sqinter>y. f"
   "\<Sqinter>x. f"     \<rightleftharpoons> "\<Sqinter>(CONST range (\<lambda>x. f))"
   "\<Sqinter>x\<in>A. f"   \<rightleftharpoons> "CONST Inf ((\<lambda>x. f) ` A)"
   "\<Squnion>x y. f"   \<rightleftharpoons> "\<Squnion>x. \<Squnion>y. f"
   "\<Squnion>x. f"     \<rightleftharpoons> "\<Squnion>(CONST range (\<lambda>x. f))"
   "\<Squnion>x\<in>A. f"   \<rightleftharpoons> "CONST Sup ((\<lambda>x. f) `  A)"
 
 context Inf
 begin
 
 lemma INF_image: "\<Sqinter> (g ` f ` A) = \<Sqinter> ((g \<circ> f) ` A)"
   by (simp add: image_comp)
 
 lemma INF_identity_eq [simp]: "(\<Sqinter>x\<in>A. x) = \<Sqinter>A"
   by simp
 
 lemma INF_id_eq [simp]: "\<Sqinter>(id ` A) = \<Sqinter>A"
   by simp
 
 lemma INF_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> \<Sqinter>(C ` A) = \<Sqinter>(D ` B)"
   by (simp add: image_def)
 
 lemma INF_cong_simp:
   "A = B \<Longrightarrow> (\<And>x. x \<in> B =simp=> C x = D x) \<Longrightarrow> \<Sqinter>(C ` A) = \<Sqinter>(D ` B)"
   unfolding simp_implies_def by (fact INF_cong)
 
 end
 
 context Sup
 begin
 
 lemma SUP_image: "\<Squnion> (g ` f ` A) = \<Squnion> ((g \<circ> f) ` A)"
 by(fact Inf.INF_image)
 
 lemma SUP_identity_eq [simp]: "(\<Squnion>x\<in>A. x) = \<Squnion>A"
 by(fact Inf.INF_identity_eq)
 
 lemma SUP_id_eq [simp]: "\<Squnion>(id ` A) = \<Squnion>A"
 by(fact Inf.INF_id_eq)
 
 lemma SUP_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> \<Squnion>(C ` A) = \<Squnion>(D ` B)"
 by (fact Inf.INF_cong)
 
 lemma SUP_cong_simp:
   "A = B \<Longrightarrow> (\<And>x. x \<in> B =simp=> C x = D x) \<Longrightarrow> \<Squnion>(C ` A) = \<Squnion>(D ` B)"
 by (fact Inf.INF_cong_simp)
 
 end
 
 
 subsection \<open>Abstract complete lattices\<close>
 
 text \<open>A complete lattice always has a bottom and a top,
 so we include them into the following type class,
 along with assumptions that define bottom and top
 in terms of infimum and supremum.\<close>
 
 class complete_lattice = lattice + Inf + Sup + bot + top +
   assumes Inf_lower: "x \<in> A \<Longrightarrow> \<Sqinter>A \<le> x"
     and Inf_greatest: "(\<And>x. x \<in> A \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> \<Sqinter>A"
     and Sup_upper: "x \<in> A \<Longrightarrow> x \<le> \<Squnion>A"
     and Sup_least: "(\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> \<Squnion>A \<le> z"
     and Inf_empty [simp]: "\<Sqinter>{} = \<top>"
     and Sup_empty [simp]: "\<Squnion>{} = \<bottom>"
 begin
 
 subclass bounded_lattice
 proof
   fix a
   show "\<bottom> \<le> a"
     by (auto intro: Sup_least simp only: Sup_empty [symmetric])
   show "a \<le> \<top>"
     by (auto intro: Inf_greatest simp only: Inf_empty [symmetric])
 qed
 
 lemma dual_complete_lattice: "class.complete_lattice Sup Inf sup (\<ge>) (>) inf \<top> \<bottom>"
   by (auto intro!: class.complete_lattice.intro dual_lattice)
     (unfold_locales, (fact Inf_empty Sup_empty Sup_upper Sup_least Inf_lower Inf_greatest)+)
 
 end
 
 context complete_lattice
 begin
 
 lemma Sup_eqI:
   "(\<And>y. y \<in> A \<Longrightarrow> y \<le> x) \<Longrightarrow> (\<And>y. (\<And>z. z \<in> A \<Longrightarrow> z \<le> y) \<Longrightarrow> x \<le> y) \<Longrightarrow> \<Squnion>A = x"
   by (blast intro: order.antisym Sup_least Sup_upper)
 
 lemma Inf_eqI:
   "(\<And>i. i \<in> A \<Longrightarrow> x \<le> i) \<Longrightarrow> (\<And>y. (\<And>i. i \<in> A \<Longrightarrow> y \<le> i) \<Longrightarrow> y \<le> x) \<Longrightarrow> \<Sqinter>A = x"
   by (blast intro: order.antisym Inf_greatest Inf_lower)
 
 lemma SUP_eqI:
   "(\<And>i. i \<in> A \<Longrightarrow> f i \<le> x) \<Longrightarrow> (\<And>y. (\<And>i. i \<in> A \<Longrightarrow> f i \<le> y) \<Longrightarrow> x \<le> y) \<Longrightarrow> (\<Squnion>i\<in>A. f i) = x"
   using Sup_eqI [of "f ` A" x] by auto
 
 lemma INF_eqI:
   "(\<And>i. i \<in> A \<Longrightarrow> x \<le> f i) \<Longrightarrow> (\<And>y. (\<And>i. i \<in> A \<Longrightarrow> f i \<ge> y) \<Longrightarrow> x \<ge> y) \<Longrightarrow> (\<Sqinter>i\<in>A. f i) = x"
   using Inf_eqI [of "f ` A" x] by auto
 
 lemma INF_lower: "i \<in> A \<Longrightarrow> (\<Sqinter>i\<in>A. f i) \<le> f i"
   using Inf_lower [of _ "f ` A"] by simp
 
 lemma INF_greatest: "(\<And>i. i \<in> A \<Longrightarrow> u \<le> f i) \<Longrightarrow> u \<le> (\<Sqinter>i\<in>A. f i)"
   using Inf_greatest [of "f ` A"] by auto
 
 lemma SUP_upper: "i \<in> A \<Longrightarrow> f i \<le> (\<Squnion>i\<in>A. f i)"
   using Sup_upper [of _ "f ` A"] by simp
 
 lemma SUP_least: "(\<And>i. i \<in> A \<Longrightarrow> f i \<le> u) \<Longrightarrow> (\<Squnion>i\<in>A. f i) \<le> u"
   using Sup_least [of "f ` A"] by auto
 
 lemma Inf_lower2: "u \<in> A \<Longrightarrow> u \<le> v \<Longrightarrow> \<Sqinter>A \<le> v"
   using Inf_lower [of u A] by auto
 
 lemma INF_lower2: "i \<in> A \<Longrightarrow> f i \<le> u \<Longrightarrow> (\<Sqinter>i\<in>A. f i) \<le> u"
   using INF_lower [of i A f] by auto
 
 lemma Sup_upper2: "u \<in> A \<Longrightarrow> v \<le> u \<Longrightarrow> v \<le> \<Squnion>A"
   using Sup_upper [of u A] by auto
 
 lemma SUP_upper2: "i \<in> A \<Longrightarrow> u \<le> f i \<Longrightarrow> u \<le> (\<Squnion>i\<in>A. f i)"
   using SUP_upper [of i A f] by auto
 
 lemma le_Inf_iff: "b \<le> \<Sqinter>A \<longleftrightarrow> (\<forall>a\<in>A. b \<le> a)"
   by (auto intro: Inf_greatest dest: Inf_lower)
 
 lemma le_INF_iff: "u \<le> (\<Sqinter>i\<in>A. f i) \<longleftrightarrow> (\<forall>i\<in>A. u \<le> f i)"
   using le_Inf_iff [of _ "f ` A"] by simp
 
 lemma Sup_le_iff: "\<Squnion>A \<le> b \<longleftrightarrow> (\<forall>a\<in>A. a \<le> b)"
   by (auto intro: Sup_least dest: Sup_upper)
 
 lemma SUP_le_iff: "(\<Squnion>i\<in>A. f i) \<le> u \<longleftrightarrow> (\<forall>i\<in>A. f i \<le> u)"
   using Sup_le_iff [of "f ` A"] by simp
 
 lemma Inf_insert [simp]: "\<Sqinter>(insert a A) = a \<sqinter> \<Sqinter>A"
   by (auto intro: le_infI le_infI1 le_infI2 order.antisym Inf_greatest Inf_lower)
 
 lemma INF_insert: "(\<Sqinter>x\<in>insert a A. f x) = f a \<sqinter> \<Sqinter>(f ` A)"
   by simp
 
 lemma Sup_insert [simp]: "\<Squnion>(insert a A) = a \<squnion> \<Squnion>A"
   by (auto intro: le_supI le_supI1 le_supI2 order.antisym Sup_least Sup_upper)
 
 lemma SUP_insert: "(\<Squnion>x\<in>insert a A. f x) = f a \<squnion> \<Squnion>(f ` A)"
   by simp
 
 lemma INF_empty: "(\<Sqinter>x\<in>{}. f x) = \<top>"
   by simp
 
 lemma SUP_empty: "(\<Squnion>x\<in>{}. f x) = \<bottom>"
   by simp
 
 lemma Inf_UNIV [simp]: "\<Sqinter>UNIV = \<bottom>"
   by (auto intro!: order.antisym Inf_lower)
 
 lemma Sup_UNIV [simp]: "\<Squnion>UNIV = \<top>"
   by (auto intro!: order.antisym Sup_upper)
 
 lemma Inf_eq_Sup: "\<Sqinter>A = \<Squnion>{b. \<forall>a \<in> A. b \<le> a}"
   by (auto intro: order.antisym Inf_lower Inf_greatest Sup_upper Sup_least)
 
 lemma Sup_eq_Inf:  "\<Squnion>A = \<Sqinter>{b. \<forall>a \<in> A. a \<le> b}"
   by (auto intro: order.antisym Inf_lower Inf_greatest Sup_upper Sup_least)
 
 lemma Inf_superset_mono: "B \<subseteq> A \<Longrightarrow> \<Sqinter>A \<le> \<Sqinter>B"
   by (auto intro: Inf_greatest Inf_lower)
 
 lemma Sup_subset_mono: "A \<subseteq> B \<Longrightarrow> \<Squnion>A \<le> \<Squnion>B"
   by (auto intro: Sup_least Sup_upper)
 
 lemma Inf_mono:
   assumes "\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b"
   shows "\<Sqinter>A \<le> \<Sqinter>B"
 proof (rule Inf_greatest)
   fix b assume "b \<in> B"
   with assms obtain a where "a \<in> A" and "a \<le> b" by blast
   from \<open>a \<in> A\<close> have "\<Sqinter>A \<le> a" by (rule Inf_lower)
   with \<open>a \<le> b\<close> show "\<Sqinter>A \<le> b" by auto
 qed
 
 lemma INF_mono: "(\<And>m. m \<in> B \<Longrightarrow> \<exists>n\<in>A. f n \<le> g m) \<Longrightarrow> (\<Sqinter>n\<in>A. f n) \<le> (\<Sqinter>n\<in>B. g n)"
   using Inf_mono [of "g ` B" "f ` A"] by auto
 
 lemma INF_mono': "(\<And>x. f x \<le> g x) \<Longrightarrow> (\<Sqinter>x\<in>A. f x) \<le> (\<Sqinter>x\<in>A. g x)"
   by (rule INF_mono) auto
 
 lemma Sup_mono:
   assumes "\<And>a. a \<in> A \<Longrightarrow> \<exists>b\<in>B. a \<le> b"
   shows "\<Squnion>A \<le> \<Squnion>B"
 proof (rule Sup_least)
   fix a assume "a \<in> A"
   with assms obtain b where "b \<in> B" and "a \<le> b" by blast
   from \<open>b \<in> B\<close> have "b \<le> \<Squnion>B" by (rule Sup_upper)
   with \<open>a \<le> b\<close> show "a \<le> \<Squnion>B" by auto
 qed
 
 lemma SUP_mono: "(\<And>n. n \<in> A \<Longrightarrow> \<exists>m\<in>B. f n \<le> g m) \<Longrightarrow> (\<Squnion>n\<in>A. f n) \<le> (\<Squnion>n\<in>B. g n)"
   using Sup_mono [of "f ` A" "g ` B"] by auto
 
 lemma SUP_mono': "(\<And>x. f x \<le> g x) \<Longrightarrow> (\<Squnion>x\<in>A. f x) \<le> (\<Squnion>x\<in>A. g x)"
   by (rule SUP_mono) auto
 
 lemma INF_superset_mono: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> f x \<le> g x) \<Longrightarrow> (\<Sqinter>x\<in>A. f x) \<le> (\<Sqinter>x\<in>B. g x)"
   \<comment> \<open>The last inclusion is POSITIVE!\<close>
   by (blast intro: INF_mono dest: subsetD)
 
 lemma SUP_subset_mono: "A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<le> g x) \<Longrightarrow> (\<Squnion>x\<in>A. f x) \<le> (\<Squnion>x\<in>B. g x)"
   by (blast intro: SUP_mono dest: subsetD)
 
 lemma Inf_less_eq:
   assumes "\<And>v. v \<in> A \<Longrightarrow> v \<le> u"
     and "A \<noteq> {}"
   shows "\<Sqinter>A \<le> u"
 proof -
   from \<open>A \<noteq> {}\<close> obtain v where "v \<in> A" by blast
   moreover from \<open>v \<in> A\<close> assms(1) have "v \<le> u" by blast
   ultimately show ?thesis by (rule Inf_lower2)
 qed
 
 lemma less_eq_Sup:
   assumes "\<And>v. v \<in> A \<Longrightarrow> u \<le> v"
     and "A \<noteq> {}"
   shows "u \<le> \<Squnion>A"
 proof -
   from \<open>A \<noteq> {}\<close> obtain v where "v \<in> A" by blast
   moreover from \<open>v \<in> A\<close> assms(1) have "u \<le> v" by blast
   ultimately show ?thesis by (rule Sup_upper2)
 qed
 
 lemma INF_eq:
   assumes "\<And>i. i \<in> A \<Longrightarrow> \<exists>j\<in>B. f i \<ge> g j"
     and "\<And>j. j \<in> B \<Longrightarrow> \<exists>i\<in>A. g j \<ge> f i"
   shows "\<Sqinter>(f ` A) = \<Sqinter>(g ` B)"
   by (intro order.antisym INF_greatest) (blast intro: INF_lower2 dest: assms)+
 
 lemma SUP_eq:
   assumes "\<And>i. i \<in> A \<Longrightarrow> \<exists>j\<in>B. f i \<le> g j"
     and "\<And>j. j \<in> B \<Longrightarrow> \<exists>i\<in>A. g j \<le> f i"
   shows "\<Squnion>(f ` A) = \<Squnion>(g ` B)"
   by (intro order.antisym SUP_least) (blast intro: SUP_upper2 dest: assms)+
 
 lemma less_eq_Inf_inter: "\<Sqinter>A \<squnion> \<Sqinter>B \<le> \<Sqinter>(A \<inter> B)"
   by (auto intro: Inf_greatest Inf_lower)
 
 lemma Sup_inter_less_eq: "\<Squnion>(A \<inter> B) \<le> \<Squnion>A \<sqinter> \<Squnion>B "
   by (auto intro: Sup_least Sup_upper)
 
 lemma Inf_union_distrib: "\<Sqinter>(A \<union> B) = \<Sqinter>A \<sqinter> \<Sqinter>B"
   by (rule order.antisym) (auto intro: Inf_greatest Inf_lower le_infI1 le_infI2)
 
 lemma INF_union: "(\<Sqinter>i \<in> A \<union> B. M i) = (\<Sqinter>i \<in> A. M i) \<sqinter> (\<Sqinter>i\<in>B. M i)"
   by (auto intro!: order.antisym INF_mono intro: le_infI1 le_infI2 INF_greatest INF_lower)
 
 lemma Sup_union_distrib: "\<Squnion>(A \<union> B) = \<Squnion>A \<squnion> \<Squnion>B"
   by (rule order.antisym) (auto intro: Sup_least Sup_upper le_supI1 le_supI2)
 
 lemma SUP_union: "(\<Squnion>i \<in> A \<union> B. M i) = (\<Squnion>i \<in> A. M i) \<squnion> (\<Squnion>i\<in>B. M i)"
   by (auto intro!: order.antisym SUP_mono intro: le_supI1 le_supI2 SUP_least SUP_upper)
 
 lemma INF_inf_distrib: "(\<Sqinter>a\<in>A. f a) \<sqinter> (\<Sqinter>a\<in>A. g a) = (\<Sqinter>a\<in>A. f a \<sqinter> g a)"
   by (rule order.antisym) (rule INF_greatest, auto intro: le_infI1 le_infI2 INF_lower INF_mono)
 
 lemma SUP_sup_distrib: "(\<Squnion>a\<in>A. f a) \<squnion> (\<Squnion>a\<in>A. g a) = (\<Squnion>a\<in>A. f a \<squnion> g a)"
   (is "?L = ?R")
 proof (rule order.antisym)
   show "?L \<le> ?R"
     by (auto intro: le_supI1 le_supI2 SUP_upper SUP_mono)
   show "?R \<le> ?L"
     by (rule SUP_least) (auto intro: le_supI1 le_supI2 SUP_upper)
 qed
 
 lemma Inf_top_conv [simp]:
   "\<Sqinter>A = \<top> \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)"
   "\<top> = \<Sqinter>A \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)"
 proof -
   show "\<Sqinter>A = \<top> \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)"
   proof
     assume "\<forall>x\<in>A. x = \<top>"
     then have "A = {} \<or> A = {\<top>}" by auto
     then show "\<Sqinter>A = \<top>" by auto
   next
     assume "\<Sqinter>A = \<top>"
     show "\<forall>x\<in>A. x = \<top>"
     proof (rule ccontr)
       assume "\<not> (\<forall>x\<in>A. x = \<top>)"
       then obtain x where "x \<in> A" and "x \<noteq> \<top>" by blast
       then obtain B where "A = insert x B" by blast
       with \<open>\<Sqinter>A = \<top>\<close> \<open>x \<noteq> \<top>\<close> show False by simp
     qed
   qed
   then show "\<top> = \<Sqinter>A \<longleftrightarrow> (\<forall>x\<in>A. x = \<top>)" by auto
 qed
 
 lemma INF_top_conv [simp]:
   "(\<Sqinter>x\<in>A. B x) = \<top> \<longleftrightarrow> (\<forall>x\<in>A. B x = \<top>)"
   "\<top> = (\<Sqinter>x\<in>A. B x) \<longleftrightarrow> (\<forall>x\<in>A. B x = \<top>)"
   using Inf_top_conv [of "B ` A"] by simp_all
 
 lemma Sup_bot_conv [simp]:
   "\<Squnion>A = \<bottom> \<longleftrightarrow> (\<forall>x\<in>A. x = \<bottom>)"
   "\<bottom> = \<Squnion>A \<longleftrightarrow> (\<forall>x\<in>A. x = \<bottom>)"
   using dual_complete_lattice
   by (rule complete_lattice.Inf_top_conv)+
 
 lemma SUP_bot_conv [simp]:
   "(\<Squnion>x\<in>A. B x) = \<bottom> \<longleftrightarrow> (\<forall>x\<in>A. B x = \<bottom>)"
   "\<bottom> = (\<Squnion>x\<in>A. B x) \<longleftrightarrow> (\<forall>x\<in>A. B x = \<bottom>)"
   using Sup_bot_conv [of "B ` A"] by simp_all
 
 lemma INF_constant: "(\<Sqinter>y\<in>A. c) = (if A = {} then \<top> else c)"
   by (auto intro: order.antisym INF_lower INF_greatest)
 
 lemma SUP_constant: "(\<Squnion>y\<in>A. c) = (if A = {} then \<bottom> else c)"
   by (auto intro: order.antisym SUP_upper SUP_least)
 
 lemma INF_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter>i\<in>A. f) = f"
   by (simp add: INF_constant)
 
 lemma SUP_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Squnion>i\<in>A. f) = f"
   by (simp add: SUP_constant)
 
 lemma INF_top [simp]: "(\<Sqinter>x\<in>A. \<top>) = \<top>"
   by (cases "A = {}") simp_all
 
 lemma SUP_bot [simp]: "(\<Squnion>x\<in>A. \<bottom>) = \<bottom>"
   by (cases "A = {}") simp_all
 
 lemma INF_commute: "(\<Sqinter>i\<in>A. \<Sqinter>j\<in>B. f i j) = (\<Sqinter>j\<in>B. \<Sqinter>i\<in>A. f i j)"
   by (iprover intro: INF_lower INF_greatest order_trans order.antisym)
 
 lemma SUP_commute: "(\<Squnion>i\<in>A. \<Squnion>j\<in>B. f i j) = (\<Squnion>j\<in>B. \<Squnion>i\<in>A. f i j)"
   by (iprover intro: SUP_upper SUP_least order_trans order.antisym)
 
 lemma INF_absorb:
   assumes "k \<in> I"
   shows "A k \<sqinter> (\<Sqinter>i\<in>I. A i) = (\<Sqinter>i\<in>I. A i)"
 proof -
   from assms obtain J where "I = insert k J" by blast
   then show ?thesis by simp
 qed
 
 lemma SUP_absorb:
   assumes "k \<in> I"
   shows "A k \<squnion> (\<Squnion>i\<in>I. A i) = (\<Squnion>i\<in>I. A i)"
 proof -
   from assms obtain J where "I = insert k J" by blast
   then show ?thesis by simp
 qed
 
 lemma INF_inf_const1: "I \<noteq> {} \<Longrightarrow> (\<Sqinter>i\<in>I. inf x (f i)) = inf x (\<Sqinter>i\<in>I. f i)"
   by (intro order.antisym INF_greatest inf_mono order_refl INF_lower)
      (auto intro: INF_lower2 le_infI2 intro!: INF_mono)
 
 lemma INF_inf_const2: "I \<noteq> {} \<Longrightarrow> (\<Sqinter>i\<in>I. inf (f i) x) = inf (\<Sqinter>i\<in>I. f i) x"
   using INF_inf_const1[of I x f] by (simp add: inf_commute)
 
 lemma less_INF_D:
   assumes "y < (\<Sqinter>i\<in>A. f i)" "i \<in> A"
   shows "y < f i"
 proof -
   note \<open>y < (\<Sqinter>i\<in>A. f i)\<close>
   also have "(\<Sqinter>i\<in>A. f i) \<le> f i" using \<open>i \<in> A\<close>
     by (rule INF_lower)
   finally show "y < f i" .
 qed
 
 lemma SUP_lessD:
   assumes "(\<Squnion>i\<in>A. f i) < y" "i \<in> A"
   shows "f i < y"
 proof -
   have "f i \<le> (\<Squnion>i\<in>A. f i)"
     using \<open>i \<in> A\<close> by (rule SUP_upper)
   also note \<open>(\<Squnion>i\<in>A. f i) < y\<close>
   finally show "f i < y" .
 qed
 
 lemma INF_UNIV_bool_expand: "(\<Sqinter>b. A b) = A True \<sqinter> A False"
   by (simp add: UNIV_bool inf_commute)
 
 lemma SUP_UNIV_bool_expand: "(\<Squnion>b. A b) = A True \<squnion> A False"
   by (simp add: UNIV_bool sup_commute)
 
 lemma Inf_le_Sup: "A \<noteq> {} \<Longrightarrow> Inf A \<le> Sup A"
   by (blast intro: Sup_upper2 Inf_lower ex_in_conv)
 
 lemma INF_le_SUP: "A \<noteq> {} \<Longrightarrow> \<Sqinter>(f ` A) \<le> \<Squnion>(f ` A)"
   using Inf_le_Sup [of "f ` A"] by simp
 
 lemma INF_eq_const: "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> f i = x) \<Longrightarrow> \<Sqinter>(f ` I) = x"
   by (auto intro: INF_eqI)
 
 lemma SUP_eq_const: "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> f i = x) \<Longrightarrow> \<Squnion>(f ` I) = x"
   by (auto intro: SUP_eqI)
 
 lemma INF_eq_iff: "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> f i \<le> c) \<Longrightarrow> \<Sqinter>(f ` I) = c \<longleftrightarrow> (\<forall>i\<in>I. f i = c)"
   by (auto intro: INF_eq_const INF_lower order.antisym)
 
 lemma SUP_eq_iff: "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> c \<le> f i) \<Longrightarrow> \<Squnion>(f ` I) = c \<longleftrightarrow> (\<forall>i\<in>I. f i = c)"
   by (auto intro: SUP_eq_const SUP_upper order.antisym)
 
 end
 
 context complete_lattice
 begin
 lemma Sup_Inf_le: "Sup (Inf ` {f ` A | f . (\<forall> Y \<in> A . f Y \<in> Y)}) \<le> Inf (Sup ` A)"
   by (rule SUP_least, clarify, rule INF_greatest, simp add: INF_lower2 Sup_upper)
 end 
 
 class complete_distrib_lattice = complete_lattice +
   assumes Inf_Sup_le: "Inf (Sup ` A) \<le> Sup (Inf ` {f ` A | f . (\<forall> Y \<in> A . f Y \<in> Y)})"
 begin
   
 lemma Inf_Sup: "Inf (Sup ` A) = Sup (Inf ` {f ` A | f . (\<forall> Y \<in> A . f Y \<in> Y)})"
   by (rule order.antisym, rule Inf_Sup_le, rule Sup_Inf_le)
 
 subclass distrib_lattice
 proof
   fix a b c
   show "a \<squnion> b \<sqinter> c = (a \<squnion> b) \<sqinter> (a \<squnion> c)"
   proof (rule order.antisym, simp_all, safe)
     show "b \<sqinter> c \<le> a \<squnion> b"
       by (rule le_infI1, simp)
     show "b \<sqinter> c \<le> a \<squnion> c"
       by (rule le_infI2, simp)
     have [simp]: "a \<sqinter> c \<le> a \<squnion> b \<sqinter> c"
       by (rule le_infI1, simp)
     have [simp]: "b \<sqinter> a \<le> a \<squnion> b \<sqinter> c"
       by (rule le_infI2, simp)
     have "\<Sqinter>(Sup ` {{a, b}, {a, c}}) =
       \<Squnion>(Inf ` {f ` {{a, b}, {a, c}} | f. \<forall>Y\<in>{{a, b}, {a, c}}. f Y \<in> Y})"
       by (rule Inf_Sup)
     from this show "(a \<squnion> b) \<sqinter> (a \<squnion> c) \<le> a \<squnion> b \<sqinter> c"
       apply simp
       by (rule SUP_least, safe, simp_all)
   qed
 qed
 end
 
 context complete_lattice
 begin
 context
   fixes f :: "'a \<Rightarrow> 'b::complete_lattice"
   assumes "mono f"
 begin
 
 lemma mono_Inf: "f (\<Sqinter>A) \<le> (\<Sqinter>x\<in>A. f x)"
   using \<open>mono f\<close> by (auto intro: complete_lattice_class.INF_greatest Inf_lower dest: monoD)
 
 lemma mono_Sup: "(\<Squnion>x\<in>A. f x) \<le> f (\<Squnion>A)"
   using \<open>mono f\<close> by (auto intro: complete_lattice_class.SUP_least Sup_upper dest: monoD)
 
 lemma mono_INF: "f (\<Sqinter>i\<in>I. A i) \<le> (\<Sqinter>x\<in>I. f (A x))"
   by (intro complete_lattice_class.INF_greatest monoD[OF \<open>mono f\<close>] INF_lower)
 
 lemma mono_SUP: "(\<Squnion>x\<in>I. f (A x)) \<le> f (\<Squnion>i\<in>I. A i)"
   by (intro complete_lattice_class.SUP_least monoD[OF \<open>mono f\<close>] SUP_upper)
 
 end
 
 end
 
 class complete_boolean_algebra = boolean_algebra + complete_distrib_lattice
 begin
 
 lemma uminus_Inf: "- (\<Sqinter>A) = \<Squnion>(uminus ` A)"
 proof (rule order.antisym)
   show "- \<Sqinter>A \<le> \<Squnion>(uminus ` A)"
     by (rule compl_le_swap2, rule Inf_greatest, rule compl_le_swap2, rule Sup_upper) simp
   show "\<Squnion>(uminus ` A) \<le> - \<Sqinter>A"
     by (rule Sup_least, rule compl_le_swap1, rule Inf_lower) auto
 qed
 
 lemma uminus_INF: "- (\<Sqinter>x\<in>A. B x) = (\<Squnion>x\<in>A. - B x)"
   by (simp add: uminus_Inf image_image)
 
 lemma uminus_Sup: "- (\<Squnion>A) = \<Sqinter>(uminus ` A)"
 proof -
   have "\<Squnion>A = - \<Sqinter>(uminus ` A)"
     by (simp add: image_image uminus_INF)
   then show ?thesis by simp
 qed
 
 lemma uminus_SUP: "- (\<Squnion>x\<in>A. B x) = (\<Sqinter>x\<in>A. - B x)"
   by (simp add: uminus_Sup image_image)
 
 end
 
 class complete_linorder = linorder + complete_lattice
 begin
 
 lemma dual_complete_linorder:
   "class.complete_linorder Sup Inf sup (\<ge>) (>) inf \<top> \<bottom>"
   by (rule class.complete_linorder.intro, rule dual_complete_lattice, rule dual_linorder)
 
 lemma complete_linorder_inf_min: "inf = min"
   by (auto intro: order.antisym simp add: min_def fun_eq_iff)
 
 lemma complete_linorder_sup_max: "sup = max"
   by (auto intro: order.antisym simp add: max_def fun_eq_iff)
 
 lemma Inf_less_iff: "\<Sqinter>S < a \<longleftrightarrow> (\<exists>x\<in>S. x < a)"
   by (simp add: not_le [symmetric] le_Inf_iff)
 
 lemma INF_less_iff: "(\<Sqinter>i\<in>A. f i) < a \<longleftrightarrow> (\<exists>x\<in>A. f x < a)"
   by (simp add: Inf_less_iff [of "f ` A"])
 
 lemma less_Sup_iff: "a < \<Squnion>S \<longleftrightarrow> (\<exists>x\<in>S. a < x)"
   by (simp add: not_le [symmetric] Sup_le_iff)
 
 lemma less_SUP_iff: "a < (\<Squnion>i\<in>A. f i) \<longleftrightarrow> (\<exists>x\<in>A. a < f x)"
   by (simp add: less_Sup_iff [of _ "f ` A"])
 
 lemma Sup_eq_top_iff [simp]: "\<Squnion>A = \<top> \<longleftrightarrow> (\<forall>x<\<top>. \<exists>i\<in>A. x < i)"
 proof
   assume *: "\<Squnion>A = \<top>"
   show "(\<forall>x<\<top>. \<exists>i\<in>A. x < i)"
     unfolding * [symmetric]
   proof (intro allI impI)
     fix x
     assume "x < \<Squnion>A"
     then show "\<exists>i\<in>A. x < i"
       by (simp add: less_Sup_iff)
   qed
 next
   assume *: "\<forall>x<\<top>. \<exists>i\<in>A. x < i"
   show "\<Squnion>A = \<top>"
   proof (rule ccontr)
     assume "\<Squnion>A \<noteq> \<top>"
     with top_greatest [of "\<Squnion>A"] have "\<Squnion>A < \<top>"
       unfolding le_less by auto
     with * have "\<Squnion>A < \<Squnion>A"
       unfolding less_Sup_iff by auto
     then show False by auto
   qed
 qed
 
 lemma SUP_eq_top_iff [simp]: "(\<Squnion>i\<in>A. f i) = \<top> \<longleftrightarrow> (\<forall>x<\<top>. \<exists>i\<in>A. x < f i)"
   using Sup_eq_top_iff [of "f ` A"] by simp
 
 lemma Inf_eq_bot_iff [simp]: "\<Sqinter>A = \<bottom> \<longleftrightarrow> (\<forall>x>\<bottom>. \<exists>i\<in>A. i < x)"
   using dual_complete_linorder
   by (rule complete_linorder.Sup_eq_top_iff)
 
 lemma INF_eq_bot_iff [simp]: "(\<Sqinter>i\<in>A. f i) = \<bottom> \<longleftrightarrow> (\<forall>x>\<bottom>. \<exists>i\<in>A. f i < x)"
   using Inf_eq_bot_iff [of "f ` A"] by simp
 
 lemma Inf_le_iff: "\<Sqinter>A \<le> x \<longleftrightarrow> (\<forall>y>x. \<exists>a\<in>A. y > a)"
 proof safe
   fix y
   assume "x \<ge> \<Sqinter>A" "y > x"
   then have "y > \<Sqinter>A" by auto
   then show "\<exists>a\<in>A. y > a"
     unfolding Inf_less_iff .
 qed (auto elim!: allE[of _ "\<Sqinter>A"] simp add: not_le[symmetric] Inf_lower)
 
 lemma INF_le_iff: "\<Sqinter>(f ` A) \<le> x \<longleftrightarrow> (\<forall>y>x. \<exists>i\<in>A. y > f i)"
   using Inf_le_iff [of "f ` A"] by simp
 
 lemma le_Sup_iff: "x \<le> \<Squnion>A \<longleftrightarrow> (\<forall>y<x. \<exists>a\<in>A. y < a)"
 proof safe
   fix y
   assume "x \<le> \<Squnion>A" "y < x"
   then have "y < \<Squnion>A" by auto
   then show "\<exists>a\<in>A. y < a"
     unfolding less_Sup_iff .
 qed (auto elim!: allE[of _ "\<Squnion>A"] simp add: not_le[symmetric] Sup_upper)
 
 lemma le_SUP_iff: "x \<le> \<Squnion>(f ` A) \<longleftrightarrow> (\<forall>y<x. \<exists>i\<in>A. y < f i)"
   using le_Sup_iff [of _ "f ` A"] by simp
 
 end
 
 subsection \<open>Complete lattice on \<^typ>\<open>bool\<close>\<close>
 
 instantiation bool :: complete_lattice
 begin
 
 definition [simp, code]: "\<Sqinter>A \<longleftrightarrow> False \<notin> A"
 
 definition [simp, code]: "\<Squnion>A \<longleftrightarrow> True \<in> A"
 
 instance
   by standard (auto intro: bool_induct)
 
 end
 
 lemma not_False_in_image_Ball [simp]: "False \<notin> P ` A \<longleftrightarrow> Ball A P"
   by auto
 
 lemma True_in_image_Bex [simp]: "True \<in> P ` A \<longleftrightarrow> Bex A P"
   by auto
 
 lemma INF_bool_eq [simp]: "(\<lambda>A f. \<Sqinter>(f ` A)) = Ball"
   by (simp add: fun_eq_iff)
 
 lemma SUP_bool_eq [simp]: "(\<lambda>A f. \<Squnion>(f ` A)) = Bex"
   by (simp add: fun_eq_iff)
 
 instance bool :: complete_boolean_algebra
   by (standard, fastforce)
 
 subsection \<open>Complete lattice on \<^typ>\<open>_ \<Rightarrow> _\<close>\<close>
 
 instantiation "fun" :: (type, Inf) Inf
 begin
 
 definition "\<Sqinter>A = (\<lambda>x. \<Sqinter>f\<in>A. f x)"
 
 lemma Inf_apply [simp, code]: "(\<Sqinter>A) x = (\<Sqinter>f\<in>A. f x)"
   by (simp add: Inf_fun_def)
 
 instance ..
 
 end
 
 instantiation "fun" :: (type, Sup) Sup
 begin
 
 definition "\<Squnion>A = (\<lambda>x. \<Squnion>f\<in>A. f x)"
 
 lemma Sup_apply [simp, code]: "(\<Squnion>A) x = (\<Squnion>f\<in>A. f x)"
   by (simp add: Sup_fun_def)
 
 instance ..
 
 end
 
 instantiation "fun" :: (type, complete_lattice) complete_lattice
 begin
 
 instance
   by standard (auto simp add: le_fun_def intro: INF_lower INF_greatest SUP_upper SUP_least)
 
 end
 
 lemma INF_apply [simp]: "(\<Sqinter>y\<in>A. f y) x = (\<Sqinter>y\<in>A. f y x)"
   by (simp add: image_comp)
 
 lemma SUP_apply [simp]: "(\<Squnion>y\<in>A. f y) x = (\<Squnion>y\<in>A. f y x)"
   by (simp add: image_comp)
 
 subsection \<open>Complete lattice on unary and binary predicates\<close>
 
 lemma Inf1_I: "(\<And>P. P \<in> A \<Longrightarrow> P a) \<Longrightarrow> (\<Sqinter>A) a"
   by auto
 
 lemma INF1_I: "(\<And>x. x \<in> A \<Longrightarrow> B x b) \<Longrightarrow> (\<Sqinter>x\<in>A. B x) b"
   by simp
 
 lemma INF2_I: "(\<And>x. x \<in> A \<Longrightarrow> B x b c) \<Longrightarrow> (\<Sqinter>x\<in>A. B x) b c"
   by simp
 
 lemma Inf2_I: "(\<And>r. r \<in> A \<Longrightarrow> r a b) \<Longrightarrow> (\<Sqinter>A) a b"
   by auto
 
 lemma Inf1_D: "(\<Sqinter>A) a \<Longrightarrow> P \<in> A \<Longrightarrow> P a"
   by auto
 
 lemma INF1_D: "(\<Sqinter>x\<in>A. B x) b \<Longrightarrow> a \<in> A \<Longrightarrow> B a b"
   by simp
 
 lemma Inf2_D: "(\<Sqinter>A) a b \<Longrightarrow> r \<in> A \<Longrightarrow> r a b"
   by auto
 
 lemma INF2_D: "(\<Sqinter>x\<in>A. B x) b c \<Longrightarrow> a \<in> A \<Longrightarrow> B a b c"
   by simp
 
 lemma Inf1_E:
   assumes "(\<Sqinter>A) a"
   obtains "P a" | "P \<notin> A"
   using assms by auto
 
 lemma INF1_E:
   assumes "(\<Sqinter>x\<in>A. B x) b"
   obtains "B a b" | "a \<notin> A"
   using assms by auto
 
 lemma Inf2_E:
   assumes "(\<Sqinter>A) a b"
   obtains "r a b" | "r \<notin> A"
   using assms by auto
 
 lemma INF2_E:
   assumes "(\<Sqinter>x\<in>A. B x) b c"
   obtains "B a b c" | "a \<notin> A"
   using assms by auto
 
 lemma Sup1_I: "P \<in> A \<Longrightarrow> P a \<Longrightarrow> (\<Squnion>A) a"
   by auto
 
 lemma SUP1_I: "a \<in> A \<Longrightarrow> B a b \<Longrightarrow> (\<Squnion>x\<in>A. B x) b"
   by auto
 
 lemma Sup2_I: "r \<in> A \<Longrightarrow> r a b \<Longrightarrow> (\<Squnion>A) a b"
   by auto
 
 lemma SUP2_I: "a \<in> A \<Longrightarrow> B a b c \<Longrightarrow> (\<Squnion>x\<in>A. B x) b c"
   by auto
 
 lemma Sup1_E:
   assumes "(\<Squnion>A) a"
   obtains P where "P \<in> A" and "P a"
   using assms by auto
 
 lemma SUP1_E:
   assumes "(\<Squnion>x\<in>A. B x) b"
   obtains x where "x \<in> A" and "B x b"
   using assms by auto
 
 lemma Sup2_E:
   assumes "(\<Squnion>A) a b"
   obtains r where "r \<in> A" "r a b"
   using assms by auto
 
 lemma SUP2_E:
   assumes "(\<Squnion>x\<in>A. B x) b c"
   obtains x where "x \<in> A" "B x b c"
   using assms by auto
 
 
 subsection \<open>Complete lattice on \<^typ>\<open>_ set\<close>\<close>
 
 instantiation "set" :: (type) complete_lattice
 begin
 
 definition "\<Sqinter>A = {x. \<Sqinter>((\<lambda>B. x \<in> B) ` A)}"
 
 definition "\<Squnion>A = {x. \<Squnion>((\<lambda>B. x \<in> B) ` A)}"
 
 instance
   by standard (auto simp add: less_eq_set_def Inf_set_def Sup_set_def le_fun_def)
 
 end
 
 subsubsection \<open>Inter\<close>
 
 abbreviation Inter :: "'a set set \<Rightarrow> 'a set"  ("\<Inter>")
   where "\<Inter>S \<equiv> \<Sqinter>S"
 
 lemma Inter_eq: "\<Inter>A = {x. \<forall>B \<in> A. x \<in> B}"
 proof (rule set_eqI)
   fix x
   have "(\<forall>Q\<in>{P. \<exists>B\<in>A. P \<longleftrightarrow> x \<in> B}. Q) \<longleftrightarrow> (\<forall>B\<in>A. x \<in> B)"
     by auto
   then show "x \<in> \<Inter>A \<longleftrightarrow> x \<in> {x. \<forall>B \<in> A. x \<in> B}"
     by (simp add: Inf_set_def image_def)
 qed
 
 lemma Inter_iff [simp]: "A \<in> \<Inter>C \<longleftrightarrow> (\<forall>X\<in>C. A \<in> X)"
   by (unfold Inter_eq) blast
 
 lemma InterI [intro!]: "(\<And>X. X \<in> C \<Longrightarrow> A \<in> X) \<Longrightarrow> A \<in> \<Inter>C"
   by (simp add: Inter_eq)
 
 text \<open>
   \<^medskip> A ``destruct'' rule -- every \<^term>\<open>X\<close> in \<^term>\<open>C\<close>
   contains \<^term>\<open>A\<close> as an element, but \<^prop>\<open>A \<in> X\<close> can hold when
   \<^prop>\<open>X \<in> C\<close> does not!  This rule is analogous to \<open>spec\<close>.
 \<close>
 
 lemma InterD [elim, Pure.elim]: "A \<in> \<Inter>C \<Longrightarrow> X \<in> C \<Longrightarrow> A \<in> X"
   by auto
 
 lemma InterE [elim]: "A \<in> \<Inter>C \<Longrightarrow> (X \<notin> C \<Longrightarrow> R) \<Longrightarrow> (A \<in> X \<Longrightarrow> R) \<Longrightarrow> R"
   \<comment> \<open>``Classical'' elimination rule -- does not require proving
     \<^prop>\<open>X \<in> C\<close>.\<close>
   unfolding Inter_eq by blast
 
 lemma Inter_lower: "B \<in> A \<Longrightarrow> \<Inter>A \<subseteq> B"
   by (fact Inf_lower)
 
 lemma Inter_subset: "(\<And>X. X \<in> A \<Longrightarrow> X \<subseteq> B) \<Longrightarrow> A \<noteq> {} \<Longrightarrow> \<Inter>A \<subseteq> B"
   by (fact Inf_less_eq)
 
 lemma Inter_greatest: "(\<And>X. X \<in> A \<Longrightarrow> C \<subseteq> X) \<Longrightarrow> C \<subseteq> \<Inter>A"
   by (fact Inf_greatest)
 
 lemma Inter_empty: "\<Inter>{} = UNIV"
   by (fact Inf_empty) (* already simp *)
 
 lemma Inter_UNIV: "\<Inter>UNIV = {}"
   by (fact Inf_UNIV) (* already simp *)
 
 lemma Inter_insert: "\<Inter>(insert a B) = a \<inter> \<Inter>B"
   by (fact Inf_insert) (* already simp *)
 
 lemma Inter_Un_subset: "\<Inter>A \<union> \<Inter>B \<subseteq> \<Inter>(A \<inter> B)"
   by (fact less_eq_Inf_inter)
 
 lemma Inter_Un_distrib: "\<Inter>(A \<union> B) = \<Inter>A \<inter> \<Inter>B"
   by (fact Inf_union_distrib)
 
 lemma Inter_UNIV_conv [simp]:
   "\<Inter>A = UNIV \<longleftrightarrow> (\<forall>x\<in>A. x = UNIV)"
   "UNIV = \<Inter>A \<longleftrightarrow> (\<forall>x\<in>A. x = UNIV)"
   by (fact Inf_top_conv)+
 
 lemma Inter_anti_mono: "B \<subseteq> A \<Longrightarrow> \<Inter>A \<subseteq> \<Inter>B"
   by (fact Inf_superset_mono)
 
 
 subsubsection \<open>Intersections of families\<close>
 
 syntax (ASCII)
   "_INTER1"     :: "pttrns \<Rightarrow> 'b set \<Rightarrow> 'b set"           ("(3INT _./ _)" [0, 10] 10)
   "_INTER"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'b set"  ("(3INT _:_./ _)" [0, 0, 10] 10)
 
 syntax
   "_INTER1"     :: "pttrns \<Rightarrow> 'b set \<Rightarrow> 'b set"           ("(3\<Inter>_./ _)" [0, 10] 10)
   "_INTER"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'b set"  ("(3\<Inter>_\<in>_./ _)" [0, 0, 10] 10)
 
 syntax (latex output)
   "_INTER1"     :: "pttrns \<Rightarrow> 'b set \<Rightarrow> 'b set"           ("(3\<Inter>(\<open>unbreakable\<close>\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
   "_INTER"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'b set"  ("(3\<Inter>(\<open>unbreakable\<close>\<^bsub>_\<in>_\<^esub>)/ _)" [0, 0, 10] 10)
 
 translations
   "\<Inter>x y. f"  \<rightleftharpoons> "\<Inter>x. \<Inter>y. f"
   "\<Inter>x. f"    \<rightleftharpoons> "\<Inter>(CONST range (\<lambda>x. f))"
   "\<Inter>x\<in>A. f"  \<rightleftharpoons> "CONST Inter ((\<lambda>x. f) ` A)"
 
 lemma INTER_eq: "(\<Inter>x\<in>A. B x) = {y. \<forall>x\<in>A. y \<in> B x}"
   by (auto intro!: INF_eqI)
 
 lemma INT_iff [simp]: "b \<in> (\<Inter>x\<in>A. B x) \<longleftrightarrow> (\<forall>x\<in>A. b \<in> B x)"
   using Inter_iff [of _ "B ` A"] by simp
 
 lemma INT_I [intro!]: "(\<And>x. x \<in> A \<Longrightarrow> b \<in> B x) \<Longrightarrow> b \<in> (\<Inter>x\<in>A. B x)"
   by auto
 
 lemma INT_D [elim, Pure.elim]: "b \<in> (\<Inter>x\<in>A. B x) \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> B a"
   by auto
 
 lemma INT_E [elim]: "b \<in> (\<Inter>x\<in>A. B x) \<Longrightarrow> (b \<in> B a \<Longrightarrow> R) \<Longrightarrow> (a \<notin> A \<Longrightarrow> R) \<Longrightarrow> R"
   \<comment> \<open>"Classical" elimination -- by the Excluded Middle on \<^prop>\<open>a\<in>A\<close>.\<close>
   by auto
 
 lemma Collect_ball_eq: "{x. \<forall>y\<in>A. P x y} = (\<Inter>y\<in>A. {x. P x y})"
   by blast
 
 lemma Collect_all_eq: "{x. \<forall>y. P x y} = (\<Inter>y. {x. P x y})"
   by blast
 
 lemma INT_lower: "a \<in> A \<Longrightarrow> (\<Inter>x\<in>A. B x) \<subseteq> B a"
   by (fact INF_lower)
 
 lemma INT_greatest: "(\<And>x. x \<in> A \<Longrightarrow> C \<subseteq> B x) \<Longrightarrow> C \<subseteq> (\<Inter>x\<in>A. B x)"
   by (fact INF_greatest)
 
 lemma INT_empty: "(\<Inter>x\<in>{}. B x) = UNIV"
   by (fact INF_empty)
 
 lemma INT_absorb: "k \<in> I \<Longrightarrow> A k \<inter> (\<Inter>i\<in>I. A i) = (\<Inter>i\<in>I. A i)"
   by (fact INF_absorb)
 
 lemma INT_subset_iff: "B \<subseteq> (\<Inter>i\<in>I. A i) \<longleftrightarrow> (\<forall>i\<in>I. B \<subseteq> A i)"
   by (fact le_INF_iff)
 
 lemma INT_insert [simp]: "(\<Inter>x \<in> insert a A. B x) = B a \<inter> \<Inter> (B ` A)"
   by (fact INF_insert)
 
 lemma INT_Un: "(\<Inter>i \<in> A \<union> B. M i) = (\<Inter>i \<in> A. M i) \<inter> (\<Inter>i\<in>B. M i)"
   by (fact INF_union)
 
 lemma INT_insert_distrib: "u \<in> A \<Longrightarrow> (\<Inter>x\<in>A. insert a (B x)) = insert a (\<Inter>x\<in>A. B x)"
   by blast
 
 lemma INT_constant [simp]: "(\<Inter>y\<in>A. c) = (if A = {} then UNIV else c)"
   by (fact INF_constant)
 
 lemma INTER_UNIV_conv:
   "(UNIV = (\<Inter>x\<in>A. B x)) = (\<forall>x\<in>A. B x = UNIV)"
   "((\<Inter>x\<in>A. B x) = UNIV) = (\<forall>x\<in>A. B x = UNIV)"
   by (fact INF_top_conv)+ (* already simp *)
 
 lemma INT_bool_eq: "(\<Inter>b. A b) = A True \<inter> A False"
   by (fact INF_UNIV_bool_expand)
 
 lemma INT_anti_mono: "A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<subseteq> g x) \<Longrightarrow> (\<Inter>x\<in>B. f x) \<subseteq> (\<Inter>x\<in>A. g x)"
   \<comment> \<open>The last inclusion is POSITIVE!\<close>
   by (fact INF_superset_mono)
 
 lemma Pow_INT_eq: "Pow (\<Inter>x\<in>A. B x) = (\<Inter>x\<in>A. Pow (B x))"
   by blast
 
 lemma vimage_INT: "f -` (\<Inter>x\<in>A. B x) = (\<Inter>x\<in>A. f -` B x)"
   by blast
 
 
 subsubsection \<open>Union\<close>
 
 abbreviation Union :: "'a set set \<Rightarrow> 'a set"  ("\<Union>")
   where "\<Union>S \<equiv> \<Squnion>S"
 
 lemma Union_eq: "\<Union>A = {x. \<exists>B \<in> A. x \<in> B}"
 proof (rule set_eqI)
   fix x
   have "(\<exists>Q\<in>{P. \<exists>B\<in>A. P \<longleftrightarrow> x \<in> B}. Q) \<longleftrightarrow> (\<exists>B\<in>A. x \<in> B)"
     by auto
   then show "x \<in> \<Union>A \<longleftrightarrow> x \<in> {x. \<exists>B\<in>A. x \<in> B}"
     by (simp add: Sup_set_def image_def)
 qed
 
 lemma Union_iff [simp]: "A \<in> \<Union>C \<longleftrightarrow> (\<exists>X\<in>C. A\<in>X)"
   by (unfold Union_eq) blast
 
 lemma UnionI [intro]: "X \<in> C \<Longrightarrow> A \<in> X \<Longrightarrow> A \<in> \<Union>C"
   \<comment> \<open>The order of the premises presupposes that \<^term>\<open>C\<close> is rigid;
     \<^term>\<open>A\<close> may be flexible.\<close>
   by auto
 
 lemma UnionE [elim!]: "A \<in> \<Union>C \<Longrightarrow> (\<And>X. A \<in> X \<Longrightarrow> X \<in> C \<Longrightarrow> R) \<Longrightarrow> R"
   by auto
 
 lemma Union_upper: "B \<in> A \<Longrightarrow> B \<subseteq> \<Union>A"
   by (fact Sup_upper)
 
 lemma Union_least: "(\<And>X. X \<in> A \<Longrightarrow> X \<subseteq> C) \<Longrightarrow> \<Union>A \<subseteq> C"
   by (fact Sup_least)
 
 lemma Union_empty: "\<Union>{} = {}"
   by (fact Sup_empty) (* already simp *)
 
 lemma Union_UNIV: "\<Union>UNIV = UNIV"
   by (fact Sup_UNIV) (* already simp *)
 
 lemma Union_insert: "\<Union>(insert a B) = a \<union> \<Union>B"
   by (fact Sup_insert) (* already simp *)
 
 lemma Union_Un_distrib [simp]: "\<Union>(A \<union> B) = \<Union>A \<union> \<Union>B"
   by (fact Sup_union_distrib)
 
 lemma Union_Int_subset: "\<Union>(A \<inter> B) \<subseteq> \<Union>A \<inter> \<Union>B"
   by (fact Sup_inter_less_eq)
 
 lemma Union_empty_conv: "(\<Union>A = {}) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
   by (fact Sup_bot_conv) (* already simp *)
 
 lemma empty_Union_conv: "({} = \<Union>A) \<longleftrightarrow> (\<forall>x\<in>A. x = {})"
   by (fact Sup_bot_conv) (* already simp *)
 
 lemma subset_Pow_Union: "A \<subseteq> Pow (\<Union>A)"
   by blast
 
 lemma Union_Pow_eq [simp]: "\<Union>(Pow A) = A"
   by blast
 
 lemma Union_mono: "A \<subseteq> B \<Longrightarrow> \<Union>A \<subseteq> \<Union>B"
   by (fact Sup_subset_mono)
 
 lemma Union_subsetI: "(\<And>x. x \<in> A \<Longrightarrow> \<exists>y. y \<in> B \<and> x \<subseteq> y) \<Longrightarrow> \<Union>A \<subseteq> \<Union>B"
   by blast
 
 lemma disjnt_inj_on_iff:
-     "\<lbrakk>inj_on f (\<Union>\<A>); X \<in> \<A>; Y \<in> \<A>\<rbrakk> \<Longrightarrow> disjnt (f ` X) (f ` Y) \<longleftrightarrow> disjnt X Y"
-  apply (auto simp: disjnt_def)
-  using inj_on_eq_iff by fastforce
+ "\<lbrakk>inj_on f (\<Union>\<A>); X \<in> \<A>; Y \<in> \<A>\<rbrakk> \<Longrightarrow> disjnt (f ` X) (f ` Y) \<longleftrightarrow> disjnt X Y"
+  unfolding disjnt_def
+  by safe (use inj_on_eq_iff in \<open>fastforce+\<close>)
 
 lemma disjnt_Union1 [simp]: "disjnt (\<Union>\<A>) B \<longleftrightarrow> (\<forall>A \<in> \<A>. disjnt A B)"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Union2 [simp]: "disjnt B (\<Union>\<A>) \<longleftrightarrow> (\<forall>A \<in> \<A>. disjnt B A)"
   by (auto simp: disjnt_def)
 
 
 subsubsection \<open>Unions of families\<close>
 
 syntax (ASCII)
   "_UNION1"     :: "pttrns => 'b set => 'b set"           ("(3UN _./ _)" [0, 10] 10)
   "_UNION"      :: "pttrn => 'a set => 'b set => 'b set"  ("(3UN _:_./ _)" [0, 0, 10] 10)
 
 syntax
   "_UNION1"     :: "pttrns => 'b set => 'b set"           ("(3\<Union>_./ _)" [0, 10] 10)
   "_UNION"      :: "pttrn => 'a set => 'b set => 'b set"  ("(3\<Union>_\<in>_./ _)" [0, 0, 10] 10)
 
 syntax (latex output)
   "_UNION1"     :: "pttrns => 'b set => 'b set"           ("(3\<Union>(\<open>unbreakable\<close>\<^bsub>_\<^esub>)/ _)" [0, 10] 10)
   "_UNION"      :: "pttrn => 'a set => 'b set => 'b set"  ("(3\<Union>(\<open>unbreakable\<close>\<^bsub>_\<in>_\<^esub>)/ _)" [0, 0, 10] 10)
 
 translations
   "\<Union>x y. f"   \<rightleftharpoons> "\<Union>x. \<Union>y. f"
   "\<Union>x. f"     \<rightleftharpoons> "\<Union>(CONST range (\<lambda>x. f))"
   "\<Union>x\<in>A. f"   \<rightleftharpoons> "CONST Union ((\<lambda>x. f) ` A)"
 
 text \<open>
   Note the difference between ordinary syntax of indexed
   unions and intersections (e.g.\ \<open>\<Union>a\<^sub>1\<in>A\<^sub>1. B\<close>)
   and their \LaTeX\ rendition: \<^term>\<open>\<Union>a\<^sub>1\<in>A\<^sub>1. B\<close>.
 \<close>
 
 lemma disjoint_UN_iff: "disjnt A (\<Union>i\<in>I. B i) \<longleftrightarrow> (\<forall>i\<in>I. disjnt A (B i))"
   by (auto simp: disjnt_def)
 
 lemma UNION_eq: "(\<Union>x\<in>A. B x) = {y. \<exists>x\<in>A. y \<in> B x}"
   by (auto intro!: SUP_eqI)
 
 lemma bind_UNION [code]: "Set.bind A f = \<Union>(f ` A)"
   by (simp add: bind_def UNION_eq)
 
 lemma member_bind [simp]: "x \<in> Set.bind A f \<longleftrightarrow> x \<in> \<Union>(f ` A)"
   by (simp add: bind_UNION)
 
 lemma Union_SetCompr_eq: "\<Union>{f x| x. P x} = {a. \<exists>x. P x \<and> a \<in> f x}"
   by blast
 
 lemma UN_iff [simp]: "b \<in> (\<Union>x\<in>A. B x) \<longleftrightarrow> (\<exists>x\<in>A. b \<in> B x)"
   using Union_iff [of _ "B ` A"] by simp
 
 lemma UN_I [intro]: "a \<in> A \<Longrightarrow> b \<in> B a \<Longrightarrow> b \<in> (\<Union>x\<in>A. B x)"
   \<comment> \<open>The order of the premises presupposes that \<^term>\<open>A\<close> is rigid;
     \<^term>\<open>b\<close> may be flexible.\<close>
   by auto
 
 lemma UN_E [elim!]: "b \<in> (\<Union>x\<in>A. B x) \<Longrightarrow> (\<And>x. x\<in>A \<Longrightarrow> b \<in> B x \<Longrightarrow> R) \<Longrightarrow> R"
   by auto
 
 lemma UN_upper: "a \<in> A \<Longrightarrow> B a \<subseteq> (\<Union>x\<in>A. B x)"
   by (fact SUP_upper)
 
 lemma UN_least: "(\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> C) \<Longrightarrow> (\<Union>x\<in>A. B x) \<subseteq> C"
   by (fact SUP_least)
 
 lemma Collect_bex_eq: "{x. \<exists>y\<in>A. P x y} = (\<Union>y\<in>A. {x. P x y})"
   by blast
 
 lemma UN_insert_distrib: "u \<in> A \<Longrightarrow> (\<Union>x\<in>A. insert a (B x)) = insert a (\<Union>x\<in>A. B x)"
   by blast
 
 lemma UN_empty: "(\<Union>x\<in>{}. B x) = {}"
   by (fact SUP_empty)
 
 lemma UN_empty2: "(\<Union>x\<in>A. {}) = {}"
   by (fact SUP_bot) (* already simp *)
 
 lemma UN_absorb: "k \<in> I \<Longrightarrow> A k \<union> (\<Union>i\<in>I. A i) = (\<Union>i\<in>I. A i)"
   by (fact SUP_absorb)
 
 lemma UN_insert [simp]: "(\<Union>x\<in>insert a A. B x) = B a \<union> \<Union>(B ` A)"
   by (fact SUP_insert)
 
 lemma UN_Un [simp]: "(\<Union>i \<in> A \<union> B. M i) = (\<Union>i\<in>A. M i) \<union> (\<Union>i\<in>B. M i)"
   by (fact SUP_union)
 
 lemma UN_UN_flatten: "(\<Union>x \<in> (\<Union>y\<in>A. B y). C x) = (\<Union>y\<in>A. \<Union>x\<in>B y. C x)"
   by blast
 
 lemma UN_subset_iff: "((\<Union>i\<in>I. A i) \<subseteq> B) = (\<forall>i\<in>I. A i \<subseteq> B)"
   by (fact SUP_le_iff)
 
 lemma UN_constant [simp]: "(\<Union>y\<in>A. c) = (if A = {} then {} else c)"
   by (fact SUP_constant)
 
 lemma UNION_singleton_eq_range: "(\<Union>x\<in>A. {f x}) = f ` A"
   by blast
 
 lemma image_Union: "f ` \<Union>S = (\<Union>x\<in>S. f ` x)"
   by blast
 
 lemma UNION_empty_conv:
   "{} = (\<Union>x\<in>A. B x) \<longleftrightarrow> (\<forall>x\<in>A. B x = {})"
   "(\<Union>x\<in>A. B x) = {} \<longleftrightarrow> (\<forall>x\<in>A. B x = {})"
   by (fact SUP_bot_conv)+ (* already simp *)
 
 lemma Collect_ex_eq: "{x. \<exists>y. P x y} = (\<Union>y. {x. P x y})"
   by blast
 
 lemma ball_UN: "(\<forall>z \<in> \<Union>(B ` A). P z) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>z \<in> B x. P z)"
   by blast
 
 lemma bex_UN: "(\<exists>z \<in> \<Union>(B ` A). P z) \<longleftrightarrow> (\<exists>x\<in>A. \<exists>z\<in>B x. P z)"
   by blast
 
 lemma Un_eq_UN: "A \<union> B = (\<Union>b. if b then A else B)"
   by safe (auto simp add: if_split_mem2)
 
 lemma UN_bool_eq: "(\<Union>b. A b) = (A True \<union> A False)"
   by (fact SUP_UNIV_bool_expand)
 
 lemma UN_Pow_subset: "(\<Union>x\<in>A. Pow (B x)) \<subseteq> Pow (\<Union>x\<in>A. B x)"
   by blast
 
 lemma UN_mono:
   "A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<subseteq> g x) \<Longrightarrow>
     (\<Union>x\<in>A. f x) \<subseteq> (\<Union>x\<in>B. g x)"
   by (fact SUP_subset_mono)
 
 lemma vimage_Union: "f -` (\<Union>A) = (\<Union>X\<in>A. f -` X)"
   by blast
 
 lemma vimage_UN: "f -` (\<Union>x\<in>A. B x) = (\<Union>x\<in>A. f -` B x)"
   by blast
 
 lemma vimage_eq_UN: "f -` B = (\<Union>y\<in>B. f -` {y})"
   \<comment> \<open>NOT suitable for rewriting\<close>
   by blast
 
 lemma image_UN: "f ` \<Union>(B ` A) = (\<Union>x\<in>A. f ` B x)"
   by blast
 
 lemma UN_singleton [simp]: "(\<Union>x\<in>A. {x}) = A"
   by blast
 
 lemma inj_on_image: "inj_on f (\<Union>A) \<Longrightarrow> inj_on ((`) f) A"
   unfolding inj_on_def by blast
 
 
 subsubsection \<open>Distributive laws\<close>
 
 lemma Int_Union: "A \<inter> \<Union>B = (\<Union>C\<in>B. A \<inter> C)"
   by blast
 
 lemma Un_Inter: "A \<union> \<Inter>B = (\<Inter>C\<in>B. A \<union> C)"
   by blast
 
 lemma Int_Union2: "\<Union>B \<inter> A = (\<Union>C\<in>B. C \<inter> A)"
   by blast
 
 lemma INT_Int_distrib: "(\<Inter>i\<in>I. A i \<inter> B i) = (\<Inter>i\<in>I. A i) \<inter> (\<Inter>i\<in>I. B i)"
   by (rule sym) (rule INF_inf_distrib)
 
 lemma UN_Un_distrib: "(\<Union>i\<in>I. A i \<union> B i) = (\<Union>i\<in>I. A i) \<union> (\<Union>i\<in>I. B i)"
   by (rule sym) (rule SUP_sup_distrib)
 
 lemma Int_Inter_image: "(\<Inter>x\<in>C. A x \<inter> B x) = \<Inter>(A ` C) \<inter> \<Inter>(B ` C)"  (* FIXME drop *)
   by (simp add: INT_Int_distrib)
 
 lemma Int_Inter_eq: "A \<inter> \<Inter>\<B> = (if \<B>={} then A else (\<Inter>B\<in>\<B>. A \<inter> B))"
                     "\<Inter>\<B> \<inter> A = (if \<B>={} then A else (\<Inter>B\<in>\<B>. B \<inter> A))"
   by auto
 
 lemma Un_Union_image: "(\<Union>x\<in>C. A x \<union> B x) = \<Union>(A ` C) \<union> \<Union>(B ` C)"  (* FIXME drop *)
   \<comment> \<open>Devlin, Fundamentals of Contemporary Set Theory, page 12, exercise 5:\<close>
   \<comment> \<open>Union of a family of unions\<close>
   by (simp add: UN_Un_distrib)
 
 lemma Un_INT_distrib: "B \<union> (\<Inter>i\<in>I. A i) = (\<Inter>i\<in>I. B \<union> A i)"
   by blast
 
 lemma Int_UN_distrib: "B \<inter> (\<Union>i\<in>I. A i) = (\<Union>i\<in>I. B \<inter> A i)"
   \<comment> \<open>Halmos, Naive Set Theory, page 35.\<close>
   by blast
 
 lemma Int_UN_distrib2: "(\<Union>i\<in>I. A i) \<inter> (\<Union>j\<in>J. B j) = (\<Union>i\<in>I. \<Union>j\<in>J. A i \<inter> B j)"
   by blast
 
 lemma Un_INT_distrib2: "(\<Inter>i\<in>I. A i) \<union> (\<Inter>j\<in>J. B j) = (\<Inter>i\<in>I. \<Inter>j\<in>J. A i \<union> B j)"
   by blast
 
 lemma Union_disjoint: "(\<Union>C \<inter> A = {}) \<longleftrightarrow> (\<forall>B\<in>C. B \<inter> A = {})"
   by blast
 
 lemma SUP_UNION: "(\<Squnion>x\<in>(\<Union>y\<in>A. g y). f x) = (\<Squnion>y\<in>A. \<Squnion>x\<in>g y. f x :: _ :: complete_lattice)"
   by (rule order_antisym) (blast intro: SUP_least SUP_upper2)+
 
 
 subsection \<open>Injections and bijections\<close>
 
 lemma inj_on_Inter: "S \<noteq> {} \<Longrightarrow> (\<And>A. A \<in> S \<Longrightarrow> inj_on f A) \<Longrightarrow> inj_on f (\<Inter>S)"
   unfolding inj_on_def by blast
 
 lemma inj_on_INTER: "I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> inj_on f (A i)) \<Longrightarrow> inj_on f (\<Inter>i \<in> I. A i)"
   unfolding inj_on_def by safe simp
 
 lemma inj_on_UNION_chain:
   assumes chain: "\<And>i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> A i \<le> A j \<or> A j \<le> A i"
     and inj: "\<And>i. i \<in> I \<Longrightarrow> inj_on f (A i)"
   shows "inj_on f (\<Union>i \<in> I. A i)"
 proof -
   have "x = y"
     if *: "i \<in> I" "j \<in> I"
     and **: "x \<in> A i" "y \<in> A j"
     and ***: "f x = f y"
     for i j x y
     using chain [OF *]
   proof
     assume "A i \<le> A j"
     with ** have "x \<in> A j" by auto
     with inj * ** *** show ?thesis
       by (auto simp add: inj_on_def)
   next
     assume "A j \<le> A i"
     with ** have "y \<in> A i" by auto
     with inj * ** *** show ?thesis
       by (auto simp add: inj_on_def)
   qed
   then show ?thesis
     by (unfold inj_on_def UNION_eq) auto
 qed
 
 lemma bij_betw_UNION_chain:
   assumes chain: "\<And>i j. i \<in> I \<Longrightarrow> j \<in> I \<Longrightarrow> A i \<le> A j \<or> A j \<le> A i"
     and bij: "\<And>i. i \<in> I \<Longrightarrow> bij_betw f (A i) (A' i)"
   shows "bij_betw f (\<Union>i \<in> I. A i) (\<Union>i \<in> I. A' i)"
   unfolding bij_betw_def
 proof safe
   have "\<And>i. i \<in> I \<Longrightarrow> inj_on f (A i)"
     using bij bij_betw_def[of f] by auto
   then show "inj_on f (\<Union>(A ` I))"
     using chain inj_on_UNION_chain[of I A f] by auto
 next
   fix i x
   assume *: "i \<in> I" "x \<in> A i"
   with bij have "f x \<in> A' i"
     by (auto simp: bij_betw_def)
   with * show "f x \<in> \<Union>(A' ` I)" by blast
 next
   fix i x'
   assume *: "i \<in> I" "x' \<in> A' i"
   with bij have "\<exists>x \<in> A i. x' = f x"
     unfolding bij_betw_def by blast
   with * have "\<exists>j \<in> I. \<exists>x \<in> A j. x' = f x"
     by blast
   then show "x' \<in> f ` \<Union>(A ` I)"
     by blast
 qed
 
 (*injectivity's required.  Left-to-right inclusion holds even if A is empty*)
 lemma image_INT: "inj_on f C \<Longrightarrow> \<forall>x\<in>A. B x \<subseteq> C \<Longrightarrow> j \<in> A \<Longrightarrow> f ` (\<Inter>(B ` A)) = (\<Inter>x\<in>A. f ` B x)"
   by (auto simp add: inj_on_def) blast
 
 lemma bij_image_INT: "bij f \<Longrightarrow> f ` (\<Inter>(B ` A)) = (\<Inter>x\<in>A. f ` B x)"
   by (auto simp: bij_def inj_def surj_def) blast
 
 lemma UNION_fun_upd: "\<Union>(A(i := B) ` J) = \<Union>(A ` (J - {i})) \<union> (if i \<in> J then B else {})"
   by (auto simp add: set_eq_iff)
 
 lemma bij_betw_Pow:
   assumes "bij_betw f A B"
   shows "bij_betw (image f) (Pow A) (Pow B)"
 proof -
   from assms have "inj_on f A"
     by (rule bij_betw_imp_inj_on)
   then have "inj_on f (\<Union>(Pow A))"
     by simp
   then have "inj_on (image f) (Pow A)"
     by (rule inj_on_image)
   then have "bij_betw (image f) (Pow A) (image f ` Pow A)"
     by (rule inj_on_imp_bij_betw)
   moreover from assms have "f ` A = B"
     by (rule bij_betw_imp_surj_on)
   then have "image f ` Pow A = Pow B"
     by (rule image_Pow_surj)
   ultimately show ?thesis by simp
 qed
 
 
 subsubsection \<open>Complement\<close>
 
 lemma Compl_INT [simp]: "- (\<Inter>x\<in>A. B x) = (\<Union>x\<in>A. -B x)"
   by blast
 
 lemma Compl_UN [simp]: "- (\<Union>x\<in>A. B x) = (\<Inter>x\<in>A. -B x)"
   by blast
 
 subsubsection \<open>Miniscoping and maxiscoping\<close>
 
 text \<open>\<^medskip> Miniscoping: pushing in quantifiers and big Unions and Intersections.\<close>
 
 lemma UN_simps [simp]:
   "\<And>a B C. (\<Union>x\<in>C. insert a (B x)) = (if C={} then {} else insert a (\<Union>x\<in>C. B x))"
   "\<And>A B C. (\<Union>x\<in>C. A x \<union> B) = ((if C={} then {} else (\<Union>x\<in>C. A x) \<union> B))"
   "\<And>A B C. (\<Union>x\<in>C. A \<union> B x) = ((if C={} then {} else A \<union> (\<Union>x\<in>C. B x)))"
   "\<And>A B C. (\<Union>x\<in>C. A x \<inter> B) = ((\<Union>x\<in>C. A x) \<inter> B)"
   "\<And>A B C. (\<Union>x\<in>C. A \<inter> B x) = (A \<inter>(\<Union>x\<in>C. B x))"
   "\<And>A B C. (\<Union>x\<in>C. A x - B) = ((\<Union>x\<in>C. A x) - B)"
   "\<And>A B C. (\<Union>x\<in>C. A - B x) = (A - (\<Inter>x\<in>C. B x))"
   "\<And>A B. (\<Union>x\<in>\<Union>A. B x) = (\<Union>y\<in>A. \<Union>x\<in>y. B x)"
   "\<And>A B C. (\<Union>z\<in>(\<Union>(B ` A)). C z) = (\<Union>x\<in>A. \<Union>z\<in>B x. C z)"
   "\<And>A B f. (\<Union>x\<in>f`A. B x) = (\<Union>a\<in>A. B (f a))"
   by auto
 
 lemma INT_simps [simp]:
   "\<And>A B C. (\<Inter>x\<in>C. A x \<inter> B) = (if C={} then UNIV else (\<Inter>x\<in>C. A x) \<inter> B)"
   "\<And>A B C. (\<Inter>x\<in>C. A \<inter> B x) = (if C={} then UNIV else A \<inter>(\<Inter>x\<in>C. B x))"
   "\<And>A B C. (\<Inter>x\<in>C. A x - B) = (if C={} then UNIV else (\<Inter>x\<in>C. A x) - B)"
   "\<And>A B C. (\<Inter>x\<in>C. A - B x) = (if C={} then UNIV else A - (\<Union>x\<in>C. B x))"
   "\<And>a B C. (\<Inter>x\<in>C. insert a (B x)) = insert a (\<Inter>x\<in>C. B x)"
   "\<And>A B C. (\<Inter>x\<in>C. A x \<union> B) = ((\<Inter>x\<in>C. A x) \<union> B)"
   "\<And>A B C. (\<Inter>x\<in>C. A \<union> B x) = (A \<union> (\<Inter>x\<in>C. B x))"
   "\<And>A B. (\<Inter>x\<in>\<Union>A. B x) = (\<Inter>y\<in>A. \<Inter>x\<in>y. B x)"
   "\<And>A B C. (\<Inter>z\<in>(\<Union>(B ` A)). C z) = (\<Inter>x\<in>A. \<Inter>z\<in>B x. C z)"
   "\<And>A B f. (\<Inter>x\<in>f`A. B x) = (\<Inter>a\<in>A. B (f a))"
   by auto
 
 lemma UN_ball_bex_simps [simp]:
   "\<And>A P. (\<forall>x\<in>\<Union>A. P x) \<longleftrightarrow> (\<forall>y\<in>A. \<forall>x\<in>y. P x)"
   "\<And>A B P. (\<forall>x\<in>(\<Union>(B ` A)). P x) = (\<forall>a\<in>A. \<forall>x\<in> B a. P x)"
   "\<And>A P. (\<exists>x\<in>\<Union>A. P x) \<longleftrightarrow> (\<exists>y\<in>A. \<exists>x\<in>y. P x)"
   "\<And>A B P. (\<exists>x\<in>(\<Union>(B ` A)). P x) \<longleftrightarrow> (\<exists>a\<in>A. \<exists>x\<in>B a. P x)"
   by auto
 
 
 text \<open>\<^medskip> Maxiscoping: pulling out big Unions and Intersections.\<close>
 
 lemma UN_extend_simps:
   "\<And>a B C. insert a (\<Union>x\<in>C. B x) = (if C={} then {a} else (\<Union>x\<in>C. insert a (B x)))"
   "\<And>A B C. (\<Union>x\<in>C. A x) \<union> B = (if C={} then B else (\<Union>x\<in>C. A x \<union> B))"
   "\<And>A B C. A \<union> (\<Union>x\<in>C. B x) = (if C={} then A else (\<Union>x\<in>C. A \<union> B x))"
   "\<And>A B C. ((\<Union>x\<in>C. A x) \<inter> B) = (\<Union>x\<in>C. A x \<inter> B)"
   "\<And>A B C. (A \<inter> (\<Union>x\<in>C. B x)) = (\<Union>x\<in>C. A \<inter> B x)"
   "\<And>A B C. ((\<Union>x\<in>C. A x) - B) = (\<Union>x\<in>C. A x - B)"
   "\<And>A B C. (A - (\<Inter>x\<in>C. B x)) = (\<Union>x\<in>C. A - B x)"
   "\<And>A B. (\<Union>y\<in>A. \<Union>x\<in>y. B x) = (\<Union>x\<in>\<Union>A. B x)"
   "\<And>A B C. (\<Union>x\<in>A. \<Union>z\<in>B x. C z) = (\<Union>z\<in>(\<Union>(B ` A)). C z)"
   "\<And>A B f. (\<Union>a\<in>A. B (f a)) = (\<Union>x\<in>f`A. B x)"
   by auto
 
 lemma INT_extend_simps:
   "\<And>A B C. (\<Inter>x\<in>C. A x) \<inter> B = (if C={} then B else (\<Inter>x\<in>C. A x \<inter> B))"
   "\<And>A B C. A \<inter> (\<Inter>x\<in>C. B x) = (if C={} then A else (\<Inter>x\<in>C. A \<inter> B x))"
   "\<And>A B C. (\<Inter>x\<in>C. A x) - B = (if C={} then UNIV - B else (\<Inter>x\<in>C. A x - B))"
   "\<And>A B C. A - (\<Union>x\<in>C. B x) = (if C={} then A else (\<Inter>x\<in>C. A - B x))"
   "\<And>a B C. insert a (\<Inter>x\<in>C. B x) = (\<Inter>x\<in>C. insert a (B x))"
   "\<And>A B C. ((\<Inter>x\<in>C. A x) \<union> B) = (\<Inter>x\<in>C. A x \<union> B)"
   "\<And>A B C. A \<union> (\<Inter>x\<in>C. B x) = (\<Inter>x\<in>C. A \<union> B x)"
   "\<And>A B. (\<Inter>y\<in>A. \<Inter>x\<in>y. B x) = (\<Inter>x\<in>\<Union>A. B x)"
   "\<And>A B C. (\<Inter>x\<in>A. \<Inter>z\<in>B x. C z) = (\<Inter>z\<in>(\<Union>(B ` A)). C z)"
   "\<And>A B f. (\<Inter>a\<in>A. B (f a)) = (\<Inter>x\<in>f`A. B x)"
   by auto
 
 text \<open>Finally\<close>
 
 lemmas mem_simps =
   insert_iff empty_iff Un_iff Int_iff Compl_iff Diff_iff
   mem_Collect_eq UN_iff Union_iff INT_iff Inter_iff
   \<comment> \<open>Each of these has ALREADY been added \<open>[simp]\<close> above.\<close>
 
 end
diff --git a/src/HOL/Conditionally_Complete_Lattices.thy b/src/HOL/Conditionally_Complete_Lattices.thy
--- a/src/HOL/Conditionally_Complete_Lattices.thy
+++ b/src/HOL/Conditionally_Complete_Lattices.thy
@@ -1,842 +1,840 @@
 (*  Title:      HOL/Conditionally_Complete_Lattices.thy
     Author:     Amine Chaieb and L C Paulson, University of Cambridge
     Author:     Johannes Hölzl, TU München
     Author:     Luke S. Serafin, Carnegie Mellon University
 *)
 
 section \<open>Conditionally-complete Lattices\<close>
 
 theory Conditionally_Complete_Lattices
 imports Finite_Set Lattices_Big Set_Interval
 begin
 
 locale preordering_bdd = preordering
 begin
 
 definition bdd :: \<open>'a set \<Rightarrow> bool\<close>
   where unfold: \<open>bdd A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<^bold>\<le> M)\<close>
 
 lemma empty [simp, intro]:
   \<open>bdd {}\<close>
   by (simp add: unfold)
 
 lemma I [intro]:
   \<open>bdd A\<close> if \<open>\<And>x. x \<in> A \<Longrightarrow> x \<^bold>\<le> M\<close>
   using that by (auto simp add: unfold)
 
 lemma E:
   assumes \<open>bdd A\<close>
   obtains M where \<open>\<And>x. x \<in> A \<Longrightarrow> x \<^bold>\<le> M\<close>
   using assms that by (auto simp add: unfold)
 
 lemma I2:
   \<open>bdd (f ` A)\<close> if \<open>\<And>x. x \<in> A \<Longrightarrow> f x \<^bold>\<le> M\<close>
   using that by (auto simp add: unfold)
 
 lemma mono:
   \<open>bdd A\<close> if \<open>bdd B\<close> \<open>A \<subseteq> B\<close>
   using that by (auto simp add: unfold)
 
 lemma Int1 [simp]:
   \<open>bdd (A \<inter> B)\<close> if \<open>bdd A\<close>
   using mono that by auto
 
 lemma Int2 [simp]:
   \<open>bdd (A \<inter> B)\<close> if \<open>bdd B\<close>
   using mono that by auto
 
 end
 
 subsection \<open>Preorders\<close>
 
 context preorder
 begin
 
 sublocale bdd_above: preordering_bdd \<open>(\<le>)\<close> \<open>(<)\<close>
   defines bdd_above_primitive_def: bdd_above = bdd_above.bdd ..
 
 sublocale bdd_below: preordering_bdd \<open>(\<ge>)\<close> \<open>(>)\<close>
   defines bdd_below_primitive_def: bdd_below = bdd_below.bdd ..
 
 lemma bdd_above_def: \<open>bdd_above A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. x \<le> M)\<close>
   by (fact bdd_above.unfold)
 
 lemma bdd_below_def: \<open>bdd_below A \<longleftrightarrow> (\<exists>M. \<forall>x \<in> A. M \<le> x)\<close>
   by (fact bdd_below.unfold)
 
 lemma bdd_aboveI: "(\<And>x. x \<in> A \<Longrightarrow> x \<le> M) \<Longrightarrow> bdd_above A"
   by (fact bdd_above.I)
 
 lemma bdd_belowI: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> x) \<Longrightarrow> bdd_below A"
   by (fact bdd_below.I)
 
 lemma bdd_aboveI2: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> bdd_above (f`A)"
   by (fact bdd_above.I2)
 
 lemma bdd_belowI2: "(\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> bdd_below (f`A)"
   by (fact bdd_below.I2)
 
 lemma bdd_above_empty: "bdd_above {}"
   by (fact bdd_above.empty)
 
 lemma bdd_below_empty: "bdd_below {}"
   by (fact bdd_below.empty)
 
 lemma bdd_above_mono: "bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_above A"
   by (fact bdd_above.mono)
 
 lemma bdd_below_mono: "bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> bdd_below A"
   by (fact bdd_below.mono)
 
 lemma bdd_above_Int1: "bdd_above A \<Longrightarrow> bdd_above (A \<inter> B)"
   by (fact bdd_above.Int1)
 
 lemma bdd_above_Int2: "bdd_above B \<Longrightarrow> bdd_above (A \<inter> B)"
   by (fact bdd_above.Int2)
 
 lemma bdd_below_Int1: "bdd_below A \<Longrightarrow> bdd_below (A \<inter> B)"
   by (fact bdd_below.Int1)
 
 lemma bdd_below_Int2: "bdd_below B \<Longrightarrow> bdd_below (A \<inter> B)"
   by (fact bdd_below.Int2)
 
 lemma bdd_above_Ioo [simp, intro]: "bdd_above {a <..< b}"
   by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)
 
 lemma bdd_above_Ico [simp, intro]: "bdd_above {a ..< b}"
   by (auto simp add: bdd_above_def intro!: exI[of _ b] less_imp_le)
 
 lemma bdd_above_Iio [simp, intro]: "bdd_above {..< b}"
   by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
 
 lemma bdd_above_Ioc [simp, intro]: "bdd_above {a <.. b}"
   by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
 
 lemma bdd_above_Icc [simp, intro]: "bdd_above {a .. b}"
   by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
 
 lemma bdd_above_Iic [simp, intro]: "bdd_above {.. b}"
   by (auto simp add: bdd_above_def intro: exI[of _ b] less_imp_le)
 
 lemma bdd_below_Ioo [simp, intro]: "bdd_below {a <..< b}"
   by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)
 
 lemma bdd_below_Ioc [simp, intro]: "bdd_below {a <.. b}"
   by (auto simp add: bdd_below_def intro!: exI[of _ a] less_imp_le)
 
 lemma bdd_below_Ioi [simp, intro]: "bdd_below {a <..}"
   by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
 
 lemma bdd_below_Ico [simp, intro]: "bdd_below {a ..< b}"
   by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
 
 lemma bdd_below_Icc [simp, intro]: "bdd_below {a .. b}"
   by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
 
 lemma bdd_below_Ici [simp, intro]: "bdd_below {a ..}"
   by (auto simp add: bdd_below_def intro: exI[of _ a] less_imp_le)
 
 end
 
 context order_top
 begin
 
 lemma bdd_above_top [simp, intro!]: "bdd_above A"
   by (rule bdd_aboveI [of _ top]) simp
 
 end
 
 context order_bot
 begin
 
 lemma bdd_below_bot [simp, intro!]: "bdd_below A"
   by (rule bdd_belowI [of _ bot]) simp
 
 end
 
 lemma bdd_above_image_mono: "mono f \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_above (f`A)"
   by (auto simp: bdd_above_def mono_def)
 
 lemma bdd_below_image_mono: "mono f \<Longrightarrow> bdd_below A \<Longrightarrow> bdd_below (f`A)"
   by (auto simp: bdd_below_def mono_def)
 
 lemma bdd_above_image_antimono: "antimono f \<Longrightarrow> bdd_below A \<Longrightarrow> bdd_above (f`A)"
   by (auto simp: bdd_above_def bdd_below_def antimono_def)
 
 lemma bdd_below_image_antimono: "antimono f \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_below (f`A)"
   by (auto simp: bdd_above_def bdd_below_def antimono_def)
 
 lemma
   fixes X :: "'a::ordered_ab_group_add set"
   shows bdd_above_uminus[simp]: "bdd_above (uminus ` X) \<longleftrightarrow> bdd_below X"
     and bdd_below_uminus[simp]: "bdd_below (uminus ` X) \<longleftrightarrow> bdd_above X"
   using bdd_above_image_antimono[of uminus X] bdd_below_image_antimono[of uminus "uminus`X"]
   using bdd_below_image_antimono[of uminus X] bdd_above_image_antimono[of uminus "uminus`X"]
   by (auto simp: antimono_def image_image)
 
 subsection \<open>Lattices\<close>
 
 context lattice
 begin
 
 lemma bdd_above_insert [simp]: "bdd_above (insert a A) = bdd_above A"
   by (auto simp: bdd_above_def intro: le_supI2 sup_ge1)
 
 lemma bdd_below_insert [simp]: "bdd_below (insert a A) = bdd_below A"
   by (auto simp: bdd_below_def intro: le_infI2 inf_le1)
 
 lemma bdd_finite [simp]:
   assumes "finite A" shows bdd_above_finite: "bdd_above A" and bdd_below_finite: "bdd_below A"
   using assms by (induct rule: finite_induct, auto)
 
 lemma bdd_above_Un [simp]: "bdd_above (A \<union> B) = (bdd_above A \<and> bdd_above B)"
 proof
   assume "bdd_above (A \<union> B)"
   thus "bdd_above A \<and> bdd_above B" unfolding bdd_above_def by auto
 next
   assume "bdd_above A \<and> bdd_above B"
   then obtain a b where "\<forall>x\<in>A. x \<le> a" "\<forall>x\<in>B. x \<le> b" unfolding bdd_above_def by auto
   hence "\<forall>x \<in> A \<union> B. x \<le> sup a b" by (auto intro: Un_iff le_supI1 le_supI2)
   thus "bdd_above (A \<union> B)" unfolding bdd_above_def ..
 qed
 
 lemma bdd_below_Un [simp]: "bdd_below (A \<union> B) = (bdd_below A \<and> bdd_below B)"
 proof
   assume "bdd_below (A \<union> B)"
   thus "bdd_below A \<and> bdd_below B" unfolding bdd_below_def by auto
 next
   assume "bdd_below A \<and> bdd_below B"
   then obtain a b where "\<forall>x\<in>A. a \<le> x" "\<forall>x\<in>B. b \<le> x" unfolding bdd_below_def by auto
   hence "\<forall>x \<in> A \<union> B. inf a b \<le> x" by (auto intro: Un_iff le_infI1 le_infI2)
   thus "bdd_below (A \<union> B)" unfolding bdd_below_def ..
 qed
 
 lemma bdd_above_image_sup[simp]:
   "bdd_above ((\<lambda>x. sup (f x) (g x)) ` A) \<longleftrightarrow> bdd_above (f`A) \<and> bdd_above (g`A)"
 by (auto simp: bdd_above_def intro: le_supI1 le_supI2)
 
 lemma bdd_below_image_inf[simp]:
   "bdd_below ((\<lambda>x. inf (f x) (g x)) ` A) \<longleftrightarrow> bdd_below (f`A) \<and> bdd_below (g`A)"
 by (auto simp: bdd_below_def intro: le_infI1 le_infI2)
 
 lemma bdd_below_UN[simp]: "finite I \<Longrightarrow> bdd_below (\<Union>i\<in>I. A i) = (\<forall>i \<in> I. bdd_below (A i))"
 by (induction I rule: finite.induct) auto
 
 lemma bdd_above_UN[simp]: "finite I \<Longrightarrow> bdd_above (\<Union>i\<in>I. A i) = (\<forall>i \<in> I. bdd_above (A i))"
 by (induction I rule: finite.induct) auto
 
 end
 
 
 text \<open>
 
 To avoid name classes with the \<^class>\<open>complete_lattice\<close>-class we prefix \<^const>\<open>Sup\<close> and
 \<^const>\<open>Inf\<close> in theorem names with c.
 
 \<close>
 
 subsection \<open>Conditionally complete lattices\<close>
 
 class conditionally_complete_lattice = lattice + Sup + Inf +
   assumes cInf_lower: "x \<in> X \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> x"
     and cInf_greatest: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf X"
   assumes cSup_upper: "x \<in> X \<Longrightarrow> bdd_above X \<Longrightarrow> x \<le> Sup X"
     and cSup_least: "X \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X \<le> z"
 begin
 
 lemma cSup_upper2: "x \<in> X \<Longrightarrow> y \<le> x \<Longrightarrow> bdd_above X \<Longrightarrow> y \<le> Sup X"
   by (metis cSup_upper order_trans)
 
 lemma cInf_lower2: "x \<in> X \<Longrightarrow> x \<le> y \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X \<le> y"
   by (metis cInf_lower order_trans)
 
 lemma cSup_mono: "B \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. b \<le> a) \<Longrightarrow> Sup B \<le> Sup A"
   by (metis cSup_least cSup_upper2)
 
 lemma cInf_mono: "B \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> (\<And>b. b \<in> B \<Longrightarrow> \<exists>a\<in>A. a \<le> b) \<Longrightarrow> Inf A \<le> Inf B"
   by (metis cInf_greatest cInf_lower2)
 
 lemma cSup_subset_mono: "A \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Sup A \<le> Sup B"
   by (metis cSup_least cSup_upper subsetD)
 
 lemma cInf_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> Inf B \<le> Inf A"
   by (metis cInf_greatest cInf_lower subsetD)
 
 lemma cSup_eq_maximum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup X = z"
   by (intro order.antisym cSup_upper[of z X] cSup_least[of X z]) auto
 
 lemma cInf_eq_minimum: "z \<in> X \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> z \<le> x) \<Longrightarrow> Inf X = z"
   by (intro order.antisym cInf_lower[of z X] cInf_greatest[of X z]) auto
 
 lemma cSup_le_iff: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S \<le> a \<longleftrightarrow> (\<forall>x\<in>S. x \<le> a)"
   by (metis order_trans cSup_upper cSup_least)
 
 lemma le_cInf_iff: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> a \<le> Inf S \<longleftrightarrow> (\<forall>x\<in>S. a \<le> x)"
   by (metis order_trans cInf_lower cInf_greatest)
 
 lemma cSup_eq_non_empty:
   assumes 1: "X \<noteq> {}"
   assumes 2: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
   assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
   shows "Sup X = a"
   by (intro 3 1 order.antisym cSup_least) (auto intro: 2 1 cSup_upper)
 
 lemma cInf_eq_non_empty:
   assumes 1: "X \<noteq> {}"
   assumes 2: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
   assumes 3: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
   shows "Inf X = a"
   by (intro 3 1 order.antisym cInf_greatest) (auto intro: 2 1 cInf_lower)
 
 lemma cInf_cSup: "S \<noteq> {} \<Longrightarrow> bdd_below S \<Longrightarrow> Inf S = Sup {x. \<forall>s\<in>S. x \<le> s}"
   by (rule cInf_eq_non_empty) (auto intro!: cSup_upper cSup_least simp: bdd_below_def)
 
 lemma cSup_cInf: "S \<noteq> {} \<Longrightarrow> bdd_above S \<Longrightarrow> Sup S = Inf {x. \<forall>s\<in>S. s \<le> x}"
   by (rule cSup_eq_non_empty) (auto intro!: cInf_lower cInf_greatest simp: bdd_above_def)
 
 lemma cSup_insert: "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> Sup (insert a X) = sup a (Sup X)"
   by (intro cSup_eq_non_empty) (auto intro: le_supI2 cSup_upper cSup_least)
 
 lemma cInf_insert: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf (insert a X) = inf a (Inf X)"
   by (intro cInf_eq_non_empty) (auto intro: le_infI2 cInf_lower cInf_greatest)
 
 lemma cSup_singleton [simp]: "Sup {x} = x"
   by (intro cSup_eq_maximum) auto
 
 lemma cInf_singleton [simp]: "Inf {x} = x"
   by (intro cInf_eq_minimum) auto
 
 lemma cSup_insert_If:  "bdd_above X \<Longrightarrow> Sup (insert a X) = (if X = {} then a else sup a (Sup X))"
   using cSup_insert[of X] by simp
 
 lemma cInf_insert_If: "bdd_below X \<Longrightarrow> Inf (insert a X) = (if X = {} then a else inf a (Inf X))"
   using cInf_insert[of X] by simp
 
 lemma le_cSup_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> x \<le> Sup X"
 proof (induct X arbitrary: x rule: finite_induct)
   case (insert x X y) then show ?case
     by (cases "X = {}") (auto simp: cSup_insert intro: le_supI2)
 qed simp
 
 lemma cInf_le_finite: "finite X \<Longrightarrow> x \<in> X \<Longrightarrow> Inf X \<le> x"
 proof (induct X arbitrary: x rule: finite_induct)
   case (insert x X y) then show ?case
     by (cases "X = {}") (auto simp: cInf_insert intro: le_infI2)
 qed simp
 
 lemma cSup_eq_Sup_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Sup_fin X"
   by (induct X rule: finite_ne_induct) (simp_all add: cSup_insert)
 
 lemma cInf_eq_Inf_fin: "finite X \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Inf_fin X"
   by (induct X rule: finite_ne_induct) (simp_all add: cInf_insert)
 
 lemma cSup_atMost[simp]: "Sup {..x} = x"
   by (auto intro!: cSup_eq_maximum)
 
 lemma cSup_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Sup {y<..x} = x"
   by (auto intro!: cSup_eq_maximum)
 
 lemma cSup_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Sup {y..x} = x"
   by (auto intro!: cSup_eq_maximum)
 
 lemma cInf_atLeast[simp]: "Inf {x..} = x"
   by (auto intro!: cInf_eq_minimum)
 
 lemma cInf_atLeastLessThan[simp]: "y < x \<Longrightarrow> Inf {y..<x} = y"
   by (auto intro!: cInf_eq_minimum)
 
 lemma cInf_atLeastAtMost[simp]: "y \<le> x \<Longrightarrow> Inf {y..x} = y"
   by (auto intro!: cInf_eq_minimum)
 
 lemma cINF_lower: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> \<Sqinter>(f ` A) \<le> f x"
   using cInf_lower [of _ "f ` A"] by simp
 
 lemma cINF_greatest: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> m \<le> f x) \<Longrightarrow> m \<le> \<Sqinter>(f ` A)"
   using cInf_greatest [of "f ` A"] by auto
 
 lemma cSUP_upper: "x \<in> A \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> f x \<le> \<Squnion>(f ` A)"
   using cSup_upper [of _ "f ` A"] by simp
 
 lemma cSUP_least: "A \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<le> M) \<Longrightarrow> \<Squnion>(f ` A) \<le> M"
   using cSup_least [of "f ` A"] by auto
 
 lemma cINF_lower2: "bdd_below (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> f x \<le> u \<Longrightarrow> \<Sqinter>(f ` A) \<le> u"
   by (auto intro: cINF_lower order_trans)
 
 lemma cSUP_upper2: "bdd_above (f ` A) \<Longrightarrow> x \<in> A \<Longrightarrow> u \<le> f x \<Longrightarrow> u \<le> \<Squnion>(f ` A)"
   by (auto intro: cSUP_upper order_trans)
 
 lemma cSUP_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Squnion>x\<in>A. c) = c"
   by (intro order.antisym cSUP_least) (auto intro: cSUP_upper)
 
 lemma cINF_const [simp]: "A \<noteq> {} \<Longrightarrow> (\<Sqinter>x\<in>A. c) = c"
   by (intro order.antisym cINF_greatest) (auto intro: cINF_lower)
 
 lemma le_cINF_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> u \<le> \<Sqinter>(f ` A) \<longleftrightarrow> (\<forall>x\<in>A. u \<le> f x)"
   by (metis cINF_greatest cINF_lower order_trans)
 
 lemma cSUP_le_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> \<Squnion>(f ` A) \<le> u \<longleftrightarrow> (\<forall>x\<in>A. f x \<le> u)"
   by (metis cSUP_least cSUP_upper order_trans)
 
 lemma less_cINF_D: "bdd_below (f`A) \<Longrightarrow> y < (\<Sqinter>i\<in>A. f i) \<Longrightarrow> i \<in> A \<Longrightarrow> y < f i"
   by (metis cINF_lower less_le_trans)
 
 lemma cSUP_lessD: "bdd_above (f`A) \<Longrightarrow> (\<Squnion>i\<in>A. f i) < y \<Longrightarrow> i \<in> A \<Longrightarrow> f i < y"
   by (metis cSUP_upper le_less_trans)
 
 lemma cINF_insert: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> \<Sqinter>(f ` insert a A) = inf (f a) (\<Sqinter>(f ` A))"
   by (simp add: cInf_insert)
 
 lemma cSUP_insert: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> \<Squnion>(f ` insert a A) = sup (f a) (\<Squnion>(f ` A))"
   by (simp add: cSup_insert)
 
 lemma cINF_mono: "B \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> (\<And>m. m \<in> B \<Longrightarrow> \<exists>n\<in>A. f n \<le> g m) \<Longrightarrow> \<Sqinter>(f ` A) \<le> \<Sqinter>(g ` B)"
   using cInf_mono [of "g ` B" "f ` A"] by auto
 
 lemma cSUP_mono: "A \<noteq> {} \<Longrightarrow> bdd_above (g ` B) \<Longrightarrow> (\<And>n. n \<in> A \<Longrightarrow> \<exists>m\<in>B. f n \<le> g m) \<Longrightarrow> \<Squnion>(f ` A) \<le> \<Squnion>(g ` B)"
   using cSup_mono [of "f ` A" "g ` B"] by auto
 
 lemma cINF_superset_mono: "A \<noteq> {} \<Longrightarrow> bdd_below (g ` B) \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> g x \<le> f x) \<Longrightarrow> \<Sqinter>(g ` B) \<le> \<Sqinter>(f ` A)"
   by (rule cINF_mono) auto
 
 lemma cSUP_subset_mono: 
   "\<lbrakk>A \<noteq> {}; bdd_above (g ` B); A \<subseteq> B; \<And>x. x \<in> A \<Longrightarrow> f x \<le> g x\<rbrakk> \<Longrightarrow> \<Squnion> (f ` A) \<le> \<Squnion> (g ` B)"
   by (rule cSUP_mono) auto
 
 lemma less_eq_cInf_inter: "bdd_below A \<Longrightarrow> bdd_below B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> inf (Inf A) (Inf B) \<le> Inf (A \<inter> B)"
   by (metis cInf_superset_mono lattice_class.inf_sup_ord(1) le_infI1)
 
 lemma cSup_inter_less_eq: "bdd_above A \<Longrightarrow> bdd_above B \<Longrightarrow> A \<inter> B \<noteq> {} \<Longrightarrow> Sup (A \<inter> B) \<le> sup (Sup A) (Sup B) "
   by (metis cSup_subset_mono lattice_class.inf_sup_ord(1) le_supI1)
 
 lemma cInf_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below B \<Longrightarrow> Inf (A \<union> B) = inf (Inf A) (Inf B)"
   by (intro order.antisym le_infI cInf_greatest cInf_lower) (auto intro: le_infI1 le_infI2 cInf_lower)
 
 lemma cINF_union: "A \<noteq> {} \<Longrightarrow> bdd_below (f ` A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_below (f ` B) \<Longrightarrow> \<Sqinter> (f ` (A \<union> B)) = \<Sqinter> (f ` A) \<sqinter> \<Sqinter> (f ` B)"
   using cInf_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un)
 
 lemma cSup_union_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above B \<Longrightarrow> Sup (A \<union> B) = sup (Sup A) (Sup B)"
   by (intro order.antisym le_supI cSup_least cSup_upper) (auto intro: le_supI1 le_supI2 cSup_upper)
 
 lemma cSUP_union: "A \<noteq> {} \<Longrightarrow> bdd_above (f ` A) \<Longrightarrow> B \<noteq> {} \<Longrightarrow> bdd_above (f ` B) \<Longrightarrow> \<Squnion> (f ` (A \<union> B)) = \<Squnion> (f ` A) \<squnion> \<Squnion> (f ` B)"
   using cSup_union_distrib [of "f ` A" "f ` B"] by (simp add: image_Un)
 
 lemma cINF_inf_distrib: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> bdd_below (g`A) \<Longrightarrow> \<Sqinter> (f ` A) \<sqinter> \<Sqinter> (g ` A) = (\<Sqinter>a\<in>A. inf (f a) (g a))"
   by (intro order.antisym le_infI cINF_greatest cINF_lower2)
      (auto intro: le_infI1 le_infI2 cINF_greatest cINF_lower le_infI)
 
 lemma SUP_sup_distrib: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> bdd_above (g`A) \<Longrightarrow> \<Squnion> (f ` A) \<squnion> \<Squnion> (g ` A) = (\<Squnion>a\<in>A. sup (f a) (g a))"
   by (intro order.antisym le_supI cSUP_least cSUP_upper2)
      (auto intro: le_supI1 le_supI2 cSUP_least cSUP_upper le_supI)
 
 lemma cInf_le_cSup:
   "A \<noteq> {} \<Longrightarrow> bdd_above A \<Longrightarrow> bdd_below A \<Longrightarrow> Inf A \<le> Sup A"
   by (auto intro!: cSup_upper2[of "SOME a. a \<in> A"] intro: someI cInf_lower)
 
   context
     fixes f :: "'a \<Rightarrow> 'b::conditionally_complete_lattice"
     assumes "mono f"
   begin
   
   lemma mono_cInf: "\<lbrakk>bdd_below A; A\<noteq>{}\<rbrakk> \<Longrightarrow> f (Inf A) \<le> (INF x\<in>A. f x)"
     by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cINF_greatest cInf_lower monoD)
   
   lemma mono_cSup: "\<lbrakk>bdd_above A; A\<noteq>{}\<rbrakk> \<Longrightarrow> (SUP x\<in>A. f x) \<le> f (Sup A)"
     by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cSUP_least cSup_upper monoD)
   
   lemma mono_cINF: "\<lbrakk>bdd_below (A`I); I\<noteq>{}\<rbrakk> \<Longrightarrow> f (INF i\<in>I. A i) \<le> (INF x\<in>I. f (A x))"
     by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cINF_greatest cINF_lower monoD)
   
   lemma mono_cSUP: "\<lbrakk>bdd_above (A`I); I\<noteq>{}\<rbrakk> \<Longrightarrow> (SUP x\<in>I. f (A x)) \<le> f (SUP i\<in>I. A i)"
     by (simp add: \<open>mono f\<close> conditionally_complete_lattice_class.cSUP_least cSUP_upper monoD)
   
   end
 
 end
 
 text \<open>The special case of well-orderings\<close>
 
 lemma wellorder_InfI:
   fixes k :: "'a::{wellorder,conditionally_complete_lattice}"
   assumes "k \<in> A" shows "Inf A \<in> A" 
   using wellorder_class.LeastI [of "\<lambda>x. x \<in> A" k]
   by (simp add: Least_le assms cInf_eq_minimum)
 
 lemma wellorder_Inf_le1:
   fixes k :: "'a::{wellorder,conditionally_complete_lattice}"
   assumes "k \<in> A" shows "Inf A \<le> k"
   by (meson Least_le assms bdd_below.I cInf_lower)
 
 subsection \<open>Complete lattices\<close>
 
 instance complete_lattice \<subseteq> conditionally_complete_lattice
   by standard (auto intro: Sup_upper Sup_least Inf_lower Inf_greatest)
 
 lemma cSup_eq:
   fixes a :: "'a :: {conditionally_complete_lattice, no_bot}"
   assumes upper: "\<And>x. x \<in> X \<Longrightarrow> x \<le> a"
   assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> x \<le> y) \<Longrightarrow> a \<le> y"
   shows "Sup X = a"
 proof cases
   assume "X = {}" with lt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
 qed (intro cSup_eq_non_empty assms)
 
 lemma cInf_eq:
   fixes a :: "'a :: {conditionally_complete_lattice, no_top}"
   assumes upper: "\<And>x. x \<in> X \<Longrightarrow> a \<le> x"
   assumes least: "\<And>y. (\<And>x. x \<in> X \<Longrightarrow> y \<le> x) \<Longrightarrow> y \<le> a"
   shows "Inf X = a"
 proof cases
   assume "X = {}" with gt_ex[of a] least show ?thesis by (auto simp: less_le_not_le)
 qed (intro cInf_eq_non_empty assms)
 
 class conditionally_complete_linorder = conditionally_complete_lattice + linorder
 begin
 
 lemma less_cSup_iff:
   "X \<noteq> {} \<Longrightarrow> bdd_above X \<Longrightarrow> y < Sup X \<longleftrightarrow> (\<exists>x\<in>X. y < x)"
   by (rule iffI) (metis cSup_least not_less, metis cSup_upper less_le_trans)
 
 lemma cInf_less_iff: "X \<noteq> {} \<Longrightarrow> bdd_below X \<Longrightarrow> Inf X < y \<longleftrightarrow> (\<exists>x\<in>X. x < y)"
   by (rule iffI) (metis cInf_greatest not_less, metis cInf_lower le_less_trans)
 
 lemma cINF_less_iff: "A \<noteq> {} \<Longrightarrow> bdd_below (f`A) \<Longrightarrow> (\<Sqinter>i\<in>A. f i) < a \<longleftrightarrow> (\<exists>x\<in>A. f x < a)"
   using cInf_less_iff[of "f`A"] by auto
 
 lemma less_cSUP_iff: "A \<noteq> {} \<Longrightarrow> bdd_above (f`A) \<Longrightarrow> a < (\<Squnion>i\<in>A. f i) \<longleftrightarrow> (\<exists>x\<in>A. a < f x)"
   using less_cSup_iff[of "f`A"] by auto
 
 lemma less_cSupE:
   assumes "y < Sup X" "X \<noteq> {}" obtains x where "x \<in> X" "y < x"
   by (metis cSup_least assms not_le that)
 
 lemma less_cSupD:
   "X \<noteq> {} \<Longrightarrow> z < Sup X \<Longrightarrow> \<exists>x\<in>X. z < x"
   by (metis less_cSup_iff not_le_imp_less bdd_above_def)
 
 lemma cInf_lessD:
   "X \<noteq> {} \<Longrightarrow> Inf X < z \<Longrightarrow> \<exists>x\<in>X. x < z"
   by (metis cInf_less_iff not_le_imp_less bdd_below_def)
 
 lemma complete_interval:
   assumes "a < b" and "P a" and "\<not> P b"
   shows "\<exists>c. a \<le> c \<and> c \<le> b \<and> (\<forall>x. a \<le> x \<and> x < c \<longrightarrow> P x) \<and>
              (\<forall>d. (\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x) \<longrightarrow> d \<le> c)"
-proof (rule exI [where x = "Sup {d. \<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x}"], auto)
+proof (rule exI [where x = "Sup {d. \<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x}"], safe)
   show "a \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
     by (rule cSup_upper, auto simp: bdd_above_def)
        (metis \<open>a < b\<close> \<open>\<not> P b\<close> linear less_le)
 next
   show "Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c} \<le> b"
-    apply (rule cSup_least)
-    apply auto
-    apply (metis less_le_not_le)
-    apply (metis \<open>a<b\<close> \<open>\<not> P b\<close> linear less_le)
-    done
+    by (rule cSup_least)
+       (use \<open>a<b\<close> \<open>\<not> P b\<close> in \<open>auto simp add: less_le_not_le\<close>)
 next
   fix x
   assume x: "a \<le> x" and lt: "x < Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
   show "P x"
-    apply (rule less_cSupE [OF lt], auto)
-    apply (metis less_le_not_le)
-    apply (metis x)
-    done
+    by (rule less_cSupE [OF lt]) (use less_le_not_le x in \<open>auto\<close>)
 next
   fix d
-    assume 0: "\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x"
-    thus "d \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
-      by (rule_tac cSup_upper, auto simp: bdd_above_def)
-         (metis \<open>a<b\<close> \<open>\<not> P b\<close> linear less_le)
+  assume 0: "\<forall>x. a \<le> x \<and> x < d \<longrightarrow> P x"
+  then have "d \<in> {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
+    by auto
+  moreover have "bdd_above {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
+    unfolding bdd_above_def using \<open>a<b\<close> \<open>\<not> P b\<close> linear
+    by (simp add: less_le) blast
+  ultimately show "d \<le> Sup {d. \<forall>c. a \<le> c \<and> c < d \<longrightarrow> P c}"
+    by (auto simp: cSup_upper)
 qed
 
 end
 
 subsection \<open>Instances\<close>
 
 instance complete_linorder < conditionally_complete_linorder
   ..
 
 lemma cSup_eq_Max: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Sup X = Max X"
   using cSup_eq_Sup_fin[of X] by (simp add: Sup_fin_Max)
 
 lemma cInf_eq_Min: "finite (X::'a::conditionally_complete_linorder set) \<Longrightarrow> X \<noteq> {} \<Longrightarrow> Inf X = Min X"
   using cInf_eq_Inf_fin[of X] by (simp add: Inf_fin_Min)
 
 lemma cSup_lessThan[simp]: "Sup {..<x::'a::{conditionally_complete_linorder, no_bot, dense_linorder}} = x"
   by (auto intro!: cSup_eq_non_empty intro: dense_le)
 
 lemma cSup_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Sup {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
   by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)
 
 lemma cSup_atLeastLessThan[simp]: "y < x \<Longrightarrow> Sup {y..<x::'a::{conditionally_complete_linorder, dense_linorder}} = x"
   by (auto intro!: cSup_eq_non_empty intro: dense_le_bounded)
 
 lemma cInf_greaterThan[simp]: "Inf {x::'a::{conditionally_complete_linorder, no_top, dense_linorder} <..} = x"
   by (auto intro!: cInf_eq_non_empty intro: dense_ge)
 
 lemma cInf_greaterThanAtMost[simp]: "y < x \<Longrightarrow> Inf {y<..x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
   by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)
 
 lemma cInf_greaterThanLessThan[simp]: "y < x \<Longrightarrow> Inf {y<..<x::'a::{conditionally_complete_linorder, dense_linorder}} = y"
   by (auto intro!: cInf_eq_non_empty intro: dense_ge_bounded)
 
 lemma Inf_insert_finite:
   fixes S :: "'a::conditionally_complete_linorder set"
   shows "finite S \<Longrightarrow> Inf (insert x S) = (if S = {} then x else min x (Inf S))"
   by (simp add: cInf_eq_Min)
 
 lemma Sup_insert_finite:
   fixes S :: "'a::conditionally_complete_linorder set"
   shows "finite S \<Longrightarrow> Sup (insert x S) = (if S = {} then x else max x (Sup S))"
   by (simp add: cSup_insert sup_max)
 
 lemma finite_imp_less_Inf:
   fixes a :: "'a::conditionally_complete_linorder"
   shows "\<lbrakk>finite X; x \<in> X; \<And>x. x\<in>X \<Longrightarrow> a < x\<rbrakk> \<Longrightarrow> a < Inf X"
   by (induction X rule: finite_induct) (simp_all add: cInf_eq_Min Inf_insert_finite)
 
 lemma finite_less_Inf_iff:
   fixes a :: "'a :: conditionally_complete_linorder"
   shows "\<lbrakk>finite X; X \<noteq> {}\<rbrakk> \<Longrightarrow> a < Inf X \<longleftrightarrow> (\<forall>x \<in> X. a < x)"
   by (auto simp: cInf_eq_Min)
 
 lemma finite_imp_Sup_less:
   fixes a :: "'a::conditionally_complete_linorder"
   shows "\<lbrakk>finite X; x \<in> X; \<And>x. x\<in>X \<Longrightarrow> a > x\<rbrakk> \<Longrightarrow> a > Sup X"
   by (induction X rule: finite_induct) (simp_all add: cSup_eq_Max Sup_insert_finite)
 
 lemma finite_Sup_less_iff:
   fixes a :: "'a :: conditionally_complete_linorder"
   shows "\<lbrakk>finite X; X \<noteq> {}\<rbrakk> \<Longrightarrow> a > Sup X \<longleftrightarrow> (\<forall>x \<in> X. a > x)"
   by (auto simp: cSup_eq_Max)
 
 class linear_continuum = conditionally_complete_linorder + dense_linorder +
   assumes UNIV_not_singleton: "\<exists>a b::'a. a \<noteq> b"
 begin
 
 lemma ex_gt_or_lt: "\<exists>b. a < b \<or> b < a"
   by (metis UNIV_not_singleton neq_iff)
 
 end
 
 instantiation nat :: conditionally_complete_linorder
 begin
 
 definition "Sup (X::nat set) = (if X={} then 0 else Max X)"
 definition "Inf (X::nat set) = (LEAST n. n \<in> X)"
 
 lemma bdd_above_nat: "bdd_above X \<longleftrightarrow> finite (X::nat set)"
 proof
   assume "bdd_above X"
   then obtain z where "X \<subseteq> {.. z}"
     by (auto simp: bdd_above_def)
   then show "finite X"
     by (rule finite_subset) simp
 qed simp
 
 instance
 proof
   fix x :: nat
   fix X :: "nat set"
   show "Inf X \<le> x" if "x \<in> X" "bdd_below X"
     using that by (simp add: Inf_nat_def Least_le)
   show "x \<le> Inf X" if "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y"
     using that unfolding Inf_nat_def ex_in_conv[symmetric] by (rule LeastI2_ex)
   show "x \<le> Sup X" if "x \<in> X" "bdd_above X"
     using that by (auto simp add: Sup_nat_def bdd_above_nat)
   show "Sup X \<le> x" if "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x"
   proof -
     from that have "bdd_above X"
       by (auto simp: bdd_above_def)
     with that show ?thesis 
       by (simp add: Sup_nat_def bdd_above_nat)
   qed
 qed
 
 end
 
 lemma Inf_nat_def1:
   fixes K::"nat set"
   assumes "K \<noteq> {}"
   shows "Inf K \<in> K"
 by (auto simp add: Min_def Inf_nat_def) (meson LeastI assms bot.extremum_unique subsetI)
 
 lemma Sup_nat_empty [simp]: "Sup {} = (0::nat)"
   by (auto simp add: Sup_nat_def) 
 
 
 
 instantiation int :: conditionally_complete_linorder
 begin
 
 definition "Sup (X::int set) = (THE x. x \<in> X \<and> (\<forall>y\<in>X. y \<le> x))"
 definition "Inf (X::int set) = - (Sup (uminus ` X))"
 
 instance
 proof
   { fix x :: int and X :: "int set" assume "X \<noteq> {}" "bdd_above X"
     then obtain x y where "X \<subseteq> {..y}" "x \<in> X"
       by (auto simp: bdd_above_def)
     then have *: "finite (X \<inter> {x..y})" "X \<inter> {x..y} \<noteq> {}" and "x \<le> y"
       by (auto simp: subset_eq)
     have "\<exists>!x\<in>X. (\<forall>y\<in>X. y \<le> x)"
     proof
       { fix z assume "z \<in> X"
         have "z \<le> Max (X \<inter> {x..y})"
         proof cases
           assume "x \<le> z" with \<open>z \<in> X\<close> \<open>X \<subseteq> {..y}\<close> *(1) show ?thesis
             by (auto intro!: Max_ge)
         next
           assume "\<not> x \<le> z"
           then have "z < x" by simp
           also have "x \<le> Max (X \<inter> {x..y})"
             using \<open>x \<in> X\<close> *(1) \<open>x \<le> y\<close> by (intro Max_ge) auto
           finally show ?thesis by simp
         qed }
       note le = this
       with Max_in[OF *] show ex: "Max (X \<inter> {x..y}) \<in> X \<and> (\<forall>z\<in>X. z \<le> Max (X \<inter> {x..y}))" by auto
 
       fix z assume *: "z \<in> X \<and> (\<forall>y\<in>X. y \<le> z)"
       with le have "z \<le> Max (X \<inter> {x..y})"
         by auto
       moreover have "Max (X \<inter> {x..y}) \<le> z"
         using * ex by auto
       ultimately show "z = Max (X \<inter> {x..y})"
         by auto
     qed
     then have "Sup X \<in> X \<and> (\<forall>y\<in>X. y \<le> Sup X)"
       unfolding Sup_int_def by (rule theI') }
   note Sup_int = this
 
   { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_above X" then show "x \<le> Sup X"
       using Sup_int[of X] by auto }
   note le_Sup = this
   { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> y \<le> x" then show "Sup X \<le> x"
       using Sup_int[of X] by (auto simp: bdd_above_def) }
   note Sup_le = this
 
   { fix x :: int and X :: "int set" assume "x \<in> X" "bdd_below X" then show "Inf X \<le> x"
       using le_Sup[of "-x" "uminus ` X"] by (auto simp: Inf_int_def) }
   { fix x :: int and X :: "int set" assume "X \<noteq> {}" "\<And>y. y \<in> X \<Longrightarrow> x \<le> y" then show "x \<le> Inf X"
       using Sup_le[of "uminus ` X" "-x"] by (force simp: Inf_int_def) }
 qed
 end
 
 lemma interval_cases:
   fixes S :: "'a :: conditionally_complete_linorder set"
   assumes ivl: "\<And>a b x. a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> x \<in> S"
   shows "\<exists>a b. S = {} \<or>
     S = UNIV \<or>
     S = {..<b} \<or>
     S = {..b} \<or>
     S = {a<..} \<or>
     S = {a..} \<or>
     S = {a<..<b} \<or>
     S = {a<..b} \<or>
     S = {a..<b} \<or>
     S = {a..b}"
 proof -
   define lower upper where "lower = {x. \<exists>s\<in>S. s \<le> x}" and "upper = {x. \<exists>s\<in>S. x \<le> s}"
   with ivl have "S = lower \<inter> upper"
     by auto
   moreover
   have "\<exists>a. upper = UNIV \<or> upper = {} \<or> upper = {.. a} \<or> upper = {..< a}"
   proof cases
     assume *: "bdd_above S \<and> S \<noteq> {}"
     from * have "upper \<subseteq> {.. Sup S}"
       by (auto simp: upper_def intro: cSup_upper2)
     moreover from * have "{..< Sup S} \<subseteq> upper"
       by (force simp add: less_cSup_iff upper_def subset_eq Ball_def)
     ultimately have "upper = {.. Sup S} \<or> upper = {..< Sup S}"
       unfolding ivl_disj_un(2)[symmetric] by auto
     then show ?thesis by auto
   next
     assume "\<not> (bdd_above S \<and> S \<noteq> {})"
     then have "upper = UNIV \<or> upper = {}"
       by (auto simp: upper_def bdd_above_def not_le dest: less_imp_le)
     then show ?thesis
       by auto
   qed
   moreover
   have "\<exists>b. lower = UNIV \<or> lower = {} \<or> lower = {b ..} \<or> lower = {b <..}"
   proof cases
     assume *: "bdd_below S \<and> S \<noteq> {}"
     from * have "lower \<subseteq> {Inf S ..}"
       by (auto simp: lower_def intro: cInf_lower2)
     moreover from * have "{Inf S <..} \<subseteq> lower"
       by (force simp add: cInf_less_iff lower_def subset_eq Ball_def)
     ultimately have "lower = {Inf S ..} \<or> lower = {Inf S <..}"
       unfolding ivl_disj_un(1)[symmetric] by auto
     then show ?thesis by auto
   next
     assume "\<not> (bdd_below S \<and> S \<noteq> {})"
     then have "lower = UNIV \<or> lower = {}"
       by (auto simp: lower_def bdd_below_def not_le dest: less_imp_le)
     then show ?thesis
       by auto
   qed
   ultimately show ?thesis
     unfolding greaterThanAtMost_def greaterThanLessThan_def atLeastAtMost_def atLeastLessThan_def
     by (metis inf_bot_left inf_bot_right inf_top.left_neutral inf_top.right_neutral)
 qed
 
 lemma cSUP_eq_cINF_D:
   fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
   assumes eq: "(\<Squnion>x\<in>A. f x) = (\<Sqinter>x\<in>A. f x)"
      and bdd: "bdd_above (f ` A)" "bdd_below (f ` A)"
      and a: "a \<in> A"
   shows "f a = (\<Sqinter>x\<in>A. f x)"
 proof (rule antisym)
   show "f a \<le> \<Sqinter> (f ` A)"
     by (metis a bdd(1) eq cSUP_upper)
   show "\<Sqinter> (f ` A) \<le> f a"
     using a bdd by (auto simp: cINF_lower)
 qed
 
 lemma cSUP_UNION:
   fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
   assumes ne: "A \<noteq> {}" "\<And>x. x \<in> A \<Longrightarrow> B(x) \<noteq> {}"
       and bdd_UN: "bdd_above (\<Union>x\<in>A. f ` B x)"
   shows "(\<Squnion>z \<in> \<Union>x\<in>A. B x. f z) = (\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z)"
 proof -
   have bdd: "\<And>x. x \<in> A \<Longrightarrow> bdd_above (f ` B x)"
     using bdd_UN by (meson UN_upper bdd_above_mono)
   obtain M where "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B(x) \<Longrightarrow> f y \<le> M"
     using bdd_UN by (auto simp: bdd_above_def)
   then have bdd2: "bdd_above ((\<lambda>x. \<Squnion>z\<in>B x. f z) ` A)"
     unfolding bdd_above_def by (force simp: bdd cSUP_le_iff ne(2))
   have "(\<Squnion>z \<in> \<Union>x\<in>A. B x. f z) \<le> (\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z)"
     using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper2 simp: bdd2 bdd)
   moreover have "(\<Squnion>x\<in>A. \<Squnion>z\<in>B x. f z) \<le> (\<Squnion> z \<in> \<Union>x\<in>A. B x. f z)"
     using assms by (fastforce simp add: intro!: cSUP_least intro: cSUP_upper simp: image_UN bdd_UN)
   ultimately show ?thesis
     by (rule order_antisym)
 qed
 
 lemma cINF_UNION:
   fixes f :: "_ \<Rightarrow> 'b::conditionally_complete_lattice"
   assumes ne: "A \<noteq> {}" "\<And>x. x \<in> A \<Longrightarrow> B(x) \<noteq> {}"
       and bdd_UN: "bdd_below (\<Union>x\<in>A. f ` B x)"
   shows "(\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z) = (\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z)"
 proof -
   have bdd: "\<And>x. x \<in> A \<Longrightarrow> bdd_below (f ` B x)"
     using bdd_UN by (meson UN_upper bdd_below_mono)
   obtain M where "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B(x) \<Longrightarrow> f y \<ge> M"
     using bdd_UN by (auto simp: bdd_below_def)
   then have bdd2: "bdd_below ((\<lambda>x. \<Sqinter>z\<in>B x. f z) ` A)"
     unfolding bdd_below_def by (force simp: bdd le_cINF_iff ne(2))
   have "(\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z) \<le> (\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z)"
     using assms by (fastforce simp add: intro!: cINF_greatest intro: cINF_lower simp: bdd2 bdd)
   moreover have "(\<Sqinter>x\<in>A. \<Sqinter>z\<in>B x. f z) \<le> (\<Sqinter>z \<in> \<Union>x\<in>A. B x. f z)"
     using assms  by (fastforce simp add: intro!: cINF_greatest intro: cINF_lower2  simp: bdd bdd_UN bdd2)
   ultimately show ?thesis
     by (rule order_antisym)
 qed
 
 lemma cSup_abs_le:
   fixes S :: "('a::{linordered_idom,conditionally_complete_linorder}) set"
   shows "S \<noteq> {} \<Longrightarrow> (\<And>x. x\<in>S \<Longrightarrow> \<bar>x\<bar> \<le> a) \<Longrightarrow> \<bar>Sup S\<bar> \<le> a"
   apply (auto simp add: abs_le_iff intro: cSup_least)
   by (metis bdd_aboveI cSup_upper neg_le_iff_le order_trans)
 
 end
diff --git a/src/HOL/Divides.thy b/src/HOL/Divides.thy
--- a/src/HOL/Divides.thy
+++ b/src/HOL/Divides.thy
@@ -1,1244 +1,1263 @@
 (*  Title:      HOL/Divides.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1999  University of Cambridge
 *)
 
 section \<open>More on quotient and remainder\<close>
 
 theory Divides
 imports Parity
 begin
 
 subsection \<open>More on division\<close>
 
 inductive eucl_rel_int :: "int \<Rightarrow> int \<Rightarrow> int \<times> int \<Rightarrow> bool"
   where eucl_rel_int_by0: "eucl_rel_int k 0 (0, k)"
   | eucl_rel_int_dividesI: "l \<noteq> 0 \<Longrightarrow> k = q * l \<Longrightarrow> eucl_rel_int k l (q, 0)"
   | eucl_rel_int_remainderI: "sgn r = sgn l \<Longrightarrow> \<bar>r\<bar> < \<bar>l\<bar>
       \<Longrightarrow> k = q * l + r \<Longrightarrow> eucl_rel_int k l (q, r)"
 
 lemma eucl_rel_int_iff:    
   "eucl_rel_int k l (q, r) \<longleftrightarrow> 
     k = l * q + r \<and>
      (if 0 < l then 0 \<le> r \<and> r < l else if l < 0 then l < r \<and> r \<le> 0 else q = 0)"
   by (cases "r = 0")
     (auto elim!: eucl_rel_int.cases intro: eucl_rel_int_by0 eucl_rel_int_dividesI eucl_rel_int_remainderI
     simp add: ac_simps sgn_1_pos sgn_1_neg)
 
 lemma unique_quotient_lemma:
   assumes "b * q' + r' \<le> b * q + r" "0 \<le> r'" "r' < b" "r < b" shows "q' \<le> (q::int)"
 proof -
   have "r' + b * (q'-q) \<le> r"
     using assms by (simp add: right_diff_distrib)
   moreover have "0 < b * (1 + q - q') "
     using assms by (simp add: right_diff_distrib distrib_left)
   moreover have "b * q' < b * (1 + q)"
     using assms by (simp add: right_diff_distrib distrib_left)
   ultimately show ?thesis
     using assms by (simp add: mult_less_cancel_left)
 qed
 
 lemma unique_quotient_lemma_neg:
   "b * q' + r' \<le> b*q + r \<Longrightarrow> r \<le> 0 \<Longrightarrow> b < r \<Longrightarrow> b < r' \<Longrightarrow> q \<le> (q'::int)"
-  by (rule_tac b = "-b" and r = "-r'" and r' = "-r" in unique_quotient_lemma) auto
+  using unique_quotient_lemma[where b = "-b" and r = "-r'" and r'="-r"] by auto
 
 lemma unique_quotient:
   "eucl_rel_int a b (q, r) \<Longrightarrow> eucl_rel_int a b (q', r') \<Longrightarrow> q = q'"
   apply (rule order_antisym)
    apply (simp_all add: eucl_rel_int_iff linorder_neq_iff split: if_split_asm)
      apply (blast intro: order_eq_refl [THEN unique_quotient_lemma] order_eq_refl [THEN unique_quotient_lemma_neg] sym)+
   done
 
 lemma unique_remainder:
-  "eucl_rel_int a b (q, r) \<Longrightarrow> eucl_rel_int a b (q', r') \<Longrightarrow> r = r'"
-apply (subgoal_tac "q = q'")
- apply (simp add: eucl_rel_int_iff)
-apply (blast intro: unique_quotient)
-done
+  assumes "eucl_rel_int a b (q, r)"
+    and "eucl_rel_int a b (q', r')"
+  shows "r = r'"
+proof -
+  have "q = q'"
+    using assms by (blast intro: unique_quotient)
+  then show "r = r'"
+    using assms by (simp add: eucl_rel_int_iff)
+qed
 
 lemma eucl_rel_int:
   "eucl_rel_int k l (k div l, k mod l)"
 proof (cases k rule: int_cases3)
   case zero
   then show ?thesis
     by (simp add: eucl_rel_int_iff divide_int_def modulo_int_def)
 next
   case (pos n)
   then show ?thesis
     using div_mult_mod_eq [of n]
     by (cases l rule: int_cases3)
       (auto simp del: of_nat_mult of_nat_add
         simp add: mod_greater_zero_iff_not_dvd of_nat_mult [symmetric] of_nat_add [symmetric] algebra_simps
         eucl_rel_int_iff divide_int_def modulo_int_def)
 next
   case (neg n)
   then show ?thesis
     using div_mult_mod_eq [of n]
     by (cases l rule: int_cases3)
       (auto simp del: of_nat_mult of_nat_add
         simp add: mod_greater_zero_iff_not_dvd of_nat_mult [symmetric] of_nat_add [symmetric] algebra_simps
         eucl_rel_int_iff divide_int_def modulo_int_def)
 qed
 
 lemma divmod_int_unique:
   assumes "eucl_rel_int k l (q, r)"
   shows div_int_unique: "k div l = q" and mod_int_unique: "k mod l = r"
   using assms eucl_rel_int [of k l]
   using unique_quotient [of k l] unique_remainder [of k l]
   by auto
 
 lemma div_abs_eq_div_nat:
   "\<bar>k\<bar> div \<bar>l\<bar> = int (nat \<bar>k\<bar> div nat \<bar>l\<bar>)"
   by (simp add: divide_int_def)
 
 lemma mod_abs_eq_div_nat:
   "\<bar>k\<bar> mod \<bar>l\<bar> = int (nat \<bar>k\<bar> mod nat \<bar>l\<bar>)"
   by (simp add: modulo_int_def)
 
 lemma zdiv_int:
   "int (a div b) = int a div int b"
   by (simp add: divide_int_def)
 
 lemma zmod_int:
   "int (a mod b) = int a mod int b"
   by (simp add: modulo_int_def)
 
 lemma div_sgn_abs_cancel:
   fixes k l v :: int
   assumes "v \<noteq> 0"
   shows "(sgn v * \<bar>k\<bar>) div (sgn v * \<bar>l\<bar>) = \<bar>k\<bar> div \<bar>l\<bar>"
 proof -
   from assms have "sgn v = - 1 \<or> sgn v = 1"
     by (cases "v \<ge> 0") auto
   then show ?thesis
     using assms unfolding divide_int_def [of "sgn v * \<bar>k\<bar>" "sgn v * \<bar>l\<bar>"]
     by (fastforce simp add: not_less div_abs_eq_div_nat)
 qed
 
 lemma div_eq_sgn_abs:
   fixes k l v :: int
   assumes "sgn k = sgn l"
   shows "k div l = \<bar>k\<bar> div \<bar>l\<bar>"
 proof (cases "l = 0")
   case True
   then show ?thesis
     by simp
 next
   case False
   with assms have "(sgn k * \<bar>k\<bar>) div (sgn l * \<bar>l\<bar>) = \<bar>k\<bar> div \<bar>l\<bar>"
     using div_sgn_abs_cancel [of l k l] by simp
   then show ?thesis
     by (simp add: sgn_mult_abs)
 qed
 
 lemma div_dvd_sgn_abs:
   fixes k l :: int
   assumes "l dvd k"
   shows "k div l = (sgn k * sgn l) * (\<bar>k\<bar> div \<bar>l\<bar>)"
 proof (cases "k = 0 \<or> l = 0")
   case True
   then show ?thesis
     by auto
 next
   case False
   then have "k \<noteq> 0" and "l \<noteq> 0"
     by auto
   show ?thesis
   proof (cases "sgn l = sgn k")
     case True
     then show ?thesis
       by (auto simp add: div_eq_sgn_abs)
   next
     case False
     with \<open>k \<noteq> 0\<close> \<open>l \<noteq> 0\<close>
     have "sgn l * sgn k = - 1"
       by (simp add: sgn_if split: if_splits)
     with assms show ?thesis
       unfolding divide_int_def [of k l]
       by (auto simp add: zdiv_int ac_simps)
   qed
 qed
 
 lemma div_noneq_sgn_abs:
   fixes k l :: int
   assumes "l \<noteq> 0"
   assumes "sgn k \<noteq> sgn l"
   shows "k div l = - (\<bar>k\<bar> div \<bar>l\<bar>) - of_bool (\<not> l dvd k)"
   using assms
   by (simp only: divide_int_def [of k l], auto simp add: not_less zdiv_int)
   
 
 subsubsection \<open>Laws for div and mod with Unary Minus\<close>
 
 lemma zminus1_lemma:
      "eucl_rel_int a b (q, r) ==> b \<noteq> 0
       ==> eucl_rel_int (-a) b (if r=0 then -q else -q - 1,
                           if r=0 then 0 else b-r)"
 by (force simp add: eucl_rel_int_iff right_diff_distrib)
 
 
 lemma zdiv_zminus1_eq_if:
      "b \<noteq> (0::int)
       \<Longrightarrow> (-a) div b = (if a mod b = 0 then - (a div b) else  - (a div b) - 1)"
 by (blast intro: eucl_rel_int [THEN zminus1_lemma, THEN div_int_unique])
 
 lemma zmod_zminus1_eq_if:
      "(-a::int) mod b = (if a mod b = 0 then 0 else  b - (a mod b))"
 proof (cases "b = 0")
   case False
   then show ?thesis
     by (blast intro: eucl_rel_int [THEN zminus1_lemma, THEN mod_int_unique])
 qed auto
 
 lemma zmod_zminus1_not_zero:
   fixes k l :: int
   shows "- k mod l \<noteq> 0 \<Longrightarrow> k mod l \<noteq> 0"
   by (simp add: mod_eq_0_iff_dvd)
 
 lemma zmod_zminus2_not_zero:
   fixes k l :: int
   shows "k mod - l \<noteq> 0 \<Longrightarrow> k mod l \<noteq> 0"
   by (simp add: mod_eq_0_iff_dvd)
 
 lemma zdiv_zminus2_eq_if:
   "b \<noteq> (0::int)
       ==> a div (-b) =
           (if a mod b = 0 then - (a div b) else  - (a div b) - 1)"
   by (auto simp add: zdiv_zminus1_eq_if div_minus_right)
 
 lemma zmod_zminus2_eq_if:
   "a mod (-b::int) = (if a mod b = 0 then 0 else  (a mod b) - b)"
   by (auto simp add: zmod_zminus1_eq_if mod_minus_right)
 
 
 subsubsection \<open>Monotonicity in the First Argument (Dividend)\<close>
 
 lemma zdiv_mono1:
   fixes b::int
   assumes "a \<le> a'" "0 < b" shows "a div b \<le> a' div b"
 proof (rule unique_quotient_lemma)
   show "b * (a div b) + a mod b \<le> b * (a' div b) + a' mod b"
     using assms(1) by auto
 qed (use assms in auto)
 
 lemma zdiv_mono1_neg:
   fixes b::int
   assumes "a \<le> a'" "b < 0" shows "a' div b \<le> a div b"
 proof (rule unique_quotient_lemma_neg)
   show "b * (a div b) + a mod b \<le> b * (a' div b) + a' mod b"
     using assms(1) by auto
 qed (use assms in auto)
 
 
 subsubsection \<open>Monotonicity in the Second Argument (Divisor)\<close>
 
 lemma q_pos_lemma:
   fixes q'::int
   assumes "0 \<le> b'*q' + r'" "r' < b'" "0 < b'"
   shows "0 \<le> q'"
 proof -
   have "0 < b'* (q' + 1)"
     using assms by (simp add: distrib_left)
   with assms show ?thesis
     by (simp add: zero_less_mult_iff)
 qed
 
 lemma zdiv_mono2_lemma:
   fixes q'::int
   assumes eq: "b*q + r = b'*q' + r'" and le: "0 \<le> b'*q' + r'" and "r' < b'" "0 \<le> r" "0 < b'" "b' \<le> b"
   shows "q \<le> q'"
 proof -
   have "0 \<le> q'"
     using q_pos_lemma le \<open>r' < b'\<close> \<open>0 < b'\<close> by blast
   moreover have "b*q = r' - r + b'*q'"
     using eq by linarith
   ultimately have "b*q < b* (q' + 1)"
     using mult_right_mono assms unfolding distrib_left by fastforce
   with assms show ?thesis
     by (simp add: mult_less_cancel_left_pos)
 qed
 
 lemma zdiv_mono2:
   fixes a::int
   assumes "0 \<le> a" "0 < b'" "b' \<le> b" shows "a div b \<le> a div b'"
 proof (rule zdiv_mono2_lemma)
   have "b \<noteq> 0"
     using assms by linarith
   show "b * (a div b) + a mod b = b' * (a div b') + a mod b'"
     by simp
 qed (use assms in auto)
 
 lemma zdiv_mono2_neg_lemma:
     fixes q'::int
     assumes "b*q + r = b'*q' + r'" "b'*q' + r' < 0" "r < b" "0 \<le> r'" "0 < b'" "b' \<le> b"
     shows "q' \<le> q"
 proof -
   have "b'*q' < 0"
     using assms by linarith
   with assms have "q' \<le> 0"
     by (simp add: mult_less_0_iff)
   have "b*q' \<le> b'*q'"
     by (simp add: \<open>q' \<le> 0\<close> assms(6) mult_right_mono_neg)
   then have "b*q' < b* (q + 1)"
     using assms by (simp add: distrib_left)
   then show ?thesis
     using assms by (simp add: mult_less_cancel_left)
 qed
 
 lemma zdiv_mono2_neg:
   fixes a::int
   assumes "a < 0" "0 < b'" "b' \<le> b" shows "a div b' \<le> a div b"
 proof (rule zdiv_mono2_neg_lemma)
   have "b \<noteq> 0"
     using assms by linarith
   show "b * (a div b) + a mod b = b' * (a div b') + a mod b'"
     by simp
 qed (use assms in auto)
 
 lemma div_pos_geq:
   fixes k l :: int
   assumes "0 < l" and "l \<le> k"
   shows "k div l = (k - l) div l + 1"
 proof -
   have "k = (k - l) + l" by simp
   then obtain j where k: "k = j + l" ..
   with assms show ?thesis by (simp add: div_add_self2)
 qed
 
 lemma mod_pos_geq:
   fixes k l :: int
   assumes "0 < l" and "l \<le> k"
   shows "k mod l = (k - l) mod l"
 proof -
   have "k = (k - l) + l" by simp
   then obtain j where k: "k = j + l" ..
   with assms show ?thesis by simp
 qed
 
 
 subsubsection \<open>Splitting Rules for div and mod\<close>
 
 text\<open>The proofs of the two lemmas below are essentially identical\<close>
 
 lemma split_pos_lemma:
  "0<k \<Longrightarrow>
     P(n div k :: int)(n mod k) = (\<forall>i j. 0\<le>j \<and> j<k \<and> n = k*i + j \<longrightarrow> P i j)"
   by auto
 
 lemma split_neg_lemma:
  "k<0 \<Longrightarrow>
     P(n div k :: int)(n mod k) = (\<forall>i j. k<j \<and> j\<le>0 \<and> n = k*i + j \<longrightarrow> P i j)"
   by auto
 
 lemma split_zdiv:
  "P(n div k :: int) =
   ((k = 0 \<longrightarrow> P 0) \<and>
    (0<k \<longrightarrow> (\<forall>i j. 0\<le>j \<and> j<k \<and> n = k*i + j \<longrightarrow> P i)) \<and>
    (k<0 \<longrightarrow> (\<forall>i j. k<j \<and> j\<le>0 \<and> n = k*i + j \<longrightarrow> P i)))"
 proof (cases "k = 0")
   case False
   then show ?thesis
     unfolding linorder_neq_iff
     by (auto simp add: split_pos_lemma [of concl: "\<lambda>x y. P x"] split_neg_lemma [of concl: "\<lambda>x y. P x"])
 qed auto
 
 lemma split_zmod:
  "P(n mod k :: int) =
   ((k = 0 \<longrightarrow> P n) \<and>
    (0<k \<longrightarrow> (\<forall>i j. 0\<le>j \<and> j<k \<and> n = k*i + j \<longrightarrow> P j)) \<and>
    (k<0 \<longrightarrow> (\<forall>i j. k<j \<and> j\<le>0 \<and> n = k*i + j \<longrightarrow> P j)))"
 proof (cases "k = 0")
   case False
   then show ?thesis
     unfolding linorder_neq_iff
     by (auto simp add: split_pos_lemma [of concl: "\<lambda>x y. P y"] split_neg_lemma [of concl: "\<lambda>x y. P y"])
 qed auto
 
 text \<open>Enable (lin)arith to deal with \<^const>\<open>divide\<close> and \<^const>\<open>modulo\<close>
   when these are applied to some constant that is of the form
   \<^term>\<open>numeral k\<close>:\<close>
 declare split_zdiv [of _ _ "numeral k", arith_split] for k
 declare split_zmod [of _ _ "numeral k", arith_split] for k
 
 
 subsubsection \<open>Computing \<open>div\<close> and \<open>mod\<close> with shifting\<close>
 
 lemma pos_eucl_rel_int_mult_2:
   assumes "0 \<le> b"
   assumes "eucl_rel_int a b (q, r)"
   shows "eucl_rel_int (1 + 2*a) (2*b) (q, 1 + 2*r)"
   using assms unfolding eucl_rel_int_iff by auto
 
 lemma neg_eucl_rel_int_mult_2:
   assumes "b \<le> 0"
   assumes "eucl_rel_int (a + 1) b (q, r)"
   shows "eucl_rel_int (1 + 2*a) (2*b) (q, 2*r - 1)"
   using assms unfolding eucl_rel_int_iff by auto
 
 text\<open>computing div by shifting\<close>
 
 lemma pos_zdiv_mult_2: "(0::int) \<le> a ==> (1 + 2*b) div (2*a) = b div a"
   using pos_eucl_rel_int_mult_2 [OF _ eucl_rel_int]
   by (rule div_int_unique)
 
 lemma neg_zdiv_mult_2:
   assumes A: "a \<le> (0::int)" shows "(1 + 2*b) div (2*a) = (b+1) div a"
   using neg_eucl_rel_int_mult_2 [OF A eucl_rel_int]
   by (rule div_int_unique)
 
 lemma zdiv_numeral_Bit0 [simp]:
   "numeral (Num.Bit0 v) div numeral (Num.Bit0 w) =
     numeral v div (numeral w :: int)"
   unfolding numeral.simps unfolding mult_2 [symmetric]
   by (rule div_mult_mult1, simp)
 
 lemma zdiv_numeral_Bit1 [simp]:
   "numeral (Num.Bit1 v) div numeral (Num.Bit0 w) =
     (numeral v div (numeral w :: int))"
   unfolding numeral.simps
   unfolding mult_2 [symmetric] add.commute [of _ 1]
   by (rule pos_zdiv_mult_2, simp)
 
 lemma pos_zmod_mult_2:
   fixes a b :: int
   assumes "0 \<le> a"
   shows "(1 + 2 * b) mod (2 * a) = 1 + 2 * (b mod a)"
   using pos_eucl_rel_int_mult_2 [OF assms eucl_rel_int]
   by (rule mod_int_unique)
 
 lemma neg_zmod_mult_2:
   fixes a b :: int
   assumes "a \<le> 0"
   shows "(1 + 2 * b) mod (2 * a) = 2 * ((b + 1) mod a) - 1"
   using neg_eucl_rel_int_mult_2 [OF assms eucl_rel_int]
   by (rule mod_int_unique)
 
 lemma zmod_numeral_Bit0 [simp]:
   "numeral (Num.Bit0 v) mod numeral (Num.Bit0 w) =
     (2::int) * (numeral v mod numeral w)"
   unfolding numeral_Bit0 [of v] numeral_Bit0 [of w]
   unfolding mult_2 [symmetric] by (rule mod_mult_mult1)
 
 lemma zmod_numeral_Bit1 [simp]:
   "numeral (Num.Bit1 v) mod numeral (Num.Bit0 w) =
     2 * (numeral v mod numeral w) + (1::int)"
   unfolding numeral_Bit1 [of v] numeral_Bit0 [of w]
   unfolding mult_2 [symmetric] add.commute [of _ 1]
   by (rule pos_zmod_mult_2, simp)
 
 lemma zdiv_eq_0_iff:
   "i div k = 0 \<longleftrightarrow> k = 0 \<or> 0 \<le> i \<and> i < k \<or> i \<le> 0 \<and> k < i" (is "?L = ?R")
   for i k :: int
 proof
   assume ?L
   moreover have "?L \<longrightarrow> ?R"
     by (rule split_zdiv [THEN iffD2]) simp
   ultimately show ?R
     by blast
 next
   assume ?R then show ?L
     by auto
 qed
 
 lemma zmod_trivial_iff:
   fixes i k :: int
   shows "i mod k = i \<longleftrightarrow> k = 0 \<or> 0 \<le> i \<and> i < k \<or> i \<le> 0 \<and> k < i"
 proof -
   have "i mod k = i \<longleftrightarrow> i div k = 0"
-    by safe (insert div_mult_mod_eq [of i k], auto)
+    using div_mult_mod_eq [of i k] by safe auto
   with zdiv_eq_0_iff
   show ?thesis
     by simp
 qed
 
   
 subsubsection \<open>Quotients of Signs\<close>
 
 lemma div_eq_minus1: "0 < b \<Longrightarrow> - 1 div b = - 1" for b :: int
   by (simp add: divide_int_def)
 
 lemma zmod_minus1: "0 < b \<Longrightarrow> - 1 mod b = b - 1" for b :: int
   by (auto simp add: modulo_int_def)
 
 lemma minus_mod_int_eq:
   \<open>- k mod l = l - 1 - (k - 1) mod l\<close> if \<open>l \<ge> 0\<close> for k l :: int
 proof (cases \<open>l = 0\<close>)
   case True
   then show ?thesis
     by simp
 next
   case False
   with that have \<open>l > 0\<close>
     by simp
   then show ?thesis
   proof (cases \<open>l dvd k\<close>)
     case True
     then obtain j where \<open>k = l * j\<close> ..
     moreover have \<open>(l * j mod l - 1) mod l = l - 1\<close>
       using \<open>l > 0\<close> by (simp add: zmod_minus1)
     then have \<open>(l * j - 1) mod l = l - 1\<close>
       by (simp only: mod_simps)
     ultimately show ?thesis
       by simp
   next
     case False
-    moreover have \<open>0 < k mod l\<close> \<open>k mod l < 1 + l\<close>
-      using \<open>0 < l\<close> le_imp_0_less False apply auto
-      using le_less apply fastforce
-      using pos_mod_bound [of l k] apply linarith 
-      done
-    with \<open>l > 0\<close> have \<open>(k mod l - 1) mod l = k mod l - 1\<close>
+    moreover have 1: \<open>0 < k mod l\<close>
+      using \<open>0 < l\<close> False le_less by fastforce
+    moreover have 2: \<open>k mod l < 1 + l\<close>
+      using \<open>0 < l\<close> pos_mod_bound[of l k] by linarith
+    from 1 2 \<open>l > 0\<close> have \<open>(k mod l - 1) mod l = k mod l - 1\<close>
       by (simp add: zmod_trivial_iff)
     ultimately show ?thesis
-      apply (simp only: zmod_zminus1_eq_if)
-      apply (simp add: mod_eq_0_iff_dvd algebra_simps mod_simps)
-      done
+      by (simp only: zmod_zminus1_eq_if)
+         (simp add: mod_eq_0_iff_dvd algebra_simps mod_simps)
   qed
 qed
 
 lemma div_neg_pos_less0:
   fixes a::int
   assumes "a < 0" "0 < b" 
   shows "a div b < 0"
 proof -
   have "a div b \<le> - 1 div b"
     using zdiv_mono1 assms by auto
   also have "... \<le> -1"
     by (simp add: assms(2) div_eq_minus1)
   finally show ?thesis 
     by force
 qed
 
 lemma div_nonneg_neg_le0: "[| (0::int) \<le> a; b < 0 |] ==> a div b \<le> 0"
   by (drule zdiv_mono1_neg, auto)
 
 lemma div_nonpos_pos_le0: "[| (a::int) \<le> 0; b > 0 |] ==> a div b \<le> 0"
   by (drule zdiv_mono1, auto)
 
 text\<open>Now for some equivalences of the form \<open>a div b >=< 0 \<longleftrightarrow> \<dots>\<close>
 conditional upon the sign of \<open>a\<close> or \<open>b\<close>. There are many more.
 They should all be simp rules unless that causes too much search.\<close>
 
 lemma pos_imp_zdiv_nonneg_iff:
       fixes a::int
       assumes "0 < b" 
       shows "(0 \<le> a div b) = (0 \<le> a)"
 proof
   show "0 \<le> a div b \<Longrightarrow> 0 \<le> a"
     using assms
     by (simp add: linorder_not_less [symmetric]) (blast intro: div_neg_pos_less0)
 next
   assume "0 \<le> a"
   then have "0 div b \<le> a div b"
     using zdiv_mono1 assms by blast
   then show "0 \<le> a div b"
     by auto
 qed
 
 lemma pos_imp_zdiv_pos_iff:
   "0<k \<Longrightarrow> 0 < (i::int) div k \<longleftrightarrow> k \<le> i"
   using pos_imp_zdiv_nonneg_iff[of k i] zdiv_eq_0_iff[of i k] by arith
 
 
 lemma neg_imp_zdiv_nonneg_iff:
   fixes a::int
   assumes "b < 0" 
   shows "(0 \<le> a div b) = (a \<le> 0)"
   using assms by (simp add: div_minus_minus [of a, symmetric] pos_imp_zdiv_nonneg_iff del: div_minus_minus)
 
 (*But not (a div b \<le> 0 iff a\<le>0); consider a=1, b=2 when a div b = 0.*)
 lemma pos_imp_zdiv_neg_iff: "(0::int) < b ==> (a div b < 0) = (a < 0)"
   by (simp add: linorder_not_le [symmetric] pos_imp_zdiv_nonneg_iff)
 
 (*Again the law fails for \<le>: consider a = -1, b = -2 when a div b = 0*)
 lemma neg_imp_zdiv_neg_iff: "b < (0::int) ==> (a div b < 0) = (0 < a)"
   by (simp add: linorder_not_le [symmetric] neg_imp_zdiv_nonneg_iff)
 
 lemma nonneg1_imp_zdiv_pos_iff:
   fixes a::int
   assumes "0 \<le> a" 
   shows "a div b > 0 \<longleftrightarrow> a \<ge> b \<and> b>0"
 proof -
   have "0 < a div b \<Longrightarrow> b \<le> a"
     using div_pos_pos_trivial[of a b] assms by arith
   moreover have "0 < a div b \<Longrightarrow> b > 0"
     using assms div_nonneg_neg_le0[of a b]  by(cases "b=0"; force)
   moreover have "b \<le> a \<and> 0 < b \<Longrightarrow> 0 < a div b"
     using int_one_le_iff_zero_less[of "a div b"] zdiv_mono1[of b a b] by simp
   ultimately show ?thesis
     by blast
 qed
 
 lemma zmod_le_nonneg_dividend: "(m::int) \<ge> 0 \<Longrightarrow> m mod k \<le> m"
   by (rule split_zmod[THEN iffD2]) (fastforce dest: q_pos_lemma intro: split_mult_pos_le)
 
 
 subsubsection \<open>Further properties\<close>
 
 lemma div_int_pos_iff:
   "k div l \<ge> 0 \<longleftrightarrow> k = 0 \<or> l = 0 \<or> k \<ge> 0 \<and> l \<ge> 0
     \<or> k < 0 \<and> l < 0"
   for k l :: int
 proof (cases "k = 0 \<or> l = 0")
   case False
+  then have *: "k \<noteq> 0" "l \<noteq> 0"
+    by auto
+  then have "0 \<le> k div l \<Longrightarrow> \<not> k < 0 \<Longrightarrow> 0 \<le> l"
+    by (meson neg_imp_zdiv_neg_iff not_le not_less_iff_gr_or_eq)
   then show ?thesis
-   apply (auto simp add: pos_imp_zdiv_nonneg_iff neg_imp_zdiv_nonneg_iff)
-    by (meson neg_imp_zdiv_neg_iff not_le not_less_iff_gr_or_eq)
+   using * by (auto simp add: pos_imp_zdiv_nonneg_iff neg_imp_zdiv_nonneg_iff)
 qed auto
 
 lemma mod_int_pos_iff:
   "k mod l \<ge> 0 \<longleftrightarrow> l dvd k \<or> l = 0 \<and> k \<ge> 0 \<or> l > 0"
   for k l :: int
 proof (cases "l > 0")
   case False
   then show ?thesis 
     by (simp add: dvd_eq_mod_eq_0) (use neg_mod_sign [of l k] in \<open>auto simp add: le_less not_less\<close>)
 qed auto
 
 text \<open>Simplify expressions in which div and mod combine numerical constants\<close>
 
 lemma int_div_pos_eq: "\<lbrakk>(a::int) = b * q + r; 0 \<le> r; r < b\<rbrakk> \<Longrightarrow> a div b = q"
   by (rule div_int_unique [of a b q r]) (simp add: eucl_rel_int_iff)
 
 lemma int_div_neg_eq: "\<lbrakk>(a::int) = b * q + r; r \<le> 0; b < r\<rbrakk> \<Longrightarrow> a div b = q"
   by (rule div_int_unique [of a b q r],
     simp add: eucl_rel_int_iff)
 
 lemma int_mod_pos_eq: "\<lbrakk>(a::int) = b * q + r; 0 \<le> r; r < b\<rbrakk> \<Longrightarrow> a mod b = r"
   by (rule mod_int_unique [of a b q r],
     simp add: eucl_rel_int_iff)
 
 lemma int_mod_neg_eq: "\<lbrakk>(a::int) = b * q + r; r \<le> 0; b < r\<rbrakk> \<Longrightarrow> a mod b = r"
   by (rule mod_int_unique [of a b q r],
     simp add: eucl_rel_int_iff)
 
 lemma abs_div: "(y::int) dvd x \<Longrightarrow> \<bar>x div y\<bar> = \<bar>x\<bar> div \<bar>y\<bar>"
   unfolding dvd_def by (cases "y=0") (auto simp add: abs_mult)
 
 text\<open>Suggested by Matthias Daum\<close>
 lemma int_power_div_base:
   fixes k :: int
   assumes "0 < m" "0 < k"
   shows "k ^ m div k = (k::int) ^ (m - Suc 0)"
 proof -
   have eq: "k ^ m = k ^ ((m - Suc 0) + Suc 0)"
     by (simp add: assms)
   show ?thesis
     using assms by (simp only: power_add eq) auto
 qed
 
 text\<open>Suggested by Matthias Daum\<close>
 lemma int_div_less_self:
   fixes x::int
   assumes "0 < x" "1 < k"
   shows  "x div k < x"
 proof -
   have "nat x div nat k < nat x"
     by (simp add: assms)
   with assms show ?thesis
     by (simp add: nat_div_distrib [symmetric])
 qed
 
 lemma mod_eq_dvd_iff_nat:
   "m mod q = n mod q \<longleftrightarrow> q dvd m - n" if "m \<ge> n" for m n q :: nat
 proof -
   have "int m mod int q = int n mod int q \<longleftrightarrow> int q dvd int m - int n"
     by (simp add: mod_eq_dvd_iff)
   with that have "int (m mod q) = int (n mod q) \<longleftrightarrow> int q dvd int (m - n)"
     by (simp only: of_nat_mod of_nat_diff)
   then show ?thesis
     by simp
 qed
 
 lemma mod_eq_nat1E:
   fixes m n q :: nat
   assumes "m mod q = n mod q" and "m \<ge> n"
   obtains s where "m = n + q * s"
 proof -
   from assms have "q dvd m - n"
     by (simp add: mod_eq_dvd_iff_nat)
   then obtain s where "m - n = q * s" ..
   with \<open>m \<ge> n\<close> have "m = n + q * s"
     by simp
   with that show thesis .
 qed
 
 lemma mod_eq_nat2E:
   fixes m n q :: nat
   assumes "m mod q = n mod q" and "n \<ge> m"
   obtains s where "n = m + q * s"
   using assms mod_eq_nat1E [of n q m] by (auto simp add: ac_simps)
 
 lemma nat_mod_eq_lemma:
   assumes "(x::nat) mod n = y mod n" and "y \<le> x"
   shows "\<exists>q. x = y + n * q"
-  using assms by (rule mod_eq_nat1E) rule
+  using assms by (rule mod_eq_nat1E) (rule exI)
 
 lemma nat_mod_eq_iff: "(x::nat) mod n = y mod n \<longleftrightarrow> (\<exists>q1 q2. x + n * q1 = y + n * q2)"
   (is "?lhs = ?rhs")
 proof
   assume H: "x mod n = y mod n"
   {assume xy: "x \<le> y"
     from H have th: "y mod n = x mod n" by simp
     from nat_mod_eq_lemma[OF th xy] have ?rhs
-      apply clarify  apply (rule_tac x="q" in exI) by (rule exI[where x="0"], simp)}
+    proof
+      fix q
+      assume "y = x + n * q"
+      then have "x + n * q = y + n * 0"
+        by simp
+      then show "\<exists>q1 q2. x + n * q1 = y + n * q2"
+        by blast
+    qed}
   moreover
   {assume xy: "y \<le> x"
     from nat_mod_eq_lemma[OF H xy] have ?rhs
-      apply clarify  apply (rule_tac x="0" in exI) by (rule_tac x="q" in exI, simp)}
+    proof
+      fix q
+      assume "x = y + n * q"
+      then have "x + n * 0 = y + n * q"
+        by simp
+      then show "\<exists>q1 q2. x + n * q1 = y + n * q2"
+        by blast
+    qed}
   ultimately  show ?rhs using linear[of x y] by blast
 next
   assume ?rhs then obtain q1 q2 where q12: "x + n * q1 = y + n * q2" by blast
   hence "(x + n * q1) mod n = (y + n * q2) mod n" by simp
   thus  ?lhs by simp
 qed
 
 
 subsection \<open>Numeral division with a pragmatic type class\<close>
 
 text \<open>
   The following type class contains everything necessary to formulate
   a division algorithm in ring structures with numerals, restricted
   to its positive segments.  This is its primary motivation, and it
   could surely be formulated using a more fine-grained, more algebraic
   and less technical class hierarchy.
 \<close>
 
 class unique_euclidean_semiring_numeral = unique_euclidean_semiring_with_nat + linordered_semidom +
   assumes div_less: "0 \<le> a \<Longrightarrow> a < b \<Longrightarrow> a div b = 0"
     and mod_less: " 0 \<le> a \<Longrightarrow> a < b \<Longrightarrow> a mod b = a"
     and div_positive: "0 < b \<Longrightarrow> b \<le> a \<Longrightarrow> a div b > 0"
     and mod_less_eq_dividend: "0 \<le> a \<Longrightarrow> a mod b \<le> a"
     and pos_mod_bound: "0 < b \<Longrightarrow> a mod b < b"
     and pos_mod_sign: "0 < b \<Longrightarrow> 0 \<le> a mod b"
     and mod_mult2_eq: "0 \<le> c \<Longrightarrow> a mod (b * c) = b * (a div b mod c) + a mod b"
     and div_mult2_eq: "0 \<le> c \<Longrightarrow> a div (b * c) = a div b div c"
   assumes discrete: "a < b \<longleftrightarrow> a + 1 \<le> b"
   fixes divmod :: "num \<Rightarrow> num \<Rightarrow> 'a \<times> 'a"
     and divmod_step :: "num \<Rightarrow> 'a \<times> 'a \<Rightarrow> 'a \<times> 'a"
   assumes divmod_def: "divmod m n = (numeral m div numeral n, numeral m mod numeral n)"
     and divmod_step_def: "divmod_step l qr = (let (q, r) = qr
     in if r \<ge> numeral l then (2 * q + 1, r - numeral l)
     else (2 * q, r))"
     \<comment> \<open>These are conceptually definitions but force generated code
     to be monomorphic wrt. particular instances of this class which
     yields a significant speedup.\<close>
 begin
 
 lemma divmod_digit_1:
   assumes "0 \<le> a" "0 < b" and "b \<le> a mod (2 * b)"
   shows "2 * (a div (2 * b)) + 1 = a div b" (is "?P")
     and "a mod (2 * b) - b = a mod b" (is "?Q")
 proof -
   from assms mod_less_eq_dividend [of a "2 * b"] have "b \<le> a"
     by (auto intro: trans)
   with \<open>0 < b\<close> have "0 < a div b" by (auto intro: div_positive)
   then have [simp]: "1 \<le> a div b" by (simp add: discrete)
   with \<open>0 < b\<close> have mod_less: "a mod b < b" by (simp add: pos_mod_bound)
   define w where "w = a div b mod 2"
   then have w_exhaust: "w = 0 \<or> w = 1" by auto
   have mod_w: "a mod (2 * b) = a mod b + b * w"
     by (simp add: w_def mod_mult2_eq ac_simps)
   from assms w_exhaust have "w = 1"
-    by (auto simp add: mod_w) (insert mod_less, auto)
+    using mod_less by (auto simp add: mod_w)
   with mod_w have mod: "a mod (2 * b) = a mod b + b" by simp
   have "2 * (a div (2 * b)) = a div b - w"
     by (simp add: w_def div_mult2_eq minus_mod_eq_mult_div ac_simps)
   with \<open>w = 1\<close> have div: "2 * (a div (2 * b)) = a div b - 1" by simp
   then show ?P and ?Q
     by (simp_all add: div mod add_implies_diff [symmetric])
 qed
 
 lemma divmod_digit_0:
   assumes "0 < b" and "a mod (2 * b) < b"
   shows "2 * (a div (2 * b)) = a div b" (is "?P")
     and "a mod (2 * b) = a mod b" (is "?Q")
 proof -
   define w where "w = a div b mod 2"
   then have w_exhaust: "w = 0 \<or> w = 1" by auto
   have mod_w: "a mod (2 * b) = a mod b + b * w"
     by (simp add: w_def mod_mult2_eq ac_simps)
   moreover have "b \<le> a mod b + b"
   proof -
     from \<open>0 < b\<close> pos_mod_sign have "0 \<le> a mod b" by blast
     then have "0 + b \<le> a mod b + b" by (rule add_right_mono)
     then show ?thesis by simp
   qed
   moreover note assms w_exhaust
   ultimately have "w = 0" by auto
   with mod_w have mod: "a mod (2 * b) = a mod b" by simp
   have "2 * (a div (2 * b)) = a div b - w"
     by (simp add: w_def div_mult2_eq minus_mod_eq_mult_div ac_simps)
   with \<open>w = 0\<close> have div: "2 * (a div (2 * b)) = a div b" by simp
   then show ?P and ?Q
     by (simp_all add: div mod)
 qed
 
 lemma mod_double_modulus:
   assumes "m > 0" "x \<ge> 0"
   shows   "x mod (2 * m) = x mod m \<or> x mod (2 * m) = x mod m + m"
 proof (cases "x mod (2 * m) < m")
   case True
   thus ?thesis using assms using divmod_digit_0(2)[of m x] by auto
 next
   case False
   hence *: "x mod (2 * m) - m = x mod m"
     using assms by (intro divmod_digit_1) auto
   hence "x mod (2 * m) = x mod m + m"
     by (subst * [symmetric], subst le_add_diff_inverse2) (use False in auto)
   thus ?thesis by simp
 qed
 
 lemma fst_divmod:
   "fst (divmod m n) = numeral m div numeral n"
   by (simp add: divmod_def)
 
 lemma snd_divmod:
   "snd (divmod m n) = numeral m mod numeral n"
   by (simp add: divmod_def)
 
 text \<open>
   This is a formulation of one step (referring to one digit position)
   in school-method division: compare the dividend at the current
   digit position with the remainder from previous division steps
   and evaluate accordingly.
 \<close>
 
 lemma divmod_step_eq [simp]:
   "divmod_step l (q, r) = (if numeral l \<le> r
     then (2 * q + 1, r - numeral l) else (2 * q, r))"
   by (simp add: divmod_step_def)
 
 text \<open>
   This is a formulation of school-method division.
   If the divisor is smaller than the dividend, terminate.
   If not, shift the dividend to the right until termination
   occurs and then reiterate single division steps in the
   opposite direction.
 \<close>
 
 lemma divmod_divmod_step:
   "divmod m n = (if m < n then (0, numeral m)
     else divmod_step n (divmod m (Num.Bit0 n)))"
 proof (cases "m < n")
   case True then have "numeral m < numeral n" by simp
   then show ?thesis
     by (simp add: prod_eq_iff div_less mod_less fst_divmod snd_divmod)
 next
   case False
   have "divmod m n =
     divmod_step n (numeral m div (2 * numeral n),
       numeral m mod (2 * numeral n))"
   proof (cases "numeral n \<le> numeral m mod (2 * numeral n)")
     case True
     with divmod_step_eq
       have "divmod_step n (numeral m div (2 * numeral n), numeral m mod (2 * numeral n)) =
         (2 * (numeral m div (2 * numeral n)) + 1, numeral m mod (2 * numeral n) - numeral n)"
         by simp
     moreover from True divmod_digit_1 [of "numeral m" "numeral n"]
       have "2 * (numeral m div (2 * numeral n)) + 1 = numeral m div numeral n"
       and "numeral m mod (2 * numeral n) - numeral n = numeral m mod numeral n"
       by simp_all
     ultimately show ?thesis by (simp only: divmod_def)
   next
     case False then have *: "numeral m mod (2 * numeral n) < numeral n"
       by (simp add: not_le)
     with divmod_step_eq
       have "divmod_step n (numeral m div (2 * numeral n), numeral m mod (2 * numeral n)) =
         (2 * (numeral m div (2 * numeral n)), numeral m mod (2 * numeral n))"
         by auto
     moreover from * divmod_digit_0 [of "numeral n" "numeral m"]
       have "2 * (numeral m div (2 * numeral n)) = numeral m div numeral n"
       and "numeral m mod (2 * numeral n) = numeral m mod numeral n"
       by (simp_all only: zero_less_numeral)
     ultimately show ?thesis by (simp only: divmod_def)
   qed
   then have "divmod m n =
     divmod_step n (numeral m div numeral (Num.Bit0 n),
       numeral m mod numeral (Num.Bit0 n))"
     by (simp only: numeral.simps distrib mult_1)
   then have "divmod m n = divmod_step n (divmod m (Num.Bit0 n))"
     by (simp add: divmod_def)
   with False show ?thesis by simp
 qed
 
 text \<open>The division rewrite proper -- first, trivial results involving \<open>1\<close>\<close>
 
 lemma divmod_trivial [simp]:
   "divmod m Num.One = (numeral m, 0)"
   "divmod num.One (num.Bit0 n) = (0, Numeral1)"
   "divmod num.One (num.Bit1 n) = (0, Numeral1)"
   using divmod_divmod_step [of "Num.One"] by (simp_all add: divmod_def)
 
 text \<open>Division by an even number is a right-shift\<close>
 
 lemma divmod_cancel [simp]:
   "divmod (Num.Bit0 m) (Num.Bit0 n) = (case divmod m n of (q, r) \<Rightarrow> (q, 2 * r))" (is ?P)
   "divmod (Num.Bit1 m) (Num.Bit0 n) = (case divmod m n of (q, r) \<Rightarrow> (q, 2 * r + 1))" (is ?Q)
 proof -
   have *: "\<And>q. numeral (Num.Bit0 q) = 2 * numeral q"
     "\<And>q. numeral (Num.Bit1 q) = 2 * numeral q + 1"
     by (simp_all only: numeral_mult numeral.simps distrib) simp_all
   have "1 div 2 = 0" "1 mod 2 = 1" by (auto intro: div_less mod_less)
   then show ?P and ?Q
     by (simp_all add: fst_divmod snd_divmod prod_eq_iff split_def * [of m] * [of n] mod_mult_mult1
       div_mult2_eq [of _ _ 2] mod_mult2_eq [of _ _ 2]
       add.commute del: numeral_times_numeral)
 qed
 
 text \<open>The really hard work\<close>
 
 lemma divmod_steps [simp]:
   "divmod (num.Bit0 m) (num.Bit1 n) =
       (if m \<le> n then (0, numeral (num.Bit0 m))
        else divmod_step (num.Bit1 n)
              (divmod (num.Bit0 m)
                (num.Bit0 (num.Bit1 n))))"
   "divmod (num.Bit1 m) (num.Bit1 n) =
       (if m < n then (0, numeral (num.Bit1 m))
        else divmod_step (num.Bit1 n)
              (divmod (num.Bit1 m)
                (num.Bit0 (num.Bit1 n))))"
   by (simp_all add: divmod_divmod_step)
 
 lemmas divmod_algorithm_code = divmod_step_eq divmod_trivial divmod_cancel divmod_steps  
 
 text \<open>Special case: divisibility\<close>
 
 definition divides_aux :: "'a \<times> 'a \<Rightarrow> bool"
 where
   "divides_aux qr \<longleftrightarrow> snd qr = 0"
 
 lemma divides_aux_eq [simp]:
   "divides_aux (q, r) \<longleftrightarrow> r = 0"
   by (simp add: divides_aux_def)
 
 lemma dvd_numeral_simp [simp]:
   "numeral m dvd numeral n \<longleftrightarrow> divides_aux (divmod n m)"
   by (simp add: divmod_def mod_eq_0_iff_dvd)
 
 text \<open>Generic computation of quotient and remainder\<close>  
 
 lemma numeral_div_numeral [simp]: 
   "numeral k div numeral l = fst (divmod k l)"
   by (simp add: fst_divmod)
 
 lemma numeral_mod_numeral [simp]: 
   "numeral k mod numeral l = snd (divmod k l)"
   by (simp add: snd_divmod)
 
 lemma one_div_numeral [simp]:
   "1 div numeral n = fst (divmod num.One n)"
   by (simp add: fst_divmod)
 
 lemma one_mod_numeral [simp]:
   "1 mod numeral n = snd (divmod num.One n)"
   by (simp add: snd_divmod)
 
 text \<open>Computing congruences modulo \<open>2 ^ q\<close>\<close>
 
 lemma cong_exp_iff_simps:
   "numeral n mod numeral Num.One = 0
     \<longleftrightarrow> True"
   "numeral (Num.Bit0 n) mod numeral (Num.Bit0 q) = 0
     \<longleftrightarrow> numeral n mod numeral q = 0"
   "numeral (Num.Bit1 n) mod numeral (Num.Bit0 q) = 0
     \<longleftrightarrow> False"
   "numeral m mod numeral Num.One = (numeral n mod numeral Num.One)
     \<longleftrightarrow> True"
   "numeral Num.One mod numeral (Num.Bit0 q) = (numeral Num.One mod numeral (Num.Bit0 q))
     \<longleftrightarrow> True"
   "numeral Num.One mod numeral (Num.Bit0 q) = (numeral (Num.Bit0 n) mod numeral (Num.Bit0 q))
     \<longleftrightarrow> False"
   "numeral Num.One mod numeral (Num.Bit0 q) = (numeral (Num.Bit1 n) mod numeral (Num.Bit0 q))
     \<longleftrightarrow> (numeral n mod numeral q) = 0"
   "numeral (Num.Bit0 m) mod numeral (Num.Bit0 q) = (numeral Num.One mod numeral (Num.Bit0 q))
     \<longleftrightarrow> False"
   "numeral (Num.Bit0 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit0 n) mod numeral (Num.Bit0 q))
     \<longleftrightarrow> numeral m mod numeral q = (numeral n mod numeral q)"
   "numeral (Num.Bit0 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit1 n) mod numeral (Num.Bit0 q))
     \<longleftrightarrow> False"
   "numeral (Num.Bit1 m) mod numeral (Num.Bit0 q) = (numeral Num.One mod numeral (Num.Bit0 q))
     \<longleftrightarrow> (numeral m mod numeral q) = 0"
   "numeral (Num.Bit1 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit0 n) mod numeral (Num.Bit0 q))
     \<longleftrightarrow> False"
   "numeral (Num.Bit1 m) mod numeral (Num.Bit0 q) = (numeral (Num.Bit1 n) mod numeral (Num.Bit0 q))
     \<longleftrightarrow> numeral m mod numeral q = (numeral n mod numeral q)"
   by (auto simp add: case_prod_beta dest: arg_cong [of _ _ even])
 
 end
 
 hide_fact (open) div_less mod_less mod_less_eq_dividend mod_mult2_eq div_mult2_eq
 
 instantiation nat :: unique_euclidean_semiring_numeral
 begin
 
 definition divmod_nat :: "num \<Rightarrow> num \<Rightarrow> nat \<times> nat"
 where
   divmod'_nat_def: "divmod_nat m n = (numeral m div numeral n, numeral m mod numeral n)"
 
 definition divmod_step_nat :: "num \<Rightarrow> nat \<times> nat \<Rightarrow> nat \<times> nat"
 where
   "divmod_step_nat l qr = (let (q, r) = qr
     in if r \<ge> numeral l then (2 * q + 1, r - numeral l)
     else (2 * q, r))"
 
 instance by standard
   (auto simp add: divmod'_nat_def divmod_step_nat_def div_greater_zero_iff div_mult2_eq mod_mult2_eq)
 
 end
 
 declare divmod_algorithm_code [where ?'a = nat, code]
 
 lemma Suc_0_div_numeral [simp]:
   fixes k l :: num
   shows "Suc 0 div numeral k = fst (divmod Num.One k)"
   by (simp_all add: fst_divmod)
 
 lemma Suc_0_mod_numeral [simp]:
   fixes k l :: num
   shows "Suc 0 mod numeral k = snd (divmod Num.One k)"
   by (simp_all add: snd_divmod)
 
 instantiation int :: unique_euclidean_semiring_numeral
 begin
 
 definition divmod_int :: "num \<Rightarrow> num \<Rightarrow> int \<times> int"
 where
   "divmod_int m n = (numeral m div numeral n, numeral m mod numeral n)"
 
 definition divmod_step_int :: "num \<Rightarrow> int \<times> int \<Rightarrow> int \<times> int"
 where
   "divmod_step_int l qr = (let (q, r) = qr
     in if r \<ge> numeral l then (2 * q + 1, r - numeral l)
     else (2 * q, r))"
 
 instance
   by standard (auto intro: zmod_le_nonneg_dividend simp add: divmod_int_def divmod_step_int_def
     pos_imp_zdiv_pos_iff zmod_zmult2_eq zdiv_zmult2_eq)
 
 end
 
 declare divmod_algorithm_code [where ?'a = int, code]
 
 context
 begin
   
 qualified definition adjust_div :: "int \<times> int \<Rightarrow> int"
 where
   "adjust_div qr = (let (q, r) = qr in q + of_bool (r \<noteq> 0))"
 
 qualified lemma adjust_div_eq [simp, code]:
   "adjust_div (q, r) = q + of_bool (r \<noteq> 0)"
   by (simp add: adjust_div_def)
 
 qualified definition adjust_mod :: "int \<Rightarrow> int \<Rightarrow> int"
 where
   [simp]: "adjust_mod l r = (if r = 0 then 0 else l - r)"
 
 lemma minus_numeral_div_numeral [simp]:
   "- numeral m div numeral n = - (adjust_div (divmod m n) :: int)"
 proof -
   have "int (fst (divmod m n)) = fst (divmod m n)"
     by (simp only: fst_divmod divide_int_def) auto
   then show ?thesis
     by (auto simp add: split_def Let_def adjust_div_def divides_aux_def divide_int_def)
 qed
 
 lemma minus_numeral_mod_numeral [simp]:
   "- numeral m mod numeral n = adjust_mod (numeral n) (snd (divmod m n) :: int)"
 proof (cases "snd (divmod m n) = (0::int)")
   case True
   then show ?thesis
     by (simp add: mod_eq_0_iff_dvd divides_aux_def)
 next
   case False
   then have "int (snd (divmod m n)) = snd (divmod m n)" if "snd (divmod m n) \<noteq> (0::int)"
     by (simp only: snd_divmod modulo_int_def) auto
   then show ?thesis
     by (simp add: divides_aux_def adjust_div_def)
       (simp add: divides_aux_def modulo_int_def)
 qed
 
 lemma numeral_div_minus_numeral [simp]:
   "numeral m div - numeral n = - (adjust_div (divmod m n) :: int)"
 proof -
   have "int (fst (divmod m n)) = fst (divmod m n)"
     by (simp only: fst_divmod divide_int_def) auto
   then show ?thesis
     by (auto simp add: split_def Let_def adjust_div_def divides_aux_def divide_int_def)
 qed
   
 lemma numeral_mod_minus_numeral [simp]:
   "numeral m mod - numeral n = - adjust_mod (numeral n) (snd (divmod m n) :: int)"
 proof (cases "snd (divmod m n) = (0::int)")
   case True
   then show ?thesis
     by (simp add: mod_eq_0_iff_dvd divides_aux_def)
 next
   case False
   then have "int (snd (divmod m n)) = snd (divmod m n)" if "snd (divmod m n) \<noteq> (0::int)"
     by (simp only: snd_divmod modulo_int_def) auto
   then show ?thesis
     by (simp add: divides_aux_def adjust_div_def)
       (simp add: divides_aux_def modulo_int_def)
 qed
 
 lemma minus_one_div_numeral [simp]:
   "- 1 div numeral n = - (adjust_div (divmod Num.One n) :: int)"
   using minus_numeral_div_numeral [of Num.One n] by simp  
 
 lemma minus_one_mod_numeral [simp]:
   "- 1 mod numeral n = adjust_mod (numeral n) (snd (divmod Num.One n) :: int)"
   using minus_numeral_mod_numeral [of Num.One n] by simp
 
 lemma one_div_minus_numeral [simp]:
   "1 div - numeral n = - (adjust_div (divmod Num.One n) :: int)"
   using numeral_div_minus_numeral [of Num.One n] by simp
   
 lemma one_mod_minus_numeral [simp]:
   "1 mod - numeral n = - adjust_mod (numeral n) (snd (divmod Num.One n) :: int)"
   using numeral_mod_minus_numeral [of Num.One n] by simp
 
 end
 
 lemma divmod_BitM_2_eq [simp]:
   \<open>divmod (Num.BitM m) (Num.Bit0 Num.One) = (numeral m - 1, (1 :: int))\<close>
   by (cases m) simp_all
 
 lemma div_positive_int:
   "k div l > 0" if "k \<ge> l" and "l > 0" for k l :: int
   using that div_positive [of l k] by blast
 
 
 subsubsection \<open>Dedicated simproc for calculation\<close>
 
 text \<open>
   There is space for improvement here: the calculation itself
   could be carried out outside the logic, and a generic simproc
   (simplifier setup) for generic calculation would be helpful. 
 \<close>
 
 simproc_setup numeral_divmod
   ("0 div 0 :: 'a :: unique_euclidean_semiring_numeral" | "0 mod 0 :: 'a :: unique_euclidean_semiring_numeral" |
    "0 div 1 :: 'a :: unique_euclidean_semiring_numeral" | "0 mod 1 :: 'a :: unique_euclidean_semiring_numeral" |
    "0 div - 1 :: int" | "0 mod - 1 :: int" |
    "0 div numeral b :: 'a :: unique_euclidean_semiring_numeral" | "0 mod numeral b :: 'a :: unique_euclidean_semiring_numeral" |
    "0 div - numeral b :: int" | "0 mod - numeral b :: int" |
    "1 div 0 :: 'a :: unique_euclidean_semiring_numeral" | "1 mod 0 :: 'a :: unique_euclidean_semiring_numeral" |
    "1 div 1 :: 'a :: unique_euclidean_semiring_numeral" | "1 mod 1 :: 'a :: unique_euclidean_semiring_numeral" |
    "1 div - 1 :: int" | "1 mod - 1 :: int" |
    "1 div numeral b :: 'a :: unique_euclidean_semiring_numeral" | "1 mod numeral b :: 'a :: unique_euclidean_semiring_numeral" |
    "1 div - numeral b :: int" |"1 mod - numeral b :: int" |
    "- 1 div 0 :: int" | "- 1 mod 0 :: int" | "- 1 div 1 :: int" | "- 1 mod 1 :: int" |
    "- 1 div - 1 :: int" | "- 1 mod - 1 :: int" | "- 1 div numeral b :: int" | "- 1 mod numeral b :: int" |
    "- 1 div - numeral b :: int" | "- 1 mod - numeral b :: int" |
    "numeral a div 0 :: 'a :: unique_euclidean_semiring_numeral" | "numeral a mod 0 :: 'a :: unique_euclidean_semiring_numeral" |
    "numeral a div 1 :: 'a :: unique_euclidean_semiring_numeral" | "numeral a mod 1 :: 'a :: unique_euclidean_semiring_numeral" |
    "numeral a div - 1 :: int" | "numeral a mod - 1 :: int" |
    "numeral a div numeral b :: 'a :: unique_euclidean_semiring_numeral" | "numeral a mod numeral b :: 'a :: unique_euclidean_semiring_numeral" |
    "numeral a div - numeral b :: int" | "numeral a mod - numeral b :: int" |
    "- numeral a div 0 :: int" | "- numeral a mod 0 :: int" |
    "- numeral a div 1 :: int" | "- numeral a mod 1 :: int" |
    "- numeral a div - 1 :: int" | "- numeral a mod - 1 :: int" |
    "- numeral a div numeral b :: int" | "- numeral a mod numeral b :: int" |
    "- numeral a div - numeral b :: int" | "- numeral a mod - numeral b :: int") =
 \<open> let
     val if_cong = the (Code.get_case_cong \<^theory> \<^const_name>\<open>If\<close>);
     fun successful_rewrite ctxt ct =
       let
         val thm = Simplifier.rewrite ctxt ct
       in if Thm.is_reflexive thm then NONE else SOME thm end;
   in fn phi =>
     let
       val simps = Morphism.fact phi (@{thms div_0 mod_0 div_by_0 mod_by_0 div_by_1 mod_by_1
         one_div_numeral one_mod_numeral minus_one_div_numeral minus_one_mod_numeral
         one_div_minus_numeral one_mod_minus_numeral
         numeral_div_numeral numeral_mod_numeral minus_numeral_div_numeral minus_numeral_mod_numeral
         numeral_div_minus_numeral numeral_mod_minus_numeral
         div_minus_minus mod_minus_minus Divides.adjust_div_eq of_bool_eq one_neq_zero
         numeral_neq_zero neg_equal_0_iff_equal arith_simps arith_special divmod_trivial
         divmod_cancel divmod_steps divmod_step_eq fst_conv snd_conv numeral_One
         case_prod_beta rel_simps Divides.adjust_mod_def div_minus1_right mod_minus1_right
         minus_minus numeral_times_numeral mult_zero_right mult_1_right}
         @ [@{lemma "0 = 0 \<longleftrightarrow> True" by simp}]);
       fun prepare_simpset ctxt = HOL_ss |> Simplifier.simpset_map ctxt
         (Simplifier.add_cong if_cong #> fold Simplifier.add_simp simps)
     in fn ctxt => successful_rewrite (Simplifier.put_simpset (prepare_simpset ctxt) ctxt) end
   end
 \<close>
 
 
 subsubsection \<open>Code generation\<close>
 
 definition divmod_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<times> nat"
   where "divmod_nat m n = (m div n, m mod n)"
 
 lemma fst_divmod_nat [simp]:
   "fst (divmod_nat m n) = m div n"
   by (simp add: divmod_nat_def)
 
 lemma snd_divmod_nat [simp]:
   "snd (divmod_nat m n) = m mod n"
   by (simp add: divmod_nat_def)
 
 lemma divmod_nat_if [code]:
   "Divides.divmod_nat m n = (if n = 0 \<or> m < n then (0, m) else
     let (q, r) = Divides.divmod_nat (m - n) n in (Suc q, r))"
   by (simp add: prod_eq_iff case_prod_beta not_less le_div_geq le_mod_geq)
 
 lemma [code]:
   "m div n = fst (divmod_nat m n)"
   "m mod n = snd (divmod_nat m n)"
   by simp_all
 
 lemma [code]:
   fixes k :: int
   shows 
     "k div 0 = 0"
     "k mod 0 = k"
     "0 div k = 0"
     "0 mod k = 0"
     "k div Int.Pos Num.One = k"
     "k mod Int.Pos Num.One = 0"
     "k div Int.Neg Num.One = - k"
     "k mod Int.Neg Num.One = 0"
     "Int.Pos m div Int.Pos n = (fst (divmod m n) :: int)"
     "Int.Pos m mod Int.Pos n = (snd (divmod m n) :: int)"
     "Int.Neg m div Int.Pos n = - (Divides.adjust_div (divmod m n) :: int)"
     "Int.Neg m mod Int.Pos n = Divides.adjust_mod (Int.Pos n) (snd (divmod m n) :: int)"
     "Int.Pos m div Int.Neg n = - (Divides.adjust_div (divmod m n) :: int)"
     "Int.Pos m mod Int.Neg n = - Divides.adjust_mod (Int.Pos n) (snd (divmod m n) :: int)"
     "Int.Neg m div Int.Neg n = (fst (divmod m n) :: int)"
     "Int.Neg m mod Int.Neg n = - (snd (divmod m n) :: int)"
   by simp_all
 
 code_identifier
   code_module Divides \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 
 subsection \<open>Lemmas of doubtful value\<close>
 
 lemma div_geq: "m div n = Suc ((m - n) div n)" if "0 < n" and " \<not> m < n" for m n :: nat
   by (rule le_div_geq) (use that in \<open>simp_all add: not_less\<close>)
 
 lemma mod_geq: "m mod n = (m - n) mod n" if "\<not> m < n" for m n :: nat
   by (rule le_mod_geq) (use that in \<open>simp add: not_less\<close>)
 
 lemma mod_eq_0D: "\<exists>q. m = d * q" if "m mod d = 0" for m d :: nat
   using that by (auto simp add: mod_eq_0_iff_dvd)
 
 lemma pos_mod_conj: "0 < b \<Longrightarrow> 0 \<le> a mod b \<and> a mod b < b" for a b :: int
   by simp
 
 lemma neg_mod_conj: "b < 0 \<Longrightarrow> a mod b \<le> 0 \<and> b < a mod b" for a b :: int
   by simp
 
 lemma zmod_eq_0_iff: "m mod d = 0 \<longleftrightarrow> (\<exists>q. m = d * q)" for m d :: int
   by (auto simp add: mod_eq_0_iff_dvd)
 
 (* REVISIT: should this be generalized to all semiring_div types? *)
 lemma zmod_eq_0D [dest!]: "\<exists>q. m = d * q" if "m mod d = 0" for m d :: int
   using that by auto
 
 end
diff --git a/src/HOL/Equiv_Relations.thy b/src/HOL/Equiv_Relations.thy
--- a/src/HOL/Equiv_Relations.thy
+++ b/src/HOL/Equiv_Relations.thy
@@ -1,588 +1,587 @@
 (*  Title:      HOL/Equiv_Relations.thy
     Author:     Lawrence C Paulson, 1996 Cambridge University Computer Laboratory
 *)
 
 section \<open>Equivalence Relations in Higher-Order Set Theory\<close>
 
 theory Equiv_Relations
   imports BNF_Least_Fixpoint
 begin
 
 subsection \<open>Equivalence relations -- set version\<close>
 
 definition equiv :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
   where "equiv A r \<longleftrightarrow> refl_on A r \<and> sym r \<and> trans r"
 
 lemma equivI: "refl_on A r \<Longrightarrow> sym r \<Longrightarrow> trans r \<Longrightarrow> equiv A r"
   by (simp add: equiv_def)
 
 lemma equivE:
   assumes "equiv A r"
   obtains "refl_on A r" and "sym r" and "trans r"
   using assms by (simp add: equiv_def)
 
 text \<open>
   Suppes, Theorem 70: \<open>r\<close> is an equiv relation iff \<open>r\<inverse> O r = r\<close>.
 
   First half: \<open>equiv A r \<Longrightarrow> r\<inverse> O r = r\<close>.
 \<close>
 
 lemma sym_trans_comp_subset: "sym r \<Longrightarrow> trans r \<Longrightarrow> r\<inverse> O r \<subseteq> r"
   unfolding trans_def sym_def converse_unfold by blast
 
 lemma refl_on_comp_subset: "refl_on A r \<Longrightarrow> r \<subseteq> r\<inverse> O r"
   unfolding refl_on_def by blast
 
 lemma equiv_comp_eq: "equiv A r \<Longrightarrow> r\<inverse> O r = r"
   unfolding equiv_def
   by (iprover intro: sym_trans_comp_subset refl_on_comp_subset equalityI)
 
 text \<open>Second half.\<close>
 
 lemma comp_equivI:
   assumes "r\<inverse> O r = r" "Domain r = A"
   shows "equiv A r"
 proof -
   have *: "\<And>x y. (x, y) \<in> r \<Longrightarrow> (y, x) \<in> r"
     using assms by blast
   show ?thesis
     unfolding equiv_def refl_on_def sym_def trans_def
     using assms by (auto intro: *)
 qed
 
 
 subsection \<open>Equivalence classes\<close>
 
 lemma equiv_class_subset: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} \<subseteq> r``{b}"
   \<comment> \<open>lemma for the next result\<close>
   unfolding equiv_def trans_def sym_def by blast
 
 theorem equiv_class_eq: "equiv A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> r``{a} = r``{b}"
   by (intro equalityI equiv_class_subset; force simp add: equiv_def sym_def)
 
 lemma equiv_class_self: "equiv A r \<Longrightarrow> a \<in> A \<Longrightarrow> a \<in> r``{a}"
   unfolding equiv_def refl_on_def by blast
 
 lemma subset_equiv_class: "equiv A r \<Longrightarrow> r``{b} \<subseteq> r``{a} \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
   \<comment> \<open>lemma for the next result\<close>
   unfolding equiv_def refl_on_def by blast
 
 lemma eq_equiv_class: "r``{a} = r``{b} \<Longrightarrow> equiv A r \<Longrightarrow> b \<in> A \<Longrightarrow> (a, b) \<in> r"
   by (iprover intro: equalityD2 subset_equiv_class)
 
 lemma equiv_class_nondisjoint: "equiv A r \<Longrightarrow> x \<in> (r``{a} \<inter> r``{b}) \<Longrightarrow> (a, b) \<in> r"
   unfolding equiv_def trans_def sym_def by blast
 
 lemma equiv_type: "equiv A r \<Longrightarrow> r \<subseteq> A \<times> A"
   unfolding equiv_def refl_on_def by blast
 
 lemma equiv_class_eq_iff: "equiv A r \<Longrightarrow> (x, y) \<in> r \<longleftrightarrow> r``{x} = r``{y} \<and> x \<in> A \<and> y \<in> A"
   by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)
 
 lemma eq_equiv_class_iff: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> r``{x} = r``{y} \<longleftrightarrow> (x, y) \<in> r"
   by (blast intro!: equiv_class_eq dest: eq_equiv_class equiv_type)
 
 lemma disjnt_equiv_class: "equiv A r \<Longrightarrow> disjnt (r``{a}) (r``{b}) \<longleftrightarrow> (a, b) \<notin> r"
   by (auto dest: equiv_class_self simp: equiv_class_eq_iff disjnt_def)
 
 
 subsection \<open>Quotients\<close>
 
 definition quotient :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set set"  (infixl "'/'/" 90)
   where "A//r = (\<Union>x \<in> A. {r``{x}})"  \<comment> \<open>set of equiv classes\<close>
 
 lemma quotientI: "x \<in> A \<Longrightarrow> r``{x} \<in> A//r"
   unfolding quotient_def by blast
 
 lemma quotientE: "X \<in> A//r \<Longrightarrow> (\<And>x. X = r``{x} \<Longrightarrow> x \<in> A \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding quotient_def by blast
 
 lemma Union_quotient: "equiv A r \<Longrightarrow> \<Union>(A//r) = A"
   unfolding equiv_def refl_on_def quotient_def by blast
 
 lemma quotient_disj: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> Y \<in> A//r \<Longrightarrow> X = Y \<or> X \<inter> Y = {}"
   unfolding quotient_def equiv_def trans_def sym_def by blast
 
 lemma quotient_eqI:
   assumes "equiv A r" "X \<in> A//r" "Y \<in> A//r" and xy: "x \<in> X" "y \<in> Y" "(x, y) \<in> r"
   shows "X = Y"
 proof -
   obtain a b where "a \<in> A" and a: "X = r `` {a}" and "b \<in> A" and b: "Y = r `` {b}"
     using assms by (auto elim!: quotientE)
   then have "(a,b) \<in> r"
       using xy \<open>equiv A r\<close> unfolding equiv_def sym_def trans_def by blast
   then show ?thesis
     unfolding a b by (rule equiv_class_eq [OF \<open>equiv A r\<close>])
 qed
 
 lemma quotient_eq_iff:
   assumes "equiv A r" "X \<in> A//r" "Y \<in> A//r" and xy: "x \<in> X" "y \<in> Y" 
   shows "X = Y \<longleftrightarrow> (x, y) \<in> r"
 proof
   assume L: "X = Y" 
   with assms show "(x, y) \<in> r" 
     unfolding equiv_def sym_def trans_def by (blast elim!: quotientE)
 next
   assume \<section>: "(x, y) \<in> r" show "X = Y"
     by (rule quotient_eqI) (use \<section> assms in \<open>blast+\<close>)
 qed
 
 lemma eq_equiv_class_iff2: "equiv A r \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> {x}//r = {y}//r \<longleftrightarrow> (x, y) \<in> r"
   by (simp add: quotient_def eq_equiv_class_iff)
 
 lemma quotient_empty [simp]: "{}//r = {}"
   by (simp add: quotient_def)
 
 lemma quotient_is_empty [iff]: "A//r = {} \<longleftrightarrow> A = {}"
   by (simp add: quotient_def)
 
 lemma quotient_is_empty2 [iff]: "{} = A//r \<longleftrightarrow> A = {}"
   by (simp add: quotient_def)
 
 lemma singleton_quotient: "{x}//r = {r `` {x}}"
   by (simp add: quotient_def)
 
 lemma quotient_diff1: "inj_on (\<lambda>a. {a}//r) A \<Longrightarrow> a \<in> A \<Longrightarrow> (A - {a})//r = A//r - {a}//r"
   unfolding quotient_def inj_on_def by blast
 
 
 subsection \<open>Refinement of one equivalence relation WRT another\<close>
 
 lemma refines_equiv_class_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> R``(S``{a}) = S``{a}"
   by (auto simp: equiv_class_eq_iff)
 
 lemma refines_equiv_class_eq2: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> S``(R``{a}) = S``{a}"
   by (auto simp: equiv_class_eq_iff)
 
 lemma refines_equiv_image_eq: "R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> (\<lambda>X. S``X) ` (A//R) = A//S"
    by (auto simp: quotient_def image_UN refines_equiv_class_eq2)
 
 lemma finite_refines_finite:
   "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> finite (A//S)"
   by (erule finite_surj [where f = "\<lambda>X. S``X"]) (simp add: refines_equiv_image_eq)
 
 lemma finite_refines_card_le:
   "finite (A//R) \<Longrightarrow> R \<subseteq> S \<Longrightarrow> equiv A R \<Longrightarrow> equiv A S \<Longrightarrow> card (A//S) \<le> card (A//R)"
   by (subst refines_equiv_image_eq [of R S A, symmetric])
     (auto simp: card_image_le [where f = "\<lambda>X. S``X"])
 
 
 subsection \<open>Defining unary operations upon equivalence classes\<close>
 
 text \<open>A congruence-preserving function.\<close>
 
 definition congruent :: "('a \<times> 'a) set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "congruent r f \<longleftrightarrow> (\<forall>(y, z) \<in> r. f y = f z)"
 
 lemma congruentI: "(\<And>y z. (y, z) \<in> r \<Longrightarrow> f y = f z) \<Longrightarrow> congruent r f"
   by (auto simp add: congruent_def)
 
 lemma congruentD: "congruent r f \<Longrightarrow> (y, z) \<in> r \<Longrightarrow> f y = f z"
   by (auto simp add: congruent_def)
 
 abbreviation RESPECTS :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects" 80)
   where "f respects r \<equiv> congruent r f"
 
 
 lemma UN_constant_eq: "a \<in> A \<Longrightarrow> \<forall>y \<in> A. f y = c \<Longrightarrow> (\<Union>y \<in> A. f y) = c"
   \<comment> \<open>lemma required to prove \<open>UN_equiv_class\<close>\<close>
   by auto
 
 lemma UN_equiv_class:
   assumes "equiv A r" "f respects r" "a \<in> A"
   shows "(\<Union>x \<in> r``{a}. f x) = f a"
   \<comment> \<open>Conversion rule\<close>
 proof -
   have \<section>: "\<forall>x\<in>r `` {a}. f x = f a"
     using assms unfolding equiv_def congruent_def sym_def by blast
   show ?thesis
     by (iprover intro: assms UN_constant_eq [OF equiv_class_self \<section>])
 qed
 
 lemma UN_equiv_class_type:
   assumes r: "equiv A r" "f respects r" and X: "X \<in> A//r" and AB: "\<And>x. x \<in> A \<Longrightarrow> f x \<in> B"
   shows "(\<Union>x \<in> X. f x) \<in> B"
   using assms unfolding quotient_def
   by (auto simp: UN_equiv_class [OF r])
 
 text \<open>
   Sufficient conditions for injectiveness.  Could weaken premises!
   major premise could be an inclusion; \<open>bcong\<close> could be
   \<open>\<And>y. y \<in> A \<Longrightarrow> f y \<in> B\<close>.
 \<close>
 
 lemma UN_equiv_class_inject:
   assumes "equiv A r" "f respects r"
     and eq: "(\<Union>x \<in> X. f x) = (\<Union>y \<in> Y. f y)" 
     and X: "X \<in> A//r" and Y: "Y \<in> A//r" 
     and fr: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> (x, y) \<in> r"
   shows "X = Y"
 proof -
   obtain a b where "a \<in> A" and a: "X = r `` {a}" and "b \<in> A" and b: "Y = r `` {b}"
     using assms by (auto elim!: quotientE)
   then have "\<Union> (f ` r `` {a}) = f a" "\<Union> (f ` r `` {b}) = f b"
     by (iprover intro: UN_equiv_class [OF \<open>equiv A r\<close>] assms)+
   then have "f a = f b"
     using eq unfolding a b by (iprover intro: trans sym)
   then have "(a,b) \<in> r"
     using fr \<open>a \<in> A\<close> \<open>b \<in> A\<close> by blast
   then show ?thesis
     unfolding a b by (rule equiv_class_eq [OF \<open>equiv A r\<close>])
 qed
 
 
 subsection \<open>Defining binary operations upon equivalence classes\<close>
 
 text \<open>A congruence-preserving function of two arguments.\<close>
 
 definition congruent2 :: "('a \<times> 'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> bool"
   where "congruent2 r1 r2 f \<longleftrightarrow> (\<forall>(y1, z1) \<in> r1. \<forall>(y2, z2) \<in> r2. f y1 y2 = f z1 z2)"
 
 lemma congruent2I':
   assumes "\<And>y1 z1 y2 z2. (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
   shows "congruent2 r1 r2 f"
   using assms by (auto simp add: congruent2_def)
 
 lemma congruent2D: "congruent2 r1 r2 f \<Longrightarrow> (y1, z1) \<in> r1 \<Longrightarrow> (y2, z2) \<in> r2 \<Longrightarrow> f y1 y2 = f z1 z2"
   by (auto simp add: congruent2_def)
 
 text \<open>Abbreviation for the common case where the relations are identical.\<close>
 abbreviation RESPECTS2:: "('a \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"  (infixr "respects2" 80)
   where "f respects2 r \<equiv> congruent2 r r f"
 
 
 lemma congruent2_implies_congruent:
   "equiv A r1 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a \<in> A \<Longrightarrow> congruent r2 (f a)"
   unfolding congruent_def congruent2_def equiv_def refl_on_def by blast
 
 lemma congruent2_implies_congruent_UN:
   assumes "equiv A1 r1" "equiv A2 r2" "congruent2 r1 r2 f" "a \<in> A2" 
   shows "congruent r1 (\<lambda>x1. \<Union>x2 \<in> r2``{a}. f x1 x2)"
   unfolding congruent_def
 proof clarify
   fix c d
   assume cd: "(c,d) \<in> r1"
   then have "c \<in> A1" "d \<in> A1"
     using \<open>equiv A1 r1\<close> by (auto elim!: equiv_type [THEN subsetD, THEN SigmaE2])
-  with assms show "\<Union> (f c ` r2 `` {a}) = \<Union> (f d ` r2 `` {a})"
-  proof (simp add: UN_equiv_class congruent2_implies_congruent)
-    show "f c a = f d a"
-      using assms cd unfolding congruent2_def equiv_def refl_on_def by blast
-  qed
+  moreover have "f c a = f d a"
+    using assms cd unfolding congruent2_def equiv_def refl_on_def by blast
+  ultimately show "\<Union> (f c ` r2 `` {a}) = \<Union> (f d ` r2 `` {a})"
+    using assms by (simp add: UN_equiv_class congruent2_implies_congruent)
 qed
 
 lemma UN_equiv_class2:
   "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f \<Longrightarrow> a1 \<in> A1 \<Longrightarrow> a2 \<in> A2 \<Longrightarrow>
     (\<Union>x1 \<in> r1``{a1}. \<Union>x2 \<in> r2``{a2}. f x1 x2) = f a1 a2"
   by (simp add: UN_equiv_class congruent2_implies_congruent congruent2_implies_congruent_UN)
 
 lemma UN_equiv_class_type2:
   "equiv A1 r1 \<Longrightarrow> equiv A2 r2 \<Longrightarrow> congruent2 r1 r2 f
     \<Longrightarrow> X1 \<in> A1//r1 \<Longrightarrow> X2 \<in> A2//r2
     \<Longrightarrow> (\<And>x1 x2. x1 \<in> A1 \<Longrightarrow> x2 \<in> A2 \<Longrightarrow> f x1 x2 \<in> B)
     \<Longrightarrow> (\<Union>x1 \<in> X1. \<Union>x2 \<in> X2. f x1 x2) \<in> B"
   unfolding quotient_def
   by (blast intro: UN_equiv_class_type congruent2_implies_congruent_UN
                    congruent2_implies_congruent quotientI)
 
 
 lemma UN_UN_split_split_eq:
   "(\<Union>(x1, x2) \<in> X. \<Union>(y1, y2) \<in> Y. A x1 x2 y1 y2) =
     (\<Union>x \<in> X. \<Union>y \<in> Y. (\<lambda>(x1, x2). (\<lambda>(y1, y2). A x1 x2 y1 y2) y) x)"
   \<comment> \<open>Allows a natural expression of binary operators,\<close>
   \<comment> \<open>without explicit calls to \<open>split\<close>\<close>
   by auto
 
 lemma congruent2I:
   "equiv A1 r1 \<Longrightarrow> equiv A2 r2
     \<Longrightarrow> (\<And>y z w. w \<in> A2 \<Longrightarrow> (y,z) \<in> r1 \<Longrightarrow> f y w = f z w)
     \<Longrightarrow> (\<And>y z w. w \<in> A1 \<Longrightarrow> (y,z) \<in> r2 \<Longrightarrow> f w y = f w z)
     \<Longrightarrow> congruent2 r1 r2 f"
   \<comment> \<open>Suggested by John Harrison -- the two subproofs may be\<close>
   \<comment> \<open>\<^emph>\<open>much\<close> simpler than the direct proof.\<close>
   unfolding congruent2_def equiv_def refl_on_def
   by (blast intro: trans)
 
 lemma congruent2_commuteI:
   assumes equivA: "equiv A r"
     and commute: "\<And>y z. y \<in> A \<Longrightarrow> z \<in> A \<Longrightarrow> f y z = f z y"
     and congt: "\<And>y z w. w \<in> A \<Longrightarrow> (y,z) \<in> r \<Longrightarrow> f w y = f w z"
   shows "f respects2 r"
 proof (rule congruent2I [OF equivA equivA])
   note eqv = equivA [THEN equiv_type, THEN subsetD, THEN SigmaE2]
   show "\<And>y z w. \<lbrakk>w \<in> A; (y, z) \<in> r\<rbrakk> \<Longrightarrow> f y w = f z w"
     by (iprover intro: commute [THEN trans] sym congt elim: eqv)
   show "\<And>y z w. \<lbrakk>w \<in> A; (y, z) \<in> r\<rbrakk> \<Longrightarrow> f w y = f w z"
     by (iprover intro: congt elim: eqv)
 qed
 
 
 subsection \<open>Quotients and finiteness\<close>
 
 text \<open>Suggested by Florian Kammüller\<close>
 
 lemma finite_quotient:
   assumes "finite A" "r \<subseteq> A \<times> A"
   shows "finite (A//r)"
     \<comment> \<open>recall @{thm equiv_type}\<close>
 proof -
   have "A//r \<subseteq> Pow A"
     using assms unfolding quotient_def by blast
   moreover have "finite (Pow A)"
     using assms by simp
   ultimately show ?thesis
     by (iprover intro: finite_subset)
 qed
 
 lemma finite_equiv_class: "finite A \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> X \<in> A//r \<Longrightarrow> finite X"
   unfolding quotient_def
   by (erule rev_finite_subset) blast
 
 lemma equiv_imp_dvd_card:
   assumes "finite A" "equiv A r" "\<And>X. X \<in> A//r \<Longrightarrow> k dvd card X"
   shows "k dvd card A"
 proof (rule Union_quotient [THEN subst])
   show "k dvd card (\<Union> (A // r))"
     apply (rule dvd_partition)
     using assms
     by (auto simp: Union_quotient dest: quotient_disj)
 qed (use assms in blast)
 
 
 subsection \<open>Projection\<close>
 
 definition proj :: "('b \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'a set"
   where "proj r x = r `` {x}"
 
 lemma proj_preserves: "x \<in> A \<Longrightarrow> proj r x \<in> A//r"
   unfolding proj_def by (rule quotientI)
 
 lemma proj_in_iff:
   assumes "equiv A r"
   shows "proj r x \<in> A//r \<longleftrightarrow> x \<in> A"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs by (simp add: proj_preserves)
 next
   assume ?lhs
   then show ?rhs
     unfolding proj_def quotient_def
-  proof clarsimp
+  proof safe
     fix y
     assume y: "y \<in> A" and "r `` {x} = r `` {y}"
     moreover have "y \<in> r `` {y}"
       using assms y unfolding equiv_def refl_on_def by blast
     ultimately have "(x, y) \<in> r" by blast
     then show "x \<in> A"
       using assms unfolding equiv_def refl_on_def by blast
   qed
 qed
 
 lemma proj_iff: "equiv A r \<Longrightarrow> {x, y} \<subseteq> A \<Longrightarrow> proj r x = proj r y \<longleftrightarrow> (x, y) \<in> r"
   by (simp add: proj_def eq_equiv_class_iff)
 
 (*
 lemma in_proj: "\<lbrakk>equiv A r; x \<in> A\<rbrakk> \<Longrightarrow> x \<in> proj r x"
 unfolding proj_def equiv_def refl_on_def by blast
 *)
 
 lemma proj_image: "proj r ` A = A//r"
   unfolding proj_def[abs_def] quotient_def by blast
 
 lemma in_quotient_imp_non_empty: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<noteq> {}"
   unfolding quotient_def using equiv_class_self by fast
 
 lemma in_quotient_imp_in_rel: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> {x, y} \<subseteq> X \<Longrightarrow> (x, y) \<in> r"
   using quotient_eq_iff[THEN iffD1] by fastforce
 
 lemma in_quotient_imp_closed: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> x \<in> X \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> y \<in> X"
   unfolding quotient_def equiv_def trans_def by blast
 
 lemma in_quotient_imp_subset: "equiv A r \<Longrightarrow> X \<in> A//r \<Longrightarrow> X \<subseteq> A"
   using in_quotient_imp_in_rel equiv_type by fastforce
 
 
 subsection \<open>Equivalence relations -- predicate version\<close>
 
 text \<open>Partial equivalences.\<close>
 
 definition part_equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> (\<forall>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y)"
     \<comment> \<open>John-Harrison-style characterization\<close>
 
 lemma part_equivpI: "\<exists>x. R x x \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> part_equivp R"
   by (auto simp add: part_equivp_def) (auto elim: sympE transpE)
 
 lemma part_equivpE:
   assumes "part_equivp R"
   obtains x where "R x x" and "symp R" and "transp R"
 proof -
   from assms have 1: "\<exists>x. R x x"
     and 2: "\<And>x y. R x y \<longleftrightarrow> R x x \<and> R y y \<and> R x = R y"
     unfolding part_equivp_def by blast+
   from 1 obtain x where "R x x" ..
   moreover have "symp R"
   proof (rule sympI)
     fix x y
     assume "R x y"
     with 2 [of x y] show "R y x" by auto
   qed
   moreover have "transp R"
   proof (rule transpI)
     fix x y z
     assume "R x y" and "R y z"
     with 2 [of x y] 2 [of y z] show "R x z" by auto
   qed
   ultimately show thesis by (rule that)
 qed
 
 lemma part_equivp_refl_symp_transp: "part_equivp R \<longleftrightarrow> (\<exists>x. R x x) \<and> symp R \<and> transp R"
   by (auto intro: part_equivpI elim: part_equivpE)
 
 lemma part_equivp_symp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
   by (erule part_equivpE, erule sympE)
 
 lemma part_equivp_transp: "part_equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   by (erule part_equivpE, erule transpE)
 
 lemma part_equivp_typedef: "part_equivp R \<Longrightarrow> \<exists>d. d \<in> {c. \<exists>x. R x x \<and> c = Collect (R x)}"
   by (auto elim: part_equivpE)
 
 
 text \<open>Total equivalences.\<close>
 
 definition equivp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "equivp R \<longleftrightarrow> (\<forall>x y. R x y = (R x = R y))" \<comment> \<open>John-Harrison-style characterization\<close>
 
 lemma equivpI: "reflp R \<Longrightarrow> symp R \<Longrightarrow> transp R \<Longrightarrow> equivp R"
   by (auto elim: reflpE sympE transpE simp add: equivp_def)
 
 lemma equivpE:
   assumes "equivp R"
   obtains "reflp R" and "symp R" and "transp R"
   using assms by (auto intro!: that reflpI sympI transpI simp add: equivp_def)
 
 lemma equivp_implies_part_equivp: "equivp R \<Longrightarrow> part_equivp R"
   by (auto intro: part_equivpI elim: equivpE reflpE)
 
 lemma equivp_equiv: "equiv UNIV A \<longleftrightarrow> equivp (\<lambda>x y. (x, y) \<in> A)"
   by (auto intro!: equivI equivpI [to_set] elim!: equivE equivpE [to_set])
 
 lemma equivp_reflp_symp_transp: "equivp R \<longleftrightarrow> reflp R \<and> symp R \<and> transp R"
   by (auto intro: equivpI elim: equivpE)
 
 lemma identity_equivp: "equivp (=)"
   by (auto intro: equivpI reflpI sympI transpI)
 
 lemma equivp_reflp: "equivp R \<Longrightarrow> R x x"
   by (erule equivpE, erule reflpE)
 
 lemma equivp_symp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y x"
   by (erule equivpE, erule sympE)
 
 lemma equivp_transp: "equivp R \<Longrightarrow> R x y \<Longrightarrow> R y z \<Longrightarrow> R x z"
   by (erule equivpE, erule transpE)
 
 lemma equivp_rtranclp: "symp r \<Longrightarrow> equivp r\<^sup>*\<^sup>*"
   by(intro equivpI reflpI sympI transpI)(auto dest: sympD[OF symp_rtranclp])
 
 lemmas equivp_rtranclp_symclp [simp] = equivp_rtranclp[OF symp_symclp]
 
 lemma equivp_vimage2p: "equivp R \<Longrightarrow> equivp (vimage2p f f R)"
   by(auto simp add: equivp_def vimage2p_def dest: fun_cong)
 
 lemma equivp_imp_transp: "equivp R \<Longrightarrow> transp R"
   by(simp add: equivp_reflp_symp_transp)
 
 
 subsection \<open>Equivalence closure\<close>
 
 definition equivclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
   "equivclp r = (symclp r)\<^sup>*\<^sup>*"
 
 lemma transp_equivclp [simp]: "transp (equivclp r)"
   by(simp add: equivclp_def)
 
 lemma reflp_equivclp [simp]: "reflp (equivclp r)"
   by(simp add: equivclp_def)
 
 lemma symp_equivclp [simp]: "symp (equivclp r)"
   by(simp add: equivclp_def)
 
 lemma equivp_evquivclp [simp]: "equivp (equivclp r)"
   by(simp add: equivpI)
 
 lemma tranclp_equivclp [simp]: "(equivclp r)\<^sup>+\<^sup>+ = equivclp r"
   by(simp add: equivclp_def)
 
 lemma rtranclp_equivclp [simp]: "(equivclp r)\<^sup>*\<^sup>* = equivclp r"
   by(simp add: equivclp_def)
 
 lemma symclp_equivclp [simp]: "symclp (equivclp r) = equivclp r"
   by(simp add: equivclp_def symp_symclp_eq)
 
 lemma equivclp_symclp [simp]: "equivclp (symclp r) = equivclp r"
   by(simp add: equivclp_def)
 
 lemma equivclp_conversep [simp]: "equivclp (conversep r) = equivclp r"
   by(simp add: equivclp_def)
 
 lemma equivclp_sym [sym]: "equivclp r x y \<Longrightarrow> equivclp r y x"
   by(rule sympD[OF symp_equivclp])
 
 lemma equivclp_OO_equivclp_le_equivclp: "equivclp r OO equivclp r \<le> equivclp r"
   by(rule transp_relcompp_less_eq transp_equivclp)+
 
 lemma rtranlcp_le_equivclp: "r\<^sup>*\<^sup>* \<le> equivclp r"
   unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)
 
 lemma rtranclp_conversep_le_equivclp: "r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
   unfolding equivclp_def by(rule rtranclp_mono)(simp add: symclp_pointfree)
 
 lemma symclp_rtranclp_le_equivclp: "symclp r\<^sup>*\<^sup>* \<le> equivclp r"
   unfolding symclp_pointfree
   by(rule le_supI)(simp_all add: rtranclp_conversep[symmetric] rtranlcp_le_equivclp rtranclp_conversep_le_equivclp)
 
 lemma r_OO_conversep_into_equivclp:
   "r\<^sup>*\<^sup>* OO r\<inverse>\<inverse>\<^sup>*\<^sup>* \<le> equivclp r"
   by(blast intro: order_trans[OF _ equivclp_OO_equivclp_le_equivclp] relcompp_mono rtranlcp_le_equivclp rtranclp_conversep_le_equivclp del: predicate2I)
 
 lemma equivclp_induct [consumes 1, case_names base step, induct pred: equivclp]:
   assumes a: "equivclp r a b"
     and cases: "P a" "\<And>y z. equivclp r a y \<Longrightarrow> r y z \<or> r z y \<Longrightarrow> P y \<Longrightarrow> P z"
   shows "P b"
   using a unfolding equivclp_def
   by(induction rule: rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)
 
 lemma converse_equivclp_induct [consumes 1, case_names base step]:
   assumes major: "equivclp r a b"
     and cases: "P b" "\<And>y z. r y z \<or> r z y \<Longrightarrow> equivclp r z b \<Longrightarrow> P z \<Longrightarrow> P y"
   shows "P a"
   using major unfolding equivclp_def
   by(induction rule: converse_rtranclp_induct; fold equivclp_def; blast intro: cases elim: symclpE)
 
 lemma equivclp_refl [simp]: "equivclp r x x"
   by(rule reflpD[OF reflp_equivclp])
 
 lemma r_into_equivclp [intro]: "r x y \<Longrightarrow> equivclp r x y"
   unfolding equivclp_def by(blast intro: symclpI)
 
 lemma converse_r_into_equivclp [intro]: "r y x \<Longrightarrow> equivclp r x y"
   unfolding equivclp_def by(blast intro: symclpI)
 
 lemma rtranclp_into_equivclp: "r\<^sup>*\<^sup>* x y \<Longrightarrow> equivclp r x y"
   using rtranlcp_le_equivclp[of r] by blast
 
 lemma converse_rtranclp_into_equivclp: "r\<^sup>*\<^sup>* y x \<Longrightarrow> equivclp r x y"
   by(blast intro: equivclp_sym rtranclp_into_equivclp)
 
 lemma equivclp_into_equivclp: "\<lbrakk> equivclp r a b; r b c \<or> r c b \<rbrakk> \<Longrightarrow> equivclp r a c"
   unfolding equivclp_def by(erule rtranclp.rtrancl_into_rtrancl)(auto intro: symclpI)
 
 lemma equivclp_trans [trans]: "\<lbrakk> equivclp r a b; equivclp r b c \<rbrakk> \<Longrightarrow> equivclp r a c"
   using equivclp_OO_equivclp_le_equivclp[of r] by blast
 
 hide_const (open) proj
 
 end
diff --git a/src/HOL/Euclidean_Division.thy b/src/HOL/Euclidean_Division.thy
--- a/src/HOL/Euclidean_Division.thy
+++ b/src/HOL/Euclidean_Division.thy
@@ -1,2143 +1,2144 @@
 (*  Title:      HOL/Euclidean_Division.thy
     Author:     Manuel Eberl, TU Muenchen
     Author:     Florian Haftmann, TU Muenchen
 *)
 
 section \<open>Division in euclidean (semi)rings\<close>
 
 theory Euclidean_Division
   imports Int Lattices_Big
 begin
 
 subsection \<open>Euclidean (semi)rings with explicit division and remainder\<close>
   
 class euclidean_semiring = semidom_modulo + 
   fixes euclidean_size :: "'a \<Rightarrow> nat"
   assumes size_0 [simp]: "euclidean_size 0 = 0"
   assumes mod_size_less: 
     "b \<noteq> 0 \<Longrightarrow> euclidean_size (a mod b) < euclidean_size b"
   assumes size_mult_mono:
     "b \<noteq> 0 \<Longrightarrow> euclidean_size a \<le> euclidean_size (a * b)"
 begin
 
 lemma euclidean_size_eq_0_iff [simp]:
   "euclidean_size b = 0 \<longleftrightarrow> b = 0"
 proof
   assume "b = 0"
   then show "euclidean_size b = 0"
     by simp
 next
   assume "euclidean_size b = 0"
   show "b = 0"
   proof (rule ccontr)
     assume "b \<noteq> 0"
     with mod_size_less have "euclidean_size (b mod b) < euclidean_size b" .
     with \<open>euclidean_size b = 0\<close> show False
       by simp
   qed
 qed
 
 lemma euclidean_size_greater_0_iff [simp]:
   "euclidean_size b > 0 \<longleftrightarrow> b \<noteq> 0"
   using euclidean_size_eq_0_iff [symmetric, of b] by safe simp
 
 lemma size_mult_mono': "b \<noteq> 0 \<Longrightarrow> euclidean_size a \<le> euclidean_size (b * a)"
   by (subst mult.commute) (rule size_mult_mono)
 
 lemma dvd_euclidean_size_eq_imp_dvd:
   assumes "a \<noteq> 0" and "euclidean_size a = euclidean_size b"
     and "b dvd a" 
   shows "a dvd b"
 proof (rule ccontr)
   assume "\<not> a dvd b"
   hence "b mod a \<noteq> 0" using mod_0_imp_dvd [of b a] by blast
   then have "b mod a \<noteq> 0" by (simp add: mod_eq_0_iff_dvd)
   from \<open>b dvd a\<close> have "b dvd b mod a" by (simp add: dvd_mod_iff)
   then obtain c where "b mod a = b * c" unfolding dvd_def by blast
     with \<open>b mod a \<noteq> 0\<close> have "c \<noteq> 0" by auto
   with \<open>b mod a = b * c\<close> have "euclidean_size (b mod a) \<ge> euclidean_size b"
     using size_mult_mono by force
   moreover from \<open>\<not> a dvd b\<close> and \<open>a \<noteq> 0\<close>
   have "euclidean_size (b mod a) < euclidean_size a"
     using mod_size_less by blast
   ultimately show False using \<open>euclidean_size a = euclidean_size b\<close>
     by simp
 qed
 
 lemma euclidean_size_times_unit:
   assumes "is_unit a"
   shows   "euclidean_size (a * b) = euclidean_size b"
 proof (rule antisym)
   from assms have [simp]: "a \<noteq> 0" by auto
   thus "euclidean_size (a * b) \<ge> euclidean_size b" by (rule size_mult_mono')
   from assms have "is_unit (1 div a)" by simp
   hence "1 div a \<noteq> 0" by (intro notI) simp_all
   hence "euclidean_size (a * b) \<le> euclidean_size ((1 div a) * (a * b))"
     by (rule size_mult_mono')
   also from assms have "(1 div a) * (a * b) = b"
     by (simp add: algebra_simps unit_div_mult_swap)
   finally show "euclidean_size (a * b) \<le> euclidean_size b" .
 qed
 
 lemma euclidean_size_unit:
   "is_unit a \<Longrightarrow> euclidean_size a = euclidean_size 1"
   using euclidean_size_times_unit [of a 1] by simp
 
 lemma unit_iff_euclidean_size: 
   "is_unit a \<longleftrightarrow> euclidean_size a = euclidean_size 1 \<and> a \<noteq> 0"
 proof safe
   assume A: "a \<noteq> 0" and B: "euclidean_size a = euclidean_size 1"
   show "is_unit a"
     by (rule dvd_euclidean_size_eq_imp_dvd [OF A B]) simp_all
 qed (auto intro: euclidean_size_unit)
 
 lemma euclidean_size_times_nonunit:
   assumes "a \<noteq> 0" "b \<noteq> 0" "\<not> is_unit a"
   shows   "euclidean_size b < euclidean_size (a * b)"
 proof (rule ccontr)
   assume "\<not>euclidean_size b < euclidean_size (a * b)"
   with size_mult_mono'[OF assms(1), of b] 
     have eq: "euclidean_size (a * b) = euclidean_size b" by simp
   have "a * b dvd b"
-    by (rule dvd_euclidean_size_eq_imp_dvd [OF _ eq]) (insert assms, simp_all)
+    by (rule dvd_euclidean_size_eq_imp_dvd [OF _ eq])
+       (use assms in simp_all)
   hence "a * b dvd 1 * b" by simp
   with \<open>b \<noteq> 0\<close> have "is_unit a" by (subst (asm) dvd_times_right_cancel_iff)
   with assms(3) show False by contradiction
 qed
 
 lemma dvd_imp_size_le:
   assumes "a dvd b" "b \<noteq> 0" 
   shows   "euclidean_size a \<le> euclidean_size b"
-  using assms by (auto elim!: dvdE simp: size_mult_mono)
+  using assms by (auto simp: size_mult_mono)
 
 lemma dvd_proper_imp_size_less:
   assumes "a dvd b" "\<not> b dvd a" "b \<noteq> 0" 
   shows   "euclidean_size a < euclidean_size b"
 proof -
   from assms(1) obtain c where "b = a * c" by (erule dvdE)
   hence z: "b = c * a" by (simp add: mult.commute)
   from z assms have "\<not>is_unit c" by (auto simp: mult.commute mult_unit_dvd_iff)
   with z assms show ?thesis
     by (auto intro!: euclidean_size_times_nonunit)
 qed
 
 lemma unit_imp_mod_eq_0:
   "a mod b = 0" if "is_unit b"
   using that by (simp add: mod_eq_0_iff_dvd unit_imp_dvd)
 
 lemma mod_eq_self_iff_div_eq_0:
   "a mod b = a \<longleftrightarrow> a div b = 0" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   with div_mult_mod_eq [of a b] show ?Q
     by auto
 next
   assume ?Q
   with div_mult_mod_eq [of a b] show ?P
     by simp
 qed
 
 lemma coprime_mod_left_iff [simp]:
   "coprime (a mod b) b \<longleftrightarrow> coprime a b" if "b \<noteq> 0"
-  by (rule; rule coprimeI)
+  by (rule iffI; rule coprimeI)
     (use that in \<open>auto dest!: dvd_mod_imp_dvd coprime_common_divisor simp add: dvd_mod_iff\<close>)
 
 lemma coprime_mod_right_iff [simp]:
   "coprime a (b mod a) \<longleftrightarrow> coprime a b" if "a \<noteq> 0"
   using that coprime_mod_left_iff [of a b] by (simp add: ac_simps)
 
 end
 
 class euclidean_ring = idom_modulo + euclidean_semiring
 begin
 
 lemma dvd_diff_commute [ac_simps]:
   "a dvd c - b \<longleftrightarrow> a dvd b - c"
 proof -
   have "a dvd c - b \<longleftrightarrow> a dvd (c - b) * - 1"
     by (subst dvd_mult_unit_iff) simp_all
   then show ?thesis
     by simp
 qed
  
 end
 
 
 subsection \<open>Euclidean (semi)rings with cancel rules\<close>
 
 class euclidean_semiring_cancel = euclidean_semiring +
   assumes div_mult_self1 [simp]: "b \<noteq> 0 \<Longrightarrow> (a + c * b) div b = c + a div b"
   and div_mult_mult1 [simp]: "c \<noteq> 0 \<Longrightarrow> (c * a) div (c * b) = a div b"
 begin
 
 lemma div_mult_self2 [simp]:
   assumes "b \<noteq> 0"
   shows "(a + b * c) div b = c + a div b"
   using assms div_mult_self1 [of b a c] by (simp add: mult.commute)
 
 lemma div_mult_self3 [simp]:
   assumes "b \<noteq> 0"
   shows "(c * b + a) div b = c + a div b"
   using assms by (simp add: add.commute)
 
 lemma div_mult_self4 [simp]:
   assumes "b \<noteq> 0"
   shows "(b * c + a) div b = c + a div b"
   using assms by (simp add: add.commute)
 
 lemma mod_mult_self1 [simp]: "(a + c * b) mod b = a mod b"
 proof (cases "b = 0")
   case True then show ?thesis by simp
 next
   case False
   have "a + c * b = (a + c * b) div b * b + (a + c * b) mod b"
     by (simp add: div_mult_mod_eq)
   also from False div_mult_self1 [of b a c] have
     "\<dots> = (c + a div b) * b + (a + c * b) mod b"
       by (simp add: algebra_simps)
   finally have "a = a div b * b + (a + c * b) mod b"
     by (simp add: add.commute [of a] add.assoc distrib_right)
   then have "a div b * b + (a + c * b) mod b = a div b * b + a mod b"
     by (simp add: div_mult_mod_eq)
   then show ?thesis by simp
 qed
 
 lemma mod_mult_self2 [simp]:
   "(a + b * c) mod b = a mod b"
   by (simp add: mult.commute [of b])
 
 lemma mod_mult_self3 [simp]:
   "(c * b + a) mod b = a mod b"
   by (simp add: add.commute)
 
 lemma mod_mult_self4 [simp]:
   "(b * c + a) mod b = a mod b"
   by (simp add: add.commute)
 
 lemma mod_mult_self1_is_0 [simp]:
   "b * a mod b = 0"
   using mod_mult_self2 [of 0 b a] by simp
 
 lemma mod_mult_self2_is_0 [simp]:
   "a * b mod b = 0"
   using mod_mult_self1 [of 0 a b] by simp
 
 lemma div_add_self1:
   assumes "b \<noteq> 0"
   shows "(b + a) div b = a div b + 1"
   using assms div_mult_self1 [of b a 1] by (simp add: add.commute)
 
 lemma div_add_self2:
   assumes "b \<noteq> 0"
   shows "(a + b) div b = a div b + 1"
   using assms div_add_self1 [of b a] by (simp add: add.commute)
 
 lemma mod_add_self1 [simp]:
   "(b + a) mod b = a mod b"
   using mod_mult_self1 [of a 1 b] by (simp add: add.commute)
 
 lemma mod_add_self2 [simp]:
   "(a + b) mod b = a mod b"
   using mod_mult_self1 [of a 1 b] by simp
 
 lemma mod_div_trivial [simp]:
   "a mod b div b = 0"
 proof (cases "b = 0")
   assume "b = 0"
   thus ?thesis by simp
 next
   assume "b \<noteq> 0"
   hence "a div b + a mod b div b = (a mod b + a div b * b) div b"
     by (rule div_mult_self1 [symmetric])
   also have "\<dots> = a div b"
     by (simp only: mod_div_mult_eq)
   also have "\<dots> = a div b + 0"
     by simp
   finally show ?thesis
     by (rule add_left_imp_eq)
 qed
 
 lemma mod_mod_trivial [simp]:
   "a mod b mod b = a mod b"
 proof -
   have "a mod b mod b = (a mod b + a div b * b) mod b"
     by (simp only: mod_mult_self1)
   also have "\<dots> = a mod b"
     by (simp only: mod_div_mult_eq)
   finally show ?thesis .
 qed
 
 lemma mod_mod_cancel:
   assumes "c dvd b"
   shows "a mod b mod c = a mod c"
 proof -
   from \<open>c dvd b\<close> obtain k where "b = c * k"
     by (rule dvdE)
   have "a mod b mod c = a mod (c * k) mod c"
     by (simp only: \<open>b = c * k\<close>)
   also have "\<dots> = (a mod (c * k) + a div (c * k) * k * c) mod c"
     by (simp only: mod_mult_self1)
   also have "\<dots> = (a div (c * k) * (c * k) + a mod (c * k)) mod c"
     by (simp only: ac_simps)
   also have "\<dots> = a mod c"
     by (simp only: div_mult_mod_eq)
   finally show ?thesis .
 qed
 
 lemma div_mult_mult2 [simp]:
   "c \<noteq> 0 \<Longrightarrow> (a * c) div (b * c) = a div b"
   by (drule div_mult_mult1) (simp add: mult.commute)
 
 lemma div_mult_mult1_if [simp]:
   "(c * a) div (c * b) = (if c = 0 then 0 else a div b)"
   by simp_all
 
 lemma mod_mult_mult1:
   "(c * a) mod (c * b) = c * (a mod b)"
 proof (cases "c = 0")
   case True then show ?thesis by simp
 next
   case False
   from div_mult_mod_eq
   have "((c * a) div (c * b)) * (c * b) + (c * a) mod (c * b) = c * a" .
   with False have "c * ((a div b) * b + a mod b) + (c * a) mod (c * b)
     = c * a + c * (a mod b)" by (simp add: algebra_simps)
   with div_mult_mod_eq show ?thesis by simp
 qed
 
 lemma mod_mult_mult2:
   "(a * c) mod (b * c) = (a mod b) * c"
   using mod_mult_mult1 [of c a b] by (simp add: mult.commute)
 
 lemma mult_mod_left: "(a mod b) * c = (a * c) mod (b * c)"
   by (fact mod_mult_mult2 [symmetric])
 
 lemma mult_mod_right: "c * (a mod b) = (c * a) mod (c * b)"
   by (fact mod_mult_mult1 [symmetric])
 
 lemma dvd_mod: "k dvd m \<Longrightarrow> k dvd n \<Longrightarrow> k dvd (m mod n)"
   unfolding dvd_def by (auto simp add: mod_mult_mult1)
 
 lemma div_plus_div_distrib_dvd_left:
   "c dvd a \<Longrightarrow> (a + b) div c = a div c + b div c"
   by (cases "c = 0") (auto elim: dvdE)
 
 lemma div_plus_div_distrib_dvd_right:
   "c dvd b \<Longrightarrow> (a + b) div c = a div c + b div c"
   using div_plus_div_distrib_dvd_left [of c b a]
   by (simp add: ac_simps)
 
 lemma sum_div_partition:
   \<open>(\<Sum>a\<in>A. f a) div b = (\<Sum>a\<in>A \<inter> {a. b dvd f a}. f a div b) + (\<Sum>a\<in>A \<inter> {a. \<not> b dvd f a}. f a) div b\<close>
     if \<open>finite A\<close>
 proof -
   have \<open>A = A \<inter> {a. b dvd f a} \<union> A \<inter> {a. \<not> b dvd f a}\<close>
     by auto
   then have \<open>(\<Sum>a\<in>A. f a) = (\<Sum>a\<in>A \<inter> {a. b dvd f a} \<union> A \<inter> {a. \<not> b dvd f a}. f a)\<close>
     by simp
   also have \<open>\<dots> = (\<Sum>a\<in>A \<inter> {a. b dvd f a}. f a) + (\<Sum>a\<in>A \<inter> {a. \<not> b dvd f a}. f a)\<close>
     using \<open>finite A\<close> by (auto intro: sum.union_inter_neutral)
   finally have *: \<open>sum f A = sum f (A \<inter> {a. b dvd f a}) + sum f (A \<inter> {a. \<not> b dvd f a})\<close> .
   define B where B: \<open>B = A \<inter> {a. b dvd f a}\<close>
   with \<open>finite A\<close> have \<open>finite B\<close> and \<open>a \<in> B \<Longrightarrow> b dvd f a\<close> for a
     by simp_all
   then have \<open>(\<Sum>a\<in>B. f a) div b = (\<Sum>a\<in>B. f a div b)\<close> and \<open>b dvd (\<Sum>a\<in>B. f a)\<close>
     by induction (simp_all add: div_plus_div_distrib_dvd_left)
   then show ?thesis using *
     by (simp add: B div_plus_div_distrib_dvd_left)
 qed
 
 named_theorems mod_simps
 
 text \<open>Addition respects modular equivalence.\<close>
 
 lemma mod_add_left_eq [mod_simps]:
   "(a mod c + b) mod c = (a + b) mod c"
 proof -
   have "(a + b) mod c = (a div c * c + a mod c + b) mod c"
     by (simp only: div_mult_mod_eq)
   also have "\<dots> = (a mod c + b + a div c * c) mod c"
     by (simp only: ac_simps)
   also have "\<dots> = (a mod c + b) mod c"
     by (rule mod_mult_self1)
   finally show ?thesis
     by (rule sym)
 qed
 
 lemma mod_add_right_eq [mod_simps]:
   "(a + b mod c) mod c = (a + b) mod c"
   using mod_add_left_eq [of b c a] by (simp add: ac_simps)
 
 lemma mod_add_eq:
   "(a mod c + b mod c) mod c = (a + b) mod c"
   by (simp add: mod_add_left_eq mod_add_right_eq)
 
 lemma mod_sum_eq [mod_simps]:
   "(\<Sum>i\<in>A. f i mod a) mod a = sum f A mod a"
 proof (induct A rule: infinite_finite_induct)
   case (insert i A)
   then have "(\<Sum>i\<in>insert i A. f i mod a) mod a
     = (f i mod a + (\<Sum>i\<in>A. f i mod a)) mod a"
     by simp
   also have "\<dots> = (f i + (\<Sum>i\<in>A. f i mod a) mod a) mod a"
     by (simp add: mod_simps)
   also have "\<dots> = (f i + (\<Sum>i\<in>A. f i) mod a) mod a"
     by (simp add: insert.hyps)
   finally show ?case
     by (simp add: insert.hyps mod_simps)
 qed simp_all
 
 lemma mod_add_cong:
   assumes "a mod c = a' mod c"
   assumes "b mod c = b' mod c"
   shows "(a + b) mod c = (a' + b') mod c"
 proof -
   have "(a mod c + b mod c) mod c = (a' mod c + b' mod c) mod c"
     unfolding assms ..
   then show ?thesis
     by (simp add: mod_add_eq)
 qed
 
 text \<open>Multiplication respects modular equivalence.\<close>
 
 lemma mod_mult_left_eq [mod_simps]:
   "((a mod c) * b) mod c = (a * b) mod c"
 proof -
   have "(a * b) mod c = ((a div c * c + a mod c) * b) mod c"
     by (simp only: div_mult_mod_eq)
   also have "\<dots> = (a mod c * b + a div c * b * c) mod c"
     by (simp only: algebra_simps)
   also have "\<dots> = (a mod c * b) mod c"
     by (rule mod_mult_self1)
   finally show ?thesis
     by (rule sym)
 qed
 
 lemma mod_mult_right_eq [mod_simps]:
   "(a * (b mod c)) mod c = (a * b) mod c"
   using mod_mult_left_eq [of b c a] by (simp add: ac_simps)
 
 lemma mod_mult_eq:
   "((a mod c) * (b mod c)) mod c = (a * b) mod c"
   by (simp add: mod_mult_left_eq mod_mult_right_eq)
 
 lemma mod_prod_eq [mod_simps]:
   "(\<Prod>i\<in>A. f i mod a) mod a = prod f A mod a"
 proof (induct A rule: infinite_finite_induct)
   case (insert i A)
   then have "(\<Prod>i\<in>insert i A. f i mod a) mod a
     = (f i mod a * (\<Prod>i\<in>A. f i mod a)) mod a"
     by simp
   also have "\<dots> = (f i * ((\<Prod>i\<in>A. f i mod a) mod a)) mod a"
     by (simp add: mod_simps)
   also have "\<dots> = (f i * ((\<Prod>i\<in>A. f i) mod a)) mod a"
     by (simp add: insert.hyps)
   finally show ?case
     by (simp add: insert.hyps mod_simps)
 qed simp_all
 
 lemma mod_mult_cong:
   assumes "a mod c = a' mod c"
   assumes "b mod c = b' mod c"
   shows "(a * b) mod c = (a' * b') mod c"
 proof -
   have "(a mod c * (b mod c)) mod c = (a' mod c * (b' mod c)) mod c"
     unfolding assms ..
   then show ?thesis
     by (simp add: mod_mult_eq)
 qed
 
 text \<open>Exponentiation respects modular equivalence.\<close>
 
 lemma power_mod [mod_simps]: 
   "((a mod b) ^ n) mod b = (a ^ n) mod b"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   have "(a mod b) ^ Suc n mod b = (a mod b) * ((a mod b) ^ n mod b) mod b"
     by (simp add: mod_mult_right_eq)
   with Suc show ?case
     by (simp add: mod_mult_left_eq mod_mult_right_eq)
 qed
 
 lemma power_diff_power_eq:
   \<open>a ^ m div a ^ n = (if n \<le> m then a ^ (m - n) else 1 div a ^ (n - m))\<close>
     if \<open>a \<noteq> 0\<close>
 proof (cases \<open>n \<le> m\<close>)
   case True
   with that power_diff [symmetric, of a n m] show ?thesis by simp
 next
   case False
   then obtain q where n: \<open>n = m + Suc q\<close>
     by (auto simp add: not_le dest: less_imp_Suc_add)
   then have \<open>a ^ m div a ^ n = (a ^ m * 1) div (a ^ m * a ^ Suc q)\<close>
     by (simp add: power_add ac_simps)
   moreover from that have \<open>a ^ m \<noteq> 0\<close>
     by simp
   ultimately have \<open>a ^ m div a ^ n = 1 div a ^ Suc q\<close>
     by (subst (asm) div_mult_mult1) simp
   with False n show ?thesis
     by simp
 qed
 
 end
 
 
 class euclidean_ring_cancel = euclidean_ring + euclidean_semiring_cancel
 begin
 
 subclass idom_divide ..
 
 lemma div_minus_minus [simp]: "(- a) div (- b) = a div b"
   using div_mult_mult1 [of "- 1" a b] by simp
 
 lemma mod_minus_minus [simp]: "(- a) mod (- b) = - (a mod b)"
   using mod_mult_mult1 [of "- 1" a b] by simp
 
 lemma div_minus_right: "a div (- b) = (- a) div b"
   using div_minus_minus [of "- a" b] by simp
 
 lemma mod_minus_right: "a mod (- b) = - ((- a) mod b)"
   using mod_minus_minus [of "- a" b] by simp
 
 lemma div_minus1_right [simp]: "a div (- 1) = - a"
   using div_minus_right [of a 1] by simp
 
 lemma mod_minus1_right [simp]: "a mod (- 1) = 0"
   using mod_minus_right [of a 1] by simp
 
 text \<open>Negation respects modular equivalence.\<close>
 
 lemma mod_minus_eq [mod_simps]:
   "(- (a mod b)) mod b = (- a) mod b"
 proof -
   have "(- a) mod b = (- (a div b * b + a mod b)) mod b"
     by (simp only: div_mult_mod_eq)
   also have "\<dots> = (- (a mod b) + - (a div b) * b) mod b"
     by (simp add: ac_simps)
   also have "\<dots> = (- (a mod b)) mod b"
     by (rule mod_mult_self1)
   finally show ?thesis
     by (rule sym)
 qed
 
 lemma mod_minus_cong:
   assumes "a mod b = a' mod b"
   shows "(- a) mod b = (- a') mod b"
 proof -
   have "(- (a mod b)) mod b = (- (a' mod b)) mod b"
     unfolding assms ..
   then show ?thesis
     by (simp add: mod_minus_eq)
 qed
 
 text \<open>Subtraction respects modular equivalence.\<close>
 
 lemma mod_diff_left_eq [mod_simps]:
   "(a mod c - b) mod c = (a - b) mod c"
   using mod_add_cong [of a c "a mod c" "- b" "- b"]
   by simp
 
 lemma mod_diff_right_eq [mod_simps]:
   "(a - b mod c) mod c = (a - b) mod c"
   using mod_add_cong [of a c a "- b" "- (b mod c)"] mod_minus_cong [of "b mod c" c b]
   by simp
 
 lemma mod_diff_eq:
   "(a mod c - b mod c) mod c = (a - b) mod c"
   using mod_add_cong [of a c "a mod c" "- b" "- (b mod c)"] mod_minus_cong [of "b mod c" c b]
   by simp
 
 lemma mod_diff_cong:
   assumes "a mod c = a' mod c"
   assumes "b mod c = b' mod c"
   shows "(a - b) mod c = (a' - b') mod c"
   using assms mod_add_cong [of a c a' "- b" "- b'"] mod_minus_cong [of b c "b'"]
   by simp
 
 lemma minus_mod_self2 [simp]:
   "(a - b) mod b = a mod b"
   using mod_diff_right_eq [of a b b]
   by (simp add: mod_diff_right_eq)
 
 lemma minus_mod_self1 [simp]:
   "(b - a) mod b = - a mod b"
   using mod_add_self2 [of "- a" b] by simp
 
 lemma mod_eq_dvd_iff:
   "a mod c = b mod c \<longleftrightarrow> c dvd a - b" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   then have "(a mod c - b mod c) mod c = 0"
     by simp
   then show ?Q
     by (simp add: dvd_eq_mod_eq_0 mod_simps)
 next
   assume ?Q
   then obtain d where d: "a - b = c * d" ..
   then have "a = c * d + b"
     by (simp add: algebra_simps)
   then show ?P by simp
 qed
 
 lemma mod_eqE:
   assumes "a mod c = b mod c"
   obtains d where "b = a + c * d"
 proof -
   from assms have "c dvd a - b"
     by (simp add: mod_eq_dvd_iff)
   then obtain d where "a - b = c * d" ..
   then have "b = a + c * - d"
     by (simp add: algebra_simps)
   with that show thesis .
 qed
 
 lemma invertible_coprime:
   "coprime a c" if "a * b mod c = 1"
   by (rule coprimeI) (use that dvd_mod_iff [of _ c "a * b"] in auto)
 
 end
 
   
 subsection \<open>Uniquely determined division\<close>
   
 class unique_euclidean_semiring = euclidean_semiring + 
   assumes euclidean_size_mult: "euclidean_size (a * b) = euclidean_size a * euclidean_size b"
   fixes division_segment :: "'a \<Rightarrow> 'a"
   assumes is_unit_division_segment [simp]: "is_unit (division_segment a)"
     and division_segment_mult:
     "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> division_segment (a * b) = division_segment a * division_segment b"
     and division_segment_mod:
     "b \<noteq> 0 \<Longrightarrow> \<not> b dvd a \<Longrightarrow> division_segment (a mod b) = division_segment b"
   assumes div_bounded:
     "b \<noteq> 0 \<Longrightarrow> division_segment r = division_segment b
     \<Longrightarrow> euclidean_size r < euclidean_size b
     \<Longrightarrow> (q * b + r) div b = q"
 begin
 
 lemma division_segment_not_0 [simp]:
   "division_segment a \<noteq> 0"
   using is_unit_division_segment [of a] is_unitE [of "division_segment a"] by blast
 
 lemma divmod_cases [case_names divides remainder by0]:
   obtains 
     (divides) q where "b \<noteq> 0"
       and "a div b = q"
       and "a mod b = 0"
       and "a = q * b"
   | (remainder) q r where "b \<noteq> 0"
       and "division_segment r = division_segment b"
       and "euclidean_size r < euclidean_size b"
       and "r \<noteq> 0"
       and "a div b = q"
       and "a mod b = r"
       and "a = q * b + r"
   | (by0) "b = 0"
 proof (cases "b = 0")
   case True
   then show thesis
   by (rule by0)
 next
   case False
   show thesis
   proof (cases "b dvd a")
     case True
     then obtain q where "a = b * q" ..
     with \<open>b \<noteq> 0\<close> divides
     show thesis
       by (simp add: ac_simps)
   next
     case False
     then have "a mod b \<noteq> 0"
       by (simp add: mod_eq_0_iff_dvd)
     moreover from \<open>b \<noteq> 0\<close> \<open>\<not> b dvd a\<close> have "division_segment (a mod b) = division_segment b"
       by (rule division_segment_mod)
     moreover have "euclidean_size (a mod b) < euclidean_size b"
       using \<open>b \<noteq> 0\<close> by (rule mod_size_less)
     moreover have "a = a div b * b + a mod b"
       by (simp add: div_mult_mod_eq)
     ultimately show thesis
       using \<open>b \<noteq> 0\<close> by (blast intro!: remainder)
   qed
 qed
 
 lemma div_eqI:
   "a div b = q" if "b \<noteq> 0" "division_segment r = division_segment b"
     "euclidean_size r < euclidean_size b" "q * b + r = a"
 proof -
   from that have "(q * b + r) div b = q"
     by (auto intro: div_bounded)
   with that show ?thesis
     by simp
 qed
 
 lemma mod_eqI:
   "a mod b = r" if "b \<noteq> 0" "division_segment r = division_segment b"
     "euclidean_size r < euclidean_size b" "q * b + r = a" 
 proof -
   from that have "a div b = q"
     by (rule div_eqI)
   moreover have "a div b * b + a mod b = a"
     by (fact div_mult_mod_eq)
   ultimately have "a div b * b + a mod b = a div b * b + r"
     using \<open>q * b + r = a\<close> by simp
   then show ?thesis
     by simp
 qed
 
 subclass euclidean_semiring_cancel
 proof
   show "(a + c * b) div b = c + a div b" if "b \<noteq> 0" for a b c
   proof (cases a b rule: divmod_cases)
     case by0
     with \<open>b \<noteq> 0\<close> show ?thesis
       by simp
   next
     case (divides q)
     then show ?thesis
       by (simp add: ac_simps)
   next
     case (remainder q r)
     then show ?thesis
       by (auto intro: div_eqI simp add: algebra_simps)
   qed
 next
   show"(c * a) div (c * b) = a div b" if "c \<noteq> 0" for a b c
   proof (cases a b rule: divmod_cases)
     case by0
     then show ?thesis
       by simp
   next
     case (divides q)
     with \<open>c \<noteq> 0\<close> show ?thesis
       by (simp add: mult.left_commute [of c])
   next
     case (remainder q r)
     from \<open>b \<noteq> 0\<close> \<open>c \<noteq> 0\<close> have "b * c \<noteq> 0"
       by simp
     from remainder \<open>c \<noteq> 0\<close>
     have "division_segment (r * c) = division_segment (b * c)"
       and "euclidean_size (r * c) < euclidean_size (b * c)"
       by (simp_all add: division_segment_mult division_segment_mod euclidean_size_mult)
     with remainder show ?thesis
       by (auto intro!: div_eqI [of _ "c * (a mod b)"] simp add: algebra_simps)
         (use \<open>b * c \<noteq> 0\<close> in simp)
   qed
 qed
 
 lemma div_mult1_eq:
   "(a * b) div c = a * (b div c) + a * (b mod c) div c"
 proof (cases "a * (b mod c)" c rule: divmod_cases)
   case (divides q)
   have "a * b = a * (b div c * c + b mod c)"
     by (simp add: div_mult_mod_eq)
   also have "\<dots> = (a * (b div c) + q) * c"
     using divides by (simp add: algebra_simps)
   finally have "(a * b) div c = \<dots> div c"
     by simp
   with divides show ?thesis
     by simp
 next
   case (remainder q r)
   from remainder(1-3) show ?thesis
   proof (rule div_eqI)
     have "a * b = a * (b div c * c + b mod c)"
       by (simp add: div_mult_mod_eq)
     also have "\<dots> = a * c * (b div c) + q * c + r"
       using remainder by (simp add: algebra_simps)
     finally show "(a * (b div c) + a * (b mod c) div c) * c + r = a * b"
       using remainder(5-7) by (simp add: algebra_simps)
   qed
 next
   case by0
   then show ?thesis
     by simp
 qed
 
 lemma div_add1_eq:
   "(a + b) div c = a div c + b div c + (a mod c + b mod c) div c"
 proof (cases "a mod c + b mod c" c rule: divmod_cases)
   case (divides q)
   have "a + b = (a div c * c + a mod c) + (b div c * c + b mod c)"
     using mod_mult_div_eq [of a c] mod_mult_div_eq [of b c] by (simp add: ac_simps)
   also have "\<dots> = (a div c + b div c) * c + (a mod c + b mod c)"
     by (simp add: algebra_simps)
   also have "\<dots> = (a div c + b div c + q) * c"
     using divides by (simp add: algebra_simps)
   finally have "(a + b) div c = (a div c + b div c + q) * c div c"
     by simp
   with divides show ?thesis
     by simp
 next
   case (remainder q r)
   from remainder(1-3) show ?thesis
   proof (rule div_eqI)
     have "(a div c + b div c + q) * c + r + (a mod c + b mod c) =
         (a div c * c + a mod c) + (b div c * c + b mod c) + q * c + r"
       by (simp add: algebra_simps)
     also have "\<dots> = a + b + (a mod c + b mod c)"
       by (simp add: div_mult_mod_eq remainder) (simp add: ac_simps)
     finally show "(a div c + b div c + (a mod c + b mod c) div c) * c + r = a + b"
       using remainder by simp
   qed
 next
   case by0
   then show ?thesis
     by simp
 qed
 
 lemma div_eq_0_iff:
   "a div b = 0 \<longleftrightarrow> euclidean_size a < euclidean_size b \<or> b = 0" (is "_ \<longleftrightarrow> ?P")
   if "division_segment a = division_segment b"
 proof
   assume ?P
   with that show "a div b = 0"
     by (cases "b = 0") (auto intro: div_eqI)
 next
   assume "a div b = 0"
   then have "a mod b = a"
     using div_mult_mod_eq [of a b] by simp
   with mod_size_less [of b a] show ?P
     by auto
 qed
 
 end
 
 class unique_euclidean_ring = euclidean_ring + unique_euclidean_semiring
 begin
   
 subclass euclidean_ring_cancel ..
 
 end
 
 
 subsection \<open>Euclidean division on \<^typ>\<open>nat\<close>\<close>
 
 instantiation nat :: normalization_semidom
 begin
 
 definition normalize_nat :: "nat \<Rightarrow> nat"
   where [simp]: "normalize = (id :: nat \<Rightarrow> nat)"
 
 definition unit_factor_nat :: "nat \<Rightarrow> nat"
   where "unit_factor n = (if n = 0 then 0 else 1 :: nat)"
 
 lemma unit_factor_simps [simp]:
   "unit_factor 0 = (0::nat)"
   "unit_factor (Suc n) = 1"
   by (simp_all add: unit_factor_nat_def)
 
 definition divide_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
   where "m div n = (if n = 0 then 0 else Max {k::nat. k * n \<le> m})"
 
 instance
   by standard (auto simp add: divide_nat_def ac_simps unit_factor_nat_def intro: Max_eqI)
 
 end
 
 lemma coprime_Suc_0_left [simp]:
   "coprime (Suc 0) n"
   using coprime_1_left [of n] by simp
 
 lemma coprime_Suc_0_right [simp]:
   "coprime n (Suc 0)"
   using coprime_1_right [of n] by simp
 
 lemma coprime_common_divisor_nat: "coprime a b \<Longrightarrow> x dvd a \<Longrightarrow> x dvd b \<Longrightarrow> x = 1"
   for a b :: nat
   by (drule coprime_common_divisor [of _ _ x]) simp_all
 
 instantiation nat :: unique_euclidean_semiring
 begin
 
 definition euclidean_size_nat :: "nat \<Rightarrow> nat"
   where [simp]: "euclidean_size_nat = id"
 
 definition division_segment_nat :: "nat \<Rightarrow> nat"
   where [simp]: "division_segment_nat n = 1"
 
 definition modulo_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat"
   where "m mod n = m - (m div n * (n::nat))"
 
 instance proof
   fix m n :: nat
   have ex: "\<exists>k. k * n \<le> l" for l :: nat
     by (rule exI [of _ 0]) simp
   have fin: "finite {k. k * n \<le> l}" if "n > 0" for l
   proof -
     from that have "{k. k * n \<le> l} \<subseteq> {k. k \<le> l}"
       by (cases n) auto
     then show ?thesis
       by (rule finite_subset) simp
   qed
   have mult_div_unfold: "n * (m div n) = Max {l. l \<le> m \<and> n dvd l}"
   proof (cases "n = 0")
     case True
     moreover have "{l. l = 0 \<and> l \<le> m} = {0::nat}"
       by auto
     ultimately show ?thesis
       by simp
   next
     case False
     with ex [of m] fin have "n * Max {k. k * n \<le> m} = Max (times n ` {k. k * n \<le> m})"
       by (auto simp add: nat_mult_max_right intro: hom_Max_commute)
     also have "times n ` {k. k * n \<le> m} = {l. l \<le> m \<and> n dvd l}"
       by (auto simp add: ac_simps elim!: dvdE)
     finally show ?thesis
       using False by (simp add: divide_nat_def ac_simps)
   qed
   have less_eq: "m div n * n \<le> m"
     by (auto simp add: mult_div_unfold ac_simps intro: Max.boundedI)
   then show "m div n * n + m mod n = m"
     by (simp add: modulo_nat_def)
   assume "n \<noteq> 0" 
   show "euclidean_size (m mod n) < euclidean_size n"
   proof -
     have "m < Suc (m div n) * n"
     proof (rule ccontr)
       assume "\<not> m < Suc (m div n) * n"
       then have "Suc (m div n) * n \<le> m"
         by (simp add: not_less)
       moreover from \<open>n \<noteq> 0\<close> have "Max {k. k * n \<le> m} < Suc (m div n)"
         by (simp add: divide_nat_def)
       with \<open>n \<noteq> 0\<close> ex fin have "\<And>k. k * n \<le> m \<Longrightarrow> k < Suc (m div n)"
         by auto
       ultimately have "Suc (m div n) < Suc (m div n)"
         by blast
       then show False
         by simp
     qed
     with \<open>n \<noteq> 0\<close> show ?thesis
       by (simp add: modulo_nat_def)
   qed
   show "euclidean_size m \<le> euclidean_size (m * n)"
     using \<open>n \<noteq> 0\<close> by (cases n) simp_all
   fix q r :: nat
   show "(q * n + r) div n = q" if "euclidean_size r < euclidean_size n"
   proof -
     from that have "r < n"
       by simp
     have "k \<le> q" if "k * n \<le> q * n + r" for k
     proof (rule ccontr)
       assume "\<not> k \<le> q"
       then have "q < k"
         by simp
       then obtain l where "k = Suc (q + l)"
         by (auto simp add: less_iff_Suc_add)
       with \<open>r < n\<close> that show False
         by (simp add: algebra_simps)
     qed
     with \<open>n \<noteq> 0\<close> ex fin show ?thesis
       by (auto simp add: divide_nat_def Max_eq_iff)
   qed
 qed simp_all
 
 end
 
 text \<open>Tool support\<close>
 
 ML \<open>
 structure Cancel_Div_Mod_Nat = Cancel_Div_Mod
 (
   val div_name = \<^const_name>\<open>divide\<close>;
   val mod_name = \<^const_name>\<open>modulo\<close>;
   val mk_binop = HOLogic.mk_binop;
   val dest_plus = HOLogic.dest_bin \<^const_name>\<open>Groups.plus\<close> HOLogic.natT;
   val mk_sum = Arith_Data.mk_sum;
   fun dest_sum tm =
     if HOLogic.is_zero tm then []
     else
       (case try HOLogic.dest_Suc tm of
         SOME t => HOLogic.Suc_zero :: dest_sum t
       | NONE =>
           (case try dest_plus tm of
             SOME (t, u) => dest_sum t @ dest_sum u
           | NONE => [tm]));
 
   val div_mod_eqs = map mk_meta_eq @{thms cancel_div_mod_rules};
 
   val prove_eq_sums = Arith_Data.prove_conv2 all_tac
     (Arith_Data.simp_all_tac @{thms add_0_left add_0_right ac_simps})
 )
 \<close>
 
 simproc_setup cancel_div_mod_nat ("(m::nat) + n") =
   \<open>K Cancel_Div_Mod_Nat.proc\<close>
 
 lemma div_nat_eqI:
   "m div n = q" if "n * q \<le> m" and "m < n * Suc q" for m n q :: nat
   by (rule div_eqI [of _ "m - n * q"]) (use that in \<open>simp_all add: algebra_simps\<close>)
 
 lemma mod_nat_eqI:
   "m mod n = r" if "r < n" and "r \<le> m" and "n dvd m - r" for m n r :: nat
   by (rule mod_eqI [of _ _ "(m - r) div n"]) (use that in \<open>simp_all add: algebra_simps\<close>)
 
 lemma div_mult_self_is_m [simp]:
   "m * n div n = m" if "n > 0" for m n :: nat
   using that by simp
 
 lemma div_mult_self1_is_m [simp]:
   "n * m div n = m" if "n > 0" for m n :: nat
   using that by simp
 
 lemma mod_less_divisor [simp]:
   "m mod n < n" if "n > 0" for m n :: nat
   using mod_size_less [of n m] that by simp
 
 lemma mod_le_divisor [simp]:
   "m mod n \<le> n" if "n > 0" for m n :: nat
   using that by (auto simp add: le_less)
 
 lemma div_times_less_eq_dividend [simp]:
   "m div n * n \<le> m" for m n :: nat
   by (simp add: minus_mod_eq_div_mult [symmetric])
 
 lemma times_div_less_eq_dividend [simp]:
   "n * (m div n) \<le> m" for m n :: nat
   using div_times_less_eq_dividend [of m n]
   by (simp add: ac_simps)
 
 lemma dividend_less_div_times:
   "m < n + (m div n) * n" if "0 < n" for m n :: nat
 proof -
   from that have "m mod n < n"
     by simp
   then show ?thesis
     by (simp add: minus_mod_eq_div_mult [symmetric])
 qed
 
 lemma dividend_less_times_div:
   "m < n + n * (m div n)" if "0 < n" for m n :: nat
   using dividend_less_div_times [of n m] that
   by (simp add: ac_simps)
 
 lemma mod_Suc_le_divisor [simp]:
   "m mod Suc n \<le> n"
   using mod_less_divisor [of "Suc n" m] by arith
 
 lemma mod_less_eq_dividend [simp]:
   "m mod n \<le> m" for m n :: nat
 proof (rule add_leD2)
   from div_mult_mod_eq have "m div n * n + m mod n = m" .
   then show "m div n * n + m mod n \<le> m" by auto
 qed
 
 lemma
   div_less [simp]: "m div n = 0"
   and mod_less [simp]: "m mod n = m"
   if "m < n" for m n :: nat
   using that by (auto intro: div_eqI mod_eqI) 
 
 lemma le_div_geq:
   "m div n = Suc ((m - n) div n)" if "0 < n" and "n \<le> m" for m n :: nat
 proof -
   from \<open>n \<le> m\<close> obtain q where "m = n + q"
     by (auto simp add: le_iff_add)
   with \<open>0 < n\<close> show ?thesis
     by (simp add: div_add_self1)
 qed
 
 lemma le_mod_geq:
   "m mod n = (m - n) mod n" if "n \<le> m" for m n :: nat
 proof -
   from \<open>n \<le> m\<close> obtain q where "m = n + q"
     by (auto simp add: le_iff_add)
   then show ?thesis
     by simp
 qed
 
 lemma div_if:
   "m div n = (if m < n \<or> n = 0 then 0 else Suc ((m - n) div n))"
   by (simp add: le_div_geq)
 
 lemma mod_if:
   "m mod n = (if m < n then m else (m - n) mod n)" for m n :: nat
   by (simp add: le_mod_geq)
 
 lemma div_eq_0_iff:
   "m div n = 0 \<longleftrightarrow> m < n \<or> n = 0" for m n :: nat
   by (simp add: div_eq_0_iff)
 
 lemma div_greater_zero_iff:
   "m div n > 0 \<longleftrightarrow> n \<le> m \<and> n > 0" for m n :: nat
   using div_eq_0_iff [of m n] by auto
 
 lemma mod_greater_zero_iff_not_dvd:
   "m mod n > 0 \<longleftrightarrow> \<not> n dvd m" for m n :: nat
   by (simp add: dvd_eq_mod_eq_0)
 
 lemma div_by_Suc_0 [simp]:
   "m div Suc 0 = m"
   using div_by_1 [of m] by simp
 
 lemma mod_by_Suc_0 [simp]:
   "m mod Suc 0 = 0"
   using mod_by_1 [of m] by simp
 
 lemma div2_Suc_Suc [simp]:
   "Suc (Suc m) div 2 = Suc (m div 2)"
   by (simp add: numeral_2_eq_2 le_div_geq)
 
 lemma Suc_n_div_2_gt_zero [simp]:
   "0 < Suc n div 2" if "n > 0" for n :: nat
   using that by (cases n) simp_all
 
 lemma div_2_gt_zero [simp]:
   "0 < n div 2" if "Suc 0 < n" for n :: nat
   using that Suc_n_div_2_gt_zero [of "n - 1"] by simp
 
 lemma mod2_Suc_Suc [simp]:
   "Suc (Suc m) mod 2 = m mod 2"
   by (simp add: numeral_2_eq_2 le_mod_geq)
 
 lemma add_self_div_2 [simp]:
   "(m + m) div 2 = m" for m :: nat
   by (simp add: mult_2 [symmetric])
 
 lemma add_self_mod_2 [simp]:
   "(m + m) mod 2 = 0" for m :: nat
   by (simp add: mult_2 [symmetric])
 
 lemma mod2_gr_0 [simp]:
   "0 < m mod 2 \<longleftrightarrow> m mod 2 = 1" for m :: nat
 proof -
   have "m mod 2 < 2"
     by (rule mod_less_divisor) simp
   then have "m mod 2 = 0 \<or> m mod 2 = 1"
     by arith
   then show ?thesis
     by auto     
 qed
 
 lemma mod_Suc_eq [mod_simps]:
   "Suc (m mod n) mod n = Suc m mod n"
 proof -
   have "(m mod n + 1) mod n = (m + 1) mod n"
     by (simp only: mod_simps)
   then show ?thesis
     by simp
 qed
 
 lemma mod_Suc_Suc_eq [mod_simps]:
   "Suc (Suc (m mod n)) mod n = Suc (Suc m) mod n"
 proof -
   have "(m mod n + 2) mod n = (m + 2) mod n"
     by (simp only: mod_simps)
   then show ?thesis
     by simp
 qed
 
 lemma
   Suc_mod_mult_self1 [simp]: "Suc (m + k * n) mod n = Suc m mod n"
   and Suc_mod_mult_self2 [simp]: "Suc (m + n * k) mod n = Suc m mod n"
   and Suc_mod_mult_self3 [simp]: "Suc (k * n + m) mod n = Suc m mod n"
   and Suc_mod_mult_self4 [simp]: "Suc (n * k + m) mod n = Suc m mod n"
   by (subst mod_Suc_eq [symmetric], simp add: mod_simps)+
 
 lemma Suc_0_mod_eq [simp]:
   "Suc 0 mod n = of_bool (n \<noteq> Suc 0)"
   by (cases n) simp_all
 
 context
   fixes m n q :: nat
 begin
 
 private lemma eucl_rel_mult2:
   "m mod n + n * (m div n mod q) < n * q"
   if "n > 0" and "q > 0"
 proof -
   from \<open>n > 0\<close> have "m mod n < n"
     by (rule mod_less_divisor)
   from \<open>q > 0\<close> have "m div n mod q < q"
     by (rule mod_less_divisor)
   then obtain s where "q = Suc (m div n mod q + s)"
     by (blast dest: less_imp_Suc_add)
   moreover have "m mod n + n * (m div n mod q) < n * Suc (m div n mod q + s)"
     using \<open>m mod n < n\<close> by (simp add: add_mult_distrib2)
   ultimately show ?thesis
     by simp
 qed
 
 lemma div_mult2_eq:
   "m div (n * q) = (m div n) div q"
 proof (cases "n = 0 \<or> q = 0")
   case True
   then show ?thesis
     by auto
 next
   case False
   with eucl_rel_mult2 show ?thesis
     by (auto intro: div_eqI [of _ "n * (m div n mod q) + m mod n"]
       simp add: algebra_simps add_mult_distrib2 [symmetric])
 qed
 
 lemma mod_mult2_eq:
   "m mod (n * q) = n * (m div n mod q) + m mod n"
 proof (cases "n = 0 \<or> q = 0")
   case True
   then show ?thesis
     by auto
 next
   case False
   with eucl_rel_mult2 show ?thesis
     by (auto intro: mod_eqI [of _ _ "(m div n) div q"]
       simp add: algebra_simps add_mult_distrib2 [symmetric])
 qed
 
 end
 
 lemma div_le_mono:
   "m div k \<le> n div k" if "m \<le> n" for m n k :: nat
 proof -
   from that obtain q where "n = m + q"
     by (auto simp add: le_iff_add)
   then show ?thesis
     by (simp add: div_add1_eq [of m q k])
 qed
 
 text \<open>Antimonotonicity of \<^const>\<open>divide\<close> in second argument\<close>
 
 lemma div_le_mono2:
   "k div n \<le> k div m" if "0 < m" and "m \<le> n" for m n k :: nat
 using that proof (induct k arbitrary: m rule: less_induct)
   case (less k)
   show ?case
   proof (cases "n \<le> k")
     case False
     then show ?thesis
       by simp
   next
     case True
     have "(k - n) div n \<le> (k - m) div n"
       using less.prems
       by (blast intro: div_le_mono diff_le_mono2)
     also have "\<dots> \<le> (k - m) div m"
       using \<open>n \<le> k\<close> less.prems less.hyps [of "k - m" m]
       by simp
     finally show ?thesis
       using \<open>n \<le> k\<close> less.prems
       by (simp add: le_div_geq)
   qed
 qed
 
 lemma div_le_dividend [simp]:
   "m div n \<le> m" for m n :: nat
   using div_le_mono2 [of 1 n m] by (cases "n = 0") simp_all
 
 lemma div_less_dividend [simp]:
   "m div n < m" if "1 < n" and "0 < m" for m n :: nat
 using that proof (induct m rule: less_induct)
   case (less m)
   show ?case
   proof (cases "n < m")
     case False
     with less show ?thesis
       by (cases "n = m") simp_all
   next
     case True
     then show ?thesis
       using less.hyps [of "m - n"] less.prems
       by (simp add: le_div_geq)
   qed
 qed
 
 lemma div_eq_dividend_iff:
   "m div n = m \<longleftrightarrow> n = 1" if "m > 0" for m n :: nat
 proof
   assume "n = 1"
   then show "m div n = m"
     by simp
 next
   assume P: "m div n = m"
   show "n = 1"
   proof (rule ccontr)
     have "n \<noteq> 0"
       by (rule ccontr) (use that P in auto)
     moreover assume "n \<noteq> 1"
     ultimately have "n > 1"
       by simp
     with that have "m div n < m"
       by simp
     with P show False
       by simp
   qed
 qed
 
 lemma less_mult_imp_div_less:
   "m div n < i" if "m < i * n" for m n i :: nat
 proof -
   from that have "i * n > 0"
     by (cases "i * n = 0") simp_all
   then have "i > 0" and "n > 0"
     by simp_all
   have "m div n * n \<le> m"
     by simp
   then have "m div n * n < i * n"
     using that by (rule le_less_trans)
   with \<open>n > 0\<close> show ?thesis
     by simp
 qed
 
 lemma div_less_iff_less_mult:
   \<open>m div q < n \<longleftrightarrow> m < n * q\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
   if \<open>q > 0\<close> for m n q :: nat
 proof
   assume ?Q then show ?P
     by (rule less_mult_imp_div_less)
 next
   assume ?P
   then obtain h where \<open>n = Suc (m div q + h)\<close>
     using less_natE by blast
   moreover have \<open>m < m + (Suc h * q - m mod q)\<close>
     using that by (simp add: trans_less_add1)
   ultimately show ?Q
     by (simp add: algebra_simps flip: minus_mod_eq_mult_div)
 qed
 
 lemma less_eq_div_iff_mult_less_eq:
   \<open>m \<le> n div q \<longleftrightarrow> m * q \<le> n\<close> if \<open>q > 0\<close> for m n q :: nat
   using div_less_iff_less_mult [of q n m] that by auto
 
 text \<open>A fact for the mutilated chess board\<close>
 
 lemma mod_Suc:
   "Suc m mod n = (if Suc (m mod n) = n then 0 else Suc (m mod n))" (is "_ = ?rhs")
 proof (cases "n = 0")
   case True
   then show ?thesis
     by simp
 next
   case False
   have "Suc m mod n = Suc (m mod n) mod n"
     by (simp add: mod_simps)
   also have "\<dots> = ?rhs"
     using False by (auto intro!: mod_nat_eqI intro: neq_le_trans simp add: Suc_le_eq)
   finally show ?thesis .
 qed
 
 lemma Suc_times_mod_eq:
   "Suc (m * n) mod m = 1" if "Suc 0 < m"
   using that by (simp add: mod_Suc)
 
 lemma Suc_times_numeral_mod_eq [simp]:
   "Suc (numeral k * n) mod numeral k = 1" if "numeral k \<noteq> (1::nat)"
   by (rule Suc_times_mod_eq) (use that in simp)
 
 lemma Suc_div_le_mono [simp]:
   "m div n \<le> Suc m div n"
   by (simp add: div_le_mono)
 
 text \<open>These lemmas collapse some needless occurrences of Suc:
   at least three Sucs, since two and fewer are rewritten back to Suc again!
   We already have some rules to simplify operands smaller than 3.\<close>
 
 lemma div_Suc_eq_div_add3 [simp]:
   "m div Suc (Suc (Suc n)) = m div (3 + n)"
   by (simp add: Suc3_eq_add_3)
 
 lemma mod_Suc_eq_mod_add3 [simp]:
   "m mod Suc (Suc (Suc n)) = m mod (3 + n)"
   by (simp add: Suc3_eq_add_3)
 
 lemma Suc_div_eq_add3_div:
   "Suc (Suc (Suc m)) div n = (3 + m) div n"
   by (simp add: Suc3_eq_add_3)
 
 lemma Suc_mod_eq_add3_mod:
   "Suc (Suc (Suc m)) mod n = (3 + m) mod n"
   by (simp add: Suc3_eq_add_3)
 
 lemmas Suc_div_eq_add3_div_numeral [simp] =
   Suc_div_eq_add3_div [of _ "numeral v"] for v
 
 lemmas Suc_mod_eq_add3_mod_numeral [simp] =
   Suc_mod_eq_add3_mod [of _ "numeral v"] for v
 
 lemma (in field_char_0) of_nat_div:
   "of_nat (m div n) = ((of_nat m - of_nat (m mod n)) / of_nat n)"
 proof -
   have "of_nat (m div n) = ((of_nat (m div n * n + m mod n) - of_nat (m mod n)) / of_nat n :: 'a)"
     unfolding of_nat_add by (cases "n = 0") simp_all
   then show ?thesis
     by simp
 qed
 
 text \<open>An ``induction'' law for modulus arithmetic.\<close>
 
 lemma mod_induct [consumes 3, case_names step]:
   "P m" if "P n" and "n < p" and "m < p"
     and step: "\<And>n. n < p \<Longrightarrow> P n \<Longrightarrow> P (Suc n mod p)"
 using \<open>m < p\<close> proof (induct m)
   case 0
   show ?case
   proof (rule ccontr)
     assume "\<not> P 0"
     from \<open>n < p\<close> have "0 < p"
       by simp
     from \<open>n < p\<close> obtain m where "0 < m" and "p = n + m"
       by (blast dest: less_imp_add_positive)
     with \<open>P n\<close> have "P (p - m)"
       by simp
     moreover have "\<not> P (p - m)"
     using \<open>0 < m\<close> proof (induct m)
       case 0
       then show ?case
         by simp
     next
       case (Suc m)
       show ?case
       proof
         assume P: "P (p - Suc m)"
         with \<open>\<not> P 0\<close> have "Suc m < p"
           by (auto intro: ccontr) 
         then have "Suc (p - Suc m) = p - m"
           by arith
         moreover from \<open>0 < p\<close> have "p - Suc m < p"
           by arith
         with P step have "P ((Suc (p - Suc m)) mod p)"
           by blast
         ultimately show False
           using \<open>\<not> P 0\<close> Suc.hyps by (cases "m = 0") simp_all
       qed
     qed
     ultimately show False
       by blast
   qed
 next
   case (Suc m)
   then have "m < p" and mod: "Suc m mod p = Suc m"
     by simp_all
   from \<open>m < p\<close> have "P m"
     by (rule Suc.hyps)
   with \<open>m < p\<close> have "P (Suc m mod p)"
     by (rule step)
   with mod show ?case
     by simp
 qed
 
 lemma split_div:
   "P (m div n) \<longleftrightarrow> (n = 0 \<longrightarrow> P 0) \<and> (n \<noteq> 0 \<longrightarrow>
      (\<forall>i j. j < n \<longrightarrow> m = n * i + j \<longrightarrow> P i))"
      (is "?P = ?Q") for m n :: nat
 proof (cases "n = 0")
   case True
   then show ?thesis
     by simp
 next
   case False
   show ?thesis
   proof
     assume ?P
     with False show ?Q
       by auto
   next
     assume ?Q
     with False have *: "\<And>i j. j < n \<Longrightarrow> m = n * i + j \<Longrightarrow> P i"
       by simp
     with False show ?P
       by (auto intro: * [of "m mod n"])
   qed
 qed
 
 lemma split_div':
   "P (m div n) \<longleftrightarrow> n = 0 \<and> P 0 \<or> (\<exists>q. (n * q \<le> m \<and> m < n * Suc q) \<and> P q)"
 proof (cases "n = 0")
   case True
   then show ?thesis
     by simp
 next
   case False
   then have "n * q \<le> m \<and> m < n * Suc q \<longleftrightarrow> m div n = q" for q
     by (auto intro: div_nat_eqI dividend_less_times_div)
   then show ?thesis
     by auto
 qed
 
 lemma split_mod:
   "P (m mod n) \<longleftrightarrow> (n = 0 \<longrightarrow> P m) \<and> (n \<noteq> 0 \<longrightarrow>
      (\<forall>i j. j < n \<longrightarrow> m = n * i + j \<longrightarrow> P j))"
      (is "?P \<longleftrightarrow> ?Q") for m n :: nat
 proof (cases "n = 0")
   case True
   then show ?thesis
     by simp
 next
   case False
   show ?thesis
   proof
     assume ?P
     with False show ?Q
       by auto
   next
     assume ?Q
     with False have *: "\<And>i j. j < n \<Longrightarrow> m = n * i + j \<Longrightarrow> P j"
       by simp
     with False show ?P
       by (auto intro: * [of _ "m div n"])
   qed
 qed
 
 lemma funpow_mod_eq: \<^marker>\<open>contributor \<open>Lars Noschinski\<close>\<close>
   \<open>(f ^^ (m mod n)) x = (f ^^ m) x\<close> if \<open>(f ^^ n) x = x\<close>
 proof -
   have \<open>(f ^^ m) x = (f ^^ (m mod n + m div n * n)) x\<close>
     by simp
   also have \<open>\<dots> = (f ^^ (m mod n)) (((f ^^ n) ^^ (m div n)) x)\<close>
     by (simp only: funpow_add funpow_mult ac_simps) simp
   also have \<open>((f ^^ n) ^^ q) x = x\<close> for q
     by (induction q) (use \<open>(f ^^ n) x = x\<close> in simp_all)
   finally show ?thesis
     by simp
 qed
 
 
 subsection \<open>Euclidean division on \<^typ>\<open>int\<close>\<close>
 
 instantiation int :: normalization_semidom
 begin
 
 definition normalize_int :: "int \<Rightarrow> int"
   where [simp]: "normalize = (abs :: int \<Rightarrow> int)"
 
 definition unit_factor_int :: "int \<Rightarrow> int"
   where [simp]: "unit_factor = (sgn :: int \<Rightarrow> int)"
 
 definition divide_int :: "int \<Rightarrow> int \<Rightarrow> int"
   where "k div l = (if l = 0 then 0
     else if sgn k = sgn l
       then int (nat \<bar>k\<bar> div nat \<bar>l\<bar>)
       else - int (nat \<bar>k\<bar> div nat \<bar>l\<bar> + of_bool (\<not> l dvd k)))"
 
 lemma divide_int_unfold:
   "(sgn k * int m) div (sgn l * int n) =
    (if sgn l = 0 \<or> sgn k = 0 \<or> n = 0 then 0
     else if sgn k = sgn l
       then int (m div n)
       else - int (m div n + of_bool (\<not> n dvd m)))"
   by (auto simp add: divide_int_def sgn_0_0 sgn_1_pos sgn_mult abs_mult
     nat_mult_distrib)
 
 instance proof
   fix k :: int show "k div 0 = 0"
   by (simp add: divide_int_def)
 next
   fix k l :: int
   assume "l \<noteq> 0"
   obtain n m and s t where k: "k = sgn s * int n" and l: "l = sgn t * int m" 
     by (blast intro: int_sgnE elim: that)
   then have "k * l = sgn (s * t) * int (n * m)"
     by (simp add: ac_simps sgn_mult)
   with k l \<open>l \<noteq> 0\<close> show "k * l div l = k"
     by (simp only: divide_int_unfold)
       (auto simp add: algebra_simps sgn_mult sgn_1_pos sgn_0_0)
 qed (auto simp add: sgn_mult mult_sgn_abs abs_eq_iff')
 
 end
 
 lemma coprime_int_iff [simp]:
   "coprime (int m) (int n) \<longleftrightarrow> coprime m n" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   show ?Q
   proof (rule coprimeI)
     fix q
     assume "q dvd m" "q dvd n"
     then have "int q dvd int m" "int q dvd int n"
       by simp_all
     with \<open>?P\<close> have "is_unit (int q)"
       by (rule coprime_common_divisor)
     then show "is_unit q"
       by simp
   qed
 next
   assume ?Q
   show ?P
   proof (rule coprimeI)
     fix k
     assume "k dvd int m" "k dvd int n"
     then have "nat \<bar>k\<bar> dvd m" "nat \<bar>k\<bar> dvd n"
       by simp_all
     with \<open>?Q\<close> have "is_unit (nat \<bar>k\<bar>)"
       by (rule coprime_common_divisor)
     then show "is_unit k"
       by simp
   qed
 qed
 
 lemma coprime_abs_left_iff [simp]:
   "coprime \<bar>k\<bar> l \<longleftrightarrow> coprime k l" for k l :: int
   using coprime_normalize_left_iff [of k l] by simp
 
 lemma coprime_abs_right_iff [simp]:
   "coprime k \<bar>l\<bar> \<longleftrightarrow> coprime k l" for k l :: int
   using coprime_abs_left_iff [of l k] by (simp add: ac_simps)
 
 lemma coprime_nat_abs_left_iff [simp]:
   "coprime (nat \<bar>k\<bar>) n \<longleftrightarrow> coprime k (int n)"
 proof -
   define m where "m = nat \<bar>k\<bar>"
   then have "\<bar>k\<bar> = int m"
     by simp
   moreover have "coprime k (int n) \<longleftrightarrow> coprime \<bar>k\<bar> (int n)"
     by simp
   ultimately show ?thesis
     by simp
 qed
 
 lemma coprime_nat_abs_right_iff [simp]:
   "coprime n (nat \<bar>k\<bar>) \<longleftrightarrow> coprime (int n) k"
   using coprime_nat_abs_left_iff [of k n] by (simp add: ac_simps)
 
 lemma coprime_common_divisor_int: "coprime a b \<Longrightarrow> x dvd a \<Longrightarrow> x dvd b \<Longrightarrow> \<bar>x\<bar> = 1"
   for a b :: int
   by (drule coprime_common_divisor [of _ _ x]) simp_all
 
 instantiation int :: idom_modulo
 begin
 
 definition modulo_int :: "int \<Rightarrow> int \<Rightarrow> int"
   where "k mod l = (if l = 0 then k
     else if sgn k = sgn l
       then sgn l * int (nat \<bar>k\<bar> mod nat \<bar>l\<bar>)
       else sgn l * (\<bar>l\<bar> * of_bool (\<not> l dvd k) - int (nat \<bar>k\<bar> mod nat \<bar>l\<bar>)))"
 
 lemma modulo_int_unfold:
   "(sgn k * int m) mod (sgn l * int n) =
    (if sgn l = 0 \<or> sgn k = 0 \<or> n = 0 then sgn k * int m
     else if sgn k = sgn l
       then sgn l * int (m mod n)
       else sgn l * (int (n * of_bool (\<not> n dvd m)) - int (m mod n)))"
   by (auto simp add: modulo_int_def sgn_0_0 sgn_1_pos sgn_mult abs_mult
     nat_mult_distrib)
 
 instance proof
   fix k l :: int
   obtain n m and s t where "k = sgn s * int n" and "l = sgn t * int m" 
     by (blast intro: int_sgnE elim: that)
   then show "k div l * l + k mod l = k"
     by (auto simp add: divide_int_unfold modulo_int_unfold algebra_simps dest!: sgn_not_eq_imp)
        (simp_all add: of_nat_mult [symmetric] of_nat_add [symmetric]
          distrib_left [symmetric] minus_mult_right
          del: of_nat_mult minus_mult_right [symmetric])
 qed
 
 end
 
 instantiation int :: unique_euclidean_ring
 begin
 
 definition euclidean_size_int :: "int \<Rightarrow> nat"
   where [simp]: "euclidean_size_int = (nat \<circ> abs :: int \<Rightarrow> nat)"
 
 definition division_segment_int :: "int \<Rightarrow> int"
   where "division_segment_int k = (if k \<ge> 0 then 1 else - 1)"
 
 lemma division_segment_eq_sgn:
   "division_segment k = sgn k" if "k \<noteq> 0" for k :: int
   using that by (simp add: division_segment_int_def)
 
 lemma abs_division_segment [simp]:
   "\<bar>division_segment k\<bar> = 1" for k :: int
   by (simp add: division_segment_int_def)
 
 lemma abs_mod_less:
   "\<bar>k mod l\<bar> < \<bar>l\<bar>" if "l \<noteq> 0" for k l :: int
 proof -
   obtain n m and s t where "k = sgn s * int n" and "l = sgn t * int m" 
     by (blast intro: int_sgnE elim: that)
   with that show ?thesis
     by (simp add: modulo_int_unfold sgn_0_0 sgn_1_pos sgn_1_neg
       abs_mult mod_greater_zero_iff_not_dvd)
 qed
 
 lemma sgn_mod:
   "sgn (k mod l) = sgn l" if "l \<noteq> 0" "\<not> l dvd k" for k l :: int
 proof -
   obtain n m and s t where "k = sgn s * int n" and "l = sgn t * int m" 
     by (blast intro: int_sgnE elim: that)
   with that show ?thesis
     by (simp add: modulo_int_unfold sgn_0_0 sgn_1_pos sgn_1_neg sgn_mult)
       (simp add: dvd_eq_mod_eq_0)
 qed
 
 instance proof
   fix k l :: int
   show "division_segment (k mod l) = division_segment l" if
     "l \<noteq> 0" and "\<not> l dvd k"
     using that by (simp add: division_segment_eq_sgn dvd_eq_mod_eq_0 sgn_mod)
 next
   fix l q r :: int
   obtain n m and s t
      where l: "l = sgn s * int n" and q: "q = sgn t * int m"
     by (blast intro: int_sgnE elim: that)
   assume \<open>l \<noteq> 0\<close>
   with l have "s \<noteq> 0" and "n > 0"
     by (simp_all add: sgn_0_0)
   assume "division_segment r = division_segment l"
   moreover have "r = sgn r * \<bar>r\<bar>"
     by (simp add: sgn_mult_abs)
   moreover define u where "u = nat \<bar>r\<bar>"
   ultimately have "r = sgn l * int u"
     using division_segment_eq_sgn \<open>l \<noteq> 0\<close> by (cases "r = 0") simp_all
   with l \<open>n > 0\<close> have r: "r = sgn s * int u"
     by (simp add: sgn_mult)
   assume "euclidean_size r < euclidean_size l"
   with l r \<open>s \<noteq> 0\<close> have "u < n"
     by (simp add: abs_mult)
   show "(q * l + r) div l = q"
   proof (cases "q = 0 \<or> r = 0")
     case True
     then show ?thesis
     proof
       assume "q = 0"
       then show ?thesis
         using l r \<open>u < n\<close> by (simp add: divide_int_unfold)
     next
       assume "r = 0"
       from \<open>r = 0\<close> have *: "q * l + r = sgn (t * s) * int (n * m)"
         using q l by (simp add: ac_simps sgn_mult)
       from \<open>s \<noteq> 0\<close> \<open>n > 0\<close> show ?thesis
         by (simp only: *, simp only: q l divide_int_unfold)
           (auto simp add: sgn_mult sgn_0_0 sgn_1_pos)
     qed
   next
     case False
     with q r have "t \<noteq> 0" and "m > 0" and "s \<noteq> 0" and "u > 0"
       by (simp_all add: sgn_0_0)
     moreover from \<open>0 < m\<close> \<open>u < n\<close> have "u \<le> m * n"
       using mult_le_less_imp_less [of 1 m u n] by simp
     ultimately have *: "q * l + r = sgn (s * t)
       * int (if t < 0 then m * n - u else m * n + u)"
       using l q r
       by (simp add: sgn_mult algebra_simps of_nat_diff)
     have "(m * n - u) div n = m - 1" if "u > 0"
       using \<open>0 < m\<close> \<open>u < n\<close> that
       by (auto intro: div_nat_eqI simp add: algebra_simps)
     moreover have "n dvd m * n - u \<longleftrightarrow> n dvd u"
       using \<open>u \<le> m * n\<close> dvd_diffD1 [of n "m * n" u]
       by auto
     ultimately show ?thesis
       using \<open>s \<noteq> 0\<close> \<open>m > 0\<close> \<open>u > 0\<close> \<open>u < n\<close> \<open>u \<le> m * n\<close>
       by (simp only: *, simp only: l q divide_int_unfold)
         (auto simp add: sgn_mult sgn_0_0 sgn_1_pos algebra_simps dest: dvd_imp_le)
   qed
 qed (use mult_le_mono2 [of 1] in \<open>auto simp add: division_segment_int_def not_le zero_less_mult_iff mult_less_0_iff abs_mult sgn_mult abs_mod_less sgn_mod nat_mult_distrib\<close>)
 
 end
 
 lemma pos_mod_bound [simp]:
   "k mod l < l" if "l > 0" for k l :: int
 proof -
   obtain m and s where "k = sgn s * int m"
     by (rule int_sgnE)
   moreover from that obtain n where "l = sgn 1 * int n"
     by (cases l) simp_all
   moreover from this that have "n > 0"
     by simp
   ultimately show ?thesis
     by (simp only: modulo_int_unfold)
       (simp add: mod_greater_zero_iff_not_dvd)
 qed
 
 lemma neg_mod_bound [simp]:
   "l < k mod l" if "l < 0" for k l :: int
 proof -
   obtain m and s where "k = sgn s * int m"
     by (rule int_sgnE)
   moreover from that obtain q where "l = sgn (- 1) * int (Suc q)"
     by (cases l) simp_all
   moreover define n where "n = Suc q"
   then have "Suc q = n"
     by simp
   ultimately show ?thesis
     by (simp only: modulo_int_unfold)
       (simp add: mod_greater_zero_iff_not_dvd)
 qed
 
 lemma pos_mod_sign [simp]:
   "0 \<le> k mod l" if "l > 0" for k l :: int
 proof -
   obtain m and s where "k = sgn s * int m"
     by (rule int_sgnE)
   moreover from that obtain n where "l = sgn 1 * int n"
     by (cases l) auto
   moreover from this that have "n > 0"
     by simp
   ultimately show ?thesis
     by (simp only: modulo_int_unfold) simp
 qed
 
 lemma neg_mod_sign [simp]:
   "k mod l \<le> 0" if "l < 0" for k l :: int
 proof -
   obtain m and s where "k = sgn s * int m"
     by (rule int_sgnE)
   moreover from that obtain q where "l = sgn (- 1) * int (Suc q)"
     by (cases l) simp_all
   moreover define n where "n = Suc q"
   then have "Suc q = n"
     by simp
   ultimately show ?thesis
     by (simp only: modulo_int_unfold) simp
 qed
 
 lemma div_pos_pos_trivial [simp]:
   "k div l = 0" if "k \<ge> 0" and "k < l" for k l :: int
   using that by (simp add: unique_euclidean_semiring_class.div_eq_0_iff division_segment_int_def)
 
 lemma mod_pos_pos_trivial [simp]:
   "k mod l = k" if "k \<ge> 0" and "k < l" for k l :: int
   using that by (simp add: mod_eq_self_iff_div_eq_0)
 
 lemma div_neg_neg_trivial [simp]:
   "k div l = 0" if "k \<le> 0" and "l < k" for k l :: int
   using that by (cases "k = 0") (simp, simp add: unique_euclidean_semiring_class.div_eq_0_iff division_segment_int_def)
 
 lemma mod_neg_neg_trivial [simp]:
   "k mod l = k" if "k \<le> 0" and "l < k" for k l :: int
   using that by (simp add: mod_eq_self_iff_div_eq_0)
 
 lemma div_pos_neg_trivial:
   "k div l = - 1" if "0 < k" and "k + l \<le> 0" for k l :: int
 proof (cases \<open>l = - k\<close>)
   case True
   with that show ?thesis
     by (simp add: divide_int_def)
 next
   case False
   show ?thesis
     apply (rule div_eqI [of _ "k + l"])
     using False that apply (simp_all add: division_segment_int_def)
     done
 qed
 
 lemma mod_pos_neg_trivial:
   "k mod l = k + l" if "0 < k" and "k + l \<le> 0" for k l :: int
 proof (cases \<open>l = - k\<close>)
   case True
   with that show ?thesis
     by (simp add: divide_int_def)
 next
   case False
   show ?thesis
     apply (rule mod_eqI [of _ _ \<open>- 1\<close>])
     using False that apply (simp_all add: division_segment_int_def)
     done
 qed
 
 text \<open>There is neither \<open>div_neg_pos_trivial\<close> nor \<open>mod_neg_pos_trivial\<close>
   because \<^term>\<open>0 div l = 0\<close> would supersede it.\<close>
 
 text \<open>Distributive laws for function \<open>nat\<close>.\<close>
 
 lemma nat_div_distrib:
   \<open>nat (x div y) = nat x div nat y\<close> if \<open>0 \<le> x\<close>
   using that by (simp add: divide_int_def sgn_if)
 
 lemma nat_div_distrib':
   \<open>nat (x div y) = nat x div nat y\<close> if \<open>0 \<le> y\<close>
   using that by (simp add: divide_int_def sgn_if)
 
 lemma nat_mod_distrib: \<comment> \<open>Fails if y<0: the LHS collapses to (nat z) but the RHS doesn't\<close>
   \<open>nat (x mod y) = nat x mod nat y\<close> if \<open>0 \<le> x\<close> \<open>0 \<le> y\<close>
   using that by (simp add: modulo_int_def sgn_if)
 
 
 subsection \<open>Special case: euclidean rings containing the natural numbers\<close>
 
 class unique_euclidean_semiring_with_nat = semidom + semiring_char_0 + unique_euclidean_semiring +
   assumes of_nat_div: "of_nat (m div n) = of_nat m div of_nat n"
     and division_segment_of_nat [simp]: "division_segment (of_nat n) = 1"
     and division_segment_euclidean_size [simp]: "division_segment a * of_nat (euclidean_size a) = a"
 begin
 
 lemma division_segment_eq_iff:
   "a = b" if "division_segment a = division_segment b"
     and "euclidean_size a = euclidean_size b"
   using that division_segment_euclidean_size [of a] by simp
 
 lemma euclidean_size_of_nat [simp]:
   "euclidean_size (of_nat n) = n"
 proof -
   have "division_segment (of_nat n) * of_nat (euclidean_size (of_nat n)) = of_nat n"
     by (fact division_segment_euclidean_size)
   then show ?thesis by simp
 qed
 
 lemma of_nat_euclidean_size:
   "of_nat (euclidean_size a) = a div division_segment a"
 proof -
   have "of_nat (euclidean_size a) = division_segment a * of_nat (euclidean_size a) div division_segment a"
     by (subst nonzero_mult_div_cancel_left) simp_all
   also have "\<dots> = a div division_segment a"
     by simp
   finally show ?thesis .
 qed
 
 lemma division_segment_1 [simp]:
   "division_segment 1 = 1"
   using division_segment_of_nat [of 1] by simp
 
 lemma division_segment_numeral [simp]:
   "division_segment (numeral k) = 1"
   using division_segment_of_nat [of "numeral k"] by simp
 
 lemma euclidean_size_1 [simp]:
   "euclidean_size 1 = 1"
   using euclidean_size_of_nat [of 1] by simp
 
 lemma euclidean_size_numeral [simp]:
   "euclidean_size (numeral k) = numeral k"
   using euclidean_size_of_nat [of "numeral k"] by simp
 
 lemma of_nat_dvd_iff:
   "of_nat m dvd of_nat n \<longleftrightarrow> m dvd n" (is "?P \<longleftrightarrow> ?Q")
 proof (cases "m = 0")
   case True
   then show ?thesis
     by simp
 next
   case False
   show ?thesis
   proof
     assume ?Q
     then show ?P
       by auto
   next
     assume ?P
     with False have "of_nat n = of_nat n div of_nat m * of_nat m"
       by simp
     then have "of_nat n = of_nat (n div m * m)"
       by (simp add: of_nat_div)
     then have "n = n div m * m"
       by (simp only: of_nat_eq_iff)
     then have "n = m * (n div m)"
       by (simp add: ac_simps)
     then show ?Q ..
   qed
 qed
 
 lemma of_nat_mod:
   "of_nat (m mod n) = of_nat m mod of_nat n"
 proof -
   have "of_nat m div of_nat n * of_nat n + of_nat m mod of_nat n = of_nat m"
     by (simp add: div_mult_mod_eq)
   also have "of_nat m = of_nat (m div n * n + m mod n)"
     by simp
   finally show ?thesis
     by (simp only: of_nat_div of_nat_mult of_nat_add) simp
 qed
 
 lemma one_div_two_eq_zero [simp]:
   "1 div 2 = 0"
 proof -
   from of_nat_div [symmetric] have "of_nat 1 div of_nat 2 = of_nat 0"
     by (simp only:) simp
   then show ?thesis
     by simp
 qed
 
 lemma one_mod_two_eq_one [simp]:
   "1 mod 2 = 1"
 proof -
   from of_nat_mod [symmetric] have "of_nat 1 mod of_nat 2 = of_nat 1"
     by (simp only:) simp
   then show ?thesis
     by simp
 qed
 
 lemma one_mod_2_pow_eq [simp]:
   "1 mod (2 ^ n) = of_bool (n > 0)"
 proof -
   have "1 mod (2 ^ n) = of_nat (1 mod (2 ^ n))"
     using of_nat_mod [of 1 "2 ^ n"] by simp
   also have "\<dots> = of_bool (n > 0)"
     by simp
   finally show ?thesis .
 qed
 
 lemma one_div_2_pow_eq [simp]:
   "1 div (2 ^ n) = of_bool (n = 0)"
   using div_mult_mod_eq [of 1 "2 ^ n"] by auto
 
 lemma div_mult2_eq':
   "a div (of_nat m * of_nat n) = a div of_nat m div of_nat n"
 proof (cases a "of_nat m * of_nat n" rule: divmod_cases)
   case (divides q)
   then show ?thesis
     using nonzero_mult_div_cancel_right [of "of_nat m" "q * of_nat n"]
     by (simp add: ac_simps)
 next
   case (remainder q r)
   then have "division_segment r = 1"
     using division_segment_of_nat [of "m * n"] by simp
   with division_segment_euclidean_size [of r]
   have "of_nat (euclidean_size r) = r"
     by simp
   have "a mod (of_nat m * of_nat n) div (of_nat m * of_nat n) = 0"
     by simp
   with remainder(6) have "r div (of_nat m * of_nat n) = 0"
     by simp
   with \<open>of_nat (euclidean_size r) = r\<close>
   have "of_nat (euclidean_size r) div (of_nat m * of_nat n) = 0"
     by simp
   then have "of_nat (euclidean_size r div (m * n)) = 0"
     by (simp add: of_nat_div)
   then have "of_nat (euclidean_size r div m div n) = 0"
     by (simp add: div_mult2_eq)
   with \<open>of_nat (euclidean_size r) = r\<close> have "r div of_nat m div of_nat n = 0"
     by (simp add: of_nat_div)
   with remainder(1)
   have "q = (r div of_nat m + q * of_nat n * of_nat m div of_nat m) div of_nat n"
     by simp
   with remainder(5) remainder(7) show ?thesis
     using div_plus_div_distrib_dvd_right [of "of_nat m" "q * (of_nat m * of_nat n)" r]
     by (simp add: ac_simps)
 next
   case by0
   then show ?thesis
     by auto
 qed
 
 lemma mod_mult2_eq':
   "a mod (of_nat m * of_nat n) = of_nat m * (a div of_nat m mod of_nat n) + a mod of_nat m"
 proof -
   have "a div (of_nat m * of_nat n) * (of_nat m * of_nat n) + a mod (of_nat m * of_nat n) = a div of_nat m div of_nat n * of_nat n * of_nat m + (a div of_nat m mod of_nat n * of_nat m + a mod of_nat m)"
     by (simp add: combine_common_factor div_mult_mod_eq)
   moreover have "a div of_nat m div of_nat n * of_nat n * of_nat m = of_nat n * of_nat m * (a div of_nat m div of_nat n)"
     by (simp add: ac_simps)
   ultimately show ?thesis
     by (simp add: div_mult2_eq' mult_commute)
 qed
 
 lemma div_mult2_numeral_eq:
   "a div numeral k div numeral l = a div numeral (k * l)" (is "?A = ?B")
 proof -
   have "?A = a div of_nat (numeral k) div of_nat (numeral l)"
     by simp
   also have "\<dots> = a div (of_nat (numeral k) * of_nat (numeral l))"
     by (fact div_mult2_eq' [symmetric])
   also have "\<dots> = ?B"
     by simp
   finally show ?thesis .
 qed
 
 lemma numeral_Bit0_div_2:
   "numeral (num.Bit0 n) div 2 = numeral n"
 proof -
   have "numeral (num.Bit0 n) = numeral n + numeral n"
     by (simp only: numeral.simps)
   also have "\<dots> = numeral n * 2"
     by (simp add: mult_2_right)
   finally have "numeral (num.Bit0 n) div 2 = numeral n * 2 div 2"
     by simp
   also have "\<dots> = numeral n"
     by (rule nonzero_mult_div_cancel_right) simp
   finally show ?thesis .
 qed
 
 lemma numeral_Bit1_div_2:
   "numeral (num.Bit1 n) div 2 = numeral n"
 proof -
   have "numeral (num.Bit1 n) = numeral n + numeral n + 1"
     by (simp only: numeral.simps)
   also have "\<dots> = numeral n * 2 + 1"
     by (simp add: mult_2_right)
   finally have "numeral (num.Bit1 n) div 2 = (numeral n * 2 + 1) div 2"
     by simp
   also have "\<dots> = numeral n * 2 div 2 + 1 div 2"
     using dvd_triv_right by (rule div_plus_div_distrib_dvd_left)
   also have "\<dots> = numeral n * 2 div 2"
     by simp
   also have "\<dots> = numeral n"
     by (rule nonzero_mult_div_cancel_right) simp
   finally show ?thesis .
 qed
 
 lemma exp_mod_exp:
   \<open>2 ^ m mod 2 ^ n = of_bool (m < n) * 2 ^ m\<close>
 proof -
   have \<open>(2::nat) ^ m mod 2 ^ n = of_bool (m < n) * 2 ^ m\<close> (is \<open>?lhs = ?rhs\<close>)
     by (auto simp add: not_less monoid_mult_class.power_add dest!: le_Suc_ex)
   then have \<open>of_nat ?lhs = of_nat ?rhs\<close>
     by simp
   then show ?thesis
     by (simp add: of_nat_mod)
 qed
 
 lemma mask_mod_exp:
   \<open>(2 ^ n - 1) mod 2 ^ m = 2 ^ min m n - 1\<close>
 proof -
   have \<open>(2 ^ n - 1) mod 2 ^ m = 2 ^ min m n - (1::nat)\<close> (is \<open>?lhs = ?rhs\<close>)
   proof (cases \<open>n \<le> m\<close>)
     case True
     then show ?thesis
       by (simp add: Suc_le_lessD min.absorb2)
   next
     case False
     then have \<open>m < n\<close>
       by simp
     then obtain q where n: \<open>n = Suc q + m\<close>
       by (auto dest: less_imp_Suc_add)
     then have \<open>min m n = m\<close>
       by simp
     moreover have \<open>(2::nat) ^ m \<le> 2 * 2 ^ q * 2 ^ m\<close>
       using mult_le_mono1 [of 1 \<open>2 * 2 ^ q\<close> \<open>2 ^ m\<close>] by simp
     with n have \<open>2 ^ n - 1 = (2 ^ Suc q - 1) * 2 ^ m + (2 ^ m - (1::nat))\<close>
       by (simp add: monoid_mult_class.power_add algebra_simps)
     ultimately show ?thesis
       by (simp only: euclidean_semiring_cancel_class.mod_mult_self3) simp
   qed
   then have \<open>of_nat ?lhs = of_nat ?rhs\<close>
     by simp
   then show ?thesis
     by (simp add: of_nat_mod of_nat_diff)
 qed
 
 lemma of_bool_half_eq_0 [simp]:
   \<open>of_bool b div 2 = 0\<close>
   by simp
 
 end
 
 class unique_euclidean_ring_with_nat = ring + unique_euclidean_semiring_with_nat
 
 instance nat :: unique_euclidean_semiring_with_nat
   by standard (simp_all add: dvd_eq_mod_eq_0)
 
 instance int :: unique_euclidean_ring_with_nat
   by standard (simp_all add: dvd_eq_mod_eq_0 divide_int_def division_segment_int_def)
 
 lemma zdiv_zmult2_eq:
   \<open>a div (b * c) = (a div b) div c\<close> if \<open>c \<ge> 0\<close> for a b c :: int
 proof (cases \<open>b \<ge> 0\<close>)
   case True
   with that show ?thesis
     using div_mult2_eq' [of a \<open>nat b\<close> \<open>nat c\<close>] by simp
 next
   case False
   with that show ?thesis
     using div_mult2_eq' [of \<open>- a\<close> \<open>nat (- b)\<close> \<open>nat c\<close>] by simp
 qed
 
 lemma zmod_zmult2_eq:
   \<open>a mod (b * c) = b * (a div b mod c) + a mod b\<close> if \<open>c \<ge> 0\<close> for a b c :: int
 proof (cases \<open>b \<ge> 0\<close>)
   case True
   with that show ?thesis
     using mod_mult2_eq' [of a \<open>nat b\<close> \<open>nat c\<close>] by simp
 next
   case False
   with that show ?thesis
     using mod_mult2_eq' [of \<open>- a\<close> \<open>nat (- b)\<close> \<open>nat c\<close>] by simp
 qed
 
 
 subsection \<open>Code generation\<close>
 
 code_identifier
   code_module Euclidean_Division \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 end
diff --git a/src/HOL/Fields.thy b/src/HOL/Fields.thy
--- a/src/HOL/Fields.thy
+++ b/src/HOL/Fields.thy
@@ -1,1348 +1,1348 @@
 (*  Title:      HOL/Fields.thy
     Author:     Gertrud Bauer
     Author:     Steven Obua
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
 *)
 
 section \<open>Fields\<close>
 
 theory Fields
 imports Nat
 begin
 
 context idom
 begin
 
 lemma inj_mult_left [simp]: \<open>inj ((*) a) \<longleftrightarrow> a \<noteq> 0\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?P
   show ?Q
   proof
     assume \<open>a = 0\<close>
     with \<open>?P\<close> have "inj ((*) 0)"
       by simp
     moreover have "0 * 0 = 0 * 1"
       by simp
     ultimately have "0 = 1"
       by (rule injD)
     then show False
       by simp
   qed
 next
   assume ?Q then show ?P
     by (auto intro: injI)
 qed
 
 end
 
 
 subsection \<open>Division rings\<close>
 
 text \<open>
   A division ring is like a field, but without the commutativity requirement.
 \<close>
 
 class inverse = divide +
   fixes inverse :: "'a \<Rightarrow> 'a"
 begin
   
 abbreviation inverse_divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "'/" 70)
 where
   "inverse_divide \<equiv> divide"
 
 end
 
 text \<open>Setup for linear arithmetic prover\<close>
 
 ML_file \<open>~~/src/Provers/Arith/fast_lin_arith.ML\<close>
 ML_file \<open>Tools/lin_arith.ML\<close>
 setup \<open>Lin_Arith.global_setup\<close>
 declaration \<open>K (
   Lin_Arith.init_arith_data
   #> Lin_Arith.add_discrete_type \<^type_name>\<open>nat\<close>
   #> Lin_Arith.add_lessD @{thm Suc_leI}
   #> Lin_Arith.add_simps @{thms simp_thms ring_distribs if_True if_False
       minus_diff_eq
       add_0_left add_0_right order_less_irrefl
       zero_neq_one zero_less_one zero_le_one
       zero_neq_one [THEN not_sym] not_one_le_zero not_one_less_zero
       add_Suc add_Suc_right nat.inject
       Suc_le_mono Suc_less_eq Zero_not_Suc
       Suc_not_Zero le_0_eq One_nat_def}
   #> Lin_Arith.add_simprocs [\<^simproc>\<open>group_cancel_add\<close>, \<^simproc>\<open>group_cancel_diff\<close>,
       \<^simproc>\<open>group_cancel_eq\<close>, \<^simproc>\<open>group_cancel_le\<close>,
       \<^simproc>\<open>group_cancel_less\<close>,
       \<^simproc>\<open>nateq_cancel_sums\<close>,\<^simproc>\<open>natless_cancel_sums\<close>,
       \<^simproc>\<open>natle_cancel_sums\<close>])\<close>
 
 simproc_setup fast_arith_nat ("(m::nat) < n" | "(m::nat) \<le> n" | "(m::nat) = n") =
   \<open>K Lin_Arith.simproc\<close> \<comment> \<open>Because of this simproc, the arithmetic solver is
    really only useful to detect inconsistencies among the premises for subgoals which are
    \<^emph>\<open>not\<close> themselves (in)equalities, because the latter activate
    \<^text>\<open>fast_nat_arith_simproc\<close> anyway. However, it seems cheaper to activate the
    solver all the time rather than add the additional check.\<close>
 
 lemmas [arith_split] = nat_diff_split split_min split_max
 
 text\<open>Lemmas \<open>divide_simps\<close> move division to the outside and eliminates them on (in)equalities.\<close>
 
 named_theorems divide_simps "rewrite rules to eliminate divisions"
 
 class division_ring = ring_1 + inverse +
   assumes left_inverse [simp]:  "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
   assumes right_inverse [simp]: "a \<noteq> 0 \<Longrightarrow> a * inverse a = 1"
   assumes divide_inverse: "a / b = a * inverse b"
   assumes inverse_zero [simp]: "inverse 0 = 0"
 begin
 
 subclass ring_1_no_zero_divisors
 proof
   fix a b :: 'a
   assume a: "a \<noteq> 0" and b: "b \<noteq> 0"
   show "a * b \<noteq> 0"
   proof
     assume ab: "a * b = 0"
     hence "0 = inverse a * (a * b) * inverse b" by simp
     also have "\<dots> = (inverse a * a) * (b * inverse b)"
       by (simp only: mult.assoc)
     also have "\<dots> = 1" using a b by simp
     finally show False by simp
   qed
 qed
 
 lemma nonzero_imp_inverse_nonzero:
   "a \<noteq> 0 \<Longrightarrow> inverse a \<noteq> 0"
 proof
   assume ianz: "inverse a = 0"
   assume "a \<noteq> 0"
   hence "1 = a * inverse a" by simp
   also have "... = 0" by (simp add: ianz)
   finally have "1 = 0" .
   thus False by (simp add: eq_commute)
 qed
 
 lemma inverse_zero_imp_zero:
   assumes "inverse a = 0" shows "a = 0"
 proof (rule ccontr)
   assume "a \<noteq> 0"
   then have "inverse a \<noteq> 0"
     by (simp add: nonzero_imp_inverse_nonzero)
   with assms show False
     by auto
 qed
 
 lemma inverse_unique:
   assumes ab: "a * b = 1"
   shows "inverse a = b"
 proof -
   have "a \<noteq> 0" using ab by (cases "a = 0") simp_all
   moreover have "inverse a * (a * b) = inverse a" by (simp add: ab)
   ultimately show ?thesis by (simp add: mult.assoc [symmetric])
 qed
 
 lemma nonzero_inverse_minus_eq:
   "a \<noteq> 0 \<Longrightarrow> inverse (- a) = - inverse a"
 by (rule inverse_unique) simp
 
 lemma nonzero_inverse_inverse_eq:
   "a \<noteq> 0 \<Longrightarrow> inverse (inverse a) = a"
 by (rule inverse_unique) simp
 
 lemma nonzero_inverse_eq_imp_eq:
   assumes "inverse a = inverse b" and "a \<noteq> 0" and "b \<noteq> 0"
   shows "a = b"
 proof -
   from \<open>inverse a = inverse b\<close>
   have "inverse (inverse a) = inverse (inverse b)" by (rule arg_cong)
   with \<open>a \<noteq> 0\<close> and \<open>b \<noteq> 0\<close> show "a = b"
     by (simp add: nonzero_inverse_inverse_eq)
 qed
 
 lemma inverse_1 [simp]: "inverse 1 = 1"
 by (rule inverse_unique) simp
 
 lemma nonzero_inverse_mult_distrib:
   assumes "a \<noteq> 0" and "b \<noteq> 0"
   shows "inverse (a * b) = inverse b * inverse a"
 proof -
   have "a * (b * inverse b) * inverse a = 1" using assms by simp
   hence "a * b * (inverse b * inverse a) = 1" by (simp only: mult.assoc)
   thus ?thesis by (rule inverse_unique)
 qed
 
 lemma division_ring_inverse_add:
   "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a + inverse b = inverse a * (a + b) * inverse b"
 by (simp add: algebra_simps)
 
 lemma division_ring_inverse_diff:
   "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a - inverse b = inverse a * (b - a) * inverse b"
 by (simp add: algebra_simps)
 
 lemma right_inverse_eq: "b \<noteq> 0 \<Longrightarrow> a / b = 1 \<longleftrightarrow> a = b"
 proof
   assume neq: "b \<noteq> 0"
   {
     hence "a = (a / b) * b" by (simp add: divide_inverse mult.assoc)
     also assume "a / b = 1"
     finally show "a = b" by simp
   next
     assume "a = b"
     with neq show "a / b = 1" by (simp add: divide_inverse)
   }
 qed
 
 lemma nonzero_inverse_eq_divide: "a \<noteq> 0 \<Longrightarrow> inverse a = 1 / a"
 by (simp add: divide_inverse)
 
 lemma divide_self [simp]: "a \<noteq> 0 \<Longrightarrow> a / a = 1"
 by (simp add: divide_inverse)
 
 lemma inverse_eq_divide [field_simps, field_split_simps, divide_simps]: "inverse a = 1 / a"
 by (simp add: divide_inverse)
 
 lemma add_divide_distrib: "(a+b) / c = a/c + b/c"
 by (simp add: divide_inverse algebra_simps)
 
 lemma times_divide_eq_right [simp]: "a * (b / c) = (a * b) / c"
   by (simp add: divide_inverse mult.assoc)
 
 lemma minus_divide_left: "- (a / b) = (-a) / b"
   by (simp add: divide_inverse)
 
 lemma nonzero_minus_divide_right: "b \<noteq> 0 \<Longrightarrow> - (a / b) = a / (- b)"
   by (simp add: divide_inverse nonzero_inverse_minus_eq)
 
 lemma nonzero_minus_divide_divide: "b \<noteq> 0 \<Longrightarrow> (-a) / (-b) = a / b"
   by (simp add: divide_inverse nonzero_inverse_minus_eq)
 
 lemma divide_minus_left [simp]: "(-a) / b = - (a / b)"
   by (simp add: divide_inverse)
 
 lemma diff_divide_distrib: "(a - b) / c = a / c - b / c"
   using add_divide_distrib [of a "- b" c] by simp
 
 lemma nonzero_eq_divide_eq [field_simps]: "c \<noteq> 0 \<Longrightarrow> a = b / c \<longleftrightarrow> a * c = b"
 proof -
   assume [simp]: "c \<noteq> 0"
   have "a = b / c \<longleftrightarrow> a * c = (b / c) * c" by simp
   also have "... \<longleftrightarrow> a * c = b" by (simp add: divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma nonzero_divide_eq_eq [field_simps]: "c \<noteq> 0 \<Longrightarrow> b / c = a \<longleftrightarrow> b = a * c"
 proof -
   assume [simp]: "c \<noteq> 0"
   have "b / c = a \<longleftrightarrow> (b / c) * c = a * c" by simp
   also have "... \<longleftrightarrow> b = a * c" by (simp add: divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma nonzero_neg_divide_eq_eq [field_simps]: "b \<noteq> 0 \<Longrightarrow> - (a / b) = c \<longleftrightarrow> - a = c * b"
   using nonzero_divide_eq_eq[of b "-a" c] by simp
 
 lemma nonzero_neg_divide_eq_eq2 [field_simps]: "b \<noteq> 0 \<Longrightarrow> c = - (a / b) \<longleftrightarrow> c * b = - a"
   using nonzero_neg_divide_eq_eq[of b a c] by auto
 
 lemma divide_eq_imp: "c \<noteq> 0 \<Longrightarrow> b = a * c \<Longrightarrow> b / c = a"
   by (simp add: divide_inverse mult.assoc)
 
 lemma eq_divide_imp: "c \<noteq> 0 \<Longrightarrow> a * c = b \<Longrightarrow> a = b / c"
   by (drule sym) (simp add: divide_inverse mult.assoc)
 
 lemma add_divide_eq_iff [field_simps]:
   "z \<noteq> 0 \<Longrightarrow> x + y / z = (x * z + y) / z"
   by (simp add: add_divide_distrib nonzero_eq_divide_eq)
 
 lemma divide_add_eq_iff [field_simps]:
   "z \<noteq> 0 \<Longrightarrow> x / z + y = (x + y * z) / z"
   by (simp add: add_divide_distrib nonzero_eq_divide_eq)
 
 lemma diff_divide_eq_iff [field_simps]:
   "z \<noteq> 0 \<Longrightarrow> x - y / z = (x * z - y) / z"
   by (simp add: diff_divide_distrib nonzero_eq_divide_eq eq_diff_eq)
 
 lemma minus_divide_add_eq_iff [field_simps]:
   "z \<noteq> 0 \<Longrightarrow> - (x / z) + y = (- x + y * z) / z"
   by (simp add: add_divide_distrib diff_divide_eq_iff)
 
 lemma divide_diff_eq_iff [field_simps]:
   "z \<noteq> 0 \<Longrightarrow> x / z - y = (x - y * z) / z"
   by (simp add: field_simps)
 
 lemma minus_divide_diff_eq_iff [field_simps]:
   "z \<noteq> 0 \<Longrightarrow> - (x / z) - y = (- x - y * z) / z"
   by (simp add: divide_diff_eq_iff[symmetric])
 
 lemma division_ring_divide_zero [simp]:
   "a / 0 = 0"
   by (simp add: divide_inverse)
 
 lemma divide_self_if [simp]:
   "a / a = (if a = 0 then 0 else 1)"
   by simp
 
 lemma inverse_nonzero_iff_nonzero [simp]:
   "inverse a = 0 \<longleftrightarrow> a = 0"
-  by rule (fact inverse_zero_imp_zero, simp)
+  by (rule iffI) (fact inverse_zero_imp_zero, simp)
 
 lemma inverse_minus_eq [simp]:
   "inverse (- a) = - inverse a"
 proof cases
   assume "a=0" thus ?thesis by simp
 next
   assume "a\<noteq>0"
   thus ?thesis by (simp add: nonzero_inverse_minus_eq)
 qed
 
 lemma inverse_inverse_eq [simp]:
   "inverse (inverse a) = a"
 proof cases
   assume "a=0" thus ?thesis by simp
 next
   assume "a\<noteq>0"
   thus ?thesis by (simp add: nonzero_inverse_inverse_eq)
 qed
 
 lemma inverse_eq_imp_eq:
   "inverse a = inverse b \<Longrightarrow> a = b"
   by (drule arg_cong [where f="inverse"], simp)
 
 lemma inverse_eq_iff_eq [simp]:
   "inverse a = inverse b \<longleftrightarrow> a = b"
   by (force dest!: inverse_eq_imp_eq)
 
 lemma mult_commute_imp_mult_inverse_commute:
   assumes "y * x = x * y"
   shows   "inverse y * x = x * inverse y"
 proof (cases "y=0")
   case False
   hence "x * inverse y = inverse y * y * x * inverse y"
     by simp
   also have "\<dots> = inverse y * (x * y * inverse y)"
     by (simp add: mult.assoc assms)
   finally show ?thesis by (simp add: mult.assoc False)
 qed simp
 
 lemmas mult_inverse_of_nat_commute =
   mult_commute_imp_mult_inverse_commute[OF mult_of_nat_commute]
 
 lemma divide_divide_eq_left':
   "(a / b) / c = a / (c * b)"
   by (cases "b = 0 \<or> c = 0")
      (auto simp: divide_inverse mult.assoc nonzero_inverse_mult_distrib)
 
 lemma add_divide_eq_if_simps [field_split_simps, divide_simps]:
     "a + b / z = (if z = 0 then a else (a * z + b) / z)"
     "a / z + b = (if z = 0 then b else (a + b * z) / z)"
     "- (a / z) + b = (if z = 0 then b else (-a + b * z) / z)"
     "a - b / z = (if z = 0 then a else (a * z - b) / z)"
     "a / z - b = (if z = 0 then -b else (a - b * z) / z)"
     "- (a / z) - b = (if z = 0 then -b else (- a - b * z) / z)"
   by (simp_all add: add_divide_eq_iff divide_add_eq_iff diff_divide_eq_iff divide_diff_eq_iff
       minus_divide_diff_eq_iff)
 
 lemma [field_split_simps, divide_simps]:
   shows divide_eq_eq: "b / c = a \<longleftrightarrow> (if c \<noteq> 0 then b = a * c else a = 0)"
     and eq_divide_eq: "a = b / c \<longleftrightarrow> (if c \<noteq> 0 then a * c = b else a = 0)"
     and minus_divide_eq_eq: "- (b / c) = a \<longleftrightarrow> (if c \<noteq> 0 then - b = a * c else a = 0)"
     and eq_minus_divide_eq: "a = - (b / c) \<longleftrightarrow> (if c \<noteq> 0 then a * c = - b else a = 0)"
   by (auto simp add:  field_simps)
 
 end
 
 subsection \<open>Fields\<close>
 
 class field = comm_ring_1 + inverse +
   assumes field_inverse: "a \<noteq> 0 \<Longrightarrow> inverse a * a = 1"
   assumes field_divide_inverse: "a / b = a * inverse b"
   assumes field_inverse_zero: "inverse 0 = 0"
 begin
 
 subclass division_ring
 proof
   fix a :: 'a
   assume "a \<noteq> 0"
   thus "inverse a * a = 1" by (rule field_inverse)
   thus "a * inverse a = 1" by (simp only: mult.commute)
 next
   fix a b :: 'a
   show "a / b = a * inverse b" by (rule field_divide_inverse)
 next
   show "inverse 0 = 0"
     by (fact field_inverse_zero) 
 qed
 
 subclass idom_divide
 proof
   fix b a
   assume "b \<noteq> 0"
   then show "a * b / b = a"
     by (simp add: divide_inverse ac_simps)
 next
   fix a
   show "a / 0 = 0"
     by (simp add: divide_inverse)
 qed
 
 text\<open>There is no slick version using division by zero.\<close>
 lemma inverse_add:
   "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> inverse a + inverse b = (a + b) * inverse a * inverse b"
   by (simp add: division_ring_inverse_add ac_simps)
 
 lemma nonzero_mult_divide_mult_cancel_left [simp]:
   assumes [simp]: "c \<noteq> 0"
   shows "(c * a) / (c * b) = a / b"
 proof (cases "b = 0")
   case True then show ?thesis by simp
 next
   case False
   then have "(c*a)/(c*b) = c * a * (inverse b * inverse c)"
     by (simp add: divide_inverse nonzero_inverse_mult_distrib)
   also have "... =  a * inverse b * (inverse c * c)"
     by (simp only: ac_simps)
   also have "... =  a * inverse b" by simp
     finally show ?thesis by (simp add: divide_inverse)
 qed
 
 lemma nonzero_mult_divide_mult_cancel_right [simp]:
   "c \<noteq> 0 \<Longrightarrow> (a * c) / (b * c) = a / b"
   using nonzero_mult_divide_mult_cancel_left [of c a b] by (simp add: ac_simps)
 
 lemma times_divide_eq_left [simp]: "(b / c) * a = (b * a) / c"
   by (simp add: divide_inverse ac_simps)
 
 lemma divide_inverse_commute: "a / b = inverse b * a"
   by (simp add: divide_inverse mult.commute)
 
 lemma add_frac_eq:
   assumes "y \<noteq> 0" and "z \<noteq> 0"
   shows "x / y + w / z = (x * z + w * y) / (y * z)"
 proof -
   have "x / y + w / z = (x * z) / (y * z) + (y * w) / (y * z)"
     using assms by simp
   also have "\<dots> = (x * z + y * w) / (y * z)"
     by (simp only: add_divide_distrib)
   finally show ?thesis
     by (simp only: mult.commute)
 qed
 
 text\<open>Special Cancellation Simprules for Division\<close>
 
 lemma nonzero_divide_mult_cancel_right [simp]:
   "b \<noteq> 0 \<Longrightarrow> b / (a * b) = 1 / a"
   using nonzero_mult_divide_mult_cancel_right [of b 1 a] by simp
 
 lemma nonzero_divide_mult_cancel_left [simp]:
   "a \<noteq> 0 \<Longrightarrow> a / (a * b) = 1 / b"
   using nonzero_mult_divide_mult_cancel_left [of a 1 b] by simp
 
 lemma nonzero_mult_divide_mult_cancel_left2 [simp]:
   "c \<noteq> 0 \<Longrightarrow> (c * a) / (b * c) = a / b"
   using nonzero_mult_divide_mult_cancel_left [of c a b] by (simp add: ac_simps)
 
 lemma nonzero_mult_divide_mult_cancel_right2 [simp]:
   "c \<noteq> 0 \<Longrightarrow> (a * c) / (c * b) = a / b"
   using nonzero_mult_divide_mult_cancel_right [of b c a] by (simp add: ac_simps)
 
 lemma diff_frac_eq:
   "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y - w / z = (x * z - w * y) / (y * z)"
   by (simp add: field_simps)
 
 lemma frac_eq_eq:
   "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> (x / y = w / z) = (x * z = w * y)"
   by (simp add: field_simps)
 
 lemma divide_minus1 [simp]: "x / - 1 = - x"
   using nonzero_minus_divide_right [of "1" x] by simp
 
 text\<open>This version builds in division by zero while also re-orienting
       the right-hand side.\<close>
 lemma inverse_mult_distrib [simp]:
   "inverse (a * b) = inverse a * inverse b"
 proof cases
   assume "a \<noteq> 0 \<and> b \<noteq> 0"
   thus ?thesis by (simp add: nonzero_inverse_mult_distrib ac_simps)
 next
   assume "\<not> (a \<noteq> 0 \<and> b \<noteq> 0)"
   thus ?thesis by force
 qed
 
 lemma inverse_divide [simp]:
   "inverse (a / b) = b / a"
   by (simp add: divide_inverse mult.commute)
 
 
 text \<open>Calculations with fractions\<close>
 
 text\<open>There is a whole bunch of simp-rules just for class \<open>field\<close> but none for class \<open>field\<close> and \<open>nonzero_divides\<close>
 because the latter are covered by a simproc.\<close>
 
 lemmas mult_divide_mult_cancel_left = nonzero_mult_divide_mult_cancel_left
 
 lemmas mult_divide_mult_cancel_right = nonzero_mult_divide_mult_cancel_right
 
 lemma divide_divide_eq_right [simp]:
   "a / (b / c) = (a * c) / b"
   by (simp add: divide_inverse ac_simps)
 
 lemma divide_divide_eq_left [simp]:
   "(a / b) / c = a / (b * c)"
   by (simp add: divide_inverse mult.assoc)
 
 lemma divide_divide_times_eq:
   "(x / y) / (z / w) = (x * w) / (y * z)"
   by simp
 
 text \<open>Special Cancellation Simprules for Division\<close>
 
 lemma mult_divide_mult_cancel_left_if [simp]:
   shows "(c * a) / (c * b) = (if c = 0 then 0 else a / b)"
   by simp
 
 
 text \<open>Division and Unary Minus\<close>
 
 lemma minus_divide_right:
   "- (a / b) = a / - b"
   by (simp add: divide_inverse)
 
 lemma divide_minus_right [simp]:
   "a / - b = - (a / b)"
   by (simp add: divide_inverse)
 
 lemma minus_divide_divide:
   "(- a) / (- b) = a / b"
   by (cases "b=0") (simp_all add: nonzero_minus_divide_divide)
 
 lemma inverse_eq_1_iff [simp]:
   "inverse x = 1 \<longleftrightarrow> x = 1"
-  by (insert inverse_eq_iff_eq [of x 1], simp)
+  using inverse_eq_iff_eq [of x 1] by simp
 
 lemma divide_eq_0_iff [simp]:
   "a / b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
   by (simp add: divide_inverse)
 
 lemma divide_cancel_right [simp]:
   "a / c = b / c \<longleftrightarrow> c = 0 \<or> a = b"
   by (cases "c=0") (simp_all add: divide_inverse)
 
 lemma divide_cancel_left [simp]:
   "c / a = c / b \<longleftrightarrow> c = 0 \<or> a = b"
   by (cases "c=0") (simp_all add: divide_inverse)
 
 lemma divide_eq_1_iff [simp]:
   "a / b = 1 \<longleftrightarrow> b \<noteq> 0 \<and> a = b"
   by (cases "b=0") (simp_all add: right_inverse_eq)
 
 lemma one_eq_divide_iff [simp]:
   "1 = a / b \<longleftrightarrow> b \<noteq> 0 \<and> a = b"
   by (simp add: eq_commute [of 1])
 
 lemma divide_eq_minus_1_iff:
    "(a / b = - 1) \<longleftrightarrow> b \<noteq> 0 \<and> a = - b"
 using divide_eq_1_iff by fastforce
 
 lemma times_divide_times_eq:
   "(x / y) * (z / w) = (x * z) / (y * w)"
   by simp
 
 lemma add_frac_num:
   "y \<noteq> 0 \<Longrightarrow> x / y + z = (x + z * y) / y"
   by (simp add: add_divide_distrib)
 
 lemma add_num_frac:
   "y \<noteq> 0 \<Longrightarrow> z + x / y = (x + z * y) / y"
   by (simp add: add_divide_distrib add.commute)
 
 lemma dvd_field_iff:
   "a dvd b \<longleftrightarrow> (a = 0 \<longrightarrow> b = 0)"
 proof (cases "a = 0")
   case False
   then have "b = a * (b / a)"
     by (simp add: field_simps)
   then have "a dvd b" ..
   with False show ?thesis
     by simp
 qed simp
 
 lemma inj_divide_right [simp]:
   "inj (\<lambda>b. b / a) \<longleftrightarrow> a \<noteq> 0"
 proof -
   have "(\<lambda>b. b / a) = (*) (inverse a)"
     by (simp add: field_simps fun_eq_iff)
   then have "inj (\<lambda>y. y / a) \<longleftrightarrow> inj ((*) (inverse a))"
     by simp
   also have "\<dots> \<longleftrightarrow> inverse a \<noteq> 0"
     by simp
   also have "\<dots> \<longleftrightarrow> a \<noteq> 0"
     by simp
   finally show ?thesis
     by simp
 qed
 
 end
 
 class field_char_0 = field + ring_char_0
 
 
 subsection \<open>Ordered fields\<close>
 
 class field_abs_sgn = field + idom_abs_sgn
 begin
 
 lemma sgn_inverse [simp]:
   "sgn (inverse a) = inverse (sgn a)"
 proof (cases "a = 0")
   case True then show ?thesis by simp
 next
   case False
   then have "a * inverse a = 1"
     by simp
   then have "sgn (a * inverse a) = sgn 1"
     by simp
   then have "sgn a * sgn (inverse a) = 1"
     by (simp add: sgn_mult)
   then have "inverse (sgn a) * (sgn a * sgn (inverse a)) = inverse (sgn a) * 1"
     by simp
   then have "(inverse (sgn a) * sgn a) * sgn (inverse a) = inverse (sgn a)"
     by (simp add: ac_simps)
   with False show ?thesis
     by (simp add: sgn_eq_0_iff)
 qed
 
 lemma abs_inverse [simp]:
   "\<bar>inverse a\<bar> = inverse \<bar>a\<bar>"
 proof -
   from sgn_mult_abs [of "inverse a"] sgn_mult_abs [of a]
   have "inverse (sgn a) * \<bar>inverse a\<bar> = inverse (sgn a * \<bar>a\<bar>)"
     by simp
   then show ?thesis by (auto simp add: sgn_eq_0_iff)
 qed
     
 lemma sgn_divide [simp]:
   "sgn (a / b) = sgn a / sgn b"
   unfolding divide_inverse sgn_mult by simp
 
 lemma abs_divide [simp]:
   "\<bar>a / b\<bar> = \<bar>a\<bar> / \<bar>b\<bar>"
   unfolding divide_inverse abs_mult by simp
   
 end
 
 class linordered_field = field + linordered_idom
 begin
 
 lemma positive_imp_inverse_positive:
   assumes a_gt_0: "0 < a"
   shows "0 < inverse a"
 proof -
   have "0 < a * inverse a"
     by (simp add: a_gt_0 [THEN less_imp_not_eq2])
   thus "0 < inverse a"
     by (simp add: a_gt_0 [THEN less_not_sym] zero_less_mult_iff)
 qed
 
 lemma negative_imp_inverse_negative:
   "a < 0 \<Longrightarrow> inverse a < 0"
-  by (insert positive_imp_inverse_positive [of "-a"],
-    simp add: nonzero_inverse_minus_eq less_imp_not_eq)
+  using positive_imp_inverse_positive [of "-a"]
+  by (simp add: nonzero_inverse_minus_eq less_imp_not_eq)
 
 lemma inverse_le_imp_le:
   assumes invle: "inverse a \<le> inverse b" and apos: "0 < a"
   shows "b \<le> a"
 proof (rule classical)
   assume "\<not> b \<le> a"
   hence "a < b"  by (simp add: linorder_not_le)
   hence bpos: "0 < b"  by (blast intro: apos less_trans)
   hence "a * inverse a \<le> a * inverse b"
     by (simp add: apos invle less_imp_le mult_left_mono)
   hence "(a * inverse a) * b \<le> (a * inverse b) * b"
     by (simp add: bpos less_imp_le mult_right_mono)
   thus "b \<le> a"  by (simp add: mult.assoc apos bpos less_imp_not_eq2)
 qed
 
 lemma inverse_positive_imp_positive:
   assumes inv_gt_0: "0 < inverse a" and nz: "a \<noteq> 0"
   shows "0 < a"
 proof -
   have "0 < inverse (inverse a)"
     using inv_gt_0 by (rule positive_imp_inverse_positive)
   thus "0 < a"
     using nz by (simp add: nonzero_inverse_inverse_eq)
 qed
 
 lemma inverse_negative_imp_negative:
   assumes inv_less_0: "inverse a < 0" and nz: "a \<noteq> 0"
   shows "a < 0"
 proof -
   have "inverse (inverse a) < 0"
     using inv_less_0 by (rule negative_imp_inverse_negative)
   thus "a < 0" using nz by (simp add: nonzero_inverse_inverse_eq)
 qed
 
 lemma linordered_field_no_lb:
   "\<forall>x. \<exists>y. y < x"
 proof
   fix x::'a
   have m1: "- (1::'a) < 0" by simp
   from add_strict_right_mono[OF m1, where c=x]
   have "(- 1) + x < x" by simp
   thus "\<exists>y. y < x" by blast
 qed
 
 lemma linordered_field_no_ub:
   "\<forall> x. \<exists>y. y > x"
 proof
   fix x::'a
   have m1: " (1::'a) > 0" by simp
   from add_strict_right_mono[OF m1, where c=x]
   have "1 + x > x" by simp
   thus "\<exists>y. y > x" by blast
 qed
 
 lemma less_imp_inverse_less:
   assumes less: "a < b" and apos:  "0 < a"
   shows "inverse b < inverse a"
 proof (rule ccontr)
   assume "\<not> inverse b < inverse a"
   hence "inverse a \<le> inverse b" by simp
   hence "\<not> (a < b)"
     by (simp add: not_less inverse_le_imp_le [OF _ apos])
   thus False by (rule notE [OF _ less])
 qed
 
 lemma inverse_less_imp_less:
   assumes "inverse a < inverse b" "0 < a"
   shows "b < a"
 proof -
   have "a \<noteq> b"
     using assms by (simp add: less_le)
   moreover have "b \<le> a"
     using assms by (force simp: less_le dest: inverse_le_imp_le)
   ultimately show ?thesis
     by (simp add: less_le)
 qed
 
 text\<open>Both premises are essential. Consider -1 and 1.\<close>
 lemma inverse_less_iff_less [simp]:
   "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> inverse a < inverse b \<longleftrightarrow> b < a"
   by (blast intro: less_imp_inverse_less dest: inverse_less_imp_less)
 
 lemma le_imp_inverse_le:
   "a \<le> b \<Longrightarrow> 0 < a \<Longrightarrow> inverse b \<le> inverse a"
   by (force simp add: le_less less_imp_inverse_less)
 
 lemma inverse_le_iff_le [simp]:
   "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> inverse a \<le> inverse b \<longleftrightarrow> b \<le> a"
   by (blast intro: le_imp_inverse_le dest: inverse_le_imp_le)
 
 
 text\<open>These results refer to both operands being negative.  The opposite-sign
 case is trivial, since inverse preserves signs.\<close>
 lemma inverse_le_imp_le_neg:
   assumes "inverse a \<le> inverse b" "b < 0"
   shows "b \<le> a"
 proof (rule classical)
   assume "\<not> b \<le> a"
   with \<open>b < 0\<close> have "a < 0"
     by force
   with assms show "b \<le> a"
     using inverse_le_imp_le [of "-b" "-a"] by (simp add: nonzero_inverse_minus_eq)
 qed
 
 lemma less_imp_inverse_less_neg:
   assumes "a < b" "b < 0"
   shows "inverse b < inverse a"
 proof -
   have "a < 0"
     using assms by (blast intro: less_trans)
   with less_imp_inverse_less [of "-b" "-a"] show ?thesis
     by (simp add: nonzero_inverse_minus_eq assms)
 qed
 
 lemma inverse_less_imp_less_neg:
   assumes "inverse a < inverse b" "b < 0"
   shows "b < a"
 proof (rule classical)
   assume "\<not> b < a"
   with \<open>b < 0\<close> have "a < 0"
     by force
   with inverse_less_imp_less [of "-b" "-a"] show ?thesis
     by (simp add: nonzero_inverse_minus_eq assms)
 qed
 
 lemma inverse_less_iff_less_neg [simp]:
   "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> inverse a < inverse b \<longleftrightarrow> b < a"
   using inverse_less_iff_less [of "-b" "-a"]
   by (simp del: inverse_less_iff_less add: nonzero_inverse_minus_eq)
 
 lemma le_imp_inverse_le_neg:
   "a \<le> b \<Longrightarrow> b < 0 \<Longrightarrow> inverse b \<le> inverse a"
   by (force simp add: le_less less_imp_inverse_less_neg)
 
 lemma inverse_le_iff_le_neg [simp]:
   "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> inverse a \<le> inverse b \<longleftrightarrow> b \<le> a"
   by (blast intro: le_imp_inverse_le_neg dest: inverse_le_imp_le_neg)
 
 lemma one_less_inverse:
   "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> 1 < inverse a"
   using less_imp_inverse_less [of a 1, unfolded inverse_1] .
 
 lemma one_le_inverse:
   "0 < a \<Longrightarrow> a \<le> 1 \<Longrightarrow> 1 \<le> inverse a"
   using le_imp_inverse_le [of a 1, unfolded inverse_1] .
 
 lemma pos_le_divide_eq [field_simps]:
   assumes "0 < c"
   shows "a \<le> b / c \<longleftrightarrow> a * c \<le> b"
 proof -
   from assms have "a \<le> b / c \<longleftrightarrow> a * c \<le> (b / c) * c"
     using mult_le_cancel_right [of a c "b * inverse c"] by (auto simp add: field_simps)
   also have "... \<longleftrightarrow> a * c \<le> b"
     by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma pos_less_divide_eq [field_simps]:
   assumes "0 < c"
   shows "a < b / c \<longleftrightarrow> a * c < b"
 proof -
   from assms have "a < b / c \<longleftrightarrow> a * c < (b / c) * c"
     using mult_less_cancel_right [of a c "b / c"] by auto
   also have "... = (a*c < b)"
     by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma neg_less_divide_eq [field_simps]:
   assumes "c < 0"
   shows "a < b / c \<longleftrightarrow> b < a * c"
 proof -
   from assms have "a < b / c \<longleftrightarrow> (b / c) * c < a * c"
     using mult_less_cancel_right [of "b / c" c a] by auto
   also have "... \<longleftrightarrow> b < a * c"
     by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma neg_le_divide_eq [field_simps]:
   assumes "c < 0"
   shows "a \<le> b / c \<longleftrightarrow> b \<le> a * c"
 proof -
   from assms have "a \<le> b / c \<longleftrightarrow> (b / c) * c \<le> a * c"
     using mult_le_cancel_right [of "b * inverse c" c a] by (auto simp add: field_simps)
   also have "... \<longleftrightarrow> b \<le> a * c"
     by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma pos_divide_le_eq [field_simps]:
   assumes "0 < c"
   shows "b / c \<le> a \<longleftrightarrow> b \<le> a * c"
 proof -
   from assms have "b / c \<le> a \<longleftrightarrow> (b / c) * c \<le> a * c"
     using mult_le_cancel_right [of "b / c" c a] by auto
   also have "... \<longleftrightarrow> b \<le> a * c"
     by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma pos_divide_less_eq [field_simps]:
   assumes "0 < c"
   shows "b / c < a \<longleftrightarrow> b < a * c"
 proof -
   from assms have "b / c < a \<longleftrightarrow> (b / c) * c < a * c"
     using mult_less_cancel_right [of "b / c" c a] by auto
   also have "... \<longleftrightarrow> b < a * c"
     by (simp add: less_imp_not_eq2 [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma neg_divide_le_eq [field_simps]:
   assumes "c < 0"
   shows "b / c \<le> a \<longleftrightarrow> a * c \<le> b"
 proof -
   from assms have "b / c \<le> a \<longleftrightarrow> a * c \<le> (b / c) * c"
     using mult_le_cancel_right [of a c "b / c"] by auto
   also have "... \<longleftrightarrow> a * c \<le> b"
     by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 lemma neg_divide_less_eq [field_simps]:
   assumes "c < 0"
   shows "b / c < a \<longleftrightarrow> a * c < b"
 proof -
   from assms have "b / c < a \<longleftrightarrow> a * c < b / c * c"
     using mult_less_cancel_right [of a c "b / c"] by auto
   also have "... \<longleftrightarrow> a * c < b"
     by (simp add: less_imp_not_eq [OF assms] divide_inverse mult.assoc)
   finally show ?thesis .
 qed
 
 text\<open>The following \<open>field_simps\<close> rules are necessary, as minus is always moved atop of
 division but we want to get rid of division.\<close>
 
 lemma pos_le_minus_divide_eq [field_simps]: "0 < c \<Longrightarrow> a \<le> - (b / c) \<longleftrightarrow> a * c \<le> - b"
   unfolding minus_divide_left by (rule pos_le_divide_eq)
 
 lemma neg_le_minus_divide_eq [field_simps]: "c < 0 \<Longrightarrow> a \<le> - (b / c) \<longleftrightarrow> - b \<le> a * c"
   unfolding minus_divide_left by (rule neg_le_divide_eq)
 
 lemma pos_less_minus_divide_eq [field_simps]: "0 < c \<Longrightarrow> a < - (b / c) \<longleftrightarrow> a * c < - b"
   unfolding minus_divide_left by (rule pos_less_divide_eq)
 
 lemma neg_less_minus_divide_eq [field_simps]: "c < 0 \<Longrightarrow> a < - (b / c) \<longleftrightarrow> - b < a * c"
   unfolding minus_divide_left by (rule neg_less_divide_eq)
 
 lemma pos_minus_divide_less_eq [field_simps]: "0 < c \<Longrightarrow> - (b / c) < a \<longleftrightarrow> - b < a * c"
   unfolding minus_divide_left by (rule pos_divide_less_eq)
 
 lemma neg_minus_divide_less_eq [field_simps]: "c < 0 \<Longrightarrow> - (b / c) < a \<longleftrightarrow> a * c < - b"
   unfolding minus_divide_left by (rule neg_divide_less_eq)
 
 lemma pos_minus_divide_le_eq [field_simps]: "0 < c \<Longrightarrow> - (b / c) \<le> a \<longleftrightarrow> - b \<le> a * c"
   unfolding minus_divide_left by (rule pos_divide_le_eq)
 
 lemma neg_minus_divide_le_eq [field_simps]: "c < 0 \<Longrightarrow> - (b / c) \<le> a \<longleftrightarrow> a * c \<le> - b"
   unfolding minus_divide_left by (rule neg_divide_le_eq)
 
 lemma frac_less_eq:
   "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y < w / z \<longleftrightarrow> (x * z - w * y) / (y * z) < 0"
   by (subst less_iff_diff_less_0) (simp add: diff_frac_eq )
 
 lemma frac_le_eq:
   "y \<noteq> 0 \<Longrightarrow> z \<noteq> 0 \<Longrightarrow> x / y \<le> w / z \<longleftrightarrow> (x * z - w * y) / (y * z) \<le> 0"
   by (subst le_iff_diff_le_0) (simp add: diff_frac_eq )
 
 lemma divide_pos_pos[simp]:
   "0 < x \<Longrightarrow> 0 < y \<Longrightarrow> 0 < x / y"
 by(simp add:field_simps)
 
 lemma divide_nonneg_pos:
   "0 \<le> x \<Longrightarrow> 0 < y \<Longrightarrow> 0 \<le> x / y"
 by(simp add:field_simps)
 
 lemma divide_neg_pos:
   "x < 0 \<Longrightarrow> 0 < y \<Longrightarrow> x / y < 0"
   by(simp add:field_simps)
 
 lemma divide_nonpos_pos:
   "x \<le> 0 \<Longrightarrow> 0 < y \<Longrightarrow> x / y \<le> 0"
   by(simp add:field_simps)
 
 lemma divide_pos_neg:
   "0 < x \<Longrightarrow> y < 0 \<Longrightarrow> x / y < 0"
   by(simp add:field_simps)
 
 lemma divide_nonneg_neg:
   "0 \<le> x \<Longrightarrow> y < 0 \<Longrightarrow> x / y \<le> 0"
   by(simp add:field_simps)
 
 lemma divide_neg_neg:
   "x < 0 \<Longrightarrow> y < 0 \<Longrightarrow> 0 < x / y"
   by(simp add:field_simps)
 
 lemma divide_nonpos_neg:
   "x \<le> 0 \<Longrightarrow> y < 0 \<Longrightarrow> 0 \<le> x / y"
   by(simp add:field_simps)
 
 lemma divide_strict_right_mono:
   "\<lbrakk>a < b; 0 < c\<rbrakk> \<Longrightarrow> a / c < b / c"
   by (simp add: less_imp_not_eq2 divide_inverse mult_strict_right_mono
       positive_imp_inverse_positive)
 
 
 lemma divide_strict_right_mono_neg:
   assumes "b < a" "c < 0" shows "a / c < b / c"
 proof -
   have "b / - c < a / - c"
     by (rule divide_strict_right_mono) (use assms in auto)
   then show ?thesis
     by (simp add: less_imp_not_eq)
 qed
 
 text\<open>The last premise ensures that \<^term>\<open>a\<close> and \<^term>\<open>b\<close>
       have the same sign\<close>
 lemma divide_strict_left_mono:
   "\<lbrakk>b < a; 0 < c; 0 < a*b\<rbrakk> \<Longrightarrow> c / a < c / b"
   by (auto simp: field_simps zero_less_mult_iff mult_strict_right_mono)
 
 lemma divide_left_mono:
   "\<lbrakk>b \<le> a; 0 \<le> c; 0 < a*b\<rbrakk> \<Longrightarrow> c / a \<le> c / b"
   by (auto simp: field_simps zero_less_mult_iff mult_right_mono)
 
 lemma divide_strict_left_mono_neg:
   "\<lbrakk>a < b; c < 0; 0 < a*b\<rbrakk> \<Longrightarrow> c / a < c / b"
   by (auto simp: field_simps zero_less_mult_iff mult_strict_right_mono_neg)
 
 lemma mult_imp_div_pos_le: "0 < y \<Longrightarrow> x \<le> z * y \<Longrightarrow> x / y \<le> z"
 by (subst pos_divide_le_eq, assumption+)
 
 lemma mult_imp_le_div_pos: "0 < y \<Longrightarrow> z * y \<le> x \<Longrightarrow> z \<le> x / y"
 by(simp add:field_simps)
 
 lemma mult_imp_div_pos_less: "0 < y \<Longrightarrow> x < z * y \<Longrightarrow> x / y < z"
 by(simp add:field_simps)
 
 lemma mult_imp_less_div_pos: "0 < y \<Longrightarrow> z * y < x \<Longrightarrow> z < x / y"
 by(simp add:field_simps)
 
 lemma frac_le:
   assumes "0 \<le> y" "x \<le> y" "0 < w" "w \<le> z"
   shows "x / z \<le> y / w"
 proof (rule mult_imp_div_pos_le)
   show "z > 0"
     using assms by simp
   have "x \<le> y * z / w"
   proof (rule mult_imp_le_div_pos [OF \<open>0 < w\<close>])
     show "x * w \<le> y * z"
       using assms by (auto intro: mult_mono)
   qed
   also have "... = y / w * z"
     by simp
   finally show "x \<le> y / w * z" .
 qed
 
 lemma frac_less:
   assumes "0 \<le> x" "x < y" "0 < w" "w \<le> z"
   shows "x / z < y / w"
 proof (rule mult_imp_div_pos_less)
   show "z > 0"
     using assms by simp
   have "x < y * z / w"
   proof (rule mult_imp_less_div_pos [OF \<open>0 < w\<close>])
     show "x * w < y * z"
       using assms by (auto intro: mult_less_le_imp_less)
   qed
   also have "... = y / w * z"
     by simp
   finally show "x < y / w * z" .
 qed
 
 lemma frac_less2:
   assumes "0 < x" "x \<le> y" "0 < w" "w < z"
   shows "x / z < y / w"
 proof (rule mult_imp_div_pos_less)
   show "z > 0"
     using assms by simp
   show "x < y / w * z"
     using assms by (force intro: mult_imp_less_div_pos mult_le_less_imp_less)
 qed
 
 lemma less_half_sum: "a < b \<Longrightarrow> a < (a+b) / (1+1)"
   by (simp add: field_simps zero_less_two)
 
 lemma gt_half_sum: "a < b \<Longrightarrow> (a+b)/(1+1) < b"
   by (simp add: field_simps zero_less_two)
 
 subclass unbounded_dense_linorder
 proof
   fix x y :: 'a
   from less_add_one show "\<exists>y. x < y" ..
   from less_add_one have "x + (- 1) < (x + 1) + (- 1)" by (rule add_strict_right_mono)
   then have "x - 1 < x + 1 - 1" by simp
   then have "x - 1 < x" by (simp add: algebra_simps)
   then show "\<exists>y. y < x" ..
   show "x < y \<Longrightarrow> \<exists>z>x. z < y" by (blast intro!: less_half_sum gt_half_sum)
 qed
 
 subclass field_abs_sgn ..
 
 lemma inverse_sgn [simp]:
   "inverse (sgn a) = sgn a"
   by (cases a 0 rule: linorder_cases) simp_all
 
 lemma divide_sgn [simp]:
   "a / sgn b = a * sgn b"
   by (cases b 0 rule: linorder_cases) simp_all
 
 lemma nonzero_abs_inverse:
   "a \<noteq> 0 \<Longrightarrow> \<bar>inverse a\<bar> = inverse \<bar>a\<bar>"
   by (rule abs_inverse)
 
 lemma nonzero_abs_divide:
   "b \<noteq> 0 \<Longrightarrow> \<bar>a / b\<bar> = \<bar>a\<bar> / \<bar>b\<bar>"
   by (rule abs_divide)
 
 lemma field_le_epsilon:
   assumes e: "\<And>e. 0 < e \<Longrightarrow> x \<le> y + e"
   shows "x \<le> y"
 proof (rule dense_le)
   fix t assume "t < x"
   hence "0 < x - t" by (simp add: less_diff_eq)
   from e [OF this] have "x + 0 \<le> x + (y - t)" by (simp add: algebra_simps)
   then have "0 \<le> y - t" by (simp only: add_le_cancel_left)
   then show "t \<le> y" by (simp add: algebra_simps)
 qed
 
 lemma inverse_positive_iff_positive [simp]: "(0 < inverse a) = (0 < a)"
 proof (cases "a = 0")
   case False
   then show ?thesis
     by (blast intro: inverse_positive_imp_positive positive_imp_inverse_positive)
 qed auto
 
 lemma inverse_negative_iff_negative [simp]: "(inverse a < 0) = (a < 0)"
 proof (cases "a = 0")
   case False
   then show ?thesis
     by (blast intro: inverse_negative_imp_negative negative_imp_inverse_negative)
 qed auto
 
 lemma inverse_nonnegative_iff_nonnegative [simp]: "0 \<le> inverse a \<longleftrightarrow> 0 \<le> a"
   by (simp add: not_less [symmetric])
 
 lemma inverse_nonpositive_iff_nonpositive [simp]: "inverse a \<le> 0 \<longleftrightarrow> a \<le> 0"
   by (simp add: not_less [symmetric])
 
 lemma one_less_inverse_iff: "1 < inverse x \<longleftrightarrow> 0 < x \<and> x < 1"
   using less_trans[of 1 x 0 for x]
   by (cases x 0 rule: linorder_cases) (auto simp add: field_simps)
 
 lemma one_le_inverse_iff: "1 \<le> inverse x \<longleftrightarrow> 0 < x \<and> x \<le> 1"
 proof (cases "x = 1")
   case True then show ?thesis by simp
 next
   case False then have "inverse x \<noteq> 1" by simp
   then have "1 \<noteq> inverse x" by blast
   then have "1 \<le> inverse x \<longleftrightarrow> 1 < inverse x" by (simp add: le_less)
   with False show ?thesis by (auto simp add: one_less_inverse_iff)
 qed
 
 lemma inverse_less_1_iff: "inverse x < 1 \<longleftrightarrow> x \<le> 0 \<or> 1 < x"
   by (simp add: not_le [symmetric] one_le_inverse_iff)
 
 lemma inverse_le_1_iff: "inverse x \<le> 1 \<longleftrightarrow> x \<le> 0 \<or> 1 \<le> x"
   by (simp add: not_less [symmetric] one_less_inverse_iff)
 
 lemma [field_split_simps, divide_simps]:
   shows le_divide_eq: "a \<le> b / c \<longleftrightarrow> (if 0 < c then a * c \<le> b else if c < 0 then b \<le> a * c else a \<le> 0)"
     and divide_le_eq: "b / c \<le> a \<longleftrightarrow> (if 0 < c then b \<le> a * c else if c < 0 then a * c \<le> b else 0 \<le> a)"
     and less_divide_eq: "a < b / c \<longleftrightarrow> (if 0 < c then a * c < b else if c < 0 then b < a * c else a < 0)"
     and divide_less_eq: "b / c < a \<longleftrightarrow> (if 0 < c then b < a * c else if c < 0 then a * c < b else 0 < a)"
     and le_minus_divide_eq: "a \<le> - (b / c) \<longleftrightarrow> (if 0 < c then a * c \<le> - b else if c < 0 then - b \<le> a * c else a \<le> 0)"
     and minus_divide_le_eq: "- (b / c) \<le> a \<longleftrightarrow> (if 0 < c then - b \<le> a * c else if c < 0 then a * c \<le> - b else 0 \<le> a)"
     and less_minus_divide_eq: "a < - (b / c) \<longleftrightarrow> (if 0 < c then a * c < - b else if c < 0 then - b < a * c else  a < 0)"
     and minus_divide_less_eq: "- (b / c) < a \<longleftrightarrow> (if 0 < c then - b < a * c else if c < 0 then a * c < - b else 0 < a)"
   by (auto simp: field_simps not_less dest: order.antisym)
 
 text \<open>Division and Signs\<close>
 
 lemma
   shows zero_less_divide_iff: "0 < a / b \<longleftrightarrow> 0 < a \<and> 0 < b \<or> a < 0 \<and> b < 0"
     and divide_less_0_iff: "a / b < 0 \<longleftrightarrow> 0 < a \<and> b < 0 \<or> a < 0 \<and> 0 < b"
     and zero_le_divide_iff: "0 \<le> a / b \<longleftrightarrow> 0 \<le> a \<and> 0 \<le> b \<or> a \<le> 0 \<and> b \<le> 0"
     and divide_le_0_iff: "a / b \<le> 0 \<longleftrightarrow> 0 \<le> a \<and> b \<le> 0 \<or> a \<le> 0 \<and> 0 \<le> b"
   by (auto simp add: field_split_simps)
 
 text \<open>Division and the Number One\<close>
 
 text\<open>Simplify expressions equated with 1\<close>
 
 lemma zero_eq_1_divide_iff [simp]: "0 = 1 / a \<longleftrightarrow> a = 0"
   by (cases "a = 0") (auto simp: field_simps)
 
 lemma one_divide_eq_0_iff [simp]: "1 / a = 0 \<longleftrightarrow> a = 0"
   using zero_eq_1_divide_iff[of a] by simp
 
 text\<open>Simplify expressions such as \<open>0 < 1/x\<close> to \<open>0 < x\<close>\<close>
 
 lemma zero_le_divide_1_iff [simp]:
   "0 \<le> 1 / a \<longleftrightarrow> 0 \<le> a"
   by (simp add: zero_le_divide_iff)
 
 lemma zero_less_divide_1_iff [simp]:
   "0 < 1 / a \<longleftrightarrow> 0 < a"
   by (simp add: zero_less_divide_iff)
 
 lemma divide_le_0_1_iff [simp]:
   "1 / a \<le> 0 \<longleftrightarrow> a \<le> 0"
   by (simp add: divide_le_0_iff)
 
 lemma divide_less_0_1_iff [simp]:
   "1 / a < 0 \<longleftrightarrow> a < 0"
   by (simp add: divide_less_0_iff)
 
 lemma divide_right_mono:
   "\<lbrakk>a \<le> b; 0 \<le> c\<rbrakk> \<Longrightarrow> a/c \<le> b/c"
   by (force simp add: divide_strict_right_mono le_less)
 
 lemma divide_right_mono_neg: "a \<le> b \<Longrightarrow> c \<le> 0 \<Longrightarrow> b / c \<le> a / c"
   by (auto dest: divide_right_mono [of _ _ "- c"])
 
 lemma divide_left_mono_neg: "a \<le> b \<Longrightarrow> c \<le> 0 \<Longrightarrow> 0 < a * b \<Longrightarrow> c / a \<le> c / b"
   by (auto simp add: mult.commute dest: divide_left_mono [of _ _ "- c"])
 
 lemma inverse_le_iff: "inverse a \<le> inverse b \<longleftrightarrow> (0 < a * b \<longrightarrow> b \<le> a) \<and> (a * b \<le> 0 \<longrightarrow> a \<le> b)"
   by (cases a 0 b 0 rule: linorder_cases[case_product linorder_cases])
      (auto simp add: field_simps zero_less_mult_iff mult_le_0_iff)
 
 lemma inverse_less_iff: "inverse a < inverse b \<longleftrightarrow> (0 < a * b \<longrightarrow> b < a) \<and> (a * b \<le> 0 \<longrightarrow> a < b)"
   by (subst less_le) (auto simp: inverse_le_iff)
 
 lemma divide_le_cancel: "a / c \<le> b / c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
   by (simp add: divide_inverse mult_le_cancel_right)
 
 lemma divide_less_cancel: "a / c < b / c \<longleftrightarrow> (0 < c \<longrightarrow> a < b) \<and> (c < 0 \<longrightarrow> b < a) \<and> c \<noteq> 0"
   by (auto simp add: divide_inverse mult_less_cancel_right)
 
 text\<open>Simplify quotients that are compared with the value 1.\<close>
 
 lemma le_divide_eq_1:
   "(1 \<le> b / a) = ((0 < a \<and> a \<le> b) \<or> (a < 0 \<and> b \<le> a))"
   by (auto simp add: le_divide_eq)
 
 lemma divide_le_eq_1:
   "(b / a \<le> 1) = ((0 < a \<and> b \<le> a) \<or> (a < 0 \<and> a \<le> b) \<or> a=0)"
   by (auto simp add: divide_le_eq)
 
 lemma less_divide_eq_1:
   "(1 < b / a) = ((0 < a \<and> a < b) \<or> (a < 0 \<and> b < a))"
   by (auto simp add: less_divide_eq)
 
 lemma divide_less_eq_1:
   "(b / a < 1) = ((0 < a \<and> b < a) \<or> (a < 0 \<and> a < b) \<or> a=0)"
   by (auto simp add: divide_less_eq)
 
 lemma divide_nonneg_nonneg [simp]:
   "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> 0 \<le> x / y"
   by (auto simp add: field_split_simps)
 
 lemma divide_nonpos_nonpos:
   "x \<le> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> 0 \<le> x / y"
   by (auto simp add: field_split_simps)
 
 lemma divide_nonneg_nonpos:
   "0 \<le> x \<Longrightarrow> y \<le> 0 \<Longrightarrow> x / y \<le> 0"
   by (auto simp add: field_split_simps)
 
 lemma divide_nonpos_nonneg:
   "x \<le> 0 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x / y \<le> 0"
   by (auto simp add: field_split_simps)
 
 text \<open>Conditional Simplification Rules: No Case Splits\<close>
 
 lemma le_divide_eq_1_pos [simp]:
   "0 < a \<Longrightarrow> (1 \<le> b/a) = (a \<le> b)"
   by (auto simp add: le_divide_eq)
 
 lemma le_divide_eq_1_neg [simp]:
   "a < 0 \<Longrightarrow> (1 \<le> b/a) = (b \<le> a)"
   by (auto simp add: le_divide_eq)
 
 lemma divide_le_eq_1_pos [simp]:
   "0 < a \<Longrightarrow> (b/a \<le> 1) = (b \<le> a)"
   by (auto simp add: divide_le_eq)
 
 lemma divide_le_eq_1_neg [simp]:
   "a < 0 \<Longrightarrow> (b/a \<le> 1) = (a \<le> b)"
   by (auto simp add: divide_le_eq)
 
 lemma less_divide_eq_1_pos [simp]:
   "0 < a \<Longrightarrow> (1 < b/a) = (a < b)"
   by (auto simp add: less_divide_eq)
 
 lemma less_divide_eq_1_neg [simp]:
   "a < 0 \<Longrightarrow> (1 < b/a) = (b < a)"
   by (auto simp add: less_divide_eq)
 
 lemma divide_less_eq_1_pos [simp]:
   "0 < a \<Longrightarrow> (b/a < 1) = (b < a)"
   by (auto simp add: divide_less_eq)
 
 lemma divide_less_eq_1_neg [simp]:
   "a < 0 \<Longrightarrow> b/a < 1 \<longleftrightarrow> a < b"
   by (auto simp add: divide_less_eq)
 
 lemma eq_divide_eq_1 [simp]:
   "(1 = b/a) = ((a \<noteq> 0 \<and> a = b))"
   by (auto simp add: eq_divide_eq)
 
 lemma divide_eq_eq_1 [simp]:
   "(b/a = 1) = ((a \<noteq> 0 \<and> a = b))"
   by (auto simp add: divide_eq_eq)
 
 lemma abs_div_pos: "0 < y \<Longrightarrow> \<bar>x\<bar> / y = \<bar>x / y\<bar>"
   by (simp add: order_less_imp_le)
 
 lemma zero_le_divide_abs_iff [simp]: "(0 \<le> a / \<bar>b\<bar>) = (0 \<le> a \<or> b = 0)"
   by (auto simp: zero_le_divide_iff)
 
 lemma divide_le_0_abs_iff [simp]: "(a / \<bar>b\<bar> \<le> 0) = (a \<le> 0 \<or> b = 0)"
   by (auto simp: divide_le_0_iff)
 
 lemma field_le_mult_one_interval:
   assumes *: "\<And>z. \<lbrakk> 0 < z ; z < 1 \<rbrakk> \<Longrightarrow> z * x \<le> y"
   shows "x \<le> y"
 proof (cases "0 < x")
   assume "0 < x"
   thus ?thesis
     using dense_le_bounded[of 0 1 "y/x"] *
     unfolding le_divide_eq if_P[OF \<open>0 < x\<close>] by simp
 next
   assume "\<not>0 < x" hence "x \<le> 0" by simp
   obtain s::'a where s: "0 < s" "s < 1" using dense[of 0 "1::'a"] by auto
   hence "x \<le> s * x" using mult_le_cancel_right[of 1 x s] \<open>x \<le> 0\<close> by auto
   also note *[OF s]
   finally show ?thesis .
 qed
 
 text\<open>For creating values between \<^term>\<open>u\<close> and \<^term>\<open>v\<close>.\<close>
 lemma scaling_mono:
   assumes "u \<le> v" "0 \<le> r" "r \<le> s"
   shows "u + r * (v - u) / s \<le> v"
 proof -
   have "r/s \<le> 1" using assms
     using divide_le_eq_1 by fastforce
   moreover have "0 \<le> v - u"
     using assms by simp
   ultimately have "(r/s) * (v - u) \<le> 1 * (v - u)"
     by (rule mult_right_mono)
   then show ?thesis
     by (simp add: field_simps)
 qed
 
 end
 
 text \<open>Min/max Simplification Rules\<close>
 
 lemma min_mult_distrib_left:
   fixes x::"'a::linordered_idom" 
   shows "p * min x y = (if 0 \<le> p then min (p*x) (p*y) else max (p*x) (p*y))"
 by (auto simp add: min_def max_def mult_le_cancel_left)
 
 lemma min_mult_distrib_right:
   fixes x::"'a::linordered_idom" 
   shows "min x y * p = (if 0 \<le> p then min (x*p) (y*p) else max (x*p) (y*p))"
 by (auto simp add: min_def max_def mult_le_cancel_right)
 
 lemma min_divide_distrib_right:
   fixes x::"'a::linordered_field" 
   shows "min x y / p = (if 0 \<le> p then min (x/p) (y/p) else max (x/p) (y/p))"
 by (simp add: min_mult_distrib_right divide_inverse)
 
 lemma max_mult_distrib_left:
   fixes x::"'a::linordered_idom" 
   shows "p * max x y = (if 0 \<le> p then max (p*x) (p*y) else min (p*x) (p*y))"
 by (auto simp add: min_def max_def mult_le_cancel_left)
 
 lemma max_mult_distrib_right:
   fixes x::"'a::linordered_idom" 
   shows "max x y * p = (if 0 \<le> p then max (x*p) (y*p) else min (x*p) (y*p))"
 by (auto simp add: min_def max_def mult_le_cancel_right)
 
 lemma max_divide_distrib_right:
   fixes x::"'a::linordered_field" 
   shows "max x y / p = (if 0 \<le> p then max (x/p) (y/p) else min (x/p) (y/p))"
 by (simp add: max_mult_distrib_right divide_inverse)
 
 hide_fact (open) field_inverse field_divide_inverse field_inverse_zero
 
 code_identifier
   code_module Fields \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 end
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,2606 +1,2607 @@
 (*  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_inverse_image_gen:
   assumes "finite A" "inj_on f D"
   shows "finite {j\<in>D. f j \<in> A}"
   using finite_vimage_IntI [OF assms]
   by (simp add: Collect_conj_eq inf_commute vimage_def)
 
 lemma finite_inverse_image:
   assumes "finite A" "inj f"
   shows "finite {j. f j \<in> A}"
   using finite_inverse_image_gen [OF assms] by simp
 
 lemma finite_Collect_bex [simp]:
   assumes "finite A"
   shows "finite {x. \<exists>y\<in>A. Q x y} \<longleftrightarrow> (\<forall>y\<in>A. finite {x. Q x y})"
 proof -
   have "{x. \<exists>y\<in>A. Q x y} = (\<Union>y\<in>A. {x. Q x y})" by auto
   with assms show ?thesis by simp
 qed
 
 lemma finite_Collect_bounded_ex [simp]:
   assumes "finite {y. P y}"
   shows "finite {x. \<exists>y. P y \<and> Q x y} \<longleftrightarrow> (\<forall>y. P y \<longrightarrow> finite {x. Q x y})"
 proof -
   have "{x. \<exists>y. P y \<and> Q x y} = (\<Union>y\<in>{y. P y}. {x. Q x y})"
     by auto
   with assms show ?thesis
     by simp
 qed
 
 lemma finite_Plus: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A <+> B)"
   by (simp add: Plus_def)
 
 lemma finite_PlusD:
   fixes A :: "'a set" and B :: "'b set"
   assumes fin: "finite (A <+> B)"
   shows "finite A" "finite B"
 proof -
   have "Inl ` A \<subseteq> A <+> B"
     by auto
   then have "finite (Inl ` A :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite A"
     by (rule finite_imageD) (auto intro: inj_onI)
 next
   have "Inr ` B \<subseteq> A <+> B"
     by auto
   then have "finite (Inr ` B :: ('a + 'b) set)"
     using fin by (rule finite_subset)
   then show "finite B"
     by (rule finite_imageD) (auto intro: inj_onI)
 qed
 
 lemma finite_Plus_iff [simp]: "finite (A <+> B) \<longleftrightarrow> finite A \<and> finite B"
   by (auto intro: finite_PlusD finite_Plus)
 
 lemma finite_Plus_UNIV_iff [simp]:
   "finite (UNIV :: ('a + 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   by (subst UNIV_Plus_UNIV [symmetric]) (rule finite_Plus_iff)
 
 lemma finite_SigmaI [simp, intro]:
   "finite A \<Longrightarrow> (\<And>a. a\<in>A \<Longrightarrow> finite (B a)) \<Longrightarrow> finite (SIGMA a:A. B a)"
   unfolding Sigma_def by blast
 
 lemma finite_SigmaI2:
   assumes "finite {x\<in>A. B x \<noteq> {}}"
   and "\<And>a. a \<in> A \<Longrightarrow> finite (B a)"
   shows "finite (Sigma A B)"
 proof -
   from assms have "finite (Sigma {x\<in>A. B x \<noteq> {}} B)"
     by auto
   also have "Sigma {x:A. B x \<noteq> {}} B = Sigma A B"
     by auto
   finally show ?thesis .
 qed
 
 lemma finite_cartesian_product: "finite A \<Longrightarrow> finite B \<Longrightarrow> finite (A \<times> B)"
   by (rule finite_SigmaI)
 
 lemma finite_Prod_UNIV:
   "finite (UNIV :: 'a set) \<Longrightarrow> finite (UNIV :: 'b set) \<Longrightarrow> finite (UNIV :: ('a \<times> 'b) set)"
   by (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product)
 
 lemma finite_cartesian_productD1:
   assumes "finite (A \<times> B)" and "B \<noteq> {}"
   shows "finite A"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "fst ` (A \<times> B) = fst ` f ` {i::nat. i < n}"
     by simp
   with \<open>B \<noteq> {}\<close> have "A = (fst \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. A = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_productD2:
   assumes "finite (A \<times> B)" and "A \<noteq> {}"
   shows "finite B"
 proof -
   from assms obtain n f where "A \<times> B = f ` {i::nat. i < n}"
     by (auto simp add: finite_conv_nat_seg_image)
   then have "snd ` (A \<times> B) = snd ` f ` {i::nat. i < n}"
     by simp
   with \<open>A \<noteq> {}\<close> have "B = (snd \<circ> f) ` {i::nat. i < n}"
     by (simp add: image_comp)
   then have "\<exists>n f. B = f ` {i::nat. i < n}"
     by blast
   then show ?thesis
     by (auto simp add: finite_conv_nat_seg_image)
 qed
 
 lemma finite_cartesian_product_iff:
   "finite (A \<times> B) \<longleftrightarrow> (A = {} \<or> B = {} \<or> (finite A \<and> finite B))"
   by (auto dest: finite_cartesian_productD1 finite_cartesian_productD2 finite_cartesian_product)
 
 lemma finite_prod:
   "finite (UNIV :: ('a \<times> 'b) set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
   using finite_cartesian_product_iff[of UNIV UNIV] by simp
 
 lemma finite_Pow_iff [iff]: "finite (Pow A) \<longleftrightarrow> finite A"
 proof
   assume "finite (Pow A)"
   then have "finite ((\<lambda>x. {x}) ` A)"
     by (blast intro: finite_subset)  (* somewhat slow *)
   then show "finite A"
     by (rule finite_imageD [unfolded inj_on_def]) simp
 next
   assume "finite A"
   then show "finite (Pow A)"
     by induct (simp_all add: Pow_insert)
 qed
 
 corollary finite_Collect_subsets [simp, intro]: "finite A \<Longrightarrow> finite {B. B \<subseteq> A}"
   by (simp add: Pow_def [symmetric])
 
 lemma finite_set: "finite (UNIV :: 'a set set) \<longleftrightarrow> finite (UNIV :: 'a set)"
   by (simp only: finite_Pow_iff Pow_UNIV[symmetric])
 
 lemma finite_UnionD: "finite (\<Union>A) \<Longrightarrow> finite A"
   by (blast intro: finite_subset [OF subset_Pow_Union])
 
 lemma finite_bind:
   assumes "finite S"
   assumes "\<forall>x \<in> S. finite (f x)"
   shows "finite (Set.bind S f)"
 using assms by (simp add: bind_UNION)
 
 lemma finite_filter [simp]: "finite S \<Longrightarrow> finite (Set.filter P S)"
 unfolding Set.filter_def by simp
 
 lemma finite_set_of_finite_funs:
   assumes "finite A" "finite B"
   shows "finite {f. \<forall>x. (x \<in> A \<longrightarrow> f x \<in> B) \<and> (x \<notin> A \<longrightarrow> f x = d)}" (is "finite ?S")
 proof -
   let ?F = "\<lambda>f. {(a,b). a \<in> A \<and> b = f a}"
   have "?F ` ?S \<subseteq> Pow(A \<times> B)"
     by auto
   from finite_subset[OF this] assms have 1: "finite (?F ` ?S)"
     by simp
   have 2: "inj_on ?F ?S"
     by (fastforce simp add: inj_on_def set_eq_iff fun_eq_iff)  (* somewhat slow *)
   show ?thesis
     by (rule finite_imageD [OF 1 2])
 qed
 
 lemma not_finite_existsD:
   assumes "\<not> finite {a. P a}"
   shows "\<exists>a. P a"
 proof (rule classical)
   assume "\<not> ?thesis"
   with assms show ?thesis by auto
 qed
 
 
 subsection \<open>Further induction rules on finite sets\<close>
 
 lemma finite_ne_induct [case_names singleton insert, consumes 2]:
   assumes "finite F" and "F \<noteq> {}"
   assumes "\<And>x. P {x}"
     and "\<And>x F. finite F \<Longrightarrow> F \<noteq> {} \<Longrightarrow> x \<notin> F \<Longrightarrow> P F  \<Longrightarrow> P (insert x F)"
   shows "P F"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case by cases auto
 qed
 
 lemma finite_subset_induct [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. finite F \<Longrightarrow> a \<in> A \<Longrightarrow> a \<notin> F \<Longrightarrow> P F \<Longrightarrow> P (insert a F)"
   shows "P F"
   using \<open>finite F\<close> \<open>F \<subseteq> A\<close>
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
   qed
 qed
 
 lemma finite_empty_induct:
   assumes "finite A"
     and "P A"
     and remove: "\<And>a A. finite A \<Longrightarrow> a \<in> A \<Longrightarrow> P A \<Longrightarrow> P (A - {a})"
   shows "P {}"
 proof -
   have "P (A - B)" if "B \<subseteq> A" for B :: "'a set"
   proof -
     from \<open>finite A\<close> that have "finite B"
       by (rule rev_finite_subset)
     from this \<open>B \<subseteq> A\<close> show "P (A - B)"
     proof induct
       case empty
       from \<open>P A\<close> show ?case by simp
     next
       case (insert b B)
       have "P (A - B - {b})"
       proof (rule remove)
         from \<open>finite A\<close> show "finite (A - B)"
           by induct auto
         from insert show "b \<in> A - B"
           by simp
         from insert show "P (A - B)"
           by simp
       qed
       also have "A - B - {b} = A - insert b B"
         by (rule Diff_insert [symmetric])
       finally show ?case .
     qed
   qed
   then have "P (A - A)" by blast
   then show ?thesis by simp
 qed
 
 lemma finite_update_induct [consumes 1, case_names const update]:
   assumes finite: "finite {a. f a \<noteq> c}"
     and const: "P (\<lambda>a. c)"
     and update: "\<And>a b f. finite {a. f a \<noteq> c} \<Longrightarrow> f a = c \<Longrightarrow> b \<noteq> c \<Longrightarrow> P f \<Longrightarrow> P (f(a := b))"
   shows "P f"
   using finite
 proof (induct "{a. f a \<noteq> c}" arbitrary: f)
   case empty
   with const show ?case by simp
 next
   case (insert a A)
   then have "A = {a'. (f(a := c)) a' \<noteq> c}" and "f a \<noteq> c"
     by auto
   with \<open>finite A\<close> have "finite {a'. (f(a := c)) a' \<noteq> c}"
     by simp
   have "(f(a := c)) a = c"
     by simp
   from insert \<open>A = {a'. (f(a := c)) a' \<noteq> c}\<close> have "P (f(a := c))"
     by simp
   with \<open>finite {a'. (f(a := c)) a' \<noteq> c}\<close> \<open>(f(a := c)) a = c\<close> \<open>f a \<noteq> c\<close>
   have "P ((f(a := c))(a := f a))"
     by (rule update)
   then show ?case by simp
 qed
 
 lemma finite_subset_induct' [consumes 2, case_names empty insert]:
   assumes "finite F" and "F \<subseteq> A"
     and empty: "P {}"
     and insert: "\<And>a F. \<lbrakk>finite F; a \<in> A; F \<subseteq> A; a \<notin> F; P F \<rbrakk> \<Longrightarrow> P (insert a F)"
   shows "P F"
   using assms(1,2)
 proof induct
   show "P {}" by fact
 next
   fix x F
   assume "finite F" and "x \<notin> F" and
     P: "F \<subseteq> A \<Longrightarrow> P F" and i: "insert x F \<subseteq> A"
   show "P (insert x F)"
   proof (rule insert)
     from i show "x \<in> A" by blast
     from i have "F \<subseteq> A" by blast
     with P show "P F" .
     show "finite F" by fact
     show "x \<notin> F" by fact
     show "F \<subseteq> A" by fact
   qed
 qed
 
 
 subsection \<open>Class \<open>finite\<close>\<close>
 
 class finite =
   assumes finite_UNIV: "finite (UNIV :: 'a set)"
 begin
 
 lemma finite [simp]: "finite (A :: 'a set)"
   by (rule subset_UNIV finite_UNIV finite_subset)+
 
 lemma finite_code [code]: "finite (A :: 'a set) \<longleftrightarrow> True"
   by simp
 
 end
 
 instance prod :: (finite, finite) finite
   by standard (simp only: UNIV_Times_UNIV [symmetric] finite_cartesian_product finite)
 
 lemma inj_graph: "inj (\<lambda>f. {(x, y). y = f x})"
   by (rule inj_onI) (auto simp add: set_eq_iff fun_eq_iff)
 
 instance "fun" :: (finite, finite) finite
 proof
   show "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   proof (rule finite_imageD)
     let ?graph = "\<lambda>f::'a \<Rightarrow> 'b. {(x, y). y = f x}"
     have "range ?graph \<subseteq> Pow UNIV"
       by simp
     moreover have "finite (Pow (UNIV :: ('a * 'b) set))"
       by (simp only: finite_Pow_iff finite)
     ultimately show "finite (range ?graph)"
       by (rule finite_subset)
     show "inj ?graph"
       by (rule inj_graph)
   qed
 qed
 
 instance bool :: finite
   by standard (simp add: UNIV_bool)
 
 instance set :: (finite) finite
   by standard (simp only: Pow_UNIV [symmetric] finite_Pow_iff finite)
 
 instance unit :: finite
   by standard (simp add: UNIV_unit)
 
 instance sum :: (finite, finite) finite
   by standard (simp only: UNIV_Plus_UNIV [symmetric] finite_Plus finite)
 
 
 subsection \<open>A basic fold functional for finite sets\<close>
 
 text \<open>
   The intended behaviour is \<open>fold f z {x\<^sub>1, \<dots>, x\<^sub>n} = f x\<^sub>1 (\<dots> (f x\<^sub>n z)\<dots>)\<close>
   if \<open>f\<close> is ``left-commutative''.
   The commutativity requirement is relativised to the carrier set \<open>S\<close>:
 \<close>
 
 locale comp_fun_commute_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma fun_left_comm: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y (f x z) = f x (f y z)"
   using comp_fun_commute_on by (simp add: fun_eq_iff)
 
 lemma commute_left_comp: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y \<circ> (f x \<circ> g) = f x \<circ> (f y \<circ> g)"
   by (simp add: o_assoc comp_fun_commute_on)
 
 end
 
 inductive fold_graph :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> bool"
   for f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: 'b
   where
     emptyI [intro]: "fold_graph f z {} z"
   | insertI [intro]: "x \<notin> A \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold_graph f z (insert x A) (f x y)"
 
 inductive_cases empty_fold_graphE [elim!]: "fold_graph f z {} x"
 
 lemma fold_graph_closed_lemma:
   "fold_graph f z A x \<and> x \<in> B"
   if "fold_graph g z A x"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
     "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
     "z \<in> B"
   using that(1-3)
 proof (induction rule: fold_graph.induct)
   case (insertI x A y)
   have "fold_graph f z A y" "y \<in> B"
     unfolding atomize_conj
     by (rule insertI.IH) (auto intro: insertI.prems)
   then have "g x y \<in> B" and f_eq: "f x y = g x y"
     by (auto simp: insertI.prems)
   moreover have "fold_graph f z (insert x A) (f x y)"
     by (rule fold_graph.insertI; fact)
   ultimately
   show ?case
     by (simp add: f_eq)
 qed (auto intro!: that)
 
 lemma fold_graph_closed_eq:
   "fold_graph f z A = fold_graph g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   using fold_graph_closed_lemma[of f z A _ B g] fold_graph_closed_lemma[of g z A _ B f] that
   by auto
 
 definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a set \<Rightarrow> 'b"
   where "fold f z A = (if finite A then (THE y. fold_graph f z A y) else z)"
 
 lemma fold_closed_eq: "fold f z A = fold g z A"
   if "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> f a b = g a b"
      "\<And>a b. a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> g a b \<in> B"
      "z \<in> B"
   unfolding Finite_Set.fold_def
   by (subst fold_graph_closed_eq[where B=B and g=g]) (auto simp: that)
 
 text \<open>
   A tempting alternative for the definition is
   \<^term>\<open>if finite A then THE y. fold_graph f z A y else e\<close>.
   It allows the removal of finiteness assumptions from the theorems
   \<open>fold_comm\<close>, \<open>fold_reindex\<close> and \<open>fold_distrib\<close>.
   The proofs become ugly. It is not worth the effort. (???)
 \<close>
 
 lemma finite_imp_fold_graph: "finite A \<Longrightarrow> \<exists>x. fold_graph f z A x"
   by (induct rule: finite_induct) auto
 
 
 subsubsection \<open>From \<^const>\<open>fold_graph\<close> to \<^term>\<open>fold\<close>\<close>
 
 context comp_fun_commute_on
 begin
 
 lemma fold_graph_finite:
   assumes "fold_graph f z A y"
   shows "finite A"
   using assms by induct simp_all
 
 lemma fold_graph_insertE_aux:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A y" "a \<in> A"
   shows "\<exists>y'. y = f a y' \<and> fold_graph f z (A - {a}) y'"
   using assms(2-,1)
 proof (induct set: fold_graph)
   case emptyI
   then show ?case by simp
 next
   case (insertI x A y)
   show ?case
   proof (cases "x = a")
     case True
     with insertI show ?thesis by auto
   next
     case False
     then obtain y' where y: "y = f a y'" and y': "fold_graph f z (A - {a}) y'"
       using insertI by auto
     from insertI have "x \<in> S" "a \<in> S" by auto
     then have "f x y = f a (f x y')"
       unfolding y by (intro fun_left_comm; simp)
     moreover have "fold_graph f z (insert x A - {a}) (f x y')"
       using y' and \<open>x \<noteq> a\<close> and \<open>x \<notin> A\<close>
       by (simp add: insert_Diff_if fold_graph.insertI)
     ultimately show ?thesis
       by fast
   qed
 qed
 
 lemma fold_graph_insertE:
   assumes "insert x A \<subseteq> S"
   assumes "fold_graph f z (insert x A) v" and "x \<notin> A"
   obtains y where "v = f x y" and "fold_graph f z A y"
   using assms by (auto dest: fold_graph_insertE_aux[OF \<open>insert x A \<subseteq> S\<close> _ insertI1])
 
 lemma fold_graph_determ:
   assumes "A \<subseteq> S"
   assumes "fold_graph f z A x" "fold_graph f z A y"
   shows "y = x"
   using assms(2-,1)
 proof (induct arbitrary: y set: fold_graph)
   case emptyI
   then show ?case by fast
 next
   case (insertI x A y v)
   from \<open>insert x A \<subseteq> S\<close> and \<open>fold_graph f z (insert x A) v\<close> and \<open>x \<notin> A\<close>
   obtain y' where "v = f x y'" and "fold_graph f z A y'"
     by (rule fold_graph_insertE)
   from \<open>fold_graph f z A y'\<close> insertI have "y' = y"
     by simp
   with \<open>v = f x y'\<close> show "v = f x y"
     by simp
 qed
 
 lemma fold_equality: "A \<subseteq> S \<Longrightarrow> fold_graph f z A y \<Longrightarrow> fold f z A = y"
   by (cases "finite A") (auto simp add: fold_def intro: fold_graph_determ dest: fold_graph_finite)
 
 lemma fold_graph_fold:
   assumes "A \<subseteq> S"
   assumes "finite A"
   shows "fold_graph f z A (fold f z A)"
 proof -
   from \<open>finite A\<close> have "\<exists>x. fold_graph f z A x"
     by (rule finite_imp_fold_graph)
   moreover note fold_graph_determ[OF \<open>A \<subseteq> S\<close>]
   ultimately have "\<exists>!x. fold_graph f z A x"
     by (rule ex_ex1I)
   then have "fold_graph f z A (The (fold_graph f z A))"
     by (rule theI')
   with assms show ?thesis
     by (simp add: fold_def)
 qed
 
 text \<open>The base case for \<open>fold\<close>:\<close>
 
 lemma (in -) fold_infinite [simp]: "\<not> finite A \<Longrightarrow> fold f z A = z"
   by (auto simp: fold_def)
 
 lemma (in -) fold_empty [simp]: "fold f z {} = z"
   by (auto simp: fold_def)
 
 text \<open>The various recursion equations for \<^const>\<open>fold\<close>:\<close>
 
 lemma fold_insert [simp]:
   assumes "insert x A \<subseteq> S"
   assumes "finite A" and "x \<notin> A"
   shows "fold f z (insert x A) = f x (fold f z A)"
 proof (rule fold_equality[OF \<open>insert x A \<subseteq> S\<close>])
   fix z
   from \<open>insert x A \<subseteq> S\<close> \<open>finite A\<close> have "fold_graph f z A (fold f z A)"
     by (blast intro: fold_graph_fold)
   with \<open>x \<notin> A\<close> have "fold_graph f z (insert x A) (f x (fold f z A))"
     by (rule fold_graph.insertI)
   then show "fold_graph f z (insert x A) (f x (fold f z A))"
     by simp
 qed
 
 declare (in -) empty_fold_graphE [rule del] fold_graph.intros [rule del]
   \<comment> \<open>No more proofs involve these.\<close>
 
 lemma fold_fun_left_comm:
   assumes "insert x A \<subseteq> S" "finite A" 
   shows "f x (fold f z A) = fold f (f x z) A"
   using assms(2,1)
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert y F)
   then have "fold f (f x z) (insert y F) = f y (fold f (f x z) F)"
     by simp
   also have "\<dots> = f x (f y (fold f z F))"
     using insert by (simp add: fun_left_comm[where ?y=x])
   also have "\<dots> = f x (fold f z (insert y F))"
   proof -
     from insert have "insert y F \<subseteq> S" by simp
     from fold_insert[OF this] insert show ?thesis by simp
   qed
   finally show ?case ..
 qed
 
 lemma fold_insert2:
   "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> fold f z (insert x A)  = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 lemma fold_rec:
   assumes "A \<subseteq> S"
   assumes "finite A" and "x \<in> A"
   shows "fold f z A = f x (fold f z (A - {x}))"
 proof -
   have A: "A = insert x (A - {x})"
     using \<open>x \<in> A\<close> by blast
   then have "fold f z A = fold f z (insert x (A - {x}))"
     by simp
   also have "\<dots> = f x (fold f z (A - {x}))"
     by (rule fold_insert) (use assms in \<open>auto\<close>)
   finally show ?thesis .
 qed
 
 lemma fold_insert_remove:
   assumes "insert x A \<subseteq> S"
   assumes "finite A"
   shows "fold f z (insert x A) = f x (fold f z (A - {x}))"
 proof -
   from \<open>finite A\<close> have "finite (insert x A)"
     by auto
   moreover have "x \<in> insert x A"
     by auto
   ultimately have "fold f z (insert x A) = f x (fold f z (insert x A - {x}))"
     using \<open>insert x A \<subseteq> S\<close> by (blast intro: fold_rec)
   then show ?thesis
     by simp
 qed
 
 lemma fold_set_union_disj:
   assumes "A \<subseteq> S" "B \<subseteq> S"
   assumes "finite A" "finite B" "A \<inter> B = {}"
   shows "Finite_Set.fold f z (A \<union> B) = Finite_Set.fold f (Finite_Set.fold f z A) B"
   using \<open>finite B\<close> assms(1,2,3,5)
 proof induct
   case (insert x F)
   have "fold f z (A \<union> insert x F) = f x (fold f (fold f z A) F)"
     using insert by auto
   also have "\<dots> = fold f (fold f z A) (insert x F)"
     using insert by (blast intro: fold_insert[symmetric])
   finally show ?case .
 qed simp
 
 
 end
 
 text \<open>Other properties of \<^const>\<open>fold\<close>:\<close>
 
 lemma fold_graph_image:
   assumes "inj_on g A"
   shows "fold_graph f z (g ` A) = fold_graph (f \<circ> g) z A"
 proof
   fix w
   show "fold_graph f z (g ` A) w = fold_graph (f o g) z A w"
   proof
     assume "fold_graph f z (g ` A) w"
     then show "fold_graph (f \<circ> g) z A w"
       using assms
     proof (induct "g ` A" w arbitrary: A)
       case emptyI
       then show ?case by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r B)
       from \<open>inj_on g B\<close> \<open>x \<notin> A\<close> \<open>insert x A = image g B\<close> obtain x' A'
         where "x' \<notin> A'" and [simp]: "B = insert x' A'" "x = g x'" "A = g ` A'"
         by (rule inj_img_insertE)
       from insertI.prems have "fold_graph (f \<circ> g) z A' r"
         by (auto intro: insertI.hyps)
       with \<open>x' \<notin> A'\<close> have "fold_graph (f \<circ> g) z (insert x' A') ((f \<circ> g) x' r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   next
     assume "fold_graph (f \<circ> g) z A w"
     then show "fold_graph f z (g ` A) w"
       using assms
     proof induct
       case emptyI
       then show ?case
         by (auto intro: fold_graph.emptyI)
     next
       case (insertI x A r)
       from \<open>x \<notin> A\<close> insertI.prems have "g x \<notin> g ` A"
         by auto
       moreover from insertI have "fold_graph f z (g ` A) r"
         by simp
       ultimately have "fold_graph f z (insert (g x) (g ` A)) (f (g x) r)"
         by (rule fold_graph.insertI)
       then show ?case
         by simp
     qed
   qed
 qed
 
 lemma fold_image:
   assumes "inj_on g A"
   shows "fold f z (g ` A) = fold (f \<circ> g) z A"
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by (auto dest: finite_imageD simp add: fold_def)
 next
   case True
   then show ?thesis
     by (auto simp add: fold_def fold_graph_image[OF assms])
 qed
 
 lemma fold_cong:
   assumes "comp_fun_commute_on S f" "comp_fun_commute_on S g"
     and "A \<subseteq> S" "finite A"
     and cong: "\<And>x. x \<in> A \<Longrightarrow> f x = g x"
     and "s = t" and "A = B"
   shows "fold f s A = fold g t B"
 proof -
   have "fold f s A = fold g s A"
     using \<open>finite A\<close> \<open>A \<subseteq> S\<close> cong
   proof (induct A)
     case empty
     then show ?case by simp
   next
     case insert
     interpret f: comp_fun_commute_on S f by (fact \<open>comp_fun_commute_on S f\<close>)
     interpret g: comp_fun_commute_on S g by (fact \<open>comp_fun_commute_on S g\<close>)
     from insert show ?case by simp
   qed
   with assms show ?thesis by simp
 qed
 
 
 text \<open>A simplified version for idempotent functions:\<close>
 
 locale comp_fun_idem_on = comp_fun_commute_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 lemma fun_left_idem: "x \<in> S \<Longrightarrow> f x (f x z) = f x z"
   using comp_fun_idem_on by (simp add: fun_eq_iff)
 
 lemma fold_insert_idem:
   assumes "insert x A \<subseteq> S"
   assumes fin: "finite A"
   shows "fold f z (insert x A)  = f x (fold f z A)"
 proof cases
   assume "x \<in> A"
   then obtain B where "A = insert x B" and "x \<notin> B"
     by (rule set_insert)
   then show ?thesis
     using assms by (simp add: comp_fun_idem_on fun_left_idem)
 next
   assume "x \<notin> A"
   then show ?thesis
     using assms by auto
 qed
 
 declare fold_insert [simp del] fold_insert_idem [simp]
 
 lemma fold_insert_idem2: "insert x A \<subseteq> S \<Longrightarrow> finite A \<Longrightarrow> fold f z (insert x A) = fold f (f x z) A"
   by (simp add: fold_fun_left_comm)
 
 end
 
 
 subsubsection \<open>Liftings to \<open>comp_fun_commute_on\<close> etc.\<close>
                    
 lemma (in comp_fun_commute_on) comp_comp_fun_commute_on:
   "range g \<subseteq> S \<Longrightarrow> comp_fun_commute_on R (f \<circ> g)"
   by standard (force intro: comp_fun_commute_on)
 
 lemma (in comp_fun_idem_on) comp_comp_fun_idem_on:
   assumes "range g \<subseteq> S"
   shows "comp_fun_idem_on R (f \<circ> g)"
 proof
   interpret f_g: comp_fun_commute_on R "f o g"
     by (fact comp_comp_fun_commute_on[OF \<open>range g \<subseteq> S\<close>])
   show "x \<in> R \<Longrightarrow> y \<in> R \<Longrightarrow> (f \<circ> g) y \<circ> (f \<circ> g) x = (f \<circ> g) x \<circ> (f \<circ> g) y" for x y
     by (fact f_g.comp_fun_commute_on)
 qed (use \<open>range g \<subseteq> S\<close> in \<open>force intro: comp_fun_idem_on\<close>)
 
 lemma (in comp_fun_commute_on) comp_fun_commute_on_funpow:
   "comp_fun_commute_on S (\<lambda>x. f x ^^ g x)"
 proof
   fix x y assume "x \<in> S" "y \<in> S"
   show "f y ^^ g y \<circ> f x ^^ g x = f x ^^ g x \<circ> f y ^^ g y"
   proof (cases "x = y")
     case True
     then show ?thesis by simp
   next
     case False
     show ?thesis
     proof (induct "g x" arbitrary: g)
       case 0
       then show ?case by simp
     next
       case (Suc n g)
       have hyp1: "f y ^^ g y \<circ> f x = f x \<circ> f y ^^ g y"
       proof (induct "g y" arbitrary: g)
         case 0
         then show ?case by simp
       next
         case (Suc n g)
         define h where "h z = g z - 1" for z
         with Suc have "n = h y"
           by simp
         with Suc have hyp: "f y ^^ h y \<circ> f x = f x \<circ> f y ^^ h y"
           by auto
         from Suc h_def have "g y = Suc (h y)"
           by simp
         with \<open>x \<in> S\<close> \<open>y \<in> S\<close> show ?case
           by (simp add: comp_assoc hyp) (simp add: o_assoc comp_fun_commute_on)
       qed
       define h where "h z = (if z = x then g x - 1 else g z)" for z
       with Suc have "n = h x"
         by simp
       with Suc have "f y ^^ h y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ h y"
         by auto
       with False h_def have hyp2: "f y ^^ g y \<circ> f x ^^ h x = f x ^^ h x \<circ> f y ^^ g y"
         by simp
       from Suc h_def have "g x = Suc (h x)"
         by simp
       then show ?case
         by (simp del: funpow.simps add: funpow_Suc_right o_assoc hyp2) (simp add: comp_assoc hyp1)
     qed
   qed
 qed
 
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as carrier set\<close>
 
 locale comp_fun_commute =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) comp_fun_commute_def': "comp_fun_commute f = comp_fun_commute_on UNIV f"
   unfolding comp_fun_commute_def comp_fun_commute_on_def by blast
 
 text \<open>
   We abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_commute_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_commute_on UNIV f"
     by standard  (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_commute) comp_comp_fun_commute: "comp_fun_commute (f o g)"
   unfolding comp_fun_commute_def' by (fact comp_comp_fun_commute_on)
 
 lemma (in comp_fun_commute) comp_fun_commute_funpow: "comp_fun_commute (\<lambda>x. f x ^^ g x)"
   unfolding comp_fun_commute_def' by (fact comp_fun_commute_on_funpow)
 
 locale comp_fun_idem = comp_fun_commute +
   assumes comp_fun_idem: "f x o f x = f x"
 begin
 
 lemma (in -) comp_fun_idem_def': "comp_fun_idem f = comp_fun_idem_on UNIV f"
   unfolding comp_fun_idem_on_def comp_fun_idem_def comp_fun_commute_def'
   unfolding comp_fun_idem_axioms_def comp_fun_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale comp_fun_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "comp_fun_idem_on UNIV f"
     by standard (simp_all add: comp_fun_idem comp_fun_commute)
 qed simp_all
 
 end
 
 lemma (in comp_fun_idem) comp_comp_fun_idem: "comp_fun_idem (f o g)"
   unfolding comp_fun_idem_def' by (fact comp_comp_fun_idem_on)
 
 
 subsubsection \<open>Expressing set operations via \<^const>\<open>fold\<close>\<close>
 
 lemma comp_fun_commute_const: "comp_fun_commute (\<lambda>_. f)"
-  by standard rule
+  by standard (rule refl)
 
 lemma comp_fun_idem_insert: "comp_fun_idem insert"
   by standard auto
 
 lemma comp_fun_idem_remove: "comp_fun_idem Set.remove"
   by standard auto
 
 lemma (in semilattice_inf) comp_fun_idem_inf: "comp_fun_idem inf"
   by standard (auto simp add: inf_left_commute)
 
 lemma (in semilattice_sup) comp_fun_idem_sup: "comp_fun_idem sup"
   by standard (auto simp add: sup_left_commute)
 
 lemma union_fold_insert:
   assumes "finite A"
   shows "A \<union> B = fold insert B A"
 proof -
   interpret comp_fun_idem insert
     by (fact comp_fun_idem_insert)
   from \<open>finite A\<close> show ?thesis
     by (induct A arbitrary: B) simp_all
 qed
 
 lemma minus_fold_remove:
   assumes "finite A"
   shows "B - A = fold Set.remove B A"
 proof -
   interpret comp_fun_idem Set.remove
     by (fact comp_fun_idem_remove)
   from \<open>finite A\<close> have "fold Set.remove B A = B - A"
     by (induct A arbitrary: B) auto  (* slow *)
   then show ?thesis ..
 qed
 
 lemma comp_fun_commute_filter_fold:
   "comp_fun_commute (\<lambda>x A'. if P x then Set.insert x A' else A')"
 proof -
   interpret comp_fun_idem Set.insert by (fact comp_fun_idem_insert)
   show ?thesis by standard (auto simp: fun_eq_iff)
 qed
 
 lemma Set_filter_fold:
   assumes "finite A"
   shows "Set.filter P A = fold (\<lambda>x A'. if P x then Set.insert x A' else A') {} A"
   using assms
 proof -
   interpret commute_insert: comp_fun_commute "(\<lambda>x A'. if P x then Set.insert x A' else A')"
     by (fact comp_fun_commute_filter_fold)
   from \<open>finite A\<close> show ?thesis
     by induct (auto simp add: Set.filter_def)
 qed
 
 lemma inter_Set_filter:
   assumes "finite B"
   shows "A \<inter> B = Set.filter (\<lambda>x. x \<in> A) B"
   using assms
   by induct (auto simp: Set.filter_def)
 
 lemma image_fold_insert:
   assumes "finite A"
   shows "image f A = fold (\<lambda>k A. Set.insert (f k) A) {} A"
 proof -
   interpret comp_fun_commute "\<lambda>k A. Set.insert (f k) A"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Ball_fold:
   assumes "finite A"
   shows "Ball A P = fold (\<lambda>k s. s \<and> P k) True A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<and> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma Bex_fold:
   assumes "finite A"
   shows "Bex A P = fold (\<lambda>k s. s \<or> P k) False A"
 proof -
   interpret comp_fun_commute "\<lambda>k s. s \<or> P k"
     by standard auto
   show ?thesis
     using assms by (induct A) auto
 qed
 
 lemma comp_fun_commute_Pow_fold: "comp_fun_commute (\<lambda>x A. A \<union> Set.insert x ` A)"
   by (clarsimp simp: fun_eq_iff comp_fun_commute_def) blast
 
 lemma Pow_fold:
   assumes "finite A"
   shows "Pow A = fold (\<lambda>x A. A \<union> Set.insert x ` A) {{}} A"
 proof -
   interpret comp_fun_commute "\<lambda>x A. A \<union> Set.insert x ` A"
     by (rule comp_fun_commute_Pow_fold)
   show ?thesis
     using assms by (induct A) (auto simp: Pow_insert)
 qed
 
 lemma fold_union_pair:
   assumes "finite B"
   shows "(\<Union>y\<in>B. {(x, y)}) \<union> A = fold (\<lambda>y. Set.insert (x, y)) A B"
 proof -
   interpret comp_fun_commute "\<lambda>y. Set.insert (x, y)"
     by standard auto
   show ?thesis
     using assms by (induct arbitrary: A) simp_all
 qed
 
 lemma comp_fun_commute_product_fold:
   "finite B \<Longrightarrow> comp_fun_commute (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
   by standard (auto simp: fold_union_pair [symmetric])
 
 lemma product_fold:
   assumes "finite A" "finite B"
   shows "A \<times> B = fold (\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B) {} A"
 proof -
   interpret commute_product: comp_fun_commute "(\<lambda>x z. fold (\<lambda>y. Set.insert (x, y)) z B)"
     by (fact comp_fun_commute_product_fold[OF \<open>finite B\<close>])
   from assms show ?thesis unfolding Sigma_def
     by (induct A) (simp_all add: fold_union_pair)
 qed
 
 context complete_lattice
 begin
 
 lemma inf_Inf_fold_inf:
   assumes "finite A"
   shows "inf (Inf A) B = fold inf B A"
 proof -
   interpret comp_fun_idem inf
     by (fact comp_fun_idem_inf)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: inf_commute fun_eq_iff)
 qed
 
 lemma sup_Sup_fold_sup:
   assumes "finite A"
   shows "sup (Sup A) B = fold sup B A"
 proof -
   interpret comp_fun_idem sup
     by (fact comp_fun_idem_sup)
   from \<open>finite A\<close> fold_fun_left_comm show ?thesis
     by (induct A arbitrary: B) (simp_all add: sup_commute fun_eq_iff)
 qed
 
 lemma Inf_fold_inf: "finite A \<Longrightarrow> Inf A = fold inf top A"
   using inf_Inf_fold_inf [of A top] by (simp add: inf_absorb2)
 
 lemma Sup_fold_sup: "finite A \<Longrightarrow> Sup A = fold sup bot A"
   using sup_Sup_fold_sup [of A bot] by (simp add: sup_absorb2)
 
 lemma inf_INF_fold_inf:
   assumes "finite A"
   shows "inf B (\<Sqinter>(f ` A)) = fold (inf \<circ> f) B A" (is "?inf = ?fold")
 proof -
   interpret comp_fun_idem inf by (fact comp_fun_idem_inf)
   interpret comp_fun_idem "inf \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?inf"
     by (induct A arbitrary: B) (simp_all add: inf_left_commute)
   then show ?thesis ..
 qed
 
 lemma sup_SUP_fold_sup:
   assumes "finite A"
   shows "sup B (\<Squnion>(f ` A)) = fold (sup \<circ> f) B A" (is "?sup = ?fold")
 proof -
   interpret comp_fun_idem sup by (fact comp_fun_idem_sup)
   interpret comp_fun_idem "sup \<circ> f" by (fact comp_comp_fun_idem)
   from \<open>finite A\<close> have "?fold = ?sup"
     by (induct A arbitrary: B) (simp_all add: sup_left_commute)
   then show ?thesis ..
 qed
 
 lemma INF_fold_inf: "finite A \<Longrightarrow> \<Sqinter>(f ` A) = fold (inf \<circ> f) top A"
   using inf_INF_fold_inf [of A top] by simp
 
 lemma SUP_fold_sup: "finite A \<Longrightarrow> \<Squnion>(f ` A) = fold (sup \<circ> f) bot A"
   using sup_SUP_fold_sup [of A bot] by simp
 
 lemma finite_Inf_in:
   assumes "finite A" "A\<noteq>{}" and inf: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> inf x y \<in> A"
   shows "Inf A \<in> A"
 proof -
   have "Inf B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use inf in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 lemma finite_Sup_in:
   assumes "finite A" "A\<noteq>{}" and sup: "\<And>x y. \<lbrakk>x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> sup x y \<in> A"
   shows "Sup A \<in> A"
 proof -
   have "Sup B \<in> A" if "B \<le> A" "B\<noteq>{}" for B
     using finite_subset [OF \<open>B \<subseteq> A\<close> \<open>finite A\<close>] that
   by (induction B) (use sup in \<open>force+\<close>)
   then show ?thesis
     by (simp add: assms)
 qed
 
 end
 
 
 subsection \<open>Locales as mini-packages for fold operations\<close>
 
 subsubsection \<open>The natural case\<close>
 
 locale folding_on =
   fixes S :: "'a set"
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f y o f x = f x o f y"
 begin
 
 interpretation fold?: comp_fun_commute_on S f
   by standard (simp add: comp_fun_commute_on)
 
 definition F :: "'a set \<Rightarrow> 'b"
   where eq_fold: "F A = Finite_Set.fold f z A"
 
 lemma empty [simp]: "F {} = z"
   by (simp add: eq_fold)
 
 lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F A = z"
   by (simp add: eq_fold)
 
 lemma insert [simp]:
   assumes "insert x A \<subseteq> S" and "finite A" and "x \<notin> A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert assms
   have "Finite_Set.fold f z (insert x A) 
       = f x (Finite_Set.fold f z A)"
     by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 lemma remove:
   assumes "A \<subseteq> S" and "finite A" and "x \<in> A"
   shows "F A = f x (F (A - {x}))"
 proof -
   from \<open>x \<in> A\<close> obtain B where A: "A = insert x B" and "x \<notin> B"
     by (auto dest: mk_disjoint_insert)
   moreover from \<open>finite A\<close> A have "finite B" by simp
   ultimately show ?thesis
     using \<open>A \<subseteq> S\<close> by auto
 qed
 
 lemma insert_remove:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F (A - {x}))"
   using assms by (cases "x \<in> A") (simp_all add: remove insert_absorb)
 
 end
 
 
 subsubsection \<open>With idempotency\<close>
 
 locale folding_idem_on = folding_on +
   assumes comp_fun_idem_on: "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f x \<circ> f x = f x"
 begin
 
 declare insert [simp del]
 
 interpretation fold?: comp_fun_idem_on S f
   by standard (simp_all add: comp_fun_commute_on comp_fun_idem_on)
 
 lemma insert_idem [simp]:
   assumes "insert x A \<subseteq> S" and "finite A"
   shows "F (insert x A) = f x (F A)"
 proof -
   from fold_insert_idem assms
   have "fold f z (insert x A) = f x (fold f z A)" by simp
   with \<open>finite A\<close> show ?thesis by (simp add: eq_fold fun_eq_iff)
 qed
 
 end
 
 subsubsection \<open>\<^term>\<open>UNIV\<close> as the carrier set\<close>
 
 locale folding =
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'b" and z :: "'b"
   assumes comp_fun_commute: "f y \<circ> f x = f x \<circ> f y"
 begin
 
 lemma (in -) folding_def': "folding f = folding_on UNIV f"
   unfolding folding_def folding_on_def by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_on UNIV f"
     by standard (simp add: comp_fun_commute)
 qed simp_all
 
 end
 
 locale folding_idem = folding +
   assumes comp_fun_idem: "f x \<circ> f x = f x"
 begin
 
 lemma (in -) folding_idem_def': "folding_idem f = folding_idem_on UNIV f"
   unfolding folding_idem_def folding_def' folding_idem_on_def
   unfolding folding_idem_axioms_def folding_idem_on_axioms_def
   by blast
 
 text \<open>
   Again, we abuse the \<open>rewrites\<close> functionality of locales to remove trivial assumptions that
   result from instantiating the carrier set to \<^term>\<open>UNIV\<close>.
 \<close>
 sublocale folding_idem_on UNIV f
   rewrites "\<And>X. (X \<subseteq> UNIV) \<equiv> True"
        and "\<And>x. x \<in> UNIV \<equiv> True"
        and "\<And>P. (True \<Longrightarrow> P) \<equiv> Trueprop P"
        and "\<And>P Q. (True \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> True \<Longrightarrow> PROP Q)"
 proof -
   show "folding_idem_on UNIV f"
     by standard (simp add: comp_fun_idem)
 qed simp_all
 
 end
 
 
 subsection \<open>Finite cardinality\<close>
 
 text \<open>
   The traditional definition
   \<^prop>\<open>card A \<equiv> LEAST n. \<exists>f. A = {f i |i. i < n}\<close>
   is ugly to work with.
   But now that we have \<^const>\<open>fold\<close> things are easy:
 \<close>
 
 global_interpretation card: folding "\<lambda>_. Suc" 0
   defines card = "folding_on.F (\<lambda>_. Suc) 0"
-  by standard rule
+  by standard (rule refl)
 
 lemma card_insert_disjoint: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> card (insert x A) = Suc (card A)"
   by (fact card.insert)
 
 lemma card_insert_if: "finite A \<Longrightarrow> card (insert x A) = (if x \<in> A then card A else Suc (card A))"
   by auto (simp add: card.insert_remove card.remove)
 
 lemma card_ge_0_finite: "card A > 0 \<Longrightarrow> finite A"
   by (rule ccontr) simp
 
 lemma card_0_eq [simp]: "finite A \<Longrightarrow> card A = 0 \<longleftrightarrow> A = {}"
   by (auto dest: mk_disjoint_insert)
 
 lemma finite_UNIV_card_ge_0: "finite (UNIV :: 'a set) \<Longrightarrow> card (UNIV :: 'a set) > 0"
   by (rule ccontr) simp
 
 lemma card_eq_0_iff: "card A = 0 \<longleftrightarrow> A = {} \<or> \<not> finite A"
   by auto
 
 lemma card_range_greater_zero: "finite (range f) \<Longrightarrow> card (range f) > 0"
   by (rule ccontr) (simp add: card_eq_0_iff)
 
 lemma card_gt_0_iff: "0 < card A \<longleftrightarrow> A \<noteq> {} \<and> finite A"
   by (simp add: neq0_conv [symmetric] card_eq_0_iff)
 
 lemma card_Suc_Diff1:
   assumes "finite A" "x \<in> A" shows "Suc (card (A - {x})) = card A"
 proof -
   have "Suc (card (A - {x})) = card (insert x (A - {x}))"
     using assms by (simp add: card.insert_remove)
   also have "... = card A"
     using assms by (simp add: card_insert_if)
   finally show ?thesis .
 qed
 
 lemma card_insert_le_m1:
   assumes "n > 0" "card y \<le> n - 1" shows  "card (insert x y) \<le> n"
   using assms
   by (cases "finite y") (auto simp: card_insert_if)
 
 lemma card_Diff_singleton:
   assumes "x \<in> A" shows "card (A - {x}) = card A - 1"
 proof (cases "finite A")
   case True
   with assms show ?thesis
     by (simp add: card_Suc_Diff1 [symmetric])
 qed auto
 
 lemma card_Diff_singleton_if:
   "card (A - {x}) = (if x \<in> A then card A - 1 else card A)"
   by (simp add: card_Diff_singleton)
 
 lemma card_Diff_insert[simp]:
   assumes "a \<in> A" and "a \<notin> B"
   shows "card (A - insert a B) = card (A - B) - 1"
 proof -
   have "A - insert a B = (A - B) - {a}"
     using assms by blast
   then show ?thesis
     using assms by (simp add: card_Diff_singleton)
 qed
 
 lemma card_insert_le: "card A \<le> card (insert x A)"
 proof (cases "finite A")
   case True
   then show ?thesis   by (simp add: card_insert_if)
 qed auto
 
 lemma card_Collect_less_nat[simp]: "card {i::nat. i < n} = n"
   by (induct n) (simp_all add:less_Suc_eq Collect_disj_eq)
 
 lemma card_Collect_le_nat[simp]: "card {i::nat. i \<le> n} = Suc n"
   using card_Collect_less_nat[of "Suc n"] by (simp add: less_Suc_eq_le)
 
 lemma card_mono:
   assumes "finite B" and "A \<subseteq> B"
   shows "card A \<le> card B"
 proof -
   from assms have "finite A"
     by (auto intro: finite_subset)
   then show ?thesis
     using assms
   proof (induct A arbitrary: B)
     case empty
     then show ?case by simp
   next
     case (insert x A)
     then have "x \<in> B"
       by simp
     from insert have "A \<subseteq> B - {x}" and "finite (B - {x})"
       by auto
     with insert.hyps have "card A \<le> card (B - {x})"
       by auto
     with \<open>finite A\<close> \<open>x \<notin> A\<close> \<open>finite B\<close> \<open>x \<in> B\<close> show ?case
       by simp (simp only: card.remove)
   qed
 qed
 
 lemma card_seteq: 
   assumes "finite B" and A: "A \<subseteq> B" "card B \<le> card A"
   shows "A = B"
   using assms
 proof (induction arbitrary: A rule: finite_induct)
   case (insert b B)
   then have A: "finite A" "A - {b} \<subseteq> B" 
     by force+
   then have "card B \<le> card (A - {b})"
     using insert by (auto simp add: card_Diff_singleton_if)
   then have "A - {b} = B"
     using A insert.IH by auto
   then show ?case 
     using insert.hyps insert.prems by auto
 qed auto
 
 lemma psubset_card_mono: "finite B \<Longrightarrow> A < B \<Longrightarrow> card A < card B"
   using card_seteq [of B A] by (auto simp add: psubset_eq)
 
 lemma card_Un_Int:
   assumes "finite A" "finite B"
   shows "card A + card B = card (A \<union> B) + card (A \<inter> B)"
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case
     by (auto simp add: insert_absorb Int_insert_left)
 qed
 
 lemma card_Un_disjoint: "finite A \<Longrightarrow> finite B \<Longrightarrow> A \<inter> B = {} \<Longrightarrow> card (A \<union> B) = card A + card B"
   using card_Un_Int [of A B] by simp
 
 lemma card_Un_disjnt: "\<lbrakk>finite A; finite B; disjnt A B\<rbrakk> \<Longrightarrow> card (A \<union> B) = card A + card B"
   by (simp add: card_Un_disjoint disjnt_def)
 
 lemma card_Un_le: "card (A \<union> B) \<le> card A + card B"
 proof (cases "finite A \<and> finite B")
   case True
   then show ?thesis
     using le_iff_add card_Un_Int [of A B] by auto
 qed auto
 
 lemma card_Diff_subset:
   assumes "finite B"
     and "B \<subseteq> A"
   shows "card (A - B) = card A - card B"
   using assms
 proof (cases "finite A")
   case False
   with assms show ?thesis
     by simp
 next
   case True
   with assms show ?thesis
     by (induct B arbitrary: A) simp_all
 qed
 
 lemma card_Diff_subset_Int:
   assumes "finite (A \<inter> B)"
   shows "card (A - B) = card A - card (A \<inter> B)"
 proof -
   have "A - B = A - A \<inter> B" by auto
   with assms show ?thesis
     by (simp add: card_Diff_subset)
 qed
 
 lemma diff_card_le_card_Diff:
   assumes "finite B"
   shows "card A - card B \<le> card (A - B)"
 proof -
   have "card A - card B \<le> card A - card (A \<inter> B)"
     using card_mono[OF assms Int_lower2, of A] by arith
   also have "\<dots> = card (A - B)"
     using assms by (simp add: card_Diff_subset_Int)
   finally show ?thesis .
 qed
 
 lemma card_le_sym_Diff:
   assumes "finite A" "finite B" "card A \<le> card B"
   shows "card(A - B) \<le> card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> \<le> card B - card (A \<inter> B)" using assms(3) by linarith
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_less_sym_Diff:
   assumes "finite A" "finite B" "card A < card B"
   shows "card(A - B) < card(B - A)"
 proof -
   have "card(A - B) = card A - card (A \<inter> B)" using assms(1,2) by(simp add: card_Diff_subset_Int)
   also have "\<dots> < card B - card (A \<inter> B)" using assms(1,3) by (simp add: card_mono diff_less_mono)
   also have "\<dots> = card(B - A)" using assms(1,2) by(simp add: card_Diff_subset_Int Int_commute)
   finally show ?thesis .
 qed
 
 lemma card_Diff1_less_iff: "card (A - {x}) < card A \<longleftrightarrow> finite A \<and> x \<in> A"
 proof (cases "finite A \<and> x \<in> A")
   case True
   then show ?thesis
     by (auto simp: card_gt_0_iff intro: diff_less)
 qed auto
 
 lemma card_Diff1_less: "finite A \<Longrightarrow> x \<in> A \<Longrightarrow> card (A - {x}) < card A"
   unfolding card_Diff1_less_iff by auto
 
 lemma card_Diff2_less:
   assumes "finite A" "x \<in> A" "y \<in> A" shows "card (A - {x} - {y}) < card A"
 proof (cases "x = y")
   case True
   with assms show ?thesis
     by (simp add: card_Diff1_less del: card_Diff_insert)
 next
   case False
   then have "card (A - {x} - {y}) < card (A - {x})" "card (A - {x}) < card A"
     using assms by (intro card_Diff1_less; simp)+
   then show ?thesis
     by (blast intro: less_trans)
 qed
 
 lemma card_Diff1_le: "card (A - {x}) \<le> card A"
 proof (cases "finite A")
   case True
   then show ?thesis  
     by (cases "x \<in> A") (simp_all add: card_Diff1_less less_imp_le)
 qed auto
 
 lemma card_psubset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> card A < card B \<Longrightarrow> A < B"
   by (erule psubsetI) blast
 
 lemma card_le_inj:
   assumes fA: "finite A"
     and fB: "finite B"
     and c: "card A \<le> card B"
   shows "\<exists>f. f ` A \<subseteq> B \<and> inj_on f A"
   using fA fB c
 proof (induct arbitrary: B rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x s t)
   then show ?case
   proof (induct rule: finite_induct [OF insert.prems(1)])
     case 1
     then show ?case by simp
   next
     case (2 y t)
     from "2.prems"(1,2,5) "2.hyps"(1,2) have cst: "card s \<le> card t"
       by simp
     from "2.prems"(3) [OF "2.hyps"(1) cst]
-    obtain f where "f ` s \<subseteq> t" "inj_on f s"
+    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
+    let ?g = "(\<lambda>a. if a = x then y else f a)"
+    have "?g ` insert x s \<subseteq> insert y t \<and> inj_on ?g (insert x s)"
+      using * "2.prems"(2) "2.hyps"(2) unfolding inj_on_def by auto
+    then show ?case by (rule exI[where ?x="?g"])
   qed
 qed
 
 lemma card_subset_eq:
   assumes fB: "finite B"
     and AB: "A \<subseteq> B"
     and c: "card A = card B"
   shows "A = B"
 proof -
   from fB AB have fA: "finite A"
     by (auto intro: finite_subset)
   from fA fB have fBA: "finite (B - A)"
     by auto
   have e: "A \<inter> (B - A) = {}"
     by blast
   have eq: "A \<union> (B - A) = B"
     using AB by blast
   from card_Un_disjoint[OF fA fBA e, unfolded eq c] have "card (B - A) = 0"
     by arith
   then have "B - A = {}"
     unfolding card_eq_0_iff using fA fB by simp
   with AB show "A = B"
     by blast
 qed
 
 lemma insert_partition:
   "x \<notin> F \<Longrightarrow> \<forall>c1 \<in> insert x F. \<forall>c2 \<in> insert x F. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {} \<Longrightarrow> x \<inter> \<Union>F = {}"
   by auto
 
 lemma finite_psubset_induct [consumes 1, case_names psubset]:
   assumes finite: "finite A"
     and major: "\<And>A. finite A \<Longrightarrow> (\<And>B. B \<subset> A \<Longrightarrow> P B) \<Longrightarrow> P A"
   shows "P A"
   using finite
 proof (induct A taking: card rule: measure_induct_rule)
   case (less A)
   have fin: "finite A" by fact
   have ih: "card B < card A \<Longrightarrow> finite B \<Longrightarrow> P B" for B by fact
   have "P B" if "B \<subset> A" for B
   proof -
     from that have "card B < card A"
       using psubset_card_mono fin by blast
     moreover
     from that have "B \<subseteq> A"
       by auto
     then have "finite B"
       using fin finite_subset by blast
     ultimately show ?thesis using ih by simp
   qed
   with fin show "P A" using major by blast
 qed
 
 lemma finite_induct_select [consumes 1, case_names empty select]:
   assumes "finite S"
     and "P {}"
     and select: "\<And>T. T \<subset> S \<Longrightarrow> P T \<Longrightarrow> \<exists>s\<in>S - T. P (insert s T)"
   shows "P S"
 proof -
   have "0 \<le> card S" by simp
   then have "\<exists>T \<subseteq> S. card T = card S \<and> P T"
   proof (induct rule: dec_induct)
     case base with \<open>P {}\<close>
     show ?case
       by (intro exI[of _ "{}"]) auto
   next
     case (step n)
     then obtain T where T: "T \<subseteq> S" "card T = n" "P T"
       by auto
     with \<open>n < card S\<close> have "T \<subset> S" "P T"
       by auto
     with select[of T] obtain s where "s \<in> S" "s \<notin> T" "P (insert s T)"
       by auto
     with step(2) T \<open>finite S\<close> show ?case
       by (intro exI[of _ "insert s T"]) (auto dest: finite_subset)
   qed
   with \<open>finite S\<close> show "P S"
     by (auto dest: card_subset_eq)
 qed
 
 lemma remove_induct [case_names empty infinite remove]:
   assumes empty: "P ({} :: 'a set)"
     and infinite: "\<not> finite B \<Longrightarrow> P B"
     and remove: "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   shows "P B"
 proof (cases "finite B")
   case False
   then show ?thesis by (rule infinite)
 next
   case True
   define A where "A = B"
   with True have "finite A" "A \<subseteq> B"
     by simp_all
   then show "P A"
   proof (induct "card A" arbitrary: A)
     case 0
     then have "A = {}" by auto
     with empty show ?case by simp
   next
     case (Suc n A)
     from \<open>A \<subseteq> B\<close> and \<open>finite B\<close> have "finite A"
       by (rule finite_subset)
     moreover from Suc.hyps have "A \<noteq> {}" by auto
     moreover note \<open>A \<subseteq> B\<close>
     moreover have "P (A - {x})" if x: "x \<in> A" for x
       using x Suc.prems \<open>Suc n = card A\<close> by (intro Suc) auto
     ultimately show ?case by (rule remove)
   qed
 qed
 
 lemma finite_remove_induct [consumes 1, case_names empty remove]:
   fixes P :: "'a set \<Rightarrow> bool"
   assumes "finite B"
     and "P {}"
     and "\<And>A. finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> A \<subseteq> B \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> P (A - {x})) \<Longrightarrow> P A"
   defines "B' \<equiv> B"
   shows "P B'"
   by (induct B' rule: remove_induct) (simp_all add: assms)
 
 
 text \<open>Main cardinality theorem.\<close>
 lemma card_partition [rule_format]:
   "finite C \<Longrightarrow> finite (\<Union>C) \<Longrightarrow> (\<forall>c\<in>C. card c = k) \<Longrightarrow>
     (\<forall>c1 \<in> C. \<forall>c2 \<in> C. c1 \<noteq> c2 \<longrightarrow> c1 \<inter> c2 = {}) \<Longrightarrow>
     k * card C = card (\<Union>C)"
 proof (induct rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case
     by (simp add: card_Un_disjoint insert_partition finite_subset [of _ "\<Union>(insert _ _)"])
 qed
 
 lemma card_eq_UNIV_imp_eq_UNIV:
   assumes fin: "finite (UNIV :: 'a set)"
     and card: "card A = card (UNIV :: 'a set)"
   shows "A = (UNIV :: 'a set)"
 proof
   show "A \<subseteq> UNIV" by simp
   show "UNIV \<subseteq> A"
   proof
     show "x \<in> A" for x
     proof (rule ccontr)
       assume "x \<notin> A"
       then have "A \<subset> UNIV" by auto
       with fin have "card A < card (UNIV :: 'a set)"
         by (fact psubset_card_mono)
       with card show False by simp
     qed
   qed
 qed
 
 text \<open>The form of a finite set of given cardinality\<close>
 
 lemma card_eq_SucD:
   assumes "card A = Suc k"
   shows "\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {})"
 proof -
   have fin: "finite A"
     using assms by (auto intro: ccontr)
   moreover have "card A \<noteq> 0"
     using assms by auto
   ultimately obtain b where b: "b \<in> A"
     by auto
   show ?thesis
   proof (intro exI conjI)
     show "A = insert b (A - {b})"
       using b by blast
     show "b \<notin> A - {b}"
       by blast
     show "card (A - {b}) = k" and "k = 0 \<longrightarrow> A - {b} = {}"
       using assms b fin by (fastforce dest: mk_disjoint_insert)+
   qed
 qed
 
 lemma card_Suc_eq:
   "card A = Suc k \<longleftrightarrow>
     (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> (k = 0 \<longrightarrow> B = {}))"
   by (auto simp: card_insert_if card_gt_0_iff elim!: card_eq_SucD)
 
 lemma card_Suc_eq_finite:
   "card A = Suc k \<longleftrightarrow> (\<exists>b B. A = insert b B \<and> b \<notin> B \<and> card B = k \<and> finite B)"
   unfolding card_Suc_eq using card_gt_0_iff by fastforce
 
 lemma card_1_singletonE:
   assumes "card A = 1"
   obtains x where "A = {x}"
   using assms by (auto simp: card_Suc_eq)
 
 lemma is_singleton_altdef: "is_singleton A \<longleftrightarrow> card A = 1"
   unfolding is_singleton_def
   by (auto elim!: card_1_singletonE is_singletonE simp del: One_nat_def)
 
 lemma card_1_singleton_iff: "card A = Suc 0 \<longleftrightarrow> (\<exists>x. A = {x})"
   by (simp add: card_Suc_eq)
 
 lemma card_le_Suc0_iff_eq:
   assumes "finite A"
   shows "card A \<le> Suc 0 \<longleftrightarrow> (\<forall>a1 \<in> A. \<forall>a2 \<in> A. a1 = a2)" (is "?C = ?A")
 proof
   assume ?C thus ?A using assms by (auto simp: le_Suc_eq dest: card_eq_SucD)
 next
   assume ?A
   show ?C
   proof cases
     assume "A = {}" thus ?C using \<open>?A\<close> by simp
   next
     assume "A \<noteq> {}"
     then obtain a where "A = {a}" using \<open>?A\<close> by blast
     thus ?C by simp
   qed
 qed
 
 lemma card_le_Suc_iff:
   "Suc n \<le> card A = (\<exists>a B. A = insert a B \<and> a \<notin> B \<and> n \<le> card B \<and> finite B)"
 proof (cases "finite A")
   case True
   then show ?thesis
     by (fastforce simp: card_Suc_eq less_eq_nat.simps split: nat.splits)
 qed auto
 
 lemma finite_fun_UNIVD2:
   assumes fin: "finite (UNIV :: ('a \<Rightarrow> 'b) set)"
   shows "finite (UNIV :: 'b set)"
 proof -
   from fin have "finite (range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary))" for arbitrary
     by (rule finite_imageI)
   moreover have "UNIV = range (\<lambda>f :: 'a \<Rightarrow> 'b. f arbitrary)" for arbitrary
     by (rule UNIV_eq_I) auto
   ultimately show "finite (UNIV :: 'b set)"
     by simp
 qed
 
 lemma card_UNIV_unit [simp]: "card (UNIV :: unit set) = 1"
   unfolding UNIV_unit by simp
 
 lemma infinite_arbitrarily_large:
   assumes "\<not> finite A"
   shows "\<exists>B. finite B \<and> card B = n \<and> B \<subseteq> A"
 proof (induction n)
   case 0
   show ?case by (intro exI[of _ "{}"]) auto
 next
   case (Suc n)
   then obtain B where B: "finite B \<and> card B = n \<and> B \<subseteq> A" ..
   with \<open>\<not> finite A\<close> have "A \<noteq> B" by auto
   with B have "B \<subset> A" by auto
   then have "\<exists>x. x \<in> A - B"
     by (elim psubset_imp_ex_mem)
   then obtain x where x: "x \<in> A - B" ..
   with B have "finite (insert x B) \<and> card (insert x B) = Suc n \<and> insert x B \<subseteq> A"
     by auto
   then show "\<exists>B. finite B \<and> card B = Suc n \<and> B \<subseteq> A" ..
 qed
 
 text \<open>Sometimes, to prove that a set is finite, it is convenient to work with finite subsets
 and to show that their cardinalities are uniformly bounded. This possibility is formalized in
 the next criterion.\<close>
 
 lemma finite_if_finite_subsets_card_bdd:
   assumes "\<And>G. G \<subseteq> F \<Longrightarrow> finite G \<Longrightarrow> card G \<le> C"
   shows "finite F \<and> card F \<le> C"
 proof (cases "finite F")
   case False
   obtain n::nat where n: "n > max C 0" by auto
   obtain G where G: "G \<subseteq> F" "card G = n" using infinite_arbitrarily_large[OF False] by auto
   hence "finite G" using \<open>n > max C 0\<close> using card.infinite gr_implies_not0 by blast
   hence False using assms G n not_less by auto
   thus ?thesis ..
 next
   case True thus ?thesis using assms[of F] by auto
 qed
 
 lemma obtain_subset_with_card_n:
   assumes "n \<le> card S"
   obtains T where "T \<subseteq> S" "card T = n" "finite T"
 proof -
   obtain n' where "card S = n + n'"
     using le_Suc_ex[OF assms] by blast
   with that show thesis
   proof (induct n' arbitrary: S)
     case 0 
     thus ?case by (cases "finite S") auto
   next
     case Suc 
     thus ?case by (auto simp add: card_Suc_eq)
   qed
 qed
 
 lemma exists_subset_between: 
   assumes 
     "card A \<le> n" 
     "n \<le> card C"
     "A \<subseteq> C"
     "finite C"
   shows "\<exists>B. A \<subseteq> B \<and> B \<subseteq> C \<and> card B = n" 
   using assms 
 proof (induct n arbitrary: A C)
   case 0
   thus ?case using finite_subset[of A C] by (intro exI[of _ "{}"], auto)
 next
   case (Suc n A C)
   show ?case
   proof (cases "A = {}")
     case True
     from obtain_subset_with_card_n[OF Suc(3)]
     obtain B where "B \<subseteq> C" "card B = Suc n" by blast
     thus ?thesis unfolding True by blast
   next
     case False
     then obtain a where a: "a \<in> A" by auto
     let ?A = "A - {a}" 
     let ?C = "C - {a}" 
     have 1: "card ?A \<le> n" using Suc(2-) a 
       using finite_subset by fastforce 
     have 2: "card ?C \<ge> n" using Suc(2-) a by auto
     from Suc(1)[OF 1 2 _ finite_subset[OF _ Suc(5)]] Suc(2-)
     obtain B where "?A \<subseteq> B" "B \<subseteq> ?C" "card B = n" by blast
     thus ?thesis using a Suc(2-) 
       by (intro exI[of _ "insert a B"], auto intro!: card_insert_disjoint finite_subset[of B C])
   qed
 qed
 
 
 subsubsection \<open>Cardinality of image\<close>
 
 lemma card_image_le: "finite A \<Longrightarrow> card (f ` A) \<le> card A"
   by (induct rule: finite_induct) (simp_all add: le_SucI card_insert_if)
 
 lemma card_image: "inj_on f A \<Longrightarrow> card (f ` A) = card A"
 proof (induct A rule: infinite_finite_induct)
   case (infinite A)
   then have "\<not> finite (f ` A)" by (auto dest: finite_imageD)
   with infinite show ?case by simp
 qed simp_all
 
 lemma bij_betw_same_card: "bij_betw f A B \<Longrightarrow> card A = card B"
   by (auto simp: card_image bij_betw_def)
 
 lemma endo_inj_surj: "finite A \<Longrightarrow> f ` A \<subseteq> A \<Longrightarrow> inj_on f A \<Longrightarrow> f ` A = A"
   by (simp add: card_seteq card_image)
 
 lemma eq_card_imp_inj_on:
   assumes "finite A" "card(f ` A) = card A"
   shows "inj_on f A"
   using assms
 proof (induct rule:finite_induct)
   case empty
   show ?case by simp
 next
   case (insert x A)
   then show ?case
     using card_image_le [of A f] by (simp add: card_insert_if split: if_splits)
 qed
 
 lemma inj_on_iff_eq_card: "finite A \<Longrightarrow> inj_on f A \<longleftrightarrow> card (f ` A) = card A"
   by (blast intro: card_image eq_card_imp_inj_on)
 
 lemma card_inj_on_le:
   assumes "inj_on f A" "f ` A \<subseteq> B" "finite B"
   shows "card A \<le> card B"
 proof -
   have "finite A"
     using assms by (blast intro: finite_imageD dest: finite_subset)
   then show ?thesis
     using assms by (force intro: card_mono simp: card_image [symmetric])
 qed
 
 lemma inj_on_iff_card_le:
   "\<lbrakk> finite A; finite B \<rbrakk> \<Longrightarrow> (\<exists>f. inj_on f A \<and> f ` A \<le> B) = (card A \<le> card B)"
 using card_inj_on_le[of _ A B] card_le_inj[of A B] by blast
 
 lemma surj_card_le: "finite A \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> card B \<le> card A"
   by (blast intro: card_image_le card_mono le_trans)
 
 lemma card_bij_eq:
   "inj_on f A \<Longrightarrow> f ` A \<subseteq> B \<Longrightarrow> inj_on g B \<Longrightarrow> g ` B \<subseteq> A \<Longrightarrow> finite A \<Longrightarrow> finite B
     \<Longrightarrow> card A = card B"
   by (auto intro: le_antisym card_inj_on_le)
 
 lemma bij_betw_finite: "bij_betw f A B \<Longrightarrow> finite A \<longleftrightarrow> finite B"
   unfolding bij_betw_def using finite_imageD [of f A] by auto
 
 lemma inj_on_finite: "inj_on f A \<Longrightarrow> f ` A \<le> B \<Longrightarrow> finite B \<Longrightarrow> finite A"
   using finite_imageD finite_subset by blast
 
 lemma card_vimage_inj_on_le:
   assumes "inj_on f D" "finite A"
   shows "card (f-`A \<inter> D) \<le> card A"
 proof (rule card_inj_on_le)
   show "inj_on f (f -` A \<inter> D)"
     by (blast intro: assms inj_on_subset)
 qed (use assms in auto)
 
 lemma card_vimage_inj: "inj f \<Longrightarrow> A \<subseteq> range f \<Longrightarrow> card (f -` A) = card A"
   by (auto 4 3 simp: subset_image_iff inj_vimage_image_eq
       intro: card_image[symmetric, OF subset_inj_on])
 
 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
+          by (cases "z = y \<longrightarrow> z = x") auto
         then show "T \<subseteq> f ` (S - {y})"
           using h xy x y f by fastforce
       qed
       also have " \<dots> \<le> card (S - {y})"
         by (simp add: card_image_le fS)
       also have "\<dots> \<le> card S - 1" using y fS by simp
       finally show False using S0 by arith
     qed
   }
   then show ?rhs
     unfolding inj_on_def by blast
 next
   assume h: ?rhs
   have "f ` S = T"
     by (simp add: ST c card_image card_subset_eq fT h)
   then show ?lhs by blast
 qed
 
 hide_const (open) Finite_Set.fold
 
 
 subsection \<open>Infinite Sets\<close>
 
 text \<open>
   Some elementary facts about infinite sets, mostly by Stephan Merz.
   Beware! Because "infinite" merely abbreviates a negation, these
   lemmas may not work well with \<open>blast\<close>.
 \<close>
 
 abbreviation infinite :: "'a set \<Rightarrow> bool"
   where "infinite S \<equiv> \<not> finite S"
 
 text \<open>
   Infinite sets are non-empty, and if we remove some elements from an
   infinite set, the result is still infinite.
 \<close>
 
 lemma infinite_UNIV_nat [iff]: "infinite (UNIV :: nat set)"
 proof
   assume "finite (UNIV :: nat set)"
   with finite_UNIV_inj_surj [of Suc] show False
     by simp (blast dest: Suc_neq_Zero surjD)
 qed
 
 lemma infinite_UNIV_char_0: "infinite (UNIV :: 'a::semiring_char_0 set)"
 proof
   assume "finite (UNIV :: 'a set)"
   with subset_UNIV have "finite (range of_nat :: 'a set)"
     by (rule finite_subset)
   moreover have "inj (of_nat :: nat \<Rightarrow> 'a)"
     by (simp add: inj_on_def)
   ultimately have "finite (UNIV :: nat set)"
     by (rule finite_imageD)
   then show False
     by simp
 qed
 
 lemma infinite_imp_nonempty: "infinite S \<Longrightarrow> S \<noteq> {}"
   by auto
 
 lemma infinite_remove: "infinite S \<Longrightarrow> infinite (S - {a})"
   by simp
 
 lemma Diff_infinite_finite:
   assumes "finite T" "infinite S"
   shows "infinite (S - T)"
   using \<open>finite T\<close>
 proof induct
   from \<open>infinite S\<close> show "infinite (S - {})"
     by auto
 next
   fix T x
   assume ih: "infinite (S - T)"
   have "S - (insert x T) = (S - T) - {x}"
     by (rule Diff_insert)
   with ih show "infinite (S - (insert x T))"
     by (simp add: infinite_remove)
 qed
 
 lemma Un_infinite: "infinite S \<Longrightarrow> infinite (S \<union> T)"
   by simp
 
 lemma infinite_Un: "infinite (S \<union> T) \<longleftrightarrow> infinite S \<or> infinite T"
   by simp
 
 lemma infinite_super:
   assumes "S \<subseteq> T"
     and "infinite S"
   shows "infinite T"
 proof
   assume "finite T"
   with \<open>S \<subseteq> T\<close> have "finite S" by (simp add: finite_subset)
   with \<open>infinite S\<close> show False by simp
 qed
 
 proposition infinite_coinduct [consumes 1, case_names infinite]:
   assumes "X A"
     and step: "\<And>A. X A \<Longrightarrow> \<exists>x\<in>A. X (A - {x}) \<or> infinite (A - {x})"
   shows "infinite A"
 proof
   assume "finite A"
   then show False
     using \<open>X A\<close>
   proof (induction rule: finite_psubset_induct)
     case (psubset A)
     then obtain x where "x \<in> A" "X (A - {x}) \<or> infinite (A - {x})"
       using local.step psubset.prems by blast
     then have "X (A - {x})"
       using psubset.hyps by blast
     show False
     proof (rule psubset.IH [where B = "A - {x}"])
       show "A - {x} \<subset> A"
         using \<open>x \<in> A\<close> by blast
     qed fact
   qed
 qed
 
 text \<open>
   For any function with infinite domain and finite range there is some
   element that is the image of infinitely many domain elements.  In
   particular, any infinite sequence of elements from a finite set
   contains some element that occurs infinitely often.
 \<close>
 
 lemma inf_img_fin_dom':
   assumes img: "finite (f ` A)"
     and dom: "infinite A"
   shows "\<exists>y \<in> f ` A. infinite (f -` {y} \<inter> A)"
 proof (rule ccontr)
   have "A \<subseteq> (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by auto
   moreover assume "\<not> ?thesis"
   with img have "finite (\<Union>y\<in>f ` A. f -` {y} \<inter> A)" by blast
   ultimately have "finite A" by (rule finite_subset)
   with dom show False by contradiction
 qed
 
 lemma inf_img_fin_domE':
   assumes "finite (f ` A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y} \<inter> A)"
   using assms by (blast dest: inf_img_fin_dom')
 
 lemma inf_img_fin_dom:
   assumes img: "finite (f`A)" and dom: "infinite A"
   shows "\<exists>y \<in> f`A. infinite (f -` {y})"
   using inf_img_fin_dom'[OF assms] by auto
 
 lemma inf_img_fin_domE:
   assumes "finite (f`A)" and "infinite A"
   obtains y where "y \<in> f`A" and "infinite (f -` {y})"
   using assms by (blast dest: inf_img_fin_dom)
 
 proposition finite_image_absD: "finite (abs ` S) \<Longrightarrow> finite S"
   for S :: "'a::linordered_ring set"
   by (rule ccontr) (auto simp: abs_eq_iff vimage_def dest: inf_img_fin_dom)
 
 
 subsection \<open>The finite powerset operator\<close>
 
 definition Fpow :: "'a set \<Rightarrow> 'a set set"
 where "Fpow A \<equiv> {X. X \<subseteq> A \<and> finite X}"
 
 lemma Fpow_mono: "A \<subseteq> B \<Longrightarrow> Fpow A \<subseteq> Fpow B"
 unfolding Fpow_def by auto
 
 lemma empty_in_Fpow: "{} \<in> Fpow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_not_empty: "Fpow A \<noteq> {}"
 using empty_in_Fpow by blast
 
 lemma Fpow_subset_Pow: "Fpow A \<subseteq> Pow A"
 unfolding Fpow_def by auto
 
 lemma Fpow_Pow_finite: "Fpow A = Pow A Int {A. finite A}"
 unfolding Fpow_def Pow_def by blast
 
 lemma inj_on_image_Fpow:
   assumes "inj_on f A"
   shows "inj_on (image f) (Fpow A)"
   using assms Fpow_subset_Pow[of A] subset_inj_on[of "image f" "Pow A"]
     inj_on_image_Pow by blast
 
 lemma image_Fpow_mono:
   assumes "f ` A \<subseteq> B"
   shows "(image f) ` (Fpow A) \<subseteq> Fpow B"
   using assms by(unfold Fpow_def, auto)
 
 end
diff --git a/src/HOL/Fun.thy b/src/HOL/Fun.thy
--- a/src/HOL/Fun.thy
+++ b/src/HOL/Fun.thy
@@ -1,1128 +1,1136 @@
 (*  Title:      HOL/Fun.thy
     Author:     Tobias Nipkow, Cambridge University Computer Laboratory
     Author:     Andrei Popescu, TU Muenchen
     Copyright   1994, 2012
 *)
 
 section \<open>Notions about functions\<close>
 
 theory Fun
   imports Set
   keywords "functor" :: thy_goal_defn
 begin
 
 lemma apply_inverse: "f x = u \<Longrightarrow> (\<And>x. P x \<Longrightarrow> g (f x) = x) \<Longrightarrow> P x \<Longrightarrow> x = g u"
   by auto
 
 text \<open>Uniqueness, so NOT the axiom of choice.\<close>
 lemma uniq_choice: "\<forall>x. \<exists>!y. Q x y \<Longrightarrow> \<exists>f. \<forall>x. Q x (f x)"
   by (force intro: theI')
 
 lemma b_uniq_choice: "\<forall>x\<in>S. \<exists>!y. Q x y \<Longrightarrow> \<exists>f. \<forall>x\<in>S. Q x (f x)"
   by (force intro: theI')
 
 
 subsection \<open>The Identity Function \<open>id\<close>\<close>
 
 definition id :: "'a \<Rightarrow> 'a"
   where "id = (\<lambda>x. x)"
 
 lemma id_apply [simp]: "id x = x"
   by (simp add: id_def)
 
 lemma image_id [simp]: "image id = id"
   by (simp add: id_def fun_eq_iff)
 
 lemma vimage_id [simp]: "vimage id = id"
   by (simp add: id_def fun_eq_iff)
 
 lemma eq_id_iff: "(\<forall>x. f x = x) \<longleftrightarrow> f = id"
   by auto
 
 code_printing
   constant id \<rightharpoonup> (Haskell) "id"
 
 
 subsection \<open>The Composition Operator \<open>f \<circ> g\<close>\<close>
 
 definition comp :: "('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c"  (infixl "\<circ>" 55)
   where "f \<circ> g = (\<lambda>x. f (g x))"
 
 notation (ASCII)
   comp  (infixl "o" 55)
 
 lemma comp_apply [simp]: "(f \<circ> g) x = f (g x)"
   by (simp add: comp_def)
 
 lemma comp_assoc: "(f \<circ> g) \<circ> h = f \<circ> (g \<circ> h)"
   by (simp add: fun_eq_iff)
 
 lemma id_comp [simp]: "id \<circ> g = g"
   by (simp add: fun_eq_iff)
 
 lemma comp_id [simp]: "f \<circ> id = f"
   by (simp add: fun_eq_iff)
 
 lemma comp_eq_dest: "a \<circ> b = c \<circ> d \<Longrightarrow> a (b v) = c (d v)"
   by (simp add: fun_eq_iff)
 
 lemma comp_eq_elim: "a \<circ> b = c \<circ> d \<Longrightarrow> ((\<And>v. a (b v) = c (d v)) \<Longrightarrow> R) \<Longrightarrow> R"
   by (simp add: fun_eq_iff)
 
 lemma comp_eq_dest_lhs: "a \<circ> b = c \<Longrightarrow> a (b v) = c v"
   by clarsimp
 
 lemma comp_eq_id_dest: "a \<circ> b = id \<circ> c \<Longrightarrow> a (b v) = c v"
   by clarsimp
 
 lemma image_comp: "f ` (g ` r) = (f \<circ> g) ` r"
   by auto
 
 lemma vimage_comp: "f -` (g -` x) = (g \<circ> f) -` x"
   by auto
 
 lemma image_eq_imp_comp: "f ` A = g ` B \<Longrightarrow> (h \<circ> f) ` A = (h \<circ> g) ` B"
   by (auto simp: comp_def elim!: equalityE)
 
 lemma image_bind: "f ` (Set.bind A g) = Set.bind A ((`) f \<circ> g)"
   by (auto simp add: Set.bind_def)
 
 lemma bind_image: "Set.bind (f ` A) g = Set.bind A (g \<circ> f)"
   by (auto simp add: Set.bind_def)
 
 lemma (in group_add) minus_comp_minus [simp]: "uminus \<circ> uminus = id"
   by (simp add: fun_eq_iff)
 
 lemma (in boolean_algebra) minus_comp_minus [simp]: "uminus \<circ> uminus = id"
   by (simp add: fun_eq_iff)
 
 code_printing
   constant comp \<rightharpoonup> (SML) infixl 5 "o" and (Haskell) infixr 9 "."
 
 
 subsection \<open>The Forward Composition Operator \<open>fcomp\<close>\<close>
 
 definition fcomp :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'c"  (infixl "\<circ>>" 60)
   where "f \<circ>> g = (\<lambda>x. g (f x))"
 
 lemma fcomp_apply [simp]:  "(f \<circ>> g) x = g (f x)"
   by (simp add: fcomp_def)
 
 lemma fcomp_assoc: "(f \<circ>> g) \<circ>> h = f \<circ>> (g \<circ>> h)"
   by (simp add: fcomp_def)
 
 lemma id_fcomp [simp]: "id \<circ>> g = g"
   by (simp add: fcomp_def)
 
 lemma fcomp_id [simp]: "f \<circ>> id = f"
   by (simp add: fcomp_def)
 
 lemma fcomp_comp: "fcomp f g = comp g f"
   by (simp add: ext)
 
 code_printing
   constant fcomp \<rightharpoonup> (Eval) infixl 1 "#>"
 
 no_notation fcomp (infixl "\<circ>>" 60)
 
 
 subsection \<open>Mapping functions\<close>
 
 definition map_fun :: "('c \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'c \<Rightarrow> 'd"
   where "map_fun f g h = g \<circ> h \<circ> f"
 
 lemma map_fun_apply [simp]: "map_fun f g h x = g (h (f x))"
   by (simp add: map_fun_def)
 
 
 subsection \<open>Injectivity and Bijectivity\<close>
 
 definition inj_on :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> bool"  \<comment> \<open>injective\<close>
   where "inj_on f A \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. f x = f y \<longrightarrow> x = y)"
 
 definition bij_betw :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool"  \<comment> \<open>bijective\<close>
   where "bij_betw f A B \<longleftrightarrow> inj_on f A \<and> f ` A = B"
 
 text \<open>
   A common special case: functions injective, surjective or bijective over
   the entire domain type.
 \<close>
 
 abbreviation inj :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "inj f \<equiv> inj_on f UNIV"
 
 abbreviation surj :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "surj f \<equiv> range f = UNIV"
 
 translations \<comment> \<open>The negated case:\<close>
   "\<not> CONST surj f" \<leftharpoondown> "CONST range f \<noteq> CONST UNIV"
 
 abbreviation bij :: "('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "bij f \<equiv> bij_betw f UNIV UNIV"
 
 lemma inj_def: "inj f \<longleftrightarrow> (\<forall>x y. f x = f y \<longrightarrow> x = y)"
   unfolding inj_on_def by blast
 
 lemma injI: "(\<And>x y. f x = f y \<Longrightarrow> x = y) \<Longrightarrow> inj f"
   unfolding inj_def by blast
 
 theorem range_ex1_eq: "inj f \<Longrightarrow> b \<in> range f \<longleftrightarrow> (\<exists>!x. b = f x)"
   unfolding inj_def by blast
 
 lemma injD: "inj f \<Longrightarrow> f x = f y \<Longrightarrow> x = y"
   by (simp add: inj_def)
 
 lemma inj_on_eq_iff: "inj_on f A \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
   by (auto simp: inj_on_def)
 
 lemma inj_on_cong: "(\<And>a. a \<in> A \<Longrightarrow> f a = g a) \<Longrightarrow> inj_on f A \<longleftrightarrow> inj_on g A"
   by (auto simp: inj_on_def)
 
 lemma inj_on_strict_subset: "inj_on f B \<Longrightarrow> A \<subset> B \<Longrightarrow> f ` A \<subset> f ` B"
   unfolding inj_on_def by blast
 
 lemma inj_compose: "inj f \<Longrightarrow> inj g \<Longrightarrow> inj (f \<circ> g)"
   by (simp add: inj_def)
 
 lemma inj_fun: "inj f \<Longrightarrow> inj (\<lambda>x y. f x)"
   by (simp add: inj_def fun_eq_iff)
 
 lemma inj_eq: "inj f \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
   by (simp add: inj_on_eq_iff)
 
 lemma inj_on_iff_Uniq: "inj_on f A \<longleftrightarrow> (\<forall>x\<in>A. \<exists>\<^sub>\<le>\<^sub>1y. y\<in>A \<and> f x = f y)"
   by (auto simp: Uniq_def inj_on_def)
 
 lemma inj_on_id[simp]: "inj_on id A"
   by (simp add: inj_on_def)
 
 lemma inj_on_id2[simp]: "inj_on (\<lambda>x. x) A"
   by (simp add: inj_on_def)
 
 lemma inj_on_Int: "inj_on f A \<or> inj_on f B \<Longrightarrow> inj_on f (A \<inter> B)"
   unfolding inj_on_def by blast
 
 lemma surj_id: "surj id"
   by simp
 
 lemma bij_id[simp]: "bij id"
   by (simp add: bij_betw_def)
 
 lemma bij_uminus: "bij (uminus :: 'a \<Rightarrow> 'a::ab_group_add)"
   unfolding bij_betw_def inj_on_def
   by (force intro: minus_minus [symmetric])
 
 lemma bij_betwE: "bij_betw f A B \<Longrightarrow> \<forall>a\<in>A. f a \<in> B"
   unfolding bij_betw_def by auto
 
 lemma inj_onI [intro?]: "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x = f y \<Longrightarrow> x = y) \<Longrightarrow> inj_on f A"
   by (simp add: inj_on_def)
 
 lemma inj_on_inverseI: "(\<And>x. x \<in> A \<Longrightarrow> g (f x) = x) \<Longrightarrow> inj_on f A"
   by (auto dest: arg_cong [of concl: g] simp add: inj_on_def)
 
 lemma inj_onD: "inj_on f A \<Longrightarrow> f x = f y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x = y"
   unfolding inj_on_def by blast
 
 lemma inj_on_subset:
   assumes "inj_on f A"
     and "B \<subseteq> A"
   shows "inj_on f B"
 proof (rule inj_onI)
   fix a b
   assume "a \<in> B" and "b \<in> B"
   with assms have "a \<in> A" and "b \<in> A"
     by auto
   moreover assume "f a = f b"
   ultimately show "a = b"
     using assms by (auto dest: inj_onD)
 qed
 
 lemma comp_inj_on: "inj_on f A \<Longrightarrow> inj_on g (f ` A) \<Longrightarrow> inj_on (g \<circ> f) A"
   by (simp add: comp_def inj_on_def)
 
 lemma inj_on_imageI: "inj_on (g \<circ> f) A \<Longrightarrow> inj_on g (f ` A)"
   by (auto simp add: inj_on_def)
 
 lemma inj_on_image_iff:
   "\<forall>x\<in>A. \<forall>y\<in>A. g (f x) = g (f y) \<longleftrightarrow> g x = g y \<Longrightarrow> inj_on f A \<Longrightarrow> inj_on g (f ` A) \<longleftrightarrow> inj_on g A"
   unfolding inj_on_def by blast
 
 lemma inj_on_contraD: "inj_on f A \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> f x \<noteq> f y"
   unfolding inj_on_def by blast
 
 lemma inj_singleton [simp]: "inj_on (\<lambda>x. {x}) A"
   by (simp add: inj_on_def)
 
 lemma inj_on_empty[iff]: "inj_on f {}"
   by (simp add: inj_on_def)
 
 lemma subset_inj_on: "inj_on f B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> inj_on f A"
   unfolding inj_on_def by blast
 
 lemma inj_on_Un: "inj_on f (A \<union> B) \<longleftrightarrow> inj_on f A \<and> inj_on f B \<and> f ` (A - B) \<inter> f ` (B - A) = {}"
   unfolding inj_on_def by (blast intro: sym)
 
 lemma inj_on_insert [iff]: "inj_on f (insert a A) \<longleftrightarrow> inj_on f A \<and> f a \<notin> f ` (A - {a})"
   unfolding inj_on_def by (blast intro: sym)
 
 lemma inj_on_diff: "inj_on f A \<Longrightarrow> inj_on f (A - B)"
   unfolding inj_on_def by blast
 
 lemma comp_inj_on_iff: "inj_on f A \<Longrightarrow> inj_on f' (f ` A) \<longleftrightarrow> inj_on (f' \<circ> f) A"
   by (auto simp: comp_inj_on inj_on_def)
 
 lemma inj_on_imageI2: "inj_on (f' \<circ> f) A \<Longrightarrow> inj_on f A"
   by (auto simp: comp_inj_on inj_on_def)
 
 lemma inj_img_insertE:
   assumes "inj_on f A"
   assumes "x \<notin> B"
     and "insert x B = f ` A"
   obtains x' A' where "x' \<notin> A'" and "A = insert x' A'" and "x = f x'" and "B = f ` A'"
 proof -
   from assms have "x \<in> f ` A" by auto
   then obtain x' where *: "x' \<in> A" "x = f x'" by auto
   then have A: "A = insert x' (A - {x'})" by auto
   with assms * have B: "B = f ` (A - {x'})" by (auto dest: inj_on_contraD)
   have "x' \<notin> A - {x'}" by simp
   from this A \<open>x = f x'\<close> B show ?thesis ..
 qed
 
 lemma linorder_inj_onI:
   fixes A :: "'a::order set"
   assumes ne: "\<And>x y. \<lbrakk>x < y; x\<in>A; y\<in>A\<rbrakk> \<Longrightarrow> f x \<noteq> f y" and lin: "\<And>x y. \<lbrakk>x\<in>A; y\<in>A\<rbrakk> \<Longrightarrow> x\<le>y \<or> y\<le>x"
   shows "inj_on f A"
 proof (rule inj_onI)
   fix x y
   assume eq: "f x = f y" and "x\<in>A" "y\<in>A"
   then show "x = y"
     using lin [of x y] ne by (force simp: dual_order.order_iff_strict)
 qed
 
 lemma linorder_injI:
   assumes "\<And>x y::'a::linorder. x < y \<Longrightarrow> f x \<noteq> f y"
   shows "inj f"
     \<comment> \<open>Courtesy of Stephan Merz\<close>
 using assms by (auto intro: linorder_inj_onI linear)
 
 lemma inj_on_image_Pow: "inj_on f A \<Longrightarrow>inj_on (image f) (Pow A)"
   unfolding Pow_def inj_on_def by blast
 
 lemma bij_betw_image_Pow: "bij_betw f A B \<Longrightarrow> bij_betw (image f) (Pow A) (Pow B)"
   by (auto simp add: bij_betw_def inj_on_image_Pow image_Pow_surj)
 
 lemma surj_def: "surj f \<longleftrightarrow> (\<forall>y. \<exists>x. y = f x)"
   by auto
 
 lemma surjI:
   assumes "\<And>x. g (f x) = x"
   shows "surj g"
   using assms [symmetric] by auto
 
 lemma surjD: "surj f \<Longrightarrow> \<exists>x. y = f x"
   by (simp add: surj_def)
 
 lemma surjE: "surj f \<Longrightarrow> (\<And>x. y = f x \<Longrightarrow> C) \<Longrightarrow> C"
   by (simp add: surj_def) blast
 
 lemma comp_surj: "surj f \<Longrightarrow> surj g \<Longrightarrow> surj (g \<circ> f)"
   using image_comp [of g f UNIV] by simp
 
 lemma bij_betw_imageI: "inj_on f A \<Longrightarrow> f ` A = B \<Longrightarrow> bij_betw f A B"
   unfolding bij_betw_def by clarify
 
 lemma bij_betw_imp_surj_on: "bij_betw f A B \<Longrightarrow> f ` A = B"
   unfolding bij_betw_def by clarify
 
 lemma bij_betw_imp_surj: "bij_betw f A UNIV \<Longrightarrow> surj f"
   unfolding bij_betw_def by auto
 
 lemma bij_betw_empty1: "bij_betw f {} A \<Longrightarrow> A = {}"
   unfolding bij_betw_def by blast
 
 lemma bij_betw_empty2: "bij_betw f A {} \<Longrightarrow> A = {}"
   unfolding bij_betw_def by blast
 
 lemma inj_on_imp_bij_betw: "inj_on f A \<Longrightarrow> bij_betw f A (f ` A)"
   unfolding bij_betw_def by simp
 
 lemma bij_betw_apply: "\<lbrakk>bij_betw f A B; a \<in> A\<rbrakk> \<Longrightarrow> f a \<in> B"
   unfolding bij_betw_def by auto
 
 lemma bij_def: "bij f \<longleftrightarrow> inj f \<and> surj f"
   by (rule bij_betw_def)
 
 lemma bijI: "inj f \<Longrightarrow> surj f \<Longrightarrow> bij f"
   by (rule bij_betw_imageI)
 
 lemma bij_is_inj: "bij f \<Longrightarrow> inj f"
   by (simp add: bij_def)
 
 lemma bij_is_surj: "bij f \<Longrightarrow> surj f"
   by (simp add: bij_def)
 
 lemma bij_betw_imp_inj_on: "bij_betw f A B \<Longrightarrow> inj_on f A"
   by (simp add: bij_betw_def)
 
 lemma bij_betw_trans: "bij_betw f A B \<Longrightarrow> bij_betw g B C \<Longrightarrow> bij_betw (g \<circ> f) A C"
   by (auto simp add:bij_betw_def comp_inj_on)
 
 lemma bij_comp: "bij f \<Longrightarrow> bij g \<Longrightarrow> bij (g \<circ> f)"
   by (rule bij_betw_trans)
 
 lemma bij_betw_comp_iff: "bij_betw f A A' \<Longrightarrow> bij_betw f' A' A'' \<longleftrightarrow> bij_betw (f' \<circ> f) A A''"
   by (auto simp add: bij_betw_def inj_on_def)
 
 lemma bij_betw_comp_iff2:
   assumes bij: "bij_betw f' A' A''"
     and img: "f ` A \<le> A'"
-  shows "bij_betw f A A' \<longleftrightarrow> bij_betw (f' \<circ> f) A A''"
-  using assms
-proof (auto simp add: bij_betw_comp_iff)
-  assume *: "bij_betw (f' \<circ> f) A A''"
-  then show "bij_betw f A A'"
-    using img
-  proof (auto simp add: bij_betw_def)
-    assume "inj_on (f' \<circ> f) A"
-    then show "inj_on f A"
-      using inj_on_imageI2 by blast
+  shows "bij_betw f A A' \<longleftrightarrow> bij_betw (f' \<circ> f) A A''" (is "?L \<longleftrightarrow> ?R")
+proof
+  assume "?L"
+  then show "?R"
+    using assms by (auto simp add: bij_betw_comp_iff)
   next
-    fix a'
-    assume **: "a' \<in> A'"
-    with bij have "f' a' \<in> A''"
-      unfolding bij_betw_def by auto
-    with * obtain a where 1: "a \<in> A \<and> f' (f a) = f' a'"
-      unfolding bij_betw_def by force
-    with img have "f a \<in> A'" by auto
-    with bij ** 1 have "f a = a'"
-      unfolding bij_betw_def inj_on_def by auto
-    with 1 show "a' \<in> f ` A" by auto
-  qed
+    assume *: "?R"
+    have "inj_on (f' \<circ> f) A \<Longrightarrow> inj_on f A"
+      using inj_on_imageI2 by blast
+    moreover have "A' \<subseteq> f ` A"
+    proof
+      fix a'
+      assume **: "a' \<in> A'"
+      with bij have "f' a' \<in> A''"
+        unfolding bij_betw_def by auto
+      with * obtain a where 1: "a \<in> A \<and> f' (f a) = f' a'"
+        unfolding bij_betw_def by force
+      with img have "f a \<in> A'" by auto
+      with bij ** 1 have "f a = a'"
+        unfolding bij_betw_def inj_on_def by auto
+      with 1 show "a' \<in> f ` A" by auto
+    qed
+    ultimately show "?L"
+      using img * by (auto simp add: bij_betw_def)
 qed
 
 lemma bij_betw_inv:
   assumes "bij_betw f A B"
   shows "\<exists>g. bij_betw g B A"
 proof -
   have i: "inj_on f A" and s: "f ` A = B"
     using assms by (auto simp: bij_betw_def)
   let ?P = "\<lambda>b a. a \<in> A \<and> f a = b"
   let ?g = "\<lambda>b. The (?P b)"
   have g: "?g b = a" if P: "?P b a" for a b
   proof -
     from that s have ex1: "\<exists>a. ?P b a" by blast
     then have uex1: "\<exists>!a. ?P b a" by (blast dest:inj_onD[OF i])
     then show ?thesis
       using the1_equality[OF uex1, OF P] P by simp
   qed
   have "inj_on ?g B"
   proof (rule inj_onI)
     fix x y
     assume "x \<in> B" "y \<in> B" "?g x = ?g y"
     from s \<open>x \<in> B\<close> obtain a1 where a1: "?P x a1" by blast
     from s \<open>y \<in> B\<close> obtain a2 where a2: "?P y a2" by blast
     from g [OF a1] a1 g [OF a2] a2 \<open>?g x = ?g y\<close> show "x = y" by simp
   qed
   moreover have "?g ` B = A"
-  proof (auto simp: image_def)
+  proof safe
     fix b
     assume "b \<in> B"
     with s obtain a where P: "?P b a" by blast
     with g[OF P] show "?g b \<in> A" by auto
   next
     fix a
     assume "a \<in> A"
     with s obtain b where P: "?P b a" by blast
     with s have "b \<in> B" by blast
-    with g[OF P] show "\<exists>b\<in>B. a = ?g b" by blast
+    with g[OF P] have "\<exists>b\<in>B. a = ?g b" by blast
+    then show "a \<in> ?g ` B"
+      by auto
   qed
   ultimately show ?thesis
     by (auto simp: bij_betw_def)
 qed
 
 lemma bij_betw_cong: "(\<And>a. a \<in> A \<Longrightarrow> f a = g a) \<Longrightarrow> bij_betw f A A' = bij_betw g A A'"
   unfolding bij_betw_def inj_on_def by safe force+  (* somewhat slow *)
 
 lemma bij_betw_id[intro, simp]: "bij_betw id A A"
   unfolding bij_betw_def id_def by auto
 
 lemma bij_betw_id_iff: "bij_betw id A B \<longleftrightarrow> A = B"
   by (auto simp add: bij_betw_def)
 
 lemma bij_betw_combine:
   "bij_betw f A B \<Longrightarrow> bij_betw f C D \<Longrightarrow> B \<inter> D = {} \<Longrightarrow> bij_betw f (A \<union> C) (B \<union> D)"
   unfolding bij_betw_def inj_on_Un image_Un by auto
 
 lemma bij_betw_subset: "bij_betw f A A' \<Longrightarrow> B \<subseteq> A \<Longrightarrow> f ` B = B' \<Longrightarrow> bij_betw f B B'"
   by (auto simp add: bij_betw_def inj_on_def)
 
 lemma bij_betw_ball: "bij_betw f A B \<Longrightarrow> (\<forall>b \<in> B. phi b) = (\<forall>a \<in> A. phi (f a))"
   unfolding bij_betw_def inj_on_def by blast
 
 lemma bij_pointE:
   assumes "bij f"
   obtains x where "y = f x" and "\<And>x'. y = f x' \<Longrightarrow> x' = x"
 proof -
   from assms have "inj f" by (rule bij_is_inj)
   moreover from assms have "surj f" by (rule bij_is_surj)
   then have "y \<in> range f" by simp
   ultimately have "\<exists>!x. y = f x" by (simp add: range_ex1_eq)
   with that show thesis by blast
 qed
 
 lemma bij_iff: \<^marker>\<open>contributor \<open>Amine Chaieb\<close>\<close>
   \<open>bij f \<longleftrightarrow> (\<forall>x. \<exists>!y. f y = x)\<close>  (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?P
   then have \<open>inj f\<close> \<open>surj f\<close>
     by (simp_all add: bij_def)
   show ?Q
   proof
     fix y
     from \<open>surj f\<close> obtain x where \<open>y = f x\<close>
       by (auto simp add: surj_def)
     with \<open>inj f\<close> show \<open>\<exists>!x. f x = y\<close>
       by (auto simp add: inj_def)
   qed
 next
   assume ?Q
   then have \<open>inj f\<close>
     by (auto simp add: inj_def)
   moreover have \<open>\<exists>x. y = f x\<close> for y
   proof -
     from \<open>?Q\<close> obtain x where \<open>f x = y\<close>
       by blast
     then have \<open>y = f x\<close>
       by simp
     then show ?thesis ..
   qed
   then have \<open>surj f\<close>
     by (auto simp add: surj_def)
   ultimately show ?P
     by (rule bijI)
 qed
 
 lemma bij_betw_partition:
   \<open>bij_betw f A B\<close>
   if \<open>bij_betw f (A \<union> C) (B \<union> D)\<close> \<open>bij_betw f C D\<close> \<open>A \<inter> C = {}\<close> \<open>B \<inter> D = {}\<close>
 proof -
   from that have \<open>inj_on f (A \<union> C)\<close> \<open>inj_on f C\<close> \<open>f ` (A \<union> C) = B \<union> D\<close> \<open>f ` C = D\<close>
     by (simp_all add: bij_betw_def)
   then have \<open>inj_on f A\<close> and \<open>f ` (A - C) \<inter> f ` (C - A) = {}\<close>
     by (simp_all add: inj_on_Un)
   with \<open>A \<inter> C = {}\<close> have \<open>f ` A \<inter> f ` C = {}\<close>
     by auto
   with \<open>f ` (A \<union> C) = B \<union> D\<close> \<open>f ` C = D\<close>  \<open>B \<inter> D = {}\<close>
   have \<open>f ` A = B\<close>
     by blast
   with \<open>inj_on f A\<close> show ?thesis
     by (simp add: bij_betw_def)
 qed
 
 lemma surj_image_vimage_eq: "surj f \<Longrightarrow> f ` (f -` A) = A"
   by simp
 
 lemma surj_vimage_empty:
   assumes "surj f"
   shows "f -` A = {} \<longleftrightarrow> A = {}"
   using surj_image_vimage_eq [OF \<open>surj f\<close>, of A]
   by (intro iffI) fastforce+
 
 lemma inj_vimage_image_eq: "inj f \<Longrightarrow> f -` (f ` A) = A"
   unfolding inj_def by blast
 
 lemma vimage_subsetD: "surj f \<Longrightarrow> f -` B \<subseteq> A \<Longrightarrow> B \<subseteq> f ` A"
   by (blast intro: sym)
 
 lemma vimage_subsetI: "inj f \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> f -` B \<subseteq> A"
   unfolding inj_def by blast
 
 lemma vimage_subset_eq: "bij f \<Longrightarrow> f -` B \<subseteq> A \<longleftrightarrow> B \<subseteq> f ` A"
   unfolding bij_def by (blast del: subsetI intro: vimage_subsetI vimage_subsetD)
 
 lemma inj_on_image_eq_iff: "inj_on f C \<Longrightarrow> A \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
   by (fastforce simp: inj_on_def)
 
 lemma inj_on_Un_image_eq_iff: "inj_on f (A \<union> B) \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
   by (erule inj_on_image_eq_iff) simp_all
 
 lemma inj_on_image_Int: "inj_on f C \<Longrightarrow> A \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
   unfolding inj_on_def by blast
 
 lemma inj_on_image_set_diff: "inj_on f C \<Longrightarrow> A - B \<subseteq> C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> f ` (A - B) = f ` A - f ` B"
   unfolding inj_on_def by blast
 
 lemma image_Int: "inj f \<Longrightarrow> f ` (A \<inter> B) = f ` A \<inter> f ` B"
   unfolding inj_def by blast
 
 lemma image_set_diff: "inj f \<Longrightarrow> f ` (A - B) = f ` A - f ` B"
   unfolding inj_def by blast
 
 lemma inj_on_image_mem_iff: "inj_on f B \<Longrightarrow> a \<in> B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> f a \<in> f ` A \<longleftrightarrow> a \<in> A"
   by (auto simp: inj_on_def)
 
 lemma inj_image_mem_iff: "inj f \<Longrightarrow> f a \<in> f ` A \<longleftrightarrow> a \<in> A"
   by (blast dest: injD)
 
 lemma inj_image_subset_iff: "inj f \<Longrightarrow> f ` A \<subseteq> f ` B \<longleftrightarrow> A \<subseteq> B"
   by (blast dest: injD)
 
 lemma inj_image_eq_iff: "inj f \<Longrightarrow> f ` A = f ` B \<longleftrightarrow> A = B"
   by (blast dest: injD)
 
 lemma surj_Compl_image_subset: "surj f \<Longrightarrow> - (f ` A) \<subseteq> f ` (- A)"
   by auto
 
 lemma inj_image_Compl_subset: "inj f \<Longrightarrow> f ` (- A) \<subseteq> - (f ` A)"
   by (auto simp: inj_def)
 
 lemma bij_image_Compl_eq: "bij f \<Longrightarrow> f ` (- A) = - (f ` A)"
   by (simp add: bij_def inj_image_Compl_subset surj_Compl_image_subset equalityI)
 
 lemma inj_vimage_singleton: "inj f \<Longrightarrow> f -` {a} \<subseteq> {THE x. f x = a}"
   \<comment> \<open>The inverse image of a singleton under an injective function is included in a singleton.\<close>
   by (simp add: inj_def) (blast intro: the_equality [symmetric])
 
 lemma inj_on_vimage_singleton: "inj_on f A \<Longrightarrow> f -` {a} \<inter> A \<subseteq> {THE x. x \<in> A \<and> f x = a}"
   by (auto simp add: inj_on_def intro: the_equality [symmetric])
 
 lemma (in ordered_ab_group_add) inj_uminus[simp, intro]: "inj_on uminus A"
   by (auto intro!: inj_onI)
 
 lemma (in linorder) strict_mono_imp_inj_on: "strict_mono f \<Longrightarrow> inj_on f A"
   by (auto intro!: inj_onI dest: strict_mono_eq)
 
 lemma bij_betw_byWitness:
   assumes left: "\<forall>a \<in> A. f' (f a) = a"
     and right: "\<forall>a' \<in> A'. f (f' a') = a'"
     and "f ` A \<subseteq> A'"
     and img2: "f' ` A' \<subseteq> A"
   shows "bij_betw f A A'"
   using assms
   unfolding bij_betw_def inj_on_def
 proof safe
   fix a b
   assume "a \<in> A" "b \<in> A"
   with left have "a = f' (f a) \<and> b = f' (f b)" by simp
   moreover assume "f a = f b"
   ultimately show "a = b" by simp
 next
   fix a' assume *: "a' \<in> A'"
   with img2 have "f' a' \<in> A" by blast
   moreover from * right have "a' = f (f' a')" by simp
   ultimately show "a' \<in> f ` A" by blast
 qed
 
 corollary notIn_Un_bij_betw:
   assumes "b \<notin> A"
     and "f b \<notin> A'"
     and "bij_betw f A A'"
   shows "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
 proof -
   have "bij_betw f {b} {f b}"
     unfolding bij_betw_def inj_on_def by simp
   with assms show ?thesis
     using bij_betw_combine[of f A A' "{b}" "{f b}"] by blast
 qed
 
 lemma notIn_Un_bij_betw3:
   assumes "b \<notin> A"
     and "f b \<notin> A'"
   shows "bij_betw f A A' = bij_betw f (A \<union> {b}) (A' \<union> {f b})"
 proof
   assume "bij_betw f A A'"
   then show "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
     using assms notIn_Un_bij_betw [of b A f A'] by blast
 next
   assume *: "bij_betw f (A \<union> {b}) (A' \<union> {f b})"
   have "f ` A = A'"
-  proof auto
+  proof safe
     fix a
     assume **: "a \<in> A"
     then have "f a \<in> A' \<union> {f b}"
       using * unfolding bij_betw_def by blast
     moreover
     have False if "f a = f b"
     proof -
       have "a = b"
         using * ** that unfolding bij_betw_def inj_on_def by blast
       with \<open>b \<notin> A\<close> ** show ?thesis by blast
     qed
     ultimately show "f a \<in> A'" by blast
   next
     fix a'
     assume **: "a' \<in> A'"
     then have "a' \<in> f ` (A \<union> {b})"
       using * by (auto simp add: bij_betw_def)
     then obtain a where 1: "a \<in> A \<union> {b} \<and> f a = a'" by blast
     moreover
     have False if "a = b" using 1 ** \<open>f b \<notin> A'\<close> that by blast
     ultimately have "a \<in> A" by blast
     with 1 show "a' \<in> f ` A" by blast
   qed
   then show "bij_betw f A A'"
     using * bij_betw_subset[of f "A \<union> {b}" _ A] by blast
 qed
 
 lemma inj_on_disjoint_Un:
   assumes "inj_on f A" and "inj_on g B" 
   and "f ` A \<inter> g ` B = {}"
   shows "inj_on (\<lambda>x. if x \<in> A then f x else g x) (A \<union> B)"
   using assms by (simp add: inj_on_def disjoint_iff) (blast)
 
 lemma bij_betw_disjoint_Un:
   assumes "bij_betw f A C" and "bij_betw g B D" 
   and "A \<inter> B = {}"
   and "C \<inter> D = {}"
   shows "bij_betw (\<lambda>x. if x \<in> A then f x else g x) (A \<union> B) (C \<union> D)"
   using assms by (auto simp: inj_on_disjoint_Un bij_betw_def)
 
 lemma involuntory_imp_bij:
   \<open>bij f\<close> if \<open>\<And>x. f (f x) = x\<close>
 proof (rule bijI)
   from that show \<open>surj f\<close>
     by (rule surjI)
   show \<open>inj f\<close>
   proof (rule injI)
     fix x y
     assume \<open>f x = f y\<close>
     then have \<open>f (f x) = f (f y)\<close>
       by simp
     then show \<open>x = y\<close>
       by (simp add: that)
   qed
 qed
 
 
 subsubsection \<open>Important examples\<close>
 
 context cancel_semigroup_add
 begin
 
 lemma inj_on_add [simp]:
   "inj_on ((+) a) A"
   by (rule inj_onI) simp
 
 lemma inj_add_left:
   \<open>inj ((+) a)\<close>
   by simp
 
 lemma inj_on_add' [simp]:
   "inj_on (\<lambda>b. b + a) A"
   by (rule inj_onI) simp
 
 lemma bij_betw_add [simp]:
   "bij_betw ((+) a) A B \<longleftrightarrow> (+) a ` A = B"
   by (simp add: bij_betw_def)
 
 end
 
 context ab_group_add
 begin
 
 lemma surj_plus [simp]:
   "surj ((+) a)"
   by (auto intro!: range_eqI [of b "(+) a" "b - a" for b]) (simp add: algebra_simps)
 
 lemma inj_diff_right [simp]:
   \<open>inj (\<lambda>b. b - a)\<close>
 proof -
   have \<open>inj ((+) (- a))\<close>
     by (fact inj_add_left)
   also have \<open>(+) (- a) = (\<lambda>b. b - a)\<close>
     by (simp add: fun_eq_iff)
   finally show ?thesis .
 qed
 
 lemma surj_diff_right [simp]:
   "surj (\<lambda>x. x - a)"
   using surj_plus [of "- a"] by (simp cong: image_cong_simp)
 
 lemma translation_Compl:
   "(+) a ` (- t) = - ((+) a ` t)"
 proof (rule set_eqI)
   fix b
   show "b \<in> (+) a ` (- t) \<longleftrightarrow> b \<in> - (+) a ` t"
     by (auto simp: image_iff algebra_simps intro!: bexI [of _ "b - a"])
 qed
 
 lemma translation_subtract_Compl:
   "(\<lambda>x. x - a) ` (- t) = - ((\<lambda>x. x - a) ` t)"
   using translation_Compl [of "- a" t] by (simp cong: image_cong_simp)
 
 lemma translation_diff:
   "(+) a ` (s - t) = ((+) a ` s) - ((+) a ` t)"
   by auto
 
 lemma translation_subtract_diff:
   "(\<lambda>x. x - a) ` (s - t) = ((\<lambda>x. x - a) ` s) - ((\<lambda>x. x - a) ` t)"
   using translation_diff [of "- a"] by (simp cong: image_cong_simp)
 
 lemma translation_Int:
   "(+) a ` (s \<inter> t) = ((+) a ` s) \<inter> ((+) a ` t)"
   by auto
 
 lemma translation_subtract_Int:
   "(\<lambda>x. x - a) ` (s \<inter> t) = ((\<lambda>x. x - a) ` s) \<inter> ((\<lambda>x. x - a) ` t)"
   using translation_Int [of " -a"] by (simp cong: image_cong_simp)
 
 end
 
 
 subsection \<open>Function Updating\<close>
 
 definition fun_upd :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)"
   where "fun_upd f a b = (\<lambda>x. if x = a then b else f x)"
 
 nonterminal updbinds and updbind
 
 syntax
   "_updbind" :: "'a \<Rightarrow> 'a \<Rightarrow> updbind"             ("(2_ :=/ _)")
   ""         :: "updbind \<Rightarrow> updbinds"             ("_")
   "_updbinds":: "updbind \<Rightarrow> updbinds \<Rightarrow> updbinds" ("_,/ _")
   "_Update"  :: "'a \<Rightarrow> updbinds \<Rightarrow> 'a"            ("_/'((_)')" [1000, 0] 900)
 
 translations
   "_Update f (_updbinds b bs)" \<rightleftharpoons> "_Update (_Update f b) bs"
   "f(x:=y)" \<rightleftharpoons> "CONST fun_upd f x y"
 
 (* Hint: to define the sum of two functions (or maps), use case_sum.
          A nice infix syntax could be defined by
 notation
   case_sum  (infixr "'(+')"80)
 *)
 
 lemma fun_upd_idem_iff: "f(x:=y) = f \<longleftrightarrow> f x = y"
   unfolding fun_upd_def
   apply safe
    apply (erule subst)
-   apply (rule_tac [2] ext)
    apply auto
   done
 
 lemma fun_upd_idem: "f x = y \<Longrightarrow> f(x := y) = f"
   by (simp only: fun_upd_idem_iff)
 
 lemma fun_upd_triv [iff]: "f(x := f x) = f"
   by (simp only: fun_upd_idem)
 
 lemma fun_upd_apply [simp]: "(f(x := y)) z = (if z = x then y else f z)"
   by (simp add: fun_upd_def)
 
 (* fun_upd_apply supersedes these two, but they are useful
    if fun_upd_apply is intentionally removed from the simpset *)
 lemma fun_upd_same: "(f(x := y)) x = y"
   by simp
 
 lemma fun_upd_other: "z \<noteq> x \<Longrightarrow> (f(x := y)) z = f z"
   by simp
 
 lemma fun_upd_upd [simp]: "f(x := y, x := z) = f(x := z)"
   by (simp add: fun_eq_iff)
 
 lemma fun_upd_twist: "a \<noteq> c \<Longrightarrow> (m(a := b))(c := d) = (m(c := d))(a := b)"
   by auto
 
 lemma inj_on_fun_updI: "inj_on f A \<Longrightarrow> y \<notin> f ` A \<Longrightarrow> inj_on (f(x := y)) A"
   by (auto simp: inj_on_def)
 
 lemma fun_upd_image: "f(x := y) ` A = (if x \<in> A then insert y (f ` (A - {x})) else f ` A)"
   by auto
 
 lemma fun_upd_comp: "f \<circ> (g(x := y)) = (f \<circ> g)(x := f y)"
   by auto
 
 lemma fun_upd_eqD: "f(x := y) = g(x := z) \<Longrightarrow> y = z"
   by (simp add: fun_eq_iff split: if_split_asm)
 
 
 subsection \<open>\<open>override_on\<close>\<close>
 
 definition override_on :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'a \<Rightarrow> 'b"
   where "override_on f g A = (\<lambda>a. if a \<in> A then g a else f a)"
 
 lemma override_on_emptyset[simp]: "override_on f g {} = f"
   by (simp add: override_on_def)
 
 lemma override_on_apply_notin[simp]: "a \<notin> A \<Longrightarrow> (override_on f g A) a = f a"
   by (simp add: override_on_def)
 
 lemma override_on_apply_in[simp]: "a \<in> A \<Longrightarrow> (override_on f g A) a = g a"
   by (simp add: override_on_def)
 
 lemma override_on_insert: "override_on f g (insert x X) = (override_on f g X)(x:=g x)"
   by (simp add: override_on_def fun_eq_iff)
 
 lemma override_on_insert': "override_on f g (insert x X) = (override_on (f(x:=g x)) g X)"
   by (simp add: override_on_def fun_eq_iff)
 
 
 subsection \<open>Inversion of injective functions\<close>
 
 definition the_inv_into :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
   where "the_inv_into A f = (\<lambda>x. THE y. y \<in> A \<and> f y = x)"
 
 lemma the_inv_into_f_f: "inj_on f A \<Longrightarrow> x \<in> A \<Longrightarrow> the_inv_into A f (f x) = x"
   unfolding the_inv_into_def inj_on_def by blast
 
 lemma f_the_inv_into_f: "inj_on f A \<Longrightarrow> y \<in> f ` A  \<Longrightarrow> f (the_inv_into A f y) = y"
   unfolding the_inv_into_def
   by (rule the1I2; blast dest: inj_onD)
 
 lemma f_the_inv_into_f_bij_betw:
   "bij_betw f A B \<Longrightarrow> (bij_betw f A B \<Longrightarrow> x \<in> B) \<Longrightarrow> f (the_inv_into A f x) = x"
   unfolding bij_betw_def by (blast intro: f_the_inv_into_f)
 
 lemma the_inv_into_into: "inj_on f A \<Longrightarrow> x \<in> f ` A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> the_inv_into A f x \<in> B"
   unfolding the_inv_into_def
   by (rule the1I2; blast dest: inj_onD)
 
 lemma the_inv_into_onto [simp]: "inj_on f A \<Longrightarrow> the_inv_into A f ` (f ` A) = A"
   by (fast intro: the_inv_into_into the_inv_into_f_f [symmetric])
 
 lemma the_inv_into_f_eq: "inj_on f A \<Longrightarrow> f x = y \<Longrightarrow> x \<in> A \<Longrightarrow> the_inv_into A f y = x"
   by (force simp add: the_inv_into_f_f)
 
 lemma the_inv_into_comp:
   "inj_on f (g ` A) \<Longrightarrow> inj_on g A \<Longrightarrow> x \<in> f ` g ` A \<Longrightarrow>
     the_inv_into A (f \<circ> g) x = (the_inv_into A g \<circ> the_inv_into (g ` A) f) x"
   apply (rule the_inv_into_f_eq)
     apply (fast intro: comp_inj_on)
    apply (simp add: f_the_inv_into_f the_inv_into_into)
   apply (simp add: the_inv_into_into)
   done
 
 lemma inj_on_the_inv_into: "inj_on f A \<Longrightarrow> inj_on (the_inv_into A f) (f ` A)"
   by (auto intro: inj_onI simp: the_inv_into_f_f)
 
 lemma bij_betw_the_inv_into: "bij_betw f A B \<Longrightarrow> bij_betw (the_inv_into A f) B A"
   by (auto simp add: bij_betw_def inj_on_the_inv_into the_inv_into_into)
 
 lemma bij_betw_iff_bijections:
   "bij_betw f A B \<longleftrightarrow> (\<exists>g. (\<forall>x \<in> A. f x \<in> B \<and> g(f x) = x) \<and> (\<forall>y \<in> B. g y \<in> A \<and> f(g y) = y))"
   (is "?lhs = ?rhs")
 proof
-  assume L: ?lhs
-  then show ?rhs
-    apply (rule_tac x="the_inv_into A f" in exI)
-    apply (auto simp: bij_betw_def f_the_inv_into_f the_inv_into_f_f the_inv_into_into)
-    done
-qed (force intro: bij_betw_byWitness)
+  show "?lhs \<Longrightarrow> ?rhs"
+    by (auto simp: bij_betw_def f_the_inv_into_f the_inv_into_f_f the_inv_into_into
+        exI[where ?x="the_inv_into A f"])
+next
+  show "?rhs \<Longrightarrow> ?lhs"
+    by (force intro: bij_betw_byWitness)
+qed
 
 abbreviation the_inv :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> 'a)"
   where "the_inv f \<equiv> the_inv_into UNIV f"
 
 lemma the_inv_f_f: "the_inv f (f x) = x" if "inj f"
   using that UNIV_I by (rule the_inv_into_f_f)
 
 
 subsection \<open>Cantor's Paradox\<close>
 
 theorem Cantors_paradox: "\<nexists>f. f ` A = Pow A"
 proof
   assume "\<exists>f. f ` A = Pow A"
   then obtain f where f: "f ` A = Pow A" ..
   let ?X = "{a \<in> A. a \<notin> f a}"
   have "?X \<in> Pow A" by blast
   then have "?X \<in> f ` A" by (simp only: f)
   then obtain x where "x \<in> A" and "f x = ?X" by blast
   then show False by blast
 qed
 
 
 subsection \<open>Monotonic functions over a set\<close>
 
 definition monotone_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "monotone_on A orda ordb f \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>A. orda x y \<longrightarrow> ordb (f x) (f y))"
 
 abbreviation monotone :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
   where "monotone \<equiv> monotone_on UNIV"
 
 lemma monotone_def[no_atp]: "monotone orda ordb f \<longleftrightarrow> (\<forall>x y. orda x y \<longrightarrow> ordb (f x) (f y))"
   by (simp add: monotone_on_def)
 
 text \<open>Lemma @{thm [source] monotone_def} is provided for backward compatibility.\<close>
 
 lemma monotone_onI:
   "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)) \<Longrightarrow> monotone_on A orda ordb f"
   by (simp add: monotone_on_def)
 
 lemma monotoneI[intro?]: "(\<And>x y. orda x y \<Longrightarrow> ordb (f x) (f y)) \<Longrightarrow> monotone orda ordb f"
   by (rule monotone_onI)
 
 lemma monotone_onD:
   "monotone_on A orda ordb f \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)"
   by (simp add: monotone_on_def)
 
 lemma monotoneD[dest?]: "monotone orda ordb f \<Longrightarrow> orda x y \<Longrightarrow> ordb (f x) (f y)"
   by (rule monotone_onD[of UNIV, simplified])
 
 lemma monotone_on_subset: "monotone_on A orda ordb f \<Longrightarrow> B \<subseteq> A \<Longrightarrow> monotone_on B orda ordb f"
   by (auto intro: monotone_onI dest: monotone_onD)
 
 lemma monotone_on_empty[simp]: "monotone_on {} orda ordb f"
   by (auto intro: monotone_onI dest: monotone_onD)
 
 lemma monotone_on_o:
   assumes
     mono_f: "monotone_on A orda ordb f" and
     mono_g: "monotone_on B ordc orda g" and
     "g ` B \<subseteq> A"
   shows "monotone_on B ordc ordb (f \<circ> g)"
 proof (rule monotone_onI)
   fix x y assume "x \<in> B" and "y \<in> B" and "ordc x y"
   hence "orda (g x) (g y)"
     by (rule mono_g[THEN monotone_onD])
   moreover from \<open>g ` B \<subseteq> A\<close> \<open>x \<in> B\<close> \<open>y \<in> B\<close> have "g x \<in> A" and "g y \<in> A"
     unfolding image_subset_iff by simp_all
   ultimately show "ordb ((f \<circ> g) x) ((f \<circ> g) y)"
     using mono_f[THEN monotone_onD] by simp
 qed
 
 abbreviation mono_on :: "('a :: ord) set \<Rightarrow> ('a \<Rightarrow> 'b :: ord) \<Rightarrow> bool"
   where "mono_on A \<equiv> monotone_on A (\<le>) (\<le>)"
 
 lemma mono_on_def: "mono_on A f \<longleftrightarrow> (\<forall>r s. r \<in> A \<and> s \<in> A \<and> r \<le> s \<longrightarrow> f r \<le> f s)"
   by (auto simp add: monotone_on_def)
 
 lemma mono_onI:
   "(\<And>r s. r \<in> A \<Longrightarrow> s \<in> A \<Longrightarrow> r \<le> s \<Longrightarrow> f r \<le> f s) \<Longrightarrow> mono_on A f"
   by (rule monotone_onI)
 
 lemma mono_onD:
   "\<lbrakk>mono_on A f; r \<in> A; s \<in> A; r \<le> s\<rbrakk> \<Longrightarrow> f r \<le> f s"
   by (rule monotone_onD)
 
 lemma mono_imp_mono_on: "mono f \<Longrightarrow> mono_on A f"
   unfolding mono_def mono_on_def by auto
 
 lemma mono_on_subset: "mono_on A f \<Longrightarrow> B \<subseteq> A \<Longrightarrow> mono_on B f"
   by (rule monotone_on_subset)
 
 abbreviation strict_mono_on :: "('a :: ord) set \<Rightarrow> ('a \<Rightarrow> 'b :: ord) \<Rightarrow> bool"
   where "strict_mono_on A \<equiv> monotone_on A (<) (<)"
 
 lemma strict_mono_on_def: "strict_mono_on A f \<longleftrightarrow> (\<forall>r s. r \<in> A \<and> s \<in> A \<and> r < s \<longrightarrow> f r < f s)"
   by (auto simp add: monotone_on_def)
 
 lemma strict_mono_onI:
   "(\<And>r s. r \<in> A \<Longrightarrow> s \<in> A \<Longrightarrow> r < s \<Longrightarrow> f r < f s) \<Longrightarrow> strict_mono_on A f"
   by (rule monotone_onI)
 
 lemma strict_mono_onD:
   "\<lbrakk>strict_mono_on A f; r \<in> A; s \<in> A; r < s\<rbrakk> \<Longrightarrow> f r < f s"
   by (rule monotone_onD)
 
 lemma mono_on_greaterD:
   assumes "mono_on A g" "x \<in> A" "y \<in> A" "g x > (g (y::_::linorder) :: _ :: linorder)"
   shows "x > y"
 proof (rule ccontr)
   assume "\<not>x > y"
   hence "x \<le> y" by (simp add: not_less)
   from assms(1-3) and this have "g x \<le> g y" by (rule mono_onD)
   with assms(4) show False by simp
 qed
 
 lemma strict_mono_inv:
   fixes f :: "('a::linorder) \<Rightarrow> ('b::linorder)"
   assumes "strict_mono f" and "surj f" and inv: "\<And>x. g (f x) = x"
   shows "strict_mono g"
 proof
   fix x y :: 'b assume "x < y"
   from \<open>surj f\<close> obtain x' y' where [simp]: "x = f x'" "y = f y'" by blast
   with \<open>x < y\<close> and \<open>strict_mono f\<close> have "x' < y'" by (simp add: strict_mono_less)
   with inv show "g x < g y" by simp
 qed
 
 lemma strict_mono_on_imp_inj_on:
   assumes "strict_mono_on A (f :: (_ :: linorder) \<Rightarrow> (_ :: preorder))"
   shows "inj_on f A"
 proof (rule inj_onI)
   fix x y assume "x \<in> A" "y \<in> A" "f x = f y"
   thus "x = y"
     by (cases x y rule: linorder_cases)
        (auto dest: strict_mono_onD[OF assms, of x y] strict_mono_onD[OF assms, of y x])
 qed
 
 lemma strict_mono_on_leD:
   assumes "strict_mono_on A (f :: (_ :: linorder) \<Rightarrow> _ :: preorder)" "x \<in> A" "y \<in> A" "x \<le> y"
   shows "f x \<le> f y"
-proof (insert le_less_linear[of y x], elim disjE)
-  assume "x < y"
-  with assms have "f x < f y" by (rule_tac strict_mono_onD[OF assms(1)]) simp_all
-  thus ?thesis by (rule less_imp_le)
-qed (insert assms, simp)
+proof (cases "x = y")
+  case True
+  then show ?thesis by simp
+next
+  case False
+  with assms have "f x < f y"
+    using strict_mono_onD[OF assms(1)] by simp
+  then show ?thesis by (rule less_imp_le)
+qed
 
 lemma strict_mono_on_eqD:
   fixes f :: "(_ :: linorder) \<Rightarrow> (_ :: preorder)"
   assumes "strict_mono_on A f" "f x = f y" "x \<in> A" "y \<in> A"
   shows "y = x"
-  using assms by (rule_tac linorder_cases[of x y]) (auto dest: strict_mono_onD)
+  using assms by (cases rule: linorder_cases) (auto dest: strict_mono_onD)
 
 lemma strict_mono_on_imp_mono_on:
   "strict_mono_on A (f :: (_ :: linorder) \<Rightarrow> _ :: preorder) \<Longrightarrow> mono_on A f"
   by (rule mono_onI, rule strict_mono_on_leD)
 
 
 subsection \<open>Setup\<close>
 
 subsubsection \<open>Proof tools\<close>
 
 text \<open>Simplify terms of the form \<open>f(\<dots>,x:=y,\<dots>,x:=z,\<dots>)\<close> to \<open>f(\<dots>,x:=z,\<dots>)\<close>\<close>
 
 simproc_setup fun_upd2 ("f(v := w, x := y)") = \<open>fn _ =>
   let
     fun gen_fun_upd NONE T _ _ = NONE
       | gen_fun_upd (SOME f) T x y = SOME (Const (\<^const_name>\<open>fun_upd\<close>, T) $ f $ x $ y)
     fun dest_fun_T1 (Type (_, T :: Ts)) = T
     fun find_double (t as Const (\<^const_name>\<open>fun_upd\<close>,T) $ f $ x $ y) =
       let
         fun find (Const (\<^const_name>\<open>fun_upd\<close>,T) $ g $ v $ w) =
               if v aconv x then SOME g else gen_fun_upd (find g) T v w
           | find t = NONE
       in (dest_fun_T1 T, gen_fun_upd (find f) T x y) end
 
     val ss = simpset_of \<^context>
 
     fun proc ctxt ct =
       let
         val t = Thm.term_of ct
       in
         (case find_double t of
           (T, NONE) => NONE
         | (T, SOME rhs) =>
             SOME (Goal.prove ctxt [] [] (Logic.mk_equals (t, rhs))
               (fn _ =>
                 resolve_tac ctxt [eq_reflection] 1 THEN
                 resolve_tac ctxt @{thms ext} 1 THEN
                 simp_tac (put_simpset ss ctxt) 1)))
       end
   in proc end
 \<close>
 
 
 subsubsection \<open>Functorial structure of types\<close>
 
 ML_file \<open>Tools/functor.ML\<close>
 
 functor map_fun: map_fun
   by (simp_all add: fun_eq_iff)
 
 functor vimage
   by (simp_all add: fun_eq_iff vimage_comp)
 
 
 text \<open>Legacy theorem names\<close>
 
 lemmas o_def = comp_def
 lemmas o_apply = comp_apply
 lemmas o_assoc = comp_assoc [symmetric]
 lemmas id_o = id_comp
 lemmas o_id = comp_id
 lemmas o_eq_dest = comp_eq_dest
 lemmas o_eq_elim = comp_eq_elim
 lemmas o_eq_dest_lhs = comp_eq_dest_lhs
 lemmas o_eq_id_dest = comp_eq_id_dest
 
 end
diff --git a/src/HOL/Fun_Def.thy b/src/HOL/Fun_Def.thy
--- a/src/HOL/Fun_Def.thy
+++ b/src/HOL/Fun_Def.thy
@@ -1,310 +1,330 @@
 (*  Title:      HOL/Fun_Def.thy
     Author:     Alexander Krauss, TU Muenchen
 *)
 
 section \<open>Function Definitions and Termination Proofs\<close>
 
 theory Fun_Def
   imports Basic_BNF_LFPs Partial_Function SAT
   keywords
     "function" "termination" :: thy_goal_defn and
     "fun" "fun_cases" :: thy_defn
 begin
 
 subsection \<open>Definitions with default value\<close>
 
 definition THE_default :: "'a \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a"
   where "THE_default d P = (if (\<exists>!x. P x) then (THE x. P x) else d)"
 
 lemma THE_defaultI': "\<exists>!x. P x \<Longrightarrow> P (THE_default d P)"
   by (simp add: theI' THE_default_def)
 
 lemma THE_default1_equality: "\<exists>!x. P x \<Longrightarrow> P a \<Longrightarrow> THE_default d P = a"
   by (simp add: the1_equality THE_default_def)
 
 lemma THE_default_none: "\<not> (\<exists>!x. P x) \<Longrightarrow> THE_default d P = d"
   by (simp add: THE_default_def)
 
 
 lemma fundef_ex1_existence:
   assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
   assumes ex1: "\<exists>!y. G x y"
   shows "G x (f x)"
   apply (simp only: f_def)
   apply (rule THE_defaultI')
   apply (rule ex1)
   done
 
 lemma fundef_ex1_uniqueness:
   assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
   assumes ex1: "\<exists>!y. G x y"
   assumes elm: "G x (h x)"
   shows "h x = f x"
-  apply (simp only: f_def)
-  apply (rule THE_default1_equality [symmetric])
-   apply (rule ex1)
-  apply (rule elm)
-  done
+  by (auto simp add: f_def ex1 elm THE_default1_equality[symmetric])
 
 lemma fundef_ex1_iff:
   assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
   assumes ex1: "\<exists>!y. G x y"
   shows "(G x y) = (f x = y)"
-  apply (auto simp:ex1 f_def THE_default1_equality)
-  apply (rule THE_defaultI')
-  apply (rule ex1)
-  done
+  by (auto simp add: ex1 f_def THE_default1_equality THE_defaultI')
+
 
 lemma fundef_default_value:
   assumes f_def: "f \<equiv> (\<lambda>x::'a. THE_default (d x) (\<lambda>y. G x y))"
   assumes graph: "\<And>x y. G x y \<Longrightarrow> D x"
   assumes "\<not> D x"
   shows "f x = d x"
 proof -
   have "\<not>(\<exists>y. G x y)"
   proof
     assume "\<exists>y. G x y"
     then have "D x" using graph ..
     with \<open>\<not> D x\<close> show False ..
   qed
   then have "\<not>(\<exists>!y. G x y)" by blast
   then show ?thesis
     unfolding f_def by (rule THE_default_none)
 qed
 
 definition in_rel_def[simp]: "in_rel R x y \<equiv> (x, y) \<in> R"
 
 lemma wf_in_rel: "wf R \<Longrightarrow> wfP (in_rel R)"
   by (simp add: wfP_def)
 
 ML_file \<open>Tools/Function/function_core.ML\<close>
 ML_file \<open>Tools/Function/mutual.ML\<close>
 ML_file \<open>Tools/Function/pattern_split.ML\<close>
 ML_file \<open>Tools/Function/relation.ML\<close>
 ML_file \<open>Tools/Function/function_elims.ML\<close>
 
 method_setup relation = \<open>
   Args.term >> (fn t => fn ctxt => SIMPLE_METHOD' (Function_Relation.relation_infer_tac ctxt t))
 \<close> "prove termination using a user-specified wellfounded relation"
 
 ML_file \<open>Tools/Function/function.ML\<close>
 ML_file \<open>Tools/Function/pat_completeness.ML\<close>
 
 method_setup pat_completeness = \<open>
   Scan.succeed (SIMPLE_METHOD' o Pat_Completeness.pat_completeness_tac)
 \<close> "prove completeness of (co)datatype patterns"
 
 ML_file \<open>Tools/Function/fun.ML\<close>
 ML_file \<open>Tools/Function/induction_schema.ML\<close>
 
 method_setup induction_schema = \<open>
   Scan.succeed (CONTEXT_TACTIC oo Induction_Schema.induction_schema_tac)
 \<close> "prove an induction principle"
 
 
 subsection \<open>Measure functions\<close>
 
 inductive is_measure :: "('a \<Rightarrow> nat) \<Rightarrow> bool"
   where is_measure_trivial: "is_measure f"
 
 named_theorems measure_function "rules that guide the heuristic generation of measure functions"
 ML_file \<open>Tools/Function/measure_functions.ML\<close>
 
 lemma measure_size[measure_function]: "is_measure size"
   by (rule is_measure_trivial)
 
 lemma measure_fst[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (fst p))"
   by (rule is_measure_trivial)
 
 lemma measure_snd[measure_function]: "is_measure f \<Longrightarrow> is_measure (\<lambda>p. f (snd p))"
   by (rule is_measure_trivial)
 
 ML_file \<open>Tools/Function/lexicographic_order.ML\<close>
 
 method_setup lexicographic_order = \<open>
   Method.sections clasimp_modifiers >>
   (K (SIMPLE_METHOD o Lexicographic_Order.lexicographic_order_tac false))
 \<close> "termination prover for lexicographic orderings"
 
 
 subsection \<open>Congruence rules\<close>
 
 lemma let_cong [fundef_cong]: "M = N \<Longrightarrow> (\<And>x. x = N \<Longrightarrow> f x = g x) \<Longrightarrow> Let M f = Let N g"
   unfolding Let_def by blast
 
 lemmas [fundef_cong] =
   if_cong image_cong
   bex_cong ball_cong imp_cong map_option_cong Option.bind_cong
 
 lemma split_cong [fundef_cong]:
   "(\<And>x y. (x, y) = q \<Longrightarrow> f x y = g x y) \<Longrightarrow> p = q \<Longrightarrow> case_prod f p = case_prod g q"
   by (auto simp: split_def)
 
 lemma comp_cong [fundef_cong]: "f (g x) = f' (g' x') \<Longrightarrow> (f \<circ> g) x = (f' \<circ> g') x'"
   by (simp only: o_apply)
 
 
 subsection \<open>Simp rules for termination proofs\<close>
 
 declare
   trans_less_add1[termination_simp]
   trans_less_add2[termination_simp]
   trans_le_add1[termination_simp]
   trans_le_add2[termination_simp]
   less_imp_le_nat[termination_simp]
   le_imp_less_Suc[termination_simp]
 
 lemma size_prod_simp[termination_simp]: "size_prod f g p = f (fst p) + g (snd p) + Suc 0"
   by (induct p) auto
 
 
 subsection \<open>Decomposition\<close>
 
 lemma less_by_empty: "A = {} \<Longrightarrow> A \<subseteq> B"
   and union_comp_emptyL: "A O C = {} \<Longrightarrow> B O C = {} \<Longrightarrow> (A \<union> B) O C = {}"
   and union_comp_emptyR: "A O B = {} \<Longrightarrow> A O C = {} \<Longrightarrow> A O (B \<union> C) = {}"
   and wf_no_loop: "R O R = {} \<Longrightarrow> wf R"
   by (auto simp add: wf_comp_self [of R])
 
 
 subsection \<open>Reduction pairs\<close>
 
 definition "reduction_pair P \<longleftrightarrow> wf (fst P) \<and> fst P O snd P \<subseteq> fst P"
 
 lemma reduction_pairI[intro]: "wf R \<Longrightarrow> R O S \<subseteq> R \<Longrightarrow> reduction_pair (R, S)"
   by (auto simp: reduction_pair_def)
 
 lemma reduction_pair_lemma:
   assumes rp: "reduction_pair P"
   assumes "R \<subseteq> fst P"
   assumes "S \<subseteq> snd P"
   assumes "wf S"
   shows "wf (R \<union> S)"
 proof -
   from rp \<open>S \<subseteq> snd P\<close> have "wf (fst P)" "fst P O S \<subseteq> fst P"
     unfolding reduction_pair_def by auto
   with \<open>wf S\<close> have "wf (fst P \<union> S)"
     by (auto intro: wf_union_compatible)
   moreover from \<open>R \<subseteq> fst P\<close> have "R \<union> S \<subseteq> fst P \<union> S" by auto
   ultimately show ?thesis by (rule wf_subset)
 qed
 
 definition "rp_inv_image = (\<lambda>(R,S) f. (inv_image R f, inv_image S f))"
 
 lemma rp_inv_image_rp: "reduction_pair P \<Longrightarrow> reduction_pair (rp_inv_image P f)"
   unfolding reduction_pair_def rp_inv_image_def split_def by force
 
 
 subsection \<open>Concrete orders for SCNP termination proofs\<close>
 
 definition "pair_less = less_than <*lex*> less_than"
 definition "pair_leq = pair_less\<^sup>="
 definition "max_strict = max_ext pair_less"
 definition "max_weak = max_ext pair_leq \<union> {({}, {})}"
 definition "min_strict = min_ext pair_less"
 definition "min_weak = min_ext pair_leq \<union> {({}, {})}"
 
 lemma wf_pair_less[simp]: "wf pair_less"
   by (auto simp: pair_less_def)
 
 lemma total_pair_less [iff]: "total_on A pair_less" and trans_pair_less [iff]: "trans pair_less"
   by (auto simp: total_on_def pair_less_def)
 
 text \<open>Introduction rules for \<open>pair_less\<close>/\<open>pair_leq\<close>\<close>
 lemma pair_leqI1: "a < b \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
   and pair_leqI2: "a \<le> b \<Longrightarrow> s \<le> t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_leq"
   and pair_lessI1: "a < b  \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
   and pair_lessI2: "a \<le> b \<Longrightarrow> s < t \<Longrightarrow> ((a, s), (b, t)) \<in> pair_less"
   by (auto simp: pair_leq_def pair_less_def)
 
 lemma pair_less_iff1 [simp]: "((x,y), (x,z)) \<in> pair_less \<longleftrightarrow> y<z"
   by (simp add: pair_less_def)
 
 text \<open>Introduction rules for max\<close>
 lemma smax_emptyI: "finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> ({}, Y) \<in> max_strict"
   and smax_insertI:
     "y \<in> Y \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (X, Y) \<in> max_strict \<Longrightarrow> (insert x X, Y) \<in> max_strict"
   and wmax_emptyI: "finite X \<Longrightarrow> ({}, X) \<in> max_weak"
   and wmax_insertI:
     "y \<in> YS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> max_weak \<Longrightarrow> (insert x XS, YS) \<in> max_weak"
   by (auto simp: max_strict_def max_weak_def elim!: max_ext.cases)
 
 text \<open>Introduction rules for min\<close>
 lemma smin_emptyI: "X \<noteq> {} \<Longrightarrow> (X, {}) \<in> min_strict"
   and smin_insertI:
     "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_less \<Longrightarrow> (XS, YS) \<in> min_strict \<Longrightarrow> (XS, insert y YS) \<in> min_strict"
   and wmin_emptyI: "(X, {}) \<in> min_weak"
   and wmin_insertI:
     "x \<in> XS \<Longrightarrow> (x, y) \<in> pair_leq \<Longrightarrow> (XS, YS) \<in> min_weak \<Longrightarrow> (XS, insert y YS) \<in> min_weak"
   by (auto simp: min_strict_def min_weak_def min_ext_def)
 
 text \<open>Reduction Pairs.\<close>
 
 lemma max_ext_compat:
   assumes "R O S \<subseteq> R"
   shows "max_ext R O (max_ext S \<union> {({}, {})}) \<subseteq> max_ext R"
-  using assms
-  apply auto
-  apply (elim max_ext.cases)
-  apply rule
-     apply auto[3]
-  apply (drule_tac x=xa in meta_spec)
-  apply simp
-  apply (erule bexE)
-  apply (drule_tac x=xb in meta_spec)
-  apply auto
-  done
+proof -
+  have "\<And>X Y Z. (X, Y) \<in> max_ext R \<Longrightarrow> (Y, Z) \<in> max_ext S \<Longrightarrow> (X, Z) \<in> max_ext R"
+  proof -
+    fix X Y Z
+    assume "(X,Y)\<in>max_ext R"
+      "(Y, Z)\<in>max_ext S"
+    then have *: "finite X" "finite Y" "finite Z" "Y\<noteq>{}" "Z\<noteq>{}"
+      "(\<And>x. x\<in>X \<Longrightarrow> \<exists>y\<in>Y. (x, y)\<in>R)"
+      "(\<And>y. y\<in>Y \<Longrightarrow> \<exists>z\<in>Z. (y, z)\<in>S)"
+      by (auto elim: max_ext.cases)
+    moreover have "\<And>x. x\<in>X \<Longrightarrow> \<exists>z\<in>Z. (x, z)\<in>R"
+    proof -
+      fix x
+      assume "x\<in>X"
+      then obtain y where 1: "y\<in>Y" "(x, y)\<in>R"
+        using * by auto
+      then obtain z where "z\<in>Z" "(y, z)\<in>S"
+        using * by auto
+      then show "\<exists>z\<in>Z. (x, z)\<in>R"
+        using assms 1 by (auto elim: max_ext.cases)
+    qed
+    ultimately show "(X,Z)\<in>max_ext R"
+      by auto
+  qed
+  then show "max_ext R O (max_ext S \<union> {({}, {})}) \<subseteq> max_ext R"
+    by auto
+qed
 
 lemma max_rpair_set: "reduction_pair (max_strict, max_weak)"
   unfolding max_strict_def max_weak_def
   apply (intro reduction_pairI max_ext_wf)
    apply simp
   apply (rule max_ext_compat)
   apply (auto simp: pair_less_def pair_leq_def)
   done
 
 lemma min_ext_compat:
   assumes "R O S \<subseteq> R"
-  shows "min_ext R O  (min_ext S \<union> {({},{})}) \<subseteq> min_ext R"
-  using assms
-  apply (auto simp: min_ext_def)
-  apply (drule_tac x=ya in bspec, assumption)
-  apply (erule bexE)
-  apply (drule_tac x=xc in bspec)
-   apply assumption
-  apply auto
-  done
+  shows "min_ext R O (min_ext S \<union> {({},{})}) \<subseteq> min_ext R"
+proof -
+  have "\<And>X Y Z z. \<forall>y\<in>Y. \<exists>x\<in>X. (x, y) \<in> R \<Longrightarrow> \<forall>z\<in>Z. \<exists>y\<in>Y. (y, z) \<in> S
+  \<Longrightarrow> z \<in> Z \<Longrightarrow> \<exists>x\<in>X. (x, z) \<in> R"
+  proof -
+    fix X Y Z z
+    assume *: "\<forall>y\<in>Y. \<exists>x\<in>X. (x, y) \<in> R"
+      "\<forall>z\<in>Z. \<exists>y\<in>Y. (y, z) \<in> S"
+      "z\<in>Z"
+    then obtain y' where 1: "y'\<in>Y" "(y', z) \<in> S"
+      by auto
+    then obtain x' where 2: "x'\<in>X" "(x', y') \<in> R"
+      using * by auto
+    show "\<exists>x\<in>X. (x, z) \<in> R"
+      using 1 2 assms by auto
+  qed
+  then show ?thesis
+    using assms by (auto simp: min_ext_def)
+qed
 
 lemma min_rpair_set: "reduction_pair (min_strict, min_weak)"
   unfolding min_strict_def min_weak_def
   apply (intro reduction_pairI min_ext_wf)
    apply simp
   apply (rule min_ext_compat)
   apply (auto simp: pair_less_def pair_leq_def)
   done
 
 
 subsection \<open>Yet another induction principle on the natural numbers\<close>
 
 lemma nat_descend_induct [case_names base descend]:
   fixes P :: "nat \<Rightarrow> bool"
   assumes H1: "\<And>k. k > n \<Longrightarrow> P k"
   assumes H2: "\<And>k. k \<le> n \<Longrightarrow> (\<And>i. i > k \<Longrightarrow> P i) \<Longrightarrow> P k"
   shows "P m"
   using assms by induction_schema (force intro!: wf_measure [of "\<lambda>k. Suc n - k"])+
 
 
 subsection \<open>Tool setup\<close>
 
 ML_file \<open>Tools/Function/termination.ML\<close>
 ML_file \<open>Tools/Function/scnp_solve.ML\<close>
 ML_file \<open>Tools/Function/scnp_reconstruct.ML\<close>
 ML_file \<open>Tools/Function/fun_cases.ML\<close>
 
 ML_val \<comment> \<open>setup inactive\<close>
 \<open>
   Context.theory_map (Function_Common.set_termination_prover
     (K (ScnpReconstruct.decomp_scnp_tac [ScnpSolve.MAX, ScnpSolve.MIN, ScnpSolve.MS])))
 \<close>
 
 end
diff --git a/src/HOL/Groups_Big.thy b/src/HOL/Groups_Big.thy
--- a/src/HOL/Groups_Big.thy
+++ b/src/HOL/Groups_Big.thy
@@ -1,1737 +1,1740 @@
 (*  Title:      HOL/Groups_Big.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
 *)
 
 section \<open>Big sum and product over finite (non-empty) sets\<close>
 
 theory Groups_Big
   imports Power Equiv_Relations
 begin
 
 subsection \<open>Generic monoid operation over a set\<close>
 
 locale comm_monoid_set = comm_monoid
 begin
 
 subsubsection \<open>Standard sum or product indexed by a finite set\<close>
 
 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)
 
 definition F :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'a"
   where eq_fold: "F g A = Finite_Set.fold (f \<circ> g) \<^bold>1 A"
 
 lemma infinite [simp]: "\<not> finite A \<Longrightarrow> F g A = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma empty [simp]: "F g {} = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma insert [simp]: "finite A \<Longrightarrow> x \<notin> A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g A"
   by (simp add: eq_fold)
 
 lemma remove:
   assumes "finite A" and "x \<in> A"
   shows "F g A = g x \<^bold>* F g (A - {x})"
 proof -
   from \<open>x \<in> A\<close> obtain B where B: "A = insert x B" and "x \<notin> B"
     by (auto dest: mk_disjoint_insert)
   moreover from \<open>finite A\<close> B have "finite B" by simp
   ultimately show ?thesis by simp
 qed
 
 lemma insert_remove: "finite A \<Longrightarrow> F g (insert x A) = g x \<^bold>* F g (A - {x})"
   by (cases "x \<in> A") (simp_all add: remove insert_absorb)
 
 lemma insert_if: "finite A \<Longrightarrow> F g (insert x A) = (if x \<in> A then F g A else g x \<^bold>* F g A)"
   by (cases "x \<in> A") (simp_all add: insert_absorb)
 
 lemma neutral: "\<forall>x\<in>A. g x = \<^bold>1 \<Longrightarrow> F g A = \<^bold>1"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma neutral_const [simp]: "F (\<lambda>_. \<^bold>1) A = \<^bold>1"
   by (simp add: neutral)
 
 lemma union_inter:
   assumes "finite A" and "finite B"
   shows "F g (A \<union> B) \<^bold>* F g (A \<inter> B) = F g A \<^bold>* F g B"
   \<comment> \<open>The reversed orientation looks more natural, but LOOPS as a simprule!\<close>
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case (insert x A)
   then show ?case
     by (auto simp: insert_absorb Int_insert_left commute [of _ "g x"] assoc left_commute)
 qed
 
 corollary union_inter_neutral:
   assumes "finite A" and "finite B"
     and "\<forall>x \<in> A \<inter> B. g x = \<^bold>1"
   shows "F g (A \<union> B) = F g A \<^bold>* F g B"
   using assms by (simp add: union_inter [symmetric] neutral)
 
 corollary union_disjoint:
   assumes "finite A" and "finite B"
   assumes "A \<inter> B = {}"
   shows "F g (A \<union> B) = F g A \<^bold>* F g B"
   using assms by (simp add: union_inter_neutral)
 
 lemma union_diff2:
   assumes "finite A" and "finite B"
   shows "F g (A \<union> B) = F g (A - B) \<^bold>* F g (B - A) \<^bold>* F g (A \<inter> B)"
 proof -
   have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
     by auto
   with assms show ?thesis
     by simp (subst union_disjoint, auto)+
 qed
 
 lemma subset_diff:
   assumes "B \<subseteq> A" and "finite A"
   shows "F g A = F g (A - B) \<^bold>* F g B"
 proof -
   from assms have "finite (A - B)" by auto
   moreover from assms have "finite B" by (rule finite_subset)
   moreover from assms have "(A - B) \<inter> B = {}" by auto
   ultimately have "F g (A - B \<union> B) = F g (A - B) \<^bold>* F g B" by (rule union_disjoint)
   moreover from assms have "A \<union> B = A" by auto
   ultimately show ?thesis by simp
 qed
 
 lemma Int_Diff:
   assumes "finite A"
   shows "F g A = F g (A \<inter> B) \<^bold>* F g (A - B)"
   by (subst subset_diff [where B = "A - B"]) (auto simp:  Diff_Diff_Int assms)
 
 lemma setdiff_irrelevant:
   assumes "finite A"
   shows "F g (A - {x. g x = z}) = F g A"
   using assms by (induct A) (simp_all add: insert_Diff_if)
 
 lemma not_neutral_contains_not_neutral:
   assumes "F g A \<noteq> \<^bold>1"
   obtains a where "a \<in> A" and "g a \<noteq> \<^bold>1"
 proof -
   from assms have "\<exists>a\<in>A. g a \<noteq> \<^bold>1"
   proof (induct A rule: infinite_finite_induct)
     case infinite
     then show ?case by simp
   next
     case empty
     then show ?case by simp
   next
     case (insert a A)
     then show ?case by fastforce
   qed
   with that show thesis by blast
 qed
 
 lemma reindex:
   assumes "inj_on h A"
   shows "F g (h ` A) = F (g \<circ> h) A"
 proof (cases "finite A")
   case True
   with assms show ?thesis
     by (simp add: eq_fold fold_image comp_assoc)
 next
   case False
   with assms have "\<not> finite (h ` A)" by (blast dest: finite_imageD)
   with False show ?thesis by simp
 qed
 
 lemma cong [fundef_cong]:
   assumes "A = B"
   assumes g_h: "\<And>x. x \<in> B \<Longrightarrow> g x = h x"
   shows "F g A = F h B"
   using g_h unfolding \<open>A = B\<close>
   by (induct B rule: infinite_finite_induct) auto
 
 lemma cong_simp [cong]:
   "\<lbrakk> A = B;  \<And>x. x \<in> B =simp=> g x = h x \<rbrakk> \<Longrightarrow> F (\<lambda>x. g x) A = F (\<lambda>x. h x) B"
 by (rule cong) (simp_all add: simp_implies_def)
 
 lemma reindex_cong:
   assumes "inj_on l B"
   assumes "A = l ` B"
   assumes "\<And>x. x \<in> B \<Longrightarrow> g (l x) = h x"
   shows "F g A = F h B"
   using assms by (simp add: reindex)
 
 lemma image_eq:
   assumes "inj_on g A"  
   shows "F (\<lambda>x. x) (g ` A) = F g A"
   using assms reindex_cong by fastforce
 
 lemma UNION_disjoint:
   assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
     and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
   shows "F g (\<Union>(A ` I)) = F (\<lambda>x. F g (A x)) I"
   using assms
 proof (induction rule: finite_induct)
   case (insert i I)
   then have "\<forall>j\<in>I. j \<noteq> i"
     by blast
   with insert.prems have "A i \<inter> \<Union>(A ` I) = {}"
     by blast
   with insert show ?case
     by (simp add: union_disjoint)
 qed auto
 
 lemma Union_disjoint:
   assumes "\<forall>A\<in>C. finite A" "\<forall>A\<in>C. \<forall>B\<in>C. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
   shows "F g (\<Union>C) = (F \<circ> F) g C"
 proof (cases "finite C")
   case True
   from UNION_disjoint [OF this assms] show ?thesis by simp
 next
   case False
   then show ?thesis by (auto dest: finite_UnionD intro: infinite)
 qed
 
 lemma distrib: "F (\<lambda>x. g x \<^bold>* h x) A = F g A \<^bold>* F h A"
   by (induct A rule: infinite_finite_induct) (simp_all add: assoc commute left_commute)
 
 lemma Sigma:
   assumes "finite A" "\<forall>x\<in>A. finite (B x)"
   shows "F (\<lambda>x. F (g x) (B x)) A = F (case_prod g) (SIGMA x:A. B x)"
   unfolding Sigma_def
 proof (subst UNION_disjoint)
   show "F (\<lambda>x. F (g x) (B x)) A = F (\<lambda>x. F (\<lambda>(x, y). g x y) (\<Union>y\<in>B x. {(x, y)})) A"
   proof (rule cong [OF refl])
     show "F (g x) (B x) = F (\<lambda>(x, y). g x y) (\<Union>y\<in>B x. {(x, y)})"
       if "x \<in> A" for x
       using that assms by (simp add: UNION_disjoint)
   qed
 qed (use assms in auto)
 
 lemma related:
   assumes Re: "R \<^bold>1 \<^bold>1"
     and Rop: "\<forall>x1 y1 x2 y2. R x1 x2 \<and> R y1 y2 \<longrightarrow> R (x1 \<^bold>* y1) (x2 \<^bold>* y2)"
     and fin: "finite S"
     and R_h_g: "\<forall>x\<in>S. R (h x) (g x)"
   shows "R (F h S) (F g S)"
   using fin by (rule finite_subset_induct) (use assms in auto)
 
 lemma mono_neutral_cong_left:
   assumes "finite T"
     and "S \<subseteq> T"
     and "\<forall>i \<in> T - S. h i = \<^bold>1"
     and "\<And>x. x \<in> S \<Longrightarrow> g x = h x"
   shows "F g S = F h T"
 proof-
   have eq: "T = S \<union> (T - S)" using \<open>S \<subseteq> T\<close> by blast
   have d: "S \<inter> (T - S) = {}" using \<open>S \<subseteq> T\<close> by blast
   from \<open>finite T\<close> \<open>S \<subseteq> T\<close> have f: "finite S" "finite (T - S)"
     by (auto intro: finite_subset)
   show ?thesis using assms(4)
     by (simp add: union_disjoint [OF f d, unfolded eq [symmetric]] neutral [OF assms(3)])
 qed
 
 lemma mono_neutral_cong_right:
   "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> g x = h x) \<Longrightarrow>
     F g T = F h S"
   by (auto intro!: mono_neutral_cong_left [symmetric])
 
 lemma mono_neutral_left: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g S = F g T"
   by (blast intro: mono_neutral_cong_left)
 
 lemma mono_neutral_right: "finite T \<Longrightarrow> S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> F g T = F g S"
   by (blast intro!: mono_neutral_left [symmetric])
 
 lemma mono_neutral_cong:
   assumes [simp]: "finite T" "finite S"
     and *: "\<And>i. i \<in> T - S \<Longrightarrow> h i = \<^bold>1" "\<And>i. i \<in> S - T \<Longrightarrow> g i = \<^bold>1"
     and gh: "\<And>x. x \<in> S \<inter> T \<Longrightarrow> g x = h x"
  shows "F g S = F h T"
 proof-
   have "F g S = F g (S \<inter> T)"
     by(rule mono_neutral_right)(auto intro: *)
   also have "\<dots> = F h (S \<inter> T)" using refl gh by(rule cong)
   also have "\<dots> = F h T"
     by(rule mono_neutral_left)(auto intro: *)
   finally show ?thesis .
 qed
 
 lemma reindex_bij_betw: "bij_betw h S T \<Longrightarrow> F (\<lambda>x. g (h x)) S = F g T"
   by (auto simp: bij_betw_def reindex)
 
 lemma reindex_bij_witness:
   assumes witness:
     "\<And>a. a \<in> S \<Longrightarrow> i (j a) = a"
     "\<And>a. a \<in> S \<Longrightarrow> j a \<in> T"
     "\<And>b. b \<in> T \<Longrightarrow> j (i b) = b"
     "\<And>b. b \<in> T \<Longrightarrow> i b \<in> S"
   assumes eq:
     "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
   shows "F g S = F h T"
 proof -
   have "bij_betw j S T"
     using bij_betw_byWitness[where A=S and f=j and f'=i and A'=T] witness by auto
   moreover have "F g S = F (\<lambda>x. h (j x)) S"
     by (intro cong) (auto simp: eq)
   ultimately show ?thesis
     by (simp add: reindex_bij_betw)
 qed
 
 lemma reindex_bij_betw_not_neutral:
   assumes fin: "finite S'" "finite T'"
   assumes bij: "bij_betw h (S - S') (T - T')"
   assumes nn:
     "\<And>a. a \<in> S' \<Longrightarrow> g (h a) = z"
     "\<And>b. b \<in> T' \<Longrightarrow> g b = z"
   shows "F (\<lambda>x. g (h x)) S = F g T"
 proof -
   have [simp]: "finite S \<longleftrightarrow> finite T"
     using bij_betw_finite[OF bij] fin by auto
   show ?thesis
   proof (cases "finite S")
     case True
     with nn have "F (\<lambda>x. g (h x)) S = F (\<lambda>x. g (h x)) (S - S')"
       by (intro mono_neutral_cong_right) auto
     also have "\<dots> = F g (T - T')"
       using bij by (rule reindex_bij_betw)
     also have "\<dots> = F g T"
       using nn \<open>finite S\<close> by (intro mono_neutral_cong_left) auto
     finally show ?thesis .
   next
     case False
     then show ?thesis by simp
   qed
 qed
 
 lemma reindex_nontrivial:
   assumes "finite A"
     and nz: "\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> h x = h y \<Longrightarrow> g (h x) = \<^bold>1"
   shows "F g (h ` A) = F (g \<circ> h) A"
 proof (subst reindex_bij_betw_not_neutral [symmetric])
   show "bij_betw h (A - {x \<in> A. (g \<circ> h) x = \<^bold>1}) (h ` A - h ` {x \<in> A. (g \<circ> h) x = \<^bold>1})"
     using nz by (auto intro!: inj_onI simp: bij_betw_def)
 qed (use \<open>finite A\<close> in auto)
 
 lemma reindex_bij_witness_not_neutral:
   assumes fin: "finite S'" "finite T'"
   assumes witness:
     "\<And>a. a \<in> S - S' \<Longrightarrow> i (j a) = a"
     "\<And>a. a \<in> S - S' \<Longrightarrow> j a \<in> T - T'"
     "\<And>b. b \<in> T - T' \<Longrightarrow> j (i b) = b"
     "\<And>b. b \<in> T - T' \<Longrightarrow> i b \<in> S - S'"
   assumes nn:
     "\<And>a. a \<in> S' \<Longrightarrow> g a = z"
     "\<And>b. b \<in> T' \<Longrightarrow> h b = z"
   assumes eq:
     "\<And>a. a \<in> S \<Longrightarrow> h (j a) = g a"
   shows "F g S = F h T"
 proof -
   have bij: "bij_betw j (S - (S' \<inter> S)) (T - (T' \<inter> T))"
     using witness by (intro bij_betw_byWitness[where f'=i]) auto
   have F_eq: "F g S = F (\<lambda>x. h (j x)) S"
     by (intro cong) (auto simp: eq)
   show ?thesis
     unfolding F_eq using fin nn eq
     by (intro reindex_bij_betw_not_neutral[OF _ _ bij]) auto
 qed
 
 lemma delta_remove:
   assumes fS: "finite S"
   shows "F (\<lambda>k. if k = a then b k else c k) S = (if a \<in> S then b a \<^bold>* F c (S-{a}) else F c (S-{a}))"
 proof -
   let ?f = "(\<lambda>k. if k = a then b k else c k)"
   show ?thesis
   proof (cases "a \<in> S")
     case False
     then have "\<forall>k\<in>S. ?f k = c k" by simp
     with False show ?thesis by simp
   next
     case True
     let ?A = "S - {a}"
     let ?B = "{a}"
     from True have eq: "S = ?A \<union> ?B" by blast
     have dj: "?A \<inter> ?B = {}" by simp
     from fS have fAB: "finite ?A" "finite ?B" by auto
     have "F ?f S = F ?f ?A \<^bold>* F ?f ?B"
       using union_disjoint [OF fAB dj, of ?f, unfolded eq [symmetric]] by simp
     with True show ?thesis
       using comm_monoid_set.remove comm_monoid_set_axioms fS by fastforce
   qed
 qed
 
 lemma delta [simp]:
   assumes fS: "finite S"
   shows "F (\<lambda>k. if k = a then b k else \<^bold>1) S = (if a \<in> S then b a else \<^bold>1)"
   by (simp add: delta_remove [OF assms])
 
 lemma delta' [simp]:
   assumes fin: "finite S"
   shows "F (\<lambda>k. if a = k then b k else \<^bold>1) S = (if a \<in> S then b a else \<^bold>1)"
   using delta [OF fin, of a b, symmetric] by (auto intro: cong)
 
 lemma If_cases:
   fixes P :: "'b \<Rightarrow> bool" and g h :: "'b \<Rightarrow> 'a"
   assumes fin: "finite A"
   shows "F (\<lambda>x. if P x then h x else g x) A = F h (A \<inter> {x. P x}) \<^bold>* F g (A \<inter> - {x. P x})"
 proof -
   have a: "A = A \<inter> {x. P x} \<union> A \<inter> -{x. P x}" "(A \<inter> {x. P x}) \<inter> (A \<inter> -{x. P x}) = {}"
     by blast+
   from fin have f: "finite (A \<inter> {x. P x})" "finite (A \<inter> -{x. P x})" by auto
   let ?g = "\<lambda>x. if P x then h x else g x"
   from union_disjoint [OF f a(2), of ?g] a(1) show ?thesis
     by (subst (1 2) cong) simp_all
 qed
 
 lemma cartesian_product: "F (\<lambda>x. F (g x) B) A = F (case_prod g) (A \<times> B)"
 proof (cases "A = {} \<or> B = {}")
   case True
   then show ?thesis
     by auto
 next
   case False
   then have "A \<noteq> {}" "B \<noteq> {}" by auto
   show ?thesis
   proof (cases "finite A \<and> finite B")
     case True
     then show ?thesis
       by (simp add: Sigma)
   next
     case False
     then consider "infinite A" | "infinite B" by auto
     then have "infinite (A \<times> B)"
       by cases (use \<open>A \<noteq> {}\<close> \<open>B \<noteq> {}\<close> in \<open>auto dest: finite_cartesian_productD1 finite_cartesian_productD2\<close>)
     then show ?thesis
       using False by auto
   qed
 qed
 
 lemma inter_restrict:
   assumes "finite A"
   shows "F g (A \<inter> B) = F (\<lambda>x. if x \<in> B then g x else \<^bold>1) A"
 proof -
   let ?g = "\<lambda>x. if x \<in> A \<inter> B then g x else \<^bold>1"
   have "\<forall>i\<in>A - A \<inter> B. (if i \<in> A \<inter> B then g i else \<^bold>1) = \<^bold>1" by simp
   moreover have "A \<inter> B \<subseteq> A" by blast
   ultimately have "F ?g (A \<inter> B) = F ?g A"
     using \<open>finite A\<close> by (intro mono_neutral_left) auto
   then show ?thesis by simp
 qed
 
 lemma inter_filter:
   "finite A \<Longrightarrow> F g {x \<in> A. P x} = F (\<lambda>x. if P x then g x else \<^bold>1) A"
   by (simp add: inter_restrict [symmetric, of A "{x. P x}" g, simplified mem_Collect_eq] Int_def)
 
 lemma Union_comp:
   assumes "\<forall>A \<in> B. finite A"
     and "\<And>A1 A2 x. A1 \<in> B \<Longrightarrow> A2 \<in> B \<Longrightarrow> A1 \<noteq> A2 \<Longrightarrow> x \<in> A1 \<Longrightarrow> x \<in> A2 \<Longrightarrow> g x = \<^bold>1"
   shows "F g (\<Union>B) = (F \<circ> F) g B"
   using assms
 proof (induct B rule: infinite_finite_induct)
   case (infinite A)
   then have "\<not> finite (\<Union>A)" by (blast dest: finite_UnionD)
   with infinite show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert A B)
   then have "finite A" "finite B" "finite (\<Union>B)" "A \<notin> B"
     and "\<forall>x\<in>A \<inter> \<Union>B. g x = \<^bold>1"
     and H: "F g (\<Union>B) = (F \<circ> F) g B" by auto
   then have "F g (A \<union> \<Union>B) = F g A \<^bold>* F g (\<Union>B)"
     by (simp add: union_inter_neutral)
   with \<open>finite B\<close> \<open>A \<notin> B\<close> show ?case
     by (simp add: H)
 qed
 
 lemma swap: "F (\<lambda>i. F (g i) B) A = F (\<lambda>j. F (\<lambda>i. g i j) A) B"
   unfolding cartesian_product
   by (rule reindex_bij_witness [where i = "\<lambda>(i, j). (j, i)" and j = "\<lambda>(i, j). (j, i)"]) auto
 
 lemma swap_restrict:
   "finite A \<Longrightarrow> finite B \<Longrightarrow>
     F (\<lambda>x. F (g x) {y. y \<in> B \<and> R x y}) A = F (\<lambda>y. F (\<lambda>x. g x y) {x. x \<in> A \<and> R x y}) B"
   by (simp add: inter_filter) (rule swap)
 
 lemma image_gen:
   assumes fin: "finite S"
   shows "F h S = F (\<lambda>y. F h {x. x \<in> S \<and> g x = y}) (g ` S)"
 proof -
   have "{y. y\<in> g`S \<and> g x = y} = {g x}" if "x \<in> S" for x
     using that by auto
   then have "F h S = F (\<lambda>x. F (\<lambda>y. h x) {y. y\<in> g`S \<and> g x = y}) S"
     by simp
   also have "\<dots> = F (\<lambda>y. F h {x. x \<in> S \<and> g x = y}) (g ` S)"
     by (rule swap_restrict [OF fin finite_imageI [OF fin]])
   finally show ?thesis .
 qed
 
 lemma group:
   assumes fS: "finite S" and fT: "finite T" and fST: "g ` S \<subseteq> T"
   shows "F (\<lambda>y. F h {x. x \<in> S \<and> g x = y}) T = F h S"
   unfolding image_gen[OF fS, of h g]
   by (auto intro: neutral mono_neutral_right[OF fT fST])
 
 lemma Plus:
   fixes A :: "'b set" and B :: "'c set"
   assumes fin: "finite A" "finite B"
   shows "F g (A <+> B) = F (g \<circ> Inl) A \<^bold>* F (g \<circ> Inr) B"
 proof -
   have "A <+> B = Inl ` A \<union> Inr ` B" by auto
   moreover from fin have "finite (Inl ` A)" "finite (Inr ` B)" by auto
   moreover have "Inl ` A \<inter> Inr ` B = {}" by auto
   moreover have "inj_on Inl A" "inj_on Inr B" by (auto intro: inj_onI)
   ultimately show ?thesis
     using fin by (simp add: union_disjoint reindex)
 qed
 
 lemma same_carrier:
   assumes "finite C"
   assumes subset: "A \<subseteq> C" "B \<subseteq> C"
   assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
   shows "F g A = F h B \<longleftrightarrow> F g C = F h C"
 proof -
   have "finite A" and "finite B" and "finite (C - A)" and "finite (C - B)"
     using \<open>finite C\<close> subset by (auto elim: finite_subset)
   from subset have [simp]: "A - (C - A) = A" by auto
   from subset have [simp]: "B - (C - B) = B" by auto
   from subset have "C = A \<union> (C - A)" by auto
   then have "F g C = F g (A \<union> (C - A))" by simp
   also have "\<dots> = F g (A - (C - A)) \<^bold>* F g (C - A - A) \<^bold>* F g (A \<inter> (C - A))"
     using \<open>finite A\<close> \<open>finite (C - A)\<close> by (simp only: union_diff2)
   finally have *: "F g C = F g A" using trivial by simp
   from subset have "C = B \<union> (C - B)" by auto
   then have "F h C = F h (B \<union> (C - B))" by simp
   also have "\<dots> = F h (B - (C - B)) \<^bold>* F h (C - B - B) \<^bold>* F h (B \<inter> (C - B))"
     using \<open>finite B\<close> \<open>finite (C - B)\<close> by (simp only: union_diff2)
   finally have "F h C = F h B"
     using trivial by simp
   with * show ?thesis by simp
 qed
 
 lemma same_carrierI:
   assumes "finite C"
   assumes subset: "A \<subseteq> C" "B \<subseteq> C"
   assumes trivial: "\<And>a. a \<in> C - A \<Longrightarrow> g a = \<^bold>1" "\<And>b. b \<in> C - B \<Longrightarrow> h b = \<^bold>1"
   assumes "F g C = F h C"
   shows "F g A = F h B"
   using assms same_carrier [of C A B] by simp
 
 lemma eq_general:
   assumes B: "\<And>y. y \<in> B \<Longrightarrow> \<exists>!x. x \<in> A \<and> h x = y" and A: "\<And>x. x \<in> A \<Longrightarrow> h x \<in> B \<and> \<gamma>(h x) = \<phi> x"
   shows "F \<phi> A = F \<gamma> B"
 proof -
   have eq: "B = h ` A"
     by (auto dest: assms)
   have h: "inj_on h A"
     using assms by (blast intro: inj_onI)
   have "F \<phi> A = F (\<gamma> \<circ> h) A"
     using A by auto
   also have "\<dots> = F \<gamma> B"
     by (simp add: eq reindex h)
   finally show ?thesis .
 qed
 
 lemma eq_general_inverses:
   assumes B: "\<And>y. y \<in> B \<Longrightarrow> k y \<in> A \<and> h(k y) = y" and A: "\<And>x. x \<in> A \<Longrightarrow> h x \<in> B \<and> k(h x) = x \<and> \<gamma>(h x) = \<phi> x"
   shows "F \<phi> A = F \<gamma> B"
   by (rule eq_general [where h=h]) (force intro: dest: A B)+
 
 subsubsection \<open>HOL Light variant: sum/product indexed by the non-neutral subset\<close>
 text \<open>NB only a subset of the properties above are proved\<close>
 
 definition G :: "['b \<Rightarrow> 'a,'b set] \<Rightarrow> 'a"
   where "G p I \<equiv> if finite {x \<in> I. p x \<noteq> \<^bold>1} then F p {x \<in> I. p x \<noteq> \<^bold>1} else \<^bold>1"
 
 lemma finite_Collect_op:
   shows "\<lbrakk>finite {i \<in> I. x i \<noteq> \<^bold>1}; finite {i \<in> I. y i \<noteq> \<^bold>1}\<rbrakk> \<Longrightarrow> finite {i \<in> I. x i \<^bold>* y i \<noteq> \<^bold>1}"
   apply (rule finite_subset [where B = "{i \<in> I. x i \<noteq> \<^bold>1} \<union> {i \<in> I. y i \<noteq> \<^bold>1}"]) 
   using left_neutral by force+
 
 lemma empty' [simp]: "G p {} = \<^bold>1"
   by (auto simp: G_def)
 
 lemma eq_sum [simp]: "finite I \<Longrightarrow> G p I = F p I"
   by (auto simp: G_def intro: mono_neutral_cong_left)
 
 lemma insert' [simp]:
   assumes "finite {x \<in> I. p x \<noteq> \<^bold>1}"
   shows "G p (insert i I) = (if i \<in> I then G p I else p i \<^bold>* G p I)"
 proof -
   have "{x. x = i \<and> p x \<noteq> \<^bold>1 \<or> x \<in> I \<and> p x \<noteq> \<^bold>1} = (if p i = \<^bold>1 then {x \<in> I. p x \<noteq> \<^bold>1} else insert i {x \<in> I. p x \<noteq> \<^bold>1})"
     by auto
   then show ?thesis
     using assms by (simp add: G_def conj_disj_distribR insert_absorb)
 qed
 
 lemma distrib_triv':
   assumes "finite I"
   shows "G (\<lambda>i. g i \<^bold>* h i) I = G g I \<^bold>* G h I"
   by (simp add: assms local.distrib)
 
 lemma non_neutral': "G g {x \<in> I. g x \<noteq> \<^bold>1} = G g I"
   by (simp add: G_def)
 
 lemma distrib':
   assumes "finite {x \<in> I. g x \<noteq> \<^bold>1}" "finite {x \<in> I. h x \<noteq> \<^bold>1}"
   shows "G (\<lambda>i. g i \<^bold>* h i) I = G g I \<^bold>* G h I"
 proof -
   have "a \<^bold>* a \<noteq> a \<Longrightarrow> a \<noteq> \<^bold>1" for a
     by auto
   then have "G (\<lambda>i. g i \<^bold>* h i) I = G (\<lambda>i. g i \<^bold>* h i) ({i \<in> I. g i \<noteq> \<^bold>1} \<union> {i \<in> I. h i \<noteq> \<^bold>1})"
     using assms  by (force simp: G_def finite_Collect_op intro!: mono_neutral_cong)
   also have "\<dots> = G g I \<^bold>* G h I"
   proof -
     have "F g ({i \<in> I. g i \<noteq> \<^bold>1} \<union> {i \<in> I. h i \<noteq> \<^bold>1}) = G g I"
          "F h ({i \<in> I. g i \<noteq> \<^bold>1} \<union> {i \<in> I. h i \<noteq> \<^bold>1}) = G h I"
       by (auto simp: G_def assms intro: mono_neutral_right)
     then show ?thesis
       using assms by (simp add: distrib)
   qed
   finally show ?thesis .
 qed
 
 lemma cong':
   assumes "A = B"
   assumes g_h: "\<And>x. x \<in> B \<Longrightarrow> g x = h x"
   shows "G g A = G h B"
   using assms by (auto simp: G_def cong: conj_cong intro: cong)
 
 
 lemma mono_neutral_cong_left':
   assumes "S \<subseteq> T"
     and "\<And>i. i \<in> T - S \<Longrightarrow> h i = \<^bold>1"
     and "\<And>x. x \<in> S \<Longrightarrow> g x = h x"
   shows "G g S = G h T"
 proof -
   have *: "{x \<in> S. g x \<noteq> \<^bold>1} = {x \<in> T. h x \<noteq> \<^bold>1}"
     using assms by (metis DiffI subset_eq) 
   then have "finite {x \<in> S. g x \<noteq> \<^bold>1} = finite {x \<in> T. h x \<noteq> \<^bold>1}"
     by simp
   then show ?thesis
     using assms by (auto simp add: G_def * intro: cong)
 qed
 
 lemma mono_neutral_cong_right':
   "S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> g x = h x) \<Longrightarrow>
     G g T = G h S"
   by (auto intro!: mono_neutral_cong_left' [symmetric])
 
 lemma mono_neutral_left': "S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> G g S = G g T"
   by (blast intro: mono_neutral_cong_left')
 
 lemma mono_neutral_right': "S \<subseteq> T \<Longrightarrow> \<forall>i \<in> T - S. g i = \<^bold>1 \<Longrightarrow> G g T = G g S"
   by (blast intro!: mono_neutral_left' [symmetric])
 
 end
 
 
 subsection \<open>Generalized summation over a set\<close>
 
 context comm_monoid_add
 begin
 
 sublocale sum: comm_monoid_set plus 0
   defines sum = sum.F and sum' = sum.G ..
 
 abbreviation Sum ("\<Sum>")
   where "\<Sum> \<equiv> sum (\<lambda>x. x)"
 
 end
 
 text \<open>Now: lots of fancy syntax. First, \<^term>\<open>sum (\<lambda>x. e) A\<close> is written \<open>\<Sum>x\<in>A. e\<close>.\<close>
 
 syntax (ASCII)
   "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(3SUM (_/:_)./ _)" [0, 51, 10] 10)
 syntax
   "_sum" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b::comm_monoid_add"  ("(2\<Sum>(_/\<in>_)./ _)" [0, 51, 10] 10)
 translations \<comment> \<open>Beware of argument permutation!\<close>
   "\<Sum>i\<in>A. b" \<rightleftharpoons> "CONST sum (\<lambda>i. b) A"
 
 text \<open>Instead of \<^term>\<open>\<Sum>x\<in>{x. P}. e\<close> we introduce the shorter \<open>\<Sum>x|P. e\<close>.\<close>
 
 syntax (ASCII)
   "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(3SUM _ |/ _./ _)" [0, 0, 10] 10)
 syntax
   "_qsum" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(2\<Sum>_ | (_)./ _)" [0, 0, 10] 10)
 translations
   "\<Sum>x|P. t" => "CONST sum (\<lambda>x. t) {x. P}"
 
 print_translation \<open>
 let
   fun sum_tr' [Abs (x, Tx, t), Const (\<^const_syntax>\<open>Collect\<close>, _) $ Abs (y, Ty, P)] =
         if x <> y then raise Match
         else
           let
             val x' = Syntax_Trans.mark_bound_body (x, Tx);
             val t' = subst_bound (x', t);
             val P' = subst_bound (x', P);
           in
             Syntax.const \<^syntax_const>\<open>_qsum\<close> $ Syntax_Trans.mark_bound_abs (x, Tx) $ P' $ t'
           end
     | sum_tr' _ = raise Match;
 in [(\<^const_syntax>\<open>sum\<close>, K sum_tr')] end
 \<close>
 
 
 subsubsection \<open>Properties in more restricted classes of structures\<close>
 
 lemma sum_Un:
   "finite A \<Longrightarrow> finite B \<Longrightarrow> sum f (A \<union> B) = sum f A + sum f B - sum f (A \<inter> B)"
   for f :: "'b \<Rightarrow> 'a::ab_group_add"
   by (subst sum.union_inter [symmetric]) (auto simp add: algebra_simps)
 
 lemma sum_Un2:
   assumes "finite (A \<union> B)"
   shows "sum f (A \<union> B) = sum f (A - B) + sum f (B - A) + sum f (A \<inter> B)"
 proof -
   have "A \<union> B = A - B \<union> (B - A) \<union> A \<inter> B"
     by auto
   with assms show ?thesis
     by simp (subst sum.union_disjoint, auto)+
 qed
 
 (*Like sum.subset_diff but expressed perhaps more conveniently using subtraction*)
 lemma sum_diff: 
   fixes f :: "'b \<Rightarrow> 'a::ab_group_add"
   assumes "finite A" "B \<subseteq> A"
   shows "sum f (A - B) = sum f A - sum f B"
   using sum.subset_diff [of B A f] assms by simp
 
 lemma sum_diff1:
   fixes f :: "'b \<Rightarrow> 'a::ab_group_add"
   assumes "finite A"
   shows "sum f (A - {a}) = (if a \<in> A then sum f A - f a else sum f A)"
   using assms by (simp add: sum_diff)
 
 lemma sum_diff1'_aux:
   fixes f :: "'a \<Rightarrow> 'b::ab_group_add"
   assumes "finite F" "{i \<in> I. f i \<noteq> 0} \<subseteq> F"
   shows "sum' f (I - {i}) = (if i \<in> I then sum' f I - f i else sum' f I)"
   using assms
 proof induct
   case (insert x F)
   have 1: "finite {x \<in> I. f x \<noteq> 0} \<Longrightarrow> finite {x \<in> I. x \<noteq> i \<and> f x \<noteq> 0}"
     by (erule rev_finite_subset) auto
   have 2: "finite {x \<in> I. x \<noteq> i \<and> f x \<noteq> 0} \<Longrightarrow> finite {x \<in> I. f x \<noteq> 0}"
     apply (drule finite_insert [THEN iffD2])
     by (erule rev_finite_subset) auto
   have 3: "finite {i \<in> I. f i \<noteq> 0}"
     using finite_subset insert by blast
   show ?case
     using insert sum_diff1 [of "{i \<in> I. f i \<noteq> 0}" f i]
     by (auto simp: sum.G_def 1 2 3 set_diff_eq conj_ac)
 qed (simp add: sum.G_def)
 
 lemma sum_diff1':
   fixes f :: "'a \<Rightarrow> 'b::ab_group_add"
   assumes "finite {i \<in> I. f i \<noteq> 0}"
   shows "sum' f (I - {i}) = (if i \<in> I then sum' f I - f i else sum' f I)"
   by (rule sum_diff1'_aux [OF assms order_refl])
 
 lemma (in ordered_comm_monoid_add) sum_mono:
   "(\<And>i. i\<in>K \<Longrightarrow> f i \<le> g i) \<Longrightarrow> (\<Sum>i\<in>K. f i) \<le> (\<Sum>i\<in>K. g i)"
   by (induct K rule: infinite_finite_induct) (use add_mono in auto)
 
 lemma (in strict_ordered_comm_monoid_add) sum_strict_mono:
   assumes "finite A" "A \<noteq> {}"
     and "\<And>x. x \<in> A \<Longrightarrow> f x < g x"
   shows "sum f A < sum g A"
   using assms
 proof (induct rule: finite_ne_induct)
   case singleton
   then show ?case by simp
 next
   case insert
   then show ?case by (auto simp: add_strict_mono)
 qed
 
 lemma sum_strict_mono_ex1:
   fixes f g :: "'i \<Rightarrow> 'a::ordered_cancel_comm_monoid_add"
   assumes "finite A"
     and "\<forall>x\<in>A. f x \<le> g x"
     and "\<exists>a\<in>A. f a < g a"
   shows "sum f A < sum g A"
 proof-
   from assms(3) obtain a where a: "a \<in> A" "f a < g a" by blast
   have "sum f A = sum f ((A - {a}) \<union> {a})"
     by(simp add: insert_absorb[OF \<open>a \<in> A\<close>])
   also have "\<dots> = sum f (A - {a}) + sum f {a}"
     using \<open>finite A\<close> by(subst sum.union_disjoint) auto
   also have "sum f (A - {a}) \<le> sum g (A - {a})"
     by (rule sum_mono) (simp add: assms(2))
   also from a have "sum f {a} < sum g {a}" by simp
   also have "sum g (A - {a}) + sum g {a} = sum g((A - {a}) \<union> {a})"
     using \<open>finite A\<close> by (subst sum.union_disjoint[symmetric]) auto
   also have "\<dots> = sum g A" by (simp add: insert_absorb[OF \<open>a \<in> A\<close>])
   finally show ?thesis
     by (auto simp add: add_right_mono add_strict_left_mono)
 qed
 
 lemma sum_mono_inv:
   fixes f g :: "'i \<Rightarrow> 'a :: ordered_cancel_comm_monoid_add"
   assumes eq: "sum f I = sum g I"
   assumes le: "\<And>i. i \<in> I \<Longrightarrow> f i \<le> g i"
   assumes i: "i \<in> I"
   assumes I: "finite I"
   shows "f i = g i"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   with le[OF i] have "f i < g i" by simp
   with i have "\<exists>i\<in>I. f i < g i" ..
   from sum_strict_mono_ex1[OF I _ this] le have "sum f I < sum g I"
     by blast
   with eq show False by simp
 qed
 
 lemma member_le_sum:
   fixes f :: "_ \<Rightarrow> 'b::{semiring_1, ordered_comm_monoid_add}"
   assumes "i \<in> A"
     and le: "\<And>x. x \<in> A - {i} \<Longrightarrow> 0 \<le> f x"
     and "finite A"
   shows "f i \<le> sum f A"
 proof -
   have "f i \<le> sum f (A \<inter> {i})"
     by (simp add: assms)
   also have "... = (\<Sum>x\<in>A. if x \<in> {i} then f x else 0)"
     using assms sum.inter_restrict by blast
   also have "... \<le> sum f A"
     apply (rule sum_mono)
     apply (auto simp: le)
     done
   finally show ?thesis .
 qed
 
 lemma sum_negf: "(\<Sum>x\<in>A. - f x) = - (\<Sum>x\<in>A. f x)"
   for f :: "'b \<Rightarrow> 'a::ab_group_add"
   by (induct A rule: infinite_finite_induct) auto
 
 lemma sum_subtractf: "(\<Sum>x\<in>A. f x - g x) = (\<Sum>x\<in>A. f x) - (\<Sum>x\<in>A. g x)"
   for f g :: "'b \<Rightarrow>'a::ab_group_add"
   using sum.distrib [of f "- g" A] by (simp add: sum_negf)
 
 lemma sum_subtractf_nat:
   "(\<And>x. x \<in> A \<Longrightarrow> g x \<le> f x) \<Longrightarrow> (\<Sum>x\<in>A. f x - g x) = (\<Sum>x\<in>A. f x) - (\<Sum>x\<in>A. g x)"
   for f g :: "'a \<Rightarrow> nat"
   by (induct A rule: infinite_finite_induct) (auto simp: sum_mono)
 
 context ordered_comm_monoid_add
 begin
 
 lemma sum_nonneg: "(\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x) \<Longrightarrow> 0 \<le> sum f A"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then have "0 + 0 \<le> f x + sum f F" by (blast intro: add_mono)
   with insert show ?case by simp
 qed
 
 lemma sum_nonpos: "(\<And>x. x \<in> A \<Longrightarrow> f x \<le> 0) \<Longrightarrow> sum f A \<le> 0"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then have "f x + sum f F \<le> 0 + 0" by (blast intro: add_mono)
   with insert show ?case by simp
 qed
 
 lemma sum_nonneg_eq_0_iff:
   "finite A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x) \<Longrightarrow> sum f A = 0 \<longleftrightarrow> (\<forall>x\<in>A. f x = 0)"
   by (induct set: finite) (simp_all add: add_nonneg_eq_0_iff sum_nonneg)
 
 lemma sum_nonneg_0:
   "finite s \<Longrightarrow> (\<And>i. i \<in> s \<Longrightarrow> f i \<ge> 0) \<Longrightarrow> (\<Sum> i \<in> s. f i) = 0 \<Longrightarrow> i \<in> s \<Longrightarrow> f i = 0"
   by (simp add: sum_nonneg_eq_0_iff)
 
 lemma sum_nonneg_leq_bound:
   assumes "finite s" "\<And>i. i \<in> s \<Longrightarrow> f i \<ge> 0" "(\<Sum>i \<in> s. f i) = B" "i \<in> s"
   shows "f i \<le> B"
 proof -
   from assms have "f i \<le> f i + (\<Sum>i \<in> s - {i}. f i)"
     by (intro add_increasing2 sum_nonneg) auto
   also have "\<dots> = B"
     using sum.remove[of s i f] assms by simp
   finally show ?thesis by auto
 qed
 
 lemma sum_mono2:
   assumes fin: "finite B"
     and sub: "A \<subseteq> B"
     and nn: "\<And>b. b \<in> B-A \<Longrightarrow> 0 \<le> f b"
   shows "sum f A \<le> sum f B"
 proof -
   have "sum f A \<le> sum f A + sum f (B-A)"
     by (auto intro: add_increasing2 [OF sum_nonneg] nn)
   also from fin finite_subset[OF sub fin] have "\<dots> = sum f (A \<union> (B-A))"
     by (simp add: sum.union_disjoint del: Un_Diff_cancel)
   also from sub have "A \<union> (B-A) = B" by blast
   finally show ?thesis .
 qed
 
 lemma sum_le_included:
   assumes "finite s" "finite t"
   and "\<forall>y\<in>t. 0 \<le> g y" "(\<forall>x\<in>s. \<exists>y\<in>t. i y = x \<and> f x \<le> g y)"
   shows "sum f s \<le> sum g t"
 proof -
   have "sum f s \<le> sum (\<lambda>y. sum g {x. x\<in>t \<and> i x = y}) s"
   proof (rule sum_mono)
     fix y
     assume "y \<in> s"
     with assms obtain z where z: "z \<in> t" "y = i z" "f y \<le> g z" by auto
     with assms show "f y \<le> sum g {x \<in> t. i x = y}" (is "?A y \<le> ?B y")
       using order_trans[of "?A (i z)" "sum g {z}" "?B (i z)", intro]
       by (auto intro!: sum_mono2)
   qed
   also have "\<dots> \<le> sum (\<lambda>y. sum g {x. x\<in>t \<and> i x = y}) (i ` t)"
     using assms(2-4) by (auto intro!: sum_mono2 sum_nonneg)
   also have "\<dots> \<le> sum g t"
     using assms by (auto simp: sum.image_gen[symmetric])
   finally show ?thesis .
 qed
 
 end
 
 lemma (in canonically_ordered_monoid_add) sum_eq_0_iff [simp]:
   "finite F \<Longrightarrow> (sum f F = 0) = (\<forall>a\<in>F. f a = 0)"
   by (intro ballI sum_nonneg_eq_0_iff zero_le)
 
 context semiring_0
 begin
 
 lemma sum_distrib_left: "r * sum f A = (\<Sum>n\<in>A. r * f n)"
   by (induct A rule: infinite_finite_induct) (simp_all add: algebra_simps)
 
 lemma sum_distrib_right: "sum f A * r = (\<Sum>n\<in>A. f n * r)"
   by (induct A rule: infinite_finite_induct) (simp_all add: algebra_simps)
 
 end
 
 lemma sum_divide_distrib: "sum f A / r = (\<Sum>n\<in>A. f n / r)"
   for r :: "'a::field"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case by (simp add: add_divide_distrib)
 qed
 
 lemma sum_abs[iff]: "\<bar>sum f A\<bar> \<le> sum (\<lambda>i. \<bar>f i\<bar>) A"
   for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case by (auto intro: abs_triangle_ineq order_trans)
 qed
 
 lemma sum_abs_ge_zero[iff]: "0 \<le> sum (\<lambda>i. \<bar>f i\<bar>) A"
   for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
   by (simp add: sum_nonneg)
 
 lemma abs_sum_abs[simp]: "\<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar> = (\<Sum>a\<in>A. \<bar>f a\<bar>)"
   for f :: "'a \<Rightarrow> 'b::ordered_ab_group_add_abs"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert a A)
   then have "\<bar>\<Sum>a\<in>insert a A. \<bar>f a\<bar>\<bar> = \<bar>\<bar>f a\<bar> + (\<Sum>a\<in>A. \<bar>f a\<bar>)\<bar>" by simp
   also from insert have "\<dots> = \<bar>\<bar>f a\<bar> + \<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar>\<bar>" by simp
   also have "\<dots> = \<bar>f a\<bar> + \<bar>\<Sum>a\<in>A. \<bar>f a\<bar>\<bar>" by (simp del: abs_of_nonneg)
   also from insert have "\<dots> = (\<Sum>a\<in>insert a A. \<bar>f a\<bar>)" by simp
   finally show ?case .
 qed
 
 lemma sum_product:
   fixes f :: "'a \<Rightarrow> 'b::semiring_0"
   shows "sum f A * sum g B = (\<Sum>i\<in>A. \<Sum>j\<in>B. f i * g j)"
   by (simp add: sum_distrib_left sum_distrib_right) (rule sum.swap)
 
 lemma sum_mult_sum_if_inj:
   fixes f :: "'a \<Rightarrow> 'b::semiring_0"
   shows "inj_on (\<lambda>(a, b). f a * g b) (A \<times> B) \<Longrightarrow>
     sum f A * sum g B = sum id {f a * g b |a b. a \<in> A \<and> b \<in> B}"
   by(auto simp: sum_product sum.cartesian_product intro!: sum.reindex_cong[symmetric])
 
 lemma sum_SucD: "sum f A = Suc n \<Longrightarrow> \<exists>a\<in>A. 0 < f a"
   by (induct A rule: infinite_finite_induct) auto
 
 lemma sum_eq_Suc0_iff:
   "finite A \<Longrightarrow> sum f A = Suc 0 \<longleftrightarrow> (\<exists>a\<in>A. f a = Suc 0 \<and> (\<forall>b\<in>A. a \<noteq> b \<longrightarrow> f b = 0))"
   by (induct A rule: finite_induct) (auto simp add: add_is_1)
 
 lemmas sum_eq_1_iff = sum_eq_Suc0_iff[simplified One_nat_def[symmetric]]
 
 lemma sum_Un_nat:
   "finite A \<Longrightarrow> finite B \<Longrightarrow> sum f (A \<union> B) = sum f A + sum f B - sum f (A \<inter> B)"
   for f :: "'a \<Rightarrow> nat"
   \<comment> \<open>For the natural numbers, we have subtraction.\<close>
   by (subst sum.union_inter [symmetric]) (auto simp: algebra_simps)
 
 lemma sum_diff1_nat: "sum f (A - {a}) = (if a \<in> A then sum f A - f a else sum f A)"
   for f :: "'a \<Rightarrow> nat"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
-  case insert
+  case (insert x F)
   then show ?case
-    apply (auto simp: insert_Diff_if)
-    apply (drule mk_disjoint_insert)
-    apply auto
-    done
+  proof (cases "a \<in> F")
+    case True
+    then have "\<exists>B. F = insert a B \<and> a \<notin> B"
+      by (auto simp: mk_disjoint_insert)
+    then show ?thesis  using insert
+      by (auto simp: insert_Diff_if)
+  qed (auto)
 qed
 
 lemma sum_diff_nat:
   fixes f :: "'a \<Rightarrow> nat"
   assumes "finite B" and "B \<subseteq> A"
   shows "sum f (A - B) = sum f A - sum f B"
   using assms
 proof induct
   case empty
   then show ?case by simp
 next
   case (insert x F)
   note IH = \<open>F \<subseteq> A \<Longrightarrow> sum f (A - F) = sum f A - sum f F\<close>
   from \<open>x \<notin> F\<close> \<open>insert x F \<subseteq> A\<close> have "x \<in> A - F" by simp
   then have A: "sum f ((A - F) - {x}) = sum f (A - F) - f x"
     by (simp add: sum_diff1_nat)
   from \<open>insert x F \<subseteq> A\<close> have "F \<subseteq> A" by simp
   with IH have "sum f (A - F) = sum f A - sum f F" by simp
   with A have B: "sum f ((A - F) - {x}) = sum f A - sum f F - f x"
     by simp
   from \<open>x \<notin> F\<close> have "A - insert x F = (A - F) - {x}" by auto
   with B have C: "sum f (A - insert x F) = sum f A - sum f F - f x"
     by simp
   from \<open>finite F\<close> \<open>x \<notin> F\<close> have "sum f (insert x F) = sum f F + f x"
     by simp
   with C have "sum f (A - insert x F) = sum f A - sum f (insert x F)"
     by simp
   then show ?case by simp
 qed
 
 lemma sum_comp_morphism:
   "h 0 = 0 \<Longrightarrow> (\<And>x y. h (x + y) = h x + h y) \<Longrightarrow> sum (h \<circ> g) A = h (sum g A)"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma (in comm_semiring_1) dvd_sum: "(\<And>a. a \<in> A \<Longrightarrow> d dvd f a) \<Longrightarrow> d dvd sum f A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma (in ordered_comm_monoid_add) sum_pos:
   "finite I \<Longrightarrow> I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> 0 < f i) \<Longrightarrow> 0 < sum f I"
   by (induct I rule: finite_ne_induct) (auto intro: add_pos_pos)
 
 lemma (in ordered_comm_monoid_add) sum_pos2:
   assumes I: "finite I" "i \<in> I" "0 < f i" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> f i"
   shows "0 < sum f I"
 proof -
   have "0 < f i + sum f (I - {i})"
     using assms by (intro add_pos_nonneg sum_nonneg) auto
   also have "\<dots> = sum f I"
     using assms by (simp add: sum.remove)
   finally show ?thesis .
 qed
 
 lemma sum_strict_mono2:
   fixes f :: "'a \<Rightarrow> 'b::ordered_cancel_comm_monoid_add"
   assumes "finite B" "A \<subseteq> B" "b \<in> B-A" "f b > 0" and "\<And>x. x \<in> B \<Longrightarrow> f x \<ge> 0"
   shows "sum f A < sum f B"
 proof -
   have "B - A \<noteq> {}"
     using assms(3) by blast
   have "sum f (B-A) > 0"
     by (rule sum_pos2) (use assms in auto)
   moreover have "sum f B = sum f (B-A) + sum f A"
     by (rule sum.subset_diff) (use assms in auto)
   ultimately show ?thesis
     using add_strict_increasing by auto
 qed
 
 lemma sum_cong_Suc:
   assumes "0 \<notin> A" "\<And>x. Suc x \<in> A \<Longrightarrow> f (Suc x) = g (Suc x)"
   shows "sum f A = sum g A"
 proof (rule sum.cong)
   fix x
   assume "x \<in> A"
   with assms(1) show "f x = g x"
     by (cases x) (auto intro!: assms(2))
 qed simp_all
 
 
 subsubsection \<open>Cardinality as special case of \<^const>\<open>sum\<close>\<close>
 
 lemma card_eq_sum: "card A = sum (\<lambda>x. 1) A"
 proof -
   have "plus \<circ> (\<lambda>_. Suc 0) = (\<lambda>_. Suc)"
     by (simp add: fun_eq_iff)
   then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) = Finite_Set.fold (\<lambda>_. Suc)"
     by (rule arg_cong)
   then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) 0 A = Finite_Set.fold (\<lambda>_. Suc) 0 A"
     by (blast intro: fun_cong)
   then show ?thesis
     by (simp add: card.eq_fold sum.eq_fold)
 qed
 
 context semiring_1
 begin
 
 lemma sum_constant [simp]:
   "(\<Sum>x \<in> A. y) = of_nat (card A) * y"
   by (induct A rule: infinite_finite_induct) (simp_all add: algebra_simps)
 
 context
   fixes A
   assumes \<open>finite A\<close>
 begin
 
 lemma sum_of_bool_eq [simp]:
   \<open>(\<Sum>x \<in> A. of_bool (P x)) = of_nat (card (A \<inter> {x. P x}))\<close> if \<open>finite A\<close>
   using \<open>finite A\<close> by induction simp_all
 
 lemma sum_mult_of_bool_eq [simp]:
   \<open>(\<Sum>x \<in> A. f x * of_bool (P x)) = (\<Sum>x \<in> (A \<inter> {x. P x}). f x)\<close>
   by (rule sum.mono_neutral_cong) (use \<open>finite A\<close> in auto)
 
 lemma sum_of_bool_mult_eq [simp]:
   \<open>(\<Sum>x \<in> A. of_bool (P x) * f x) = (\<Sum>x \<in> (A \<inter> {x. P x}). f x)\<close>
   by (rule sum.mono_neutral_cong) (use \<open>finite A\<close> in auto)
 
 end
 
 end
 
 lemma sum_Suc: "sum (\<lambda>x. Suc(f x)) A = sum f A + card A"
   using sum.distrib[of f "\<lambda>_. 1" A] by simp
 
 lemma sum_bounded_above:
   fixes K :: "'a::{semiring_1,ordered_comm_monoid_add}"
   assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> K"
   shows "sum f A \<le> of_nat (card A) * K"
 proof (cases "finite A")
   case True
   then show ?thesis
     using le sum_mono[where K=A and g = "\<lambda>x. K"] by simp
 next
   case False
   then show ?thesis by simp
 qed
 
 lemma sum_bounded_above_divide:
   fixes K :: "'a::linordered_field"
   assumes le: "\<And>i. i\<in>A \<Longrightarrow> f i \<le> K / of_nat (card A)" and fin: "finite A" "A \<noteq> {}"
   shows "sum f A \<le> K"
   using sum_bounded_above [of A f "K / of_nat (card A)", OF le] fin by simp
 
 lemma sum_bounded_above_strict:
   fixes K :: "'a::{ordered_cancel_comm_monoid_add,semiring_1}"
   assumes "\<And>i. i\<in>A \<Longrightarrow> f i < K" "card A > 0"
   shows "sum f A < of_nat (card A) * K"
   using assms sum_strict_mono[where A=A and g = "\<lambda>x. K"]
   by (simp add: card_gt_0_iff)
 
 lemma sum_bounded_below:
   fixes K :: "'a::{semiring_1,ordered_comm_monoid_add}"
   assumes le: "\<And>i. i\<in>A \<Longrightarrow> K \<le> f i"
   shows "of_nat (card A) * K \<le> sum f A"
 proof (cases "finite A")
   case True
   then show ?thesis
     using le sum_mono[where K=A and f = "\<lambda>x. K"] by simp
 next
   case False
   then show ?thesis by simp
 qed
 
 lemma convex_sum_bound_le:
   fixes x :: "'a \<Rightarrow> 'b::linordered_idom"
   assumes 0: "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> x i" and 1: "sum x I = 1"
       and \<delta>: "\<And>i. i \<in> I \<Longrightarrow> \<bar>a i - b\<bar> \<le> \<delta>"
     shows "\<bar>(\<Sum>i\<in>I. a i * x i) - b\<bar> \<le> \<delta>"
 proof -
   have [simp]: "(\<Sum>i\<in>I. c * x i) = c" for c
     by (simp flip: sum_distrib_left 1)
   then have "\<bar>(\<Sum>i\<in>I. a i * x i) - b\<bar> = \<bar>\<Sum>i\<in>I. (a i - b) * x i\<bar>"
     by (simp add: sum_subtractf left_diff_distrib)
   also have "\<dots> \<le> (\<Sum>i\<in>I. \<bar>(a i - b) * x i\<bar>)"
     using abs_abs abs_of_nonneg by blast
   also have "\<dots> \<le> (\<Sum>i\<in>I. \<bar>(a i - b)\<bar> * x i)"
     by (simp add: abs_mult 0)
   also have "\<dots> \<le> (\<Sum>i\<in>I. \<delta> * x i)"
     by (rule sum_mono) (use \<delta> "0" mult_right_mono in blast)
   also have "\<dots> = \<delta>"
     by simp
   finally show ?thesis .
 qed
 
 lemma card_UN_disjoint:
   assumes "finite I" and "\<forall>i\<in>I. finite (A i)"
     and "\<forall>i\<in>I. \<forall>j\<in>I. i \<noteq> j \<longrightarrow> A i \<inter> A j = {}"
   shows "card (\<Union>(A ` I)) = (\<Sum>i\<in>I. card(A i))"
 proof -
   have "(\<Sum>i\<in>I. card (A i)) = (\<Sum>i\<in>I. \<Sum>x\<in>A i. 1)"
     by simp
   with assms show ?thesis
     by (simp add: card_eq_sum sum.UNION_disjoint del: sum_constant)
 qed
 
 lemma card_Union_disjoint:
   assumes "pairwise disjnt C" and fin: "\<And>A. A \<in> C \<Longrightarrow> finite A"
   shows "card (\<Union>C) = sum card C"
 proof (cases "finite C")
   case True
   then show ?thesis
     using card_UN_disjoint [OF True, of "\<lambda>x. x"] assms
     by (simp add: disjnt_def fin pairwise_def)
 next
   case False
   then show ?thesis
     using assms card_eq_0_iff finite_UnionD by fastforce
 qed
 
 lemma card_Union_le_sum_card_weak:
   fixes U :: "'a set set"
   assumes "\<forall>u \<in> U. finite u"
   shows "card (\<Union>U) \<le> sum card U"
 proof (cases "finite U")
   case False
   then show "card (\<Union>U) \<le> sum card U"
     using card_eq_0_iff finite_UnionD by auto
 next
   case True
   then show "card (\<Union>U) \<le> sum card U"
   proof (induct U rule: finite_induct)
     case empty
     then show ?case by auto
   next
     case (insert x F)
     then have "card(\<Union>(insert x F)) \<le> card(x) + card (\<Union>F)" using card_Un_le by auto
     also have "... \<le> card(x) + sum card F" using insert.hyps by auto
     also have "... = sum card (insert x F)" using sum.insert_if and insert.hyps by auto
     finally show ?case .
   qed
 qed
 
 lemma card_Union_le_sum_card:
   fixes U :: "'a set set"
   shows "card (\<Union>U) \<le> sum card U"
   by (metis Union_upper card.infinite card_Union_le_sum_card_weak finite_subset zero_le)
 
 lemma card_UN_le:
   assumes "finite I"
   shows "card(\<Union>i\<in>I. A i) \<le> (\<Sum>i\<in>I. card(A i))"
   using assms
 proof induction
   case (insert i I)
   then show ?case
     using card_Un_le nat_add_left_cancel_le by (force intro: order_trans) 
 qed auto
 
 lemma card_quotient_disjoint:
   assumes "finite A" "inj_on (\<lambda>x. {x} // r) A"
   shows "card (A//r) = card A"
 proof -
   have "\<forall>i\<in>A. \<forall>j\<in>A. i \<noteq> j \<longrightarrow> r `` {j} \<noteq> r `` {i}"
     using assms by (fastforce simp add: quotient_def inj_on_def)
   with assms show ?thesis
     by (simp add: quotient_def card_UN_disjoint)
 qed
 
 lemma sum_multicount_gen:
   assumes "finite s" "finite t" "\<forall>j\<in>t. (card {i\<in>s. R i j} = k j)"
   shows "sum (\<lambda>i. (card {j\<in>t. R i j})) s = sum k t"
     (is "?l = ?r")
 proof-
   have "?l = sum (\<lambda>i. sum (\<lambda>x.1) {j\<in>t. R i j}) s"
     by auto
   also have "\<dots> = ?r"
     unfolding sum.swap_restrict [OF assms(1-2)]
     using assms(3) by auto
   finally show ?thesis .
 qed
 
 lemma sum_multicount:
   assumes "finite S" "finite T" "\<forall>j\<in>T. (card {i\<in>S. R i j} = k)"
   shows "sum (\<lambda>i. card {j\<in>T. R i j}) S = k * card T" (is "?l = ?r")
 proof-
   have "?l = sum (\<lambda>i. k) T"
     by (rule sum_multicount_gen) (auto simp: assms)
   also have "\<dots> = ?r" by (simp add: mult.commute)
   finally show ?thesis by auto
 qed
 
 lemma sum_card_image:
   assumes "finite A"
   assumes "pairwise (\<lambda>s t. disjnt (f s) (f t)) A"
   shows "sum card (f ` A) = sum (\<lambda>a. card (f a)) A"
 using assms
 proof (induct A)
   case (insert a A)
   show ?case
   proof cases
     assume "f a = {}"
     with insert show ?case
       by (subst sum.mono_neutral_right[where S="f ` A"]) (auto simp: pairwise_insert)
   next
     assume "f a \<noteq> {}"
     then have "sum card (insert (f a) (f ` A)) = card (f a) + sum card (f ` A)"
       using insert
       by (subst sum.insert) (auto simp: pairwise_insert)
     with insert show ?case by (simp add: pairwise_insert)
   qed
 qed simp
 
 text \<open>By Jakub Kądziołka:\<close>
 
 lemma sum_fun_comp:
   assumes "finite S" "finite R" "g ` S \<subseteq> R"
   shows "(\<Sum>x \<in> S. f (g x)) = (\<Sum>y \<in> R. of_nat (card {x \<in> S. g x = y}) * f y)"
 proof -
   let ?r = "relation_of (\<lambda>p q. g p = g q) S"
   have eqv: "equiv S ?r"
     unfolding relation_of_def by (auto intro: comp_equivI)
   have finite: "C \<in> S//?r \<Longrightarrow> finite C" for C
     by (fact finite_equiv_class[OF `finite S` equiv_type[OF `equiv S ?r`]])
   have disjoint: "A \<in> S//?r \<Longrightarrow> B \<in> S//?r \<Longrightarrow> A \<noteq> B \<Longrightarrow> A \<inter> B = {}" for A B
     using eqv quotient_disj by blast
 
   let ?cls = "\<lambda>y. {x \<in> S. y = g x}"
   have quot_as_img: "S//?r = ?cls ` g ` S"
     by (auto simp add: relation_of_def quotient_def)
   have cls_inj: "inj_on ?cls (g ` S)"
     by (auto intro: inj_onI)
 
   have rest_0: "(\<Sum>y \<in> R - g ` S. of_nat (card (?cls y)) * f y) = 0"
   proof -
     have "of_nat (card (?cls y)) * f y = 0" if asm: "y \<in> R - g ` S" for y
     proof -
       from asm have *: "?cls y = {}" by auto
       show ?thesis unfolding * by simp
     qed
     thus ?thesis by simp
   qed
 
   have "(\<Sum>x \<in> S. f (g x)) = (\<Sum>C \<in> S//?r. \<Sum>x \<in> C. f (g x))"
     using eqv finite disjoint
     by (simp flip: sum.Union_disjoint[simplified] add: Union_quotient)
   also have "... = (\<Sum>y \<in> g ` S. \<Sum>x \<in> ?cls y. f (g x))"
     unfolding quot_as_img by (simp add: sum.reindex[OF cls_inj])
   also have "... = (\<Sum>y \<in> g ` S. \<Sum>x \<in> ?cls y. f y)"
     by auto
   also have "... = (\<Sum>y \<in> g ` S. of_nat (card (?cls y)) * f y)"
     by (simp flip: sum_constant)
   also have "... = (\<Sum>y \<in> R. of_nat (card (?cls y)) * f y)"
     using rest_0 by (simp add: sum.subset_diff[OF \<open>g ` S \<subseteq> R\<close> \<open>finite R\<close>])
   finally show ?thesis
     by (simp add: eq_commute)
 qed
 
 
 
 subsubsection \<open>Cardinality of products\<close>
 
 lemma card_SigmaI [simp]:
   "finite A \<Longrightarrow> \<forall>a\<in>A. finite (B a) \<Longrightarrow> card (SIGMA x: A. B x) = (\<Sum>a\<in>A. card (B a))"
   by (simp add: card_eq_sum sum.Sigma del: sum_constant)
 
 (*
 lemma SigmaI_insert: "y \<notin> A ==>
   (SIGMA x:(insert y A). B x) = (({y} \<times> (B y)) \<union> (SIGMA x: A. B x))"
   by auto
 *)
 
 lemma card_cartesian_product: "card (A \<times> B) = card A * card B"
   by (cases "finite A \<and> finite B")
     (auto simp add: card_eq_0_iff dest: finite_cartesian_productD1 finite_cartesian_productD2)
 
 lemma card_cartesian_product_singleton:  "card ({x} \<times> A) = card A"
   by (simp add: card_cartesian_product)
 
 
 subsection \<open>Generalized product over a set\<close>
 
 context comm_monoid_mult
 begin
 
 sublocale prod: comm_monoid_set times 1
   defines prod = prod.F and prod' = prod.G ..
 
 abbreviation Prod ("\<Prod>_" [1000] 999)
   where "\<Prod>A \<equiv> prod (\<lambda>x. x) A"
 
 end
 
 syntax (ASCII)
   "_prod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(4PROD (_/:_)./ _)" [0, 51, 10] 10)
 syntax
   "_prod" :: "pttrn => 'a set => 'b => 'b::comm_monoid_mult"  ("(2\<Prod>(_/\<in>_)./ _)" [0, 51, 10] 10)
 translations \<comment> \<open>Beware of argument permutation!\<close>
   "\<Prod>i\<in>A. b" == "CONST prod (\<lambda>i. b) A"
 
 text \<open>Instead of \<^term>\<open>\<Prod>x\<in>{x. P}. e\<close> we introduce the shorter \<open>\<Prod>x|P. e\<close>.\<close>
 
 syntax (ASCII)
   "_qprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(4PROD _ |/ _./ _)" [0, 0, 10] 10)
 syntax
   "_qprod" :: "pttrn \<Rightarrow> bool \<Rightarrow> 'a \<Rightarrow> 'a"  ("(2\<Prod>_ | (_)./ _)" [0, 0, 10] 10)
 translations
   "\<Prod>x|P. t" => "CONST prod (\<lambda>x. t) {x. P}"
 
 context comm_monoid_mult
 begin
 
 lemma prod_dvd_prod: "(\<And>a. a \<in> A \<Longrightarrow> f a dvd g a) \<Longrightarrow> prod f A dvd prod g A"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by (auto intro: dvdI)
 next
   case empty
   then show ?case by (auto intro: dvdI)
 next
   case (insert a A)
   then have "f a dvd g a" and "prod f A dvd prod g A"
     by simp_all
   then obtain r s where "g a = f a * r" and "prod g A = prod f A * s"
     by (auto elim!: dvdE)
   then have "g a * prod g A = f a * prod f A * (r * s)"
     by (simp add: ac_simps)
   with insert.hyps show ?case
     by (auto intro: dvdI)
 qed
 
 lemma prod_dvd_prod_subset: "finite B \<Longrightarrow> A \<subseteq> B \<Longrightarrow> prod f A dvd prod f B"
   by (auto simp add: prod.subset_diff ac_simps intro: dvdI)
 
 end
 
 
 subsubsection \<open>Properties in more restricted classes of structures\<close>
 
 context linordered_nonzero_semiring
 begin
 
 lemma prod_ge_1: "(\<And>x. x \<in> A \<Longrightarrow> 1 \<le> f x) \<Longrightarrow> 1 \<le> prod f A"
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   have "1 * 1 \<le> f x * prod f F"
     by (rule mult_mono') (use insert in auto)
   with insert show ?case by simp
 qed
 
 lemma prod_le_1:
   fixes f :: "'b \<Rightarrow> 'a"
   assumes "\<And>x. x \<in> A \<Longrightarrow> 0 \<le> f x \<and> f x \<le> 1"
   shows "prod f A \<le> 1"
     using assms
 proof (induct A rule: infinite_finite_induct)
   case infinite
   then show ?case by simp
 next
   case empty
   then show ?case by simp
 next
   case (insert x F)
   then show ?case by (force simp: mult.commute intro: dest: mult_le_one)
 qed
 
 end
 
 context comm_semiring_1
 begin
 
 lemma dvd_prod_eqI [intro]:
   assumes "finite A" and "a \<in> A" and "b = f a"
   shows "b dvd prod f A"
 proof -
   from \<open>finite A\<close> have "prod f (insert a (A - {a})) = f a * prod f (A - {a})"
     by (intro prod.insert) auto
   also from \<open>a \<in> A\<close> have "insert a (A - {a}) = A"
     by blast
   finally have "prod f A = f a * prod f (A - {a})" .
   with \<open>b = f a\<close> show ?thesis
     by simp
 qed
 
 lemma dvd_prodI [intro]: "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> f a dvd prod f A"
   by auto
 
 lemma prod_zero:
   assumes "finite A" and "\<exists>a\<in>A. f a = 0"
   shows "prod f A = 0"
   using assms
 proof (induct A)
   case empty
   then show ?case by simp
 next
   case (insert a A)
   then have "f a = 0 \<or> (\<exists>a\<in>A. f a = 0)" by simp
-  then have "f a * prod f A = 0" by rule (simp_all add: insert)
+  then have "f a * prod f A = 0" by (rule disjE) (simp_all add: insert)
   with insert show ?case by simp
 qed
 
 lemma prod_dvd_prod_subset2:
   assumes "finite B" and "A \<subseteq> B" and "\<And>a. a \<in> A \<Longrightarrow> f a dvd g a"
   shows "prod f A dvd prod g B"
 proof -
   from assms have "prod f A dvd prod g A"
     by (auto intro: prod_dvd_prod)
   moreover from assms have "prod g A dvd prod g B"
     by (auto intro: prod_dvd_prod_subset)
   ultimately show ?thesis by (rule dvd_trans)
 qed
 
 end
 
 lemma (in semidom) prod_zero_iff [simp]:
   fixes f :: "'b \<Rightarrow> 'a"
   assumes "finite A"
   shows "prod f A = 0 \<longleftrightarrow> (\<exists>a\<in>A. f a = 0)"
   using assms by (induct A) (auto simp: no_zero_divisors)
 
 lemma (in semidom_divide) prod_diff1:
   assumes "finite A" and "f a \<noteq> 0"
   shows "prod f (A - {a}) = (if a \<in> A then prod f A div f a else prod f A)"
 proof (cases "a \<notin> A")
   case True
   then show ?thesis by simp
 next
   case False
   with assms show ?thesis
   proof induct
     case empty
     then show ?case by simp
   next
     case (insert b B)
     then show ?case
     proof (cases "a = b")
       case True
       with insert show ?thesis by simp
     next
       case False
       with insert have "a \<in> B" by simp
       define C where "C = B - {a}"
       with \<open>finite B\<close> \<open>a \<in> B\<close> have "B = insert a C" "finite C" "a \<notin> C"
         by auto
       with insert show ?thesis
         by (auto simp add: insert_commute ac_simps)
     qed
   qed
 qed
 
 lemma sum_zero_power [simp]: "(\<Sum>i\<in>A. c i * 0^i) = (if finite A \<and> 0 \<in> A then c 0 else 0)"
   for c :: "nat \<Rightarrow> 'a::division_ring"
   by (induct A rule: infinite_finite_induct) auto
 
 lemma sum_zero_power' [simp]:
   "(\<Sum>i\<in>A. c i * 0^i / d i) = (if finite A \<and> 0 \<in> A then c 0 / d 0 else 0)"
   for c :: "nat \<Rightarrow> 'a::field"
   using sum_zero_power [of "\<lambda>i. c i / d i" A] by auto
 
 lemma (in field) prod_inversef: "prod (inverse \<circ> f) A = inverse (prod f A)"
  proof (cases "finite A")
    case True
    then show ?thesis
      by (induct A rule: finite_induct) simp_all
  next
    case False
    then show ?thesis
      by auto
  qed
 
 lemma (in field) prod_dividef: "(\<Prod>x\<in>A. f x / g x) = prod f A / prod g A"
   using prod_inversef [of g A] by (simp add: divide_inverse prod.distrib)
 
 lemma prod_Un:
   fixes f :: "'b \<Rightarrow> 'a :: field"
   assumes "finite A" and "finite B"
     and "\<forall>x\<in>A \<inter> B. f x \<noteq> 0"
   shows "prod f (A \<union> B) = prod f A * prod f B / prod f (A \<inter> B)"
 proof -
   from assms have "prod f A * prod f B = prod f (A \<union> B) * prod f (A \<inter> B)"
     by (simp add: prod.union_inter [symmetric, of A B])
   with assms show ?thesis
     by simp
 qed
 
 context linordered_semidom
 begin
 
 lemma prod_nonneg: "(\<forall>a\<in>A. 0 \<le> f a) \<Longrightarrow> 0 \<le> prod f A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma prod_pos: "(\<forall>a\<in>A. 0 < f a) \<Longrightarrow> 0 < prod f A"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma prod_mono:
   "(\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i \<and> f i \<le> g i) \<Longrightarrow> prod f A \<le> prod g A"
   by (induct A rule: infinite_finite_induct) (force intro!: prod_nonneg mult_mono)+
 
 lemma prod_mono_strict:
   assumes "finite A" "\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i \<and> f i < g i" "A \<noteq> {}"
   shows "prod f A < prod g A"
   using assms
 proof (induct A rule: finite_induct)
   case empty
   then show ?case by simp
 next
   case insert
   then show ?case by (force intro: mult_strict_mono' prod_nonneg)
 qed
 
 lemma prod_le_power:
   assumes A: "\<And>i. i \<in> A \<Longrightarrow> 0 \<le> f i \<and> f i \<le> n" "card A \<le> k" and "n \<ge> 1"
   shows "prod f A \<le> n ^ k"
   using A
 proof (induction A arbitrary: k rule: infinite_finite_induct)
   case (insert i A)
   then obtain k' where k': "card A \<le> k'" "k = Suc k'"
     using Suc_le_D by force
   have "f i * prod f A \<le> n * n ^ k'"
     using insert \<open>n \<ge> 1\<close> k' by (intro prod_nonneg mult_mono; force)
   then show ?case 
     by (auto simp: \<open>k = Suc k'\<close> insert.hyps)
 qed (use \<open>n \<ge> 1\<close> in auto)
 
 end
 
 lemma prod_mono2:
   fixes f :: "'a \<Rightarrow> 'b :: linordered_idom"
   assumes fin: "finite B"
     and sub: "A \<subseteq> B"
     and nn: "\<And>b. b \<in> B-A \<Longrightarrow> 1 \<le> f b"
     and A: "\<And>a. a \<in> A \<Longrightarrow> 0 \<le> f a"
   shows "prod f A \<le> prod f B"
 proof -
   have "prod f A \<le> prod f A * prod f (B-A)"
     by (metis prod_ge_1 A mult_le_cancel_left1 nn not_less prod_nonneg)
   also from fin finite_subset[OF sub fin] have "\<dots> = prod f (A \<union> (B-A))"
     by (simp add: prod.union_disjoint del: Un_Diff_cancel)
   also from sub have "A \<union> (B-A) = B" by blast
   finally show ?thesis .
 qed
 
 lemma less_1_prod:
   fixes f :: "'a \<Rightarrow> 'b::linordered_idom"
   shows "finite I \<Longrightarrow> I \<noteq> {} \<Longrightarrow> (\<And>i. i \<in> I \<Longrightarrow> 1 < f i) \<Longrightarrow> 1 < prod f I"
   by (induct I rule: finite_ne_induct) (auto intro: less_1_mult)
 
 lemma less_1_prod2:
   fixes f :: "'a \<Rightarrow> 'b::linordered_idom"
   assumes I: "finite I" "i \<in> I" "1 < f i" "\<And>i. i \<in> I \<Longrightarrow> 1 \<le> f i"
   shows "1 < prod f I"
 proof -
   have "1 < f i * prod f (I - {i})"
     using assms
     by (meson DiffD1 leI less_1_mult less_le_trans mult_le_cancel_left1 prod_ge_1)
   also have "\<dots> = prod f I"
     using assms by (simp add: prod.remove)
   finally show ?thesis .
 qed
 
 lemma (in linordered_field) abs_prod: "\<bar>prod f A\<bar> = (\<Prod>x\<in>A. \<bar>f x\<bar>)"
   by (induct A rule: infinite_finite_induct) (simp_all add: abs_mult)
 
 lemma prod_eq_1_iff [simp]: "finite A \<Longrightarrow> prod f A = 1 \<longleftrightarrow> (\<forall>a\<in>A. f a = 1)"
   for f :: "'a \<Rightarrow> nat"
   by (induct A rule: finite_induct) simp_all
 
 lemma prod_pos_nat_iff [simp]: "finite A \<Longrightarrow> prod f A > 0 \<longleftrightarrow> (\<forall>a\<in>A. f a > 0)"
   for f :: "'a \<Rightarrow> nat"
   using prod_zero_iff by (simp del: neq0_conv add: zero_less_iff_neq_zero)
 
 lemma prod_constant [simp]: "(\<Prod>x\<in> A. y) = y ^ card A"
   for y :: "'a::comm_monoid_mult"
   by (induct A rule: infinite_finite_induct) simp_all
 
 lemma prod_power_distrib: "prod f A ^ n = prod (\<lambda>x. (f x) ^ n) A"
   for f :: "'a \<Rightarrow> 'b::comm_semiring_1"
   by (induct A rule: infinite_finite_induct) (auto simp add: power_mult_distrib)
 
 lemma power_sum: "c ^ (\<Sum>a\<in>A. f a) = (\<Prod>a\<in>A. c ^ f a)"
   by (induct A rule: infinite_finite_induct) (simp_all add: power_add)
 
 lemma prod_gen_delta:
   fixes b :: "'b \<Rightarrow> 'a::comm_monoid_mult"
   assumes fin: "finite S"
   shows "prod (\<lambda>k. if k = a then b k else c) S =
     (if a \<in> S then b a * c ^ (card S - 1) else c ^ card S)"
 proof -
   let ?f = "(\<lambda>k. if k=a then b k else c)"
   show ?thesis
   proof (cases "a \<in> S")
     case False
     then have "\<forall> k\<in> S. ?f k = c" by simp
     with False show ?thesis by (simp add: prod_constant)
   next
     case True
     let ?A = "S - {a}"
     let ?B = "{a}"
     from True have eq: "S = ?A \<union> ?B" by blast
     have disjoint: "?A \<inter> ?B = {}" by simp
     from fin have fin': "finite ?A" "finite ?B" by auto
     have f_A0: "prod ?f ?A = prod (\<lambda>i. c) ?A"
       by (rule prod.cong) auto
     from fin True have card_A: "card ?A = card S - 1" by auto
     have f_A1: "prod ?f ?A = c ^ card ?A"
       unfolding f_A0 by (rule prod_constant)
     have "prod ?f ?A * prod ?f ?B = prod ?f S"
       using prod.union_disjoint[OF fin' disjoint, of ?f, unfolded eq[symmetric]]
       by simp
     with True card_A show ?thesis
       by (simp add: f_A1 field_simps cong add: prod.cong cong del: if_weak_cong)
   qed
 qed
 
 lemma sum_image_le:
   fixes g :: "'a \<Rightarrow> 'b::ordered_comm_monoid_add"
   assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> 0 \<le> g(f i)"
     shows "sum g (f ` I) \<le> sum (g \<circ> f) I"
   using assms
 proof induction
   case empty
   then show ?case by auto
 next
   case (insert x F)
   from insertI1 have "0 \<le> g (f x)" by (rule insert)
   hence 1: "sum g (f ` F) \<le> g (f x) + sum g (f ` F)" using add_increasing by blast
   have 2: "sum g (f ` F) \<le> sum (g \<circ> f) F" using insert by blast
   have "sum g (f ` insert x F) = sum g (insert (f x) (f ` F))" by simp
   also have "\<dots> \<le> g (f x) + sum g (f ` F)" by (simp add: 1 insert sum.insert_if)
   also from 2 have "\<dots> \<le> g (f x) + sum (g \<circ> f) F" by (rule add_left_mono)
   also from insert(1, 2) have "\<dots> = sum (g \<circ> f) (insert x F)" by (simp add: sum.insert_if)
   finally show ?case .
 qed
 
 end
diff --git a/src/HOL/HOL.thy b/src/HOL/HOL.thy
--- a/src/HOL/HOL.thy
+++ b/src/HOL/HOL.thy
@@ -1,2177 +1,2177 @@
 (*  Title:      HOL/HOL.thy
     Author:     Tobias Nipkow, Markus Wenzel, and Larry Paulson
 *)
 
 section \<open>The basis of Higher-Order Logic\<close>
 
 theory HOL
 imports Pure Tools.Code_Generator
 keywords
   "try" "solve_direct" "quickcheck" "print_coercions" "print_claset"
     "print_induct_rules" :: diag and
   "quickcheck_params" :: thy_decl
 abbrevs "?<" = "\<exists>\<^sub>\<le>\<^sub>1"
 begin
 
 ML_file \<open>~~/src/Tools/misc_legacy.ML\<close>
 ML_file \<open>~~/src/Tools/try.ML\<close>
 ML_file \<open>~~/src/Tools/quickcheck.ML\<close>
 ML_file \<open>~~/src/Tools/solve_direct.ML\<close>
 ML_file \<open>~~/src/Tools/IsaPlanner/zipper.ML\<close>
 ML_file \<open>~~/src/Tools/IsaPlanner/isand.ML\<close>
 ML_file \<open>~~/src/Tools/IsaPlanner/rw_inst.ML\<close>
 ML_file \<open>~~/src/Provers/hypsubst.ML\<close>
 ML_file \<open>~~/src/Provers/splitter.ML\<close>
 ML_file \<open>~~/src/Provers/classical.ML\<close>
 ML_file \<open>~~/src/Provers/blast.ML\<close>
 ML_file \<open>~~/src/Provers/clasimp.ML\<close>
 ML_file \<open>~~/src/Tools/eqsubst.ML\<close>
 ML_file \<open>~~/src/Provers/quantifier1.ML\<close>
 ML_file \<open>~~/src/Tools/atomize_elim.ML\<close>
 ML_file \<open>~~/src/Tools/cong_tac.ML\<close>
 ML_file \<open>~~/src/Tools/intuitionistic.ML\<close> setup \<open>Intuitionistic.method_setup \<^binding>\<open>iprover\<close>\<close>
 ML_file \<open>~~/src/Tools/project_rule.ML\<close>
 ML_file \<open>~~/src/Tools/subtyping.ML\<close>
 ML_file \<open>~~/src/Tools/case_product.ML\<close>
 
 
 ML \<open>Plugin_Name.declare_setup \<^binding>\<open>extraction\<close>\<close>
 
 ML \<open>
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_random\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_exhaustive\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_bounded_forall\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_full_exhaustive\<close>;
   Plugin_Name.declare_setup \<^binding>\<open>quickcheck_narrowing\<close>;
 \<close>
 ML \<open>
   Plugin_Name.define_setup \<^binding>\<open>quickcheck\<close>
    [\<^plugin>\<open>quickcheck_exhaustive\<close>,
     \<^plugin>\<open>quickcheck_random\<close>,
     \<^plugin>\<open>quickcheck_bounded_forall\<close>,
     \<^plugin>\<open>quickcheck_full_exhaustive\<close>,
     \<^plugin>\<open>quickcheck_narrowing\<close>]
 \<close>
 
 
 subsection \<open>Primitive logic\<close>
 
 text \<open>
 The definition of the logic is based on Mike Gordon's technical report @{cite "Gordon-TR68"} that
 describes the first implementation of HOL. However, there are a number of differences.
 In particular, we start with the definite description operator and introduce Hilbert's \<open>\<epsilon>\<close> operator
 only much later. Moreover, axiom \<open>(P \<longrightarrow> Q) \<longrightarrow> (Q \<longrightarrow> P) \<longrightarrow> (P = Q)\<close> is derived from the other
 axioms. The fact that this axiom is derivable was first noticed by Bruno Barras (for Mike Gordon's
 line of HOL systems) and later independently by Alexander Maletzky (for Isabelle/HOL).
 \<close>
 
 subsubsection \<open>Core syntax\<close>
 
 setup \<open>Axclass.class_axiomatization (\<^binding>\<open>type\<close>, [])\<close>
 default_sort type
 setup \<open>Object_Logic.add_base_sort \<^sort>\<open>type\<close>\<close>
 
 setup \<open>Proofterm.set_preproc (Proof_Rewrite_Rules.standard_preproc [])\<close>
 
 axiomatization where fun_arity: "OFCLASS('a \<Rightarrow> 'b, type_class)"
 instance "fun" :: (type, type) type by (rule fun_arity)
 
 axiomatization where itself_arity: "OFCLASS('a itself, type_class)"
 instance itself :: (type) type by (rule itself_arity)
 
 typedecl bool
 
 judgment Trueprop :: "bool \<Rightarrow> prop"  ("(_)" 5)
 
 axiomatization implies :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<longrightarrow>" 25)
   and eq :: "['a, 'a] \<Rightarrow> bool"
   and The :: "('a \<Rightarrow> bool) \<Rightarrow> 'a"
 
 notation (input)
   eq  (infixl "=" 50)
 notation (output)
   eq  (infix "=" 50)
 
 text \<open>The input syntax for \<open>eq\<close> is more permissive than the output syntax
 because of the large amount of material that relies on infixl.\<close>
 
 subsubsection \<open>Defined connectives and quantifiers\<close>
 
 definition True :: bool
   where "True \<equiv> ((\<lambda>x::bool. x) = (\<lambda>x. x))"
 
 definition All :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<forall>" 10)
   where "All P \<equiv> (P = (\<lambda>x. True))"
 
 definition Ex :: "('a \<Rightarrow> bool) \<Rightarrow> bool"  (binder "\<exists>" 10)
   where "Ex P \<equiv> \<forall>Q. (\<forall>x. P x \<longrightarrow> Q) \<longrightarrow> Q"
 
 definition False :: bool
   where "False \<equiv> (\<forall>P. P)"
 
 definition Not :: "bool \<Rightarrow> bool"  ("\<not> _" [40] 40)
   where not_def: "\<not> P \<equiv> P \<longrightarrow> False"
 
 definition conj :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<and>" 35)
   where and_def: "P \<and> Q \<equiv> \<forall>R. (P \<longrightarrow> Q \<longrightarrow> R) \<longrightarrow> R"
 
 definition disj :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<or>" 30)
   where or_def: "P \<or> Q \<equiv> \<forall>R. (P \<longrightarrow> R) \<longrightarrow> (Q \<longrightarrow> R) \<longrightarrow> R"
 
 definition Uniq :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Uniq P \<equiv> (\<forall>x y. P x \<longrightarrow> P y \<longrightarrow> y = x)"
 
 definition Ex1 :: "('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "Ex1 P \<equiv> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> y = x)"
 
 
 subsubsection \<open>Additional concrete syntax\<close>
 
 syntax (ASCII) "_Uniq" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(4?< _./ _)" [0, 10] 10)
 syntax "_Uniq" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(2\<exists>\<^sub>\<le>\<^sub>1 _./ _)" [0, 10] 10)
 translations "\<exists>\<^sub>\<le>\<^sub>1x. P" \<rightleftharpoons> "CONST Uniq (\<lambda>x. P)"
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs_tr' \<^const_syntax>\<open>Uniq\<close> \<^syntax_const>\<open>_Uniq\<close>]
 \<close> \<comment> \<open>to avoid eta-contraction of body\<close>
 
 
 syntax (ASCII)
   "_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3EX! _./ _)" [0, 10] 10)
 syntax (input)
   "_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3?! _./ _)" [0, 10] 10)
 syntax "_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3\<exists>!_./ _)" [0, 10] 10)
 translations "\<exists>!x. P" \<rightleftharpoons> "CONST Ex1 (\<lambda>x. P)"
 
 print_translation \<open>
  [Syntax_Trans.preserve_binder_abs_tr' \<^const_syntax>\<open>Ex1\<close> \<^syntax_const>\<open>_Ex1\<close>]
 \<close> \<comment> \<open>to avoid eta-contraction of body\<close>
 
 
 syntax
   "_Not_Ex" :: "idts \<Rightarrow> bool \<Rightarrow> bool"  ("(3\<nexists>_./ _)" [0, 10] 10)
   "_Not_Ex1" :: "pttrn \<Rightarrow> bool \<Rightarrow> bool"  ("(3\<nexists>!_./ _)" [0, 10] 10)
 translations
   "\<nexists>x. P" \<rightleftharpoons> "\<not> (\<exists>x. P)"
   "\<nexists>!x. P" \<rightleftharpoons> "\<not> (\<exists>!x. P)"
 
 
 abbreviation not_equal :: "['a, 'a] \<Rightarrow> bool"  (infix "\<noteq>" 50)
   where "x \<noteq> y \<equiv> \<not> (x = y)"
 
 notation (ASCII)
   Not  ("~ _" [40] 40) and
   conj  (infixr "&" 35) and
   disj  (infixr "|" 30) and
   implies  (infixr "-->" 25) and
   not_equal  (infix "~=" 50)
 
 abbreviation (iff)
   iff :: "[bool, bool] \<Rightarrow> bool"  (infixr "\<longleftrightarrow>" 25)
   where "A \<longleftrightarrow> B \<equiv> A = B"
 
 syntax "_The" :: "[pttrn, bool] \<Rightarrow> 'a"  ("(3THE _./ _)" [0, 10] 10)
 translations "THE x. P" \<rightleftharpoons> "CONST The (\<lambda>x. P)"
 print_translation \<open>
   [(\<^const_syntax>\<open>The\<close>, fn _ => fn [Abs abs] =>
       let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
       in Syntax.const \<^syntax_const>\<open>_The\<close> $ x $ t end)]
 \<close>  \<comment> \<open>To avoid eta-contraction of body\<close>
 
 nonterminal letbinds and letbind
 syntax
   "_bind"       :: "[pttrn, 'a] \<Rightarrow> letbind"              ("(2_ =/ _)" 10)
   ""            :: "letbind \<Rightarrow> letbinds"                 ("_")
   "_binds"      :: "[letbind, letbinds] \<Rightarrow> letbinds"     ("_;/ _")
   "_Let"        :: "[letbinds, 'a] \<Rightarrow> 'a"                ("(let (_)/ in (_))" [0, 10] 10)
 
 nonterminal case_syn and cases_syn
 syntax
   "_case_syntax" :: "['a, cases_syn] \<Rightarrow> 'b"  ("(case _ of/ _)" 10)
   "_case1" :: "['a, 'b] \<Rightarrow> case_syn"  ("(2_ \<Rightarrow>/ _)" 10)
   "" :: "case_syn \<Rightarrow> cases_syn"  ("_")
   "_case2" :: "[case_syn, cases_syn] \<Rightarrow> cases_syn"  ("_/ | _")
 syntax (ASCII)
   "_case1" :: "['a, 'b] \<Rightarrow> case_syn"  ("(2_ =>/ _)" 10)
 
 notation (ASCII)
   All  (binder "ALL " 10) and
   Ex  (binder "EX " 10)
 
 notation (input)
   All  (binder "! " 10) and
   Ex  (binder "? " 10)
 
 
 subsubsection \<open>Axioms and basic definitions\<close>
 
 axiomatization where
   refl: "t = (t::'a)" and
   subst: "s = t \<Longrightarrow> P s \<Longrightarrow> P t" and
   ext: "(\<And>x::'a. (f x ::'b) = g x) \<Longrightarrow> (\<lambda>x. f x) = (\<lambda>x. g x)"
     \<comment> \<open>Extensionality is built into the meta-logic, and this rule expresses
          a related property.  It is an eta-expanded version of the traditional
          rule, and similar to the ABS rule of HOL\<close> and
 
   the_eq_trivial: "(THE x. x = a) = (a::'a)"
 
 axiomatization where
   impI: "(P \<Longrightarrow> Q) \<Longrightarrow> P \<longrightarrow> Q" and
   mp: "\<lbrakk>P \<longrightarrow> Q; P\<rbrakk> \<Longrightarrow> Q" and
 
   True_or_False: "(P = True) \<or> (P = False)"
 
 definition If :: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("(if (_)/ then (_)/ else (_))" [0, 0, 10] 10)
   where "If P x y \<equiv> (THE z::'a. (P = True \<longrightarrow> z = x) \<and> (P = False \<longrightarrow> z = y))"
 
 definition Let :: "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b"
   where "Let s f \<equiv> f s"
 
 translations
   "_Let (_binds b bs) e"  \<rightleftharpoons> "_Let b (_Let bs e)"
   "let x = a in e"        \<rightleftharpoons> "CONST Let a (\<lambda>x. e)"
 
 axiomatization undefined :: 'a
 
 class default = fixes default :: 'a
 
 
 subsection \<open>Fundamental rules\<close>
 
 subsubsection \<open>Equality\<close>
 
 lemma sym: "s = t \<Longrightarrow> t = s"
   by (erule subst) (rule refl)
 
 lemma ssubst: "t = s \<Longrightarrow> P s \<Longrightarrow> P t"
   by (drule sym) (erule subst)
 
 lemma trans: "\<lbrakk>r = s; s = t\<rbrakk> \<Longrightarrow> r = t"
   by (erule subst)
 
 lemma trans_sym [Pure.elim?]: "r = s \<Longrightarrow> t = s \<Longrightarrow> r = t"
   by (rule trans [OF _ sym])
 
 lemma meta_eq_to_obj_eq:
   assumes "A \<equiv> B"
   shows "A = B"
   unfolding assms by (rule refl)
 
 text \<open>Useful with \<open>erule\<close> for proving equalities from known equalities.\<close>
      (* a = b
         |   |
         c = d   *)
 lemma box_equals: "\<lbrakk>a = b; a = c; b = d\<rbrakk> \<Longrightarrow> c = d"
   by (iprover intro: sym trans)
 
 text \<open>For calculational reasoning:\<close>
 
 lemma forw_subst: "a = b \<Longrightarrow> P b \<Longrightarrow> P a"
   by (rule ssubst)
 
 lemma back_subst: "P a \<Longrightarrow> a = b \<Longrightarrow> P b"
   by (rule subst)
 
 
 subsubsection \<open>Congruence rules for application\<close>
 
 text \<open>Similar to \<open>AP_THM\<close> in Gordon's HOL.\<close>
 lemma fun_cong: "(f :: 'a \<Rightarrow> 'b) = g \<Longrightarrow> f x = g x"
   by (iprover intro: refl elim: subst)
 
 text \<open>Similar to \<open>AP_TERM\<close> in Gordon's HOL and FOL's \<open>subst_context\<close>.\<close>
 lemma arg_cong: "x = y \<Longrightarrow> f x = f y"
   by (iprover intro: refl elim: subst)
 
 lemma arg_cong2: "\<lbrakk>a = b; c = d\<rbrakk> \<Longrightarrow> f a c = f b d"
   by (iprover intro: refl elim: subst)
 
 lemma cong: "\<lbrakk>f = g; (x::'a) = y\<rbrakk> \<Longrightarrow> f x = g y"
   by (iprover intro: refl elim: subst)
 
 ML \<open>fun cong_tac ctxt = Cong_Tac.cong_tac ctxt @{thm cong}\<close>
 
 
 subsubsection \<open>Equality of booleans -- iff\<close>
 
 lemma iffD2: "\<lbrakk>P = Q; Q\<rbrakk> \<Longrightarrow> P"
   by (erule ssubst)
 
 lemma rev_iffD2: "\<lbrakk>Q; P = Q\<rbrakk> \<Longrightarrow> P"
   by (erule iffD2)
 
 lemma iffD1: "Q = P \<Longrightarrow> Q \<Longrightarrow> P"
   by (drule sym) (rule iffD2)
 
 lemma rev_iffD1: "Q \<Longrightarrow> Q = P \<Longrightarrow> P"
   by (drule sym) (rule rev_iffD2)
 
 lemma iffE:
   assumes major: "P = Q"
     and minor: "\<lbrakk>P \<longrightarrow> Q; Q \<longrightarrow> P\<rbrakk> \<Longrightarrow> R"
   shows R
   by (iprover intro: minor impI major [THEN iffD2] major [THEN iffD1])
 
 
 subsubsection \<open>True (1)\<close>
 
 lemma TrueI: True
   unfolding True_def by (rule refl)
 
 lemma eqTrueE: "P = True \<Longrightarrow> P"
   by (erule iffD2) (rule TrueI)
 
 
 subsubsection \<open>Universal quantifier (1)\<close>
 
 lemma spec: "\<forall>x::'a. P x \<Longrightarrow> P x"
   unfolding All_def by (iprover intro: eqTrueE fun_cong)
 
 lemma allE:
   assumes major: "\<forall>x. P x" and minor: "P x \<Longrightarrow> R"
   shows R
   by (iprover intro: minor major [THEN spec])
 
 lemma all_dupE:
   assumes major: "\<forall>x. P x" and minor: "\<lbrakk>P x; \<forall>x. P x\<rbrakk> \<Longrightarrow> R"
   shows R
   by (iprover intro: minor major major [THEN spec])
 
 
 subsubsection \<open>False\<close>
 
 text \<open>
   Depends upon \<open>spec\<close>; it is impossible to do propositional
   logic before quantifiers!
 \<close>
 
 lemma FalseE: "False \<Longrightarrow> P"
   unfolding False_def by (erule spec)
 
 lemma False_neq_True: "False = True \<Longrightarrow> P"
   by (erule eqTrueE [THEN FalseE])
 
 
 subsubsection \<open>Negation\<close>
 
 lemma notI:
   assumes "P \<Longrightarrow> False"
   shows "\<not> P"
   unfolding not_def by (iprover intro: impI assms)
 
 lemma False_not_True: "False \<noteq> True"
   by (iprover intro: notI elim: False_neq_True)
 
 lemma True_not_False: "True \<noteq> False"
   by (iprover intro: notI dest: sym elim: False_neq_True)
 
 lemma notE: "\<lbrakk>\<not> P; P\<rbrakk> \<Longrightarrow> R"
   unfolding not_def
   by (iprover intro: mp [THEN FalseE])
 
 
 subsubsection \<open>Implication\<close>
 
 lemma impE:
   assumes "P \<longrightarrow> Q" P "Q \<Longrightarrow> R"
   shows R
   by (iprover intro: assms mp)
 
 text \<open>Reduces \<open>Q\<close> to \<open>P \<longrightarrow> Q\<close>, allowing substitution in \<open>P\<close>.\<close>
 lemma rev_mp: "\<lbrakk>P; P \<longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
   by (rule mp)
 
 lemma contrapos_nn:
   assumes major: "\<not> Q"
     and minor: "P \<Longrightarrow> Q"
   shows "\<not> P"
   by (iprover intro: notI minor major [THEN notE])
 
 text \<open>Not used at all, but we already have the other 3 combinations.\<close>
 lemma contrapos_pn:
   assumes major: "Q"
     and minor: "P \<Longrightarrow> \<not> Q"
   shows "\<not> P"
   by (iprover intro: notI minor major notE)
 
 lemma not_sym: "t \<noteq> s \<Longrightarrow> s \<noteq> t"
   by (erule contrapos_nn) (erule sym)
 
 lemma eq_neq_eq_imp_neq: "\<lbrakk>x = a; a \<noteq> b; b = y\<rbrakk> \<Longrightarrow> x \<noteq> y"
   by (erule subst, erule ssubst, assumption)
 
 
 subsubsection \<open>Disjunction (1)\<close>
 
 lemma disjE:
   assumes major: "P \<or> Q"
     and minorP: "P \<Longrightarrow> R"
     and minorQ: "Q \<Longrightarrow> R"
   shows R
   by (iprover intro: minorP minorQ impI
       major [unfolded or_def, THEN spec, THEN mp, THEN mp])
 
 
 subsubsection \<open>Derivation of \<open>iffI\<close>\<close>
 
 text \<open>In an intuitionistic version of HOL \<open>iffI\<close> needs to be an axiom.\<close>
 
 lemma iffI:
   assumes "P \<Longrightarrow> Q" and "Q \<Longrightarrow> P"
   shows "P = Q"
 proof (rule disjE[OF True_or_False[of P]])
   assume 1: "P = True"
   note Q = assms(1)[OF eqTrueE[OF this]]
   from 1 show ?thesis
   proof (rule ssubst)
     from True_or_False[of Q] show "True = Q"
     proof (rule disjE)
       assume "Q = True"
       thus ?thesis by(rule sym)
     next
       assume "Q = False"
       with Q have False by (rule rev_iffD1)
       thus ?thesis by (rule FalseE)
     qed
   qed
 next
   assume 2: "P = False"
   thus ?thesis
   proof (rule ssubst)
     from True_or_False[of Q] show "False = Q"
     proof (rule disjE)
       assume "Q = True"
       from 2 assms(2)[OF eqTrueE[OF this]] have False by (rule iffD1)
       thus ?thesis by (rule FalseE)
     next
       assume "Q = False"
       thus ?thesis by(rule sym)
     qed
   qed
 qed
 
 
 subsubsection \<open>True (2)\<close>
 
 lemma eqTrueI: "P \<Longrightarrow> P = True"
   by (iprover intro: iffI TrueI)
 
 
 subsubsection \<open>Universal quantifier (2)\<close>
 
 lemma allI:
   assumes "\<And>x::'a. P x"
   shows "\<forall>x. P x"
   unfolding All_def by (iprover intro: ext eqTrueI assms)
 
 
 subsubsection \<open>Existential quantifier\<close>
 
 lemma exI: "P x \<Longrightarrow> \<exists>x::'a. P x"
   unfolding Ex_def by (iprover intro: allI allE impI mp)
 
 lemma exE:
   assumes major: "\<exists>x::'a. P x"
     and minor: "\<And>x. P x \<Longrightarrow> Q"
   shows "Q"
   by (rule major [unfolded Ex_def, THEN spec, THEN mp]) (iprover intro: impI [THEN allI] minor)
 
 
 subsubsection \<open>Conjunction\<close>
 
 lemma conjI: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> P \<and> Q"
   unfolding and_def by (iprover intro: impI [THEN allI] mp)
 
 lemma conjunct1: "\<lbrakk>P \<and> Q\<rbrakk> \<Longrightarrow> P"
   unfolding and_def by (iprover intro: impI dest: spec mp)
 
 lemma conjunct2: "\<lbrakk>P \<and> Q\<rbrakk> \<Longrightarrow> Q"
   unfolding and_def by (iprover intro: impI dest: spec mp)
 
 lemma conjE:
   assumes major: "P \<and> Q"
     and minor: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R"
   shows R
 proof (rule minor)
   show P by (rule major [THEN conjunct1])
   show Q by (rule major [THEN conjunct2])
 qed
 
 lemma context_conjI:
   assumes P "P \<Longrightarrow> Q"
   shows "P \<and> Q"
   by (iprover intro: conjI assms)
 
 
 subsubsection \<open>Disjunction (2)\<close>
 
 lemma disjI1: "P \<Longrightarrow> P \<or> Q"
   unfolding or_def by (iprover intro: allI impI mp)
 
 lemma disjI2: "Q \<Longrightarrow> P \<or> Q"
   unfolding or_def by (iprover intro: allI impI mp)
 
 
 subsubsection \<open>Classical logic\<close>
 
 lemma classical:
   assumes "\<not> P \<Longrightarrow> P"
   shows P
 proof (rule True_or_False [THEN disjE])
   show P if "P = True"
     using that by (iprover intro: eqTrueE)
   show P if "P = False"
   proof (intro notI assms)
     assume P
     with that show False
       by (iprover elim: subst)
   qed
 qed
 
 lemmas ccontr = FalseE [THEN classical]
 
 text \<open>\<open>notE\<close> with premises exchanged; it discharges \<open>\<not> R\<close> so that it can be used to
   make elimination rules.\<close>
 lemma rev_notE:
   assumes premp: P
     and premnot: "\<not> R \<Longrightarrow> \<not> P"
   shows R
   by (iprover intro: ccontr notE [OF premnot premp])
 
 
 text \<open>Double negation law.\<close>
 lemma notnotD: "\<not>\<not> P \<Longrightarrow> P"
   by (iprover intro: ccontr notE )
 
 lemma contrapos_pp:
   assumes p1: Q
     and p2: "\<not> P \<Longrightarrow> \<not> Q"
   shows P
   by (iprover intro: classical p1 p2 notE)
 
 
 subsubsection \<open>Unique existence\<close>
 
 lemma Uniq_I [intro?]:
   assumes "\<And>x y. \<lbrakk>P x; P y\<rbrakk> \<Longrightarrow> y = x"
   shows "Uniq P"
   unfolding Uniq_def by (iprover intro: assms allI impI)
 
 lemma Uniq_D [dest?]: "\<lbrakk>Uniq P; P a; P b\<rbrakk> \<Longrightarrow> a=b"
   unfolding Uniq_def by (iprover dest: spec mp)
 
 lemma ex1I:
   assumes "P a" "\<And>x. P x \<Longrightarrow> x = a"
   shows "\<exists>!x. P x"
   unfolding Ex1_def by (iprover intro: assms exI conjI allI impI)
 
 text \<open>Sometimes easier to use: the premises have no shared variables. Safe!\<close>
 lemma ex_ex1I:
   assumes ex_prem: "\<exists>x. P x"
     and eq: "\<And>x y. \<lbrakk>P x; P y\<rbrakk> \<Longrightarrow> x = y"
   shows "\<exists>!x. P x"
   by (iprover intro: ex_prem [THEN exE] ex1I eq)
 
 lemma ex1E:
   assumes major: "\<exists>!x. P x" and minor: "\<And>x. \<lbrakk>P x; \<forall>y. P y \<longrightarrow> y = x\<rbrakk> \<Longrightarrow> R"
   shows R
 proof (rule major [unfolded Ex1_def, THEN exE])
   show "\<And>x. P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<Longrightarrow> R"
     by (iprover intro: minor elim: conjE)
 qed
 
 lemma ex1_implies_ex: "\<exists>!x. P x \<Longrightarrow> \<exists>x. P x"
   by (iprover intro: exI elim: ex1E)
 
 subsubsection \<open>Classical intro rules for disjunction and existential quantifiers\<close>
 
 lemma disjCI:
   assumes "\<not> Q \<Longrightarrow> P"
   shows "P \<or> Q"
   by (rule classical) (iprover intro: assms disjI1 disjI2 notI elim: notE)
 
 lemma excluded_middle: "\<not> P \<or> P"
   by (iprover intro: disjCI)
 
 text \<open>
   case distinction as a natural deduction rule.
   Note that \<open>\<not> P\<close> is the second case, not the first.
 \<close>
 lemma case_split [case_names True False]:
   assumes "P \<Longrightarrow> Q" "\<not> P \<Longrightarrow> Q"
   shows Q
   using excluded_middle [of P]
     by (iprover intro: assms elim: disjE)
 
 text \<open>Classical implies (\<open>\<longrightarrow>\<close>) elimination.\<close>
 lemma impCE:
   assumes major: "P \<longrightarrow> Q"
     and minor: "\<not> P \<Longrightarrow> R" "Q \<Longrightarrow> R"
   shows R
   using excluded_middle [of P]
   by (iprover intro: minor major [THEN mp] elim: disjE)+
 
 text \<open>
   This version of \<open>\<longrightarrow>\<close> elimination works on \<open>Q\<close> before \<open>P\<close>.  It works best for
   those cases in which \<open>P\<close> holds "almost everywhere".  Can't install as
   default: would break old proofs.
 \<close>
 lemma impCE':
   assumes major: "P \<longrightarrow> Q"
     and minor: "Q \<Longrightarrow> R" "\<not> P \<Longrightarrow> R"
   shows R
   using assms by (elim impCE)
 
 
 text \<open>Classical \<open>\<longleftrightarrow>\<close> elimination.\<close>
 lemma iffCE:
   assumes major: "P = Q"
     and minor: "\<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R" "\<lbrakk>\<not> P; \<not> Q\<rbrakk> \<Longrightarrow> R"
   shows R
   by (rule major [THEN iffE]) (iprover intro: minor elim: impCE notE)
 
 lemma exCI:
   assumes "\<forall>x. \<not> P x \<Longrightarrow> P a"
   shows "\<exists>x. P x"
   by (rule ccontr) (iprover intro: assms exI allI notI notE [of "\<exists>x. P x"])
 
 
 subsubsection \<open>Intuitionistic Reasoning\<close>
 
 lemma impE':
   assumes 1: "P \<longrightarrow> Q"
     and 2: "Q \<Longrightarrow> R"
     and 3: "P \<longrightarrow> Q \<Longrightarrow> P"
   shows R
 proof -
   from 3 and 1 have P .
   with 1 have Q by (rule impE)
   with 2 show R .
 qed
 
 lemma allE':
   assumes 1: "\<forall>x. P x"
     and 2: "P x \<Longrightarrow> \<forall>x. P x \<Longrightarrow> Q"
   shows Q
 proof -
   from 1 have "P x" by (rule spec)
   from this and 1 show Q by (rule 2)
 qed
 
 lemma notE':
   assumes 1: "\<not> P"
     and 2: "\<not> P \<Longrightarrow> P"
   shows R
 proof -
   from 2 and 1 have P .
   with 1 show R by (rule notE)
 qed
 
 lemma TrueE: "True \<Longrightarrow> P \<Longrightarrow> P" .
 lemma notFalseE: "\<not> False \<Longrightarrow> P \<Longrightarrow> P" .
 
 lemmas [Pure.elim!] = disjE iffE FalseE conjE exE TrueE notFalseE
   and [Pure.intro!] = iffI conjI impI TrueI notI allI refl
   and [Pure.elim 2] = allE notE' impE'
   and [Pure.intro] = exI disjI2 disjI1
 
 lemmas [trans] = trans
   and [sym] = sym not_sym
   and [Pure.elim?] = iffD1 iffD2 impE
 
 
 subsubsection \<open>Atomizing meta-level connectives\<close>
 
 axiomatization where
   eq_reflection: "x = y \<Longrightarrow> x \<equiv> y"  \<comment> \<open>admissible axiom\<close>
 
 lemma atomize_all [atomize]: "(\<And>x. P x) \<equiv> Trueprop (\<forall>x. P x)"
 proof
   assume "\<And>x. P x"
   then show "\<forall>x. P x" ..
 next
   assume "\<forall>x. P x"
   then show "\<And>x. P x" by (rule allE)
 qed
 
 lemma atomize_imp [atomize]: "(A \<Longrightarrow> B) \<equiv> Trueprop (A \<longrightarrow> B)"
 proof
   assume r: "A \<Longrightarrow> B"
   show "A \<longrightarrow> B" by (rule impI) (rule r)
 next
   assume "A \<longrightarrow> B" and A
   then show B by (rule mp)
 qed
 
 lemma atomize_not: "(A \<Longrightarrow> False) \<equiv> Trueprop (\<not> A)"
 proof
   assume r: "A \<Longrightarrow> False"
   show "\<not> A" by (rule notI) (rule r)
 next
   assume "\<not> A" and A
   then show False by (rule notE)
 qed
 
 lemma atomize_eq [atomize, code]: "(x \<equiv> y) \<equiv> Trueprop (x = y)"
 proof
   assume "x \<equiv> y"
   show "x = y" by (unfold \<open>x \<equiv> y\<close>) (rule refl)
 next
   assume "x = y"
   then show "x \<equiv> y" by (rule eq_reflection)
 qed
 
 lemma atomize_conj [atomize]: "(A &&& B) \<equiv> Trueprop (A \<and> B)"
 proof
   assume conj: "A &&& B"
   show "A \<and> B"
   proof (rule conjI)
     from conj show A by (rule conjunctionD1)
     from conj show B by (rule conjunctionD2)
   qed
 next
   assume conj: "A \<and> B"
   show "A &&& B"
   proof -
     from conj show A ..
     from conj show B ..
   qed
 qed
 
 lemmas [symmetric, rulify] = atomize_all atomize_imp
   and [symmetric, defn] = atomize_all atomize_imp atomize_eq
 
 
 subsubsection \<open>Atomizing elimination rules\<close>
 
 lemma atomize_exL[atomize_elim]: "(\<And>x. P x \<Longrightarrow> Q) \<equiv> ((\<exists>x. P x) \<Longrightarrow> Q)"
-  by rule iprover+
+  by (rule equal_intr_rule) iprover+
 
 lemma atomize_conjL[atomize_elim]: "(A \<Longrightarrow> B \<Longrightarrow> C) \<equiv> (A \<and> B \<Longrightarrow> C)"
-  by rule iprover+
+  by (rule equal_intr_rule) iprover+
 
 lemma atomize_disjL[atomize_elim]: "((A \<Longrightarrow> C) \<Longrightarrow> (B \<Longrightarrow> C) \<Longrightarrow> C) \<equiv> ((A \<or> B \<Longrightarrow> C) \<Longrightarrow> C)"
-  by rule iprover+
+  by (rule equal_intr_rule) iprover+
 
 lemma atomize_elimL[atomize_elim]: "(\<And>B. (A \<Longrightarrow> B) \<Longrightarrow> B) \<equiv> Trueprop A" ..
 
 
 subsection \<open>Package setup\<close>
 
 ML_file \<open>Tools/hologic.ML\<close>
 ML_file \<open>Tools/rewrite_hol_proof.ML\<close>
 
 setup \<open>Proofterm.set_preproc (Proof_Rewrite_Rules.standard_preproc Rewrite_HOL_Proof.rews)\<close>
 
 
 subsubsection \<open>Sledgehammer setup\<close>
 
 text \<open>
   Theorems blacklisted to Sledgehammer. These theorems typically produce clauses
   that are prolific (match too many equality or membership literals) and relate to
   seldom-used facts. Some duplicate other rules.
 \<close>
 
 named_theorems no_atp "theorems that should be filtered out by Sledgehammer"
 
 
 subsubsection \<open>Classical Reasoner setup\<close>
 
 lemma imp_elim: "P \<longrightarrow> Q \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
   by (rule classical) iprover
 
 lemma swap: "\<not> P \<Longrightarrow> (\<not> R \<Longrightarrow> P) \<Longrightarrow> R"
   by (rule classical) iprover
 
 lemma thin_refl: "\<lbrakk>x = x; PROP W\<rbrakk> \<Longrightarrow> PROP W" .
 
 ML \<open>
 structure Hypsubst = Hypsubst
 (
   val dest_eq = HOLogic.dest_eq
   val dest_Trueprop = HOLogic.dest_Trueprop
   val dest_imp = HOLogic.dest_imp
   val eq_reflection = @{thm eq_reflection}
   val rev_eq_reflection = @{thm meta_eq_to_obj_eq}
   val imp_intr = @{thm impI}
   val rev_mp = @{thm rev_mp}
   val subst = @{thm subst}
   val sym = @{thm sym}
   val thin_refl = @{thm thin_refl};
 );
 open Hypsubst;
 
 structure Classical = Classical
 (
   val imp_elim = @{thm imp_elim}
   val not_elim = @{thm notE}
   val swap = @{thm swap}
   val classical = @{thm classical}
   val sizef = Drule.size_of_thm
   val hyp_subst_tacs = [Hypsubst.hyp_subst_tac]
 );
 
 structure Basic_Classical: BASIC_CLASSICAL = Classical;
 open Basic_Classical;
 \<close>
 
 setup \<open>
   (*prevent substitution on bool*)
   let
     fun non_bool_eq (\<^const_name>\<open>HOL.eq\<close>, Type (_, [T, _])) = T <> \<^typ>\<open>bool\<close>
       | non_bool_eq _ = false;
     fun hyp_subst_tac' ctxt =
       SUBGOAL (fn (goal, i) =>
         if Term.exists_Const non_bool_eq goal
         then Hypsubst.hyp_subst_tac ctxt i
         else no_tac);
   in
     Context_Rules.addSWrapper (fn ctxt => fn tac => hyp_subst_tac' ctxt ORELSE' tac)
   end
 \<close>
 
 declare iffI [intro!]
   and notI [intro!]
   and impI [intro!]
   and disjCI [intro!]
   and conjI [intro!]
   and TrueI [intro!]
   and refl [intro!]
 
 declare iffCE [elim!]
   and FalseE [elim!]
   and impCE [elim!]
   and disjE [elim!]
   and conjE [elim!]
 
 declare ex_ex1I [intro!]
   and allI [intro!]
   and exI [intro]
 
 declare exE [elim!]
   allE [elim]
 
 ML \<open>val HOL_cs = claset_of \<^context>\<close>
 
 lemma contrapos_np: "\<not> Q \<Longrightarrow> (\<not> P \<Longrightarrow> Q) \<Longrightarrow> P"
   by (erule swap)
 
 declare ex_ex1I [rule del, intro! 2]
   and ex1I [intro]
 
 declare ext [intro]
 
 lemmas [intro?] = ext
   and [elim?] = ex1_implies_ex
 
 text \<open>Better than \<open>ex1E\<close> for classical reasoner: needs no quantifier duplication!\<close>
 lemma alt_ex1E [elim!]:
   assumes major: "\<exists>!x. P x"
     and minor: "\<And>x. \<lbrakk>P x; \<forall>y y'. P y \<and> P y' \<longrightarrow> y = y'\<rbrakk> \<Longrightarrow> R"
   shows R
 proof (rule ex1E [OF major minor])
   show "\<forall>y y'. P y \<and> P y' \<longrightarrow> y = y'" if "P x" and \<section>: "\<forall>y. P y \<longrightarrow> y = x" for x
     using \<open>P x\<close> \<section> \<section> by fast
 qed assumption
 
 text \<open>And again using Uniq\<close>
 lemma alt_ex1E':
   assumes  "\<exists>!x. P x" "\<And>x. \<lbrakk>P x; \<exists>\<^sub>\<le>\<^sub>1x. P x\<rbrakk> \<Longrightarrow> R"
   shows R
   using assms unfolding Uniq_def by fast
 
 lemma ex1_iff_ex_Uniq: "(\<exists>!x. P x) \<longleftrightarrow> (\<exists>x. P x) \<and> (\<exists>\<^sub>\<le>\<^sub>1x. P x)"
   unfolding Uniq_def by fast
 
 
 ML \<open>
   structure Blast = Blast
   (
     structure Classical = Classical
     val Trueprop_const = dest_Const \<^Const>\<open>Trueprop\<close>
     val equality_name = \<^const_name>\<open>HOL.eq\<close>
     val not_name = \<^const_name>\<open>Not\<close>
     val notE = @{thm notE}
     val ccontr = @{thm ccontr}
     val hyp_subst_tac = Hypsubst.blast_hyp_subst_tac
   );
   val blast_tac = Blast.blast_tac;
 \<close>
 
 
 subsubsection \<open>THE: definite description operator\<close>
 
 lemma the_equality [intro]:
   assumes "P a"
     and "\<And>x. P x \<Longrightarrow> x = a"
   shows "(THE x. P x) = a"
   by (blast intro: assms trans [OF arg_cong [where f=The] the_eq_trivial])
 
 lemma theI:
   assumes "P a"
     and "\<And>x. P x \<Longrightarrow> x = a"
   shows "P (THE x. P x)"
   by (iprover intro: assms the_equality [THEN ssubst])
 
 lemma theI': "\<exists>!x. P x \<Longrightarrow> P (THE x. P x)"
   by (blast intro: theI)
 
 text \<open>Easier to apply than \<open>theI\<close>: only one occurrence of \<open>P\<close>.\<close>
 lemma theI2:
   assumes "P a" "\<And>x. P x \<Longrightarrow> x = a" "\<And>x. P x \<Longrightarrow> Q x"
   shows "Q (THE x. P x)"
   by (iprover intro: assms theI)
 
 lemma the1I2:
   assumes "\<exists>!x. P x" "\<And>x. P x \<Longrightarrow> Q x"
   shows "Q (THE x. P x)"
   by (iprover intro: assms(2) theI2[where P=P and Q=Q] ex1E[OF assms(1)] elim: allE impE)
 
 lemma the1_equality [elim?]: "\<lbrakk>\<exists>!x. P x; P a\<rbrakk> \<Longrightarrow> (THE x. P x) = a"
   by blast
 
 lemma the1_equality': "\<lbrakk>\<exists>\<^sub>\<le>\<^sub>1x. P x; P a\<rbrakk> \<Longrightarrow> (THE x. P x) = a"
   unfolding Uniq_def by blast
 
 lemma the_sym_eq_trivial: "(THE y. x = y) = x"
   by blast
 
 
 subsubsection \<open>Simplifier\<close>
 
 lemma eta_contract_eq: "(\<lambda>s. f s) = f" ..
 
 lemma subst_all:
   \<open>(\<And>x. x = a \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
   \<open>(\<And>x. a = x \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
 proof -
   show \<open>(\<And>x. x = a \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
   proof (rule equal_intr_rule)
     assume *: \<open>\<And>x. x = a \<Longrightarrow> PROP P x\<close>
     show \<open>PROP P a\<close>
       by (rule *) (rule refl)
   next
     fix x
     assume \<open>PROP P a\<close> and \<open>x = a\<close>
     from \<open>x = a\<close> have \<open>x \<equiv> a\<close>
       by (rule eq_reflection)
     with \<open>PROP P a\<close> show \<open>PROP P x\<close>
       by simp
   qed
   show \<open>(\<And>x. a = x \<Longrightarrow> PROP P x) \<equiv> PROP P a\<close>
   proof (rule equal_intr_rule)
     assume *: \<open>\<And>x. a = x \<Longrightarrow> PROP P x\<close>
     show \<open>PROP P a\<close>
       by (rule *) (rule refl)
   next
     fix x
     assume \<open>PROP P a\<close> and \<open>a = x\<close>
     from \<open>a = x\<close> have \<open>a \<equiv> x\<close>
       by (rule eq_reflection)
     with \<open>PROP P a\<close> show \<open>PROP P x\<close>
       by simp
   qed
 qed
 
 lemma simp_thms:
   shows not_not: "(\<not> \<not> P) = P"
   and Not_eq_iff: "((\<not> P) = (\<not> Q)) = (P = Q)"
   and
     "(P \<noteq> Q) = (P = (\<not> Q))"
     "(P \<or> \<not>P) = True"    "(\<not> P \<or> P) = True"
     "(x = x) = True"
   and not_True_eq_False [code]: "(\<not> True) = False"
   and not_False_eq_True [code]: "(\<not> False) = True"
   and
     "(\<not> P) \<noteq> P"  "P \<noteq> (\<not> P)"
     "(True = P) = P"
   and eq_True: "(P = True) = P"
   and "(False = P) = (\<not> P)"
   and eq_False: "(P = False) = (\<not> P)"
   and
     "(True \<longrightarrow> P) = P"  "(False \<longrightarrow> P) = True"
     "(P \<longrightarrow> True) = True"  "(P \<longrightarrow> P) = True"
     "(P \<longrightarrow> False) = (\<not> P)"  "(P \<longrightarrow> \<not> P) = (\<not> P)"
     "(P \<and> True) = P"  "(True \<and> P) = P"
     "(P \<and> False) = False"  "(False \<and> P) = False"
     "(P \<and> P) = P"  "(P \<and> (P \<and> Q)) = (P \<and> Q)"
     "(P \<and> \<not> P) = False"    "(\<not> P \<and> P) = False"
     "(P \<or> True) = True"  "(True \<or> P) = True"
     "(P \<or> False) = P"  "(False \<or> P) = P"
     "(P \<or> P) = P"  "(P \<or> (P \<or> Q)) = (P \<or> Q)" and
     "(\<forall>x. P) = P"  "(\<exists>x. P) = P"  "\<exists>x. x = t"  "\<exists>x. t = x"
   and
     "\<And>P. (\<exists>x. x = t \<and> P x) = P t"
     "\<And>P. (\<exists>x. t = x \<and> P x) = P t"
     "\<And>P. (\<forall>x. x = t \<longrightarrow> P x) = P t"
     "\<And>P. (\<forall>x. t = x \<longrightarrow> P x) = P t"
     "(\<forall>x. x \<noteq> t) = False"  "(\<forall>x. t \<noteq> x) = False"
   by (blast, blast, blast, blast, blast, iprover+)
 
 lemma disj_absorb: "A \<or> A \<longleftrightarrow> A"
   by blast
 
 lemma disj_left_absorb: "A \<or> (A \<or> B) \<longleftrightarrow> A \<or> B"
   by blast
 
 lemma conj_absorb: "A \<and> A \<longleftrightarrow> A"
   by blast
 
 lemma conj_left_absorb: "A \<and> (A \<and> B) \<longleftrightarrow> A \<and> B"
   by blast
 
 lemma eq_ac:
   shows eq_commute: "a = b \<longleftrightarrow> b = a"
     and iff_left_commute: "(P \<longleftrightarrow> (Q \<longleftrightarrow> R)) \<longleftrightarrow> (Q \<longleftrightarrow> (P \<longleftrightarrow> R))"
     and iff_assoc: "((P \<longleftrightarrow> Q) \<longleftrightarrow> R) \<longleftrightarrow> (P \<longleftrightarrow> (Q \<longleftrightarrow> R))"
   by (iprover, blast+)
 
 lemma neq_commute: "a \<noteq> b \<longleftrightarrow> b \<noteq> a" by iprover
 
 lemma conj_comms:
   shows conj_commute: "P \<and> Q \<longleftrightarrow> Q \<and> P"
     and conj_left_commute: "P \<and> (Q \<and> R) \<longleftrightarrow> Q \<and> (P \<and> R)" by iprover+
 lemma conj_assoc: "(P \<and> Q) \<and> R \<longleftrightarrow> P \<and> (Q \<and> R)" by iprover
 
 lemmas conj_ac = conj_commute conj_left_commute conj_assoc
 
 lemma disj_comms:
   shows disj_commute: "P \<or> Q \<longleftrightarrow> Q \<or> P"
     and disj_left_commute: "P \<or> (Q \<or> R) \<longleftrightarrow> Q \<or> (P \<or> R)" by iprover+
 lemma disj_assoc: "(P \<or> Q) \<or> R \<longleftrightarrow> P \<or> (Q \<or> R)" by iprover
 
 lemmas disj_ac = disj_commute disj_left_commute disj_assoc
 
 lemma conj_disj_distribL: "P \<and> (Q \<or> R) \<longleftrightarrow> P \<and> Q \<or> P \<and> R" by iprover
 lemma conj_disj_distribR: "(P \<or> Q) \<and> R \<longleftrightarrow> P \<and> R \<or> Q \<and> R" by iprover
 
 lemma disj_conj_distribL: "P \<or> (Q \<and> R) \<longleftrightarrow> (P \<or> Q) \<and> (P \<or> R)" by iprover
 lemma disj_conj_distribR: "(P \<and> Q) \<or> R \<longleftrightarrow> (P \<or> R) \<and> (Q \<or> R)" by iprover
 
 lemma imp_conjR: "(P \<longrightarrow> (Q \<and> R)) = ((P \<longrightarrow> Q) \<and> (P \<longrightarrow> R))" by iprover
 lemma imp_conjL: "((P \<and> Q) \<longrightarrow> R) = (P \<longrightarrow> (Q \<longrightarrow> R))" by iprover
 lemma imp_disjL: "((P \<or> Q) \<longrightarrow> R) = ((P \<longrightarrow> R) \<and> (Q \<longrightarrow> R))" by iprover
 
 text \<open>These two are specialized, but \<open>imp_disj_not1\<close> is useful in \<open>Auth/Yahalom\<close>.\<close>
 lemma imp_disj_not1: "(P \<longrightarrow> Q \<or> R) \<longleftrightarrow> (\<not> Q \<longrightarrow> P \<longrightarrow> R)" by blast
 lemma imp_disj_not2: "(P \<longrightarrow> Q \<or> R) \<longleftrightarrow> (\<not> R \<longrightarrow> P \<longrightarrow> Q)" by blast
 
 lemma imp_disj1: "((P \<longrightarrow> Q) \<or> R) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)" by blast
 lemma imp_disj2: "(Q \<or> (P \<longrightarrow> R)) \<longleftrightarrow> (P \<longrightarrow> Q \<or> R)" by blast
 
 lemma imp_cong: "(P = P') \<Longrightarrow> (P' \<Longrightarrow> (Q = Q')) \<Longrightarrow> ((P \<longrightarrow> Q) \<longleftrightarrow> (P' \<longrightarrow> Q'))"
   by iprover
 
 lemma de_Morgan_disj: "\<not> (P \<or> Q) \<longleftrightarrow> \<not> P \<and> \<not> Q" by iprover
 lemma de_Morgan_conj: "\<not> (P \<and> Q) \<longleftrightarrow> \<not> P \<or> \<not> Q" by blast
 lemma not_imp: "\<not> (P \<longrightarrow> Q) \<longleftrightarrow> P \<and> \<not> Q" by blast
 lemma not_iff: "P \<noteq> Q \<longleftrightarrow> (P \<longleftrightarrow> \<not> Q)" by blast
 lemma disj_not1: "\<not> P \<or> Q \<longleftrightarrow> (P \<longrightarrow> Q)" by blast
 lemma disj_not2: "P \<or> \<not> Q \<longleftrightarrow> (Q \<longrightarrow> P)" by blast  \<comment> \<open>changes orientation :-(\<close>
 lemma imp_conv_disj: "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> P) \<or> Q" by blast
 lemma disj_imp: "P \<or> Q \<longleftrightarrow> \<not> P \<longrightarrow> Q" by blast
 
 lemma iff_conv_conj_imp: "(P \<longleftrightarrow> Q) \<longleftrightarrow> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)" by iprover
 
 
 lemma cases_simp: "(P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> Q) \<longleftrightarrow> Q"
   \<comment> \<open>Avoids duplication of subgoals after \<open>if_split\<close>, when the true and false\<close>
   \<comment> \<open>cases boil down to the same thing.\<close>
   by blast
 
 lemma not_all: "\<not> (\<forall>x. P x) \<longleftrightarrow> (\<exists>x. \<not> P x)" by blast
 lemma imp_all: "((\<forall>x. P x) \<longrightarrow> Q) \<longleftrightarrow> (\<exists>x. P x \<longrightarrow> Q)" by blast
 lemma not_ex: "\<not> (\<exists>x. P x) \<longleftrightarrow> (\<forall>x. \<not> P x)" by iprover
 lemma imp_ex: "((\<exists>x. P x) \<longrightarrow> Q) \<longleftrightarrow> (\<forall>x. P x \<longrightarrow> Q)" by iprover
 lemma all_not_ex: "(\<forall>x. P x) \<longleftrightarrow> \<not> (\<exists>x. \<not> P x)" by blast
 
 declare All_def [no_atp]
 
 lemma ex_disj_distrib: "(\<exists>x. P x \<or> Q x) \<longleftrightarrow> (\<exists>x. P x) \<or> (\<exists>x. Q x)" by iprover
 lemma all_conj_distrib: "(\<forall>x. P x \<and> Q x) \<longleftrightarrow> (\<forall>x. P x) \<and> (\<forall>x. Q x)" by iprover
 
 text \<open>
   \<^medskip> The \<open>\<and>\<close> congruence rule: not included by default!
   May slow rewrite proofs down by as much as 50\%\<close>
 
 lemma conj_cong: "P = P' \<Longrightarrow> (P' \<Longrightarrow> Q = Q') \<Longrightarrow> (P \<and> Q) = (P' \<and> Q')"
   by iprover
 
 lemma rev_conj_cong: "Q = Q' \<Longrightarrow> (Q' \<Longrightarrow> P = P') \<Longrightarrow> (P \<and> Q) = (P' \<and> Q')"
   by iprover
 
 text \<open>The \<open>|\<close> congruence rule: not included by default!\<close>
 
 lemma disj_cong: "P = P' \<Longrightarrow> (\<not> P' \<Longrightarrow> Q = Q') \<Longrightarrow> (P \<or> Q) = (P' \<or> Q')"
   by blast
 
 
 text \<open>\<^medskip> if-then-else rules\<close>
 
 lemma if_True [code]: "(if True then x else y) = x"
   unfolding If_def by blast
 
 lemma if_False [code]: "(if False then x else y) = y"
   unfolding If_def by blast
 
 lemma if_P: "P \<Longrightarrow> (if P then x else y) = x"
   unfolding If_def by blast
 
 lemma if_not_P: "\<not> P \<Longrightarrow> (if P then x else y) = y"
   unfolding If_def by blast
 
 lemma if_split: "P (if Q then x else y) = ((Q \<longrightarrow> P x) \<and> (\<not> Q \<longrightarrow> P y))"
 proof (rule case_split [of Q])
   show ?thesis if Q
     using that by (simplesubst if_P) blast+
   show ?thesis if "\<not> Q"
     using that by (simplesubst if_not_P) blast+
 qed
 
 lemma if_split_asm: "P (if Q then x else y) = (\<not> ((Q \<and> \<not> P x) \<or> (\<not> Q \<and> \<not> P y)))"
   by (simplesubst if_split) blast
 
 lemmas if_splits [no_atp] = if_split if_split_asm
 
 lemma if_cancel: "(if c then x else x) = x"
   by (simplesubst if_split) blast
 
 lemma if_eq_cancel: "(if x = y then y else x) = x"
   by (simplesubst if_split) blast
 
 lemma if_bool_eq_conj: "(if P then Q else R) = ((P \<longrightarrow> Q) \<and> (\<not> P \<longrightarrow> R))"
   \<comment> \<open>This form is useful for expanding \<open>if\<close>s on the RIGHT of the \<open>\<Longrightarrow>\<close> symbol.\<close>
   by (rule if_split)
 
 lemma if_bool_eq_disj: "(if P then Q else R) = ((P \<and> Q) \<or> (\<not> P \<and> R))"
   \<comment> \<open>And this form is useful for expanding \<open>if\<close>s on the LEFT.\<close>
   by (simplesubst if_split) blast
 
 lemma Eq_TrueI: "P \<Longrightarrow> P \<equiv> True" unfolding atomize_eq by iprover
 lemma Eq_FalseI: "\<not> P \<Longrightarrow> P \<equiv> False" unfolding atomize_eq by iprover
 
 text \<open>\<^medskip> let rules for simproc\<close>
 
 lemma Let_folded: "f x \<equiv> g x \<Longrightarrow> Let x f \<equiv> Let x g"
   by (unfold Let_def)
 
 lemma Let_unfold: "f x \<equiv> g \<Longrightarrow> Let x f \<equiv> g"
   by (unfold Let_def)
 
 text \<open>
   The following copy of the implication operator is useful for
   fine-tuning congruence rules.  It instructs the simplifier to simplify
   its premise.
 \<close>
 
 definition simp_implies :: "prop \<Rightarrow> prop \<Rightarrow> prop"  (infixr "=simp=>" 1)
   where "simp_implies \<equiv> (\<Longrightarrow>)"
 
 lemma simp_impliesI:
   assumes PQ: "(PROP P \<Longrightarrow> PROP Q)"
   shows "PROP P =simp=> PROP Q"
   unfolding simp_implies_def
   by (iprover intro: PQ)
 
 lemma simp_impliesE:
   assumes PQ: "PROP P =simp=> PROP Q"
     and P: "PROP P"
     and QR: "PROP Q \<Longrightarrow> PROP R"
   shows "PROP R"
   by (iprover intro: QR P PQ [unfolded simp_implies_def])
 
 lemma simp_implies_cong:
   assumes PP' :"PROP P \<equiv> PROP P'"
     and P'QQ': "PROP P' \<Longrightarrow> (PROP Q \<equiv> PROP Q')"
   shows "(PROP P =simp=> PROP Q) \<equiv> (PROP P' =simp=> PROP Q')"
   unfolding simp_implies_def
 proof (rule equal_intr_rule)
   assume PQ: "PROP P \<Longrightarrow> PROP Q"
     and P': "PROP P'"
   from PP' [symmetric] and P' have "PROP P"
     by (rule equal_elim_rule1)
   then have "PROP Q" by (rule PQ)
   with P'QQ' [OF P'] show "PROP Q'" by (rule equal_elim_rule1)
 next
   assume P'Q': "PROP P' \<Longrightarrow> PROP Q'"
     and P: "PROP P"
   from PP' and P have P': "PROP P'" by (rule equal_elim_rule1)
   then have "PROP Q'" by (rule P'Q')
   with P'QQ' [OF P', symmetric] show "PROP Q"
     by (rule equal_elim_rule1)
 qed
 
 lemma uncurry:
   assumes "P \<longrightarrow> Q \<longrightarrow> R"
   shows "P \<and> Q \<longrightarrow> R"
   using assms by blast
 
 lemma iff_allI:
   assumes "\<And>x. P x = Q x"
   shows "(\<forall>x. P x) = (\<forall>x. Q x)"
   using assms by blast
 
 lemma iff_exI:
   assumes "\<And>x. P x = Q x"
   shows "(\<exists>x. P x) = (\<exists>x. Q x)"
   using assms by blast
 
 lemma all_comm: "(\<forall>x y. P x y) = (\<forall>y x. P x y)"
   by blast
 
 lemma ex_comm: "(\<exists>x y. P x y) = (\<exists>y x. P x y)"
   by blast
 
 ML_file \<open>Tools/simpdata.ML\<close>
 ML \<open>open Simpdata\<close>
 
 setup \<open>
   map_theory_simpset (put_simpset HOL_basic_ss) #>
   Simplifier.method_setup Splitter.split_modifiers
 \<close>
 
 simproc_setup defined_Ex ("\<exists>x. P x") = \<open>K Quantifier1.rearrange_Ex\<close>
 simproc_setup defined_All ("\<forall>x. P x") = \<open>K Quantifier1.rearrange_All\<close>
 simproc_setup defined_all("\<And>x. PROP P x") = \<open>K Quantifier1.rearrange_all\<close>
 
 text \<open>Simproc for proving \<open>(y = x) \<equiv> False\<close> from premise \<open>\<not> (x = y)\<close>:\<close>
 
 simproc_setup neq ("x = y") = \<open>fn _ =>
   let
     val neq_to_EQ_False = @{thm not_sym} RS @{thm Eq_FalseI};
     fun is_neq eq lhs rhs thm =
       (case Thm.prop_of thm of
         _ $ (Not $ (eq' $ l' $ r')) =>
           Not = HOLogic.Not andalso eq' = eq andalso
           r' aconv lhs andalso l' aconv rhs
       | _ => false);
     fun proc ss ct =
       (case Thm.term_of ct of
         eq $ lhs $ rhs =>
           (case find_first (is_neq eq lhs rhs) (Simplifier.prems_of ss) of
             SOME thm => SOME (thm RS neq_to_EQ_False)
           | NONE => NONE)
        | _ => NONE);
   in proc end
 \<close>
 
 simproc_setup let_simp ("Let x f") = \<open>
   let
     fun count_loose (Bound i) k = if i >= k then 1 else 0
       | count_loose (s $ t) k = count_loose s k + count_loose t k
       | count_loose (Abs (_, _, t)) k = count_loose  t (k + 1)
       | count_loose _ _ = 0;
     fun is_trivial_let (Const (\<^const_name>\<open>Let\<close>, _) $ x $ t) =
       (case t of
         Abs (_, _, t') => count_loose t' 0 <= 1
       | _ => true);
   in
     fn _ => fn ctxt => fn ct =>
       if is_trivial_let (Thm.term_of ct)
       then SOME @{thm Let_def} (*no or one ocurrence of bound variable*)
       else
         let (*Norbert Schirmer's case*)
           val t = Thm.term_of ct;
           val (t', ctxt') = yield_singleton (Variable.import_terms false) t ctxt;
         in
           Option.map (hd o Variable.export ctxt' ctxt o single)
             (case t' of Const (\<^const_name>\<open>Let\<close>,_) $ x $ f => (* x and f are already in normal form *)
               if is_Free x orelse is_Bound x orelse is_Const x
               then SOME @{thm Let_def}
               else
                 let
                   val n = case f of (Abs (x, _, _)) => x | _ => "x";
                   val cx = Thm.cterm_of ctxt x;
                   val xT = Thm.typ_of_cterm cx;
                   val cf = Thm.cterm_of ctxt f;
                   val fx_g = Simplifier.rewrite ctxt (Thm.apply cf cx);
                   val (_ $ _ $ g) = Thm.prop_of fx_g;
                   val g' = abstract_over (x, g);
                   val abs_g'= Abs (n, xT, g');
                 in
                   if g aconv g' then
                     let
                       val rl =
                         infer_instantiate ctxt [(("f", 0), cf), (("x", 0), cx)] @{thm Let_unfold};
                     in SOME (rl OF [fx_g]) end
                   else if (Envir.beta_eta_contract f) aconv (Envir.beta_eta_contract abs_g')
                   then NONE (*avoid identity conversion*)
                   else
                     let
                       val g'x = abs_g' $ x;
                       val g_g'x = Thm.symmetric (Thm.beta_conversion false (Thm.cterm_of ctxt g'x));
                       val rl =
                         @{thm Let_folded} |> infer_instantiate ctxt
                           [(("f", 0), Thm.cterm_of ctxt f),
                            (("x", 0), cx),
                            (("g", 0), Thm.cterm_of ctxt abs_g')];
                     in SOME (rl OF [Thm.transitive fx_g g_g'x]) end
                 end
             | _ => NONE)
         end
   end
 \<close>
 
 lemma True_implies_equals: "(True \<Longrightarrow> PROP P) \<equiv> PROP P"
 proof
   assume "True \<Longrightarrow> PROP P"
   from this [OF TrueI] show "PROP P" .
 next
   assume "PROP P"
   then show "PROP P" .
 qed
 
 lemma implies_True_equals: "(PROP P \<Longrightarrow> True) \<equiv> Trueprop True"
   by standard (intro TrueI)
 
 lemma False_implies_equals: "(False \<Longrightarrow> P) \<equiv> Trueprop True"
   by standard simp_all
 
 (* It seems that making this a simp rule is slower than using the simproc below *)
 lemma implies_False_swap:
   "(False \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> False \<Longrightarrow> PROP Q)"
   by (rule swap_prems_eq)
 
 ML \<open>
 fun eliminate_false_implies ct =
   let
     val (prems, concl) = Logic.strip_horn (Thm.term_of ct)
     fun go n =
       if n > 1 then
         Conv.rewr_conv @{thm Pure.swap_prems_eq}
         then_conv Conv.arg_conv (go (n - 1))
         then_conv Conv.rewr_conv @{thm HOL.implies_True_equals}
       else
         Conv.rewr_conv @{thm HOL.False_implies_equals}
   in
     case concl of
       Const (@{const_name HOL.Trueprop}, _) $ _ => SOME (go (length prems) ct)
     | _ => NONE
   end
 \<close>
 
 simproc_setup eliminate_false_implies ("False \<Longrightarrow> PROP P") = \<open>K (K eliminate_false_implies)\<close>
 
 
 lemma ex_simps:
   "\<And>P Q. (\<exists>x. P x \<and> Q)   = ((\<exists>x. P x) \<and> Q)"
   "\<And>P Q. (\<exists>x. P \<and> Q x)   = (P \<and> (\<exists>x. Q x))"
   "\<And>P Q. (\<exists>x. P x \<or> Q)   = ((\<exists>x. P x) \<or> Q)"
   "\<And>P Q. (\<exists>x. P \<or> Q x)   = (P \<or> (\<exists>x. Q x))"
   "\<And>P Q. (\<exists>x. P x \<longrightarrow> Q) = ((\<forall>x. P x) \<longrightarrow> Q)"
   "\<And>P Q. (\<exists>x. P \<longrightarrow> Q x) = (P \<longrightarrow> (\<exists>x. Q x))"
   \<comment> \<open>Miniscoping: pushing in existential quantifiers.\<close>
   by (iprover | blast)+
 
 lemma all_simps:
   "\<And>P Q. (\<forall>x. P x \<and> Q)   = ((\<forall>x. P x) \<and> Q)"
   "\<And>P Q. (\<forall>x. P \<and> Q x)   = (P \<and> (\<forall>x. Q x))"
   "\<And>P Q. (\<forall>x. P x \<or> Q)   = ((\<forall>x. P x) \<or> Q)"
   "\<And>P Q. (\<forall>x. P \<or> Q x)   = (P \<or> (\<forall>x. Q x))"
   "\<And>P Q. (\<forall>x. P x \<longrightarrow> Q) = ((\<exists>x. P x) \<longrightarrow> Q)"
   "\<And>P Q. (\<forall>x. P \<longrightarrow> Q x) = (P \<longrightarrow> (\<forall>x. Q x))"
   \<comment> \<open>Miniscoping: pushing in universal quantifiers.\<close>
   by (iprover | blast)+
 
 lemmas [simp] =
   triv_forall_equality  \<comment> \<open>prunes params\<close>
   True_implies_equals implies_True_equals  \<comment> \<open>prune \<open>True\<close> in asms\<close>
   False_implies_equals  \<comment> \<open>prune \<open>False\<close> in asms\<close>
   if_True
   if_False
   if_cancel
   if_eq_cancel
   imp_disjL \<comment> \<open>In general it seems wrong to add distributive laws by default: they
     might cause exponential blow-up.  But \<open>imp_disjL\<close> has been in for a while
     and cannot be removed without affecting existing proofs.  Moreover,
     rewriting by \<open>(P \<or> Q \<longrightarrow> R) = ((P \<longrightarrow> R) \<and> (Q \<longrightarrow> R))\<close> might be justified on the
     grounds that it allows simplification of \<open>R\<close> in the two cases.\<close>
   conj_assoc
   disj_assoc
   de_Morgan_conj
   de_Morgan_disj
   imp_disj1
   imp_disj2
   not_imp
   disj_not1
   not_all
   not_ex
   cases_simp
   the_eq_trivial
   the_sym_eq_trivial
   ex_simps
   all_simps
   simp_thms
   subst_all
 
 lemmas [cong] = imp_cong simp_implies_cong
 lemmas [split] = if_split
 
 ML \<open>val HOL_ss = simpset_of \<^context>\<close>
 
 text \<open>Simplifies \<open>x\<close> assuming \<open>c\<close> and \<open>y\<close> assuming \<open>\<not> c\<close>.\<close>
 lemma if_cong:
   assumes "b = c"
     and "c \<Longrightarrow> x = u"
     and "\<not> c \<Longrightarrow> y = v"
   shows "(if b then x else y) = (if c then u else v)"
   using assms by simp
 
 text \<open>Prevents simplification of \<open>x\<close> and \<open>y\<close>:
   faster and allows the execution of functional programs.\<close>
 lemma if_weak_cong [cong]:
   assumes "b = c"
   shows "(if b then x else y) = (if c then x else y)"
   using assms by (rule arg_cong)
 
 text \<open>Prevents simplification of t: much faster\<close>
 lemma let_weak_cong:
   assumes "a = b"
   shows "(let x = a in t x) = (let x = b in t x)"
   using assms by (rule arg_cong)
 
 text \<open>To tidy up the result of a simproc.  Only the RHS will be simplified.\<close>
 lemma eq_cong2:
   assumes "u = u'"
   shows "(t \<equiv> u) \<equiv> (t \<equiv> u')"
   using assms by simp
 
 lemma if_distrib: "f (if c then x else y) = (if c then f x else f y)"
   by simp
 
 lemma if_distribR: "(if b then f else g) x = (if b then f x else g x)"
   by simp
 
 lemma all_if_distrib: "(\<forall>x. if x = a then P x else Q x) \<longleftrightarrow> P a \<and> (\<forall>x. x\<noteq>a \<longrightarrow> Q x)"
   by auto
 
 lemma ex_if_distrib: "(\<exists>x. if x = a then P x else Q x) \<longleftrightarrow> P a \<or> (\<exists>x. x\<noteq>a \<and> Q x)"
   by auto
 
 lemma if_if_eq_conj: "(if P then if Q then x else y else y) = (if P \<and> Q then x else y)"
   by simp
 
 text \<open>As a simplification rule, it replaces all function equalities by
   first-order equalities.\<close>
 lemma fun_eq_iff: "f = g \<longleftrightarrow> (\<forall>x. f x = g x)"
   by auto
 
 
 subsubsection \<open>Generic cases and induction\<close>
 
 text \<open>Rule projections:\<close>
 ML \<open>
 structure Project_Rule = Project_Rule
 (
   val conjunct1 = @{thm conjunct1}
   val conjunct2 = @{thm conjunct2}
   val mp = @{thm mp}
 );
 \<close>
 
 context
 begin
 
 qualified definition "induct_forall P \<equiv> \<forall>x. P x"
 qualified definition "induct_implies A B \<equiv> A \<longrightarrow> B"
 qualified definition "induct_equal x y \<equiv> x = y"
 qualified definition "induct_conj A B \<equiv> A \<and> B"
 qualified definition "induct_true \<equiv> True"
 qualified definition "induct_false \<equiv> False"
 
 lemma induct_forall_eq: "(\<And>x. P x) \<equiv> Trueprop (induct_forall (\<lambda>x. P x))"
   by (unfold atomize_all induct_forall_def)
 
 lemma induct_implies_eq: "(A \<Longrightarrow> B) \<equiv> Trueprop (induct_implies A B)"
   by (unfold atomize_imp induct_implies_def)
 
 lemma induct_equal_eq: "(x \<equiv> y) \<equiv> Trueprop (induct_equal x y)"
   by (unfold atomize_eq induct_equal_def)
 
 lemma induct_conj_eq: "(A &&& B) \<equiv> Trueprop (induct_conj A B)"
   by (unfold atomize_conj induct_conj_def)
 
 lemmas induct_atomize' = induct_forall_eq induct_implies_eq induct_conj_eq
 lemmas induct_atomize = induct_atomize' induct_equal_eq
 lemmas induct_rulify' [symmetric] = induct_atomize'
 lemmas induct_rulify [symmetric] = induct_atomize
 lemmas induct_rulify_fallback =
   induct_forall_def induct_implies_def induct_equal_def induct_conj_def
   induct_true_def induct_false_def
 
 lemma induct_forall_conj: "induct_forall (\<lambda>x. induct_conj (A x) (B x)) =
     induct_conj (induct_forall A) (induct_forall B)"
   by (unfold induct_forall_def induct_conj_def) iprover
 
 lemma induct_implies_conj: "induct_implies C (induct_conj A B) =
     induct_conj (induct_implies C A) (induct_implies C B)"
   by (unfold induct_implies_def induct_conj_def) iprover
 
 lemma induct_conj_curry: "(induct_conj A B \<Longrightarrow> PROP C) \<equiv> (A \<Longrightarrow> B \<Longrightarrow> PROP C)"
 proof
   assume r: "induct_conj A B \<Longrightarrow> PROP C"
   assume ab: A B
   show "PROP C" by (rule r) (simp add: induct_conj_def ab)
 next
   assume r: "A \<Longrightarrow> B \<Longrightarrow> PROP C"
   assume ab: "induct_conj A B"
   show "PROP C" by (rule r) (simp_all add: ab [unfolded induct_conj_def])
 qed
 
 lemmas induct_conj = induct_forall_conj induct_implies_conj induct_conj_curry
 
 lemma induct_trueI: "induct_true"
   by (simp add: induct_true_def)
 
 text \<open>Method setup.\<close>
 
 ML_file \<open>~~/src/Tools/induct.ML\<close>
 ML \<open>
 structure Induct = Induct
 (
   val cases_default = @{thm case_split}
   val atomize = @{thms induct_atomize}
   val rulify = @{thms induct_rulify'}
   val rulify_fallback = @{thms induct_rulify_fallback}
   val equal_def = @{thm induct_equal_def}
   fun dest_def (Const (\<^const_name>\<open>induct_equal\<close>, _) $ t $ u) = SOME (t, u)
     | dest_def _ = NONE
   fun trivial_tac ctxt = match_tac ctxt @{thms induct_trueI}
 )
 \<close>
 
 ML_file \<open>~~/src/Tools/induction.ML\<close>
 
 declaration \<open>
   fn _ => Induct.map_simpset (fn ss => ss
     addsimprocs
       [Simplifier.make_simproc \<^context> "swap_induct_false"
         {lhss = [\<^term>\<open>induct_false \<Longrightarrow> PROP P \<Longrightarrow> PROP Q\<close>],
          proc = fn _ => fn _ => fn ct =>
           (case Thm.term_of ct of
             _ $ (P as _ $ \<^Const_>\<open>induct_false\<close>) $ (_ $ Q $ _) =>
               if P <> Q then SOME Drule.swap_prems_eq else NONE
           | _ => NONE)},
        Simplifier.make_simproc \<^context> "induct_equal_conj_curry"
         {lhss = [\<^term>\<open>induct_conj P Q \<Longrightarrow> PROP R\<close>],
          proc = fn _ => fn _ => fn ct =>
           (case Thm.term_of ct of
             _ $ (_ $ P) $ _ =>
               let
                 fun is_conj \<^Const_>\<open>induct_conj for P Q\<close> =
                       is_conj P andalso is_conj Q
                   | is_conj \<^Const_>\<open>induct_equal _ for _ _\<close> = true
                   | is_conj \<^Const_>\<open>induct_true\<close> = true
                   | is_conj \<^Const_>\<open>induct_false\<close> = true
                   | is_conj _ = false
               in if is_conj P then SOME @{thm induct_conj_curry} else NONE end
             | _ => NONE)}]
     |> Simplifier.set_mksimps (fn ctxt =>
         Simpdata.mksimps Simpdata.mksimps_pairs ctxt #>
         map (rewrite_rule ctxt (map Thm.symmetric @{thms induct_rulify_fallback}))))
 \<close>
 
 text \<open>Pre-simplification of induction and cases rules\<close>
 
 lemma [induct_simp]: "(\<And>x. induct_equal x t \<Longrightarrow> PROP P x) \<equiv> PROP P t"
   unfolding induct_equal_def
 proof
   assume r: "\<And>x. x = t \<Longrightarrow> PROP P x"
   show "PROP P t" by (rule r [OF refl])
 next
   fix x
   assume "PROP P t" "x = t"
   then show "PROP P x" by simp
 qed
 
 lemma [induct_simp]: "(\<And>x. induct_equal t x \<Longrightarrow> PROP P x) \<equiv> PROP P t"
   unfolding induct_equal_def
 proof
   assume r: "\<And>x. t = x \<Longrightarrow> PROP P x"
   show "PROP P t" by (rule r [OF refl])
 next
   fix x
   assume "PROP P t" "t = x"
   then show "PROP P x" by simp
 qed
 
 lemma [induct_simp]: "(induct_false \<Longrightarrow> P) \<equiv> Trueprop induct_true"
   unfolding induct_false_def induct_true_def
   by (iprover intro: equal_intr_rule)
 
 lemma [induct_simp]: "(induct_true \<Longrightarrow> PROP P) \<equiv> PROP P"
   unfolding induct_true_def
 proof
   assume "True \<Longrightarrow> PROP P"
   then show "PROP P" using TrueI .
 next
   assume "PROP P"
   then show "PROP P" .
 qed
 
 lemma [induct_simp]: "(PROP P \<Longrightarrow> induct_true) \<equiv> Trueprop induct_true"
   unfolding induct_true_def
   by (iprover intro: equal_intr_rule)
 
 lemma [induct_simp]: "(\<And>x::'a::{}. induct_true) \<equiv> Trueprop induct_true"
   unfolding induct_true_def
   by (iprover intro: equal_intr_rule)
 
 lemma [induct_simp]: "induct_implies induct_true P \<equiv> P"
   by (simp add: induct_implies_def induct_true_def)
 
 lemma [induct_simp]: "x = x \<longleftrightarrow> True"
   by (rule simp_thms)
 
 end
 
 ML_file \<open>~~/src/Tools/induct_tacs.ML\<close>
 
 
 subsubsection \<open>Coherent logic\<close>
 
 ML_file \<open>~~/src/Tools/coherent.ML\<close>
 ML \<open>
 structure Coherent = Coherent
 (
   val atomize_elimL = @{thm atomize_elimL};
   val atomize_exL = @{thm atomize_exL};
   val atomize_conjL = @{thm atomize_conjL};
   val atomize_disjL = @{thm atomize_disjL};
   val operator_names = [\<^const_name>\<open>HOL.disj\<close>, \<^const_name>\<open>HOL.conj\<close>, \<^const_name>\<open>Ex\<close>];
 );
 \<close>
 
 
 subsubsection \<open>Reorienting equalities\<close>
 
 ML \<open>
 signature REORIENT_PROC =
 sig
   val add : (term -> bool) -> theory -> theory
   val proc : morphism -> Proof.context -> cterm -> thm option
 end;
 
 structure Reorient_Proc : REORIENT_PROC =
 struct
   structure Data = Theory_Data
   (
     type T = ((term -> bool) * stamp) list;
     val empty = [];
     fun merge data : T = Library.merge (eq_snd (op =)) data;
   );
   fun add m = Data.map (cons (m, stamp ()));
   fun matches thy t = exists (fn (m, _) => m t) (Data.get thy);
 
   val meta_reorient = @{thm eq_commute [THEN eq_reflection]};
   fun proc phi ctxt ct =
     let
       val thy = Proof_Context.theory_of ctxt;
     in
       case Thm.term_of ct of
         (_ $ t $ u) => if matches thy u then NONE else SOME meta_reorient
       | _ => NONE
     end;
 end;
 \<close>
 
 
 subsection \<open>Other simple lemmas and lemma duplicates\<close>
 
 lemma eq_iff_swap: "(x = y \<longleftrightarrow> P) \<Longrightarrow> (y = x \<longleftrightarrow> P)"
 by blast
 
 lemma all_cong1: "(\<And>x. P x = P' x) \<Longrightarrow> (\<forall>x. P x) = (\<forall>x. P' x)"
   by auto
 
 lemma ex_cong1: "(\<And>x. P x = P' x) \<Longrightarrow> (\<exists>x. P x) = (\<exists>x. P' x)"
   by auto
 
 lemma all_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow> (\<forall>x. Q x \<longrightarrow> P x) = (\<forall>x. Q x \<longrightarrow> P' x)"
   by auto
 
 lemma ex_cong: "(\<And>x. Q x \<Longrightarrow> P x = P' x) \<Longrightarrow> (\<exists>x. Q x \<and> P x) = (\<exists>x. Q x \<and> P' x)"
   by auto
 
 lemma ex1_eq [iff]: "\<exists>!x. x = t" "\<exists>!x. t = x"
   by blast+
 
 lemma choice_eq: "(\<forall>x. \<exists>!y. P x y) = (\<exists>!f. \<forall>x. P x (f x))" (is "?lhs = ?rhs")
 proof (intro iffI allI)
   assume L: ?lhs
   then have \<section>: "\<forall>x. P x (THE y. P x y)"
     by (best intro: theI')
   show ?rhs
     by (rule ex1I) (use L \<section> in \<open>fast+\<close>)
 next
   fix x
   assume R: ?rhs
   then obtain f where f: "\<forall>x. P x (f x)" and f1: "\<And>y. (\<forall>x. P x (y x)) \<Longrightarrow> y = f"
     by (blast elim: ex1E)
   show "\<exists>!y. P x y"
   proof (rule ex1I)
     show "P x (f x)"
       using f by blast
     show "y = f x" if "P x y" for y
     proof -
       have "P z (if z = x then y else f z)" for z
         using f that by (auto split: if_split)
       with f1 [of "\<lambda>z. if z = x then y else f z"] f
       show ?thesis
         by (auto simp add: split: if_split_asm dest: fun_cong)
     qed
   qed
 qed
 
 lemmas eq_sym_conv = eq_commute
 
 lemma nnf_simps:
   "(\<not> (P \<and> Q)) = (\<not> P \<or> \<not> Q)"
   "(\<not> (P \<or> Q)) = (\<not> P \<and> \<not> Q)"
   "(P \<longrightarrow> Q) = (\<not> P \<or> Q)"
   "(P = Q) = ((P \<and> Q) \<or> (\<not> P \<and> \<not> Q))"
   "(\<not> (P = Q)) = ((P \<and> \<not> Q) \<or> (\<not> P \<and> Q))"
   "(\<not> \<not> P) = P"
   by blast+
 
 
 subsection \<open>Basic ML bindings\<close>
 
 ML \<open>
 val FalseE = @{thm FalseE}
 val Let_def = @{thm Let_def}
 val TrueI = @{thm TrueI}
 val allE = @{thm allE}
 val allI = @{thm allI}
 val all_dupE = @{thm all_dupE}
 val arg_cong = @{thm arg_cong}
 val box_equals = @{thm box_equals}
 val ccontr = @{thm ccontr}
 val classical = @{thm classical}
 val conjE = @{thm conjE}
 val conjI = @{thm conjI}
 val conjunct1 = @{thm conjunct1}
 val conjunct2 = @{thm conjunct2}
 val disjCI = @{thm disjCI}
 val disjE = @{thm disjE}
 val disjI1 = @{thm disjI1}
 val disjI2 = @{thm disjI2}
 val eq_reflection = @{thm eq_reflection}
 val ex1E = @{thm ex1E}
 val ex1I = @{thm ex1I}
 val ex1_implies_ex = @{thm ex1_implies_ex}
 val exE = @{thm exE}
 val exI = @{thm exI}
 val excluded_middle = @{thm excluded_middle}
 val ext = @{thm ext}
 val fun_cong = @{thm fun_cong}
 val iffD1 = @{thm iffD1}
 val iffD2 = @{thm iffD2}
 val iffI = @{thm iffI}
 val impE = @{thm impE}
 val impI = @{thm impI}
 val meta_eq_to_obj_eq = @{thm meta_eq_to_obj_eq}
 val mp = @{thm mp}
 val notE = @{thm notE}
 val notI = @{thm notI}
 val not_all = @{thm not_all}
 val not_ex = @{thm not_ex}
 val not_iff = @{thm not_iff}
 val not_not = @{thm not_not}
 val not_sym = @{thm not_sym}
 val refl = @{thm refl}
 val rev_mp = @{thm rev_mp}
 val spec = @{thm spec}
 val ssubst = @{thm ssubst}
 val subst = @{thm subst}
 val sym = @{thm sym}
 val trans = @{thm trans}
 \<close>
 
 locale cnf
 begin
 
 lemma clause2raw_notE: "\<lbrakk>P; \<not>P\<rbrakk> \<Longrightarrow> False" by auto
 lemma clause2raw_not_disj: "\<lbrakk>\<not> P; \<not> Q\<rbrakk> \<Longrightarrow> \<not> (P \<or> Q)" by auto
 lemma clause2raw_not_not: "P \<Longrightarrow> \<not>\<not> P" by auto
 
 lemma iff_refl: "(P::bool) = P" by auto
 lemma iff_trans: "[| (P::bool) = Q; Q = R |] ==> P = R" by auto
 lemma conj_cong: "[| P = P'; Q = Q' |] ==> (P \<and> Q) = (P' \<and> Q')" by auto
 lemma disj_cong: "[| P = P'; Q = Q' |] ==> (P \<or> Q) = (P' \<or> Q')" by auto
 
 lemma make_nnf_imp: "[| (\<not>P) = P'; Q = Q' |] ==> (P \<longrightarrow> Q) = (P' \<or> Q')" by auto
 lemma make_nnf_iff: "[| P = P'; (\<not>P) = NP; Q = Q'; (\<not>Q) = NQ |] ==> (P = Q) = ((P' \<or> NQ) \<and> (NP \<or> Q'))" by auto
 lemma make_nnf_not_false: "(\<not>False) = True" by auto
 lemma make_nnf_not_true: "(\<not>True) = False" by auto
 lemma make_nnf_not_conj: "[| (\<not>P) = P'; (\<not>Q) = Q' |] ==> (\<not>(P \<and> Q)) = (P' \<or> Q')" by auto
 lemma make_nnf_not_disj: "[| (\<not>P) = P'; (\<not>Q) = Q' |] ==> (\<not>(P \<or> Q)) = (P' \<and> Q')" by auto
 lemma make_nnf_not_imp: "[| P = P'; (\<not>Q) = Q' |] ==> (\<not>(P \<longrightarrow> Q)) = (P' \<and> Q')" by auto
 lemma make_nnf_not_iff: "[| P = P'; (\<not>P) = NP; Q = Q'; (\<not>Q) = NQ |] ==> (\<not>(P = Q)) = ((P' \<or> Q') \<and> (NP \<or> NQ))" by auto
 lemma make_nnf_not_not: "P = P' ==> (\<not>\<not>P) = P'" by auto
 
 lemma simp_TF_conj_True_l: "[| P = True; Q = Q' |] ==> (P \<and> Q) = Q'" by auto
 lemma simp_TF_conj_True_r: "[| P = P'; Q = True |] ==> (P \<and> Q) = P'" by auto
 lemma simp_TF_conj_False_l: "P = False ==> (P \<and> Q) = False" by auto
 lemma simp_TF_conj_False_r: "Q = False ==> (P \<and> Q) = False" by auto
 lemma simp_TF_disj_True_l: "P = True ==> (P \<or> Q) = True" by auto
 lemma simp_TF_disj_True_r: "Q = True ==> (P \<or> Q) = True" by auto
 lemma simp_TF_disj_False_l: "[| P = False; Q = Q' |] ==> (P \<or> Q) = Q'" by auto
 lemma simp_TF_disj_False_r: "[| P = P'; Q = False |] ==> (P \<or> Q) = P'" by auto
 
 lemma make_cnf_disj_conj_l: "[| (P \<or> R) = PR; (Q \<or> R) = QR |] ==> ((P \<and> Q) \<or> R) = (PR \<and> QR)" by auto
 lemma make_cnf_disj_conj_r: "[| (P \<or> Q) = PQ; (P \<or> R) = PR |] ==> (P \<or> (Q \<and> R)) = (PQ \<and> PR)" by auto
 
 lemma make_cnfx_disj_ex_l: "((\<exists>(x::bool). P x) \<or> Q) = (\<exists>x. P x \<or> Q)" by auto
 lemma make_cnfx_disj_ex_r: "(P \<or> (\<exists>(x::bool). Q x)) = (\<exists>x. P \<or> Q x)" by auto
 lemma make_cnfx_newlit: "(P \<or> Q) = (\<exists>x. (P \<or> x) \<and> (Q \<or> \<not>x))" by auto
 lemma make_cnfx_ex_cong: "(\<forall>(x::bool). P x = Q x) \<Longrightarrow> (\<exists>x. P x) = (\<exists>x. Q x)" by auto
 
 lemma weakening_thm: "[| P; Q |] ==> Q" by auto
 
 lemma cnftac_eq_imp: "[| P = Q; P |] ==> Q" by auto
 
 end
 
 ML_file \<open>Tools/cnf.ML\<close>
 
 
 section \<open>\<open>NO_MATCH\<close> simproc\<close>
 
 text \<open>
   The simplification procedure can be used to avoid simplification of terms
   of a certain form.
 \<close>
 
 definition NO_MATCH :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
   where "NO_MATCH pat val \<equiv> True"
 
 lemma NO_MATCH_cong[cong]: "NO_MATCH pat val = NO_MATCH pat val"
   by (rule refl)
 
 declare [[coercion_args NO_MATCH - -]]
 
 simproc_setup NO_MATCH ("NO_MATCH pat val") = \<open>fn _ => fn ctxt => fn ct =>
   let
     val thy = Proof_Context.theory_of ctxt
     val dest_binop = Term.dest_comb #> apfst (Term.dest_comb #> snd)
     val m = Pattern.matches thy (dest_binop (Thm.term_of ct))
   in if m then NONE else SOME @{thm NO_MATCH_def} end
 \<close>
 
 text \<open>
   This setup ensures that a rewrite rule of the form \<^term>\<open>NO_MATCH pat val \<Longrightarrow> t\<close>
   is only applied, if the pattern \<open>pat\<close> does not match the value \<open>val\<close>.
 \<close>
 
 
 text\<open>
   Tagging a premise of a simp rule with ASSUMPTION forces the simplifier
   not to simplify the argument and to solve it by an assumption.
 \<close>
 
 definition ASSUMPTION :: "bool \<Rightarrow> bool"
   where "ASSUMPTION A \<equiv> A"
 
 lemma ASSUMPTION_cong[cong]: "ASSUMPTION A = ASSUMPTION A"
   by (rule refl)
 
 lemma ASSUMPTION_I: "A \<Longrightarrow> ASSUMPTION A"
   by (simp add: ASSUMPTION_def)
 
 lemma ASSUMPTION_D: "ASSUMPTION A \<Longrightarrow> A"
   by (simp add: ASSUMPTION_def)
 
 setup \<open>
 let
   val asm_sol = mk_solver "ASSUMPTION" (fn ctxt =>
     resolve_tac ctxt [@{thm ASSUMPTION_I}] THEN'
     resolve_tac ctxt (Simplifier.prems_of ctxt))
 in
   map_theory_simpset (fn ctxt => Simplifier.addSolver (ctxt,asm_sol))
 end
 \<close>
 
 
 subsection \<open>Code generator setup\<close>
 
 subsubsection \<open>Generic code generator preprocessor setup\<close>
 
 lemma conj_left_cong: "P \<longleftrightarrow> Q \<Longrightarrow> P \<and> R \<longleftrightarrow> Q \<and> R"
   by (fact arg_cong)
 
 lemma disj_left_cong: "P \<longleftrightarrow> Q \<Longrightarrow> P \<or> R \<longleftrightarrow> Q \<or> R"
   by (fact arg_cong)
 
 setup \<open>
   Code_Preproc.map_pre (put_simpset HOL_basic_ss) #>
   Code_Preproc.map_post (put_simpset HOL_basic_ss) #>
   Code_Simp.map_ss (put_simpset HOL_basic_ss #>
   Simplifier.add_cong @{thm conj_left_cong} #>
   Simplifier.add_cong @{thm disj_left_cong})
 \<close>
 
 
 subsubsection \<open>Equality\<close>
 
 class equal =
   fixes equal :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   assumes equal_eq: "equal x y \<longleftrightarrow> x = y"
 begin
 
 lemma equal: "equal = (=)"
   by (rule ext equal_eq)+
 
 lemma equal_refl: "equal x x \<longleftrightarrow> True"
-  unfolding equal by rule+
+  unfolding equal by (rule iffI TrueI refl)+
 
 lemma eq_equal: "(=) \<equiv> equal"
   by (rule eq_reflection) (rule ext, rule ext, rule sym, rule equal_eq)
 
 end
 
 declare eq_equal [symmetric, code_post]
 declare eq_equal [code]
 
 setup \<open>
   Code_Preproc.map_pre (fn ctxt =>
     ctxt addsimprocs
       [Simplifier.make_simproc \<^context> "equal"
         {lhss = [\<^term>\<open>HOL.eq\<close>],
          proc = fn _ => fn _ => fn ct =>
           (case Thm.term_of ct of
             Const (_, Type (\<^type_name>\<open>fun\<close>, [Type _, _])) => SOME @{thm eq_equal}
           | _ => NONE)}])
 \<close>
 
 
 subsubsection \<open>Generic code generator foundation\<close>
 
 text \<open>Datatype \<^typ>\<open>bool\<close>\<close>
 
 code_datatype True False
 
 lemma [code]:
   shows "False \<and> P \<longleftrightarrow> False"
     and "True \<and> P \<longleftrightarrow> P"
     and "P \<and> False \<longleftrightarrow> False"
     and "P \<and> True \<longleftrightarrow> P"
   by simp_all
 
 lemma [code]:
   shows "False \<or> P \<longleftrightarrow> P"
     and "True \<or> P \<longleftrightarrow> True"
     and "P \<or> False \<longleftrightarrow> P"
     and "P \<or> True \<longleftrightarrow> True"
   by simp_all
 
 lemma [code]:
   shows "(False \<longrightarrow> P) \<longleftrightarrow> True"
     and "(True \<longrightarrow> P) \<longleftrightarrow> P"
     and "(P \<longrightarrow> False) \<longleftrightarrow> \<not> P"
     and "(P \<longrightarrow> True) \<longleftrightarrow> True"
   by simp_all
 
 text \<open>More about \<^typ>\<open>prop\<close>\<close>
 
 lemma [code nbe]:
   shows "(True \<Longrightarrow> PROP Q) \<equiv> PROP Q"
     and "(PROP Q \<Longrightarrow> True) \<equiv> Trueprop True"
     and "(P \<Longrightarrow> R) \<equiv> Trueprop (P \<longrightarrow> R)"
   by (auto intro!: equal_intr_rule)
 
 lemma Trueprop_code [code]: "Trueprop True \<equiv> Code_Generator.holds"
   by (auto intro!: equal_intr_rule holds)
 
 declare Trueprop_code [symmetric, code_post]
 
 text \<open>Equality\<close>
 
 declare simp_thms(6) [code nbe]
 
 instantiation itself :: (type) equal
 begin
 
 definition equal_itself :: "'a itself \<Rightarrow> 'a itself \<Rightarrow> bool"
   where "equal_itself x y \<longleftrightarrow> x = y"
 
 instance
   by standard (fact equal_itself_def)
 
 end
 
 lemma equal_itself_code [code]: "equal TYPE('a) TYPE('a) \<longleftrightarrow> True"
   by (simp add: equal)
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>equal\<close>, SOME \<^typ>\<open>'a::type \<Rightarrow> 'a \<Rightarrow> bool\<close>)\<close>
 
 lemma equal_alias_cert: "OFCLASS('a, equal_class) \<equiv> (((=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool) \<equiv> equal)"
   (is "?ofclass \<equiv> ?equal")
 proof
   assume "PROP ?ofclass"
   show "PROP ?equal"
     by (tactic \<open>ALLGOALS (resolve_tac \<^context> [Thm.unconstrainT @{thm eq_equal}])\<close>)
       (fact \<open>PROP ?ofclass\<close>)
 next
   assume "PROP ?equal"
   show "PROP ?ofclass" proof
   qed (simp add: \<open>PROP ?equal\<close>)
 qed
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>equal\<close>, SOME \<^typ>\<open>'a::equal \<Rightarrow> 'a \<Rightarrow> bool\<close>)\<close>
 
 setup \<open>Nbe.add_const_alias @{thm equal_alias_cert}\<close>
 
 text \<open>Cases\<close>
 
 lemma Let_case_cert:
   assumes "CASE \<equiv> (\<lambda>x. Let x f)"
   shows "CASE x \<equiv> f x"
   using assms by simp_all
 
 setup \<open>
   Code.declare_case_global @{thm Let_case_cert} #>
   Code.declare_undefined_global \<^const_name>\<open>undefined\<close>
 \<close>
 
 declare [[code abort: undefined]]
 
 
 subsubsection \<open>Generic code generator target languages\<close>
 
 text \<open>type \<^typ>\<open>bool\<close>\<close>
 
 code_printing
   type_constructor bool \<rightharpoonup>
     (SML) "bool" and (OCaml) "bool" and (Haskell) "Bool" and (Scala) "Boolean"
 | constant True \<rightharpoonup>
     (SML) "true" and (OCaml) "true" and (Haskell) "True" and (Scala) "true"
 | constant False \<rightharpoonup>
     (SML) "false" and (OCaml) "false" and (Haskell) "False" and (Scala) "false"
 
 code_reserved SML
   bool true false
 
 code_reserved OCaml
   bool
 
 code_reserved Scala
   Boolean
 
 code_printing
   constant Not \<rightharpoonup>
     (SML) "not" and (OCaml) "not" and (Haskell) "not" and (Scala) "'! _"
 | constant HOL.conj \<rightharpoonup>
     (SML) infixl 1 "andalso" and (OCaml) infixl 3 "&&" and (Haskell) infixr 3 "&&" and (Scala) infixl 3 "&&"
 | constant HOL.disj \<rightharpoonup>
     (SML) infixl 0 "orelse" and (OCaml) infixl 2 "||" and (Haskell) infixl 2 "||" and (Scala) infixl 1 "||"
 | constant HOL.implies \<rightharpoonup>
     (SML) "!(if (_)/ then (_)/ else true)"
     and (OCaml) "!(if (_)/ then (_)/ else true)"
     and (Haskell) "!(if (_)/ then (_)/ else True)"
     and (Scala) "!(if ((_))/ (_)/ else true)"
 | constant If \<rightharpoonup>
     (SML) "!(if (_)/ then (_)/ else (_))"
     and (OCaml) "!(if (_)/ then (_)/ else (_))"
     and (Haskell) "!(if (_)/ then (_)/ else (_))"
     and (Scala) "!(if ((_))/ (_)/ else (_))"
 
 code_reserved SML
   not
 
 code_reserved OCaml
   not
 
 code_identifier
   code_module Pure \<rightharpoonup>
     (SML) HOL and (OCaml) HOL and (Haskell) HOL and (Scala) HOL
 
 text \<open>Using built-in Haskell equality.\<close>
 code_printing
   type_class equal \<rightharpoonup> (Haskell) "Eq"
 | constant HOL.equal \<rightharpoonup> (Haskell) infix 4 "=="
 | constant HOL.eq \<rightharpoonup> (Haskell) infix 4 "=="
 
 text \<open>\<open>undefined\<close>\<close>
 code_printing
   constant undefined \<rightharpoonup>
     (SML) "!(raise/ Fail/ \"undefined\")"
     and (OCaml) "failwith/ \"undefined\""
     and (Haskell) "error/ \"undefined\""
     and (Scala) "!sys.error(\"undefined\")"
 
 
 subsubsection \<open>Evaluation and normalization by evaluation\<close>
 
 method_setup eval = \<open>
   let
     fun eval_tac ctxt =
       let val conv = Code_Runtime.dynamic_holds_conv
       in
         CONVERSION (Conv.params_conv ~1 (Conv.concl_conv ~1 o conv) ctxt) THEN'
         resolve_tac ctxt [TrueI]
       end
   in
     Scan.succeed (SIMPLE_METHOD' o eval_tac)
   end
 \<close> "solve goal by evaluation"
 
 method_setup normalization = \<open>
   Scan.succeed (fn ctxt =>
     SIMPLE_METHOD'
       (CHANGED_PROP o
         (CONVERSION (Nbe.dynamic_conv ctxt)
           THEN_ALL_NEW (TRY o resolve_tac ctxt [TrueI]))))
 \<close> "solve goal by normalization"
 
 
 subsection \<open>Counterexample Search Units\<close>
 
 subsubsection \<open>Quickcheck\<close>
 
 quickcheck_params [size = 5, iterations = 50]
 
 
 subsubsection \<open>Nitpick setup\<close>
 
 named_theorems nitpick_unfold "alternative definitions of constants as needed by Nitpick"
   and nitpick_simp "equational specification of constants as needed by Nitpick"
   and nitpick_psimp "partial equational specification of constants as needed by Nitpick"
   and nitpick_choice_spec "choice specification of constants as needed by Nitpick"
 
 declare if_bool_eq_conj [nitpick_unfold, no_atp]
   and if_bool_eq_disj [no_atp]
 
 
 subsection \<open>Preprocessing for the predicate compiler\<close>
 
 named_theorems code_pred_def "alternative definitions of constants for the Predicate Compiler"
   and code_pred_inline "inlining definitions for the Predicate Compiler"
   and code_pred_simp "simplification rules for the optimisations in the Predicate Compiler"
 
 
 subsection \<open>Legacy tactics and ML bindings\<close>
 
 ML \<open>
   (* combination of (spec RS spec RS ...(j times) ... spec RS mp) *)
   local
     fun wrong_prem (Const (\<^const_name>\<open>All\<close>, _) $ Abs (_, _, t)) = wrong_prem t
       | wrong_prem (Bound _) = true
       | wrong_prem _ = false;
     val filter_right = filter (not o wrong_prem o HOLogic.dest_Trueprop o hd o Thm.prems_of);
     fun smp i = funpow i (fn m => filter_right ([spec] RL m)) [mp];
   in
     fun smp_tac ctxt j = EVERY' [dresolve_tac ctxt (smp j), assume_tac ctxt];
   end;
 
   local
     val nnf_ss =
       simpset_of (put_simpset HOL_basic_ss \<^context> addsimps @{thms simp_thms nnf_simps});
   in
     fun nnf_conv ctxt = Simplifier.rewrite (put_simpset nnf_ss ctxt);
   end
 \<close>
 
 hide_const (open) eq equal
 
 end
diff --git a/src/HOL/Int.thy b/src/HOL/Int.thy
--- a/src/HOL/Int.thy
+++ b/src/HOL/Int.thy
@@ -1,2252 +1,2272 @@
 (*  Title:      HOL/Int.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Author:     Tobias Nipkow, Florian Haftmann, TU Muenchen
 *)
 
 section \<open>The Integers as Equivalence Classes over Pairs of Natural Numbers\<close>
 
 theory Int
   imports Quotient Groups_Big Fun_Def
 begin
 
 subsection \<open>Definition of integers as a quotient type\<close>
 
 definition intrel :: "(nat \<times> nat) \<Rightarrow> (nat \<times> nat) \<Rightarrow> bool"
   where "intrel = (\<lambda>(x, y) (u, v). x + v = u + y)"
 
 lemma intrel_iff [simp]: "intrel (x, y) (u, v) \<longleftrightarrow> x + v = u + y"
   by (simp add: intrel_def)
 
 quotient_type int = "nat \<times> nat" / "intrel"
   morphisms Rep_Integ Abs_Integ
 proof (rule equivpI)
   show "reflp intrel" by (auto simp: reflp_def)
   show "symp intrel" by (auto simp: symp_def)
   show "transp intrel" by (auto simp: transp_def)
 qed
 
 lemma eq_Abs_Integ [case_names Abs_Integ, cases type: int]:
   "(\<And>x y. z = Abs_Integ (x, y) \<Longrightarrow> P) \<Longrightarrow> P"
   by (induct z) auto
 
 
 subsection \<open>Integers form a commutative ring\<close>
 
 instantiation int :: comm_ring_1
 begin
 
 lift_definition zero_int :: "int" is "(0, 0)" .
 
 lift_definition one_int :: "int" is "(1, 0)" .
 
 lift_definition plus_int :: "int \<Rightarrow> int \<Rightarrow> int"
   is "\<lambda>(x, y) (u, v). (x + u, y + v)"
   by clarsimp
 
 lift_definition uminus_int :: "int \<Rightarrow> int"
   is "\<lambda>(x, y). (y, x)"
   by clarsimp
 
 lift_definition minus_int :: "int \<Rightarrow> int \<Rightarrow> int"
   is "\<lambda>(x, y) (u, v). (x + v, y + u)"
   by clarsimp
 
 lift_definition times_int :: "int \<Rightarrow> int \<Rightarrow> int"
   is "\<lambda>(x, y) (u, v). (x*u + y*v, x*v + y*u)"
-proof (clarsimp)
+proof (unfold intrel_def, clarify)
   fix s t u v w x y z :: nat
   assume "s + v = u + t" and "w + z = y + x"
   then have "(s + v) * w + (u + t) * x + u * (w + z) + v * (y + x) =
     (u + t) * w + (s + v) * x + u * (y + x) + v * (w + z)"
     by simp
   then show "(s * w + t * x) + (u * z + v * y) = (u * y + v * z) + (s * x + t * w)"
     by (simp add: algebra_simps)
 qed
 
 instance
   by standard (transfer; clarsimp simp: algebra_simps)+
 
 end
 
 abbreviation int :: "nat \<Rightarrow> int"
   where "int \<equiv> of_nat"
 
 lemma int_def: "int n = Abs_Integ (n, 0)"
   by (induct n) (simp add: zero_int.abs_eq, simp add: one_int.abs_eq plus_int.abs_eq)
 
 lemma int_transfer [transfer_rule]:
   includes lifting_syntax
   shows "rel_fun (=) pcr_int (\<lambda>n. (n, 0)) int"
   by (simp add: rel_fun_def int.pcr_cr_eq cr_int_def int_def)
 
 lemma int_diff_cases: obtains (diff) m n where "z = int m - int n"
   by transfer clarsimp
 
 
 subsection \<open>Integers are totally ordered\<close>
 
 instantiation int :: linorder
 begin
 
 lift_definition less_eq_int :: "int \<Rightarrow> int \<Rightarrow> bool"
   is "\<lambda>(x, y) (u, v). x + v \<le> u + y"
   by auto
 
 lift_definition less_int :: "int \<Rightarrow> int \<Rightarrow> bool"
   is "\<lambda>(x, y) (u, v). x + v < u + y"
   by auto
 
 instance
   by standard (transfer, force)+
 
 end
 
 instantiation int :: distrib_lattice
 begin
 
 definition "(inf :: int \<Rightarrow> int \<Rightarrow> int) = min"
 
 definition "(sup :: int \<Rightarrow> int \<Rightarrow> int) = max"
 
 instance
   by standard (auto simp add: inf_int_def sup_int_def max_min_distrib2)
 
 end
 
 subsection \<open>Ordering properties of arithmetic operations\<close>
 
 instance int :: ordered_cancel_ab_semigroup_add
 proof
   fix i j k :: int
   show "i \<le> j \<Longrightarrow> k + i \<le> k + j"
     by transfer clarsimp
 qed
 
 text \<open>Strict Monotonicity of Multiplication.\<close>
 
 text \<open>Strict, in 1st argument; proof is by induction on \<open>k > 0\<close>.\<close>
 lemma zmult_zless_mono2_lemma: "i < j \<Longrightarrow> 0 < k \<Longrightarrow> int k * i < int k * j"
   for i j :: int
 proof (induct k)
   case 0
   then show ?case by simp
 next
   case (Suc k)
   then show ?case
     by (cases "k = 0") (simp_all add: distrib_right add_strict_mono)
 qed
 
 lemma zero_le_imp_eq_int:
   assumes "k \<ge> (0::int)" shows "\<exists>n. k = int n"
 proof -
   have "b \<le> a \<Longrightarrow> \<exists>n::nat. a = n + b" for a b
-    by (rule_tac x="a - b" in exI) simp
+    using exI[of _ "a - b"] by simp
   with assms show ?thesis
     by transfer auto
 qed
 
 lemma zero_less_imp_eq_int:
   assumes "k > (0::int)" shows "\<exists>n>0. k = int n"
 proof -
   have "b < a \<Longrightarrow> \<exists>n::nat. n>0 \<and> a = n + b" for a b
-    by (rule_tac x="a - b" in exI) simp
+    using exI[of _ "a - b"] by simp
   with assms show ?thesis
     by transfer auto
 qed
 
 lemma zmult_zless_mono2: "i < j \<Longrightarrow> 0 < k \<Longrightarrow> k * i < k * j"
   for i j k :: int
   by (drule zero_less_imp_eq_int) (auto simp add: zmult_zless_mono2_lemma)
 
 
 text \<open>The integers form an ordered integral domain.\<close>
 
 instantiation int :: linordered_idom
 begin
 
 definition zabs_def: "\<bar>i::int\<bar> = (if i < 0 then - i else i)"
 
 definition zsgn_def: "sgn (i::int) = (if i = 0 then 0 else if 0 < i then 1 else - 1)"
 
 instance
 proof
   fix i j k :: int
   show "i < j \<Longrightarrow> 0 < k \<Longrightarrow> k * i < k * j"
     by (rule zmult_zless_mono2)
   show "\<bar>i\<bar> = (if i < 0 then -i else i)"
     by (simp only: zabs_def)
   show "sgn (i::int) = (if i=0 then 0 else if 0<i then 1 else - 1)"
     by (simp only: zsgn_def)
 qed
 
 end
 
 lemma zless_imp_add1_zle: "w < z \<Longrightarrow> w + 1 \<le> z"
   for w z :: int
   by transfer clarsimp
 
 lemma zless_iff_Suc_zadd: "w < z \<longleftrightarrow> (\<exists>n. z = w + int (Suc n))"
   for w z :: int
 proof -
   have "\<And>a b c d. a + d < c + b \<Longrightarrow> \<exists>n. c + b = Suc (a + n + d)"
-    by (rule_tac x="c+b - Suc(a+d)" in exI) arith
+  proof -
+    fix a b c d :: nat
+    assume "a + d < c + b"
+    then have "c + b = Suc (a + (c + b - Suc (a + d)) + d) "
+      by arith
+    then show "\<exists>n. c + b = Suc (a + n + d)"
+      by (rule exI)
+  qed
   then show ?thesis
     by transfer auto
 qed
 
 lemma zabs_less_one_iff [simp]: "\<bar>z\<bar> < 1 \<longleftrightarrow> z = 0" (is "?lhs \<longleftrightarrow> ?rhs")
   for z :: int
 proof
   assume ?rhs
   then show ?lhs by simp
 next
   assume ?lhs
   with zless_imp_add1_zle [of "\<bar>z\<bar>" 1] have "\<bar>z\<bar> + 1 \<le> 1" by simp
   then have "\<bar>z\<bar> \<le> 0" by simp
   then show ?rhs by simp
 qed
 
 
 subsection \<open>Embedding of the Integers into any \<open>ring_1\<close>: \<open>of_int\<close>\<close>
 
 context ring_1
 begin
 
 lift_definition of_int :: "int \<Rightarrow> 'a"
   is "\<lambda>(i, j). of_nat i - of_nat j"
   by (clarsimp simp add: diff_eq_eq eq_diff_eq diff_add_eq
       of_nat_add [symmetric] simp del: of_nat_add)
 
 lemma of_int_0 [simp]: "of_int 0 = 0"
   by transfer simp
 
 lemma of_int_1 [simp]: "of_int 1 = 1"
   by transfer simp
 
 lemma of_int_add [simp]: "of_int (w + z) = of_int w + of_int z"
   by transfer (clarsimp simp add: algebra_simps)
 
 lemma of_int_minus [simp]: "of_int (- z) = - (of_int z)"
   by (transfer fixing: uminus) clarsimp
 
 lemma of_int_diff [simp]: "of_int (w - z) = of_int w - of_int z"
   using of_int_add [of w "- z"] by simp
 
 lemma of_int_mult [simp]: "of_int (w*z) = of_int w * of_int z"
   by (transfer fixing: times) (clarsimp simp add: algebra_simps)
 
 lemma mult_of_int_commute: "of_int x * y = y * of_int x"
   by (transfer fixing: times) (auto simp: algebra_simps mult_of_nat_commute)
 
 text \<open>Collapse nested embeddings.\<close>
 lemma of_int_of_nat_eq [simp]: "of_int (int n) = of_nat n"
   by (induct n) auto
 
 lemma of_int_numeral [simp, code_post]: "of_int (numeral k) = numeral k"
   by (simp add: of_nat_numeral [symmetric] of_int_of_nat_eq [symmetric])
 
 lemma of_int_neg_numeral [code_post]: "of_int (- numeral k) = - numeral k"
   by simp
 
 lemma of_int_power [simp]: "of_int (z ^ n) = of_int z ^ n"
   by (induct n) simp_all
 
 lemma of_int_of_bool [simp]:
   "of_int (of_bool P) = of_bool P"
   by auto
 
 end
 
 context ring_char_0
 begin
 
 lemma of_int_eq_iff [simp]: "of_int w = of_int z \<longleftrightarrow> w = z"
   by transfer (clarsimp simp add: algebra_simps of_nat_add [symmetric] simp del: of_nat_add)
 
 text \<open>Special cases where either operand is zero.\<close>
 lemma of_int_eq_0_iff [simp]: "of_int z = 0 \<longleftrightarrow> z = 0"
   using of_int_eq_iff [of z 0] by simp
 
 lemma of_int_0_eq_iff [simp]: "0 = of_int z \<longleftrightarrow> z = 0"
   using of_int_eq_iff [of 0 z] by simp
 
 lemma of_int_eq_1_iff [iff]: "of_int z = 1 \<longleftrightarrow> z = 1"
   using of_int_eq_iff [of z 1] by simp
 
 lemma numeral_power_eq_of_int_cancel_iff [simp]:
   "numeral x ^ n = of_int y \<longleftrightarrow> numeral x ^ n = y"
   using of_int_eq_iff[of "numeral x ^ n" y, unfolded of_int_numeral of_int_power] .
 
 lemma of_int_eq_numeral_power_cancel_iff [simp]:
   "of_int y = numeral x ^ n \<longleftrightarrow> y = numeral x ^ n"
   using numeral_power_eq_of_int_cancel_iff [of x n y] by (metis (mono_tags))
 
 lemma neg_numeral_power_eq_of_int_cancel_iff [simp]:
   "(- numeral x) ^ n = of_int y \<longleftrightarrow> (- numeral x) ^ n = y"
   using of_int_eq_iff[of "(- numeral x) ^ n" y]
   by simp
 
 lemma of_int_eq_neg_numeral_power_cancel_iff [simp]:
   "of_int y = (- numeral x) ^ n \<longleftrightarrow> y = (- numeral x) ^ n"
   using neg_numeral_power_eq_of_int_cancel_iff[of x n y] by (metis (mono_tags))
 
 lemma of_int_eq_of_int_power_cancel_iff[simp]: "(of_int b) ^ w = of_int x \<longleftrightarrow> b ^ w = x"
   by (metis of_int_power of_int_eq_iff)
 
 lemma of_int_power_eq_of_int_cancel_iff[simp]: "of_int x = (of_int b) ^ w \<longleftrightarrow> x = b ^ w"
   by (metis of_int_eq_of_int_power_cancel_iff)
 
 end
 
 context linordered_idom
 begin
 
 text \<open>Every \<open>linordered_idom\<close> has characteristic zero.\<close>
 subclass ring_char_0 ..
 
 lemma of_int_le_iff [simp]: "of_int w \<le> of_int z \<longleftrightarrow> w \<le> z"
   by (transfer fixing: less_eq)
     (clarsimp simp add: algebra_simps of_nat_add [symmetric] simp del: of_nat_add)
 
 lemma of_int_less_iff [simp]: "of_int w < of_int z \<longleftrightarrow> w < z"
   by (simp add: less_le order_less_le)
 
 lemma of_int_0_le_iff [simp]: "0 \<le> of_int z \<longleftrightarrow> 0 \<le> z"
   using of_int_le_iff [of 0 z] by simp
 
 lemma of_int_le_0_iff [simp]: "of_int z \<le> 0 \<longleftrightarrow> z \<le> 0"
   using of_int_le_iff [of z 0] by simp
 
 lemma of_int_0_less_iff [simp]: "0 < of_int z \<longleftrightarrow> 0 < z"
   using of_int_less_iff [of 0 z] by simp
 
 lemma of_int_less_0_iff [simp]: "of_int z < 0 \<longleftrightarrow> z < 0"
   using of_int_less_iff [of z 0] by simp
 
 lemma of_int_1_le_iff [simp]: "1 \<le> of_int z \<longleftrightarrow> 1 \<le> z"
   using of_int_le_iff [of 1 z] by simp
 
 lemma of_int_le_1_iff [simp]: "of_int z \<le> 1 \<longleftrightarrow> z \<le> 1"
   using of_int_le_iff [of z 1] by simp
 
 lemma of_int_1_less_iff [simp]: "1 < of_int z \<longleftrightarrow> 1 < z"
   using of_int_less_iff [of 1 z] by simp
 
 lemma of_int_less_1_iff [simp]: "of_int z < 1 \<longleftrightarrow> z < 1"
   using of_int_less_iff [of z 1] by simp
 
 lemma of_int_pos: "z > 0 \<Longrightarrow> of_int z > 0"
   by simp
 
 lemma of_int_nonneg: "z \<ge> 0 \<Longrightarrow> of_int z \<ge> 0"
   by simp
 
 lemma of_int_abs [simp]: "of_int \<bar>x\<bar> = \<bar>of_int x\<bar>"
   by (auto simp add: abs_if)
 
 lemma of_int_lessD:
   assumes "\<bar>of_int n\<bar> < x"
   shows "n = 0 \<or> x > 1"
 proof (cases "n = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "\<bar>n\<bar> \<noteq> 0" by simp
   then have "\<bar>n\<bar> > 0" by simp
   then have "\<bar>n\<bar> \<ge> 1"
     using zless_imp_add1_zle [of 0 "\<bar>n\<bar>"] by simp
   then have "\<bar>of_int n\<bar> \<ge> 1"
     unfolding of_int_1_le_iff [of "\<bar>n\<bar>", symmetric] by simp
   then have "1 < x" using assms by (rule le_less_trans)
   then show ?thesis ..
 qed
 
 lemma of_int_leD:
   assumes "\<bar>of_int n\<bar> \<le> x"
   shows "n = 0 \<or> 1 \<le> x"
 proof (cases "n = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "\<bar>n\<bar> \<noteq> 0" by simp
   then have "\<bar>n\<bar> > 0" by simp
   then have "\<bar>n\<bar> \<ge> 1"
     using zless_imp_add1_zle [of 0 "\<bar>n\<bar>"] by simp
   then have "\<bar>of_int n\<bar> \<ge> 1"
     unfolding of_int_1_le_iff [of "\<bar>n\<bar>", symmetric] by simp
   then have "1 \<le> x" using assms by (rule order_trans)
   then show ?thesis ..
 qed
 
 lemma numeral_power_le_of_int_cancel_iff [simp]:
   "numeral x ^ n \<le> of_int a \<longleftrightarrow> numeral x ^ n \<le> a"
   by (metis (mono_tags) local.of_int_eq_numeral_power_cancel_iff of_int_le_iff)
 
 lemma of_int_le_numeral_power_cancel_iff [simp]:
   "of_int a \<le> numeral x ^ n \<longleftrightarrow> a \<le> numeral x ^ n"
   by (metis (mono_tags) local.numeral_power_eq_of_int_cancel_iff of_int_le_iff)
 
 lemma numeral_power_less_of_int_cancel_iff [simp]:
   "numeral x ^ n < of_int a \<longleftrightarrow> numeral x ^ n < a"
   by (metis (mono_tags) local.of_int_eq_numeral_power_cancel_iff of_int_less_iff)
 
 lemma of_int_less_numeral_power_cancel_iff [simp]:
   "of_int a < numeral x ^ n \<longleftrightarrow> a < numeral x ^ n"
   by (metis (mono_tags) local.of_int_eq_numeral_power_cancel_iff of_int_less_iff)
 
 lemma neg_numeral_power_le_of_int_cancel_iff [simp]:
   "(- numeral x) ^ n \<le> of_int a \<longleftrightarrow> (- numeral x) ^ n \<le> a"
   by (metis (mono_tags) of_int_le_iff of_int_neg_numeral of_int_power)
 
 lemma of_int_le_neg_numeral_power_cancel_iff [simp]:
   "of_int a \<le> (- numeral x) ^ n \<longleftrightarrow> a \<le> (- numeral x) ^ n"
   by (metis (mono_tags) of_int_le_iff of_int_neg_numeral of_int_power)
 
 lemma neg_numeral_power_less_of_int_cancel_iff [simp]:
   "(- numeral x) ^ n < of_int a \<longleftrightarrow> (- numeral x) ^ n < a"
   using of_int_less_iff[of "(- numeral x) ^ n" a]
   by simp
 
 lemma of_int_less_neg_numeral_power_cancel_iff [simp]:
   "of_int a < (- numeral x) ^ n \<longleftrightarrow> a < (- numeral x::int) ^ n"
   using of_int_less_iff[of a "(- numeral x) ^ n"]
   by simp
 
 lemma of_int_le_of_int_power_cancel_iff[simp]: "(of_int b) ^ w \<le> of_int x \<longleftrightarrow> b ^ w \<le> x"
   by (metis (mono_tags) of_int_le_iff of_int_power)
 
 lemma of_int_power_le_of_int_cancel_iff[simp]: "of_int x \<le> (of_int b) ^ w\<longleftrightarrow> x \<le> b ^ w"
   by (metis (mono_tags) of_int_le_iff of_int_power)
 
 lemma of_int_less_of_int_power_cancel_iff[simp]: "(of_int b) ^ w < of_int x \<longleftrightarrow> b ^ w < x"
   by (metis (mono_tags) of_int_less_iff of_int_power)
 
 lemma of_int_power_less_of_int_cancel_iff[simp]: "of_int x < (of_int b) ^ w\<longleftrightarrow> x < b ^ w"
   by (metis (mono_tags) of_int_less_iff of_int_power)
 
 lemma of_int_max: "of_int (max x y) = max (of_int x) (of_int y)"
   by (auto simp: max_def)
 
 lemma of_int_min: "of_int (min x y) = min (of_int x) (of_int y)"
   by (auto simp: min_def)
 
 end
 
 context division_ring
 begin
 
 lemmas mult_inverse_of_int_commute =
   mult_commute_imp_mult_inverse_commute[OF mult_of_int_commute]
 
 end
 
 text \<open>Comparisons involving \<^term>\<open>of_int\<close>.\<close>
 
 lemma of_int_eq_numeral_iff [iff]: "of_int z = (numeral n :: 'a::ring_char_0) \<longleftrightarrow> z = numeral n"
   using of_int_eq_iff by fastforce
 
 lemma of_int_le_numeral_iff [simp]:
   "of_int z \<le> (numeral n :: 'a::linordered_idom) \<longleftrightarrow> z \<le> numeral n"
   using of_int_le_iff [of z "numeral n"] by simp
 
 lemma of_int_numeral_le_iff [simp]:
   "(numeral n :: 'a::linordered_idom) \<le> of_int z \<longleftrightarrow> numeral n \<le> z"
   using of_int_le_iff [of "numeral n"] by simp
 
 lemma of_int_less_numeral_iff [simp]:
   "of_int z < (numeral n :: 'a::linordered_idom) \<longleftrightarrow> z < numeral n"
   using of_int_less_iff [of z "numeral n"] by simp
 
 lemma of_int_numeral_less_iff [simp]:
   "(numeral n :: 'a::linordered_idom) < of_int z \<longleftrightarrow> numeral n < z"
   using of_int_less_iff [of "numeral n" z] by simp
 
 lemma of_nat_less_of_int_iff: "(of_nat n::'a::linordered_idom) < of_int x \<longleftrightarrow> int n < x"
   by (metis of_int_of_nat_eq of_int_less_iff)
 
 lemma of_int_eq_id [simp]: "of_int = id"
 proof
   show "of_int z = id z" for z
     by (cases z rule: int_diff_cases) simp
 qed
 
 instance int :: no_top
 proof
-  show "\<And>x::int. \<exists>y. x < y"
-    by (rule_tac x="x + 1" in exI) simp
+  fix x::int
+  have "x < x + 1"
+    by simp
+  then show "\<exists>y. x < y"
+    by (rule exI)
 qed
 
 instance int :: no_bot
 proof
-  show "\<And>x::int. \<exists>y. y < x"
-    by (rule_tac x="x - 1" in exI) simp
+  fix x::int
+  have "x - 1< x"
+    by simp
+  then show "\<exists>y. y < x"
+    by (rule exI)
 qed
 
 
 subsection \<open>Magnitude of an Integer, as a Natural Number: \<open>nat\<close>\<close>
 
 lift_definition nat :: "int \<Rightarrow> nat" is "\<lambda>(x, y). x - y"
   by auto
 
 lemma nat_int [simp]: "nat (int n) = n"
   by transfer simp
 
 lemma int_nat_eq [simp]: "int (nat z) = (if 0 \<le> z then z else 0)"
   by transfer clarsimp
 
 lemma nat_0_le: "0 \<le> z \<Longrightarrow> int (nat z) = z"
   by simp
 
 lemma nat_le_0 [simp]: "z \<le> 0 \<Longrightarrow> nat z = 0"
   by transfer clarsimp
 
 lemma nat_le_eq_zle: "0 < w \<or> 0 \<le> z \<Longrightarrow> nat w \<le> nat z \<longleftrightarrow> w \<le> z"
   by transfer (clarsimp, arith)
 
 text \<open>An alternative condition is \<^term>\<open>0 \<le> w\<close>.\<close>
 lemma nat_mono_iff: "0 < z \<Longrightarrow> nat w < nat z \<longleftrightarrow> w < z"
   by (simp add: nat_le_eq_zle linorder_not_le [symmetric])
 
 lemma nat_less_eq_zless: "0 \<le> w \<Longrightarrow> nat w < nat z \<longleftrightarrow> w < z"
   by (simp add: nat_le_eq_zle linorder_not_le [symmetric])
 
 lemma zless_nat_conj [simp]: "nat w < nat z \<longleftrightarrow> 0 < z \<and> w < z"
   by transfer (clarsimp, arith)
 
 lemma nonneg_int_cases:
   assumes "0 \<le> k"
   obtains n where "k = int n"
 proof -
   from assms have "k = int (nat k)"
     by simp
   then show thesis
     by (rule that)
 qed
 
 lemma pos_int_cases:
   assumes "0 < k"
   obtains n where "k = int n" and "n > 0"
 proof -
   from assms have "0 \<le> k"
     by simp
   then obtain n where "k = int n"
     by (rule nonneg_int_cases)
   moreover have "n > 0"
     using \<open>k = int n\<close> assms by simp
   ultimately show thesis
     by (rule that)
 qed
 
 lemma nonpos_int_cases:
   assumes "k \<le> 0"
   obtains n where "k = - int n"
 proof -
   from assms have "- k \<ge> 0"
     by simp
   then obtain n where "- k = int n"
     by (rule nonneg_int_cases)
   then have "k = - int n"
     by simp
   then show thesis
     by (rule that)
 qed
 
 lemma neg_int_cases:
   assumes "k < 0"
   obtains n where "k = - int n" and "n > 0"
 proof -
   from assms have "- k > 0"
     by simp
   then obtain n where "- k = int n" and "- k > 0"
     by (blast elim: pos_int_cases)
   then have "k = - int n" and "n > 0"
     by simp_all
   then show thesis
     by (rule that)
 qed
 
 lemma nat_eq_iff: "nat w = m \<longleftrightarrow> (if 0 \<le> w then w = int m else m = 0)"
   by transfer (clarsimp simp add: le_imp_diff_is_add)
 
 lemma nat_eq_iff2: "m = nat w \<longleftrightarrow> (if 0 \<le> w then w = int m else m = 0)"
   using nat_eq_iff [of w m] by auto
 
 lemma nat_0 [simp]: "nat 0 = 0"
   by (simp add: nat_eq_iff)
 
 lemma nat_1 [simp]: "nat 1 = Suc 0"
   by (simp add: nat_eq_iff)
 
 lemma nat_numeral [simp]: "nat (numeral k) = numeral k"
   by (simp add: nat_eq_iff)
 
 lemma nat_neg_numeral [simp]: "nat (- numeral k) = 0"
   by simp
 
 lemma nat_2: "nat 2 = Suc (Suc 0)"
   by simp
 
 lemma nat_less_iff: "0 \<le> w \<Longrightarrow> nat w < m \<longleftrightarrow> w < of_nat m"
   by transfer (clarsimp, arith)
 
 lemma nat_le_iff: "nat x \<le> n \<longleftrightarrow> x \<le> int n"
   by transfer (clarsimp simp add: le_diff_conv)
 
 lemma nat_mono: "x \<le> y \<Longrightarrow> nat x \<le> nat y"
   by transfer auto
 
 lemma nat_0_iff[simp]: "nat i = 0 \<longleftrightarrow> i \<le> 0"
   for i :: int
   by transfer clarsimp
 
 lemma int_eq_iff: "of_nat m = z \<longleftrightarrow> m = nat z \<and> 0 \<le> z"
   by (auto simp add: nat_eq_iff2)
 
 lemma zero_less_nat_eq [simp]: "0 < nat z \<longleftrightarrow> 0 < z"
   using zless_nat_conj [of 0] by auto
 
 lemma nat_add_distrib: "0 \<le> z \<Longrightarrow> 0 \<le> z' \<Longrightarrow> nat (z + z') = nat z + nat z'"
   by transfer clarsimp
 
 lemma nat_diff_distrib': "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> nat (x - y) = nat x - nat y"
   by transfer clarsimp
 
 lemma nat_diff_distrib: "0 \<le> z' \<Longrightarrow> z' \<le> z \<Longrightarrow> nat (z - z') = nat z - nat z'"
   by (rule nat_diff_distrib') auto
 
 lemma nat_zminus_int [simp]: "nat (- int n) = 0"
   by transfer simp
 
 lemma le_nat_iff: "k \<ge> 0 \<Longrightarrow> n \<le> nat k \<longleftrightarrow> int n \<le> k"
   by transfer auto
 
 lemma zless_nat_eq_int_zless: "m < nat z \<longleftrightarrow> int m < z"
   by transfer (clarsimp simp add: less_diff_conv)
 
 lemma (in ring_1) of_nat_nat [simp]: "0 \<le> z \<Longrightarrow> of_nat (nat z) = of_int z"
   by transfer (clarsimp simp add: of_nat_diff)
 
 lemma diff_nat_numeral [simp]: "(numeral v :: nat) - numeral v' = nat (numeral v - numeral v')"
   by (simp only: nat_diff_distrib' zero_le_numeral nat_numeral)
 
 lemma nat_abs_triangle_ineq:
   "nat \<bar>k + l\<bar> \<le> nat \<bar>k\<bar> + nat \<bar>l\<bar>"
   by (simp add: nat_add_distrib [symmetric] nat_le_eq_zle abs_triangle_ineq)
 
 lemma nat_of_bool [simp]:
   "nat (of_bool P) = of_bool P"
   by auto
 
 lemma split_nat [arith_split]: "P (nat i) \<longleftrightarrow> ((\<forall>n. i = int n \<longrightarrow> P n) \<and> (i < 0 \<longrightarrow> P 0))"
   (is "?P = (?L \<and> ?R)")
   for i :: int
 proof (cases "i < 0")
   case True
   then show ?thesis
     by auto
 next
   case False
   have "?P = ?L"
   proof
     assume ?P
     then show ?L using False by auto
   next
     assume ?L
     moreover from False have "int (nat i) = i"
       by (simp add: not_less)
     ultimately show ?P
       by simp
   qed
   with False show ?thesis by simp
 qed
 
 lemma all_nat: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>x\<ge>0. P (nat x))"
   by (auto split: split_nat)
 
 lemma ex_nat: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>x. 0 \<le> x \<and> P (nat x))"
 proof
   assume "\<exists>x. P x"
   then obtain x where "P x" ..
   then have "int x \<ge> 0 \<and> P (nat (int x))" by simp
   then show "\<exists>x\<ge>0. P (nat x)" ..
 next
   assume "\<exists>x\<ge>0. P (nat x)"
   then show "\<exists>x. P x" by auto
 qed
 
 
 text \<open>For termination proofs:\<close>
 lemma measure_function_int[measure_function]: "is_measure (nat \<circ> abs)" ..
 
 
 subsection \<open>Lemmas about the Function \<^term>\<open>of_nat\<close> and Orderings\<close>
 
 lemma negative_zless_0: "- (int (Suc n)) < (0 :: int)"
   by (simp add: order_less_le del: of_nat_Suc)
 
 lemma negative_zless [iff]: "- (int (Suc n)) < int m"
   by (rule negative_zless_0 [THEN order_less_le_trans], simp)
 
 lemma negative_zle_0: "- int n \<le> 0"
   by (simp add: minus_le_iff)
 
 lemma negative_zle [iff]: "- int n \<le> int m"
   by (rule order_trans [OF negative_zle_0 of_nat_0_le_iff])
 
 lemma not_zle_0_negative [simp]: "\<not> 0 \<le> - int (Suc n)"
   by (subst le_minus_iff) (simp del: of_nat_Suc)
 
 lemma int_zle_neg: "int n \<le> - int m \<longleftrightarrow> n = 0 \<and> m = 0"
   by transfer simp
 
 lemma not_int_zless_negative [simp]: "\<not> int n < - int m"
   by (simp add: linorder_not_less)
 
 lemma negative_eq_positive [simp]: "- int n = of_nat m \<longleftrightarrow> n = 0 \<and> m = 0"
   by (force simp add: order_eq_iff [of "- of_nat n"] int_zle_neg)
 
 lemma zle_iff_zadd: "w \<le> z \<longleftrightarrow> (\<exists>n. z = w + int n)"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs by auto
 next
   assume ?lhs
   then have "0 \<le> z - w" by simp
   then obtain n where "z - w = int n"
     using zero_le_imp_eq_int [of "z - w"] by blast
   then have "z = w + int n" by simp
   then show ?rhs ..
 qed
 
 lemma zadd_int_left: "int m + (int n + z) = int (m + n) + z"
   by simp
 
 text \<open>
   This version is proved for all ordered rings, not just integers!
   It is proved here because attribute \<open>arith_split\<close> is not available
   in theory \<open>Rings\<close>.
   But is it really better than just rewriting with \<open>abs_if\<close>?
 \<close>
 lemma abs_split [arith_split, no_atp]: "P \<bar>a\<bar> \<longleftrightarrow> (0 \<le> a \<longrightarrow> P a) \<and> (a < 0 \<longrightarrow> P (- a))"
   for a :: "'a::linordered_idom"
   by (force dest: order_less_le_trans simp add: abs_if linorder_not_less)
 
 lemma negD:
   assumes "x < 0" shows "\<exists>n. x = - (int (Suc n))"
 proof -
   have "\<And>a b. a < b \<Longrightarrow> \<exists>n. Suc (a + n) = b"
-    by (rule_tac x="b - Suc a" in exI) arith
+  proof -
+    fix a b:: nat
+    assume "a < b"
+    then have "Suc (a + (b - Suc a)) = b"
+      by arith
+    then show "\<exists>n. Suc (a + n) = b"
+      by (rule exI)
+  qed
   with assms show ?thesis
     by transfer auto
 qed
 
 
 subsection \<open>Cases and induction\<close>
 
 text \<open>
   Now we replace the case analysis rule by a more conventional one:
   whether an integer is negative or not.
 \<close>
 
 text \<open>This version is symmetric in the two subgoals.\<close>
 lemma int_cases2 [case_names nonneg nonpos, cases type: int]:
   "(\<And>n. z = int n \<Longrightarrow> P) \<Longrightarrow> (\<And>n. z = - (int n) \<Longrightarrow> P) \<Longrightarrow> P"
   by (cases "z < 0") (auto simp add: linorder_not_less dest!: negD nat_0_le [THEN sym])
 
 text \<open>This is the default, with a negative case.\<close>
 lemma int_cases [case_names nonneg neg, cases type: int]:
   assumes pos: "\<And>n. z = int n \<Longrightarrow> P" and neg: "\<And>n. z = - (int (Suc n)) \<Longrightarrow> P"
   shows P
 proof (cases "z < 0")
   case True
   with neg show ?thesis
     by (blast dest!: negD)
 next
   case False
   with pos show ?thesis
     by (force simp add: linorder_not_less dest: nat_0_le [THEN sym])
 qed
 
 lemma int_cases3 [case_names zero pos neg]:
   fixes k :: int
   assumes "k = 0 \<Longrightarrow> P" and "\<And>n. k = int n \<Longrightarrow> n > 0 \<Longrightarrow> P"
     and "\<And>n. k = - int n \<Longrightarrow> n > 0 \<Longrightarrow> P"
   shows "P"
 proof (cases k "0::int" rule: linorder_cases)
   case equal
   with assms(1) show P by simp
 next
   case greater
   then have *: "nat k > 0" by simp
   moreover from * have "k = int (nat k)" by auto
   ultimately show P using assms(2) by blast
 next
   case less
   then have *: "nat (- k) > 0" by simp
   moreover from * have "k = - int (nat (- k))" by auto
   ultimately show P using assms(3) by blast
 qed
 
 lemma int_of_nat_induct [case_names nonneg neg, induct type: int]:
   "(\<And>n. P (int n)) \<Longrightarrow> (\<And>n. P (- (int (Suc n)))) \<Longrightarrow> P z"
   by (cases z) auto
 
 lemma sgn_mult_dvd_iff [simp]:
   "sgn r * l dvd k \<longleftrightarrow> l dvd k \<and> (r = 0 \<longrightarrow> k = 0)" for k l r :: int
   by (cases r rule: int_cases3) auto
 
 lemma mult_sgn_dvd_iff [simp]:
   "l * sgn r dvd k \<longleftrightarrow> l dvd k \<and> (r = 0 \<longrightarrow> k = 0)" for k l r :: int
   using sgn_mult_dvd_iff [of r l k] by (simp add: ac_simps)
 
 lemma dvd_sgn_mult_iff [simp]:
   "l dvd sgn r * k \<longleftrightarrow> l dvd k \<or> r = 0" for k l r :: int
   by (cases r rule: int_cases3) simp_all
 
 lemma dvd_mult_sgn_iff [simp]:
   "l dvd k * sgn r \<longleftrightarrow> l dvd k \<or> r = 0" for k l r :: int
   using dvd_sgn_mult_iff [of l r k] by (simp add: ac_simps)
 
 lemma int_sgnE:
   fixes k :: int
   obtains n and l where "k = sgn l * int n"
 proof -
   have "k = sgn k * int (nat \<bar>k\<bar>)"
     by (simp add: sgn_mult_abs)
   then show ?thesis ..
 qed
 
 
 subsubsection \<open>Binary comparisons\<close>
 
 text \<open>Preliminaries\<close>
 
 lemma le_imp_0_less:
   fixes z :: int
   assumes le: "0 \<le> z"
   shows "0 < 1 + z"
 proof -
   have "0 \<le> z" by fact
   also have "\<dots> < z + 1" by (rule less_add_one)
   also have "\<dots> = 1 + z" by (simp add: ac_simps)
   finally show "0 < 1 + z" .
 qed
 
 lemma odd_less_0_iff: "1 + z + z < 0 \<longleftrightarrow> z < 0"
   for z :: int
 proof (cases z)
   case (nonneg n)
   then show ?thesis
     by (simp add: linorder_not_less add.assoc add_increasing le_imp_0_less [THEN order_less_imp_le])
 next
   case (neg n)
   then show ?thesis
     by (simp del: of_nat_Suc of_nat_add of_nat_1
         add: algebra_simps of_nat_1 [where 'a=int, symmetric] of_nat_add [symmetric])
 qed
 
 
 subsubsection \<open>Comparisons, for Ordered Rings\<close>
 
 lemma odd_nonzero: "1 + z + z \<noteq> 0"
   for z :: int
 proof (cases z)
   case (nonneg n)
   have le: "0 \<le> z + z"
     by (simp add: nonneg add_increasing)
   then show ?thesis
     using le_imp_0_less [OF le] by (auto simp: ac_simps)
 next
   case (neg n)
   show ?thesis
   proof
     assume eq: "1 + z + z = 0"
     have "0 < 1 + (int n + int n)"
       by (simp add: le_imp_0_less add_increasing)
     also have "\<dots> = - (1 + z + z)"
       by (simp add: neg add.assoc [symmetric])
     also have "\<dots> = 0" by (simp add: eq)
     finally have "0<0" ..
     then show False by blast
   qed
 qed
 
 
 subsection \<open>The Set of Integers\<close>
 
 context ring_1
 begin
 
 definition Ints :: "'a set"  ("\<int>")
   where "\<int> = range of_int"
 
 lemma Ints_of_int [simp]: "of_int z \<in> \<int>"
   by (simp add: Ints_def)
 
 lemma Ints_of_nat [simp]: "of_nat n \<in> \<int>"
   using Ints_of_int [of "of_nat n"] by simp
 
 lemma Ints_0 [simp]: "0 \<in> \<int>"
   using Ints_of_int [of "0"] by simp
 
 lemma Ints_1 [simp]: "1 \<in> \<int>"
   using Ints_of_int [of "1"] by simp
 
 lemma Ints_numeral [simp]: "numeral n \<in> \<int>"
   by (subst of_nat_numeral [symmetric], rule Ints_of_nat)
 
 lemma Ints_add [simp]: "a \<in> \<int> \<Longrightarrow> b \<in> \<int> \<Longrightarrow> a + b \<in> \<int>"
   by (force simp add: Ints_def simp flip: of_int_add intro: range_eqI)
 
 lemma Ints_minus [simp]: "a \<in> \<int> \<Longrightarrow> -a \<in> \<int>"
   by (force simp add: Ints_def simp flip: of_int_minus intro: range_eqI)
 
 lemma minus_in_Ints_iff: "-x \<in> \<int> \<longleftrightarrow> x \<in> \<int>"
   using Ints_minus[of x] Ints_minus[of "-x"] by auto
 
 lemma Ints_diff [simp]: "a \<in> \<int> \<Longrightarrow> b \<in> \<int> \<Longrightarrow> a - b \<in> \<int>"
   by (force simp add: Ints_def simp flip: of_int_diff intro: range_eqI)
 
 lemma Ints_mult [simp]: "a \<in> \<int> \<Longrightarrow> b \<in> \<int> \<Longrightarrow> a * b \<in> \<int>"
   by (force simp add: Ints_def simp flip: of_int_mult intro: range_eqI)
 
 lemma Ints_power [simp]: "a \<in> \<int> \<Longrightarrow> a ^ n \<in> \<int>"
   by (induct n) simp_all
 
 lemma Ints_cases [cases set: Ints]:
   assumes "q \<in> \<int>"
   obtains (of_int) z where "q = of_int z"
   unfolding Ints_def
 proof -
   from \<open>q \<in> \<int>\<close> have "q \<in> range of_int" unfolding Ints_def .
   then obtain z where "q = of_int z" ..
   then show thesis ..
 qed
 
 lemma Ints_induct [case_names of_int, induct set: Ints]:
   "q \<in> \<int> \<Longrightarrow> (\<And>z. P (of_int z)) \<Longrightarrow> P q"
   by (rule Ints_cases) auto
 
 lemma Nats_subset_Ints: "\<nat> \<subseteq> \<int>"
   unfolding Nats_def Ints_def
   by (rule subsetI, elim imageE, hypsubst, subst of_int_of_nat_eq[symmetric], rule imageI) simp_all
 
 lemma Nats_altdef1: "\<nat> = {of_int n |n. n \<ge> 0}"
 proof (intro subsetI equalityI)
   fix x :: 'a
   assume "x \<in> {of_int n |n. n \<ge> 0}"
   then obtain n where "x = of_int n" "n \<ge> 0"
     by (auto elim!: Ints_cases)
   then have "x = of_nat (nat n)"
     by (subst of_nat_nat) simp_all
   then show "x \<in> \<nat>"
     by simp
 next
   fix x :: 'a
   assume "x \<in> \<nat>"
   then obtain n where "x = of_nat n"
     by (auto elim!: Nats_cases)
   then have "x = of_int (int n)" by simp
   also have "int n \<ge> 0" by simp
   then have "of_int (int n) \<in> {of_int n |n. n \<ge> 0}" by blast
   finally show "x \<in> {of_int n |n. n \<ge> 0}" .
 qed
 
 end
 
 lemma Ints_sum [intro]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<int>) \<Longrightarrow> sum f A \<in> \<int>"
   by (induction A rule: infinite_finite_induct) auto
 
 lemma Ints_prod [intro]: "(\<And>x. x \<in> A \<Longrightarrow> f x \<in> \<int>) \<Longrightarrow> prod f A \<in> \<int>"
   by (induction A rule: infinite_finite_induct) auto
 
 lemma (in linordered_idom) Ints_abs [simp]:
   shows "a \<in> \<int> \<Longrightarrow> abs a \<in> \<int>"
   by (auto simp: abs_if)
 
 lemma (in linordered_idom) Nats_altdef2: "\<nat> = {n \<in> \<int>. n \<ge> 0}"
 proof (intro subsetI equalityI)
   fix x :: 'a
   assume "x \<in> {n \<in> \<int>. n \<ge> 0}"
   then obtain n where "x = of_int n" "n \<ge> 0"
     by (auto elim!: Ints_cases)
   then have "x = of_nat (nat n)"
     by (subst of_nat_nat) simp_all
   then show "x \<in> \<nat>"
     by simp
 qed (auto elim!: Nats_cases)
 
 lemma (in idom_divide) of_int_divide_in_Ints: 
   "of_int a div of_int b \<in> \<int>" if "b dvd a"
 proof -
   from that obtain c where "a = b * c" ..
   then show ?thesis
     by (cases "of_int b = 0") simp_all
 qed
 
 text \<open>The premise involving \<^term>\<open>Ints\<close> prevents \<^term>\<open>a = 1/2\<close>.\<close>
 
 lemma Ints_double_eq_0_iff:
   fixes a :: "'a::ring_char_0"
   assumes in_Ints: "a \<in> \<int>"
   shows "a + a = 0 \<longleftrightarrow> a = 0"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof -
   from in_Ints have "a \<in> range of_int"
     unfolding Ints_def [symmetric] .
   then obtain z where a: "a = of_int z" ..
   show ?thesis
   proof
     assume ?rhs
     then show ?lhs by simp
   next
     assume ?lhs
     with a have "of_int (z + z) = (of_int 0 :: 'a)" by simp
     then have "z + z = 0" by (simp only: of_int_eq_iff)
     then have "z = 0" by (simp only: double_zero)
     with a show ?rhs by simp
   qed
 qed
 
 lemma Ints_odd_nonzero:
   fixes a :: "'a::ring_char_0"
   assumes in_Ints: "a \<in> \<int>"
   shows "1 + a + a \<noteq> 0"
 proof -
   from in_Ints have "a \<in> range of_int"
     unfolding Ints_def [symmetric] .
   then obtain z where a: "a = of_int z" ..
   show ?thesis
   proof
     assume "1 + a + a = 0"
     with a have "of_int (1 + z + z) = (of_int 0 :: 'a)" by simp
     then have "1 + z + z = 0" by (simp only: of_int_eq_iff)
     with odd_nonzero show False by blast
   qed
 qed
 
 lemma Nats_numeral [simp]: "numeral w \<in> \<nat>"
   using of_nat_in_Nats [of "numeral w"] by simp
 
 lemma Ints_odd_less_0:
   fixes a :: "'a::linordered_idom"
   assumes in_Ints: "a \<in> \<int>"
   shows "1 + a + a < 0 \<longleftrightarrow> a < 0"
 proof -
   from in_Ints have "a \<in> range of_int"
     unfolding Ints_def [symmetric] .
   then obtain z where a: "a = of_int z" ..
   with a have "1 + a + a < 0 \<longleftrightarrow> of_int (1 + z + z) < (of_int 0 :: 'a)"
     by simp
   also have "\<dots> \<longleftrightarrow> z < 0"
     by (simp only: of_int_less_iff odd_less_0_iff)
   also have "\<dots> \<longleftrightarrow> a < 0"
     by (simp add: a)
   finally show ?thesis .
 qed
 
 
 subsection \<open>\<^term>\<open>sum\<close> and \<^term>\<open>prod\<close>\<close>
 
 context semiring_1
 begin
 
 lemma of_nat_sum [simp]:
   "of_nat (sum f A) = (\<Sum>x\<in>A. of_nat (f x))"
   by (induction A rule: infinite_finite_induct) auto
 
 end
 
 context ring_1
 begin
 
 lemma of_int_sum [simp]:
   "of_int (sum f A) = (\<Sum>x\<in>A. of_int (f x))"
   by (induction A rule: infinite_finite_induct) auto
 
 end
 
 context comm_semiring_1
 begin
 
 lemma of_nat_prod [simp]:
   "of_nat (prod f A) = (\<Prod>x\<in>A. of_nat (f x))"
   by (induction A rule: infinite_finite_induct) auto
 
 end
 
 context comm_ring_1
 begin
 
 lemma of_int_prod [simp]:
   "of_int (prod f A) = (\<Prod>x\<in>A. of_int (f x))"
   by (induction A rule: infinite_finite_induct) auto
 
 end
 
 
 subsection \<open>Setting up simplification procedures\<close>
 
 ML_file \<open>Tools/int_arith.ML\<close>
 
 declaration \<open>K (
   Lin_Arith.add_discrete_type \<^type_name>\<open>Int.int\<close>
   #> Lin_Arith.add_lessD @{thm zless_imp_add1_zle}
   #> Lin_Arith.add_inj_thms @{thms of_nat_le_iff [THEN iffD2] of_nat_eq_iff [THEN iffD2]}
   #> Lin_Arith.add_inj_const (\<^const_name>\<open>of_nat\<close>, \<^typ>\<open>nat \<Rightarrow> int\<close>)
   #> Lin_Arith.add_simps
       @{thms of_int_0 of_int_1 of_int_add of_int_mult of_int_numeral of_int_neg_numeral nat_0 nat_1 diff_nat_numeral nat_numeral
       neg_less_iff_less
       True_implies_equals
       distrib_left [where a = "numeral v" for v]
       distrib_left [where a = "- numeral v" for v]
       div_by_1 div_0
       times_divide_eq_right times_divide_eq_left
       minus_divide_left [THEN sym] minus_divide_right [THEN sym]
       add_divide_distrib diff_divide_distrib
       of_int_minus of_int_diff
       of_int_of_nat_eq}
   #> Lin_Arith.add_simprocs [Int_Arith.zero_one_idom_simproc]
 )\<close>
 
 simproc_setup fast_arith
   ("(m::'a::linordered_idom) < n" |
     "(m::'a::linordered_idom) \<le> n" |
     "(m::'a::linordered_idom) = n") =
   \<open>K Lin_Arith.simproc\<close>
 
 
 subsection\<open>More Inequality Reasoning\<close>
 
 lemma zless_add1_eq: "w < z + 1 \<longleftrightarrow> w < z \<or> w = z"
   for w z :: int
   by arith
 
 lemma add1_zle_eq: "w + 1 \<le> z \<longleftrightarrow> w < z"
   for w z :: int
   by arith
 
 lemma zle_diff1_eq [simp]: "w \<le> z - 1 \<longleftrightarrow> w < z"
   for w z :: int
   by arith
 
 lemma zle_add1_eq_le [simp]: "w < z + 1 \<longleftrightarrow> w \<le> z"
   for w z :: int
   by arith
 
 lemma int_one_le_iff_zero_less: "1 \<le> z \<longleftrightarrow> 0 < z"
   for z :: int
   by arith
 
 lemma Ints_nonzero_abs_ge1:
   fixes x:: "'a :: linordered_idom"
     assumes "x \<in> Ints" "x \<noteq> 0"
     shows "1 \<le> abs x"
 proof (rule Ints_cases [OF \<open>x \<in> Ints\<close>])
   fix z::int
   assume "x = of_int z"
-    with \<open>x \<noteq> 0\<close> 
+  with \<open>x \<noteq> 0\<close>
   show "1 \<le> \<bar>x\<bar>"
-    apply (auto simp add: abs_if)
+    apply (auto simp: abs_if)
     by (metis diff_0 of_int_1 of_int_le_iff of_int_minus zle_diff1_eq)
 qed
   
 lemma Ints_nonzero_abs_less1:
   fixes x:: "'a :: linordered_idom"
   shows "\<lbrakk>x \<in> Ints; abs x < 1\<rbrakk> \<Longrightarrow> x = 0"
     using Ints_nonzero_abs_ge1 [of x] by auto
 
 lemma Ints_eq_abs_less1:
   fixes x:: "'a :: linordered_idom"
   shows "\<lbrakk>x \<in> Ints; y \<in> Ints\<rbrakk> \<Longrightarrow> x = y \<longleftrightarrow> abs (x-y) < 1"
   using eq_iff_diff_eq_0 by (fastforce intro: Ints_nonzero_abs_less1)
  
 
 subsection \<open>The functions \<^term>\<open>nat\<close> and \<^term>\<open>int\<close>\<close>
 
 text \<open>Simplify the term \<^term>\<open>w + - z\<close>.\<close>
 
 lemma one_less_nat_eq [simp]: "Suc 0 < nat z \<longleftrightarrow> 1 < z"
   using zless_nat_conj [of 1 z] by auto
 
 lemma int_eq_iff_numeral [simp]:
   "int m = numeral v \<longleftrightarrow> m = numeral v"
   by (simp add: int_eq_iff)
 
 lemma nat_abs_int_diff:
   "nat \<bar>int a - int b\<bar> = (if a \<le> b then b - a else a - b)"
   by auto
 
 lemma nat_int_add: "nat (int a + int b) = a + b"
   by auto
 
 context ring_1
 begin
 
 lemma of_int_of_nat [nitpick_simp]:
   "of_int k = (if k < 0 then - of_nat (nat (- k)) else of_nat (nat k))"
 proof (cases "k < 0")
   case True
   then have "0 \<le> - k" by simp
   then have "of_nat (nat (- k)) = of_int (- k)" by (rule of_nat_nat)
   with True show ?thesis by simp
 next
   case False
   then show ?thesis by (simp add: not_less)
 qed
 
 end
 
 lemma transfer_rule_of_int:
   includes lifting_syntax
   fixes R :: "'a::ring_1 \<Rightarrow> 'b::ring_1 \<Rightarrow> bool"
   assumes [transfer_rule]: "R 0 0" "R 1 1"
     "(R ===> R ===> R) (+) (+)"
     "(R ===> R) uminus uminus"
   shows "((=) ===> R) of_int of_int"
 proof -
   note assms
   note transfer_rule_of_nat [transfer_rule]
   have [transfer_rule]: "((=) ===> R) of_nat of_nat"
     by transfer_prover
   show ?thesis
     by (unfold of_int_of_nat [abs_def]) transfer_prover
 qed
 
 lemma nat_mult_distrib:
   fixes z z' :: int
   assumes "0 \<le> z"
   shows "nat (z * z') = nat z * nat z'"
 proof (cases "0 \<le> z'")
   case False
   with assms have "z * z' \<le> 0"
     by (simp add: not_le mult_le_0_iff)
   then have "nat (z * z') = 0" by simp
   moreover from False have "nat z' = 0" by simp
   ultimately show ?thesis by simp
 next
   case True
   with assms have ge_0: "z * z' \<ge> 0" by (simp add: zero_le_mult_iff)
   show ?thesis
     by (rule injD [of "of_nat :: nat \<Rightarrow> int", OF inj_of_nat])
       (simp only: of_nat_mult of_nat_nat [OF True]
          of_nat_nat [OF assms] of_nat_nat [OF ge_0], simp)
 qed
 
 lemma nat_mult_distrib_neg:
   assumes "z \<le> (0::int)" shows "nat (z * z') = nat (- z) * nat (- z')" (is "?L = ?R")
 proof -
   have "?L = nat (- z * - z')"
     using assms by auto
   also have "... = ?R"
     by (rule nat_mult_distrib) (use assms in auto)
   finally show ?thesis .
 qed
 
 lemma nat_abs_mult_distrib: "nat \<bar>w * z\<bar> = nat \<bar>w\<bar> * nat \<bar>z\<bar>"
   by (cases "z = 0 \<or> w = 0")
     (auto simp add: abs_if nat_mult_distrib [symmetric]
       nat_mult_distrib_neg [symmetric] mult_less_0_iff)
 
 lemma int_in_range_abs [simp]: "int n \<in> range abs"
 proof (rule range_eqI)
   show "int n = \<bar>int n\<bar>" by simp
 qed
 
 lemma range_abs_Nats [simp]: "range abs = (\<nat> :: int set)"
 proof -
   have "\<bar>k\<bar> \<in> \<nat>" for k :: int
     by (cases k) simp_all
   moreover have "k \<in> range abs" if "k \<in> \<nat>" for k :: int
     using that by induct simp
   ultimately show ?thesis by blast
 qed
 
 lemma Suc_nat_eq_nat_zadd1: "0 \<le> z \<Longrightarrow> Suc (nat z) = nat (1 + z)"
   for z :: int
   by (rule sym) (simp add: nat_eq_iff)
 
 lemma diff_nat_eq_if:
   "nat z - nat z' =
     (if z' < 0 then nat z
      else
       let d = z - z'
       in if d < 0 then 0 else nat d)"
   by (simp add: Let_def nat_diff_distrib [symmetric])
 
 lemma nat_numeral_diff_1 [simp]: "numeral v - (1::nat) = nat (numeral v - 1)"
   using diff_nat_numeral [of v Num.One] by simp
 
 
 subsection \<open>Induction principles for int\<close>
 
 text \<open>Well-founded segments of the integers.\<close>
 
 definition int_ge_less_than :: "int \<Rightarrow> (int \<times> int) set"
   where "int_ge_less_than d = {(z', z). d \<le> z' \<and> z' < z}"
 
 lemma wf_int_ge_less_than: "wf (int_ge_less_than d)"
 proof -
   have "int_ge_less_than d \<subseteq> measure (\<lambda>z. nat (z - d))"
     by (auto simp add: int_ge_less_than_def)
   then show ?thesis
     by (rule wf_subset [OF wf_measure])
 qed
 
 text \<open>
   This variant looks odd, but is typical of the relations suggested
   by RankFinder.\<close>
 
 definition int_ge_less_than2 :: "int \<Rightarrow> (int \<times> int) set"
   where "int_ge_less_than2 d = {(z',z). d \<le> z \<and> z' < z}"
 
 lemma wf_int_ge_less_than2: "wf (int_ge_less_than2 d)"
 proof -
   have "int_ge_less_than2 d \<subseteq> measure (\<lambda>z. nat (1 + z - d))"
     by (auto simp add: int_ge_less_than2_def)
   then show ?thesis
     by (rule wf_subset [OF wf_measure])
 qed
 
 (* `set:int': dummy construction *)
 theorem int_ge_induct [case_names base step, induct set: int]:
   fixes i :: int
   assumes ge: "k \<le> i"
     and base: "P k"
     and step: "\<And>i. k \<le> i \<Longrightarrow> P i \<Longrightarrow> P (i + 1)"
   shows "P i"
 proof -
   have "\<And>i::int. n = nat (i - k) \<Longrightarrow> k \<le> i \<Longrightarrow> P i" for n
   proof (induct n)
     case 0
     then have "i = k" by arith
     with base show "P i" by simp
   next
     case (Suc n)
     then have "n = nat ((i - 1) - k)" by arith
     moreover have k: "k \<le> i - 1" using Suc.prems by arith
     ultimately have "P (i - 1)" by (rule Suc.hyps)
     from step [OF k this] show ?case by simp
   qed
   with ge show ?thesis by fast
 qed
 
 (* `set:int': dummy construction *)
 theorem int_gr_induct [case_names base step, induct set: int]:
   fixes i k :: int
   assumes "k < i" "P (k + 1)" "\<And>i. k < i \<Longrightarrow> P i \<Longrightarrow> P (i + 1)"
   shows "P i"
 proof -
   have "k+1 \<le> i"
     using assms by auto
   then show ?thesis
     by (induction i rule: int_ge_induct) (auto simp: assms)
 qed
 
 theorem int_le_induct [consumes 1, case_names base step]:
   fixes i k :: int
   assumes le: "i \<le> k"
     and base: "P k"
     and step: "\<And>i. i \<le> k \<Longrightarrow> P i \<Longrightarrow> P (i - 1)"
   shows "P i"
 proof -
   have "\<And>i::int. n = nat(k-i) \<Longrightarrow> i \<le> k \<Longrightarrow> P i" for n
   proof (induct n)
     case 0
     then have "i = k" by arith
     with base show "P i" by simp
   next
     case (Suc n)
     then have "n = nat (k - (i + 1))" by arith
     moreover have k: "i + 1 \<le> k" using Suc.prems by arith
     ultimately have "P (i + 1)" by (rule Suc.hyps)
     from step[OF k this] show ?case by simp
   qed
   with le show ?thesis by fast
 qed
 
 theorem int_less_induct [consumes 1, case_names base step]:
   fixes i k :: int
   assumes "i < k" "P (k - 1)" "\<And>i. i < k \<Longrightarrow> P i \<Longrightarrow> P (i - 1)"
   shows "P i"
 proof -
   have "i \<le> k-1"
     using assms by auto
   then show ?thesis
     by (induction i rule: int_le_induct) (auto simp: assms)
 qed
 
 theorem int_induct [case_names base step1 step2]:
   fixes k :: int
   assumes base: "P k"
     and step1: "\<And>i. k \<le> i \<Longrightarrow> P i \<Longrightarrow> P (i + 1)"
     and step2: "\<And>i. k \<ge> i \<Longrightarrow> P i \<Longrightarrow> P (i - 1)"
   shows "P i"
 proof -
   have "i \<le> k \<or> i \<ge> k" by arith
   then show ?thesis
   proof
     assume "i \<ge> k"
     then show ?thesis
       using base by (rule int_ge_induct) (fact step1)
   next
     assume "i \<le> k"
     then show ?thesis
       using base by (rule int_le_induct) (fact step2)
   qed
 qed
 
 
 subsection \<open>Intermediate value theorems\<close>
 
 lemma nat_ivt_aux: 
   "\<lbrakk>\<forall>i<n. \<bar>f (Suc i) - f i\<bar> \<le> 1; f 0 \<le> k; k \<le> f n\<rbrakk> \<Longrightarrow> \<exists>i \<le> n. f i = k"
   for m n :: nat and k :: int
 proof (induct n)
   case (Suc n)
   show ?case
   proof (cases "k = f (Suc n)")
     case False
     with Suc have "k \<le> f n"
       by auto
     with Suc show ?thesis
       by (auto simp add: abs_if split: if_split_asm intro: le_SucI)
   qed (use Suc in auto)
 qed auto
 
 lemma nat_intermed_int_val:
   fixes m n :: nat and k :: int
   assumes "\<forall>i. m \<le> i \<and> i < n \<longrightarrow> \<bar>f (Suc i) - f i\<bar> \<le> 1" "m \<le> n" "f m \<le> k" "k \<le> f n"
   shows "\<exists>i. m \<le> i \<and> i \<le> n \<and> f i = k"
 proof -
   obtain i where "i \<le> n - m" "k = f (m + i)"
     using nat_ivt_aux [of "n - m" "f \<circ> plus m" k] assms by auto
   with assms show ?thesis
-    by (rule_tac x = "m + i" in exI) auto
+    using exI[of _ "m + i"] by auto
 qed
 
 lemma nat0_intermed_int_val:
   "\<exists>i\<le>n. f i = k"
   if "\<forall>i<n. \<bar>f (i + 1) - f i\<bar> \<le> 1" "f 0 \<le> k" "k \<le> f n"
   for n :: nat and k :: int
   using nat_intermed_int_val [of 0 n f k] that by auto
 
 
 subsection \<open>Products and 1, by T. M. Rasmussen\<close>
 
 lemma abs_zmult_eq_1:
   fixes m n :: int
   assumes mn: "\<bar>m * n\<bar> = 1"
   shows "\<bar>m\<bar> = 1"
 proof -
   from mn have 0: "m \<noteq> 0" "n \<noteq> 0" by auto
   have "\<not> 2 \<le> \<bar>m\<bar>"
   proof
     assume "2 \<le> \<bar>m\<bar>"
     then have "2 * \<bar>n\<bar> \<le> \<bar>m\<bar> * \<bar>n\<bar>" by (simp add: mult_mono 0)
     also have "\<dots> = \<bar>m * n\<bar>" by (simp add: abs_mult)
     also from mn have "\<dots> = 1" by simp
     finally have "2 * \<bar>n\<bar> \<le> 1" .
     with 0 show "False" by arith
   qed
   with 0 show ?thesis by auto
 qed
 
 lemma pos_zmult_eq_1_iff_lemma: "m * n = 1 \<Longrightarrow> m = 1 \<or> m = - 1"
   for m n :: int
   using abs_zmult_eq_1 [of m n] by arith
 
 lemma pos_zmult_eq_1_iff:
   fixes m n :: int
   assumes "0 < m"
   shows "m * n = 1 \<longleftrightarrow> m = 1 \<and> n = 1"
 proof -
   from assms have "m * n = 1 \<Longrightarrow> m = 1"
     by (auto dest: pos_zmult_eq_1_iff_lemma)
   then show ?thesis
     by (auto dest: pos_zmult_eq_1_iff_lemma)
 qed
 
 lemma zmult_eq_1_iff: "m * n = 1 \<longleftrightarrow> (m = 1 \<and> n = 1) \<or> (m = - 1 \<and> n = - 1)" (is "?L = ?R")
   for m n :: int
 proof
   assume L: ?L show ?R
     using pos_zmult_eq_1_iff_lemma [OF L] L by force
 qed auto
 
 lemma infinite_UNIV_int [simp]: "\<not> finite (UNIV::int set)"
 proof
   assume "finite (UNIV::int set)"
   moreover have "inj (\<lambda>i::int. 2 * i)"
     by (rule injI) simp
   ultimately have "surj (\<lambda>i::int. 2 * i)"
     by (rule finite_UNIV_inj_surj)
   then obtain i :: int where "1 = 2 * i" by (rule surjE)
   then show False by (simp add: pos_zmult_eq_1_iff)
 qed
 
 
 subsection \<open>The divides relation\<close>
 
 lemma zdvd_antisym_nonneg: "0 \<le> m \<Longrightarrow> 0 \<le> n \<Longrightarrow> m dvd n \<Longrightarrow> n dvd m \<Longrightarrow> m = n"
   for m n :: int
   by (auto simp add: dvd_def mult.assoc zero_le_mult_iff zmult_eq_1_iff)
 
 lemma zdvd_antisym_abs:
   fixes a b :: int
   assumes "a dvd b" and "b dvd a"
   shows "\<bar>a\<bar> = \<bar>b\<bar>"
 proof (cases "a = 0")
   case True
   with assms show ?thesis by simp
 next
   case False
   from \<open>a dvd b\<close> obtain k where k: "b = a * k"
     unfolding dvd_def by blast
   from \<open>b dvd a\<close> obtain k' where k': "a = b * k'"
     unfolding dvd_def by blast
   from k k' have "a = a * k * k'" by simp
   with mult_cancel_left1[where c="a" and b="k*k'"] have kk': "k * k' = 1"
     using \<open>a \<noteq> 0\<close> by (simp add: mult.assoc)
   then have "k = 1 \<and> k' = 1 \<or> k = -1 \<and> k' = -1"
     by (simp add: zmult_eq_1_iff)
   with k k' show ?thesis by auto
 qed
 
 lemma zdvd_zdiffD: "k dvd m - n \<Longrightarrow> k dvd n \<Longrightarrow> k dvd m"
   for k m n :: int
   using dvd_add_right_iff [of k "- n" m] by simp
 
 lemma zdvd_reduce: "k dvd n + k * m \<longleftrightarrow> k dvd n"
   for k m n :: int
   using dvd_add_times_triv_right_iff [of k n m] by (simp add: ac_simps)
 
 lemma dvd_imp_le_int:
   fixes d i :: int
   assumes "i \<noteq> 0" and "d dvd i"
   shows "\<bar>d\<bar> \<le> \<bar>i\<bar>"
 proof -
   from \<open>d dvd i\<close> obtain k where "i = d * k" ..
   with \<open>i \<noteq> 0\<close> have "k \<noteq> 0" by auto
   then have "1 \<le> \<bar>k\<bar>" and "0 \<le> \<bar>d\<bar>" by auto
   then have "\<bar>d\<bar> * 1 \<le> \<bar>d\<bar> * \<bar>k\<bar>" by (rule mult_left_mono)
   with \<open>i = d * k\<close> show ?thesis by (simp add: abs_mult)
 qed
 
 lemma zdvd_not_zless:
   fixes m n :: int
   assumes "0 < m" and "m < n"
   shows "\<not> n dvd m"
 proof
   from assms have "0 < n" by auto
   assume "n dvd m" then obtain k where k: "m = n * k" ..
   with \<open>0 < m\<close> have "0 < n * k" by auto
   with \<open>0 < n\<close> have "0 < k" by (simp add: zero_less_mult_iff)
   with k \<open>0 < n\<close> \<open>m < n\<close> have "n * k < n * 1" by simp
   with \<open>0 < n\<close> \<open>0 < k\<close> show False unfolding mult_less_cancel_left by auto
 qed
 
 lemma zdvd_mult_cancel:
   fixes k m n :: int
   assumes d: "k * m dvd k * n"
     and "k \<noteq> 0"
   shows "m dvd n"
 proof -
   from d obtain h where h: "k * n = k * m * h"
     unfolding dvd_def by blast
   have "n = m * h"
   proof (rule ccontr)
     assume "\<not> ?thesis"
     with \<open>k \<noteq> 0\<close> have "k * n \<noteq> k * (m * h)" by simp
     with h show False
       by (simp add: mult.assoc)
   qed
   then show ?thesis by simp
 qed
 
 lemma int_dvd_int_iff [simp]:
   "int m dvd int n \<longleftrightarrow> m dvd n"
 proof -
   have "m dvd n" if "int n = int m * k" for k
   proof (cases k)
     case (nonneg q)
     with that have "n = m * q"
       by (simp del: of_nat_mult add: of_nat_mult [symmetric])
     then show ?thesis ..
   next
     case (neg q)
     with that have "int n = int m * (- int (Suc q))"
       by simp
     also have "\<dots> = - (int m * int (Suc q))"
       by (simp only: mult_minus_right)
     also have "\<dots> = - int (m * Suc q)"
       by (simp only: of_nat_mult [symmetric])
     finally have "- int (m * Suc q) = int n" ..
     then show ?thesis
       by (simp only: negative_eq_positive) auto
   qed
   then show ?thesis by (auto simp add: dvd_def)
 qed
 
 lemma dvd_nat_abs_iff [simp]:
   "n dvd nat \<bar>k\<bar> \<longleftrightarrow> int n dvd k"
 proof -
   have "n dvd nat \<bar>k\<bar> \<longleftrightarrow> int n dvd int (nat \<bar>k\<bar>)"
     by (simp only: int_dvd_int_iff)
   then show ?thesis
     by simp
 qed
 
 lemma nat_abs_dvd_iff [simp]:
   "nat \<bar>k\<bar> dvd n \<longleftrightarrow> k dvd int n"
 proof -
   have "nat \<bar>k\<bar> dvd n \<longleftrightarrow> int (nat \<bar>k\<bar>) dvd int n"
     by (simp only: int_dvd_int_iff)
   then show ?thesis
     by simp
 qed
 
 lemma zdvd1_eq [simp]: "x dvd 1 \<longleftrightarrow> \<bar>x\<bar> = 1" (is "?lhs \<longleftrightarrow> ?rhs")
   for x :: int
 proof
   assume ?lhs
   then have "nat \<bar>x\<bar> dvd nat \<bar>1\<bar>"
     by (simp only: nat_abs_dvd_iff) simp
   then have "nat \<bar>x\<bar> = 1"
     by simp
   then show ?rhs
     by (cases "x < 0") simp_all
 next
   assume ?rhs
   then have "x = 1 \<or> x = - 1"
     by auto
   then show ?lhs
     by (auto intro: dvdI)
 qed
 
 lemma zdvd_mult_cancel1:
   fixes m :: int
   assumes mp: "m \<noteq> 0"
   shows "m * n dvd m \<longleftrightarrow> \<bar>n\<bar> = 1"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs
     by (cases "n > 0") (auto simp add: minus_equation_iff)
 next
   assume ?lhs
   then have "m * n dvd m * 1" by simp
   from zdvd_mult_cancel[OF this mp] show ?rhs
     by (simp only: zdvd1_eq)
 qed
 
 lemma nat_dvd_iff: "nat z dvd m \<longleftrightarrow> (if 0 \<le> z then z dvd int m else m = 0)"
   using nat_abs_dvd_iff [of z m] by (cases "z \<ge> 0") auto
 
 lemma eq_nat_nat_iff: "0 \<le> z \<Longrightarrow> 0 \<le> z' \<Longrightarrow> nat z = nat z' \<longleftrightarrow> z = z'"
   by (auto elim: nonneg_int_cases)
 
 lemma nat_power_eq: "0 \<le> z \<Longrightarrow> nat (z ^ n) = nat z ^ n"
   by (induct n) (simp_all add: nat_mult_distrib)
 
 lemma numeral_power_eq_nat_cancel_iff [simp]:
   "numeral x ^ n = nat y \<longleftrightarrow> numeral x ^ n = y"
   using nat_eq_iff2 by auto
 
 lemma nat_eq_numeral_power_cancel_iff [simp]:
   "nat y = numeral x ^ n \<longleftrightarrow> y = numeral x ^ n"
   using numeral_power_eq_nat_cancel_iff[of x n y]
   by (metis (mono_tags))
 
 lemma numeral_power_le_nat_cancel_iff [simp]:
   "numeral x ^ n \<le> nat a \<longleftrightarrow> numeral x ^ n \<le> a"
   using nat_le_eq_zle[of "numeral x ^ n" a]
   by (auto simp: nat_power_eq)
 
 lemma nat_le_numeral_power_cancel_iff [simp]:
   "nat a \<le> numeral x ^ n \<longleftrightarrow> a \<le> numeral x ^ n"
   by (simp add: nat_le_iff)
 
 lemma numeral_power_less_nat_cancel_iff [simp]:
   "numeral x ^ n < nat a \<longleftrightarrow> numeral x ^ n < a"
   using nat_less_eq_zless[of "numeral x ^ n" a]
   by (auto simp: nat_power_eq)
 
 lemma nat_less_numeral_power_cancel_iff [simp]:
   "nat a < numeral x ^ n \<longleftrightarrow> a < numeral x ^ n"
   using nat_less_eq_zless[of a "numeral x ^ n"]
   by (cases "a < 0") (auto simp: nat_power_eq less_le_trans[where y=0])
 
 lemma zdvd_imp_le: "z \<le> n" if "z dvd n" "0 < n" for n z :: int
 proof (cases n)
   case (nonneg n)
   show ?thesis
     by (cases z) (use nonneg dvd_imp_le that in auto)
 qed (use that in auto)
 
 lemma zdvd_period:
   fixes a d :: int
   assumes "a dvd d"
   shows "a dvd (x + t) \<longleftrightarrow> a dvd ((x + c * d) + t)"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof -
   from assms have "a dvd (x + t) \<longleftrightarrow> a dvd ((x + t) + c * d)"
     by (simp add: dvd_add_left_iff)
   then show ?thesis
     by (simp add: ac_simps)
 qed
 
 
 subsection \<open>Powers with integer exponents\<close>
 
 text \<open>
   The following allows writing powers with an integer exponent. While the type signature
   is very generic, most theorems will assume that the underlying type is a division ring or
   a field.
 
   The notation `powi' is inspired by the `powr' notation for real/complex exponentiation.
 \<close>
 definition power_int :: "'a :: {inverse, power} \<Rightarrow> int \<Rightarrow> 'a" (infixr "powi" 80) where
   "power_int x n = (if n \<ge> 0 then x ^ nat n else inverse x ^ (nat (-n)))"
 
 lemma power_int_0_right [simp]: "power_int x 0 = 1"
   and power_int_1_right [simp]:
         "power_int (y :: 'a :: {power, inverse, monoid_mult}) 1 = y"
   and power_int_minus1_right [simp]:
         "power_int (y :: 'a :: {power, inverse, monoid_mult}) (-1) = inverse y"
   by (simp_all add: power_int_def)
 
 lemma power_int_of_nat [simp]: "power_int x (int n) = x ^ n"
   by (simp add: power_int_def)
 
 lemma power_int_numeral [simp]: "power_int x (numeral n) = x ^ numeral n"
   by (simp add: power_int_def)
 
 lemma int_cases4 [case_names nonneg neg]:
   fixes m :: int
   obtains n where "m = int n" | n where "n > 0" "m = -int n"
 proof (cases "m \<ge> 0")
   case True
   thus ?thesis using that(1)[of "nat m"] by auto
 next
   case False
   thus ?thesis using that(2)[of "nat (-m)"] by auto
 qed
 
 
 context
   assumes "SORT_CONSTRAINT('a::division_ring)"
 begin
 
 lemma power_int_minus: "power_int (x::'a) (-n) = inverse (power_int x n)"
   by (auto simp: power_int_def power_inverse)
 
 lemma power_int_eq_0_iff [simp]: "power_int (x::'a) n = 0 \<longleftrightarrow> x = 0 \<and> n \<noteq> 0"
   by (auto simp: power_int_def)
 
 lemma power_int_0_left_If: "power_int (0 :: 'a) m = (if m = 0 then 1 else 0)"
   by (auto simp: power_int_def)
 
 lemma power_int_0_left [simp]: "m \<noteq> 0 \<Longrightarrow> power_int (0 :: 'a) m = 0"
   by (simp add: power_int_0_left_If)
 
 lemma power_int_1_left [simp]: "power_int 1 n = (1 :: 'a :: division_ring)"
   by (auto simp: power_int_def) 
 
 lemma power_diff_conv_inverse: "x \<noteq> 0 \<Longrightarrow> m \<le> n \<Longrightarrow> (x :: 'a) ^ (n - m) = x ^ n * inverse x ^ m"
   by (simp add: field_simps flip: power_add)
 
 lemma power_mult_inverse_distrib: "x ^ m * inverse (x :: 'a) = inverse x * x ^ m"
 proof (cases "x = 0")
   case [simp]: False
   show ?thesis
   proof (cases m)
     case (Suc m')
     have "x ^ Suc m' * inverse x = x ^ m'"
       by (subst power_Suc2) (auto simp: mult.assoc)
     also have "\<dots> = inverse x * x ^ Suc m'"
       by (subst power_Suc) (auto simp: mult.assoc [symmetric])
     finally show ?thesis using Suc by simp
   qed auto
 qed auto
 
 lemma power_mult_power_inverse_commute:
   "x ^ m * inverse (x :: 'a) ^ n = inverse x ^ n * x ^ m"
 proof (induction n)
   case (Suc n)
   have "x ^ m * inverse x ^ Suc n = (x ^ m * inverse x ^ n) * inverse x"
     by (simp only: power_Suc2 mult.assoc)
   also have "x ^ m * inverse x ^ n = inverse x ^ n * x ^ m"
     by (rule Suc)
   also have "\<dots> * inverse x = (inverse x ^ n * inverse x) * x ^ m"
     by (simp add: mult.assoc power_mult_inverse_distrib)
   also have "\<dots> = inverse x ^ (Suc n) * x ^ m"
     by (simp only: power_Suc2)
   finally show ?case .
 qed auto
 
 lemma power_int_add:
   assumes "x \<noteq> 0 \<or> m + n \<noteq> 0"
   shows   "power_int (x::'a) (m + n) = power_int x m * power_int x n"
 proof (cases "x = 0")
   case True
   thus ?thesis using assms by (auto simp: power_int_0_left_If)
 next
   case [simp]: False
   show ?thesis
   proof (cases m n rule: int_cases4[case_product int_cases4])
     case (nonneg_nonneg a b)
     thus ?thesis
       by (auto simp: power_int_def nat_add_distrib power_add)
   next
     case (nonneg_neg a b)
     thus ?thesis
       by (auto simp: power_int_def nat_diff_distrib not_le power_diff_conv_inverse
                      power_mult_power_inverse_commute)
   next
     case (neg_nonneg a b)
     thus ?thesis
       by (auto simp: power_int_def nat_diff_distrib not_le power_diff_conv_inverse
                      power_mult_power_inverse_commute)    
   next
     case (neg_neg a b)
     thus ?thesis
       by (auto simp: power_int_def nat_add_distrib add.commute simp flip: power_add)
   qed
 qed
 
 lemma power_int_add_1:
   assumes "x \<noteq> 0 \<or> m \<noteq> -1"
   shows   "power_int (x::'a) (m + 1) = power_int x m * x"
   using assms by (subst power_int_add) auto
 
 lemma power_int_add_1':
   assumes "x \<noteq> 0 \<or> m \<noteq> -1"
   shows   "power_int (x::'a) (m + 1) = x * power_int x m"
   using assms by (subst add.commute, subst power_int_add) auto
 
 lemma power_int_commutes: "power_int (x :: 'a) n * x = x * power_int x n"
   by (cases "x = 0") (auto simp flip: power_int_add_1 power_int_add_1')
 
 lemma power_int_inverse [field_simps, field_split_simps, divide_simps]:
   "power_int (inverse (x :: 'a)) n = inverse (power_int x n)"
   by (auto simp: power_int_def power_inverse)
 
 lemma power_int_mult: "power_int (x :: 'a) (m * n) = power_int (power_int x m) n"
   by (auto simp: power_int_def zero_le_mult_iff simp flip: power_mult power_inverse nat_mult_distrib)
 
 end
 
 context
   assumes "SORT_CONSTRAINT('a::field)"
 begin
 
 lemma power_int_diff:
   assumes "x \<noteq> 0 \<or> m \<noteq> n"
   shows   "power_int (x::'a) (m - n) = power_int x m / power_int x n"
   using power_int_add[of x m "-n"] assms by (auto simp: field_simps power_int_minus)
 
 lemma power_int_minus_mult: "x \<noteq> 0 \<or> n \<noteq> 0 \<Longrightarrow> power_int (x :: 'a) (n - 1) * x = power_int x n"
   by (auto simp flip: power_int_add_1)  
 
 lemma power_int_mult_distrib: "power_int (x * y :: 'a) m = power_int x m * power_int y m"
   by (auto simp: power_int_def power_mult_distrib)
 
 lemmas power_int_mult_distrib_numeral1 = power_int_mult_distrib [where x = "numeral w" for w, simp]
 lemmas power_int_mult_distrib_numeral2 = power_int_mult_distrib [where y = "numeral w" for w, simp]
 
 lemma power_int_divide_distrib: "power_int (x / y :: 'a) m = power_int x m / power_int y m"
   using power_int_mult_distrib[of x "inverse y" m] unfolding power_int_inverse
   by (simp add: field_simps)
 
 end
 
 
 lemma power_int_add_numeral [simp]:
   "power_int x (numeral m) * power_int x (numeral n) = power_int x (numeral (m + n))"
   for x :: "'a :: division_ring"
   by (simp add: power_int_add [symmetric])
 
 lemma power_int_add_numeral2 [simp]:
   "power_int x (numeral m) * (power_int x (numeral n) * b) = power_int x (numeral (m + n)) * b"
   for x :: "'a :: division_ring"
   by (simp add: mult.assoc [symmetric])
 
 lemma power_int_mult_numeral [simp]:
   "power_int (power_int x (numeral m)) (numeral n) = power_int x (numeral (m * n))"
   for x :: "'a :: division_ring"
   by (simp only: numeral_mult power_int_mult)
   
 lemma power_int_not_zero: "(x :: 'a :: division_ring) \<noteq> 0 \<or> n = 0 \<Longrightarrow> power_int x n \<noteq> 0"
   by (subst power_int_eq_0_iff) auto
 
 lemma power_int_one_over [field_simps, field_split_simps, divide_simps]:
   "power_int (1 / x :: 'a :: division_ring) n = 1 / power_int x n"
   using power_int_inverse[of x] by (simp add: divide_inverse)
 
 
 context
   assumes "SORT_CONSTRAINT('a :: linordered_field)"
 begin
 
 lemma power_int_numeral_neg_numeral [simp]:
   "power_int (numeral m) (-numeral n) = (inverse (numeral (Num.pow m n)) :: 'a)"
   by (simp add: power_int_minus)
 
 lemma zero_less_power_int [simp]: "0 < (x :: 'a) \<Longrightarrow> 0 < power_int x n"
   by (auto simp: power_int_def)
 
 lemma zero_le_power_int [simp]: "0 \<le> (x :: 'a) \<Longrightarrow> 0 \<le> power_int x n"
   by (auto simp: power_int_def)
 
 lemma power_int_mono: "(x :: 'a) \<le> y \<Longrightarrow> n \<ge> 0 \<Longrightarrow> 0 \<le> x \<Longrightarrow> power_int x n \<le> power_int y n"
   by (cases n rule: int_cases4) (auto intro: power_mono)
 
 lemma one_le_power_int [simp]: "1 \<le> (x :: 'a) \<Longrightarrow> n \<ge> 0 \<Longrightarrow> 1 \<le> power_int x n"
   using power_int_mono [of 1 x n] by simp
 
 lemma power_int_le_one: "0 \<le> (x :: 'a) \<Longrightarrow> n \<ge> 0 \<Longrightarrow> x \<le> 1 \<Longrightarrow> power_int x n \<le> 1"
   using power_int_mono [of x 1 n] by simp
 
 lemma power_int_le_imp_le_exp:
   assumes gt1: "1 < (x :: 'a :: linordered_field)"
   assumes "power_int x m \<le> power_int x n" "n \<ge> 0"
   shows   "m \<le> n"
 proof (cases "m < 0")
   case True
   with \<open>n \<ge> 0\<close> show ?thesis by simp
 next
   case False
   with assms have "x ^ nat m \<le> x ^ nat n"
     by (simp add: power_int_def)
   from gt1 and this show ?thesis
     using False \<open>n \<ge> 0\<close> by auto
 qed
 
 lemma power_int_le_imp_less_exp:
   assumes gt1: "1 < (x :: 'a :: linordered_field)"
   assumes "power_int x m < power_int x n" "n \<ge> 0"
   shows   "m < n"
 proof (cases "m < 0")
   case True
   with \<open>n \<ge> 0\<close> show ?thesis by simp
 next
   case False
   with assms have "x ^ nat m < x ^ nat n"
     by (simp add: power_int_def)
   from gt1 and this show ?thesis
     using False \<open>n \<ge> 0\<close> by auto
 qed
 
 lemma power_int_strict_mono:
   "(a :: 'a :: linordered_field) < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> power_int a n < power_int b n"
   by (auto simp: power_int_def intro!: power_strict_mono)
 
 lemma power_int_mono_iff [simp]:
   fixes a b :: "'a :: linordered_field"
   shows "\<lbrakk>a \<ge> 0; b \<ge> 0; n > 0\<rbrakk> \<Longrightarrow> power_int a n \<le> power_int b n \<longleftrightarrow> a \<le> b"
   by (auto simp: power_int_def intro!: power_strict_mono)
 
 lemma power_int_strict_increasing:
   fixes a :: "'a :: linordered_field"
   assumes "n < N" "1 < a"
   shows   "power_int a N > power_int a n"
 proof -
   have *: "a ^ nat (N - n) > a ^ 0"
     using assms by (intro power_strict_increasing) auto
   have "power_int a N = power_int a n * power_int a (N - n)"
     using assms by (simp flip: power_int_add)
   also have "\<dots> > power_int a n * 1"
     using assms *
     by (intro mult_strict_left_mono zero_less_power_int) (auto simp: power_int_def)
   finally show ?thesis by simp
 qed
 
 lemma power_int_increasing:
   fixes a :: "'a :: linordered_field"
   assumes "n \<le> N" "a \<ge> 1"
   shows   "power_int a N \<ge> power_int a n"
 proof -
   have *: "a ^ nat (N - n) \<ge> a ^ 0"
     using assms by (intro power_increasing) auto
   have "power_int a N = power_int a n * power_int a (N - n)"
     using assms by (simp flip: power_int_add)
   also have "\<dots> \<ge> power_int a n * 1"
     using assms * by (intro mult_left_mono) (auto simp: power_int_def)
   finally show ?thesis by simp
 qed
 
 lemma power_int_strict_decreasing:
   fixes a :: "'a :: linordered_field"
   assumes "n < N" "0 < a" "a < 1"
   shows   "power_int a N < power_int a n"
 proof -
   have *: "a ^ nat (N - n) < a ^ 0"
     using assms by (intro power_strict_decreasing) auto
   have "power_int a N = power_int a n * power_int a (N - n)"
     using assms by (simp flip: power_int_add)
   also have "\<dots> < power_int a n * 1"
     using assms *
     by (intro mult_strict_left_mono zero_less_power_int) (auto simp: power_int_def)
   finally show ?thesis by simp
 qed
 
 lemma power_int_decreasing:
   fixes a :: "'a :: linordered_field"
   assumes "n \<le> N" "0 \<le> a" "a \<le> 1" "a \<noteq> 0 \<or> N \<noteq> 0 \<or> n = 0"
   shows   "power_int a N \<le> power_int a n"
 proof (cases "a = 0")
   case False
   have *: "a ^ nat (N - n) \<le> a ^ 0"
     using assms by (intro power_decreasing) auto
   have "power_int a N = power_int a n * power_int a (N - n)"
     using assms False by (simp flip: power_int_add)
   also have "\<dots> \<le> power_int a n * 1"
     using assms * by (intro mult_left_mono) (auto simp: power_int_def)
   finally show ?thesis by simp
 qed (use assms in \<open>auto simp: power_int_0_left_If\<close>)
 
 lemma one_less_power_int: "1 < (a :: 'a) \<Longrightarrow> 0 < n \<Longrightarrow> 1 < power_int a n"
   using power_int_strict_increasing[of 0 n a] by simp
 
 lemma power_int_abs: "\<bar>power_int a n :: 'a\<bar> = power_int \<bar>a\<bar> n"
   by (auto simp: power_int_def power_abs)
 
 lemma power_int_sgn [simp]: "sgn (power_int a n :: 'a) = power_int (sgn a) n"
   by (auto simp: power_int_def)
 
 lemma abs_power_int_minus [simp]: "\<bar>power_int (- a) n :: 'a\<bar> = \<bar>power_int a n\<bar>"
   by (simp add: power_int_abs)
 
 lemma power_int_strict_antimono:
   assumes "(a :: 'a :: linordered_field) < b" "0 < a" "n < 0"
   shows   "power_int a n > power_int b n"
 proof -
   have "inverse (power_int a (-n)) > inverse (power_int b (-n))"
     using assms by (intro less_imp_inverse_less power_int_strict_mono zero_less_power_int) auto
   thus ?thesis by (simp add: power_int_minus)
 qed
 
 lemma power_int_antimono:
   assumes "(a :: 'a :: linordered_field) \<le> b" "0 < a" "n < 0"
   shows   "power_int a n \<ge> power_int b n"
   using power_int_strict_antimono[of a b n] assms by (cases "a = b") auto
 
 end
 
 
 subsection \<open>Finiteness of intervals\<close>
 
 lemma finite_interval_int1 [iff]: "finite {i :: int. a \<le> i \<and> i \<le> b}"
 proof (cases "a \<le> b")
   case True
   then show ?thesis
   proof (induct b rule: int_ge_induct)
     case base
     have "{i. a \<le> i \<and> i \<le> a} = {a}" by auto
     then show ?case by simp
   next
     case (step b)
     then have "{i. a \<le> i \<and> i \<le> b + 1} = {i. a \<le> i \<and> i \<le> b} \<union> {b + 1}" by auto
     with step show ?case by simp
   qed
 next
   case False
   then show ?thesis
     by (metis (lifting, no_types) Collect_empty_eq finite.emptyI order_trans)
 qed
 
 lemma finite_interval_int2 [iff]: "finite {i :: int. a \<le> i \<and> i < b}"
   by (rule rev_finite_subset[OF finite_interval_int1[of "a" "b"]]) auto
 
 lemma finite_interval_int3 [iff]: "finite {i :: int. a < i \<and> i \<le> b}"
   by (rule rev_finite_subset[OF finite_interval_int1[of "a" "b"]]) auto
 
 lemma finite_interval_int4 [iff]: "finite {i :: int. a < i \<and> i < b}"
   by (rule rev_finite_subset[OF finite_interval_int1[of "a" "b"]]) auto
 
 
 subsection \<open>Configuration of the code generator\<close>
 
 text \<open>Constructors\<close>
 
 definition Pos :: "num \<Rightarrow> int"
   where [simp, code_abbrev]: "Pos = numeral"
 
 definition Neg :: "num \<Rightarrow> int"
   where [simp, code_abbrev]: "Neg n = - (Pos n)"
 
 code_datatype "0::int" Pos Neg
 
 
 text \<open>Auxiliary operations.\<close>
 
 definition dup :: "int \<Rightarrow> int"
   where [simp]: "dup k = k + k"
 
 lemma dup_code [code]:
   "dup 0 = 0"
   "dup (Pos n) = Pos (Num.Bit0 n)"
   "dup (Neg n) = Neg (Num.Bit0 n)"
   by (simp_all add: numeral_Bit0)
 
 definition sub :: "num \<Rightarrow> num \<Rightarrow> int"
   where [simp]: "sub m n = numeral m - numeral n"
 
 lemma sub_code [code]:
   "sub Num.One Num.One = 0"
   "sub (Num.Bit0 m) Num.One = Pos (Num.BitM m)"
   "sub (Num.Bit1 m) Num.One = Pos (Num.Bit0 m)"
   "sub Num.One (Num.Bit0 n) = Neg (Num.BitM n)"
   "sub Num.One (Num.Bit1 n) = Neg (Num.Bit0 n)"
   "sub (Num.Bit0 m) (Num.Bit0 n) = dup (sub m n)"
   "sub (Num.Bit1 m) (Num.Bit1 n) = dup (sub m n)"
   "sub (Num.Bit1 m) (Num.Bit0 n) = dup (sub m n) + 1"
   "sub (Num.Bit0 m) (Num.Bit1 n) = dup (sub m n) - 1"
   by (simp_all only: sub_def dup_def numeral.simps Pos_def Neg_def numeral_BitM)
 
 lemma sub_BitM_One_eq:
   \<open>(Num.sub (Num.BitM n) num.One) = 2 * (Num.sub n Num.One :: int)\<close>
   by (cases n) simp_all
 
 text \<open>Implementations.\<close>
 
 lemma one_int_code [code]: "1 = Pos Num.One"
   by simp
 
 lemma plus_int_code [code]:
   "k + 0 = k"
   "0 + l = l"
   "Pos m + Pos n = Pos (m + n)"
   "Pos m + Neg n = sub m n"
   "Neg m + Pos n = sub n m"
   "Neg m + Neg n = Neg (m + n)"
   for k l :: int
   by simp_all
 
 lemma uminus_int_code [code]:
   "uminus 0 = (0::int)"
   "uminus (Pos m) = Neg m"
   "uminus (Neg m) = Pos m"
   by simp_all
 
 lemma minus_int_code [code]:
   "k - 0 = k"
   "0 - l = uminus l"
   "Pos m - Pos n = sub m n"
   "Pos m - Neg n = Pos (m + n)"
   "Neg m - Pos n = Neg (m + n)"
   "Neg m - Neg n = sub n m"
   for k l :: int
   by simp_all
 
 lemma times_int_code [code]:
   "k * 0 = 0"
   "0 * l = 0"
   "Pos m * Pos n = Pos (m * n)"
   "Pos m * Neg n = Neg (m * n)"
   "Neg m * Pos n = Neg (m * n)"
   "Neg m * Neg n = Pos (m * n)"
   for k l :: int
   by simp_all
 
 instantiation int :: equal
 begin
 
 definition "HOL.equal k l \<longleftrightarrow> k = (l::int)"
 
 instance
   by standard (rule equal_int_def)
 
 end
 
 lemma equal_int_code [code]:
   "HOL.equal 0 (0::int) \<longleftrightarrow> True"
   "HOL.equal 0 (Pos l) \<longleftrightarrow> False"
   "HOL.equal 0 (Neg l) \<longleftrightarrow> False"
   "HOL.equal (Pos k) 0 \<longleftrightarrow> False"
   "HOL.equal (Pos k) (Pos l) \<longleftrightarrow> HOL.equal k l"
   "HOL.equal (Pos k) (Neg l) \<longleftrightarrow> False"
   "HOL.equal (Neg k) 0 \<longleftrightarrow> False"
   "HOL.equal (Neg k) (Pos l) \<longleftrightarrow> False"
   "HOL.equal (Neg k) (Neg l) \<longleftrightarrow> HOL.equal k l"
   by (auto simp add: equal)
 
 lemma equal_int_refl [code nbe]: "HOL.equal k k \<longleftrightarrow> True"
   for k :: int
   by (fact equal_refl)
 
 lemma less_eq_int_code [code]:
   "0 \<le> (0::int) \<longleftrightarrow> True"
   "0 \<le> Pos l \<longleftrightarrow> True"
   "0 \<le> Neg l \<longleftrightarrow> False"
   "Pos k \<le> 0 \<longleftrightarrow> False"
   "Pos k \<le> Pos l \<longleftrightarrow> k \<le> l"
   "Pos k \<le> Neg l \<longleftrightarrow> False"
   "Neg k \<le> 0 \<longleftrightarrow> True"
   "Neg k \<le> Pos l \<longleftrightarrow> True"
   "Neg k \<le> Neg l \<longleftrightarrow> l \<le> k"
   by simp_all
 
 lemma less_int_code [code]:
   "0 < (0::int) \<longleftrightarrow> False"
   "0 < Pos l \<longleftrightarrow> True"
   "0 < Neg l \<longleftrightarrow> False"
   "Pos k < 0 \<longleftrightarrow> False"
   "Pos k < Pos l \<longleftrightarrow> k < l"
   "Pos k < Neg l \<longleftrightarrow> False"
   "Neg k < 0 \<longleftrightarrow> True"
   "Neg k < Pos l \<longleftrightarrow> True"
   "Neg k < Neg l \<longleftrightarrow> l < k"
   by simp_all
 
 lemma nat_code [code]:
   "nat (Int.Neg k) = 0"
   "nat 0 = 0"
   "nat (Int.Pos k) = nat_of_num k"
   by (simp_all add: nat_of_num_numeral)
 
 lemma (in ring_1) of_int_code [code]:
   "of_int (Int.Neg k) = - numeral k"
   "of_int 0 = 0"
   "of_int (Int.Pos k) = numeral k"
   by simp_all
 
 
 text \<open>Serializer setup.\<close>
 
 code_identifier
   code_module Int \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 quickcheck_params [default_type = int]
 
 hide_const (open) Pos Neg sub dup
 
 
 text \<open>De-register \<open>int\<close> as a quotient type:\<close>
 
 lifting_update int.lifting
 lifting_forget int.lifting
 
 
 subsection \<open>Duplicates\<close>
 
 lemmas int_sum = of_nat_sum [where 'a=int]
 lemmas int_prod = of_nat_prod [where 'a=int]
 lemmas zle_int = of_nat_le_iff [where 'a=int]
 lemmas int_int_eq = of_nat_eq_iff [where 'a=int]
 lemmas nonneg_eq_int = nonneg_int_cases
 lemmas double_eq_0_iff = double_zero
 
 lemmas int_distrib =
   distrib_right [of z1 z2 w]
   distrib_left [of w z1 z2]
   left_diff_distrib [of z1 z2 w]
   right_diff_distrib [of w z1 z2]
   for z1 z2 w :: int
 
 end
 
diff --git a/src/HOL/Lattices_Big.thy b/src/HOL/Lattices_Big.thy
--- a/src/HOL/Lattices_Big.thy
+++ b/src/HOL/Lattices_Big.thy
@@ -1,1071 +1,1077 @@
 (*  Title:      HOL/Lattices_Big.thy
     Author:     Tobias Nipkow, Lawrence C Paulson and Markus Wenzel
                 with contributions by Jeremy Avigad
 *)
 
 section \<open>Big infimum (minimum) and supremum (maximum) over finite (non-empty) sets\<close>
 
 theory Lattices_Big
   imports Groups_Big Option
 begin
 
 subsection \<open>Generic lattice operations over a set\<close>
 
 subsubsection \<open>Without neutral element\<close>
 
 locale semilattice_set = semilattice
 begin
 
 interpretation comp_fun_idem f
   by standard (simp_all add: fun_eq_iff left_commute)
 
 definition F :: "'a set \<Rightarrow> 'a"
 where
   eq_fold': "F A = the (Finite_Set.fold (\<lambda>x y. Some (case y of None \<Rightarrow> x | Some z \<Rightarrow> f x z)) None A)"
 
 lemma eq_fold:
   assumes "finite A"
   shows "F (insert x A) = Finite_Set.fold f x A"
 proof (rule sym)
   let ?f = "\<lambda>x y. Some (case y of None \<Rightarrow> x | Some z \<Rightarrow> f x z)"
   interpret comp_fun_idem "?f"
     by standard (simp_all add: fun_eq_iff commute left_commute split: option.split)
   from assms show "Finite_Set.fold f x A = F (insert x A)"
   proof induct
     case empty then show ?case by (simp add: eq_fold')
   next
     case (insert y B) then show ?case by (simp add: insert_commute [of x] eq_fold')
   qed
 qed
 
 lemma singleton [simp]:
   "F {x} = x"
   by (simp add: eq_fold)
 
 lemma insert_not_elem:
   assumes "finite A" and "x \<notin> A" and "A \<noteq> {}"
   shows "F (insert x A) = x \<^bold>* F A"
 proof -
   from \<open>A \<noteq> {}\<close> obtain b where "b \<in> A" by blast
   then obtain B where *: "A = insert b B" "b \<notin> B" by (blast dest: mk_disjoint_insert)
   with \<open>finite A\<close> and \<open>x \<notin> A\<close>
     have "finite (insert x B)" and "b \<notin> insert x B" by auto
   then have "F (insert b (insert x B)) = x \<^bold>* F (insert b B)"
     by (simp add: eq_fold)
   then show ?thesis by (simp add: * insert_commute)
 qed
 
 lemma in_idem:
   assumes "finite A" and "x \<in> A"
   shows "x \<^bold>* F A = F A"
 proof -
   from assms have "A \<noteq> {}" by auto
   with \<open>finite A\<close> show ?thesis using \<open>x \<in> A\<close>
     by (induct A rule: finite_ne_induct) (auto simp add: ac_simps insert_not_elem)
 qed
 
 lemma insert [simp]:
   assumes "finite A" and "A \<noteq> {}"
   shows "F (insert x A) = x \<^bold>* F A"
   using assms by (cases "x \<in> A") (simp_all add: insert_absorb in_idem insert_not_elem)
 
 lemma union:
   assumes "finite A" "A \<noteq> {}" and "finite B" "B \<noteq> {}"
   shows "F (A \<union> B) = F A \<^bold>* F B"
   using assms by (induct A rule: finite_ne_induct) (simp_all add: ac_simps)
 
 lemma remove:
   assumes "finite A" and "x \<in> A"
   shows "F A = (if A - {x} = {} then x else x \<^bold>* F (A - {x}))"
 proof -
   from assms obtain B where "A = insert x B" and "x \<notin> B" by (blast dest: mk_disjoint_insert)
   with assms show ?thesis by simp
 qed
 
 lemma insert_remove:
   assumes "finite A"
   shows "F (insert x A) = (if A - {x} = {} then x else x \<^bold>* F (A - {x}))"
   using assms by (cases "x \<in> A") (simp_all add: insert_absorb remove)
 
 lemma subset:
   assumes "finite A" "B \<noteq> {}" and "B \<subseteq> A"
   shows "F B \<^bold>* F A = F A"
 proof -
   from assms have "A \<noteq> {}" and "finite B" by (auto dest: finite_subset)
   with assms show ?thesis by (simp add: union [symmetric] Un_absorb1)
 qed
 
 lemma closed:
   assumes "finite A" "A \<noteq> {}" and elem: "\<And>x y. x \<^bold>* y \<in> {x, y}"
   shows "F A \<in> A"
 using \<open>finite A\<close> \<open>A \<noteq> {}\<close> proof (induct rule: finite_ne_induct)
   case singleton then show ?case by simp
 next
   case insert with elem show ?case by force
 qed
 
 lemma hom_commute:
   assumes hom: "\<And>x y. h (x \<^bold>* y) = h x \<^bold>* h y"
   and N: "finite N" "N \<noteq> {}"
   shows "h (F N) = F (h ` N)"
 using N proof (induct rule: finite_ne_induct)
   case singleton thus ?case by simp
 next
   case (insert n N)
   then have "h (F (insert n N)) = h (n \<^bold>* F N)" by simp
   also have "\<dots> = h n \<^bold>* h (F N)" by (rule hom)
   also have "h (F N) = F (h ` N)" by (rule insert)
   also have "h n \<^bold>* \<dots> = F (insert (h n) (h ` N))"
     using insert by simp
   also have "insert (h n) (h ` N) = h ` insert n N" by simp
   finally show ?case .
 qed
 
 lemma infinite: "\<not> finite A \<Longrightarrow> F A = the None"
   unfolding eq_fold' by (cases "finite (UNIV::'a set)") (auto intro: finite_subset fold_infinite)
 
 end
 
 locale semilattice_order_set = binary?: semilattice_order + semilattice_set
 begin
 
 lemma bounded_iff:
   assumes "finite A" and "A \<noteq> {}"
   shows "x \<^bold>\<le> F A \<longleftrightarrow> (\<forall>a\<in>A. x \<^bold>\<le> a)"
   using assms by (induct rule: finite_ne_induct) simp_all
 
 lemma boundedI:
   assumes "finite A"
   assumes "A \<noteq> {}"
   assumes "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
   shows "x \<^bold>\<le> F A"
   using assms by (simp add: bounded_iff)
 
 lemma boundedE:
   assumes "finite A" and "A \<noteq> {}" and "x \<^bold>\<le> F A"
   obtains "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
   using assms by (simp add: bounded_iff)
 
 lemma coboundedI:
   assumes "finite A"
     and "a \<in> A"
   shows "F A \<^bold>\<le> a"
 proof -
   from assms have "A \<noteq> {}" by auto
   from \<open>finite A\<close> \<open>A \<noteq> {}\<close> \<open>a \<in> A\<close> show ?thesis
   proof (induct rule: finite_ne_induct)
     case singleton thus ?case by (simp add: refl)
   next
     case (insert x B)
     from insert have "a = x \<or> a \<in> B" by simp
     then show ?case using insert by (auto intro: coboundedI2)
   qed
 qed
 
 lemma subset_imp:
   assumes "A \<subseteq> B" and "A \<noteq> {}" and "finite B"
   shows "F B \<^bold>\<le> F A"
 proof (cases "A = B")
   case True then show ?thesis by (simp add: refl)
 next
   case False
   have B: "B = A \<union> (B - A)" using \<open>A \<subseteq> B\<close> by blast
   then have "F B = F (A \<union> (B - A))" by simp
   also have "\<dots> = F A \<^bold>* F (B - A)" using False assms by (subst union) (auto intro: finite_subset)
   also have "\<dots> \<^bold>\<le> F A" by simp
   finally show ?thesis .
 qed
 
 end
 
 
 subsubsection \<open>With neutral element\<close>
 
 locale semilattice_neutr_set = semilattice_neutr
 begin
 
 interpretation comp_fun_idem f
   by standard (simp_all add: fun_eq_iff left_commute)
 
 definition F :: "'a set \<Rightarrow> 'a"
 where
   eq_fold: "F A = Finite_Set.fold f \<^bold>1 A"
 
 lemma infinite [simp]:
   "\<not> finite A \<Longrightarrow> F A = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma empty [simp]:
   "F {} = \<^bold>1"
   by (simp add: eq_fold)
 
 lemma insert [simp]:
   assumes "finite A"
   shows "F (insert x A) = x \<^bold>* F A"
   using assms by (simp add: eq_fold)
 
 lemma in_idem:
   assumes "finite A" and "x \<in> A"
   shows "x \<^bold>* F A = F A"
 proof -
   from assms have "A \<noteq> {}" by auto
   with \<open>finite A\<close> show ?thesis using \<open>x \<in> A\<close>
     by (induct A rule: finite_ne_induct) (auto simp add: ac_simps)
 qed
 
 lemma union:
   assumes "finite A" and "finite B"
   shows "F (A \<union> B) = F A \<^bold>* F B"
   using assms by (induct A) (simp_all add: ac_simps)
 
 lemma remove:
   assumes "finite A" and "x \<in> A"
   shows "F A = x \<^bold>* F (A - {x})"
 proof -
   from assms obtain B where "A = insert x B" and "x \<notin> B" by (blast dest: mk_disjoint_insert)
   with assms show ?thesis by simp
 qed
 
 lemma insert_remove:
   assumes "finite A"
   shows "F (insert x A) = x \<^bold>* F (A - {x})"
   using assms by (cases "x \<in> A") (simp_all add: insert_absorb remove)
 
 lemma subset:
   assumes "finite A" and "B \<subseteq> A"
   shows "F B \<^bold>* F A = F A"
 proof -
   from assms have "finite B" by (auto dest: finite_subset)
   with assms show ?thesis by (simp add: union [symmetric] Un_absorb1)
 qed
 
 lemma closed:
   assumes "finite A" "A \<noteq> {}" and elem: "\<And>x y. x \<^bold>* y \<in> {x, y}"
   shows "F A \<in> A"
 using \<open>finite A\<close> \<open>A \<noteq> {}\<close> proof (induct rule: finite_ne_induct)
   case singleton then show ?case by simp
 next
   case insert with elem show ?case by force
 qed
 
 end
 
 locale semilattice_order_neutr_set = binary?: semilattice_neutr_order + semilattice_neutr_set
 begin
 
 lemma bounded_iff:
   assumes "finite A"
   shows "x \<^bold>\<le> F A \<longleftrightarrow> (\<forall>a\<in>A. x \<^bold>\<le> a)"
   using assms by (induct A) simp_all
 
 lemma boundedI:
   assumes "finite A"
   assumes "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
   shows "x \<^bold>\<le> F A"
   using assms by (simp add: bounded_iff)
 
 lemma boundedE:
   assumes "finite A" and "x \<^bold>\<le> F A"
   obtains "\<And>a. a \<in> A \<Longrightarrow> x \<^bold>\<le> a"
   using assms by (simp add: bounded_iff)
 
 lemma coboundedI:
   assumes "finite A"
     and "a \<in> A"
   shows "F A \<^bold>\<le> a"
 proof -
   from assms have "A \<noteq> {}" by auto
   from \<open>finite A\<close> \<open>A \<noteq> {}\<close> \<open>a \<in> A\<close> show ?thesis
   proof (induct rule: finite_ne_induct)
     case singleton thus ?case by (simp add: refl)
   next
     case (insert x B)
     from insert have "a = x \<or> a \<in> B" by simp
     then show ?case using insert by (auto intro: coboundedI2)
   qed
 qed
 
 lemma subset_imp:
   assumes "A \<subseteq> B" and "finite B"
   shows "F B \<^bold>\<le> F A"
 proof (cases "A = B")
   case True then show ?thesis by (simp add: refl)
 next
   case False
   have B: "B = A \<union> (B - A)" using \<open>A \<subseteq> B\<close> by blast
   then have "F B = F (A \<union> (B - A))" by simp
   also have "\<dots> = F A \<^bold>* F (B - A)" using False assms by (subst union) (auto intro: finite_subset)
   also have "\<dots> \<^bold>\<le> F A" by simp
   finally show ?thesis .
 qed
 
 end
 
 
 subsection \<open>Lattice operations on finite sets\<close>
 
 context semilattice_inf
 begin
 
 sublocale Inf_fin: semilattice_order_set inf less_eq less
 defines
   Inf_fin ("\<Sqinter>\<^sub>f\<^sub>i\<^sub>n _" [900] 900) = Inf_fin.F ..
 
 end
 
 context semilattice_sup
 begin
 
 sublocale Sup_fin: semilattice_order_set sup greater_eq greater
 defines
   Sup_fin ("\<Squnion>\<^sub>f\<^sub>i\<^sub>n _" [900] 900) = Sup_fin.F ..
 
 end
 
 
 subsection \<open>Infimum and Supremum over non-empty sets\<close>
 
 context lattice
 begin
 
 lemma Inf_fin_le_Sup_fin [simp]: 
   assumes "finite A" and "A \<noteq> {}"
   shows "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<le> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA"
 proof -
   from \<open>A \<noteq> {}\<close> obtain a where "a \<in> A" by blast
   with \<open>finite A\<close> have "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<le> a" by (rule Inf_fin.coboundedI)
   moreover from \<open>finite A\<close> \<open>a \<in> A\<close> have "a \<le> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA" by (rule Sup_fin.coboundedI)
   ultimately show ?thesis by (rule order_trans)
 qed
 
 lemma sup_Inf_absorb [simp]:
   "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> \<Sqinter>\<^sub>f\<^sub>i\<^sub>nA \<squnion> a = a"
   by (rule sup_absorb2) (rule Inf_fin.coboundedI)
 
 lemma inf_Sup_absorb [simp]:
   "finite A \<Longrightarrow> a \<in> A \<Longrightarrow> a \<sqinter> \<Squnion>\<^sub>f\<^sub>i\<^sub>nA = a"
   by (rule inf_absorb1) (rule Sup_fin.coboundedI)
 
 end
 
 context distrib_lattice
 begin
 
 lemma sup_Inf1_distrib:
   assumes "finite A"
     and "A \<noteq> {}"
   shows "sup x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup x a|a. a \<in> A}"
 using assms by (simp add: image_def Inf_fin.hom_commute [where h="sup x", OF sup_inf_distrib1])
   (rule arg_cong [where f="Inf_fin"], blast)
 
 lemma sup_Inf2_distrib:
   assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
   shows "sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB) = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup a b|a b. a \<in> A \<and> b \<in> B}"
 using A proof (induct rule: finite_ne_induct)
   case singleton then show ?case
     by (simp add: sup_Inf1_distrib [OF B])
 next
   case (insert x A)
   have finB: "finite {sup x b |b. b \<in> B}"
     by (rule finite_surj [where f = "sup x", OF B(1)], auto)
   have finAB: "finite {sup a b |a b. a \<in> A \<and> b \<in> B}"
   proof -
     have "{sup a b |a b. a \<in> A \<and> b \<in> B} = (\<Union>a\<in>A. \<Union>b\<in>B. {sup a b})"
       by blast
     thus ?thesis by(simp add: insert(1) B(1))
   qed
   have ne: "{sup a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
   have "sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n(insert x A)) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB) = sup (inf x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA)) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB)"
     using insert by simp
   also have "\<dots> = inf (sup x (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB)) (sup (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>nB))" by(rule sup_inf_distrib2)
   also have "\<dots> = inf (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup x b|b. b \<in> B}) (\<Sqinter>\<^sub>f\<^sub>i\<^sub>n{sup a b|a b. a \<in> A \<and> b \<in> B})"
     using insert by(simp add:sup_Inf1_distrib[OF B])
   also have "\<dots> = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n({sup x b |b. b \<in> B} \<union> {sup a b |a b. a \<in> A \<and> b \<in> B})"
     (is "_ = \<Sqinter>\<^sub>f\<^sub>i\<^sub>n?M")
     using B insert
     by (simp add: Inf_fin.union [OF finB _ finAB ne])
   also have "?M = {sup a b |a b. a \<in> insert x A \<and> b \<in> B}"
     by blast
   finally show ?case .
 qed
 
 lemma inf_Sup1_distrib:
   assumes "finite A" and "A \<noteq> {}"
   shows "inf x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) = \<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf x a|a. a \<in> A}"
 using assms by (simp add: image_def Sup_fin.hom_commute [where h="inf x", OF inf_sup_distrib1])
   (rule arg_cong [where f="Sup_fin"], blast)
 
 lemma inf_Sup2_distrib:
   assumes A: "finite A" "A \<noteq> {}" and B: "finite B" "B \<noteq> {}"
   shows "inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB) = \<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf a b|a b. a \<in> A \<and> b \<in> B}"
 using A proof (induct rule: finite_ne_induct)
   case singleton thus ?case
     by(simp add: inf_Sup1_distrib [OF B])
 next
   case (insert x A)
   have finB: "finite {inf x b |b. b \<in> B}"
     by(rule finite_surj[where f = "%b. inf x b", OF B(1)], auto)
   have finAB: "finite {inf a b |a b. a \<in> A \<and> b \<in> B}"
   proof -
     have "{inf a b |a b. a \<in> A \<and> b \<in> B} = (\<Union>a\<in>A. \<Union>b\<in>B. {inf a b})"
       by blast
     thus ?thesis by(simp add: insert(1) B(1))
   qed
   have ne: "{inf a b |a b. a \<in> A \<and> b \<in> B} \<noteq> {}" using insert B by blast
   have "inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>n(insert x A)) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB) = inf (sup x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA)) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB)"
     using insert by simp
   also have "\<dots> = sup (inf x (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB)) (inf (\<Squnion>\<^sub>f\<^sub>i\<^sub>nA) (\<Squnion>\<^sub>f\<^sub>i\<^sub>nB))" by(rule inf_sup_distrib2)
   also have "\<dots> = sup (\<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf x b|b. b \<in> B}) (\<Squnion>\<^sub>f\<^sub>i\<^sub>n{inf a b|a b. a \<in> A \<and> b \<in> B})"
     using insert by(simp add:inf_Sup1_distrib[OF B])
   also have "\<dots> = \<Squnion>\<^sub>f\<^sub>i\<^sub>n({inf x b |b. b \<in> B} \<union> {inf a b |a b. a \<in> A \<and> b \<in> B})"
     (is "_ = \<Squnion>\<^sub>f\<^sub>i\<^sub>n?M")
     using B insert
     by (simp add: Sup_fin.union [OF finB _ finAB ne])
   also have "?M = {inf a b |a b. a \<in> insert x A \<and> b \<in> B}"
     by blast
   finally show ?case .
 qed
 
 end
 
 context complete_lattice
 begin
 
 lemma Inf_fin_Inf:
   assumes "finite A" and "A \<noteq> {}"
   shows "\<Sqinter>\<^sub>f\<^sub>i\<^sub>nA = \<Sqinter>A"
 proof -
   from assms obtain b B where "A = insert b B" and "finite B" by auto
   then show ?thesis
     by (simp add: Inf_fin.eq_fold inf_Inf_fold_inf inf.commute [of b])
 qed
 
 lemma Sup_fin_Sup:
   assumes "finite A" and "A \<noteq> {}"
   shows "\<Squnion>\<^sub>f\<^sub>i\<^sub>nA = \<Squnion>A"
 proof -
   from assms obtain b B where "A = insert b B" and "finite B" by auto
   then show ?thesis
     by (simp add: Sup_fin.eq_fold sup_Sup_fold_sup sup.commute [of b])
 qed
 
 end
 
 
 subsection \<open>Minimum and Maximum over non-empty sets\<close>
 
 context linorder
 begin
 
 sublocale Min: semilattice_order_set min less_eq less
   + Max: semilattice_order_set max greater_eq greater
 defines
   Min = Min.F and Max = Max.F ..
 
 end
 
 syntax
   "_MIN1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3MIN _./ _)" [0, 10] 10)
   "_MIN"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3MIN _\<in>_./ _)" [0, 0, 10] 10)
   "_MAX1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3MAX _./ _)" [0, 10] 10)
   "_MAX"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3MAX _\<in>_./ _)" [0, 0, 10] 10)
 
 translations
   "MIN x y. f"   \<rightleftharpoons> "MIN x. MIN y. f"
   "MIN x. f"     \<rightleftharpoons> "CONST Min (CONST range (\<lambda>x. f))"
   "MIN x\<in>A. f"   \<rightleftharpoons> "CONST Min ((\<lambda>x. f) ` A)"
   "MAX x y. f"   \<rightleftharpoons> "MAX x. MAX y. f"
   "MAX x. f"     \<rightleftharpoons> "CONST Max (CONST range (\<lambda>x. f))"
   "MAX x\<in>A. f"   \<rightleftharpoons> "CONST Max ((\<lambda>x. f) ` A)"
 
 text \<open>An aside: \<^const>\<open>Min\<close>/\<^const>\<open>Max\<close> on linear orders as special case of \<^const>\<open>Inf_fin\<close>/\<^const>\<open>Sup_fin\<close>\<close>
 
 lemma Inf_fin_Min:
   "Inf_fin = (Min :: 'a::{semilattice_inf, linorder} set \<Rightarrow> 'a)"
   by (simp add: Inf_fin_def Min_def inf_min)
 
 lemma Sup_fin_Max:
   "Sup_fin = (Max :: 'a::{semilattice_sup, linorder} set \<Rightarrow> 'a)"
   by (simp add: Sup_fin_def Max_def sup_max)
 
 context linorder
 begin
 
 lemma dual_min:
   "ord.min greater_eq = max"
   by (auto simp add: ord.min_def max_def fun_eq_iff)
 
 lemma dual_max:
   "ord.max greater_eq = min"
   by (auto simp add: ord.max_def min_def fun_eq_iff)
 
 lemma dual_Min:
   "linorder.Min greater_eq = Max"
 proof -
   interpret dual: linorder greater_eq greater by (fact dual_linorder)
   show ?thesis by (simp add: dual.Min_def dual_min Max_def)
 qed
 
 lemma dual_Max:
   "linorder.Max greater_eq = Min"
 proof -
   interpret dual: linorder greater_eq greater by (fact dual_linorder)
   show ?thesis by (simp add: dual.Max_def dual_max Min_def)
 qed
 
 lemmas Min_singleton = Min.singleton
 lemmas Max_singleton = Max.singleton
 lemmas Min_insert = Min.insert
 lemmas Max_insert = Max.insert
 lemmas Min_Un = Min.union
 lemmas Max_Un = Max.union
 lemmas hom_Min_commute = Min.hom_commute
 lemmas hom_Max_commute = Max.hom_commute
 
 lemma Min_in [simp]:
   assumes "finite A" and "A \<noteq> {}"
   shows "Min A \<in> A"
   using assms by (auto simp add: min_def Min.closed)
 
 lemma Max_in [simp]:
   assumes "finite A" and "A \<noteq> {}"
   shows "Max A \<in> A"
   using assms by (auto simp add: max_def Max.closed)
 
 lemma Min_insert2:
   assumes "finite A" and min: "\<And>b. b \<in> A \<Longrightarrow> a \<le> b"
   shows "Min (insert a A) = a"
 proof (cases "A = {}")
   case True
   then show ?thesis by simp
 next
   case False
   with \<open>finite A\<close> have "Min (insert a A) = min a (Min A)"
     by simp
   moreover from \<open>finite A\<close> \<open>A \<noteq> {}\<close> min have "a \<le> Min A" by simp
   ultimately show ?thesis by (simp add: min.absorb1)
 qed
 
 lemma Max_insert2:
   assumes "finite A" and max: "\<And>b. b \<in> A \<Longrightarrow> b \<le> a"
   shows "Max (insert a A) = a"
 proof (cases "A = {}")
   case True
   then show ?thesis by simp
 next
   case False
   with \<open>finite A\<close> have "Max (insert a A) = max a (Max A)"
     by simp
   moreover from \<open>finite A\<close> \<open>A \<noteq> {}\<close> max have "Max A \<le> a" by simp
   ultimately show ?thesis by (simp add: max.absorb1)
 qed
 
 lemma Max_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max ((\<lambda>_. c) ` A) = c"
 using Max_in image_is_empty by blast
 
 lemma Min_const[simp]: "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Min ((\<lambda>_. c) ` A) = c"
 using Min_in image_is_empty by blast
 
 lemma Min_le [simp]:
   assumes "finite A" and "x \<in> A"
   shows "Min A \<le> x"
   using assms by (fact Min.coboundedI)
 
 lemma Max_ge [simp]:
   assumes "finite A" and "x \<in> A"
   shows "x \<le> Max A"
   using assms by (fact Max.coboundedI)
 
 lemma Min_eqI:
   assumes "finite A"
   assumes "\<And>y. y \<in> A \<Longrightarrow> y \<ge> x"
     and "x \<in> A"
   shows "Min A = x"
 proof (rule order.antisym)
   from \<open>x \<in> A\<close> have "A \<noteq> {}" by auto
   with assms show "Min A \<ge> x" by simp
 next
   from assms show "x \<ge> Min A" by simp
 qed
 
 lemma Max_eqI:
   assumes "finite A"
   assumes "\<And>y. y \<in> A \<Longrightarrow> y \<le> x"
     and "x \<in> A"
   shows "Max A = x"
 proof (rule order.antisym)
   from \<open>x \<in> A\<close> have "A \<noteq> {}" by auto
   with assms show "Max A \<le> x" by simp
 next
   from assms show "x \<le> Max A" by simp
 qed
 
 lemma eq_Min_iff:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> m = Min A  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. m \<le> a)"
 by (meson Min_in Min_le order.antisym)
 
 lemma Min_eq_iff:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Min A = m  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. m \<le> a)"
 by (meson Min_in Min_le order.antisym)
 
 lemma eq_Max_iff:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> m = Max A  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. a \<le> m)"
 by (meson Max_in Max_ge order.antisym)
 
 lemma Max_eq_iff:
   "\<lbrakk> finite A; A \<noteq> {} \<rbrakk> \<Longrightarrow> Max A = m  \<longleftrightarrow>  m \<in> A \<and> (\<forall>a \<in> A. a \<le> m)"
 by (meson Max_in Max_ge order.antisym)
 
 context
   fixes A :: "'a set"
   assumes fin_nonempty: "finite A" "A \<noteq> {}"
 begin
 
 lemma Min_ge_iff [simp]:
   "x \<le> Min A \<longleftrightarrow> (\<forall>a\<in>A. x \<le> a)"
   using fin_nonempty by (fact Min.bounded_iff)
 
 lemma Max_le_iff [simp]:
   "Max A \<le> x \<longleftrightarrow> (\<forall>a\<in>A. a \<le> x)"
   using fin_nonempty by (fact Max.bounded_iff)
 
 lemma Min_gr_iff [simp]:
   "x < Min A \<longleftrightarrow> (\<forall>a\<in>A. x < a)"
   using fin_nonempty  by (induct rule: finite_ne_induct) simp_all
 
 lemma Max_less_iff [simp]:
   "Max A < x \<longleftrightarrow> (\<forall>a\<in>A. a < x)"
   using fin_nonempty by (induct rule: finite_ne_induct) simp_all
 
 lemma Min_le_iff:
   "Min A \<le> x \<longleftrightarrow> (\<exists>a\<in>A. a \<le> x)"
   using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_le_iff_disj)
 
 lemma Max_ge_iff:
   "x \<le> Max A \<longleftrightarrow> (\<exists>a\<in>A. x \<le> a)"
   using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: le_max_iff_disj)
 
 lemma Min_less_iff:
   "Min A < x \<longleftrightarrow> (\<exists>a\<in>A. a < x)"
   using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: min_less_iff_disj)
 
 lemma Max_gr_iff:
   "x < Max A \<longleftrightarrow> (\<exists>a\<in>A. x < a)"
   using fin_nonempty by (induct rule: finite_ne_induct) (simp_all add: less_max_iff_disj)
 
 end
 
 lemma Max_eq_if:
   assumes "finite A"  "finite B"  "\<forall>a\<in>A. \<exists>b\<in>B. a \<le> b"  "\<forall>b\<in>B. \<exists>a\<in>A. b \<le> a"
   shows "Max A = Max B"
 proof cases
   assume "A = {}" thus ?thesis using assms by simp
 next
   assume "A \<noteq> {}" thus ?thesis using assms
     by(blast intro: order.antisym Max_in Max_ge_iff[THEN iffD2])
 qed
 
 lemma Min_antimono:
   assumes "M \<subseteq> N" and "M \<noteq> {}" and "finite N"
   shows "Min N \<le> Min M"
   using assms by (fact Min.subset_imp)
 
 lemma Max_mono:
   assumes "M \<subseteq> N" and "M \<noteq> {}" and "finite N"
   shows "Max M \<le> Max N"
   using assms by (fact Max.subset_imp)
 
 lemma mono_Min_commute:
   assumes "mono f"
   assumes "finite A" and "A \<noteq> {}"
   shows "f (Min A) = Min (f ` A)"
 proof (rule linorder_class.Min_eqI [symmetric])
   from \<open>finite A\<close> show "finite (f ` A)" by simp
   from assms show "f (Min A) \<in> f ` A" by simp
   fix x
   assume "x \<in> f ` A"
   then obtain y where "y \<in> A" and "x = f y" ..
   with assms have "Min A \<le> y" by auto
   with \<open>mono f\<close> have "f (Min A) \<le> f y" by (rule monoE)
   with \<open>x = f y\<close> show "f (Min A) \<le> x" by simp
 qed
 
 lemma mono_Max_commute:
   assumes "mono f"
   assumes "finite A" and "A \<noteq> {}"
   shows "f (Max A) = Max (f ` A)"
 proof (rule linorder_class.Max_eqI [symmetric])
   from \<open>finite A\<close> show "finite (f ` A)" by simp
   from assms show "f (Max A) \<in> f ` A" by simp
   fix x
   assume "x \<in> f ` A"
   then obtain y where "y \<in> A" and "x = f y" ..
   with assms have "y \<le> Max A" by auto
   with \<open>mono f\<close> have "f y \<le> f (Max A)" by (rule monoE)
   with \<open>x = f y\<close> show "x \<le> f (Max A)" by simp
 qed
 
 lemma finite_linorder_max_induct [consumes 1, case_names empty insert]:
   assumes fin: "finite A"
   and empty: "P {}" 
   and insert: "\<And>b A. finite A \<Longrightarrow> \<forall>a\<in>A. a < b \<Longrightarrow> P A \<Longrightarrow> P (insert b A)"
   shows "P A"
 using fin empty insert
 proof (induct rule: finite_psubset_induct)
   case (psubset A)
   have IH: "\<And>B. \<lbrakk>B < A; P {}; (\<And>A b. \<lbrakk>finite A; \<forall>a\<in>A. a<b; P A\<rbrakk> \<Longrightarrow> P (insert b A))\<rbrakk> \<Longrightarrow> P B" by fact 
   have fin: "finite A" by fact 
   have empty: "P {}" by fact
   have step: "\<And>b A. \<lbrakk>finite A; \<forall>a\<in>A. a < b; P A\<rbrakk> \<Longrightarrow> P (insert b A)" by fact
   show "P A"
   proof (cases "A = {}")
     assume "A = {}" 
     then show "P A" using \<open>P {}\<close> by simp
   next
     let ?B = "A - {Max A}" 
     let ?A = "insert (Max A) ?B"
     have "finite ?B" using \<open>finite A\<close> by simp
     assume "A \<noteq> {}"
     with \<open>finite A\<close> have "Max A \<in> A" by auto
     then have A: "?A = A" using insert_Diff_single insert_absorb by auto
     then have "P ?B" using \<open>P {}\<close> step IH [of ?B] by blast
     moreover 
     have "\<forall>a\<in>?B. a < Max A" using Max_ge [OF \<open>finite A\<close>] by fastforce
     ultimately show "P A" using A insert_Diff_single step [OF \<open>finite ?B\<close>] by fastforce
   qed
 qed
 
 lemma finite_linorder_min_induct [consumes 1, case_names empty insert]:
   "\<lbrakk>finite A; P {}; \<And>b A. \<lbrakk>finite A; \<forall>a\<in>A. b < a; P A\<rbrakk> \<Longrightarrow> P (insert b A)\<rbrakk> \<Longrightarrow> P A"
   by (rule linorder.finite_linorder_max_induct [OF dual_linorder])
 
 lemma finite_ranking_induct[consumes 1, case_names empty insert]:
   fixes f :: "'b \<Rightarrow> 'a"
   assumes "finite S"
   assumes "P {}" 
   assumes "\<And>x S. finite S \<Longrightarrow> (\<And>y. y \<in> S \<Longrightarrow> f y \<le> f x) \<Longrightarrow> P S \<Longrightarrow> P (insert x S)"
   shows "P S"
   using \<open>finite S\<close> 
 proof (induction rule: finite_psubset_induct)
   case (psubset A)
   {
     assume "A \<noteq> {}"
     hence "f ` A \<noteq> {}" and "finite (f ` A)"
       using psubset finite_image_iff by simp+ 
     then obtain a where "f a = Max (f ` A)" and "a \<in> A"
       by (metis Max_in[of "f ` A"] imageE)
     then have "P (A - {a})"
       using psubset member_remove by blast 
     moreover 
     have "\<And>y. y \<in> A \<Longrightarrow> f y \<le> f a"
       using \<open>f a = Max (f ` A)\<close> \<open>finite (f ` A)\<close> by simp
     ultimately
     have ?case
       by (metis \<open>a \<in> A\<close> DiffD1 insert_Diff assms(3) finite_Diff psubset.hyps)
   }
   thus ?case
     using assms(2) by blast
 qed
 
 lemma Least_Min:
   assumes "finite {a. P a}" and "\<exists>a. P a"
   shows "(LEAST a. P a) = Min {a. P a}"
 proof -
   { fix A :: "'a set"
     assume A: "finite A" "A \<noteq> {}"
     have "(LEAST a. a \<in> A) = Min A"
     using A proof (induct A rule: finite_ne_induct)
       case singleton show ?case by (rule Least_equality) simp_all
     next
       case (insert a A)
       have "(LEAST b. b = a \<or> b \<in> A) = min a (LEAST a. a \<in> A)"
         by (auto intro!: Least_equality simp add: min_def not_le Min_le_iff insert.hyps dest!: less_imp_le)
       with insert show ?case by simp
     qed
   } from this [of "{a. P a}"] assms show ?thesis by simp
 qed
 
 lemma infinite_growing:
   assumes "X \<noteq> {}"
   assumes *: "\<And>x. x \<in> X \<Longrightarrow> \<exists>y\<in>X. y > x"
   shows "\<not> finite X"
 proof
   assume "finite X"
   with \<open>X \<noteq> {}\<close> have "Max X \<in> X" "\<forall>x\<in>X. x \<le> Max X"
     by auto
   with *[of "Max X"] show False
     by auto
 qed
 
 end
 
 lemma sum_le_card_Max: "finite A \<Longrightarrow> sum f A \<le> card A * Max (f ` A)"
 using sum_bounded_above[of A f "Max (f ` A)"] by simp
 
 lemma card_Min_le_sum: "finite A \<Longrightarrow> card A * Min (f ` A) \<le> sum f A"
 using sum_bounded_below[of A "Min (f ` A)" f] by simp
 
 context linordered_ab_semigroup_add
 begin
 
 lemma Min_add_commute:
   fixes k
   assumes "finite S" and "S \<noteq> {}"
   shows "Min ((\<lambda>x. f x + k) ` S) = Min(f ` S) + k"
 proof -
   have m: "\<And>x y. min x y + k = min (x+k) (y+k)"
     by (simp add: min_def order.antisym add_right_mono)
   have "(\<lambda>x. f x + k) ` S = (\<lambda>y. y + k) ` (f ` S)" by auto
   also have "Min \<dots> = Min (f ` S) + k"
     using assms hom_Min_commute [of "\<lambda>y. y+k" "f ` S", OF m, symmetric] by simp
   finally show ?thesis by simp
 qed
 
 lemma Max_add_commute:
   fixes k
   assumes "finite S" and "S \<noteq> {}"
   shows "Max ((\<lambda>x. f x + k) ` S) = Max(f ` S) + k"
 proof -
   have m: "\<And>x y. max x y + k = max (x+k) (y+k)"
     by (simp add: max_def order.antisym add_right_mono)
   have "(\<lambda>x. f x + k) ` S = (\<lambda>y. y + k) ` (f ` S)" by auto
   also have "Max \<dots> = Max (f ` S) + k"
     using assms hom_Max_commute [of "\<lambda>y. y+k" "f ` S", OF m, symmetric] by simp
   finally show ?thesis by simp
 qed
 
 end
 
 context linordered_ab_group_add
 begin
 
 lemma minus_Max_eq_Min [simp]:
   "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - Max S = Min (uminus ` S)"
   by (induct S rule: finite_ne_induct) (simp_all add: minus_max_eq_min)
 
 lemma minus_Min_eq_Max [simp]:
   "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> - Min S = Max (uminus ` S)"
   by (induct S rule: finite_ne_induct) (simp_all add: minus_min_eq_max)
 
 end
 
 context complete_linorder
 begin
 
 lemma Min_Inf:
   assumes "finite A" and "A \<noteq> {}"
   shows "Min A = Inf A"
 proof -
   from assms obtain b B where "A = insert b B" and "finite B" by auto
   then show ?thesis
     by (simp add: Min.eq_fold complete_linorder_inf_min [symmetric] inf_Inf_fold_inf inf.commute [of b])
 qed
 
 lemma Max_Sup:
   assumes "finite A" and "A \<noteq> {}"
   shows "Max A = Sup A"
 proof -
   from assms obtain b B where "A = insert b B" and "finite B" by auto
   then show ?thesis
     by (simp add: Max.eq_fold complete_linorder_sup_max [symmetric] sup_Sup_fold_sup sup.commute [of b])
 qed
 
 end
 
 lemma disjnt_ge_max: \<^marker>\<open>contributor \<open>Lars Hupel\<close>\<close>
   \<open>disjnt X Y\<close> if \<open>finite Y\<close> \<open>\<And>x. x \<in> X \<Longrightarrow> x > Max Y\<close>
   using that by (auto simp add: disjnt_def) (use Max_less_iff in blast)
 
 
 subsection \<open>Arg Min\<close>
 
 context ord
 begin
 
 definition is_arg_min :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool" where
 "is_arg_min f P x = (P x \<and> \<not>(\<exists>y. P y \<and> f y < f x))"
 
 definition arg_min :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b" where
 "arg_min f P = (SOME x. is_arg_min f P x)"
 
 definition arg_min_on :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'b" where
 "arg_min_on f S = arg_min f (\<lambda>x. x \<in> S)"
 
 end
 
 syntax
   "_arg_min" :: "('b \<Rightarrow> 'a) \<Rightarrow> pttrn \<Rightarrow> bool \<Rightarrow> 'b"
     ("(3ARG'_MIN _ _./ _)" [1000, 0, 10] 10)
 translations
   "ARG_MIN f x. P" \<rightleftharpoons> "CONST arg_min f (\<lambda>x. P)"
 
 lemma is_arg_min_linorder: fixes f :: "'a \<Rightarrow> 'b :: linorder"
 shows "is_arg_min f P x = (P x \<and> (\<forall>y. P y \<longrightarrow> f x \<le> f y))"
 by(auto simp add: is_arg_min_def)
 
 lemma is_arg_min_antimono: fixes f :: "'a \<Rightarrow> ('b::order)"
 shows "\<lbrakk> is_arg_min f P x; f y \<le> f x; P y \<rbrakk> \<Longrightarrow> is_arg_min f P y"
 by (simp add: order.order_iff_strict is_arg_min_def)
 
 lemma arg_minI:
   "\<lbrakk> P x;
     \<And>y. P y \<Longrightarrow> \<not> f y < f x;
     \<And>x. \<lbrakk> P x; \<forall>y. P y \<longrightarrow> \<not> f y < f x \<rbrakk> \<Longrightarrow> Q x \<rbrakk>
   \<Longrightarrow> Q (arg_min f P)"
 apply (simp add: arg_min_def is_arg_min_def)
 apply (rule someI2_ex)
  apply blast
 apply blast
 done
 
 lemma arg_min_equality:
   "\<lbrakk> P k; \<And>x. P x \<Longrightarrow> f k \<le> f x \<rbrakk> \<Longrightarrow> f (arg_min f P) = f k"
   for f :: "_ \<Rightarrow> 'a::order"
 apply (rule arg_minI)
   apply assumption
  apply (simp add: less_le_not_le)
 by (metis le_less)
 
 lemma wf_linord_ex_has_least:
   "\<lbrakk> wf r; \<forall>x y. (x, y) \<in> r\<^sup>+ \<longleftrightarrow> (y, x) \<notin> r\<^sup>*; P k \<rbrakk>
    \<Longrightarrow> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> (m x, m y) \<in> r\<^sup>*)"
 apply (drule wf_trancl [THEN wf_eq_minimal [THEN iffD1]])
 apply (drule_tac x = "m ` Collect P" in spec)
 by force
 
 lemma ex_has_least_nat: "P k \<Longrightarrow> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> m x \<le> m y)"
   for m :: "'a \<Rightarrow> nat"
 apply (simp only: pred_nat_trancl_eq_le [symmetric])
 apply (rule wf_pred_nat [THEN wf_linord_ex_has_least])
  apply (simp add: less_eq linorder_not_le pred_nat_trancl_eq_le)
 by assumption
 
 lemma arg_min_nat_lemma:
   "P k \<Longrightarrow> P(arg_min m P) \<and> (\<forall>y. P y \<longrightarrow> m (arg_min m P) \<le> m y)"
   for m :: "'a \<Rightarrow> nat"
 apply (simp add: arg_min_def is_arg_min_linorder)
 apply (rule someI_ex)
 apply (erule ex_has_least_nat)
 done
 
 lemmas arg_min_natI = arg_min_nat_lemma [THEN conjunct1]
 
 lemma is_arg_min_arg_min_nat: fixes m :: "'a \<Rightarrow> nat"
 shows "P x \<Longrightarrow> is_arg_min m P (arg_min m P)"
 by (metis arg_min_nat_lemma is_arg_min_linorder)
 
 lemma arg_min_nat_le: "P x \<Longrightarrow> m (arg_min m P) \<le> m x"
   for m :: "'a \<Rightarrow> nat"
 by (rule arg_min_nat_lemma [THEN conjunct2, THEN spec, THEN mp])
 
 lemma ex_min_if_finite:
   "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>m\<in>S. \<not>(\<exists>x\<in>S. x < (m::'a::order))"
 by(induction rule: finite.induct) (auto intro: order.strict_trans)
 
 lemma ex_is_arg_min_if_finite: fixes f :: "'a \<Rightarrow> 'b :: order"
 shows "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> \<exists>x. is_arg_min f (\<lambda>x. x \<in> S) x"
 unfolding is_arg_min_def
 using ex_min_if_finite[of "f ` S"]
 by auto
 
 lemma arg_min_SOME_Min:
   "finite S \<Longrightarrow> arg_min_on f S = (SOME y. y \<in> S \<and> f y = Min(f ` S))"
 unfolding arg_min_on_def arg_min_def is_arg_min_linorder
 apply(rule arg_cong[where f = Eps])
 apply (auto simp: fun_eq_iff intro: Min_eqI[symmetric])
 done
 
 lemma arg_min_if_finite: fixes f :: "'a \<Rightarrow> 'b :: order"
 assumes "finite S" "S \<noteq> {}"
 shows  "arg_min_on f S \<in> S" and "\<not>(\<exists>x\<in>S. f x < f (arg_min_on f S))"
 using ex_is_arg_min_if_finite[OF assms, of f]
 unfolding arg_min_on_def arg_min_def is_arg_min_def
 by(auto dest!: someI_ex)
 
 lemma arg_min_least: fixes f :: "'a \<Rightarrow> 'b :: linorder"
 shows "\<lbrakk> finite S;  S \<noteq> {};  y \<in> S \<rbrakk> \<Longrightarrow> f(arg_min_on f S) \<le> f y"
 by(simp add: arg_min_SOME_Min inv_into_def2[symmetric] f_inv_into_f)
 
 lemma arg_min_inj_eq: fixes f :: "'a \<Rightarrow> 'b :: order"
 shows "\<lbrakk> inj_on f {x. P x}; P a; \<forall>y. P y \<longrightarrow> f a \<le> f y \<rbrakk> \<Longrightarrow> arg_min f P = a"
 apply(simp add: arg_min_def is_arg_min_def)
 apply(rule someI2[of _ a])
  apply (simp add: less_le_not_le)
 by (metis inj_on_eq_iff less_le mem_Collect_eq)
 
 
 subsection \<open>Arg Max\<close>
 
 context ord
 begin
 
 definition is_arg_max :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> bool" where
 "is_arg_max f P x = (P x \<and> \<not>(\<exists>y. P y \<and> f y > f x))"
 
 definition arg_max :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b" where
 "arg_max f P = (SOME x. is_arg_max f P x)"
 
 definition arg_max_on :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b set \<Rightarrow> 'b" where
 "arg_max_on f S = arg_max f (\<lambda>x. x \<in> S)"
 
 end
 
 syntax
   "_arg_max" :: "('b \<Rightarrow> 'a) \<Rightarrow> pttrn \<Rightarrow> bool \<Rightarrow> 'a"
     ("(3ARG'_MAX _ _./ _)" [1000, 0, 10] 10)
 translations
   "ARG_MAX f x. P" \<rightleftharpoons> "CONST arg_max f (\<lambda>x. P)"
 
 lemma is_arg_max_linorder: fixes f :: "'a \<Rightarrow> 'b :: linorder"
 shows "is_arg_max f P x = (P x \<and> (\<forall>y. P y \<longrightarrow> f x \<ge> f y))"
 by(auto simp add: is_arg_max_def)
 
 lemma arg_maxI:
   "P x \<Longrightarrow>
     (\<And>y. P y \<Longrightarrow> \<not> f y > f x) \<Longrightarrow>
     (\<And>x. P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> \<not> f y > f x \<Longrightarrow> Q x) \<Longrightarrow>
     Q (arg_max f P)"
 apply (simp add: arg_max_def is_arg_max_def)
 apply (rule someI2_ex)
  apply blast
 apply blast
 done
 
 lemma arg_max_equality:
   "\<lbrakk> P k; \<And>x. P x \<Longrightarrow> f x \<le> f k \<rbrakk> \<Longrightarrow> f (arg_max f P) = f k"
   for f :: "_ \<Rightarrow> 'a::order"
 apply (rule arg_maxI [where f = f])
   apply assumption
  apply (simp add: less_le_not_le)
 by (metis le_less)
 
 lemma ex_has_greatest_nat_lemma:
   "P k \<Longrightarrow> \<forall>x. P x \<longrightarrow> (\<exists>y. P y \<and> \<not> f y \<le> f x) \<Longrightarrow> \<exists>y. P y \<and> \<not> f y < f k + n"
   for f :: "'a \<Rightarrow> nat"
-by (induct n) (force simp: le_Suc_eq)+
+  by (induct n) (force simp: le_Suc_eq)+
 
 lemma ex_has_greatest_nat:
-  "P k \<Longrightarrow> \<forall>y. P y \<longrightarrow> f y < b \<Longrightarrow> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> f y \<le> f x)"
-  for f :: "'a \<Rightarrow> nat"
-apply (rule ccontr)
-apply (cut_tac P = P and n = "b - f k" in ex_has_greatest_nat_lemma)
-  apply (subgoal_tac [3] "f k \<le> b")
-   apply auto
-done
+  assumes "P k"
+    and "\<forall>y. P y \<longrightarrow> (f:: 'a \<Rightarrow> nat) y < b"
+shows "\<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> f y \<le> f x)"
+proof (rule ccontr)
+  assume "\<nexists>x. P x \<and> (\<forall>y. P y \<longrightarrow> f y \<le> f x)"
+  then have "\<forall>x. P x \<longrightarrow> (\<exists>y. P y \<and> \<not> f y \<le> f x)"
+    by auto
+  then have "\<exists>y. P y \<and> \<not> f y < f k + (b - f k)"
+    using assms ex_has_greatest_nat_lemma[of P k f "b - f k"]
+    by blast
+  then show "False"
+    using assms by auto
+qed
 
 lemma arg_max_nat_lemma:
   "\<lbrakk> P k;  \<forall>y. P y \<longrightarrow> f y < b \<rbrakk>
   \<Longrightarrow> P (arg_max f P) \<and> (\<forall>y. P y \<longrightarrow> f y \<le> f (arg_max f P))"
   for f :: "'a \<Rightarrow> nat"
 apply (simp add: arg_max_def is_arg_max_linorder)
 apply (rule someI_ex)
 apply (erule (1) ex_has_greatest_nat)
 done
 
 lemmas arg_max_natI = arg_max_nat_lemma [THEN conjunct1]
 
 lemma arg_max_nat_le: "P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> f y < b \<Longrightarrow> f x \<le> f (arg_max f P)"
   for f :: "'a \<Rightarrow> nat"
 by (blast dest: arg_max_nat_lemma [THEN conjunct2, THEN spec, of P])
 
 end
diff --git a/src/HOL/Nat.thy b/src/HOL/Nat.thy
--- a/src/HOL/Nat.thy
+++ b/src/HOL/Nat.thy
@@ -1,2560 +1,2572 @@
 (*  Title:      HOL/Nat.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
 *)
 
 section \<open>Natural numbers\<close>
 
 theory Nat
 imports Inductive Typedef Fun Rings
 begin
 
 subsection \<open>Type \<open>ind\<close>\<close>
 
 typedecl ind
 
 axiomatization Zero_Rep :: ind and Suc_Rep :: "ind \<Rightarrow> ind"
   \<comment> \<open>The axiom of infinity in 2 parts:\<close>
   where Suc_Rep_inject: "Suc_Rep x = Suc_Rep y \<Longrightarrow> x = y"
     and Suc_Rep_not_Zero_Rep: "Suc_Rep x \<noteq> Zero_Rep"
 
 
 subsection \<open>Type nat\<close>
 
 text \<open>Type definition\<close>
 
 inductive Nat :: "ind \<Rightarrow> bool"
   where
     Zero_RepI: "Nat Zero_Rep"
   | Suc_RepI: "Nat i \<Longrightarrow> Nat (Suc_Rep i)"
 
 typedef nat = "{n. Nat n}"
   morphisms Rep_Nat Abs_Nat
   using Nat.Zero_RepI by auto
 
 lemma Nat_Rep_Nat: "Nat (Rep_Nat n)"
   using Rep_Nat by simp
 
 lemma Nat_Abs_Nat_inverse: "Nat n \<Longrightarrow> Rep_Nat (Abs_Nat n) = n"
   using Abs_Nat_inverse by simp
 
 lemma Nat_Abs_Nat_inject: "Nat n \<Longrightarrow> Nat m \<Longrightarrow> Abs_Nat n = Abs_Nat m \<longleftrightarrow> n = m"
   using Abs_Nat_inject by simp
 
 instantiation nat :: zero
 begin
 
 definition Zero_nat_def: "0 = Abs_Nat Zero_Rep"
 
 instance ..
 
 end
 
 definition Suc :: "nat \<Rightarrow> nat"
   where "Suc n = Abs_Nat (Suc_Rep (Rep_Nat n))"
 
 lemma Suc_not_Zero: "Suc m \<noteq> 0"
   by (simp add: Zero_nat_def Suc_def Suc_RepI Zero_RepI
       Nat_Abs_Nat_inject Suc_Rep_not_Zero_Rep Nat_Rep_Nat)
 
 lemma Zero_not_Suc: "0 \<noteq> Suc m"
   by (rule not_sym) (rule Suc_not_Zero)
 
 lemma Suc_Rep_inject': "Suc_Rep x = Suc_Rep y \<longleftrightarrow> x = y"
   by (rule iffI, rule Suc_Rep_inject) simp_all
 
 lemma nat_induct0:
   assumes "P 0" and "\<And>n. P n \<Longrightarrow> P (Suc n)"
   shows "P n"
 proof -
   have "P (Abs_Nat (Rep_Nat n))"
     using assms unfolding Zero_nat_def Suc_def
     by (iprover intro:  Nat_Rep_Nat [THEN Nat.induct] elim: Nat_Abs_Nat_inverse [THEN subst])
   then show ?thesis
     by (simp add: Rep_Nat_inverse)
 qed
 
 free_constructors case_nat for "0 :: nat" | Suc pred
   where "pred (0 :: nat) = (0 :: nat)"
-    apply atomize_elim
-    apply (rename_tac n, induct_tac n rule: nat_induct0, auto)
-   apply (simp add: Suc_def Nat_Abs_Nat_inject Nat_Rep_Nat Suc_RepI Suc_Rep_inject' Rep_Nat_inject)
-  apply (simp only: Suc_not_Zero)
-  done
+proof atomize_elim
+  fix n
+  show "n = 0 \<or> (\<exists>m. n = Suc m)"
+    by (induction n rule: nat_induct0) auto
+next
+  fix n m
+  show "(Suc n = Suc m) = (n = m)"
+    by (simp add: Suc_def Nat_Abs_Nat_inject Nat_Rep_Nat Suc_RepI Suc_Rep_inject' Rep_Nat_inject)
+next
+  fix n
+  show "0 \<noteq> Suc n"
+    by (simp add: Suc_not_Zero)
+qed
+
 
 \<comment> \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype "0 :: nat" Suc
   by (erule nat_induct0) auto
 
 setup \<open>Sign.parent_path\<close>
 
 \<comment> \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 setup \<open>Sign.mandatory_path "nat"\<close>
 
 declare old.nat.inject[iff del]
   and old.nat.distinct(1)[simp del, induct_simp del]
 
 lemmas induct = old.nat.induct
 lemmas inducts = old.nat.inducts
 lemmas rec = old.nat.rec
 lemmas simps = nat.inject nat.distinct nat.case nat.rec
 
 setup \<open>Sign.parent_path\<close>
 
 abbreviation rec_nat :: "'a \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a"
   where "rec_nat \<equiv> old.rec_nat"
 
 declare nat.sel[code del]
 
 hide_const (open) Nat.pred \<comment> \<open>hide everything related to the selector\<close>
 hide_fact
   nat.case_eq_if
   nat.collapse
   nat.expand
   nat.sel
   nat.exhaust_sel
   nat.split_sel
   nat.split_sel_asm
 
 lemma nat_exhaust [case_names 0 Suc, cases type: nat]:
   "(y = 0 \<Longrightarrow> P) \<Longrightarrow> (\<And>nat. y = Suc nat \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   by (rule old.nat.exhaust)
 
 lemma nat_induct [case_names 0 Suc, induct type: nat]:
   fixes n
   assumes "P 0" and "\<And>n. P n \<Longrightarrow> P (Suc n)"
   shows "P n"
   \<comment> \<open>for backward compatibility -- names of variables differ\<close>
   using assms by (rule nat.induct)
 
 hide_fact
   nat_exhaust
   nat_induct0
 
 ML \<open>
 val nat_basic_lfp_sugar =
   let
     val ctr_sugar = the (Ctr_Sugar.ctr_sugar_of_global \<^theory> \<^type_name>\<open>nat\<close>);
     val recx = Logic.varify_types_global \<^term>\<open>rec_nat\<close>;
     val C = body_type (fastype_of recx);
   in
     {T = HOLogic.natT, fp_res_index = 0, C = C, fun_arg_Tsss = [[], [[HOLogic.natT, C]]],
      ctr_sugar = ctr_sugar, recx = recx, rec_thms = @{thms nat.rec}}
   end;
 \<close>
 
 setup \<open>
 let
   fun basic_lfp_sugars_of _ [\<^typ>\<open>nat\<close>] _ _ ctxt =
       ([], [0], [nat_basic_lfp_sugar], [], [], [], TrueI (*dummy*), [], false, ctxt)
     | basic_lfp_sugars_of bs arg_Ts callers callssss ctxt =
       BNF_LFP_Rec_Sugar.default_basic_lfp_sugars_of bs arg_Ts callers callssss ctxt;
 in
   BNF_LFP_Rec_Sugar.register_lfp_rec_extension
     {nested_simps = [], special_endgame_tac = K (K (K (K no_tac))), is_new_datatype = K (K true),
      basic_lfp_sugars_of = basic_lfp_sugars_of, rewrite_nested_rec_call = NONE}
 end
 \<close>
 
 text \<open>Injectiveness and distinctness lemmas\<close>
 
 lemma inj_Suc [simp]:
   "inj_on Suc N"
   by (simp add: inj_on_def)
 
 lemma bij_betw_Suc [simp]:
   "bij_betw Suc M N \<longleftrightarrow> Suc ` M = N"
   by (simp add: bij_betw_def)
 
 lemma Suc_neq_Zero: "Suc m = 0 \<Longrightarrow> R"
   by (rule notE) (rule Suc_not_Zero)
 
 lemma Zero_neq_Suc: "0 = Suc m \<Longrightarrow> R"
   by (rule Suc_neq_Zero) (erule sym)
 
 lemma Suc_inject: "Suc x = Suc y \<Longrightarrow> x = y"
   by (rule inj_Suc [THEN injD])
 
 lemma n_not_Suc_n: "n \<noteq> Suc n"
   by (induct n) simp_all
 
 lemma Suc_n_not_n: "Suc n \<noteq> n"
   by (rule not_sym) (rule n_not_Suc_n)
 
 text \<open>A special form of induction for reasoning about \<^term>\<open>m < n\<close> and \<^term>\<open>m - n\<close>.\<close>
 lemma diff_induct:
   assumes "\<And>x. P x 0"
     and "\<And>y. P 0 (Suc y)"
     and "\<And>x y. P x y \<Longrightarrow> P (Suc x) (Suc y)"
   shows "P m n"
 proof (induct n arbitrary: m)
   case 0
   show ?case by (rule assms(1))
 next
   case (Suc n)
   show ?case
   proof (induct m)
     case 0
     show ?case by (rule assms(2))
   next
     case (Suc m)
     from \<open>P m n\<close> show ?case by (rule assms(3))
   qed
 qed
 
 
 subsection \<open>Arithmetic operators\<close>
 
 instantiation nat :: comm_monoid_diff
 begin
 
 primrec plus_nat
   where
     add_0: "0 + n = (n::nat)"
   | add_Suc: "Suc m + n = Suc (m + n)"
 
 lemma add_0_right [simp]: "m + 0 = m"
   for m :: nat
   by (induct m) simp_all
 
 lemma add_Suc_right [simp]: "m + Suc n = Suc (m + n)"
   by (induct m) simp_all
 
 declare add_0 [code]
 
 lemma add_Suc_shift [code]: "Suc m + n = m + Suc n"
   by simp
 
 primrec minus_nat
   where
     diff_0 [code]: "m - 0 = (m::nat)"
   | diff_Suc: "m - Suc n = (case m - n of 0 \<Rightarrow> 0 | Suc k \<Rightarrow> k)"
 
 declare diff_Suc [simp del]
 
 lemma diff_0_eq_0 [simp, code]: "0 - n = 0"
   for n :: nat
   by (induct n) (simp_all add: diff_Suc)
 
 lemma diff_Suc_Suc [simp, code]: "Suc m - Suc n = m - n"
   by (induct n) (simp_all add: diff_Suc)
 
 instance
 proof
   fix n m q :: nat
   show "(n + m) + q = n + (m + q)" by (induct n) simp_all
   show "n + m = m + n" by (induct n) simp_all
   show "m + n - m = n" by (induct m) simp_all
   show "n - m - q = n - (m + q)" by (induct q) (simp_all add: diff_Suc)
   show "0 + n = n" by simp
   show "0 - n = 0" by simp
 qed
 
 end
 
 hide_fact (open) add_0 add_0_right diff_0
 
 instantiation nat :: comm_semiring_1_cancel
 begin
 
 definition One_nat_def [simp]: "1 = Suc 0"
 
 primrec times_nat
   where
     mult_0: "0 * n = (0::nat)"
   | mult_Suc: "Suc m * n = n + (m * n)"
 
 lemma mult_0_right [simp]: "m * 0 = 0"
   for m :: nat
   by (induct m) simp_all
 
 lemma mult_Suc_right [simp]: "m * Suc n = m + (m * n)"
   by (induct m) (simp_all add: add.left_commute)
 
 lemma add_mult_distrib: "(m + n) * k = (m * k) + (n * k)"
   for m n k :: nat
   by (induct m) (simp_all add: add.assoc)
 
 instance
 proof
   fix k n m q :: nat
   show "0 \<noteq> (1::nat)"
     by simp
   show "1 * n = n"
     by simp
   show "n * m = m * n"
     by (induct n) simp_all
   show "(n * m) * q = n * (m * q)"
     by (induct n) (simp_all add: add_mult_distrib)
   show "(n + m) * q = n * q + m * q"
     by (rule add_mult_distrib)
   show "k * (m - n) = (k * m) - (k * n)"
     by (induct m n rule: diff_induct) simp_all
 qed
 
 end
 
 
 subsubsection \<open>Addition\<close>
 
 text \<open>Reasoning about \<open>m + 0 = 0\<close>, etc.\<close>
 
 lemma add_is_0 [iff]: "m + n = 0 \<longleftrightarrow> m = 0 \<and> n = 0"
   for m n :: nat
   by (cases m) simp_all
 
 lemma add_is_1: "m + n = Suc 0 \<longleftrightarrow> m = Suc 0 \<and> n = 0 \<or> m = 0 \<and> n = Suc 0"
   by (cases m) simp_all
 
 lemma one_is_add: "Suc 0 = m + n \<longleftrightarrow> m = Suc 0 \<and> n = 0 \<or> m = 0 \<and> n = Suc 0"
   by (rule trans, rule eq_commute, rule add_is_1)
 
 lemma add_eq_self_zero: "m + n = m \<Longrightarrow> n = 0"
   for m n :: nat
   by (induct m) simp_all
 
 lemma plus_1_eq_Suc:
   "plus 1 = Suc"
   by (simp add: fun_eq_iff)
 
 lemma Suc_eq_plus1: "Suc n = n + 1"
   by simp
 
 lemma Suc_eq_plus1_left: "Suc n = 1 + n"
   by simp
 
 
 subsubsection \<open>Difference\<close>
 
 lemma Suc_diff_diff [simp]: "(Suc m - n) - Suc k = m - n - k"
   by (simp add: diff_diff_add)
 
 lemma diff_Suc_1 [simp]: "Suc n - 1 = n"
   by simp
 
 
 subsubsection \<open>Multiplication\<close>
 
 lemma mult_is_0 [simp]: "m * n = 0 \<longleftrightarrow> m = 0 \<or> n = 0" for m n :: nat
   by (induct m) auto
 
 lemma mult_eq_1_iff [simp]: "m * n = Suc 0 \<longleftrightarrow> m = Suc 0 \<and> n = Suc 0"
 proof (induct m)
   case 0
   then show ?case by simp
 next
   case (Suc m)
   then show ?case by (induct n) auto
 qed
 
 lemma one_eq_mult_iff [simp]: "Suc 0 = m * n \<longleftrightarrow> m = Suc 0 \<and> n = Suc 0"
   by (simp add: eq_commute flip: mult_eq_1_iff)
 
 lemma nat_mult_eq_1_iff [simp]: "m * n = 1 \<longleftrightarrow> m = 1 \<and> n = 1" 
   and nat_1_eq_mult_iff [simp]: "1 = m * n \<longleftrightarrow> m = 1 \<and> n = 1" for m n :: nat
   by auto
 
 lemma mult_cancel1 [simp]: "k * m = k * n \<longleftrightarrow> m = n \<or> k = 0"
   for k m n :: nat
 proof -
   have "k \<noteq> 0 \<Longrightarrow> k * m = k * n \<Longrightarrow> m = n"
   proof (induct n arbitrary: m)
     case 0
     then show "m = 0" by simp
   next
     case (Suc n)
     then show "m = Suc n"
       by (cases m) (simp_all add: eq_commute [of 0])
   qed
   then show ?thesis by auto
 qed
 
 lemma mult_cancel2 [simp]: "m * k = n * k \<longleftrightarrow> m = n \<or> k = 0"
   for k m n :: nat
   by (simp add: mult.commute)
 
 lemma Suc_mult_cancel1: "Suc k * m = Suc k * n \<longleftrightarrow> m = n"
   by (subst mult_cancel1) simp
 
 
 subsection \<open>Orders on \<^typ>\<open>nat\<close>\<close>
 
 subsubsection \<open>Operation definition\<close>
 
 instantiation nat :: linorder
 begin
 
 primrec less_eq_nat
   where
     "(0::nat) \<le> n \<longleftrightarrow> True"
   | "Suc m \<le> n \<longleftrightarrow> (case n of 0 \<Rightarrow> False | Suc n \<Rightarrow> m \<le> n)"
 
 declare less_eq_nat.simps [simp del]
 
 lemma le0 [iff]: "0 \<le> n" for
   n :: nat
   by (simp add: less_eq_nat.simps)
 
 lemma [code]: "0 \<le> n \<longleftrightarrow> True"
   for n :: nat
   by simp
 
 definition less_nat
   where less_eq_Suc_le: "n < m \<longleftrightarrow> Suc n \<le> m"
 
 lemma Suc_le_mono [iff]: "Suc n \<le> Suc m \<longleftrightarrow> n \<le> m"
   by (simp add: less_eq_nat.simps(2))
 
 lemma Suc_le_eq [code]: "Suc m \<le> n \<longleftrightarrow> m < n"
   unfolding less_eq_Suc_le ..
 
 lemma le_0_eq [iff]: "n \<le> 0 \<longleftrightarrow> n = 0"
   for n :: nat
   by (induct n) (simp_all add: less_eq_nat.simps(2))
 
 lemma not_less0 [iff]: "\<not> n < 0"
   for n :: nat
   by (simp add: less_eq_Suc_le)
 
 lemma less_nat_zero_code [code]: "n < 0 \<longleftrightarrow> False"
   for n :: nat
   by simp
 
 lemma Suc_less_eq [iff]: "Suc m < Suc n \<longleftrightarrow> m < n"
   by (simp add: less_eq_Suc_le)
 
 lemma less_Suc_eq_le [code]: "m < Suc n \<longleftrightarrow> m \<le> n"
   by (simp add: less_eq_Suc_le)
 
 lemma Suc_less_eq2: "Suc n < m \<longleftrightarrow> (\<exists>m'. m = Suc m' \<and> n < m')"
   by (cases m) auto
 
 lemma le_SucI: "m \<le> n \<Longrightarrow> m \<le> Suc n"
   by (induct m arbitrary: n) (simp_all add: less_eq_nat.simps(2) split: nat.splits)
 
 lemma Suc_leD: "Suc m \<le> n \<Longrightarrow> m \<le> n"
   by (cases n) (auto intro: le_SucI)
 
 lemma less_SucI: "m < n \<Longrightarrow> m < Suc n"
   by (simp add: less_eq_Suc_le) (erule Suc_leD)
 
 lemma Suc_lessD: "Suc m < n \<Longrightarrow> m < n"
   by (simp add: less_eq_Suc_le) (erule Suc_leD)
 
 instance
 proof
   fix n m q :: nat
   show "n < m \<longleftrightarrow> n \<le> m \<and> \<not> m \<le> n"
   proof (induct n arbitrary: m)
     case 0
     then show ?case
       by (cases m) (simp_all add: less_eq_Suc_le)
   next
     case (Suc n)
     then show ?case
       by (cases m) (simp_all add: less_eq_Suc_le)
   qed
   show "n \<le> n"
     by (induct n) simp_all
   then show "n = m" if "n \<le> m" and "m \<le> n"
     using that by (induct n arbitrary: m)
       (simp_all add: less_eq_nat.simps(2) split: nat.splits)
   show "n \<le> q" if "n \<le> m" and "m \<le> q"
     using that
   proof (induct n arbitrary: m q)
     case 0
     show ?case by simp
   next
     case (Suc n)
     then show ?case
       by (simp_all (no_asm_use) add: less_eq_nat.simps(2) split: nat.splits, clarify,
         simp_all (no_asm_use) add: less_eq_nat.simps(2) split: nat.splits, clarify,
         simp_all (no_asm_use) add: less_eq_nat.simps(2) split: nat.splits)
   qed
   show "n \<le> m \<or> m \<le> n"
     by (induct n arbitrary: m)
       (simp_all add: less_eq_nat.simps(2) split: nat.splits)
 qed
 
 end
 
 instantiation nat :: order_bot
 begin
 
 definition bot_nat :: nat
   where "bot_nat = 0"
 
 instance
   by standard (simp add: bot_nat_def)
 
 end
 
 instance nat :: no_top
   by standard (auto intro: less_Suc_eq_le [THEN iffD2])
 
 
 subsubsection \<open>Introduction properties\<close>
 
 lemma lessI [iff]: "n < Suc n"
   by (simp add: less_Suc_eq_le)
 
 lemma zero_less_Suc [iff]: "0 < Suc n"
   by (simp add: less_Suc_eq_le)
 
 
 subsubsection \<open>Elimination properties\<close>
 
 lemma less_not_refl: "\<not> n < n"
   for n :: nat
   by (rule order_less_irrefl)
 
 lemma less_not_refl2: "n < m \<Longrightarrow> m \<noteq> n"
   for m n :: nat
   by (rule not_sym) (rule less_imp_neq)
 
 lemma less_not_refl3: "s < t \<Longrightarrow> s \<noteq> t"
   for s t :: nat
   by (rule less_imp_neq)
 
 lemma less_irrefl_nat: "n < n \<Longrightarrow> R"
   for n :: nat
   by (rule notE, rule less_not_refl)
 
 lemma less_zeroE: "n < 0 \<Longrightarrow> R"
   for n :: nat
   by (rule notE) (rule not_less0)
 
 lemma less_Suc_eq: "m < Suc n \<longleftrightarrow> m < n \<or> m = n"
   unfolding less_Suc_eq_le le_less ..
 
 lemma less_Suc0 [iff]: "(n < Suc 0) = (n = 0)"
   by (simp add: less_Suc_eq)
 
 lemma less_one [iff]: "n < 1 \<longleftrightarrow> n = 0"
   for n :: nat
   unfolding One_nat_def by (rule less_Suc0)
 
 lemma Suc_mono: "m < n \<Longrightarrow> Suc m < Suc n"
   by simp
 
 text \<open>"Less than" is antisymmetric, sort of.\<close>
 lemma less_antisym: "\<not> n < m \<Longrightarrow> n < Suc m \<Longrightarrow> m = n"
   unfolding not_less less_Suc_eq_le by (rule antisym)
 
 lemma nat_neq_iff: "m \<noteq> n \<longleftrightarrow> m < n \<or> n < m"
   for m n :: nat
   by (rule linorder_neq_iff)
 
 
 subsubsection \<open>Inductive (?) properties\<close>
 
 lemma Suc_lessI: "m < n \<Longrightarrow> Suc m \<noteq> n \<Longrightarrow> Suc m < n"
   unfolding less_eq_Suc_le [of m] le_less by simp
 
 lemma lessE:
   assumes major: "i < k"
     and 1: "k = Suc i \<Longrightarrow> P"
     and 2: "\<And>j. i < j \<Longrightarrow> k = Suc j \<Longrightarrow> P"
   shows P
 proof -
   from major have "\<exists>j. i \<le> j \<and> k = Suc j"
     unfolding less_eq_Suc_le by (induct k) simp_all
   then have "(\<exists>j. i < j \<and> k = Suc j) \<or> k = Suc i"
     by (auto simp add: less_le)
   with 1 2 show P by auto
 qed
 
 lemma less_SucE:
   assumes major: "m < Suc n"
     and less: "m < n \<Longrightarrow> P"
     and eq: "m = n \<Longrightarrow> P"
   shows P
 proof (rule major [THEN lessE])
   show "Suc n = Suc m \<Longrightarrow> P"
     using eq by blast
   show "\<And>j. \<lbrakk>m < j; Suc n = Suc j\<rbrakk> \<Longrightarrow> P"
     by (blast intro: less)
 qed
 
 lemma Suc_lessE:
   assumes major: "Suc i < k"
     and minor: "\<And>j. i < j \<Longrightarrow> k = Suc j \<Longrightarrow> P"
   shows P
 proof (rule major [THEN lessE])
   show "k = Suc (Suc i) \<Longrightarrow> P"
     using lessI minor by iprover
   show "\<And>j. \<lbrakk>Suc i < j; k = Suc j\<rbrakk> \<Longrightarrow> P"
     using Suc_lessD minor by iprover
 qed
 
 lemma Suc_less_SucD: "Suc m < Suc n \<Longrightarrow> m < n"
   by simp
 
 lemma less_trans_Suc:
   assumes le: "i < j"
   shows "j < k \<Longrightarrow> Suc i < k"
 proof (induct k)
   case 0
   then show ?case by simp
 next
   case (Suc k)
   with le show ?case
     by simp (auto simp add: less_Suc_eq dest: Suc_lessD)
 qed
 
 text \<open>Can be used with \<open>less_Suc_eq\<close> to get \<^prop>\<open>n = m \<or> n < m\<close>.\<close>
 lemma not_less_eq: "\<not> m < n \<longleftrightarrow> n < Suc m"
   by (simp only: not_less less_Suc_eq_le)
 
 lemma not_less_eq_eq: "\<not> m \<le> n \<longleftrightarrow> Suc n \<le> m"
   by (simp only: not_le Suc_le_eq)
 
 text \<open>Properties of "less than or equal".\<close>
 
 lemma le_imp_less_Suc: "m \<le> n \<Longrightarrow> m < Suc n"
   by (simp only: less_Suc_eq_le)
 
 lemma Suc_n_not_le_n: "\<not> Suc n \<le> n"
   by (simp add: not_le less_Suc_eq_le)
 
 lemma le_Suc_eq: "m \<le> Suc n \<longleftrightarrow> m \<le> n \<or> m = Suc n"
   by (simp add: less_Suc_eq_le [symmetric] less_Suc_eq)
 
 lemma le_SucE: "m \<le> Suc n \<Longrightarrow> (m \<le> n \<Longrightarrow> R) \<Longrightarrow> (m = Suc n \<Longrightarrow> R) \<Longrightarrow> R"
   by (drule le_Suc_eq [THEN iffD1], iprover+)
 
 lemma Suc_leI: "m < n \<Longrightarrow> Suc m \<le> n"
   by (simp only: Suc_le_eq)
 
 text \<open>Stronger version of \<open>Suc_leD\<close>.\<close>
 lemma Suc_le_lessD: "Suc m \<le> n \<Longrightarrow> m < n"
   by (simp only: Suc_le_eq)
 
 lemma less_imp_le_nat: "m < n \<Longrightarrow> m \<le> n" for m n :: nat
   unfolding less_eq_Suc_le by (rule Suc_leD)
 
 text \<open>For instance, \<open>(Suc m < Suc n) = (Suc m \<le> n) = (m < n)\<close>\<close>
 lemmas le_simps = less_imp_le_nat less_Suc_eq_le Suc_le_eq
 
 
 text \<open>Equivalence of \<open>m \<le> n\<close> and \<open>m < n \<or> m = n\<close>\<close>
 
 lemma less_or_eq_imp_le: "m < n \<or> m = n \<Longrightarrow> m \<le> n"
   for m n :: nat
   unfolding le_less .
 
 lemma le_eq_less_or_eq: "m \<le> n \<longleftrightarrow> m < n \<or> m = n"
   for m n :: nat
   by (rule le_less)
 
 text \<open>Useful with \<open>blast\<close>.\<close>
 lemma eq_imp_le: "m = n \<Longrightarrow> m \<le> n"
   for m n :: nat
   by auto
 
 lemma le_refl: "n \<le> n"
   for n :: nat
   by simp
 
 lemma le_trans: "i \<le> j \<Longrightarrow> j \<le> k \<Longrightarrow> i \<le> k"
   for i j k :: nat
   by (rule order_trans)
 
 lemma le_antisym: "m \<le> n \<Longrightarrow> n \<le> m \<Longrightarrow> m = n"
   for m n :: nat
   by (rule antisym)
 
 lemma nat_less_le: "m < n \<longleftrightarrow> m \<le> n \<and> m \<noteq> n"
   for m n :: nat
   by (rule less_le)
 
 lemma le_neq_implies_less: "m \<le> n \<Longrightarrow> m \<noteq> n \<Longrightarrow> m < n"
   for m n :: nat
   unfolding less_le ..
 
 lemma nat_le_linear: "m \<le> n \<or> n \<le> m"
   for m n :: nat
   by (rule linear)
 
 lemmas linorder_neqE_nat = linorder_neqE [where 'a = nat]
 
 lemma le_less_Suc_eq: "m \<le> n \<Longrightarrow> n < Suc m \<longleftrightarrow> n = m"
   unfolding less_Suc_eq_le by auto
 
 lemma not_less_less_Suc_eq: "\<not> n < m \<Longrightarrow> n < Suc m \<longleftrightarrow> n = m"
   unfolding not_less by (rule le_less_Suc_eq)
 
 lemmas not_less_simps = not_less_less_Suc_eq le_less_Suc_eq
 
 lemma not0_implies_Suc: "n \<noteq> 0 \<Longrightarrow> \<exists>m. n = Suc m"
   by (cases n) simp_all
 
 lemma gr0_implies_Suc: "n > 0 \<Longrightarrow> \<exists>m. n = Suc m"
   by (cases n) simp_all
 
 lemma gr_implies_not0: "m < n \<Longrightarrow> n \<noteq> 0"
   for m n :: nat
   by (cases n) simp_all
 
 lemma neq0_conv[iff]: "n \<noteq> 0 \<longleftrightarrow> 0 < n"
   for n :: nat
   by (cases n) simp_all
 
 text \<open>This theorem is useful with \<open>blast\<close>\<close>
 lemma gr0I: "(n = 0 \<Longrightarrow> False) \<Longrightarrow> 0 < n"
   for n :: nat
   by (rule neq0_conv[THEN iffD1]) iprover
 
 lemma gr0_conv_Suc: "0 < n \<longleftrightarrow> (\<exists>m. n = Suc m)"
   by (fast intro: not0_implies_Suc)
 
 lemma not_gr0 [iff]: "\<not> 0 < n \<longleftrightarrow> n = 0"
   for n :: nat
   using neq0_conv by blast
 
 lemma Suc_le_D: "Suc n \<le> m' \<Longrightarrow> \<exists>m. m' = Suc m"
   by (induct m') simp_all
 
 text \<open>Useful in certain inductive arguments\<close>
 lemma less_Suc_eq_0_disj: "m < Suc n \<longleftrightarrow> m = 0 \<or> (\<exists>j. m = Suc j \<and> j < n)"
   by (cases m) simp_all
 
 lemma All_less_Suc: "(\<forall>i < Suc n. P i) = (P n \<and> (\<forall>i < n. P i))"
   by (auto simp: less_Suc_eq)
 
 lemma All_less_Suc2: "(\<forall>i < Suc n. P i) = (P 0 \<and> (\<forall>i < n. P(Suc i)))"
   by (auto simp: less_Suc_eq_0_disj)
 
 lemma Ex_less_Suc: "(\<exists>i < Suc n. P i) = (P n \<or> (\<exists>i < n. P i))"
   by (auto simp: less_Suc_eq)
 
 lemma Ex_less_Suc2: "(\<exists>i < Suc n. P i) = (P 0 \<or> (\<exists>i < n. P(Suc i)))"
   by (auto simp: less_Suc_eq_0_disj)
 
 text \<open>@{term mono} (non-strict) doesn't imply increasing, as the function could be constant\<close>
 lemma strict_mono_imp_increasing:
   fixes n::nat
   assumes "strict_mono f" shows "f n \<ge> n"
 proof (induction n)
   case 0
   then show ?case
     by auto
 next
   case (Suc n)
   then show ?case
     unfolding not_less_eq_eq [symmetric]
     using Suc_n_not_le_n assms order_trans strict_mono_less_eq by blast
 qed
 
 subsubsection \<open>Monotonicity of Addition\<close>
 
 lemma Suc_pred [simp]: "n > 0 \<Longrightarrow> Suc (n - Suc 0) = n"
   by (simp add: diff_Suc split: nat.split)
 
 lemma Suc_diff_1 [simp]: "0 < n \<Longrightarrow> Suc (n - 1) = n"
   unfolding One_nat_def by (rule Suc_pred)
 
 lemma nat_add_left_cancel_le [simp]: "k + m \<le> k + n \<longleftrightarrow> m \<le> n"
   for k m n :: nat
   by (induct k) simp_all
 
 lemma nat_add_left_cancel_less [simp]: "k + m < k + n \<longleftrightarrow> m < n"
   for k m n :: nat
   by (induct k) simp_all
 
 lemma add_gr_0 [iff]: "m + n > 0 \<longleftrightarrow> m > 0 \<or> n > 0"
   for m n :: nat
   by (auto dest: gr0_implies_Suc)
 
 text \<open>strict, in 1st argument\<close>
 lemma add_less_mono1: "i < j \<Longrightarrow> i + k < j + k"
   for i j k :: nat
   by (induct k) simp_all
 
 text \<open>strict, in both arguments\<close>
 lemma add_less_mono: 
   fixes i j k l :: nat
   assumes "i < j" "k < l" shows "i + k < j + l"
 proof -
   have "i + k < j + k"
     by (simp add: add_less_mono1 assms)
   also have "...  < j + l"
     using \<open>i < j\<close> by (induction j) (auto simp: assms)
   finally show ?thesis .
 qed
 
 lemma less_imp_Suc_add: "m < n \<Longrightarrow> \<exists>k. n = Suc (m + k)"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case Suc
   then show ?case
     by (simp add: order_le_less)
       (blast elim!: less_SucE intro!: Nat.add_0_right [symmetric] add_Suc_right [symmetric])
 qed
 
 lemma le_Suc_ex: "k \<le> l \<Longrightarrow> (\<exists>n. l = k + n)"
   for k l :: nat
   by (auto simp: less_Suc_eq_le[symmetric] dest: less_imp_Suc_add)
 
 lemma less_natE:
   assumes \<open>m < n\<close>
   obtains q where \<open>n = Suc (m + q)\<close>
   using assms by (auto dest: less_imp_Suc_add intro: that)
 
 text \<open>strict, in 1st argument; proof is by induction on \<open>k > 0\<close>\<close>
 lemma mult_less_mono2:
   fixes i j :: nat
   assumes "i < j" and "0 < k"
   shows "k * i < k * j"
   using \<open>0 < k\<close>
 proof (induct k)
   case 0
   then show ?case by simp
 next
   case (Suc k)
   with \<open>i < j\<close> show ?case
     by (cases k) (simp_all add: add_less_mono)
 qed
 
 text \<open>Addition is the inverse of subtraction:
   if \<^term>\<open>n \<le> m\<close> then \<^term>\<open>n + (m - n) = m\<close>.\<close>
 lemma add_diff_inverse_nat: "\<not> m < n \<Longrightarrow> n + (m - n) = m"
   for m n :: nat
   by (induct m n rule: diff_induct) simp_all
 
 lemma nat_le_iff_add: "m \<le> n \<longleftrightarrow> (\<exists>k. n = m + k)"
   for m n :: nat
   using nat_add_left_cancel_le[of m 0] by (auto dest: le_Suc_ex)
 
 text \<open>The naturals form an ordered \<open>semidom\<close> and a \<open>dioid\<close>.\<close>
 
 instance nat :: linordered_semidom
 proof
   fix m n q :: nat
   show "0 < (1::nat)"
     by simp
   show "m \<le> n \<Longrightarrow> q + m \<le> q + n"
     by simp
   show "m < n \<Longrightarrow> 0 < q \<Longrightarrow> q * m < q * n"
     by (simp add: mult_less_mono2)
   show "m \<noteq> 0 \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> m * n \<noteq> 0"
     by simp
   show "n \<le> m \<Longrightarrow> (m - n) + n = m"
     by (simp add: add_diff_inverse_nat add.commute linorder_not_less)
 qed
 
 instance nat :: dioid
   by standard (rule nat_le_iff_add)
 
 declare le0[simp del] \<comment> \<open>This is now @{thm zero_le}\<close>
 declare le_0_eq[simp del] \<comment> \<open>This is now @{thm le_zero_eq}\<close>
 declare not_less0[simp del] \<comment> \<open>This is now @{thm not_less_zero}\<close>
 declare not_gr0[simp del] \<comment> \<open>This is now @{thm not_gr_zero}\<close>
 
 instance nat :: ordered_cancel_comm_monoid_add ..
 instance nat :: ordered_cancel_comm_monoid_diff ..
 
 
 subsubsection \<open>\<^term>\<open>min\<close> and \<^term>\<open>max\<close>\<close>
 
 global_interpretation bot_nat_0: ordering_top \<open>(\<ge>)\<close> \<open>(>)\<close> \<open>0::nat\<close>
   by standard simp
 
 global_interpretation max_nat: semilattice_neutr_order max \<open>0::nat\<close> \<open>(\<ge>)\<close> \<open>(>)\<close>
   by standard (simp add: max_def)
 
 lemma mono_Suc: "mono Suc"
   by (rule monoI) simp
 
 lemma min_0L [simp]: "min 0 n = 0"
   for n :: nat
   by (rule min_absorb1) simp
 
 lemma min_0R [simp]: "min n 0 = 0"
   for n :: nat
   by (rule min_absorb2) simp
 
 lemma min_Suc_Suc [simp]: "min (Suc m) (Suc n) = Suc (min m n)"
   by (simp add: mono_Suc min_of_mono)
 
 lemma min_Suc1: "min (Suc n) m = (case m of 0 \<Rightarrow> 0 | Suc m' \<Rightarrow> Suc(min n m'))"
   by (simp split: nat.split)
 
 lemma min_Suc2: "min m (Suc n) = (case m of 0 \<Rightarrow> 0 | Suc m' \<Rightarrow> Suc(min m' n))"
   by (simp split: nat.split)
 
 lemma max_0L [simp]: "max 0 n = n"
   for n :: nat
   by (fact max_nat.left_neutral)
 
 lemma max_0R [simp]: "max n 0 = n"
   for n :: nat
   by (fact max_nat.right_neutral)
 
 lemma max_Suc_Suc [simp]: "max (Suc m) (Suc n) = Suc (max m n)"
   by (simp add: mono_Suc max_of_mono)
 
 lemma max_Suc1: "max (Suc n) m = (case m of 0 \<Rightarrow> Suc n | Suc m' \<Rightarrow> Suc (max n m'))"
   by (simp split: nat.split)
 
 lemma max_Suc2: "max m (Suc n) = (case m of 0 \<Rightarrow> Suc n | Suc m' \<Rightarrow> Suc (max m' n))"
   by (simp split: nat.split)
 
 lemma nat_mult_min_left: "min m n * q = min (m * q) (n * q)"
   for m n q :: nat
   by (simp add: min_def not_le)
     (auto dest: mult_right_le_imp_le mult_right_less_imp_less le_less_trans)
 
 lemma nat_mult_min_right: "m * min n q = min (m * n) (m * q)"
   for m n q :: nat
   by (simp add: min_def not_le)
     (auto dest: mult_left_le_imp_le mult_left_less_imp_less le_less_trans)
 
 lemma nat_add_max_left: "max m n + q = max (m + q) (n + q)"
   for m n q :: nat
   by (simp add: max_def)
 
 lemma nat_add_max_right: "m + max n q = max (m + n) (m + q)"
   for m n q :: nat
   by (simp add: max_def)
 
 lemma nat_mult_max_left: "max m n * q = max (m * q) (n * q)"
   for m n q :: nat
   by (simp add: max_def not_le)
     (auto dest: mult_right_le_imp_le mult_right_less_imp_less le_less_trans)
 
 lemma nat_mult_max_right: "m * max n q = max (m * n) (m * q)"
   for m n q :: nat
   by (simp add: max_def not_le)
     (auto dest: mult_left_le_imp_le mult_left_less_imp_less le_less_trans)
 
 
 subsubsection \<open>Additional theorems about \<^term>\<open>(\<le>)\<close>\<close>
 
 text \<open>Complete induction, aka course-of-values induction\<close>
 
 instance nat :: wellorder
 proof
   fix P and n :: nat
   assume step: "(\<And>m. m < n \<Longrightarrow> P m) \<Longrightarrow> P n" for n :: nat
   have "\<And>q. q \<le> n \<Longrightarrow> P q"
   proof (induct n)
     case (0 n)
     have "P 0" by (rule step) auto
     with 0 show ?case by auto
   next
     case (Suc m n)
     then have "n \<le> m \<or> n = Suc m"
       by (simp add: le_Suc_eq)
     then show ?case
     proof
       assume "n \<le> m"
       then show "P n" by (rule Suc(1))
     next
       assume n: "n = Suc m"
       show "P n" by (rule step) (rule Suc(1), simp add: n le_simps)
     qed
   qed
   then show "P n" by auto
 qed
 
 
 lemma Least_eq_0[simp]: "P 0 \<Longrightarrow> Least P = 0"
   for P :: "nat \<Rightarrow> bool"
   by (rule Least_equality[OF _ le0])
 
 lemma Least_Suc:
   assumes "P n" "\<not> P 0" 
   shows "(LEAST n. P n) = Suc (LEAST m. P (Suc m))"
 proof (cases n)
   case (Suc m)
   show ?thesis
   proof (rule antisym)
     show "(LEAST x. P x) \<le> Suc (LEAST x. P (Suc x))"
       using assms Suc by (force intro: LeastI Least_le)
     have \<section>: "P (LEAST x. P x)"
       by (blast intro: LeastI assms)
     show "Suc (LEAST m. P (Suc m)) \<le> (LEAST n. P n)"
     proof (cases "(LEAST n. P n)")
       case 0
       then show ?thesis
         using \<section> by (simp add: assms)
     next
       case Suc
       with \<section> show ?thesis
         by (auto simp: Least_le)
     qed
   qed
 qed (use assms in auto)
 
 lemma Least_Suc2: "P n \<Longrightarrow> Q m \<Longrightarrow> \<not> P 0 \<Longrightarrow> \<forall>k. P (Suc k) = Q k \<Longrightarrow> Least P = Suc (Least Q)"
   by (erule (1) Least_Suc [THEN ssubst]) simp
 
 lemma ex_least_nat_le:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "P n" "\<not> P 0" 
   shows "\<exists>k\<le>n. (\<forall>i<k. \<not> P i) \<and> P k"
 proof (cases n)
   case (Suc m)
   with assms show ?thesis
     by (blast intro: Least_le LeastI_ex dest: not_less_Least)
 qed (use assms in auto)
 
 lemma ex_least_nat_less:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "P n" "\<not> P 0" 
   shows "\<exists>k<n. (\<forall>i\<le>k. \<not> P i) \<and> P (Suc k)"
 proof (cases n)
   case (Suc m)
   then obtain k where k: "k \<le> n" "\<forall>i<k. \<not> P i" "P k"
     using ex_least_nat_le [OF assms] by blast
   show ?thesis 
     by (cases k) (use assms k less_eq_Suc_le in auto)
 qed (use assms in auto)
 
 
 lemma nat_less_induct:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "\<And>n. \<forall>m. m < n \<longrightarrow> P m \<Longrightarrow> P n"
   shows "P n"
   using assms less_induct by blast
 
 lemma measure_induct_rule [case_names less]:
   fixes f :: "'a \<Rightarrow> 'b::wellorder"
   assumes step: "\<And>x. (\<And>y. f y < f x \<Longrightarrow> P y) \<Longrightarrow> P x"
   shows "P a"
   by (induct m \<equiv> "f a" arbitrary: a rule: less_induct) (auto intro: step)
 
 text \<open>old style induction rules:\<close>
 lemma measure_induct:
   fixes f :: "'a \<Rightarrow> 'b::wellorder"
   shows "(\<And>x. \<forall>y. f y < f x \<longrightarrow> P y \<Longrightarrow> P x) \<Longrightarrow> P a"
   by (rule measure_induct_rule [of f P a]) iprover
 
 lemma full_nat_induct:
   assumes step: "\<And>n. (\<forall>m. Suc m \<le> n \<longrightarrow> P m) \<Longrightarrow> P n"
   shows "P n"
   by (rule less_induct) (auto intro: step simp:le_simps)
 
 text\<open>An induction rule for establishing binary relations\<close>
 lemma less_Suc_induct [consumes 1]:
   assumes less: "i < j"
     and step: "\<And>i. P i (Suc i)"
     and trans: "\<And>i j k. i < j \<Longrightarrow> j < k \<Longrightarrow> P i j \<Longrightarrow> P j k \<Longrightarrow> P i k"
   shows "P i j"
 proof -
   from less obtain k where j: "j = Suc (i + k)"
     by (auto dest: less_imp_Suc_add)
   have "P i (Suc (i + k))"
   proof (induct k)
     case 0
     show ?case by (simp add: step)
   next
     case (Suc k)
     have "0 + i < Suc k + i" by (rule add_less_mono1) simp
     then have "i < Suc (i + k)" by (simp add: add.commute)
     from trans[OF this lessI Suc step]
     show ?case by simp
   qed
   then show "P i j" by (simp add: j)
 qed
 
 text \<open>
   The method of infinite descent, frequently used in number theory.
   Provided by Roelof Oosterhuis.
   \<open>P n\<close> is true for all natural numbers if
   \<^item> case ``0'': given \<open>n = 0\<close> prove \<open>P n\<close>
   \<^item> case ``smaller'': given \<open>n > 0\<close> and \<open>\<not> P n\<close> prove there exists
     a smaller natural number \<open>m\<close> such that \<open>\<not> P m\<close>.
 \<close>
 
 lemma infinite_descent: "(\<And>n. \<not> P n \<Longrightarrow> \<exists>m<n. \<not> P m) \<Longrightarrow> P n" for P :: "nat \<Rightarrow> bool"
   \<comment> \<open>compact version without explicit base case\<close>
   by (induct n rule: less_induct) auto
 
 lemma infinite_descent0 [case_names 0 smaller]:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "P 0"
     and "\<And>n. n > 0 \<Longrightarrow> \<not> P n \<Longrightarrow> \<exists>m. m < n \<and> \<not> P m"
   shows "P n"
 proof (rule infinite_descent)
-  show "\<And>n. \<not> P n \<Longrightarrow> \<exists>m<n. \<not> P m"
-  using assms by (case_tac "n > 0") auto
+  fix n
+  show "\<not> P n \<Longrightarrow> \<exists>m<n. \<not> P m"
+    using assms by (cases "n > 0") auto
 qed
 
 text \<open>
   Infinite descent using a mapping to \<open>nat\<close>:
   \<open>P x\<close> is true for all \<open>x \<in> D\<close> if there exists a \<open>V \<in> D \<Rightarrow> nat\<close> and
   \<^item> case ``0'': given \<open>V x = 0\<close> prove \<open>P x\<close>
   \<^item> ``smaller'': given \<open>V x > 0\<close> and \<open>\<not> P x\<close> prove
   there exists a \<open>y \<in> D\<close> such that \<open>V y < V x\<close> and \<open>\<not> P y\<close>.
 \<close>
 corollary infinite_descent0_measure [case_names 0 smaller]:
   fixes V :: "'a \<Rightarrow> nat"
   assumes 1: "\<And>x. V x = 0 \<Longrightarrow> P x"
     and 2: "\<And>x. V x > 0 \<Longrightarrow> \<not> P x \<Longrightarrow> \<exists>y. V y < V x \<and> \<not> P y"
   shows "P x"
 proof -
   obtain n where "n = V x" by auto
   moreover have "\<And>x. V x = n \<Longrightarrow> P x"
   proof (induct n rule: infinite_descent0)
     case 0
     with 1 show "P x" by auto
   next
     case (smaller n)
     then obtain x where *: "V x = n " and "V x > 0 \<and> \<not> P x" by auto
     with 2 obtain y where "V y < V x \<and> \<not> P y" by auto
     with * obtain m where "m = V y \<and> m < n \<and> \<not> P y" by auto
     then show ?case by auto
   qed
   ultimately show "P x" by auto
 qed
 
 text \<open>Again, without explicit base case:\<close>
 lemma infinite_descent_measure:
   fixes V :: "'a \<Rightarrow> nat"
   assumes "\<And>x. \<not> P x \<Longrightarrow> \<exists>y. V y < V x \<and> \<not> P y"
   shows "P x"
 proof -
   from assms obtain n where "n = V x" by auto
   moreover have "\<And>x. V x = n \<Longrightarrow> P x"
-  proof (induct n rule: infinite_descent, auto)
-    show "\<exists>m < V x. \<exists>y. V y = m \<and> \<not> P y" if "\<not> P x" for x
+  proof -
+    have "\<exists>m < V x. \<exists>y. V y = m \<and> \<not> P y" if "\<not> P x" for x
       using assms and that by auto
+    then show "\<And>x. V x = n \<Longrightarrow> P x"
+      by (induct n rule: infinite_descent, auto)
   qed
   ultimately show "P x" by auto
 qed
 
 text \<open>A (clumsy) way of lifting \<open><\<close> monotonicity to \<open>\<le>\<close> monotonicity\<close>
 lemma less_mono_imp_le_mono:
   fixes f :: "nat \<Rightarrow> nat"
     and i j :: nat
   assumes "\<And>i j::nat. i < j \<Longrightarrow> f i < f j"
     and "i \<le> j"
   shows "f i \<le> f j"
   using assms by (auto simp add: order_le_less)
 
 
 text \<open>non-strict, in 1st argument\<close>
 lemma add_le_mono1: "i \<le> j \<Longrightarrow> i + k \<le> j + k"
   for i j k :: nat
   by (rule add_right_mono)
 
 text \<open>non-strict, in both arguments\<close>
 lemma add_le_mono: "i \<le> j \<Longrightarrow> k \<le> l \<Longrightarrow> i + k \<le> j + l"
   for i j k l :: nat
   by (rule add_mono)
 
 lemma le_add2: "n \<le> m + n"
   for m n :: nat
   by simp
 
 lemma le_add1: "n \<le> n + m"
   for m n :: nat
   by simp
 
 lemma less_add_Suc1: "i < Suc (i + m)"
   by (rule le_less_trans, rule le_add1, rule lessI)
 
 lemma less_add_Suc2: "i < Suc (m + i)"
   by (rule le_less_trans, rule le_add2, rule lessI)
 
 lemma less_iff_Suc_add: "m < n \<longleftrightarrow> (\<exists>k. n = Suc (m + k))"
   by (iprover intro!: less_add_Suc1 less_imp_Suc_add)
 
 lemma trans_le_add1: "i \<le> j \<Longrightarrow> i \<le> j + m"
   for i j m :: nat
   by (rule le_trans, assumption, rule le_add1)
 
 lemma trans_le_add2: "i \<le> j \<Longrightarrow> i \<le> m + j"
   for i j m :: nat
   by (rule le_trans, assumption, rule le_add2)
 
 lemma trans_less_add1: "i < j \<Longrightarrow> i < j + m"
   for i j m :: nat
   by (rule less_le_trans, assumption, rule le_add1)
 
 lemma trans_less_add2: "i < j \<Longrightarrow> i < m + j"
   for i j m :: nat
   by (rule less_le_trans, assumption, rule le_add2)
 
 lemma add_lessD1: "i + j < k \<Longrightarrow> i < k"
   for i j k :: nat
   by (rule le_less_trans [of _ "i+j"]) (simp_all add: le_add1)
 
 lemma not_add_less1 [iff]: "\<not> i + j < i"
   for i j :: nat
   by simp
 
 lemma not_add_less2 [iff]: "\<not> j + i < i"
   for i j :: nat
   by simp
 
 lemma add_leD1: "m + k \<le> n \<Longrightarrow> m \<le> n"
   for k m n :: nat
   by (rule order_trans [of _ "m + k"]) (simp_all add: le_add1)
 
 lemma add_leD2: "m + k \<le> n \<Longrightarrow> k \<le> n"
   for k m n :: nat
   by (force simp add: add.commute dest: add_leD1)
 
 lemma add_leE: "m + k \<le> n \<Longrightarrow> (m \<le> n \<Longrightarrow> k \<le> n \<Longrightarrow> R) \<Longrightarrow> R"
   for k m n :: nat
   by (blast dest: add_leD1 add_leD2)
 
 text \<open>needs \<open>\<And>k\<close> for \<open>ac_simps\<close> to work\<close>
 lemma less_add_eq_less: "\<And>k. k < l \<Longrightarrow> m + l = k + n \<Longrightarrow> m < n"
   for l m n :: nat
   by (force simp del: add_Suc_right simp add: less_iff_Suc_add add_Suc_right [symmetric] ac_simps)
 
 
 subsubsection \<open>More results about difference\<close>
 
 lemma Suc_diff_le: "n \<le> m \<Longrightarrow> Suc m - n = Suc (m - n)"
   by (induct m n rule: diff_induct) simp_all
 
 lemma diff_less_Suc: "m - n < Suc m"
   by (induct m n rule: diff_induct) (auto simp: less_Suc_eq)
 
 lemma diff_le_self [simp]: "m - n \<le> m"
   for m n :: nat
   by (induct m n rule: diff_induct) (simp_all add: le_SucI)
 
 lemma less_imp_diff_less: "j < k \<Longrightarrow> j - n < k"
   for j k n :: nat
   by (rule le_less_trans, rule diff_le_self)
 
 lemma diff_Suc_less [simp]: "0 < n \<Longrightarrow> n - Suc i < n"
   by (cases n) (auto simp add: le_simps)
 
 lemma diff_add_assoc: "k \<le> j \<Longrightarrow> (i + j) - k = i + (j - k)"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.diff_add_assoc) 
 
 lemma add_diff_assoc [simp]: "k \<le> j \<Longrightarrow> i + (j - k) = i + j - k"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.add_diff_assoc)
 
 lemma diff_add_assoc2: "k \<le> j \<Longrightarrow> (j + i) - k = (j - k) + i"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.diff_add_assoc2)
 
 lemma add_diff_assoc2 [simp]: "k \<le> j \<Longrightarrow> j - k + i = j + i - k"
   for i j k :: nat
   by (fact ordered_cancel_comm_monoid_diff_class.add_diff_assoc2)
 
 lemma le_imp_diff_is_add: "i \<le> j \<Longrightarrow> (j - i = k) = (j = k + i)"
   for i j k :: nat
   by auto
 
 lemma diff_is_0_eq [simp]: "m - n = 0 \<longleftrightarrow> m \<le> n"
   for m n :: nat
   by (induct m n rule: diff_induct) simp_all
 
 lemma diff_is_0_eq' [simp]: "m \<le> n \<Longrightarrow> m - n = 0"
   for m n :: nat
   by (rule iffD2, rule diff_is_0_eq)
 
 lemma zero_less_diff [simp]: "0 < n - m \<longleftrightarrow> m < n"
   for m n :: nat
   by (induct m n rule: diff_induct) simp_all
 
 lemma less_imp_add_positive:
   assumes "i < j"
   shows "\<exists>k::nat. 0 < k \<and> i + k = j"
 proof
   from assms show "0 < j - i \<and> i + (j - i) = j"
     by (simp add: order_less_imp_le)
 qed
 
 text \<open>a nice rewrite for bounded subtraction\<close>
 lemma nat_minus_add_max: "n - m + m = max n m"
   for m n :: nat
   by (simp add: max_def not_le order_less_imp_le)
 
 lemma nat_diff_split: "P (a - b) \<longleftrightarrow> (a < b \<longrightarrow> P 0) \<and> (\<forall>d. a = b + d \<longrightarrow> P d)"
   for a b :: nat
   \<comment> \<open>elimination of \<open>-\<close> on \<open>nat\<close>\<close>
   by (cases "a < b") (auto simp add: not_less le_less dest!: add_eq_self_zero [OF sym])
 
 lemma nat_diff_split_asm: "P (a - b) \<longleftrightarrow> \<not> (a < b \<and> \<not> P 0 \<or> (\<exists>d. a = b + d \<and> \<not> P d))"
   for a b :: nat
   \<comment> \<open>elimination of \<open>-\<close> on \<open>nat\<close> in assumptions\<close>
   by (auto split: nat_diff_split)
 
 lemma Suc_pred': "0 < n \<Longrightarrow> n = Suc(n - 1)"
   by simp
 
 lemma add_eq_if: "m + n = (if m = 0 then n else Suc ((m - 1) + n))"
   unfolding One_nat_def by (cases m) simp_all
 
 lemma mult_eq_if: "m * n = (if m = 0 then 0 else n + ((m - 1) * n))"
   for m n :: nat
   by (cases m) simp_all
 
 lemma Suc_diff_eq_diff_pred: "0 < n \<Longrightarrow> Suc m - n = m - (n - 1)"
   by (cases n) simp_all
 
 lemma diff_Suc_eq_diff_pred: "m - Suc n = (m - 1) - n"
   by (cases m) simp_all
 
 lemma Let_Suc [simp]: "Let (Suc n) f \<equiv> f (Suc n)"
   by (fact Let_def)
 
 
 subsubsection \<open>Monotonicity of multiplication\<close>
 
 lemma mult_le_mono1: "i \<le> j \<Longrightarrow> i * k \<le> j * k"
   for i j k :: nat
   by (simp add: mult_right_mono)
 
 lemma mult_le_mono2: "i \<le> j \<Longrightarrow> k * i \<le> k * j"
   for i j k :: nat
   by (simp add: mult_left_mono)
 
 text \<open>\<open>\<le>\<close> monotonicity, BOTH arguments\<close>
 lemma mult_le_mono: "i \<le> j \<Longrightarrow> k \<le> l \<Longrightarrow> i * k \<le> j * l"
   for i j k l :: nat
   by (simp add: mult_mono)
 
 lemma mult_less_mono1: "i < j \<Longrightarrow> 0 < k \<Longrightarrow> i * k < j * k"
   for i j k :: nat
   by (simp add: mult_strict_right_mono)
 
 text \<open>Differs from the standard \<open>zero_less_mult_iff\<close> in that there are no negative numbers.\<close>
 lemma nat_0_less_mult_iff [simp]: "0 < m * n \<longleftrightarrow> 0 < m \<and> 0 < n"
   for m n :: nat
 proof (induct m)
   case 0
   then show ?case by simp
 next
   case (Suc m)
   then show ?case by (cases n) simp_all
 qed
 
 lemma one_le_mult_iff [simp]: "Suc 0 \<le> m * n \<longleftrightarrow> Suc 0 \<le> m \<and> Suc 0 \<le> n"
 proof (induct m)
   case 0
   then show ?case by simp
 next
   case (Suc m)
   then show ?case by (cases n) simp_all
 qed
 
 lemma mult_less_cancel2 [simp]: "m * k < n * k \<longleftrightarrow> 0 < k \<and> m < n"
   for k m n :: nat
 proof (intro iffI conjI)
   assume m: "m * k < n * k"
   then show "0 < k"
     by (cases k) auto
   show "m < n"
   proof (cases k)
     case 0
     then show ?thesis
       using m by auto
   next
     case (Suc k')
     then show ?thesis
       using m
       by (simp flip: linorder_not_le) (blast intro: add_mono mult_le_mono1)
   qed
 next
   assume "0 < k \<and> m < n"
   then show "m * k < n * k"
     by (blast intro: mult_less_mono1)
 qed
 
 lemma mult_less_cancel1 [simp]: "k * m < k * n \<longleftrightarrow> 0 < k \<and> m < n"
   for k m n :: nat
   by (simp add: mult.commute [of k])
 
 lemma mult_le_cancel1 [simp]: "k * m \<le> k * n \<longleftrightarrow> (0 < k \<longrightarrow> m \<le> n)"
   for k m n :: nat
   by (simp add: linorder_not_less [symmetric], auto)
 
 lemma mult_le_cancel2 [simp]: "m * k \<le> n * k \<longleftrightarrow> (0 < k \<longrightarrow> m \<le> n)"
   for k m n :: nat
   by (simp add: linorder_not_less [symmetric], auto)
 
 lemma Suc_mult_less_cancel1: "Suc k * m < Suc k * n \<longleftrightarrow> m < n"
   by (subst mult_less_cancel1) simp
 
 lemma Suc_mult_le_cancel1: "Suc k * m \<le> Suc k * n \<longleftrightarrow> m \<le> n"
   by (subst mult_le_cancel1) simp
 
 lemma le_square: "m \<le> m * m"
   for m :: nat
   by (cases m) (auto intro: le_add1)
 
 lemma le_cube: "m \<le> m * (m * m)"
   for m :: nat
   by (cases m) (auto intro: le_add1)
 
 text \<open>Lemma for \<open>gcd\<close>\<close>
 lemma mult_eq_self_implies_10: 
   fixes m n :: nat
   assumes "m = m * n" shows "n = 1 \<or> m = 0"
 proof (rule disjCI)
   assume "m \<noteq> 0"
   show "n = 1"
   proof (cases n "1::nat" rule: linorder_cases)
     case greater
     show ?thesis
       using assms mult_less_mono2 [OF greater, of m] \<open>m \<noteq> 0\<close> by auto
   qed (use assms \<open>m \<noteq> 0\<close> in auto)
 qed
 
 lemma mono_times_nat:
   fixes n :: nat
   assumes "n > 0"
   shows "mono (times n)"
 proof
   fix m q :: nat
   assume "m \<le> q"
   with assms show "n * m \<le> n * q" by simp
 qed
 
 text \<open>The lattice order on \<^typ>\<open>nat\<close>.\<close>
 
 instantiation nat :: distrib_lattice
 begin
 
 definition "(inf :: nat \<Rightarrow> nat \<Rightarrow> nat) = min"
 
 definition "(sup :: nat \<Rightarrow> nat \<Rightarrow> nat) = max"
 
 instance
   by intro_classes
     (auto simp add: inf_nat_def sup_nat_def max_def not_le min_def
       intro: order_less_imp_le antisym elim!: order_trans order_less_trans)
 
 end
 
 
 subsection \<open>Natural operation of natural numbers on functions\<close>
 
 text \<open>
   We use the same logical constant for the power operations on
   functions and relations, in order to share the same syntax.
 \<close>
 
 consts compow :: "nat \<Rightarrow> 'a \<Rightarrow> 'a"
 
 abbreviation compower :: "'a \<Rightarrow> nat \<Rightarrow> 'a" (infixr "^^" 80)
   where "f ^^ n \<equiv> compow n f"
 
 notation (latex output)
   compower ("(_\<^bsup>_\<^esup>)" [1000] 1000)
 
 text \<open>\<open>f ^^ n = f \<circ> \<dots> \<circ> f\<close>, the \<open>n\<close>-fold composition of \<open>f\<close>\<close>
 
 overloading
   funpow \<equiv> "compow :: nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
 begin
 
 primrec funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
   where
     "funpow 0 f = id"
   | "funpow (Suc n) f = f \<circ> funpow n f"
 
 end
 
 lemma funpow_0 [simp]: "(f ^^ 0) x = x"
   by simp
 
 lemma funpow_Suc_right: "f ^^ Suc n = f ^^ n \<circ> f"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   fix n
   assume "f ^^ Suc n = f ^^ n \<circ> f"
   then show "f ^^ Suc (Suc n) = f ^^ Suc n \<circ> f"
     by (simp add: o_assoc)
 qed
 
 lemmas funpow_simps_right = funpow.simps(1) funpow_Suc_right
 
 text \<open>For code generation.\<close>
 
 context
 begin
 
 qualified definition funpow :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a"
   where funpow_code_def [code_abbrev]: "funpow = compow"
 
 lemma [code]:
   "funpow (Suc n) f = f \<circ> funpow n f"
   "funpow 0 f = id"
   by (simp_all add: funpow_code_def)
 
 end
 
 lemma funpow_add: "f ^^ (m + n) = f ^^ m \<circ> f ^^ n"
   by (induct m) simp_all
 
 lemma funpow_mult: "(f ^^ m) ^^ n = f ^^ (m * n)"
   for f :: "'a \<Rightarrow> 'a"
   by (induct n) (simp_all add: funpow_add)
 
 lemma funpow_swap1: "f ((f ^^ n) x) = (f ^^ n) (f x)"
 proof -
   have "f ((f ^^ n) x) = (f ^^ (n + 1)) x" by simp
   also have "\<dots>  = (f ^^ n \<circ> f ^^ 1) x" by (simp only: funpow_add)
   also have "\<dots> = (f ^^ n) (f x)" by simp
   finally show ?thesis .
 qed
 
 lemma comp_funpow: "comp f ^^ n = comp (f ^^ n)"
   for f :: "'a \<Rightarrow> 'a"
   by (induct n) simp_all
 
 lemma Suc_funpow[simp]: "Suc ^^ n = ((+) n)"
   by (induct n) simp_all
 
 lemma id_funpow[simp]: "id ^^ n = id"
   by (induct n) simp_all
 
 lemma funpow_mono: "mono f \<Longrightarrow> A \<le> B \<Longrightarrow> (f ^^ n) A \<le> (f ^^ n) B"
   for f :: "'a \<Rightarrow> ('a::order)"
   by (induct n arbitrary: A B)
      (auto simp del: funpow.simps(2) simp add: funpow_Suc_right mono_def)
 
 lemma funpow_mono2:
   assumes "mono f"
     and "i \<le> j"
     and "x \<le> y"
     and "x \<le> f x"
   shows "(f ^^ i) x \<le> (f ^^ j) y"
   using assms(2,3)
 proof (induct j arbitrary: y)
   case 0
   then show ?case by simp
 next
   case (Suc j)
   show ?case
   proof(cases "i = Suc j")
     case True
     with assms(1) Suc show ?thesis
       by (simp del: funpow.simps add: funpow_simps_right monoD funpow_mono)
   next
     case False
     with assms(1,4) Suc show ?thesis
       by (simp del: funpow.simps add: funpow_simps_right le_eq_less_or_eq less_Suc_eq_le)
         (simp add: Suc.hyps monoD order_subst1)
   qed
 qed
 
 lemma inj_fn[simp]:
   fixes f::"'a \<Rightarrow> 'a"
   assumes "inj f"
   shows "inj (f^^n)"
 proof (induction n)
   case Suc thus ?case using inj_compose[OF assms Suc.IH] by (simp del: comp_apply)
 qed simp
 
 lemma surj_fn[simp]:
   fixes f::"'a \<Rightarrow> 'a"
   assumes "surj f"
   shows "surj (f^^n)"
 proof (induction n)
   case Suc thus ?case by (simp add: comp_surj[OF Suc.IH assms] del: comp_apply)
 qed simp
 
 lemma bij_fn[simp]:
   fixes f::"'a \<Rightarrow> 'a"
   assumes "bij f"
   shows "bij (f^^n)"
 by (rule bijI[OF inj_fn[OF bij_is_inj[OF assms]] surj_fn[OF bij_is_surj[OF assms]]])
 
 lemma bij_betw_funpow: \<^marker>\<open>contributor \<open>Lars Noschinski\<close>\<close>
   assumes "bij_betw f S S" shows "bij_betw (f ^^ n) S S"
 proof (induct n)
   case 0 then show ?case by (auto simp: id_def[symmetric])
 next
   case (Suc n)
   then show ?case unfolding funpow.simps using assms by (rule bij_betw_trans)
 qed
 
 
 subsection \<open>Kleene iteration\<close>
 
 lemma Kleene_iter_lpfp:
   fixes f :: "'a::order_bot \<Rightarrow> 'a"
   assumes "mono f"
     and "f p \<le> p"
   shows "(f ^^ k) bot \<le> p"
 proof (induct k)
   case 0
   show ?case by simp
 next
   case Suc
   show ?case
     using monoD[OF assms(1) Suc] assms(2) by simp
 qed
 
 lemma lfp_Kleene_iter:
   assumes "mono f"
     and "(f ^^ Suc k) bot = (f ^^ k) bot"
   shows "lfp f = (f ^^ k) bot"
 proof (rule antisym)
   show "lfp f \<le> (f ^^ k) bot"
   proof (rule lfp_lowerbound)
     show "f ((f ^^ k) bot) \<le> (f ^^ k) bot"
       using assms(2) by simp
   qed
   show "(f ^^ k) bot \<le> lfp f"
     using Kleene_iter_lpfp[OF assms(1)] lfp_unfold[OF assms(1)] by simp
 qed
 
 lemma mono_pow: "mono f \<Longrightarrow> mono (f ^^ n)"
   for f :: "'a \<Rightarrow> 'a::complete_lattice"
   by (induct n) (auto simp: mono_def)
 
 lemma lfp_funpow:
   assumes f: "mono f"
   shows "lfp (f ^^ Suc n) = lfp f"
 proof (rule antisym)
   show "lfp f \<le> lfp (f ^^ Suc n)"
   proof (rule lfp_lowerbound)
     have "f (lfp (f ^^ Suc n)) = lfp (\<lambda>x. f ((f ^^ n) x))"
       unfolding funpow_Suc_right by (simp add: lfp_rolling f mono_pow comp_def)
     then show "f (lfp (f ^^ Suc n)) \<le> lfp (f ^^ Suc n)"
       by (simp add: comp_def)
   qed
   have "(f ^^ n) (lfp f) = lfp f" for n
     by (induct n) (auto intro: f lfp_fixpoint)
   then show "lfp (f ^^ Suc n) \<le> lfp f"
     by (intro lfp_lowerbound) (simp del: funpow.simps)
 qed
 
 lemma gfp_funpow:
   assumes f: "mono f"
   shows "gfp (f ^^ Suc n) = gfp f"
 proof (rule antisym)
   show "gfp f \<ge> gfp (f ^^ Suc n)"
   proof (rule gfp_upperbound)
     have "f (gfp (f ^^ Suc n)) = gfp (\<lambda>x. f ((f ^^ n) x))"
       unfolding funpow_Suc_right by (simp add: gfp_rolling f mono_pow comp_def)
     then show "f (gfp (f ^^ Suc n)) \<ge> gfp (f ^^ Suc n)"
       by (simp add: comp_def)
   qed
   have "(f ^^ n) (gfp f) = gfp f" for n
     by (induct n) (auto intro: f gfp_fixpoint)
   then show "gfp (f ^^ Suc n) \<ge> gfp f"
     by (intro gfp_upperbound) (simp del: funpow.simps)
 qed
 
 lemma Kleene_iter_gpfp:
   fixes f :: "'a::order_top \<Rightarrow> 'a"
   assumes "mono f"
     and "p \<le> f p"
   shows "p \<le> (f ^^ k) top"
 proof (induct k)
   case 0
   show ?case by simp
 next
   case Suc
   show ?case
     using monoD[OF assms(1) Suc] assms(2) by simp
 qed
 
 lemma gfp_Kleene_iter:
   assumes "mono f"
     and "(f ^^ Suc k) top = (f ^^ k) top"
   shows "gfp f = (f ^^ k) top"
     (is "?lhs = ?rhs")
 proof (rule antisym)
   have "?rhs \<le> f ?rhs"
     using assms(2) by simp
   then show "?rhs \<le> ?lhs"
     by (rule gfp_upperbound)
   show "?lhs \<le> ?rhs"
     using Kleene_iter_gpfp[OF assms(1)] gfp_unfold[OF assms(1)] by simp
 qed
 
 
 subsection \<open>Embedding of the naturals into any \<open>semiring_1\<close>: \<^term>\<open>of_nat\<close>\<close>
 
 context semiring_1
 begin
 
 definition of_nat :: "nat \<Rightarrow> 'a"
   where "of_nat n = (plus 1 ^^ n) 0"
 
 lemma of_nat_simps [simp]:
   shows of_nat_0: "of_nat 0 = 0"
     and of_nat_Suc: "of_nat (Suc m) = 1 + of_nat m"
   by (simp_all add: of_nat_def)
 
 lemma of_nat_1 [simp]: "of_nat 1 = 1"
   by (simp add: of_nat_def)
 
 lemma of_nat_add [simp]: "of_nat (m + n) = of_nat m + of_nat n"
   by (induct m) (simp_all add: ac_simps)
 
 lemma of_nat_mult [simp]: "of_nat (m * n) = of_nat m * of_nat n"
   by (induct m) (simp_all add: ac_simps distrib_right)
 
 lemma mult_of_nat_commute: "of_nat x * y = y * of_nat x"
   by (induct x) (simp_all add: algebra_simps)
 
 primrec of_nat_aux :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a"
   where
     "of_nat_aux inc 0 i = i"
   | "of_nat_aux inc (Suc n) i = of_nat_aux inc n (inc i)" \<comment> \<open>tail recursive\<close>
 
 lemma of_nat_code: "of_nat n = of_nat_aux (\<lambda>i. i + 1) n 0"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   have "\<And>i. of_nat_aux (\<lambda>i. i + 1) n (i + 1) = of_nat_aux (\<lambda>i. i + 1) n i + 1"
     by (induct n) simp_all
   from this [of 0] have "of_nat_aux (\<lambda>i. i + 1) n 1 = of_nat_aux (\<lambda>i. i + 1) n 0 + 1"
     by simp
   with Suc show ?case
     by (simp add: add.commute)
 qed
 
 lemma of_nat_of_bool [simp]:
   "of_nat (of_bool P) = of_bool P"
   by auto
 
 end
 
 declare of_nat_code [code]
 
 context semiring_1_cancel
 begin
 
 lemma of_nat_diff:
   \<open>of_nat (m - n) = of_nat m - of_nat n\<close> if \<open>n \<le> m\<close>
 proof -
   from that obtain q where \<open>m = n + q\<close>
     by (blast dest: le_Suc_ex)
   then show ?thesis
     by simp
 qed
 
 end
 
 text \<open>Class for unital semirings with characteristic zero.
  Includes non-ordered rings like the complex numbers.\<close>
 
 class semiring_char_0 = semiring_1 +
   assumes inj_of_nat: "inj of_nat"
 begin
 
 lemma of_nat_eq_iff [simp]: "of_nat m = of_nat n \<longleftrightarrow> m = n"
   by (auto intro: inj_of_nat injD)
 
 text \<open>Special cases where either operand is zero\<close>
 
 lemma of_nat_0_eq_iff [simp]: "0 = of_nat n \<longleftrightarrow> 0 = n"
   by (fact of_nat_eq_iff [of 0 n, unfolded of_nat_0])
 
 lemma of_nat_eq_0_iff [simp]: "of_nat m = 0 \<longleftrightarrow> m = 0"
   by (fact of_nat_eq_iff [of m 0, unfolded of_nat_0])
 
 lemma of_nat_1_eq_iff [simp]: "1 = of_nat n \<longleftrightarrow> n=1"
   using of_nat_eq_iff by fastforce
 
 lemma of_nat_eq_1_iff [simp]: "of_nat n = 1 \<longleftrightarrow> n=1"
   using of_nat_eq_iff by fastforce
 
 lemma of_nat_neq_0 [simp]: "of_nat (Suc n) \<noteq> 0"
   unfolding of_nat_eq_0_iff by simp
 
 lemma of_nat_0_neq [simp]: "0 \<noteq> of_nat (Suc n)"
   unfolding of_nat_0_eq_iff by simp
 
 end
 
 class ring_char_0 = ring_1 + semiring_char_0
 
 context linordered_nonzero_semiring
 begin
 
 lemma of_nat_0_le_iff [simp]: "0 \<le> of_nat n"
   by (induct n) simp_all
 
 lemma of_nat_less_0_iff [simp]: "\<not> of_nat m < 0"
   by (simp add: not_less)
 
 lemma of_nat_mono[simp]: "i \<le> j \<Longrightarrow> of_nat i \<le> of_nat j"
   by (auto simp: le_iff_add intro!: add_increasing2)
 
 lemma of_nat_less_iff [simp]: "of_nat m < of_nat n \<longleftrightarrow> m < n"
 proof(induct m n rule: diff_induct)
   case (1 m) then show ?case
     by auto
 next
   case (2 n) then show ?case
     by (simp add: add_pos_nonneg)
 next
   case (3 m n)
   then show ?case
     by (auto simp: add_commute [of 1] add_mono1 not_less add_right_mono leD)
 qed
 
 lemma of_nat_le_iff [simp]: "of_nat m \<le> of_nat n \<longleftrightarrow> m \<le> n"
   by (simp add: not_less [symmetric] linorder_not_less [symmetric])
 
 lemma less_imp_of_nat_less: "m < n \<Longrightarrow> of_nat m < of_nat n"
   by simp
 
 lemma of_nat_less_imp_less: "of_nat m < of_nat n \<Longrightarrow> m < n"
   by simp
 
 text \<open>Every \<open>linordered_nonzero_semiring\<close> has characteristic zero.\<close>
 
 subclass semiring_char_0
   by standard (auto intro!: injI simp add: order.eq_iff)
 
 text \<open>Special cases where either operand is zero\<close>
 
 lemma of_nat_le_0_iff [simp]: "of_nat m \<le> 0 \<longleftrightarrow> m = 0"
   by (rule of_nat_le_iff [of _ 0, simplified])
 
 lemma of_nat_0_less_iff [simp]: "0 < of_nat n \<longleftrightarrow> 0 < n"
   by (rule of_nat_less_iff [of 0, simplified])
 
 end
 
 context linordered_nonzero_semiring
 begin
 
 lemma of_nat_max: "of_nat (max x y) = max (of_nat x) (of_nat y)"
   by (auto simp: max_def ord_class.max_def)
 
 lemma of_nat_min: "of_nat (min x y) = min (of_nat x) (of_nat y)"
   by (auto simp: min_def ord_class.min_def)
 
 end
 
 context linordered_semidom
 begin
 
 subclass linordered_nonzero_semiring ..
 
 subclass semiring_char_0 ..
 
 end
 
 context linordered_idom
 begin
 
 lemma abs_of_nat [simp]:
   "\<bar>of_nat n\<bar> = of_nat n"
   by (simp add: abs_if)
 
 lemma sgn_of_nat [simp]:
   "sgn (of_nat n) = of_bool (n > 0)"
   by simp
 
 end
 
 lemma of_nat_id [simp]: "of_nat n = n"
   by (induct n) simp_all
 
 lemma of_nat_eq_id [simp]: "of_nat = id"
   by (auto simp add: fun_eq_iff)
 
 
 subsection \<open>The set of natural numbers\<close>
 
 context semiring_1
 begin
 
 definition Nats :: "'a set"  ("\<nat>")
   where "\<nat> = range of_nat"
 
 lemma of_nat_in_Nats [simp]: "of_nat n \<in> \<nat>"
   by (simp add: Nats_def)
 
 lemma Nats_0 [simp]: "0 \<in> \<nat>"
   using of_nat_0 [symmetric] unfolding Nats_def
   by (rule range_eqI)
 
 lemma Nats_1 [simp]: "1 \<in> \<nat>"
   using of_nat_1 [symmetric] unfolding Nats_def
   by (rule range_eqI)
 
 lemma Nats_add [simp]: "a \<in> \<nat> \<Longrightarrow> b \<in> \<nat> \<Longrightarrow> a + b \<in> \<nat>"
   unfolding Nats_def using of_nat_add [symmetric]
   by (blast intro: range_eqI)
 
 lemma Nats_mult [simp]: "a \<in> \<nat> \<Longrightarrow> b \<in> \<nat> \<Longrightarrow> a * b \<in> \<nat>"
   unfolding Nats_def using of_nat_mult [symmetric]
   by (blast intro: range_eqI)
 
 lemma Nats_cases [cases set: Nats]:
   assumes "x \<in> \<nat>"
   obtains (of_nat) n where "x = of_nat n"
   unfolding Nats_def
 proof -
   from \<open>x \<in> \<nat>\<close> have "x \<in> range of_nat" unfolding Nats_def .
   then obtain n where "x = of_nat n" ..
   then show thesis ..
 qed
 
 lemma Nats_induct [case_names of_nat, induct set: Nats]: "x \<in> \<nat> \<Longrightarrow> (\<And>n. P (of_nat n)) \<Longrightarrow> P x"
   by (rule Nats_cases) auto
 
 end
 
 lemma Nats_diff [simp]:
   fixes a:: "'a::linordered_idom"
   assumes "a \<in> \<nat>" "b \<in> \<nat>" "b \<le> a" shows "a - b \<in> \<nat>"
 proof -
   obtain i where i: "a = of_nat i"
     using Nats_cases assms by blast
   obtain j where j: "b = of_nat j"
     using Nats_cases assms by blast
   have "j \<le> i"
     using \<open>b \<le> a\<close> i j of_nat_le_iff by blast
   then have *: "of_nat i - of_nat j = (of_nat (i-j) :: 'a)"
     by (simp add: of_nat_diff)
   then show ?thesis
     by (simp add: * i j)
 qed
 
 
 subsection \<open>Further arithmetic facts concerning the natural numbers\<close>
 
 lemma subst_equals:
   assumes "t = s" and "u = t"
   shows "u = s"
   using assms(2,1) by (rule trans)
 
 locale nat_arith
 begin
 
 lemma add1: "(A::'a::comm_monoid_add) \<equiv> k + a \<Longrightarrow> A + b \<equiv> k + (a + b)"
   by (simp only: ac_simps)
 
 lemma add2: "(B::'a::comm_monoid_add) \<equiv> k + b \<Longrightarrow> a + B \<equiv> k + (a + b)"
   by (simp only: ac_simps)
 
 lemma suc1: "A == k + a \<Longrightarrow> Suc A \<equiv> k + Suc a"
   by (simp only: add_Suc_right)
 
 lemma rule0: "(a::'a::comm_monoid_add) \<equiv> a + 0"
   by (simp only: add_0_right)
 
 end
 
 ML_file \<open>Tools/nat_arith.ML\<close>
 
 simproc_setup nateq_cancel_sums
   ("(l::nat) + m = n" | "(l::nat) = m + n" | "Suc m = n" | "m = Suc n") =
   \<open>fn phi => try o Nat_Arith.cancel_eq_conv\<close>
 
 simproc_setup natless_cancel_sums
   ("(l::nat) + m < n" | "(l::nat) < m + n" | "Suc m < n" | "m < Suc n") =
   \<open>fn phi => try o Nat_Arith.cancel_less_conv\<close>
 
 simproc_setup natle_cancel_sums
   ("(l::nat) + m \<le> n" | "(l::nat) \<le> m + n" | "Suc m \<le> n" | "m \<le> Suc n") =
   \<open>fn phi => try o Nat_Arith.cancel_le_conv\<close>
 
 simproc_setup natdiff_cancel_sums
   ("(l::nat) + m - n" | "(l::nat) - (m + n)" | "Suc m - n" | "m - Suc n") =
   \<open>fn phi => try o Nat_Arith.cancel_diff_conv\<close>
 
 context order
 begin
 
 lemma lift_Suc_mono_le:
   assumes mono: "\<And>n. f n \<le> f (Suc n)"
     and "n \<le> n'"
   shows "f n \<le> f n'"
 proof (cases "n < n'")
   case True
   then show ?thesis
     by (induct n n' rule: less_Suc_induct) (auto intro: mono)
 next
   case False
   with \<open>n \<le> n'\<close> show ?thesis by auto
 qed
 
 lemma lift_Suc_antimono_le:
   assumes mono: "\<And>n. f n \<ge> f (Suc n)"
     and "n \<le> n'"
   shows "f n \<ge> f n'"
 proof (cases "n < n'")
   case True
   then show ?thesis
     by (induct n n' rule: less_Suc_induct) (auto intro: mono)
 next
   case False
   with \<open>n \<le> n'\<close> show ?thesis by auto
 qed
 
 lemma lift_Suc_mono_less:
   assumes mono: "\<And>n. f n < f (Suc n)"
     and "n < n'"
   shows "f n < f n'"
   using \<open>n < n'\<close> by (induct n n' rule: less_Suc_induct) (auto intro: mono)
 
 lemma lift_Suc_mono_less_iff: "(\<And>n. f n < f (Suc n)) \<Longrightarrow> f n < f m \<longleftrightarrow> n < m"
   by (blast intro: less_asym' lift_Suc_mono_less [of f]
     dest: linorder_not_less[THEN iffD1] le_eq_less_or_eq [THEN iffD1])
 
 end
 
 lemma mono_iff_le_Suc: "mono f \<longleftrightarrow> (\<forall>n. f n \<le> f (Suc n))"
   unfolding mono_def by (auto intro: lift_Suc_mono_le [of f])
 
 lemma antimono_iff_le_Suc: "antimono f \<longleftrightarrow> (\<forall>n. f (Suc n) \<le> f n)"
   unfolding antimono_def by (auto intro: lift_Suc_antimono_le [of f])
 
 lemma mono_nat_linear_lb:
   fixes f :: "nat \<Rightarrow> nat"
   assumes "\<And>m n. m < n \<Longrightarrow> f m < f n"
   shows "f m + k \<le> f (m + k)"
 proof (induct k)
   case 0
   then show ?case by simp
 next
   case (Suc k)
   then have "Suc (f m + k) \<le> Suc (f (m + k))" by simp
   also from assms [of "m + k" "Suc (m + k)"] have "Suc (f (m + k)) \<le> f (Suc (m + k))"
     by (simp add: Suc_le_eq)
   finally show ?case by simp
 qed
 
 
 text \<open>Subtraction laws, mostly by Clemens Ballarin\<close>
 
 lemma diff_less_mono:
   fixes a b c :: nat
   assumes "a < b" and "c \<le> a"
   shows "a - c < b - c"
 proof -
   from assms obtain d e where "b = c + (d + e)" and "a = c + e" and "d > 0"
     by (auto dest!: le_Suc_ex less_imp_Suc_add simp add: ac_simps)
   then show ?thesis by simp
 qed
 
 lemma less_diff_conv: "i < j - k \<longleftrightarrow> i + k < j"
   for i j k :: nat
   by (cases "k \<le> j") (auto simp add: not_le dest: less_imp_Suc_add le_Suc_ex)
 
 lemma less_diff_conv2: "k \<le> j \<Longrightarrow> j - k < i \<longleftrightarrow> j < i + k"
   for j k i :: nat
   by (auto dest: le_Suc_ex)
 
 lemma le_diff_conv: "j - k \<le> i \<longleftrightarrow> j \<le> i + k"
   for j k i :: nat
   by (cases "k \<le> j") (auto simp add: not_le dest!: less_imp_Suc_add le_Suc_ex)
 
 lemma diff_diff_cancel [simp]: "i \<le> n \<Longrightarrow> n - (n - i) = i"
   for i n :: nat
   by (auto dest: le_Suc_ex)
 
 lemma diff_less [simp]: "0 < n \<Longrightarrow> 0 < m \<Longrightarrow> m - n < m"
   for i n :: nat
   by (auto dest: less_imp_Suc_add)
 
 text \<open>Simplification of relational expressions involving subtraction\<close>
 
 lemma diff_diff_eq: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k - (n - k) = m - n"
   for m n k :: nat
   by (auto dest!: le_Suc_ex)
 
 hide_fact (open) diff_diff_eq
 
 lemma eq_diff_iff: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k = n - k \<longleftrightarrow> m = n"
   for m n k :: nat
   by (auto dest: le_Suc_ex)
 
 lemma less_diff_iff: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k < n - k \<longleftrightarrow> m < n"
   for m n k :: nat
   by (auto dest!: le_Suc_ex)
 
 lemma le_diff_iff: "k \<le> m \<Longrightarrow> k \<le> n \<Longrightarrow> m - k \<le> n - k \<longleftrightarrow> m \<le> n"
   for m n k :: nat
   by (auto dest!: le_Suc_ex)
 
 lemma le_diff_iff': "a \<le> c \<Longrightarrow> b \<le> c \<Longrightarrow> c - a \<le> c - b \<longleftrightarrow> b \<le> a"
   for a b c :: nat
   by (force dest: le_Suc_ex)
 
 
 text \<open>(Anti)Monotonicity of subtraction -- by Stephan Merz\<close>
 
 lemma diff_le_mono: "m \<le> n \<Longrightarrow> m - l \<le> n - l"
   for m n l :: nat
   by (auto dest: less_imp_le less_imp_Suc_add split: nat_diff_split)
 
 lemma diff_le_mono2: "m \<le> n \<Longrightarrow> l - n \<le> l - m"
   for m n l :: nat
   by (auto dest: less_imp_le le_Suc_ex less_imp_Suc_add less_le_trans split: nat_diff_split)
 
 lemma diff_less_mono2: "m < n \<Longrightarrow> m < l \<Longrightarrow> l - n < l - m"
   for m n l :: nat
   by (auto dest: less_imp_Suc_add split: nat_diff_split)
 
 lemma diffs0_imp_equal: "m - n = 0 \<Longrightarrow> n - m = 0 \<Longrightarrow> m = n"
   for m n :: nat
   by (simp split: nat_diff_split)
 
 lemma min_diff: "min (m - i) (n - i) = min m n - i"
   for m n i :: nat
   by (cases m n rule: le_cases)
     (auto simp add: not_le min.absorb1 min.absorb2 min.absorb_iff1 [symmetric] diff_le_mono)
 
 lemma inj_on_diff_nat:
   fixes k :: nat
   assumes "\<And>n. n \<in> N \<Longrightarrow> k \<le> n"
   shows "inj_on (\<lambda>n. n - k) N"
 proof (rule inj_onI)
   fix x y
   assume a: "x \<in> N" "y \<in> N" "x - k = y - k"
   with assms have "x - k + k = y - k + k" by auto
   with a assms show "x = y" by (auto simp add: eq_diff_iff)
 qed
 
 text \<open>Rewriting to pull differences out\<close>
 
 lemma diff_diff_right [simp]: "k \<le> j \<Longrightarrow> i - (j - k) = i + k - j"
   for i j k :: nat
   by (fact diff_diff_right)
 
 lemma diff_Suc_diff_eq1 [simp]:
   assumes "k \<le> j"
   shows "i - Suc (j - k) = i + k - Suc j"
 proof -
   from assms have *: "Suc (j - k) = Suc j - k"
     by (simp add: Suc_diff_le)
   from assms have "k \<le> Suc j"
     by (rule order_trans) simp
   with diff_diff_right [of k "Suc j" i] * show ?thesis
     by simp
 qed
 
 lemma diff_Suc_diff_eq2 [simp]:
   assumes "k \<le> j"
   shows "Suc (j - k) - i = Suc j - (k + i)"
 proof -
   from assms obtain n where "j = k + n"
     by (auto dest: le_Suc_ex)
   moreover have "Suc n - i = (k + Suc n) - (k + i)"
     using add_diff_cancel_left [of k "Suc n" i] by simp
   ultimately show ?thesis by simp
 qed
 
 lemma Suc_diff_Suc:
   assumes "n < m"
   shows "Suc (m - Suc n) = m - n"
 proof -
   from assms obtain q where "m = n + Suc q"
     by (auto dest: less_imp_Suc_add)
   moreover define r where "r = Suc q"
   ultimately have "Suc (m - Suc n) = r" and "m = n + r"
     by simp_all
   then show ?thesis by simp
 qed
 
 lemma one_less_mult: "Suc 0 < n \<Longrightarrow> Suc 0 < m \<Longrightarrow> Suc 0 < m * n"
   using less_1_mult [of n m] by (simp add: ac_simps)
 
 lemma n_less_m_mult_n: "0 < n \<Longrightarrow> Suc 0 < m \<Longrightarrow> n < m * n"
   using mult_strict_right_mono [of 1 m n] by simp
 
 lemma n_less_n_mult_m: "0 < n \<Longrightarrow> Suc 0 < m \<Longrightarrow> n < n * m"
   using mult_strict_left_mono [of 1 m n] by simp
 
 
 text \<open>Induction starting beyond zero\<close>
 
 lemma nat_induct_at_least [consumes 1, case_names base Suc]:
   "P n" if "n \<ge> m" "P m" "\<And>n. n \<ge> m \<Longrightarrow> P n \<Longrightarrow> P (Suc n)"
 proof -
   define q where "q = n - m"
   with \<open>n \<ge> m\<close> have "n = m + q"
     by simp
   moreover have "P (m + q)"
     by (induction q) (use that in simp_all)
   ultimately show "P n"
     by simp
 qed
 
 lemma nat_induct_non_zero [consumes 1, case_names 1 Suc]:
   "P n" if "n > 0" "P 1" "\<And>n. n > 0 \<Longrightarrow> P n \<Longrightarrow> P (Suc n)"
 proof -
   from \<open>n > 0\<close> have "n \<ge> 1"
     by (cases n) simp_all
   moreover note \<open>P 1\<close>
   moreover have "\<And>n. n \<ge> 1 \<Longrightarrow> P n \<Longrightarrow> P (Suc n)"
     using \<open>\<And>n. n > 0 \<Longrightarrow> P n \<Longrightarrow> P (Suc n)\<close>
     by (simp add: Suc_le_eq)
   ultimately show "P n"
     by (rule nat_induct_at_least)
 qed
 
 
 text \<open>Specialized induction principles that work "backwards":\<close>
 
 lemma inc_induct [consumes 1, case_names base step]:
   assumes less: "i \<le> j"
     and base: "P j"
     and step: "\<And>n. i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P (Suc n) \<Longrightarrow> P n"
   shows "P i"
   using less step
 proof (induct "j - i" arbitrary: i)
   case (0 i)
   then have "i = j" by simp
   with base show ?case by simp
 next
   case (Suc d n)
   from Suc.hyps have "n \<noteq> j" by auto
   with Suc have "n < j" by (simp add: less_le)
   from \<open>Suc d = j - n\<close> have "d + 1 = j - n" by simp
   then have "d + 1 - 1 = j - n - 1" by simp
   then have "d = j - n - 1" by simp
   then have "d = j - (n + 1)" by (simp add: diff_diff_eq)
   then have "d = j - Suc n" by simp
   moreover from \<open>n < j\<close> have "Suc n \<le> j" by (simp add: Suc_le_eq)
   ultimately have "P (Suc n)"
   proof (rule Suc.hyps)
     fix q
     assume "Suc n \<le> q"
     then have "n \<le> q" by (simp add: Suc_le_eq less_imp_le)
     moreover assume "q < j"
     moreover assume "P (Suc q)"
     ultimately show "P q" by (rule Suc.prems)
   qed
   with order_refl \<open>n < j\<close> show "P n" by (rule Suc.prems)
 qed
 
 lemma strict_inc_induct [consumes 1, case_names base step]:
   assumes less: "i < j"
     and base: "\<And>i. j = Suc i \<Longrightarrow> P i"
     and step: "\<And>i. i < j \<Longrightarrow> P (Suc i) \<Longrightarrow> P i"
   shows "P i"
 using less proof (induct "j - i - 1" arbitrary: i)
   case (0 i)
   from \<open>i < j\<close> obtain n where "j = i + n" and "n > 0"
     by (auto dest!: less_imp_Suc_add)
   with 0 have "j = Suc i"
     by (auto intro: order_antisym simp add: Suc_le_eq)
   with base show ?case by simp
 next
   case (Suc d i)
   from \<open>Suc d = j - i - 1\<close> have *: "Suc d = j - Suc i"
     by (simp add: diff_diff_add)
   then have "Suc d - 1 = j - Suc i - 1" by simp
   then have "d = j - Suc i - 1" by simp
   moreover from * have "j - Suc i \<noteq> 0" by auto
   then have "Suc i < j" by (simp add: not_le)
   ultimately have "P (Suc i)" by (rule Suc.hyps)
   with \<open>i < j\<close> show "P i" by (rule step)
 qed
 
 lemma zero_induct_lemma: "P k \<Longrightarrow> (\<And>n. P (Suc n) \<Longrightarrow> P n) \<Longrightarrow> P (k - i)"
   using inc_induct[of "k - i" k P, simplified] by blast
 
 lemma zero_induct: "P k \<Longrightarrow> (\<And>n. P (Suc n) \<Longrightarrow> P n) \<Longrightarrow> P 0"
   using inc_induct[of 0 k P] by blast
 
 text \<open>Further induction rule similar to @{thm inc_induct}.\<close>
 
 lemma dec_induct [consumes 1, case_names base step]:
   "i \<le> j \<Longrightarrow> P i \<Longrightarrow> (\<And>n. i \<le> n \<Longrightarrow> n < j \<Longrightarrow> P n \<Longrightarrow> P (Suc n)) \<Longrightarrow> P j"
 proof (induct j arbitrary: i)
   case 0
   then show ?case by simp
 next
   case (Suc j)
   from Suc.prems consider "i \<le> j" | "i = Suc j"
     by (auto simp add: le_Suc_eq)
   then show ?case
   proof cases
     case 1
     moreover have "j < Suc j" by simp
     moreover have "P j" using \<open>i \<le> j\<close> \<open>P i\<close>
     proof (rule Suc.hyps)
       fix q
       assume "i \<le> q"
       moreover assume "q < j" then have "q < Suc j"
         by (simp add: less_Suc_eq)
       moreover assume "P q"
       ultimately show "P (Suc q)" by (rule Suc.prems)
     qed
     ultimately show "P (Suc j)" by (rule Suc.prems)
   next
     case 2
     with \<open>P i\<close> show "P (Suc j)" by simp
   qed
 qed
 
 lemma transitive_stepwise_le:
   assumes "m \<le> n" "\<And>x. R x x" "\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z" and "\<And>n. R n (Suc n)"
   shows "R m n"
 using \<open>m \<le> n\<close>  
   by (induction rule: dec_induct) (use assms in blast)+
 
 
 subsubsection \<open>Greatest operator\<close>
 
 lemma ex_has_greatest_nat:
   "P (k::nat) \<Longrightarrow> \<forall>y. P y \<longrightarrow> y \<le> b \<Longrightarrow> \<exists>x. P x \<and> (\<forall>y. P y \<longrightarrow> y \<le> x)"
 proof (induction "b-k" arbitrary: b k rule: less_induct)
   case less
   show ?case
   proof cases
     assume "\<exists>n>k. P n"
     then obtain n where "n>k" "P n" by blast
     have "n \<le> b" using \<open>P n\<close> less.prems(2) by auto
     hence "b-n < b-k"
       by(rule diff_less_mono2[OF \<open>k<n\<close> less_le_trans[OF \<open>k<n\<close>]])
     from less.hyps[OF this \<open>P n\<close> less.prems(2)]
     show ?thesis .
   next
     assume "\<not> (\<exists>n>k. P n)"
     hence "\<forall>y. P y \<longrightarrow> y \<le> k" by (auto simp: not_less)
     thus ?thesis using less.prems(1) by auto
   qed
 qed
 
 lemma
   fixes k::nat
   assumes "P k" and minor: "\<And>y. P y \<Longrightarrow> y \<le> b"
   shows GreatestI_nat: "P (Greatest P)" 
     and Greatest_le_nat: "k \<le> Greatest P"
 proof -
   obtain x where "P x" "\<And>y. P y \<Longrightarrow> y \<le> x"
     using assms ex_has_greatest_nat by blast
   with \<open>P k\<close> show "P (Greatest P)" "k \<le> Greatest P"
     using GreatestI2_order by blast+
 qed
 
 lemma GreatestI_ex_nat:
   "\<lbrakk> \<exists>k::nat. P k;  \<And>y. P y \<Longrightarrow> y \<le> b \<rbrakk> \<Longrightarrow> P (Greatest P)"
   by (blast intro: GreatestI_nat)
 
 
 subsection \<open>Monotonicity of \<open>funpow\<close>\<close>
 
 lemma funpow_increasing: "m \<le> n \<Longrightarrow> mono f \<Longrightarrow> (f ^^ n) \<top> \<le> (f ^^ m) \<top>"
   for f :: "'a::{lattice,order_top} \<Rightarrow> 'a"
   by (induct rule: inc_induct)
     (auto simp del: funpow.simps(2) simp add: funpow_Suc_right
       intro: order_trans[OF _ funpow_mono])
 
 lemma funpow_decreasing: "m \<le> n \<Longrightarrow> mono f \<Longrightarrow> (f ^^ m) \<bottom> \<le> (f ^^ n) \<bottom>"
   for f :: "'a::{lattice,order_bot} \<Rightarrow> 'a"
   by (induct rule: dec_induct)
     (auto simp del: funpow.simps(2) simp add: funpow_Suc_right
       intro: order_trans[OF _ funpow_mono])
 
 lemma mono_funpow: "mono Q \<Longrightarrow> mono (\<lambda>i. (Q ^^ i) \<bottom>)"
   for Q :: "'a::{lattice,order_bot} \<Rightarrow> 'a"
   by (auto intro!: funpow_decreasing simp: mono_def)
 
 lemma antimono_funpow: "mono Q \<Longrightarrow> antimono (\<lambda>i. (Q ^^ i) \<top>)"
   for Q :: "'a::{lattice,order_top} \<Rightarrow> 'a"
   by (auto intro!: funpow_increasing simp: antimono_def)
 
 
 subsection \<open>The divides relation on \<^typ>\<open>nat\<close>\<close>
 
 lemma dvd_1_left [iff]: "Suc 0 dvd k"
   by (simp add: dvd_def)
 
 lemma dvd_1_iff_1 [simp]: "m dvd Suc 0 \<longleftrightarrow> m = Suc 0"
   by (simp add: dvd_def)
 
 lemma nat_dvd_1_iff_1 [simp]: "m dvd 1 \<longleftrightarrow> m = 1"
   for m :: nat
   by (simp add: dvd_def)
 
 lemma dvd_antisym: "m dvd n \<Longrightarrow> n dvd m \<Longrightarrow> m = n"
   for m n :: nat
   unfolding dvd_def by (force dest: mult_eq_self_implies_10 simp add: mult.assoc)
 
 lemma dvd_diff_nat [simp]: "k dvd m \<Longrightarrow> k dvd n \<Longrightarrow> k dvd (m - n)"
   for k m n :: nat
   unfolding dvd_def by (blast intro: right_diff_distrib' [symmetric])
 
 lemma dvd_diffD: 
   fixes k m n :: nat
   assumes "k dvd m - n" "k dvd n" "n \<le> m"
   shows "k dvd m"
 proof -
   have "k dvd n + (m - n)"
     using assms by (blast intro: dvd_add)
   with assms show ?thesis
     by simp
 qed
 
 lemma dvd_diffD1: "k dvd m - n \<Longrightarrow> k dvd m \<Longrightarrow> n \<le> m \<Longrightarrow> k dvd n"
   for k m n :: nat
   by (drule_tac m = m in dvd_diff_nat) auto
 
 lemma dvd_mult_cancel:
   fixes m n k :: nat
   assumes "k * m dvd k * n" and "0 < k"
   shows "m dvd n"
 proof -
   from assms(1) obtain q where "k * n = (k * m) * q" ..
   then have "k * n = k * (m * q)" by (simp add: ac_simps)
   with \<open>0 < k\<close> have "n = m * q" by (auto simp add: mult_left_cancel)
   then show ?thesis ..
 qed
 
 lemma dvd_mult_cancel1:
   fixes m n :: nat
   assumes "0 < m"
   shows "m * n dvd m \<longleftrightarrow> n = 1"
 proof 
   assume "m * n dvd m"
   then have "m * n dvd m * 1"
     by simp
   then have "n dvd 1"
     by (iprover intro: assms dvd_mult_cancel)
   then show "n = 1"
     by auto
 qed auto
 
 lemma dvd_mult_cancel2: "0 < m \<Longrightarrow> n * m dvd m \<longleftrightarrow> n = 1"
   for m n :: nat
   using dvd_mult_cancel1 [of m n] by (simp add: ac_simps)
 
 lemma dvd_imp_le: "k dvd n \<Longrightarrow> 0 < n \<Longrightarrow> k \<le> n"
   for k n :: nat
   by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
 
 lemma nat_dvd_not_less: "0 < m \<Longrightarrow> m < n \<Longrightarrow> \<not> n dvd m"
   for m n :: nat
   by (auto elim!: dvdE) (auto simp add: gr0_conv_Suc)
 
 lemma less_eq_dvd_minus:
   fixes m n :: nat
   assumes "m \<le> n"
   shows "m dvd n \<longleftrightarrow> m dvd n - m"
 proof -
   from assms have "n = m + (n - m)" by simp
   then obtain q where "n = m + q" ..
   then show ?thesis by (simp add: add.commute [of m])
 qed
 
 lemma dvd_minus_self: "m dvd n - m \<longleftrightarrow> n < m \<or> m dvd n"
   for m n :: nat
   by (cases "n < m") (auto elim!: dvdE simp add: not_less le_imp_diff_is_add dest: less_imp_le)
 
 lemma dvd_minus_add:
   fixes m n q r :: nat
   assumes "q \<le> n" "q \<le> r * m"
   shows "m dvd n - q \<longleftrightarrow> m dvd n + (r * m - q)"
 proof -
   have "m dvd n - q \<longleftrightarrow> m dvd r * m + (n - q)"
     using dvd_add_times_triv_left_iff [of m r] by simp
   also from assms have "\<dots> \<longleftrightarrow> m dvd r * m + n - q" by simp
   also from assms have "\<dots> \<longleftrightarrow> m dvd (r * m - q) + n" by simp
   also have "\<dots> \<longleftrightarrow> m dvd n + (r * m - q)" by (simp add: add.commute)
   finally show ?thesis .
 qed
 
 
 subsection \<open>Aliasses\<close>
 
 lemma nat_mult_1: "1 * n = n"
   for n :: nat
   by (fact mult_1_left)
 
 lemma nat_mult_1_right: "n * 1 = n"
   for n :: nat
   by (fact mult_1_right)
 
 lemma diff_mult_distrib: "(m - n) * k = (m * k) - (n * k)"
   for k m n :: nat
   by (fact left_diff_distrib')
 
 lemma diff_mult_distrib2: "k * (m - n) = (k * m) - (k * n)"
   for k m n :: nat
   by (fact right_diff_distrib')
 
 (*Used in AUTO2 and Groups.le_diff_conv2 (with variables renamed) doesn't work for some reason*)
 lemma le_diff_conv2: "k \<le> j \<Longrightarrow> (i \<le> j - k) = (i + k \<le> j)"
   for i j k :: nat
   by (fact le_diff_conv2) 
 
 lemma diff_self_eq_0 [simp]: "m - m = 0"
   for m :: nat
   by (fact diff_cancel)
 
 lemma diff_diff_left [simp]: "i - j - k = i - (j + k)"
   for i j k :: nat
   by (fact diff_diff_add)
 
 lemma diff_commute: "i - j - k = i - k - j"
   for i j k :: nat
   by (fact diff_right_commute)
 
 lemma diff_add_inverse: "(n + m) - n = m"
   for m n :: nat
   by (fact add_diff_cancel_left')
 
 lemma diff_add_inverse2: "(m + n) - n = m"
   for m n :: nat
   by (fact add_diff_cancel_right')
 
 lemma diff_cancel: "(k + m) - (k + n) = m - n"
   for k m n :: nat
   by (fact add_diff_cancel_left)
 
 lemma diff_cancel2: "(m + k) - (n + k) = m - n"
   for k m n :: nat
   by (fact add_diff_cancel_right)
 
 lemma diff_add_0: "n - (n + m) = 0"
   for m n :: nat
   by (fact diff_add_zero)
 
 lemma add_mult_distrib2: "k * (m + n) = (k * m) + (k * n)"
   for k m n :: nat
   by (fact distrib_left)
 
 lemmas nat_distrib =
   add_mult_distrib distrib_left diff_mult_distrib diff_mult_distrib2
 
 
 subsection \<open>Size of a datatype value\<close>
 
 class size =
   fixes size :: "'a \<Rightarrow> nat" \<comment> \<open>see further theory \<open>Wellfounded\<close>\<close>
 
 instantiation nat :: size
 begin
 
 definition size_nat where [simp, code]: "size (n::nat) = n"
 
 instance ..
 
 end
 
 lemmas size_nat = size_nat_def
 
 lemma size_neq_size_imp_neq: "size x \<noteq> size y \<Longrightarrow> x \<noteq> y"
   by (erule contrapos_nn) (rule arg_cong)
 
 
 subsection \<open>Code module namespace\<close>
 
 code_identifier
   code_module Nat \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 hide_const (open) of_nat_aux
 
 end
diff --git a/src/HOL/Num.thy b/src/HOL/Num.thy
--- a/src/HOL/Num.thy
+++ b/src/HOL/Num.thy
@@ -1,1530 +1,1553 @@
 (*  Title:      HOL/Num.thy
     Author:     Florian Haftmann
     Author:     Brian Huffman
 *)
 
 section \<open>Binary Numerals\<close>
 
 theory Num
   imports BNF_Least_Fixpoint Transfer
 begin
 
 subsection \<open>The \<open>num\<close> type\<close>
 
 datatype num = One | Bit0 num | Bit1 num
 
 text \<open>Increment function for type \<^typ>\<open>num\<close>\<close>
 
 primrec inc :: "num \<Rightarrow> num"
   where
     "inc One = Bit0 One"
   | "inc (Bit0 x) = Bit1 x"
   | "inc (Bit1 x) = Bit0 (inc x)"
 
 text \<open>Converting between type \<^typ>\<open>num\<close> and type \<^typ>\<open>nat\<close>\<close>
 
 primrec nat_of_num :: "num \<Rightarrow> nat"
   where
     "nat_of_num One = Suc 0"
   | "nat_of_num (Bit0 x) = nat_of_num x + nat_of_num x"
   | "nat_of_num (Bit1 x) = Suc (nat_of_num x + nat_of_num x)"
 
 primrec num_of_nat :: "nat \<Rightarrow> num"
   where
     "num_of_nat 0 = One"
   | "num_of_nat (Suc n) = (if 0 < n then inc (num_of_nat n) else One)"
 
 lemma nat_of_num_pos: "0 < nat_of_num x"
   by (induct x) simp_all
 
 lemma nat_of_num_neq_0: " nat_of_num x \<noteq> 0"
   by (induct x) simp_all
 
 lemma nat_of_num_inc: "nat_of_num (inc x) = Suc (nat_of_num x)"
   by (induct x) simp_all
 
 lemma num_of_nat_double: "0 < n \<Longrightarrow> num_of_nat (n + n) = Bit0 (num_of_nat n)"
   by (induct n) simp_all
 
 text \<open>Type \<^typ>\<open>num\<close> is isomorphic to the strictly positive natural numbers.\<close>
 
 lemma nat_of_num_inverse: "num_of_nat (nat_of_num x) = x"
   by (induct x) (simp_all add: num_of_nat_double nat_of_num_pos)
 
 lemma num_of_nat_inverse: "0 < n \<Longrightarrow> nat_of_num (num_of_nat n) = n"
   by (induct n) (simp_all add: nat_of_num_inc)
 
 lemma num_eq_iff: "x = y \<longleftrightarrow> nat_of_num x = nat_of_num y"
   apply safe
   apply (drule arg_cong [where f=num_of_nat])
   apply (simp add: nat_of_num_inverse)
   done
 
 lemma num_induct [case_names One inc]:
   fixes P :: "num \<Rightarrow> bool"
   assumes One: "P One"
     and inc: "\<And>x. P x \<Longrightarrow> P (inc x)"
   shows "P x"
 proof -
   obtain n where n: "Suc n = nat_of_num x"
     by (cases "nat_of_num x") (simp_all add: nat_of_num_neq_0)
   have "P (num_of_nat (Suc n))"
   proof (induct n)
     case 0
     from One show ?case by simp
   next
     case (Suc n)
     then have "P (inc (num_of_nat (Suc n)))" by (rule inc)
     then show "P (num_of_nat (Suc (Suc n)))" by simp
   qed
   with n show "P x"
     by (simp add: nat_of_num_inverse)
 qed
 
 text \<open>
   From now on, there are two possible models for \<^typ>\<open>num\<close>: as positive
   naturals (rule \<open>num_induct\<close>) and as digit representation (rules
   \<open>num.induct\<close>, \<open>num.cases\<close>).
 \<close>
 
 
 subsection \<open>Numeral operations\<close>
 
 instantiation num :: "{plus,times,linorder}"
 begin
 
 definition [code del]: "m + n = num_of_nat (nat_of_num m + nat_of_num n)"
 
 definition [code del]: "m * n = num_of_nat (nat_of_num m * nat_of_num n)"
 
 definition [code del]: "m \<le> n \<longleftrightarrow> nat_of_num m \<le> nat_of_num n"
 
 definition [code del]: "m < n \<longleftrightarrow> nat_of_num m < nat_of_num n"
 
 instance
   by standard (auto simp add: less_num_def less_eq_num_def num_eq_iff)
 
 end
 
 lemma nat_of_num_add: "nat_of_num (x + y) = nat_of_num x + nat_of_num y"
   unfolding plus_num_def
   by (intro num_of_nat_inverse add_pos_pos nat_of_num_pos)
 
 lemma nat_of_num_mult: "nat_of_num (x * y) = nat_of_num x * nat_of_num y"
   unfolding times_num_def
   by (intro num_of_nat_inverse mult_pos_pos nat_of_num_pos)
 
 lemma add_num_simps [simp, code]:
   "One + One = Bit0 One"
   "One + Bit0 n = Bit1 n"
   "One + Bit1 n = Bit0 (n + One)"
   "Bit0 m + One = Bit1 m"
   "Bit0 m + Bit0 n = Bit0 (m + n)"
   "Bit0 m + Bit1 n = Bit1 (m + n)"
   "Bit1 m + One = Bit0 (m + One)"
   "Bit1 m + Bit0 n = Bit1 (m + n)"
   "Bit1 m + Bit1 n = Bit0 (m + n + One)"
   by (simp_all add: num_eq_iff nat_of_num_add)
 
 lemma mult_num_simps [simp, code]:
   "m * One = m"
   "One * n = n"
   "Bit0 m * Bit0 n = Bit0 (Bit0 (m * n))"
   "Bit0 m * Bit1 n = Bit0 (m * Bit1 n)"
   "Bit1 m * Bit0 n = Bit0 (Bit1 m * n)"
   "Bit1 m * Bit1 n = Bit1 (m + n + Bit0 (m * n))"
   by (simp_all add: num_eq_iff nat_of_num_add nat_of_num_mult distrib_right distrib_left)
 
 lemma eq_num_simps:
   "One = One \<longleftrightarrow> True"
   "One = Bit0 n \<longleftrightarrow> False"
   "One = Bit1 n \<longleftrightarrow> False"
   "Bit0 m = One \<longleftrightarrow> False"
   "Bit1 m = One \<longleftrightarrow> False"
   "Bit0 m = Bit0 n \<longleftrightarrow> m = n"
   "Bit0 m = Bit1 n \<longleftrightarrow> False"
   "Bit1 m = Bit0 n \<longleftrightarrow> False"
   "Bit1 m = Bit1 n \<longleftrightarrow> m = n"
   by simp_all
 
 lemma le_num_simps [simp, code]:
   "One \<le> n \<longleftrightarrow> True"
   "Bit0 m \<le> One \<longleftrightarrow> False"
   "Bit1 m \<le> One \<longleftrightarrow> False"
   "Bit0 m \<le> Bit0 n \<longleftrightarrow> m \<le> n"
   "Bit0 m \<le> Bit1 n \<longleftrightarrow> m \<le> n"
   "Bit1 m \<le> Bit1 n \<longleftrightarrow> m \<le> n"
   "Bit1 m \<le> Bit0 n \<longleftrightarrow> m < n"
   using nat_of_num_pos [of n] nat_of_num_pos [of m]
   by (auto simp add: less_eq_num_def less_num_def)
 
 lemma less_num_simps [simp, code]:
   "m < One \<longleftrightarrow> False"
   "One < Bit0 n \<longleftrightarrow> True"
   "One < Bit1 n \<longleftrightarrow> True"
   "Bit0 m < Bit0 n \<longleftrightarrow> m < n"
   "Bit0 m < Bit1 n \<longleftrightarrow> m \<le> n"
   "Bit1 m < Bit1 n \<longleftrightarrow> m < n"
   "Bit1 m < Bit0 n \<longleftrightarrow> m < n"
   using nat_of_num_pos [of n] nat_of_num_pos [of m]
   by (auto simp add: less_eq_num_def less_num_def)
 
 lemma le_num_One_iff: "x \<le> num.One \<longleftrightarrow> x = num.One"
   by (simp add: antisym_conv)
 
 text \<open>Rules using \<open>One\<close> and \<open>inc\<close> as constructors.\<close>
 
 lemma add_One: "x + One = inc x"
   by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)
 
 lemma add_One_commute: "One + n = n + One"
   by (induct n) simp_all
 
 lemma add_inc: "x + inc y = inc (x + y)"
   by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)
 
 lemma mult_inc: "x * inc y = x * y + x"
   by (simp add: num_eq_iff nat_of_num_mult nat_of_num_add nat_of_num_inc)
 
 text \<open>The \<^const>\<open>num_of_nat\<close> conversion.\<close>
 
 lemma num_of_nat_One: "n \<le> 1 \<Longrightarrow> num_of_nat n = One"
   by (cases n) simp_all
 
 lemma num_of_nat_plus_distrib:
   "0 < m \<Longrightarrow> 0 < n \<Longrightarrow> num_of_nat (m + n) = num_of_nat m + num_of_nat n"
   by (induct n) (auto simp add: add_One add_One_commute add_inc)
 
 text \<open>A double-and-decrement function.\<close>
 
 primrec BitM :: "num \<Rightarrow> num"
   where
     "BitM One = One"
   | "BitM (Bit0 n) = Bit1 (BitM n)"
   | "BitM (Bit1 n) = Bit1 (Bit0 n)"
 
 lemma BitM_plus_one: "BitM n + One = Bit0 n"
   by (induct n) simp_all
 
 lemma one_plus_BitM: "One + BitM n = Bit0 n"
   unfolding add_One_commute BitM_plus_one ..
 
 lemma BitM_inc_eq:
   \<open>Num.BitM (Num.inc n) = Num.Bit1 n\<close>
   by (induction n) simp_all
 
 lemma inc_BitM_eq:
   \<open>Num.inc (Num.BitM n) = num.Bit0 n\<close>
   by (simp add: BitM_plus_one[symmetric] add_One)
 
 text \<open>Squaring and exponentiation.\<close>
 
 primrec sqr :: "num \<Rightarrow> num"
   where
     "sqr One = One"
   | "sqr (Bit0 n) = Bit0 (Bit0 (sqr n))"
   | "sqr (Bit1 n) = Bit1 (Bit0 (sqr n + n))"
 
 primrec pow :: "num \<Rightarrow> num \<Rightarrow> num"
   where
     "pow x One = x"
   | "pow x (Bit0 y) = sqr (pow x y)"
   | "pow x (Bit1 y) = sqr (pow x y) * x"
 
 lemma nat_of_num_sqr: "nat_of_num (sqr x) = nat_of_num x * nat_of_num x"
   by (induct x) (simp_all add: algebra_simps nat_of_num_add)
 
 lemma sqr_conv_mult: "sqr x = x * x"
   by (simp add: num_eq_iff nat_of_num_sqr nat_of_num_mult)
 
 lemma num_double [simp]:
   "num.Bit0 num.One * n = num.Bit0 n"
   by (simp add: num_eq_iff nat_of_num_mult)
 
 
 subsection \<open>Binary numerals\<close>
 
 text \<open>
   We embed binary representations into a generic algebraic
   structure using \<open>numeral\<close>.
 \<close>
 
 class numeral = one + semigroup_add
 begin
 
 primrec numeral :: "num \<Rightarrow> 'a"
   where
     numeral_One: "numeral One = 1"
   | numeral_Bit0: "numeral (Bit0 n) = numeral n + numeral n"
   | numeral_Bit1: "numeral (Bit1 n) = numeral n + numeral n + 1"
 
 lemma numeral_code [code]:
   "numeral One = 1"
   "numeral (Bit0 n) = (let m = numeral n in m + m)"
   "numeral (Bit1 n) = (let m = numeral n in m + m + 1)"
   by (simp_all add: Let_def)
 
 lemma one_plus_numeral_commute: "1 + numeral x = numeral x + 1"
 proof (induct x)
   case One
   then show ?case by simp
 next
   case Bit0
   then show ?case by (simp add: add.assoc [symmetric]) (simp add: add.assoc)
 next
   case Bit1
   then show ?case by (simp add: add.assoc [symmetric]) (simp add: add.assoc)
 qed
 
 lemma numeral_inc: "numeral (inc x) = numeral x + 1"
 proof (induct x)
   case One
   then show ?case by simp
 next
   case Bit0
   then show ?case by simp
 next
   case (Bit1 x)
   have "numeral x + (1 + numeral x) + 1 = numeral x + (numeral x + 1) + 1"
     by (simp only: one_plus_numeral_commute)
   with Bit1 show ?case
     by (simp add: add.assoc)
 qed
 
 declare numeral.simps [simp del]
 
 abbreviation "Numeral1 \<equiv> numeral One"
 
 declare numeral_One [code_post]
 
 end
 
 text \<open>Numeral syntax.\<close>
 
 syntax
   "_Numeral" :: "num_const \<Rightarrow> 'a"    ("_")
 
 ML_file \<open>Tools/numeral.ML\<close>
 
 parse_translation \<open>
   let
     fun numeral_tr [(c as Const (\<^syntax_const>\<open>_constrain\<close>, _)) $ t $ u] =
           c $ numeral_tr [t] $ u
       | numeral_tr [Const (num, _)] =
           (Numeral.mk_number_syntax o #value o Lexicon.read_num) num
       | numeral_tr ts = raise TERM ("numeral_tr", ts);
   in [(\<^syntax_const>\<open>_Numeral\<close>, K numeral_tr)] end
 \<close>
 
 typed_print_translation \<open>
   let
     fun num_tr' ctxt T [n] =
       let
         val k = Numeral.dest_num_syntax n;
         val t' =
           Syntax.const \<^syntax_const>\<open>_Numeral\<close> $
             Syntax.free (string_of_int k);
       in
         (case T of
           Type (\<^type_name>\<open>fun\<close>, [_, T']) =>
             if Printer.type_emphasis ctxt T' then
               Syntax.const \<^syntax_const>\<open>_constrain\<close> $ t' $
                 Syntax_Phases.term_of_typ ctxt T'
             else t'
         | _ => if T = dummyT then t' else raise Match)
       end;
   in
    [(\<^const_syntax>\<open>numeral\<close>, num_tr')]
   end
 \<close>
 
 
 subsection \<open>Class-specific numeral rules\<close>
 
 text \<open>\<^const>\<open>numeral\<close> is a morphism.\<close>
 
 
 subsubsection \<open>Structures with addition: class \<open>numeral\<close>\<close>
 
 context numeral
 begin
 
 lemma numeral_add: "numeral (m + n) = numeral m + numeral n"
   by (induct n rule: num_induct)
     (simp_all only: numeral_One add_One add_inc numeral_inc add.assoc)
 
 lemma numeral_plus_numeral: "numeral m + numeral n = numeral (m + n)"
   by (rule numeral_add [symmetric])
 
 lemma numeral_plus_one: "numeral n + 1 = numeral (n + One)"
   using numeral_add [of n One] by (simp add: numeral_One)
 
 lemma one_plus_numeral: "1 + numeral n = numeral (One + n)"
   using numeral_add [of One n] by (simp add: numeral_One)
 
 lemma one_add_one: "1 + 1 = 2"
   using numeral_add [of One One] by (simp add: numeral_One)
 
 lemmas add_numeral_special =
   numeral_plus_one one_plus_numeral one_add_one
 
 end
 
 
 subsubsection \<open>Structures with negation: class \<open>neg_numeral\<close>\<close>
 
 class neg_numeral = numeral + group_add
 begin
 
 lemma uminus_numeral_One: "- Numeral1 = - 1"
   by (simp add: numeral_One)
 
 text \<open>Numerals form an abelian subgroup.\<close>
 
 inductive is_num :: "'a \<Rightarrow> bool"
   where
     "is_num 1"
   | "is_num x \<Longrightarrow> is_num (- x)"
   | "is_num x \<Longrightarrow> is_num y \<Longrightarrow> is_num (x + y)"
 
 lemma is_num_numeral: "is_num (numeral k)"
   by (induct k) (simp_all add: numeral.simps is_num.intros)
 
 lemma is_num_add_commute: "is_num x \<Longrightarrow> is_num y \<Longrightarrow> x + y = y + x"
-  apply (induct x rule: is_num.induct)
-    apply (induct y rule: is_num.induct)
-      apply simp
-     apply (rule_tac a=x in add_left_imp_eq)
-     apply (rule_tac a=x in add_right_imp_eq)
-     apply (simp add: add.assoc)
-    apply (simp add: add.assoc [symmetric])
-    apply (simp add: add.assoc)
-   apply (rule_tac a=x in add_left_imp_eq)
-   apply (rule_tac a=x in add_right_imp_eq)
-   apply (simp add: add.assoc)
-  apply (simp add: add.assoc)
-  apply (simp add: add.assoc [symmetric])
-  done
+proof(induction x rule: is_num.induct)
+  case 1
+  then show ?case
+  proof (induction y rule: is_num.induct)
+    case 1
+    then show ?case by simp
+  next
+    case (2 y)
+    then have "y + (1 + - y) + y = y + (- y + 1) + y"
+      by (simp add: add.assoc)
+    then have "y + (1 + - y) = y + (- y + 1)"
+      by simp
+    then show ?case
+      by (rule add_left_imp_eq[of y])
+  next
+    case (3 x y)
+    then have "1 + (x + y) = x + 1 + y"
+      by (simp add: add.assoc [symmetric])
+    then show ?case using 3
+      by (simp add: add.assoc)
+  qed
+next
+  case (2 x)
+  then have "x + (- x + y) + x = x + (y + - x) + x"
+    by (simp add: add.assoc)
+  then have "x + (- x + y) = x + (y + - x)"
+    by simp
+  then show ?case
+    by (rule add_left_imp_eq[of x])
+next
+  case (3 x z)
+  moreover have "x + (y + z) = (x + y) + z"
+    by (simp add: add.assoc[symmetric])
+  ultimately show ?case 
+    by (simp add: add.assoc)
+qed
 
 lemma is_num_add_left_commute: "is_num x \<Longrightarrow> is_num y \<Longrightarrow> x + (y + z) = y + (x + z)"
   by (simp only: add.assoc [symmetric] is_num_add_commute)
 
 lemmas is_num_normalize =
   add.assoc is_num_add_commute is_num_add_left_commute
   is_num.intros is_num_numeral
   minus_add
 
 definition dbl :: "'a \<Rightarrow> 'a"
   where "dbl x = x + x"
 
 definition dbl_inc :: "'a \<Rightarrow> 'a"
   where "dbl_inc x = x + x + 1"
 
 definition dbl_dec :: "'a \<Rightarrow> 'a"
   where "dbl_dec x = x + x - 1"
 
 definition sub :: "num \<Rightarrow> num \<Rightarrow> 'a"
   where "sub k l = numeral k - numeral l"
 
 lemma numeral_BitM: "numeral (BitM n) = numeral (Bit0 n) - 1"
   by (simp only: BitM_plus_one [symmetric] numeral_add numeral_One eq_diff_eq)
 
 lemma sub_inc_One_eq:
   \<open>Num.sub (Num.inc n) num.One = numeral n\<close>
   by (simp_all add: sub_def diff_eq_eq numeral_inc numeral.numeral_One)
 
 lemma dbl_simps [simp]:
   "dbl (- numeral k) = - dbl (numeral k)"
   "dbl 0 = 0"
   "dbl 1 = 2"
   "dbl (- 1) = - 2"
   "dbl (numeral k) = numeral (Bit0 k)"
   by (simp_all add: dbl_def numeral.simps minus_add)
 
 lemma dbl_inc_simps [simp]:
   "dbl_inc (- numeral k) = - dbl_dec (numeral k)"
   "dbl_inc 0 = 1"
   "dbl_inc 1 = 3"
   "dbl_inc (- 1) = - 1"
   "dbl_inc (numeral k) = numeral (Bit1 k)"
   by (simp_all add: dbl_inc_def dbl_dec_def numeral.simps numeral_BitM is_num_normalize algebra_simps
       del: add_uminus_conv_diff)
 
 lemma dbl_dec_simps [simp]:
   "dbl_dec (- numeral k) = - dbl_inc (numeral k)"
   "dbl_dec 0 = - 1"
   "dbl_dec 1 = 1"
   "dbl_dec (- 1) = - 3"
   "dbl_dec (numeral k) = numeral (BitM k)"
   by (simp_all add: dbl_dec_def dbl_inc_def numeral.simps numeral_BitM is_num_normalize)
 
 lemma sub_num_simps [simp]:
   "sub One One = 0"
   "sub One (Bit0 l) = - numeral (BitM l)"
   "sub One (Bit1 l) = - numeral (Bit0 l)"
   "sub (Bit0 k) One = numeral (BitM k)"
   "sub (Bit1 k) One = numeral (Bit0 k)"
   "sub (Bit0 k) (Bit0 l) = dbl (sub k l)"
   "sub (Bit0 k) (Bit1 l) = dbl_dec (sub k l)"
   "sub (Bit1 k) (Bit0 l) = dbl_inc (sub k l)"
   "sub (Bit1 k) (Bit1 l) = dbl (sub k l)"
   by (simp_all add: dbl_def dbl_dec_def dbl_inc_def sub_def numeral.simps
     numeral_BitM is_num_normalize del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma add_neg_numeral_simps:
   "numeral m + - numeral n = sub m n"
   "- numeral m + numeral n = sub n m"
   "- numeral m + - numeral n = - (numeral m + numeral n)"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma add_neg_numeral_special:
   "1 + - numeral m = sub One m"
   "- numeral m + 1 = sub One m"
   "numeral m + - 1 = sub m One"
   "- 1 + numeral n = sub n One"
   "- 1 + - numeral n = - numeral (inc n)"
   "- numeral m + - 1 = - numeral (inc m)"
   "1 + - 1 = 0"
   "- 1 + 1 = 0"
   "- 1 + - 1 = - 2"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize right_minus numeral_inc
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma diff_numeral_simps:
   "numeral m - numeral n = sub m n"
   "numeral m - - numeral n = numeral (m + n)"
   "- numeral m - numeral n = - numeral (m + n)"
   "- numeral m - - numeral n = sub n m"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 lemma diff_numeral_special:
   "1 - numeral n = sub One n"
   "numeral m - 1 = sub m One"
   "1 - - numeral n = numeral (One + n)"
   "- numeral m - 1 = - numeral (m + One)"
   "- 1 - numeral n = - numeral (inc n)"
   "numeral m - - 1 = numeral (inc m)"
   "- 1 - - numeral n = sub n One"
   "- numeral m - - 1 = sub One m"
   "1 - 1 = 0"
   "- 1 - 1 = - 2"
   "1 - - 1 = 2"
   "- 1 - - 1 = 0"
   by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize numeral_inc
       del: add_uminus_conv_diff add: diff_conv_add_uminus)
 
 end
 
 
 subsubsection \<open>Structures with multiplication: class \<open>semiring_numeral\<close>\<close>
 
 class semiring_numeral = semiring + monoid_mult
 begin
 
 subclass numeral ..
 
 lemma numeral_mult: "numeral (m * n) = numeral m * numeral n"
   by (induct n rule: num_induct)
     (simp_all add: numeral_One mult_inc numeral_inc numeral_add distrib_left)
 
 lemma numeral_times_numeral: "numeral m * numeral n = numeral (m * n)"
   by (rule numeral_mult [symmetric])
 
 lemma mult_2: "2 * z = z + z"
   by (simp add: one_add_one [symmetric] distrib_right)
 
 lemma mult_2_right: "z * 2 = z + z"
   by (simp add: one_add_one [symmetric] distrib_left)
 
 lemma left_add_twice:
   "a + (a + b) = 2 * a + b"
   by (simp add: mult_2 ac_simps)
 
 end
 
 
 subsubsection \<open>Structures with a zero: class \<open>semiring_1\<close>\<close>
 
 context semiring_1
 begin
 
 subclass semiring_numeral ..
 
 lemma of_nat_numeral [simp]: "of_nat (numeral n) = numeral n"
   by (induct n) (simp_all only: numeral.simps numeral_class.numeral.simps of_nat_add of_nat_1)
 
 end
 
 lemma nat_of_num_numeral [code_abbrev]: "nat_of_num = numeral"
 proof
   fix n
   have "numeral n = nat_of_num n"
     by (induct n) (simp_all add: numeral.simps)
   then show "nat_of_num n = numeral n"
     by simp
 qed
 
 lemma nat_of_num_code [code]:
   "nat_of_num One = 1"
   "nat_of_num (Bit0 n) = (let m = nat_of_num n in m + m)"
   "nat_of_num (Bit1 n) = (let m = nat_of_num n in Suc (m + m))"
   by (simp_all add: Let_def)
 
 
 subsubsection \<open>Equality: class \<open>semiring_char_0\<close>\<close>
 
 context semiring_char_0
 begin
 
 lemma numeral_eq_iff: "numeral m = numeral n \<longleftrightarrow> m = n"
   by (simp only: of_nat_numeral [symmetric] nat_of_num_numeral [symmetric]
     of_nat_eq_iff num_eq_iff)
 
 lemma numeral_eq_one_iff: "numeral n = 1 \<longleftrightarrow> n = One"
   by (rule numeral_eq_iff [of n One, unfolded numeral_One])
 
 lemma one_eq_numeral_iff: "1 = numeral n \<longleftrightarrow> One = n"
   by (rule numeral_eq_iff [of One n, unfolded numeral_One])
 
 lemma numeral_neq_zero: "numeral n \<noteq> 0"
   by (simp add: of_nat_numeral [symmetric] nat_of_num_numeral [symmetric] nat_of_num_pos)
 
 lemma zero_neq_numeral: "0 \<noteq> numeral n"
   unfolding eq_commute [of 0] by (rule numeral_neq_zero)
 
 lemmas eq_numeral_simps [simp] =
   numeral_eq_iff
   numeral_eq_one_iff
   one_eq_numeral_iff
   numeral_neq_zero
   zero_neq_numeral
 
 end
 
 
 subsubsection \<open>Comparisons: class \<open>linordered_nonzero_semiring\<close>\<close>
 
 context linordered_nonzero_semiring
 begin
 
 lemma numeral_le_iff: "numeral m \<le> numeral n \<longleftrightarrow> m \<le> n"
 proof -
   have "of_nat (numeral m) \<le> of_nat (numeral n) \<longleftrightarrow> m \<le> n"
     by (simp only: less_eq_num_def nat_of_num_numeral of_nat_le_iff)
   then show ?thesis by simp
 qed
 
 lemma one_le_numeral: "1 \<le> numeral n"
   using numeral_le_iff [of num.One n] by (simp add: numeral_One)
 
 lemma numeral_le_one_iff: "numeral n \<le> 1 \<longleftrightarrow> n \<le> num.One"
   using numeral_le_iff [of n num.One] by (simp add: numeral_One)
 
 lemma numeral_less_iff: "numeral m < numeral n \<longleftrightarrow> m < n"
 proof -
   have "of_nat (numeral m) < of_nat (numeral n) \<longleftrightarrow> m < n"
     unfolding less_num_def nat_of_num_numeral of_nat_less_iff ..
   then show ?thesis by simp
 qed
 
 lemma not_numeral_less_one: "\<not> numeral n < 1"
   using numeral_less_iff [of n num.One] by (simp add: numeral_One)
 
 lemma one_less_numeral_iff: "1 < numeral n \<longleftrightarrow> num.One < n"
   using numeral_less_iff [of num.One n] by (simp add: numeral_One)
 
 lemma zero_le_numeral: "0 \<le> numeral n"
   using dual_order.trans one_le_numeral zero_le_one by blast
 
 lemma zero_less_numeral: "0 < numeral n"
   using less_linear not_numeral_less_one order.strict_trans zero_less_one by blast
 
 lemma not_numeral_le_zero: "\<not> numeral n \<le> 0"
   by (simp add: not_le zero_less_numeral)
 
 lemma not_numeral_less_zero: "\<not> numeral n < 0"
   by (simp add: not_less zero_le_numeral)
 
 lemmas le_numeral_extra =
   zero_le_one not_one_le_zero
   order_refl [of 0] order_refl [of 1]
 
 lemmas less_numeral_extra =
   zero_less_one not_one_less_zero
   less_irrefl [of 0] less_irrefl [of 1]
 
 lemmas le_numeral_simps [simp] =
   numeral_le_iff
   one_le_numeral
   numeral_le_one_iff
   zero_le_numeral
   not_numeral_le_zero
 
 lemmas less_numeral_simps [simp] =
   numeral_less_iff
   one_less_numeral_iff
   not_numeral_less_one
   zero_less_numeral
   not_numeral_less_zero
 
 lemma min_0_1 [simp]:
   fixes min' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   defines "min' \<equiv> min"
   shows
     "min' 0 1 = 0"
     "min' 1 0 = 0"
     "min' 0 (numeral x) = 0"
     "min' (numeral x) 0 = 0"
     "min' 1 (numeral x) = 1"
     "min' (numeral x) 1 = 1"
   by (simp_all add: min'_def min_def le_num_One_iff)
 
 lemma max_0_1 [simp]:
   fixes max' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
   defines "max' \<equiv> max"
   shows
     "max' 0 1 = 1"
     "max' 1 0 = 1"
     "max' 0 (numeral x) = numeral x"
     "max' (numeral x) 0 = numeral x"
     "max' 1 (numeral x) = numeral x"
     "max' (numeral x) 1 = numeral x"
   by (simp_all add: max'_def max_def le_num_One_iff)
 
 end
 
 text \<open>Unfold \<open>min\<close> and \<open>max\<close> on numerals.\<close>
 
 lemmas max_number_of [simp] =
   max_def [of "numeral u" "numeral v"]
   max_def [of "numeral u" "- numeral v"]
   max_def [of "- numeral u" "numeral v"]
   max_def [of "- numeral u" "- numeral v"] for u v
 
 lemmas min_number_of [simp] =
   min_def [of "numeral u" "numeral v"]
   min_def [of "numeral u" "- numeral v"]
   min_def [of "- numeral u" "numeral v"]
   min_def [of "- numeral u" "- numeral v"] for u v
 
 
 subsubsection \<open>Multiplication and negation: class \<open>ring_1\<close>\<close>
 
 context ring_1
 begin
 
 subclass neg_numeral ..
 
 lemma mult_neg_numeral_simps:
   "- numeral m * - numeral n = numeral (m * n)"
   "- numeral m * numeral n = - numeral (m * n)"
   "numeral m * - numeral n = - numeral (m * n)"
   by (simp_all only: mult_minus_left mult_minus_right minus_minus numeral_mult)
 
 lemma mult_minus1 [simp]: "- 1 * z = - z"
   by (simp add: numeral.simps)
 
 lemma mult_minus1_right [simp]: "z * - 1 = - z"
   by (simp add: numeral.simps)
 
 lemma minus_sub_one_diff_one [simp]:
   \<open>- sub m One - 1 = - numeral m\<close>
 proof -
   have \<open>sub m One + 1 = numeral m\<close>
     by (simp flip: eq_diff_eq add: diff_numeral_special)
   then have \<open>- (sub m One + 1) = - numeral m\<close>
     by simp
   then show ?thesis
     by simp
 qed
 
 end
 
 
 subsubsection \<open>Equality using \<open>iszero\<close> for rings with non-zero characteristic\<close>
 
 context ring_1
 begin
 
 definition iszero :: "'a \<Rightarrow> bool"
   where "iszero z \<longleftrightarrow> z = 0"
 
 lemma iszero_0 [simp]: "iszero 0"
   by (simp add: iszero_def)
 
 lemma not_iszero_1 [simp]: "\<not> iszero 1"
   by (simp add: iszero_def)
 
 lemma not_iszero_Numeral1: "\<not> iszero Numeral1"
   by (simp add: numeral_One)
 
 lemma not_iszero_neg_1 [simp]: "\<not> iszero (- 1)"
   by (simp add: iszero_def)
 
 lemma not_iszero_neg_Numeral1: "\<not> iszero (- Numeral1)"
   by (simp add: numeral_One)
 
 lemma iszero_neg_numeral [simp]: "iszero (- numeral w) \<longleftrightarrow> iszero (numeral w)"
   unfolding iszero_def by (rule neg_equal_0_iff_equal)
 
 lemma eq_iff_iszero_diff: "x = y \<longleftrightarrow> iszero (x - y)"
   unfolding iszero_def by (rule eq_iff_diff_eq_0)
 
 text \<open>
   The \<open>eq_numeral_iff_iszero\<close> lemmas are not declared \<open>[simp]\<close> by default,
   because for rings of characteristic zero, better simp rules are possible.
   For a type like integers mod \<open>n\<close>, type-instantiated versions of these rules
   should be added to the simplifier, along with a type-specific rule for
   deciding propositions of the form \<open>iszero (numeral w)\<close>.
 
   bh: Maybe it would not be so bad to just declare these as simp rules anyway?
   I should test whether these rules take precedence over the \<open>ring_char_0\<close>
   rules in the simplifier.
 \<close>
 
 lemma eq_numeral_iff_iszero:
   "numeral x = numeral y \<longleftrightarrow> iszero (sub x y)"
   "numeral x = - numeral y \<longleftrightarrow> iszero (numeral (x + y))"
   "- numeral x = numeral y \<longleftrightarrow> iszero (numeral (x + y))"
   "- numeral x = - numeral y \<longleftrightarrow> iszero (sub y x)"
   "numeral x = 1 \<longleftrightarrow> iszero (sub x One)"
   "1 = numeral y \<longleftrightarrow> iszero (sub One y)"
   "- numeral x = 1 \<longleftrightarrow> iszero (numeral (x + One))"
   "1 = - numeral y \<longleftrightarrow> iszero (numeral (One + y))"
   "numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
   "0 = numeral y \<longleftrightarrow> iszero (numeral y)"
   "- numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
   "0 = - numeral y \<longleftrightarrow> iszero (numeral y)"
   unfolding eq_iff_iszero_diff diff_numeral_simps diff_numeral_special
   by simp_all
 
 end
 
 
 subsubsection \<open>Equality and negation: class \<open>ring_char_0\<close>\<close>
 
 context ring_char_0
 begin
 
 lemma not_iszero_numeral [simp]: "\<not> iszero (numeral w)"
   by (simp add: iszero_def)
 
 lemma neg_numeral_eq_iff: "- numeral m = - numeral n \<longleftrightarrow> m = n"
   by simp
 
 lemma numeral_neq_neg_numeral: "numeral m \<noteq> - numeral n"
   by (simp add: eq_neg_iff_add_eq_0 numeral_plus_numeral)
 
 lemma neg_numeral_neq_numeral: "- numeral m \<noteq> numeral n"
   by (rule numeral_neq_neg_numeral [symmetric])
 
 lemma zero_neq_neg_numeral: "0 \<noteq> - numeral n"
   by simp
 
 lemma neg_numeral_neq_zero: "- numeral n \<noteq> 0"
   by simp
 
 lemma one_neq_neg_numeral: "1 \<noteq> - numeral n"
   using numeral_neq_neg_numeral [of One n] by (simp add: numeral_One)
 
 lemma neg_numeral_neq_one: "- numeral n \<noteq> 1"
   using neg_numeral_neq_numeral [of n One] by (simp add: numeral_One)
 
 lemma neg_one_neq_numeral: "- 1 \<noteq> numeral n"
   using neg_numeral_neq_numeral [of One n] by (simp add: numeral_One)
 
 lemma numeral_neq_neg_one: "numeral n \<noteq> - 1"
   using numeral_neq_neg_numeral [of n One] by (simp add: numeral_One)
 
 lemma neg_one_eq_numeral_iff: "- 1 = - numeral n \<longleftrightarrow> n = One"
   using neg_numeral_eq_iff [of One n] by (auto simp add: numeral_One)
 
 lemma numeral_eq_neg_one_iff: "- numeral n = - 1 \<longleftrightarrow> n = One"
   using neg_numeral_eq_iff [of n One] by (auto simp add: numeral_One)
 
 lemma neg_one_neq_zero: "- 1 \<noteq> 0"
   by simp
 
 lemma zero_neq_neg_one: "0 \<noteq> - 1"
   by simp
 
 lemma neg_one_neq_one: "- 1 \<noteq> 1"
   using neg_numeral_neq_numeral [of One One] by (simp only: numeral_One not_False_eq_True)
 
 lemma one_neq_neg_one: "1 \<noteq> - 1"
   using numeral_neq_neg_numeral [of One One] by (simp only: numeral_One not_False_eq_True)
 
 lemmas eq_neg_numeral_simps [simp] =
   neg_numeral_eq_iff
   numeral_neq_neg_numeral neg_numeral_neq_numeral
   one_neq_neg_numeral neg_numeral_neq_one
   zero_neq_neg_numeral neg_numeral_neq_zero
   neg_one_neq_numeral numeral_neq_neg_one
   neg_one_eq_numeral_iff numeral_eq_neg_one_iff
   neg_one_neq_zero zero_neq_neg_one
   neg_one_neq_one one_neq_neg_one
 
 end
 
 
 subsubsection \<open>Structures with negation and order: class \<open>linordered_idom\<close>\<close>
 
 context linordered_idom
 begin
 
 subclass ring_char_0 ..
 
 lemma neg_numeral_le_iff: "- numeral m \<le> - numeral n \<longleftrightarrow> n \<le> m"
   by (simp only: neg_le_iff_le numeral_le_iff)
 
 lemma neg_numeral_less_iff: "- numeral m < - numeral n \<longleftrightarrow> n < m"
   by (simp only: neg_less_iff_less numeral_less_iff)
 
 lemma neg_numeral_less_zero: "- numeral n < 0"
   by (simp only: neg_less_0_iff_less zero_less_numeral)
 
 lemma neg_numeral_le_zero: "- numeral n \<le> 0"
   by (simp only: neg_le_0_iff_le zero_le_numeral)
 
 lemma not_zero_less_neg_numeral: "\<not> 0 < - numeral n"
   by (simp only: not_less neg_numeral_le_zero)
 
 lemma not_zero_le_neg_numeral: "\<not> 0 \<le> - numeral n"
   by (simp only: not_le neg_numeral_less_zero)
 
 lemma neg_numeral_less_numeral: "- numeral m < numeral n"
   using neg_numeral_less_zero zero_less_numeral by (rule less_trans)
 
 lemma neg_numeral_le_numeral: "- numeral m \<le> numeral n"
   by (simp only: less_imp_le neg_numeral_less_numeral)
 
 lemma not_numeral_less_neg_numeral: "\<not> numeral m < - numeral n"
   by (simp only: not_less neg_numeral_le_numeral)
 
 lemma not_numeral_le_neg_numeral: "\<not> numeral m \<le> - numeral n"
   by (simp only: not_le neg_numeral_less_numeral)
 
 lemma neg_numeral_less_one: "- numeral m < 1"
   by (rule neg_numeral_less_numeral [of m One, unfolded numeral_One])
 
 lemma neg_numeral_le_one: "- numeral m \<le> 1"
   by (rule neg_numeral_le_numeral [of m One, unfolded numeral_One])
 
 lemma not_one_less_neg_numeral: "\<not> 1 < - numeral m"
   by (simp only: not_less neg_numeral_le_one)
 
 lemma not_one_le_neg_numeral: "\<not> 1 \<le> - numeral m"
   by (simp only: not_le neg_numeral_less_one)
 
 lemma not_numeral_less_neg_one: "\<not> numeral m < - 1"
   using not_numeral_less_neg_numeral [of m One] by (simp add: numeral_One)
 
 lemma not_numeral_le_neg_one: "\<not> numeral m \<le> - 1"
   using not_numeral_le_neg_numeral [of m One] by (simp add: numeral_One)
 
 lemma neg_one_less_numeral: "- 1 < numeral m"
   using neg_numeral_less_numeral [of One m] by (simp add: numeral_One)
 
 lemma neg_one_le_numeral: "- 1 \<le> numeral m"
   using neg_numeral_le_numeral [of One m] by (simp add: numeral_One)
 
 lemma neg_numeral_less_neg_one_iff: "- numeral m < - 1 \<longleftrightarrow> m \<noteq> One"
   by (cases m) simp_all
 
 lemma neg_numeral_le_neg_one: "- numeral m \<le> - 1"
   by simp
 
 lemma not_neg_one_less_neg_numeral: "\<not> - 1 < - numeral m"
   by simp
 
 lemma not_neg_one_le_neg_numeral_iff: "\<not> - 1 \<le> - numeral m \<longleftrightarrow> m \<noteq> One"
   by (cases m) simp_all
 
 lemma sub_non_negative: "sub n m \<ge> 0 \<longleftrightarrow> n \<ge> m"
   by (simp only: sub_def le_diff_eq) simp
 
 lemma sub_positive: "sub n m > 0 \<longleftrightarrow> n > m"
   by (simp only: sub_def less_diff_eq) simp
 
 lemma sub_non_positive: "sub n m \<le> 0 \<longleftrightarrow> n \<le> m"
   by (simp only: sub_def diff_le_eq) simp
 
 lemma sub_negative: "sub n m < 0 \<longleftrightarrow> n < m"
   by (simp only: sub_def diff_less_eq) simp
 
 lemmas le_neg_numeral_simps [simp] =
   neg_numeral_le_iff
   neg_numeral_le_numeral not_numeral_le_neg_numeral
   neg_numeral_le_zero not_zero_le_neg_numeral
   neg_numeral_le_one not_one_le_neg_numeral
   neg_one_le_numeral not_numeral_le_neg_one
   neg_numeral_le_neg_one not_neg_one_le_neg_numeral_iff
 
 lemma le_minus_one_simps [simp]:
   "- 1 \<le> 0"
   "- 1 \<le> 1"
   "\<not> 0 \<le> - 1"
   "\<not> 1 \<le> - 1"
   by simp_all
 
 lemmas less_neg_numeral_simps [simp] =
   neg_numeral_less_iff
   neg_numeral_less_numeral not_numeral_less_neg_numeral
   neg_numeral_less_zero not_zero_less_neg_numeral
   neg_numeral_less_one not_one_less_neg_numeral
   neg_one_less_numeral not_numeral_less_neg_one
   neg_numeral_less_neg_one_iff not_neg_one_less_neg_numeral
 
 lemma less_minus_one_simps [simp]:
   "- 1 < 0"
   "- 1 < 1"
   "\<not> 0 < - 1"
   "\<not> 1 < - 1"
   by (simp_all add: less_le)
 
 lemma abs_numeral [simp]: "\<bar>numeral n\<bar> = numeral n"
   by simp
 
 lemma abs_neg_numeral [simp]: "\<bar>- numeral n\<bar> = numeral n"
   by (simp only: abs_minus_cancel abs_numeral)
 
 lemma abs_neg_one [simp]: "\<bar>- 1\<bar> = 1"
   by simp
 
 end
 
 
 subsubsection \<open>Natural numbers\<close>
 
 lemma numeral_num_of_nat:
   "numeral (num_of_nat n) = n" if "n > 0"
   using that nat_of_num_numeral num_of_nat_inverse by simp
 
 lemma Suc_1 [simp]: "Suc 1 = 2"
   unfolding Suc_eq_plus1 by (rule one_add_one)
 
 lemma Suc_numeral [simp]: "Suc (numeral n) = numeral (n + One)"
   unfolding Suc_eq_plus1 by (rule numeral_plus_one)
 
 definition pred_numeral :: "num \<Rightarrow> nat"
   where "pred_numeral k = numeral k - 1"
 
 declare [[code drop: pred_numeral]]
 
 lemma numeral_eq_Suc: "numeral k = Suc (pred_numeral k)"
   by (simp add: pred_numeral_def)
 
 lemma eval_nat_numeral:
   "numeral One = Suc 0"
   "numeral (Bit0 n) = Suc (numeral (BitM n))"
   "numeral (Bit1 n) = Suc (numeral (Bit0 n))"
   by (simp_all add: numeral.simps BitM_plus_one)
 
 lemma pred_numeral_simps [simp]:
   "pred_numeral One = 0"
   "pred_numeral (Bit0 k) = numeral (BitM k)"
   "pred_numeral (Bit1 k) = numeral (Bit0 k)"
   by (simp_all only: pred_numeral_def eval_nat_numeral diff_Suc_Suc diff_0)
 
 lemma pred_numeral_inc [simp]:
   "pred_numeral (Num.inc k) = numeral k"
   by (simp only: pred_numeral_def numeral_inc diff_add_inverse2)
 
 lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
   by (simp add: eval_nat_numeral)
 
 lemma numeral_3_eq_3: "3 = Suc (Suc (Suc 0))"
   by (simp add: eval_nat_numeral)
 
 lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
   by (simp only: numeral_One One_nat_def)
 
 lemma Suc_nat_number_of_add: "Suc (numeral v + n) = numeral (v + One) + n"
   by simp
 
 lemma numerals: "Numeral1 = (1::nat)" "2 = Suc (Suc 0)"
   by (rule numeral_One) (rule numeral_2_eq_2)
 
 lemmas numeral_nat = eval_nat_numeral BitM.simps One_nat_def
 
 text \<open>Comparisons involving \<^term>\<open>Suc\<close>.\<close>
 
 lemma eq_numeral_Suc [simp]: "numeral k = Suc n \<longleftrightarrow> pred_numeral k = n"
   by (simp add: numeral_eq_Suc)
 
 lemma Suc_eq_numeral [simp]: "Suc n = numeral k \<longleftrightarrow> n = pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma less_numeral_Suc [simp]: "numeral k < Suc n \<longleftrightarrow> pred_numeral k < n"
   by (simp add: numeral_eq_Suc)
 
 lemma less_Suc_numeral [simp]: "Suc n < numeral k \<longleftrightarrow> n < pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma le_numeral_Suc [simp]: "numeral k \<le> Suc n \<longleftrightarrow> pred_numeral k \<le> n"
   by (simp add: numeral_eq_Suc)
 
 lemma le_Suc_numeral [simp]: "Suc n \<le> numeral k \<longleftrightarrow> n \<le> pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma diff_Suc_numeral [simp]: "Suc n - numeral k = n - pred_numeral k"
   by (simp add: numeral_eq_Suc)
 
 lemma diff_numeral_Suc [simp]: "numeral k - Suc n = pred_numeral k - n"
   by (simp add: numeral_eq_Suc)
 
 lemma max_Suc_numeral [simp]: "max (Suc n) (numeral k) = Suc (max n (pred_numeral k))"
   by (simp add: numeral_eq_Suc)
 
 lemma max_numeral_Suc [simp]: "max (numeral k) (Suc n) = Suc (max (pred_numeral k) n)"
   by (simp add: numeral_eq_Suc)
 
 lemma min_Suc_numeral [simp]: "min (Suc n) (numeral k) = Suc (min n (pred_numeral k))"
   by (simp add: numeral_eq_Suc)
 
 lemma min_numeral_Suc [simp]: "min (numeral k) (Suc n) = Suc (min (pred_numeral k) n)"
   by (simp add: numeral_eq_Suc)
 
 text \<open>For \<^term>\<open>case_nat\<close> and \<^term>\<open>rec_nat\<close>.\<close>
 
 lemma case_nat_numeral [simp]: "case_nat a f (numeral v) = (let pv = pred_numeral v in f pv)"
   by (simp add: numeral_eq_Suc)
 
 lemma case_nat_add_eq_if [simp]:
   "case_nat a f ((numeral v) + n) = (let pv = pred_numeral v in f (pv + n))"
   by (simp add: numeral_eq_Suc)
 
 lemma rec_nat_numeral [simp]:
   "rec_nat a f (numeral v) = (let pv = pred_numeral v in f pv (rec_nat a f pv))"
   by (simp add: numeral_eq_Suc Let_def)
 
 lemma rec_nat_add_eq_if [simp]:
   "rec_nat a f (numeral v + n) = (let pv = pred_numeral v in f (pv + n) (rec_nat a f (pv + n)))"
   by (simp add: numeral_eq_Suc Let_def)
 
 text \<open>Case analysis on \<^term>\<open>n < 2\<close>.\<close>
 lemma less_2_cases: "n < 2 \<Longrightarrow> n = 0 \<or> n = Suc 0"
   by (auto simp add: numeral_2_eq_2)
 
 lemma less_2_cases_iff: "n < 2 \<longleftrightarrow> n = 0 \<or> n = Suc 0"
   by (auto simp add: numeral_2_eq_2)
 
 text \<open>Removal of Small Numerals: 0, 1 and (in additive positions) 2.\<close>
 text \<open>bh: Are these rules really a good idea? LCP: well, it already happens for 0 and 1!\<close>
 
 lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
   by simp
 
 lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
   by simp
 
 text \<open>Can be used to eliminate long strings of Sucs, but not by default.\<close>
 lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
   by simp
 
 lemmas nat_1_add_1 = one_add_one [where 'a=nat] (* legacy *)
 
 context semiring_numeral
 begin
 
 lemma numeral_add_unfold_funpow:
   \<open>numeral k + a = ((+) 1 ^^ numeral k) a\<close>
 proof (rule sym, induction k arbitrary: a)
   case One
   then show ?case
     by (simp add: numeral_One Num.numeral_One)
 next
   case (Bit0 k)
   then show ?case
     by (simp add: numeral_Bit0 Num.numeral_Bit0 ac_simps funpow_add)
 next
   case (Bit1 k)
   then show ?case
     by (simp add: numeral_Bit1 Num.numeral_Bit1 ac_simps funpow_add)
 qed
 
 end
 
 context semiring_1
 begin
 
 lemma numeral_unfold_funpow:
   \<open>numeral k = ((+) 1 ^^ numeral k) 0\<close>
   using numeral_add_unfold_funpow [of k 0] by simp
 
 end
 
 context
   includes lifting_syntax
 begin
 
 lemma transfer_rule_numeral:
   \<open>((=) ===> R) numeral numeral\<close>
     if [transfer_rule]: \<open>R 0 0\<close> \<open>R 1 1\<close>
       \<open>(R ===> R ===> R) (+) (+)\<close>
     for R :: \<open>'a::{semiring_numeral,monoid_add} \<Rightarrow> 'b::{semiring_numeral,monoid_add} \<Rightarrow> bool\<close>
 proof -
   have "((=) ===> R) (\<lambda>k. ((+) 1 ^^ numeral k) 0) (\<lambda>k. ((+) 1 ^^ numeral k) 0)"
     by transfer_prover
   moreover have \<open>numeral = (\<lambda>k. ((+) (1::'a) ^^ numeral k) 0)\<close>
     using numeral_add_unfold_funpow [where ?'a = 'a, of _ 0]
     by (simp add: fun_eq_iff)
   moreover have \<open>numeral = (\<lambda>k. ((+) (1::'b) ^^ numeral k) 0)\<close>
     using numeral_add_unfold_funpow [where ?'a = 'b, of _ 0]
     by (simp add: fun_eq_iff)
   ultimately show ?thesis
     by simp
 qed
 
 end
 
 
 subsection \<open>Particular lemmas concerning \<^term>\<open>2\<close>\<close>
 
 context linordered_field
 begin
 
 subclass field_char_0 ..
 
 lemma half_gt_zero_iff: "0 < a / 2 \<longleftrightarrow> 0 < a"
   by (auto simp add: field_simps)
 
 lemma half_gt_zero [simp]: "0 < a \<Longrightarrow> 0 < a / 2"
   by (simp add: half_gt_zero_iff)
 
 end
 
 
 subsection \<open>Numeral equations as default simplification rules\<close>
 
 declare (in numeral) numeral_One [simp]
 declare (in numeral) numeral_plus_numeral [simp]
 declare (in numeral) add_numeral_special [simp]
 declare (in neg_numeral) add_neg_numeral_simps [simp]
 declare (in neg_numeral) add_neg_numeral_special [simp]
 declare (in neg_numeral) diff_numeral_simps [simp]
 declare (in neg_numeral) diff_numeral_special [simp]
 declare (in semiring_numeral) numeral_times_numeral [simp]
 declare (in ring_1) mult_neg_numeral_simps [simp]
 
 
 subsubsection \<open>Special Simplification for Constants\<close>
 
 text \<open>These distributive laws move literals inside sums and differences.\<close>
 
 lemmas distrib_right_numeral [simp] = distrib_right [of _ _ "numeral v"] for v
 lemmas distrib_left_numeral [simp] = distrib_left [of "numeral v"] for v
 lemmas left_diff_distrib_numeral [simp] = left_diff_distrib [of _ _ "numeral v"] for v
 lemmas right_diff_distrib_numeral [simp] = right_diff_distrib [of "numeral v"] for v
 
 text \<open>These are actually for fields, like real\<close>
 
 lemmas zero_less_divide_iff_numeral [simp, no_atp] = zero_less_divide_iff [of "numeral w"] for w
 lemmas divide_less_0_iff_numeral [simp, no_atp] = divide_less_0_iff [of "numeral w"] for w
 lemmas zero_le_divide_iff_numeral [simp, no_atp] = zero_le_divide_iff [of "numeral w"] for w
 lemmas divide_le_0_iff_numeral [simp, no_atp] = divide_le_0_iff [of "numeral w"] for w
 
 text \<open>Replaces \<open>inverse #nn\<close> by \<open>1/#nn\<close>.  It looks
   strange, but then other simprocs simplify the quotient.\<close>
 
 lemmas inverse_eq_divide_numeral [simp] =
   inverse_eq_divide [of "numeral w"] for w
 
 lemmas inverse_eq_divide_neg_numeral [simp] =
   inverse_eq_divide [of "- numeral w"] for w
 
 text \<open>These laws simplify inequalities, moving unary minus from a term
   into the literal.\<close>
 
 lemmas equation_minus_iff_numeral [no_atp] =
   equation_minus_iff [of "numeral v"] for v
 
 lemmas minus_equation_iff_numeral [no_atp] =
   minus_equation_iff [of _ "numeral v"] for v
 
 lemmas le_minus_iff_numeral [no_atp] =
   le_minus_iff [of "numeral v"] for v
 
 lemmas minus_le_iff_numeral [no_atp] =
   minus_le_iff [of _ "numeral v"] for v
 
 lemmas less_minus_iff_numeral [no_atp] =
   less_minus_iff [of "numeral v"] for v
 
 lemmas minus_less_iff_numeral [no_atp] =
   minus_less_iff [of _ "numeral v"] for v
 
 (* FIXME maybe simproc *)
 
 text \<open>Cancellation of constant factors in comparisons (\<open><\<close> and \<open>\<le>\<close>)\<close>
 
 lemmas mult_less_cancel_left_numeral [simp, no_atp] = mult_less_cancel_left [of "numeral v"] for v
 lemmas mult_less_cancel_right_numeral [simp, no_atp] = mult_less_cancel_right [of _ "numeral v"] for v
 lemmas mult_le_cancel_left_numeral [simp, no_atp] = mult_le_cancel_left [of "numeral v"] for v
 lemmas mult_le_cancel_right_numeral [simp, no_atp] = mult_le_cancel_right [of _ "numeral v"] for v
 
 text \<open>Multiplying out constant divisors in comparisons (\<open><\<close>, \<open>\<le>\<close> and \<open>=\<close>)\<close>
 
 named_theorems divide_const_simps "simplification rules to simplify comparisons involving constant divisors"
 
 lemmas le_divide_eq_numeral1 [simp,divide_const_simps] =
   pos_le_divide_eq [of "numeral w", OF zero_less_numeral]
   neg_le_divide_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas divide_le_eq_numeral1 [simp,divide_const_simps] =
   pos_divide_le_eq [of "numeral w", OF zero_less_numeral]
   neg_divide_le_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas less_divide_eq_numeral1 [simp,divide_const_simps] =
   pos_less_divide_eq [of "numeral w", OF zero_less_numeral]
   neg_less_divide_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas divide_less_eq_numeral1 [simp,divide_const_simps] =
   pos_divide_less_eq [of "numeral w", OF zero_less_numeral]
   neg_divide_less_eq [of "- numeral w", OF neg_numeral_less_zero] for w
 
 lemmas eq_divide_eq_numeral1 [simp,divide_const_simps] =
   eq_divide_eq [of _ _ "numeral w"]
   eq_divide_eq [of _ _ "- numeral w"] for w
 
 lemmas divide_eq_eq_numeral1 [simp,divide_const_simps] =
   divide_eq_eq [of _ "numeral w"]
   divide_eq_eq [of _ "- numeral w"] for w
 
 
 subsubsection \<open>Optional Simplification Rules Involving Constants\<close>
 
 text \<open>Simplify quotients that are compared with a literal constant.\<close>
 
 lemmas le_divide_eq_numeral [divide_const_simps] =
   le_divide_eq [of "numeral w"]
   le_divide_eq [of "- numeral w"] for w
 
 lemmas divide_le_eq_numeral [divide_const_simps] =
   divide_le_eq [of _ _ "numeral w"]
   divide_le_eq [of _ _ "- numeral w"] for w
 
 lemmas less_divide_eq_numeral [divide_const_simps] =
   less_divide_eq [of "numeral w"]
   less_divide_eq [of "- numeral w"] for w
 
 lemmas divide_less_eq_numeral [divide_const_simps] =
   divide_less_eq [of _ _ "numeral w"]
   divide_less_eq [of _ _ "- numeral w"] for w
 
 lemmas eq_divide_eq_numeral [divide_const_simps] =
   eq_divide_eq [of "numeral w"]
   eq_divide_eq [of "- numeral w"] for w
 
 lemmas divide_eq_eq_numeral [divide_const_simps] =
   divide_eq_eq [of _ _ "numeral w"]
   divide_eq_eq [of _ _ "- numeral w"] for w
 
 text \<open>Not good as automatic simprules because they cause case splits.\<close>
 
 lemmas [divide_const_simps] =
   le_divide_eq_1 divide_le_eq_1 less_divide_eq_1 divide_less_eq_1
 
 
 subsection \<open>Setting up simprocs\<close>
 
 lemma mult_numeral_1: "Numeral1 * a = a"
   for a :: "'a::semiring_numeral"
   by simp
 
 lemma mult_numeral_1_right: "a * Numeral1 = a"
   for a :: "'a::semiring_numeral"
   by simp
 
 lemma divide_numeral_1: "a / Numeral1 = a"
   for a :: "'a::field"
   by simp
 
 lemma inverse_numeral_1: "inverse Numeral1 = (Numeral1::'a::division_ring)"
   by simp
 
 text \<open>
   Theorem lists for the cancellation simprocs. The use of a binary
   numeral for 1 reduces the number of special cases.
 \<close>
 
 lemma mult_1s_semiring_numeral:
   "Numeral1 * a = a"
   "a * Numeral1 = a"
   for a :: "'a::semiring_numeral"
   by simp_all
 
 lemma mult_1s_ring_1:
   "- Numeral1 * b = - b"
   "b * - Numeral1 = - b"
   for b :: "'a::ring_1"
   by simp_all
 
 lemmas mult_1s = mult_1s_semiring_numeral mult_1s_ring_1
 
 setup \<open>
   Reorient_Proc.add
     (fn Const (\<^const_name>\<open>numeral\<close>, _) $ _ => true
       | Const (\<^const_name>\<open>uminus\<close>, _) $ (Const (\<^const_name>\<open>numeral\<close>, _) $ _) => true
       | _ => false)
 \<close>
 
 simproc_setup reorient_numeral ("numeral w = x" | "- numeral w = y") =
   Reorient_Proc.proc
 
 
 subsubsection \<open>Simplification of arithmetic operations on integer constants\<close>
 
 lemmas arith_special = (* already declared simp above *)
   add_numeral_special add_neg_numeral_special
   diff_numeral_special
 
 lemmas arith_extra_simps = (* rules already in simpset *)
   numeral_plus_numeral add_neg_numeral_simps add_0_left add_0_right
   minus_zero
   diff_numeral_simps diff_0 diff_0_right
   numeral_times_numeral mult_neg_numeral_simps
   mult_zero_left mult_zero_right
   abs_numeral abs_neg_numeral
 
 text \<open>
   For making a minimal simpset, one must include these default simprules.
   Also include \<open>simp_thms\<close>.
 \<close>
 
 lemmas arith_simps =
   add_num_simps mult_num_simps sub_num_simps
   BitM.simps dbl_simps dbl_inc_simps dbl_dec_simps
   abs_zero abs_one arith_extra_simps
 
 lemmas more_arith_simps =
   neg_le_iff_le
   minus_zero left_minus right_minus
   mult_1_left mult_1_right
   mult_minus_left mult_minus_right
   minus_add_distrib minus_minus mult.assoc
 
 lemmas of_nat_simps =
   of_nat_0 of_nat_1 of_nat_Suc of_nat_add of_nat_mult
 
 text \<open>Simplification of relational operations.\<close>
 
 lemmas eq_numeral_extra =
   zero_neq_one one_neq_zero
 
 lemmas rel_simps =
   le_num_simps less_num_simps eq_num_simps
   le_numeral_simps le_neg_numeral_simps le_minus_one_simps le_numeral_extra
   less_numeral_simps less_neg_numeral_simps less_minus_one_simps less_numeral_extra
   eq_numeral_simps eq_neg_numeral_simps eq_numeral_extra
 
 lemma Let_numeral [simp]: "Let (numeral v) f = f (numeral v)"
   \<comment> \<open>Unfold all \<open>let\<close>s involving constants\<close>
   unfolding Let_def ..
 
 lemma Let_neg_numeral [simp]: "Let (- numeral v) f = f (- numeral v)"
   \<comment> \<open>Unfold all \<open>let\<close>s involving constants\<close>
   unfolding Let_def ..
 
 declaration \<open>
 let
   fun number_of ctxt T n =
     if not (Sign.of_sort (Proof_Context.theory_of ctxt) (T, \<^sort>\<open>numeral\<close>))
     then raise CTERM ("number_of", [])
     else Numeral.mk_cnumber (Thm.ctyp_of ctxt T) n;
 in
   K (
     Lin_Arith.set_number_of number_of
     #> Lin_Arith.add_simps
       @{thms arith_simps more_arith_simps rel_simps pred_numeral_simps
         arith_special numeral_One of_nat_simps uminus_numeral_One
         Suc_numeral Let_numeral Let_neg_numeral Let_0 Let_1
         le_Suc_numeral le_numeral_Suc less_Suc_numeral less_numeral_Suc
         Suc_eq_numeral eq_numeral_Suc mult_Suc mult_Suc_right of_nat_numeral})
 end
 \<close>
 
 
 subsubsection \<open>Simplification of arithmetic when nested to the right\<close>
 
 lemma add_numeral_left [simp]: "numeral v + (numeral w + z) = (numeral(v + w) + z)"
   by (simp_all add: add.assoc [symmetric])
 
 lemma add_neg_numeral_left [simp]:
   "numeral v + (- numeral w + y) = (sub v w + y)"
   "- numeral v + (numeral w + y) = (sub w v + y)"
   "- numeral v + (- numeral w + y) = (- numeral(v + w) + y)"
   by (simp_all add: add.assoc [symmetric])
 
 lemma mult_numeral_left_semiring_numeral:
   "numeral v * (numeral w * z) = (numeral(v * w) * z :: 'a::semiring_numeral)"
   by (simp add: mult.assoc [symmetric])
 
 lemma mult_numeral_left_ring_1:
   "- numeral v * (numeral w * y) = (- numeral(v * w) * y :: 'a::ring_1)"
   "numeral v * (- numeral w * y) = (- numeral(v * w) * y :: 'a::ring_1)"
   "- numeral v * (- numeral w * y) = (numeral(v * w) * y :: 'a::ring_1)"
   by (simp_all add: mult.assoc [symmetric])
 
 lemmas mult_numeral_left [simp] =
   mult_numeral_left_semiring_numeral
   mult_numeral_left_ring_1
 
 hide_const (open) One Bit0 Bit1 BitM inc pow sqr sub dbl dbl_inc dbl_dec
 
 
 subsection \<open>Code module namespace\<close>
 
 code_identifier
   code_module Num \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 subsection \<open>Printing of evaluated natural numbers as numerals\<close>
 
 lemma [code_post]:
   "Suc 0 = 1"
   "Suc 1 = 2"
   "Suc (numeral n) = numeral (Num.inc n)"
   by (simp_all add: numeral_inc)
 
 lemmas [code_post] = Num.inc.simps
 
 
 subsection \<open>More on auxiliary conversion\<close>
 
 context semiring_1
 begin
 
 lemma numeral_num_of_nat_unfold:
   \<open>numeral (num_of_nat n) = (if n = 0 then 1 else of_nat n)\<close>
   by (induction n) (simp_all add: numeral_inc ac_simps)
 
 lemma num_of_nat_numeral_eq [simp]:
   \<open>num_of_nat (numeral q) = q\<close>
 proof (induction q)
   case One
   then show ?case
     by simp
 next
   case (Bit0 q)
-  then show ?case
-    apply (simp only: Num.numeral_Bit0 Num.numeral_add)
-    apply (subst num_of_nat_double)
-     apply simp_all
-    done
+  then have "num_of_nat (numeral (num.Bit0 q)) = num_of_nat (numeral q + numeral q)"
+    by (simp only: Num.numeral_Bit0 Num.numeral_add)
+  also have "\<dots> = num.Bit0 (num_of_nat (numeral q))"
+    by (rule num_of_nat_double) simp
+  finally show ?case
+    using Bit0.IH by simp
 next
   case (Bit1 q)
-  then show ?case
-    apply (simp only: Num.numeral_Bit1 Num.numeral_add)
-    apply (subst num_of_nat_plus_distrib)
-      apply simp
-     apply simp
-    apply (subst num_of_nat_double)
-     apply simp_all
-    done
+  then have "num_of_nat (numeral (num.Bit1 q)) = num_of_nat (numeral q + numeral q + 1)"
+    by (simp only: Num.numeral_Bit1 Num.numeral_add)
+  also have "\<dots> = num_of_nat (numeral q + numeral q) + num_of_nat 1"
+    by (rule num_of_nat_plus_distrib) auto
+  also have "\<dots> = num.Bit0 (num_of_nat (numeral q)) + num_of_nat 1"
+    by (subst num_of_nat_double) auto
+  finally show ?case
+    using Bit1.IH by simp
 qed
 
 end
 
 end
diff --git a/src/HOL/Order_Relation.thy b/src/HOL/Order_Relation.thy
--- a/src/HOL/Order_Relation.thy
+++ b/src/HOL/Order_Relation.thy
@@ -1,585 +1,613 @@
 (*  Title:      HOL/Order_Relation.thy
     Author:     Tobias Nipkow
     Author:     Andrei Popescu, TU Muenchen
 *)
 
 section \<open>Orders as Relations\<close>
 
 theory Order_Relation
 imports Wfrec
 begin
 
 subsection \<open>Orders on a set\<close>
 
 definition "preorder_on A r \<equiv> refl_on A r \<and> trans r"
 
 definition "partial_order_on A r \<equiv> preorder_on A r \<and> antisym r"
 
 definition "linear_order_on A r \<equiv> partial_order_on A r \<and> total_on A r"
 
 definition "strict_linear_order_on A r \<equiv> trans r \<and> irrefl r \<and> total_on A r"
 
 definition "well_order_on A r \<equiv> linear_order_on A r \<and> wf(r - Id)"
 
 lemmas order_on_defs =
   preorder_on_def partial_order_on_def linear_order_on_def
   strict_linear_order_on_def well_order_on_def
 
 lemma partial_order_onD:
   assumes "partial_order_on A r" shows "refl_on A r" and "trans r" and "antisym r"
   using assms unfolding partial_order_on_def preorder_on_def by auto
 
 lemma preorder_on_empty[simp]: "preorder_on {} {}"
   by (simp add: preorder_on_def trans_def)
 
 lemma partial_order_on_empty[simp]: "partial_order_on {} {}"
   by (simp add: partial_order_on_def)
 
 lemma lnear_order_on_empty[simp]: "linear_order_on {} {}"
   by (simp add: linear_order_on_def)
 
 lemma well_order_on_empty[simp]: "well_order_on {} {}"
   by (simp add: well_order_on_def)
 
 
 lemma preorder_on_converse[simp]: "preorder_on A (r\<inverse>) = preorder_on A r"
   by (simp add: preorder_on_def)
 
 lemma partial_order_on_converse[simp]: "partial_order_on A (r\<inverse>) = partial_order_on A r"
   by (simp add: partial_order_on_def)
 
 lemma linear_order_on_converse[simp]: "linear_order_on A (r\<inverse>) = linear_order_on A r"
   by (simp add: linear_order_on_def)
 
 
 lemma partial_order_on_acyclic:
   "partial_order_on A r \<Longrightarrow> acyclic (r - Id)"
   by (simp add: acyclic_irrefl partial_order_on_def preorder_on_def trans_diff_Id)
 
 lemma partial_order_on_well_order_on:               
   "finite r \<Longrightarrow> partial_order_on A r \<Longrightarrow> wf (r - Id)" 
   by (simp add: finite_acyclic_wf partial_order_on_acyclic) 
 
 lemma strict_linear_order_on_diff_Id: "linear_order_on A r \<Longrightarrow> strict_linear_order_on A (r - Id)"
   by (simp add: order_on_defs trans_diff_Id)
 
 lemma linear_order_on_singleton [simp]: "linear_order_on {x} {(x, x)}"
   by (simp add: order_on_defs)
 
 lemma linear_order_on_acyclic:
   assumes "linear_order_on A r"
   shows "acyclic (r - Id)"
   using strict_linear_order_on_diff_Id[OF assms]
   by (auto simp add: acyclic_irrefl strict_linear_order_on_def)
 
 lemma linear_order_on_well_order_on:
   assumes "finite r"
   shows "linear_order_on A r \<longleftrightarrow> well_order_on A r"
   unfolding well_order_on_def
   using assms finite_acyclic_wf[OF _ linear_order_on_acyclic, of r] by blast
 
 
 subsection \<open>Orders on the field\<close>
 
 abbreviation "Refl r \<equiv> refl_on (Field r) r"
 
 abbreviation "Preorder r \<equiv> preorder_on (Field r) r"
 
 abbreviation "Partial_order r \<equiv> partial_order_on (Field r) r"
 
 abbreviation "Total r \<equiv> total_on (Field r) r"
 
 abbreviation "Linear_order r \<equiv> linear_order_on (Field r) r"
 
 abbreviation "Well_order r \<equiv> well_order_on (Field r) r"
 
 
 lemma subset_Image_Image_iff:
   "Preorder r \<Longrightarrow> A \<subseteq> Field r \<Longrightarrow> B \<subseteq> Field r \<Longrightarrow>
     r `` A \<subseteq> r `` B \<longleftrightarrow> (\<forall>a\<in>A.\<exists>b\<in>B. (b, a) \<in> r)"
   apply (simp add: preorder_on_def refl_on_def Image_def subset_eq)
   apply (simp only: trans_def)
   apply fast
   done
 
 lemma subset_Image1_Image1_iff:
   "Preorder r \<Longrightarrow> a \<in> Field r \<Longrightarrow> b \<in> Field r \<Longrightarrow> r `` {a} \<subseteq> r `` {b} \<longleftrightarrow> (b, a) \<in> r"
   by (simp add: subset_Image_Image_iff)
 
 lemma Refl_antisym_eq_Image1_Image1_iff:
   assumes "Refl r"
     and as: "antisym r"
     and abf: "a \<in> Field r" "b \<in> Field r"
   shows "r `` {a} = r `` {b} \<longleftrightarrow> a = b"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   then have *: "\<And>x. (a, x) \<in> r \<longleftrightarrow> (b, x) \<in> r"
     by (simp add: set_eq_iff)
   have "(a, a) \<in> r" "(b, b) \<in> r" using \<open>Refl r\<close> abf by (simp_all add: refl_on_def)
   then have "(a, b) \<in> r" "(b, a) \<in> r" using *[of a] *[of b] by simp_all
   then show ?rhs
     using \<open>antisym r\<close>[unfolded antisym_def] by blast
 next
   assume ?rhs
   then show ?lhs by fast
 qed
 
 lemma Partial_order_eq_Image1_Image1_iff:
   "Partial_order r \<Longrightarrow> a \<in> Field r \<Longrightarrow> b \<in> Field r \<Longrightarrow> r `` {a} = r `` {b} \<longleftrightarrow> a = b"
   by (auto simp: order_on_defs Refl_antisym_eq_Image1_Image1_iff)
 
 lemma Total_Id_Field:
   assumes "Total r"
     and not_Id: "\<not> r \<subseteq> Id"
   shows "Field r = Field (r - Id)"
-  using mono_Field[of "r - Id" r] Diff_subset[of r Id]
-proof auto
-  fix a assume *: "a \<in> Field r"
-  from not_Id have "r \<noteq> {}" by fast
-  with not_Id obtain b and c where "b \<noteq> c \<and> (b,c) \<in> r" by auto
-  then have "b \<noteq> c \<and> {b, c} \<subseteq> Field r" by (auto simp: Field_def)
-  with * obtain d where "d \<in> Field r" "d \<noteq> a" by auto
-  with * \<open>Total r\<close> have "(a, d) \<in> r \<or> (d, a) \<in> r" by (simp add: total_on_def)
-  with \<open>d \<noteq> a\<close> show "a \<in> Field (r - Id)" unfolding Field_def by blast
+proof -
+  have "Field r \<subseteq> Field (r - Id)"
+  proof (rule subsetI)
+    fix a assume *: "a \<in> Field r"
+    from not_Id have "r \<noteq> {}" by fast
+    with not_Id obtain b and c where "b \<noteq> c \<and> (b,c) \<in> r" by auto
+    then have "b \<noteq> c \<and> {b, c} \<subseteq> Field r" by (auto simp: Field_def)
+    with * obtain d where "d \<in> Field r" "d \<noteq> a" by auto
+    with * \<open>Total r\<close> have "(a, d) \<in> r \<or> (d, a) \<in> r" by (simp add: total_on_def)
+    with \<open>d \<noteq> a\<close> show "a \<in> Field (r - Id)" unfolding Field_def by blast
+  qed
+  then show ?thesis
+    using mono_Field[of "r - Id" r] Diff_subset[of r Id] by auto
 qed
 
 subsection\<open>Relations given by a predicate and the field\<close>
 
 definition relation_of :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set"
   where "relation_of P A \<equiv> { (a, b) \<in> A \<times> A. P a b }"
 
 lemma Field_relation_of:
   assumes "refl_on A (relation_of P A)" shows "Field (relation_of P A) = A"
   using assms unfolding refl_on_def Field_def by auto
 
 lemma partial_order_on_relation_ofI:
   assumes refl: "\<And>a. a \<in> A \<Longrightarrow> P a a"
     and trans: "\<And>a b c. \<lbrakk> a \<in> A; b \<in> A; c \<in> A \<rbrakk> \<Longrightarrow> P a b \<Longrightarrow> P b c \<Longrightarrow> P a c"
     and antisym: "\<And>a b. \<lbrakk> a \<in> A; b \<in> A \<rbrakk> \<Longrightarrow> P a b \<Longrightarrow> P b a \<Longrightarrow> a = b"
   shows "partial_order_on A (relation_of P A)"
 proof -
   from refl have "refl_on A (relation_of P A)"
     unfolding refl_on_def relation_of_def by auto
   moreover have "trans (relation_of P A)" and "antisym (relation_of P A)"
     unfolding relation_of_def
     by (auto intro: transI dest: trans, auto intro: antisymI dest: antisym)
   ultimately show ?thesis
     unfolding partial_order_on_def preorder_on_def by simp
 qed
 
 lemma Partial_order_relation_ofI:
   assumes "partial_order_on A (relation_of P A)" shows "Partial_order (relation_of P A)"
   using Field_relation_of assms partial_order_on_def preorder_on_def by fastforce
 
 
 subsection \<open>Orders on a type\<close>
 
 abbreviation "strict_linear_order \<equiv> strict_linear_order_on UNIV"
 
 abbreviation "linear_order \<equiv> linear_order_on UNIV"
 
 abbreviation "well_order \<equiv> well_order_on UNIV"
 
 
 subsection \<open>Order-like relations\<close>
 
 text \<open>
   In this subsection, we develop basic concepts and results pertaining
   to order-like relations, i.e., to reflexive and/or transitive and/or symmetric and/or
   total relations. We also further define upper and lower bounds operators.
 \<close>
 
 
 subsubsection \<open>Auxiliaries\<close>
 
 lemma refl_on_domain: "refl_on A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> a \<in> A \<and> b \<in> A"
   by (auto simp add: refl_on_def)
 
 corollary well_order_on_domain: "well_order_on A r \<Longrightarrow> (a, b) \<in> r \<Longrightarrow> a \<in> A \<and> b \<in> A"
   by (auto simp add: refl_on_domain order_on_defs)
 
 lemma well_order_on_Field: "well_order_on A r \<Longrightarrow> A = Field r"
   by (auto simp add: refl_on_def Field_def order_on_defs)
 
 lemma well_order_on_Well_order: "well_order_on A r \<Longrightarrow> A = Field r \<and> Well_order r"
   using well_order_on_Field [of A] by auto
 
 lemma Total_subset_Id:
   assumes "Total r"
     and "r \<subseteq> Id"
   shows "r = {} \<or> (\<exists>a. r = {(a, a)})"
 proof -
   have "\<exists>a. r = {(a, a)}" if "r \<noteq> {}"
   proof -
     from that obtain a b where ab: "(a, b) \<in> r" by fast
     with \<open>r \<subseteq> Id\<close> have "a = b" by blast
     with ab have aa: "(a, a) \<in> r" by simp
     have "a = c \<and> a = d" if "(c, d) \<in> r" for c d
     proof -
       from that have "{a, c, d} \<subseteq> Field r"
         using ab unfolding Field_def by blast
       then have "((a, c) \<in> r \<or> (c, a) \<in> r \<or> a = c) \<and> ((a, d) \<in> r \<or> (d, a) \<in> r \<or> a = d)"
         using \<open>Total r\<close> unfolding total_on_def by blast
       with \<open>r \<subseteq> Id\<close> show ?thesis by blast
     qed
     then have "r \<subseteq> {(a, a)}" by auto
     with aa show ?thesis by blast
   qed
   then show ?thesis by blast
 qed
 
 lemma Linear_order_in_diff_Id:
   assumes "Linear_order r"
     and "a \<in> Field r"
     and "b \<in> Field r"
   shows "(a, b) \<in> r \<longleftrightarrow> (b, a) \<notin> r - Id"
   using assms unfolding order_on_defs total_on_def antisym_def Id_def refl_on_def by force
 
 
 subsubsection \<open>The upper and lower bounds operators\<close>
 
 text \<open>
   Here we define upper (``above") and lower (``below") bounds operators. We
   think of \<open>r\<close> as a \<^emph>\<open>non-strict\<close> relation. The suffix \<open>S\<close> at the names of
   some operators indicates that the bounds are strict -- e.g., \<open>underS a\<close> is
   the set of all strict lower bounds of \<open>a\<close> (w.r.t. \<open>r\<close>). Capitalization of
   the first letter in the name reminds that the operator acts on sets, rather
   than on individual elements.
 \<close>
 
 definition under :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
   where "under r a \<equiv> {b. (b, a) \<in> r}"
 
 definition underS :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
   where "underS r a \<equiv> {b. b \<noteq> a \<and> (b, a) \<in> r}"
 
 definition Under :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
   where "Under r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (b, a) \<in> r}"
 
 definition UnderS :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
   where "UnderS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (b, a) \<in> r}"
 
 definition above :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
   where "above r a \<equiv> {b. (a, b) \<in> r}"
 
 definition aboveS :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a set"
   where "aboveS r a \<equiv> {b. b \<noteq> a \<and> (a, b) \<in> r}"
 
 definition Above :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
   where "Above r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. (a, b) \<in> r}"
 
 definition AboveS :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a set"
   where "AboveS r A \<equiv> {b \<in> Field r. \<forall>a \<in> A. b \<noteq> a \<and> (a, b) \<in> r}"
 
 definition ofilter :: "'a rel \<Rightarrow> 'a set \<Rightarrow> bool"
   where "ofilter r A \<equiv> A \<subseteq> Field r \<and> (\<forall>a \<in> A. under r a \<subseteq> A)"
 
 text \<open>
   Note: In the definitions of \<open>Above[S]\<close> and \<open>Under[S]\<close>, we bounded
   comprehension by \<open>Field r\<close> in order to properly cover the case of \<open>A\<close> being
   empty.
 \<close>
 
 lemma underS_subset_under: "underS r a \<subseteq> under r a"
   by (auto simp add: underS_def under_def)
 
 lemma underS_notIn: "a \<notin> underS r a"
   by (simp add: underS_def)
 
 lemma Refl_under_in: "Refl r \<Longrightarrow> a \<in> Field r \<Longrightarrow> a \<in> under r a"
   by (simp add: refl_on_def under_def)
 
 lemma AboveS_disjoint: "A \<inter> (AboveS r A) = {}"
   by (auto simp add: AboveS_def)
 
 lemma in_AboveS_underS: "a \<in> Field r \<Longrightarrow> a \<in> AboveS r (underS r a)"
   by (auto simp add: AboveS_def underS_def)
 
 lemma Refl_under_underS: "Refl r \<Longrightarrow> a \<in> Field r \<Longrightarrow> under r a = underS r a \<union> {a}"
   unfolding under_def underS_def
   using refl_on_def[of _ r] by fastforce
 
 lemma underS_empty: "a \<notin> Field r \<Longrightarrow> underS r a = {}"
   by (auto simp: Field_def underS_def)
 
 lemma under_Field: "under r a \<subseteq> Field r"
   by (auto simp: under_def Field_def)
 
 lemma underS_Field: "underS r a \<subseteq> Field r"
   by (auto simp: underS_def Field_def)
 
 lemma underS_Field2: "a \<in> Field r \<Longrightarrow> underS r a \<subset> Field r"
   using underS_notIn underS_Field by fast
 
 lemma underS_Field3: "Field r \<noteq> {} \<Longrightarrow> underS r a \<subset> Field r"
   by (cases "a \<in> Field r") (auto simp: underS_Field2 underS_empty)
 
 lemma AboveS_Field: "AboveS r A \<subseteq> Field r"
   by (auto simp: AboveS_def Field_def)
 
 lemma under_incr:
   assumes "trans r"
     and "(a, b) \<in> r"
   shows "under r a \<subseteq> under r b"
   unfolding under_def
-proof auto
+proof safe
   fix x assume "(x, a) \<in> r"
   with assms trans_def[of r] show "(x, b) \<in> r" by blast
 qed
 
 lemma underS_incr:
   assumes "trans r"
     and "antisym r"
     and ab: "(a, b) \<in> r"
   shows "underS r a \<subseteq> underS r b"
   unfolding underS_def
-proof auto
+proof safe
   assume *: "b \<noteq> a" and **: "(b, a) \<in> r"
   with \<open>antisym r\<close> antisym_def[of r] ab show False
     by blast
 next
   fix x assume "x \<noteq> a" "(x, a) \<in> r"
   with ab \<open>trans r\<close> trans_def[of r] show "(x, b) \<in> r"
     by blast
 qed
 
 lemma underS_incl_iff:
   assumes LO: "Linear_order r"
     and INa: "a \<in> Field r"
     and INb: "b \<in> Field r"
   shows "underS r a \<subseteq> underS r b \<longleftrightarrow> (a, b) \<in> r"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   with \<open>Linear_order r\<close> show ?lhs
     by (simp add: order_on_defs underS_incr)
 next
   assume *: ?lhs
   have "(a, b) \<in> r" if "a = b"
     using assms that by (simp add: order_on_defs refl_on_def)
   moreover have False if "a \<noteq> b" "(b, a) \<in> r"
   proof -
     from that have "b \<in> underS r a" unfolding underS_def by blast
     with * have "b \<in> underS r b" by blast
     then show ?thesis by (simp add: underS_notIn)
   qed
   ultimately show "(a,b) \<in> r"
     using assms order_on_defs[of "Field r" r] total_on_def[of "Field r" r] by blast
 qed
 
 lemma finite_Partial_order_induct[consumes 3, case_names step]:
   assumes "Partial_order r"
     and "x \<in> Field r"
     and "finite r"
     and step: "\<And>x. x \<in> Field r \<Longrightarrow> (\<And>y. y \<in> aboveS r x \<Longrightarrow> P y) \<Longrightarrow> P x"
   shows "P x"
   using assms(2)
 proof (induct rule: wf_induct[of "r\<inverse> - Id"])
   case 1
   from assms(1,3) show "wf (r\<inverse> - Id)"
     using partial_order_on_well_order_on partial_order_on_converse by blast
 next
   case prems: (2 x)
   show ?case
     by (rule step) (use prems in \<open>auto simp: aboveS_def intro: FieldI2\<close>)
 qed
 
 lemma finite_Linear_order_induct[consumes 3, case_names step]:
   assumes "Linear_order r"
     and "x \<in> Field r"
     and "finite r"
     and step: "\<And>x. x \<in> Field r \<Longrightarrow> (\<And>y. y \<in> aboveS r x \<Longrightarrow> P y) \<Longrightarrow> P x"
   shows "P x"
   using assms(2)
 proof (induct rule: wf_induct[of "r\<inverse> - Id"])
   case 1
   from assms(1,3) show "wf (r\<inverse> - Id)"
     using linear_order_on_well_order_on linear_order_on_converse
     unfolding well_order_on_def by blast
 next
   case prems: (2 x)
   show ?case
     by (rule step) (use prems in \<open>auto simp: aboveS_def intro: FieldI2\<close>)
 qed
 
 
 subsection \<open>Variations on Well-Founded Relations\<close>
 
 text \<open>
   This subsection contains some variations of the results from \<^theory>\<open>HOL.Wellfounded\<close>:
     \<^item> means for slightly more direct definitions by well-founded recursion;
     \<^item> variations of well-founded induction;
     \<^item> means for proving a linear order to be a well-order.
 \<close>
 
 
 subsubsection \<open>Characterizations of well-foundedness\<close>
 
 text \<open>
   A transitive relation is well-founded iff it is ``locally'' well-founded,
   i.e., iff its restriction to the lower bounds of of any element is
   well-founded.
 \<close>
 
 lemma trans_wf_iff:
   assumes "trans r"
   shows "wf r \<longleftrightarrow> (\<forall>a. wf (r \<inter> (r\<inverse>``{a} \<times> r\<inverse>``{a})))"
 proof -
   define R where "R a = r \<inter> (r\<inverse>``{a} \<times> r\<inverse>``{a})" for a
   have "wf (R a)" if "wf r" for a
     using that R_def wf_subset[of r "R a"] by auto
   moreover
   have "wf r" if *: "\<forall>a. wf(R a)"
     unfolding wf_def
   proof clarify
     fix phi a
     assume **: "\<forall>a. (\<forall>b. (b, a) \<in> r \<longrightarrow> phi b) \<longrightarrow> phi a"
     define chi where "chi b \<longleftrightarrow> (b, a) \<in> r \<longrightarrow> phi b" for b
     with * have "wf (R a)" by auto
     then have "(\<forall>b. (\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b) \<longrightarrow> (\<forall>b. chi b)"
       unfolding wf_def by blast
     also have "\<forall>b. (\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c) \<longrightarrow> chi b"
-    proof (auto simp add: chi_def R_def)
+    proof safe
       fix b
-      assume "(b, a) \<in> r" and "\<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c"
-      then have "\<forall>c. (c, b) \<in> r \<longrightarrow> phi c"
-        using assms trans_def[of r] by blast
-      with ** show "phi b" by blast
+      assume "\<forall>c. (c, b) \<in> R a \<longrightarrow> chi c"
+      moreover have "(b, a) \<in> r \<Longrightarrow> \<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c \<Longrightarrow> phi b"
+      proof -
+        assume "(b, a) \<in> r" and "\<forall>c. (c, b) \<in> r \<and> (c, a) \<in> r \<longrightarrow> phi c"
+        then have "\<forall>c. (c, b) \<in> r \<longrightarrow> phi c"
+          using assms trans_def[of r] by blast
+        with ** show "phi b" by blast
+      qed
+      ultimately show "chi b"
+        by (auto simp add: chi_def R_def)
     qed
     finally have  "\<forall>b. chi b" .
     with ** chi_def show "phi a" by blast
   qed
   ultimately show ?thesis unfolding R_def by blast
 qed
 
 text\<open>A transitive relation is well-founded if all initial segments are finite.\<close>
 corollary wf_finite_segments:
   assumes "irrefl r" and "trans r" and "\<And>x. finite {y. (y, x) \<in> r}"
-  shows "wf (r)"
-proof (clarsimp simp: trans_wf_iff wf_iff_acyclic_if_finite converse_def assms)
-  fix a
-  have "trans (r \<inter> ({x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r}))"
-    using assms unfolding trans_def Field_def by blast
-  then show "acyclic (r \<inter> {x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r})"
-    using assms acyclic_def assms irrefl_def by fastforce
+  shows "wf r"
+proof -
+  have "\<And>a. acyclic (r \<inter> {x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r})"
+  proof -
+    fix a
+    have "trans (r \<inter> ({x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r}))"
+      using assms unfolding trans_def Field_def by blast
+    then show "acyclic (r \<inter> {x. (x, a) \<in> r} \<times> {x. (x, a) \<in> r})"
+      using assms acyclic_def assms irrefl_def by fastforce
+  qed
+  then show ?thesis
+    by (clarsimp simp: trans_wf_iff wf_iff_acyclic_if_finite converse_def assms)
 qed
 
 text \<open>The next lemma is a variation of \<open>wf_eq_minimal\<close> from Wellfounded,
   allowing one to assume the set included in the field.\<close>
 
 lemma wf_eq_minimal2: "wf r \<longleftrightarrow> (\<forall>A. A \<subseteq> Field r \<and> A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a', a) \<notin> r))"
 proof-
   let ?phi = "\<lambda>A. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r)"
   have "wf r \<longleftrightarrow> (\<forall>A. ?phi A)"
-    apply (auto simp: ex_in_conv [THEN sym])
-     apply (erule wfE_min)
-      apply assumption
-     apply blast
-    apply (rule wfI_min)
-    apply fast
-    done
+  proof
+    assume "wf r"
+    show  "\<forall>A. ?phi A"
+    proof clarify
+      fix A:: "'a set"
+      assume "A \<noteq> {}"
+      then obtain x where "x \<in> A"
+        by auto
+      show "\<exists>a\<in>A. \<forall>a'\<in>A. (a', a) \<notin> r"
+        apply (rule wfE_min[of r x A])
+          apply fact+
+        by blast
+    qed
+  next
+    assume *: "\<forall>A. ?phi A"
+    then show "wf r"
+      apply (clarsimp simp: ex_in_conv [THEN sym])
+      apply (rule wfI_min)
+      by fast
+  qed
   also have "(\<forall>A. ?phi A) \<longleftrightarrow> (\<forall>B \<subseteq> Field r. ?phi B)"
   proof
     assume "\<forall>A. ?phi A"
     then show "\<forall>B \<subseteq> Field r. ?phi B" by simp
   next
     assume *: "\<forall>B \<subseteq> Field r. ?phi B"
     show "\<forall>A. ?phi A"
     proof clarify
       fix A :: "'a set"
       assume **: "A \<noteq> {}"
       define B where "B = A \<inter> Field r"
       show "\<exists>a \<in> A. \<forall>a' \<in> A. (a', a) \<notin> r"
       proof (cases "B = {}")
         case True
         with ** obtain a where a: "a \<in> A" "a \<notin> Field r"
           unfolding B_def by blast
         with a have "\<forall>a' \<in> A. (a',a) \<notin> r"
           unfolding Field_def by blast
         with a show ?thesis by blast
       next
         case False
         have "B \<subseteq> Field r" unfolding B_def by blast
         with False * obtain a where a: "a \<in> B" "\<forall>a' \<in> B. (a', a) \<notin> r"
           by blast
         have "(a', a) \<notin> r" if "a' \<in> A" for a'
         proof
           assume a'a: "(a', a) \<in> r"
           with that have "a' \<in> B" unfolding B_def Field_def by blast
           with a a'a show False by blast
         qed
         with a show ?thesis unfolding B_def by blast
       qed
     qed
   qed
   finally show ?thesis by blast
 qed
 
 
 subsubsection \<open>Characterizations of well-foundedness\<close>
 
 text \<open>
   The next lemma and its corollary enable one to prove that a linear order is
   a well-order in a way which is more standard than via well-foundedness of
   the strict version of the relation.
 \<close>
 
 lemma Linear_order_wf_diff_Id:
   assumes "Linear_order r"
   shows "wf (r - Id) \<longleftrightarrow> (\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r))"
 proof (cases "r \<subseteq> Id")
   case True
   then have *: "r - Id = {}" by blast
   have "wf (r - Id)" by (simp add: *)
   moreover have "\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r"
     if *: "A \<subseteq> Field r" and **: "A \<noteq> {}" for A
   proof -
     from \<open>Linear_order r\<close> True
     obtain a where a: "r = {} \<or> r = {(a, a)}"
       unfolding order_on_defs using Total_subset_Id [of r] by blast
     with * ** have "A = {a} \<and> r = {(a, a)}"
       unfolding Field_def by blast
     with a show ?thesis by blast
   qed
   ultimately show ?thesis by blast
 next
   case False
   with \<open>Linear_order r\<close> have Field: "Field r = Field (r - Id)"
     unfolding order_on_defs using Total_Id_Field [of r] by blast
   show ?thesis
   proof
     assume *: "wf (r - Id)"
     show "\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r)"
     proof clarify
       fix A
       assume **: "A \<subseteq> Field r" and ***: "A \<noteq> {}"
       then have "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
         using Field * unfolding wf_eq_minimal2 by simp
       moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r \<longleftrightarrow> (a', a) \<notin> r - Id"
         using Linear_order_in_diff_Id [OF \<open>Linear_order r\<close>] ** by blast
       ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r" by blast
     qed
   next
     assume *: "\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r)"
     show "wf (r - Id)"
       unfolding wf_eq_minimal2
     proof clarify
       fix A
       assume **: "A \<subseteq> Field(r - Id)" and ***: "A \<noteq> {}"
       then have "\<exists>a \<in> A. \<forall>a' \<in> A. (a,a') \<in> r"
         using Field * by simp
       moreover have "\<forall>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r \<longleftrightarrow> (a', a) \<notin> r - Id"
         using Linear_order_in_diff_Id [OF \<open>Linear_order r\<close>] ** mono_Field[of "r - Id" r] by blast
       ultimately show "\<exists>a \<in> A. \<forall>a' \<in> A. (a',a) \<notin> r - Id"
         by blast
     qed
   qed
 qed
 
 corollary Linear_order_Well_order_iff:
   "Linear_order r \<Longrightarrow>
     Well_order r \<longleftrightarrow> (\<forall>A \<subseteq> Field r. A \<noteq> {} \<longrightarrow> (\<exists>a \<in> A. \<forall>a' \<in> A. (a, a') \<in> r))"
   unfolding well_order_on_def using Linear_order_wf_diff_Id[of r] by blast
 
 end
diff --git a/src/HOL/Orderings.thy b/src/HOL/Orderings.thy
--- a/src/HOL/Orderings.thy
+++ b/src/HOL/Orderings.thy
@@ -1,1712 +1,1736 @@
 (*  Title:      HOL/Orderings.thy
     Author:     Tobias Nipkow, Markus Wenzel, and Larry Paulson
 *)
 
 section \<open>Abstract orderings\<close>
 
 theory Orderings
 imports HOL
 keywords "print_orders" :: diag
 begin
 
 ML_file \<open>~~/src/Provers/order_procedure.ML\<close>
 ML_file \<open>~~/src/Provers/order_tac.ML\<close>
 
 subsection \<open>Abstract ordering\<close>
 
 locale partial_preordering =
   fixes less_eq :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>\<^bold>\<le>\<close> 50)
   assumes refl: \<open>a \<^bold>\<le> a\<close> \<comment> \<open>not \<open>iff\<close>: makes problems due to multiple (dual) interpretations\<close>
     and trans: \<open>a \<^bold>\<le> b \<Longrightarrow> b \<^bold>\<le> c \<Longrightarrow> a \<^bold>\<le> c\<close>
 
 locale preordering = partial_preordering +
   fixes less :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>\<^bold><\<close> 50)
   assumes strict_iff_not: \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> \<not> b \<^bold>\<le> a\<close>
 begin
 
 lemma strict_implies_order:
   \<open>a \<^bold>< b \<Longrightarrow> a \<^bold>\<le> b\<close>
   by (simp add: strict_iff_not)
 
 lemma irrefl: \<comment> \<open>not \<open>iff\<close>: makes problems due to multiple (dual) interpretations\<close>
   \<open>\<not> a \<^bold>< a\<close>
   by (simp add: strict_iff_not)
 
 lemma asym:
   \<open>a \<^bold>< b \<Longrightarrow> b \<^bold>< a \<Longrightarrow> False\<close>
   by (auto simp add: strict_iff_not)
 
 lemma strict_trans1:
   \<open>a \<^bold>\<le> b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
   by (auto simp add: strict_iff_not intro: trans)
 
 lemma strict_trans2:
   \<open>a \<^bold>< b \<Longrightarrow> b \<^bold>\<le> c \<Longrightarrow> a \<^bold>< c\<close>
   by (auto simp add: strict_iff_not intro: trans)
 
 lemma strict_trans:
   \<open>a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
   by (auto intro: strict_trans1 strict_implies_order)
 
 end
 
 lemma preordering_strictI: \<comment> \<open>Alternative introduction rule with bias towards strict order\<close>
   fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
     and less (infix \<open>\<^bold><\<close> 50)
   assumes less_eq_less: \<open>\<And>a b. a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b\<close>
     assumes asym: \<open>\<And>a b. a \<^bold>< b \<Longrightarrow> \<not> b \<^bold>< a\<close>
   assumes irrefl: \<open>\<And>a. \<not> a \<^bold>< a\<close>
   assumes trans: \<open>\<And>a b c. a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
   shows \<open>preordering (\<^bold>\<le>) (\<^bold><)\<close>
 proof
   fix a b
   show \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> \<not> b \<^bold>\<le> a\<close>
     by (auto simp add: less_eq_less asym irrefl)
 next
   fix a
   show \<open>a \<^bold>\<le> a\<close>
     by (auto simp add: less_eq_less)
 next
   fix a b c
   assume \<open>a \<^bold>\<le> b\<close> and \<open>b \<^bold>\<le> c\<close> then show \<open>a \<^bold>\<le> c\<close>
     by (auto simp add: less_eq_less intro: trans)
 qed
 
 lemma preordering_dualI:
   fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
     and less (infix \<open>\<^bold><\<close> 50)
   assumes \<open>preordering (\<lambda>a b. b \<^bold>\<le> a) (\<lambda>a b. b \<^bold>< a)\<close>
   shows \<open>preordering (\<^bold>\<le>) (\<^bold><)\<close>
 proof -
   from assms interpret preordering \<open>\<lambda>a b. b \<^bold>\<le> a\<close> \<open>\<lambda>a b. b \<^bold>< a\<close> .
   show ?thesis
     by standard (auto simp: strict_iff_not refl intro: trans)
 qed
 
 locale ordering = partial_preordering +
   fixes less :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>\<^bold><\<close> 50)
   assumes strict_iff_order: \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> a \<noteq> b\<close>
   assumes antisym: \<open>a \<^bold>\<le> b \<Longrightarrow> b \<^bold>\<le> a \<Longrightarrow> a = b\<close>
 begin
 
 sublocale preordering \<open>(\<^bold>\<le>)\<close> \<open>(\<^bold><)\<close>
 proof
   show \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> \<not> b \<^bold>\<le> a\<close> for a b
     by (auto simp add: strict_iff_order intro: antisym)
 qed
 
 lemma strict_implies_not_eq:
   \<open>a \<^bold>< b \<Longrightarrow> a \<noteq> b\<close>
   by (simp add: strict_iff_order)
 
 lemma not_eq_order_implies_strict:
   \<open>a \<noteq> b \<Longrightarrow> a \<^bold>\<le> b \<Longrightarrow> a \<^bold>< b\<close>
   by (simp add: strict_iff_order)
 
 lemma order_iff_strict:
   \<open>a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b\<close>
   by (auto simp add: strict_iff_order refl)
 
 lemma eq_iff: \<open>a = b \<longleftrightarrow> a \<^bold>\<le> b \<and> b \<^bold>\<le> a\<close>
   by (auto simp add: refl intro: antisym)
 
 end
 
 lemma ordering_strictI: \<comment> \<open>Alternative introduction rule with bias towards strict order\<close>
   fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
     and less (infix \<open>\<^bold><\<close> 50)
   assumes less_eq_less: \<open>\<And>a b. a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b\<close>
     assumes asym: \<open>\<And>a b. a \<^bold>< b \<Longrightarrow> \<not> b \<^bold>< a\<close>
   assumes irrefl: \<open>\<And>a. \<not> a \<^bold>< a\<close>
   assumes trans: \<open>\<And>a b c. a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c\<close>
   shows \<open>ordering (\<^bold>\<le>) (\<^bold><)\<close>
 proof
   fix a b
   show \<open>a \<^bold>< b \<longleftrightarrow> a \<^bold>\<le> b \<and> a \<noteq> b\<close>
     by (auto simp add: less_eq_less asym irrefl)
 next
   fix a
   show \<open>a \<^bold>\<le> a\<close>
     by (auto simp add: less_eq_less)
 next
   fix a b c
   assume \<open>a \<^bold>\<le> b\<close> and \<open>b \<^bold>\<le> c\<close> then show \<open>a \<^bold>\<le> c\<close>
     by (auto simp add: less_eq_less intro: trans)
 next
   fix a b
   assume \<open>a \<^bold>\<le> b\<close> and \<open>b \<^bold>\<le> a\<close> then show \<open>a = b\<close>
     by (auto simp add: less_eq_less asym)
 qed
 
 lemma ordering_dualI:
   fixes less_eq (infix \<open>\<^bold>\<le>\<close> 50)
     and less (infix \<open>\<^bold><\<close> 50)
   assumes \<open>ordering (\<lambda>a b. b \<^bold>\<le> a) (\<lambda>a b. b \<^bold>< a)\<close>
   shows \<open>ordering (\<^bold>\<le>) (\<^bold><)\<close>
 proof -
   from assms interpret ordering \<open>\<lambda>a b. b \<^bold>\<le> a\<close> \<open>\<lambda>a b. b \<^bold>< a\<close> .
   show ?thesis
     by standard (auto simp: strict_iff_order refl intro: antisym trans)
 qed
 
 locale ordering_top = ordering +
   fixes top :: \<open>'a\<close>  (\<open>\<^bold>\<top>\<close>)
   assumes extremum [simp]: \<open>a \<^bold>\<le> \<^bold>\<top>\<close>
 begin
 
 lemma extremum_uniqueI:
   \<open>\<^bold>\<top> \<^bold>\<le> a \<Longrightarrow> a = \<^bold>\<top>\<close>
   by (rule antisym) auto
 
 lemma extremum_unique:
   \<open>\<^bold>\<top> \<^bold>\<le> a \<longleftrightarrow> a = \<^bold>\<top>\<close>
   by (auto intro: antisym)
 
 lemma extremum_strict [simp]:
   \<open>\<not> (\<^bold>\<top> \<^bold>< a)\<close>
   using extremum [of a] by (auto simp add: order_iff_strict intro: asym irrefl)
 
 lemma not_eq_extremum:
   \<open>a \<noteq> \<^bold>\<top> \<longleftrightarrow> a \<^bold>< \<^bold>\<top>\<close>
   by (auto simp add: order_iff_strict intro: not_eq_order_implies_strict extremum)
 
 end
 
 
 subsection \<open>Syntactic orders\<close>
 
 class ord =
   fixes less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
     and less :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
 begin
 
 notation
   less_eq  ("'(\<le>')") and
   less_eq  ("(_/ \<le> _)"  [51, 51] 50) and
   less  ("'(<')") and
   less  ("(_/ < _)"  [51, 51] 50)
 
 abbreviation (input)
   greater_eq  (infix "\<ge>" 50)
   where "x \<ge> y \<equiv> y \<le> x"
 
 abbreviation (input)
   greater  (infix ">" 50)
   where "x > y \<equiv> y < x"
 
 notation (ASCII)
   less_eq  ("'(<=')") and
   less_eq  ("(_/ <= _)" [51, 51] 50)
 
 notation (input)
   greater_eq  (infix ">=" 50)
 
 end
 
 
 subsection \<open>Quasi orders\<close>
 
 class preorder = ord +
   assumes less_le_not_le: "x < y \<longleftrightarrow> x \<le> y \<and> \<not> (y \<le> x)"
   and order_refl [iff]: "x \<le> x"
   and order_trans: "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
 begin
 
 sublocale order: preordering less_eq less + dual_order: preordering greater_eq greater
 proof -
   interpret preordering less_eq less
     by standard (auto intro: order_trans simp add: less_le_not_le)
   show \<open>preordering less_eq less\<close>
     by (fact preordering_axioms)
   then show \<open>preordering greater_eq greater\<close>
     by (rule preordering_dualI)
 qed
 
 text \<open>Reflexivity.\<close>
 
 lemma eq_refl: "x = y \<Longrightarrow> x \<le> y"
     \<comment> \<open>This form is useful with the classical reasoner.\<close>
 by (erule ssubst) (rule order_refl)
 
 lemma less_irrefl [iff]: "\<not> x < x"
 by (simp add: less_le_not_le)
 
 lemma less_imp_le: "x < y \<Longrightarrow> x \<le> y"
 by (simp add: less_le_not_le)
 
 
 text \<open>Asymmetry.\<close>
 
 lemma less_not_sym: "x < y \<Longrightarrow> \<not> (y < x)"
 by (simp add: less_le_not_le)
 
 lemma less_asym: "x < y \<Longrightarrow> (\<not> P \<Longrightarrow> y < x) \<Longrightarrow> P"
 by (drule less_not_sym, erule contrapos_np) simp
 
 
 text \<open>Transitivity.\<close>
 
 lemma less_trans: "x < y \<Longrightarrow> y < z \<Longrightarrow> x < z"
 by (auto simp add: less_le_not_le intro: order_trans)
 
 lemma le_less_trans: "x \<le> y \<Longrightarrow> y < z \<Longrightarrow> x < z"
 by (auto simp add: less_le_not_le intro: order_trans)
 
 lemma less_le_trans: "x < y \<Longrightarrow> y \<le> z \<Longrightarrow> x < z"
 by (auto simp add: less_le_not_le intro: order_trans)
 
 
 text \<open>Useful for simplification, but too risky to include by default.\<close>
 
 lemma less_imp_not_less: "x < y \<Longrightarrow> (\<not> y < x) \<longleftrightarrow> True"
 by (blast elim: less_asym)
 
 lemma less_imp_triv: "x < y \<Longrightarrow> (y < x \<longrightarrow> P) \<longleftrightarrow> True"
 by (blast elim: less_asym)
 
 
 text \<open>Transitivity rules for calculational reasoning\<close>
 
 lemma less_asym': "a < b \<Longrightarrow> b < a \<Longrightarrow> P"
 by (rule less_asym)
 
 
 text \<open>Dual order\<close>
 
 lemma dual_preorder:
   \<open>class.preorder (\<ge>) (>)\<close>
   by standard (auto simp add: less_le_not_le intro: order_trans)
 
 end
 
 lemma preordering_preorderI:
   \<open>class.preorder (\<^bold>\<le>) (\<^bold><)\<close> if \<open>preordering (\<^bold>\<le>) (\<^bold><)\<close>
     for less_eq (infix \<open>\<^bold>\<le>\<close> 50) and less (infix \<open>\<^bold><\<close> 50)
 proof -
   from that interpret preordering \<open>(\<^bold>\<le>)\<close> \<open>(\<^bold><)\<close> .
   show ?thesis
     by standard (auto simp add: strict_iff_not refl intro: trans)
 qed
 
 
 
 subsection \<open>Partial orders\<close>
 
 class order = preorder +
   assumes order_antisym: "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
 begin
 
 lemma less_le: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"
   by (auto simp add: less_le_not_le intro: order_antisym)
 
 sublocale order: ordering less_eq less + dual_order: ordering greater_eq greater
 proof -
   interpret ordering less_eq less
     by standard (auto intro: order_antisym order_trans simp add: less_le)
   show "ordering less_eq less"
     by (fact ordering_axioms)
   then show "ordering greater_eq greater"
     by (rule ordering_dualI)
 qed
 
 print_theorems
 
 text \<open>Reflexivity.\<close>
 
 lemma le_less: "x \<le> y \<longleftrightarrow> x < y \<or> x = y"
     \<comment> \<open>NOT suitable for iff, since it can cause PROOF FAILED.\<close>
 by (fact order.order_iff_strict)
 
 lemma le_imp_less_or_eq: "x \<le> y \<Longrightarrow> x < y \<or> x = y"
 by (simp add: less_le)
 
 
 text \<open>Useful for simplification, but too risky to include by default.\<close>
 
 lemma less_imp_not_eq: "x < y \<Longrightarrow> (x = y) \<longleftrightarrow> False"
 by auto
 
 lemma less_imp_not_eq2: "x < y \<Longrightarrow> (y = x) \<longleftrightarrow> False"
 by auto
 
 
 text \<open>Transitivity rules for calculational reasoning\<close>
 
 lemma neq_le_trans: "a \<noteq> b \<Longrightarrow> a \<le> b \<Longrightarrow> a < b"
 by (fact order.not_eq_order_implies_strict)
 
 lemma le_neq_trans: "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a < b"
 by (rule order.not_eq_order_implies_strict)
 
 
 text \<open>Asymmetry.\<close>
 
 lemma order_eq_iff: "x = y \<longleftrightarrow> x \<le> y \<and> y \<le> x"
   by (fact order.eq_iff)
 
 lemma antisym_conv: "y \<le> x \<Longrightarrow> x \<le> y \<longleftrightarrow> x = y"
   by (simp add: order.eq_iff)
 
 lemma less_imp_neq: "x < y \<Longrightarrow> x \<noteq> y"
   by (fact order.strict_implies_not_eq)
 
 lemma antisym_conv1: "\<not> x < y \<Longrightarrow> x \<le> y \<longleftrightarrow> x = y"
   by (simp add: local.le_less)
 
 lemma antisym_conv2: "x \<le> y \<Longrightarrow> \<not> x < y \<longleftrightarrow> x = y"
   by (simp add: local.less_le)
 
 lemma leD: "y \<le> x \<Longrightarrow> \<not> x < y"
   by (auto simp: less_le order.antisym)
 
 text \<open>Least value operator\<close>
 
 definition (in ord)
   Least :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" (binder "LEAST " 10) where
   "Least P = (THE x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<le> y))"
 
 lemma Least_equality:
   assumes "P x"
     and "\<And>y. P y \<Longrightarrow> x \<le> y"
   shows "Least P = x"
 unfolding Least_def by (rule the_equality)
   (blast intro: assms order.antisym)+
 
 lemma LeastI2_order:
   assumes "P x"
     and "\<And>y. P y \<Longrightarrow> x \<le> y"
     and "\<And>x. P x \<Longrightarrow> \<forall>y. P y \<longrightarrow> x \<le> y \<Longrightarrow> Q x"
   shows "Q (Least P)"
 unfolding Least_def by (rule theI2)
   (blast intro: assms order.antisym)+
 
 lemma Least_ex1:
   assumes   "\<exists>!x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<le> y)"
   shows     Least1I: "P (Least P)" and Least1_le: "P z \<Longrightarrow> Least P \<le> z"
   using     theI'[OF assms]
   unfolding Least_def
   by        auto
 
 text \<open>Greatest value operator\<close>
 
 definition Greatest :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" (binder "GREATEST " 10) where
 "Greatest P = (THE x. P x \<and> (\<forall>y. P y \<longrightarrow> x \<ge> y))"
 
 lemma GreatestI2_order:
   "\<lbrakk> P x;
     \<And>y. P y \<Longrightarrow> x \<ge> y;
     \<And>x. \<lbrakk> P x; \<forall>y. P y \<longrightarrow> x \<ge> y \<rbrakk> \<Longrightarrow> Q x \<rbrakk>
   \<Longrightarrow> Q (Greatest P)"
 unfolding Greatest_def
 by (rule theI2) (blast intro: order.antisym)+
 
 lemma Greatest_equality:
   "\<lbrakk> P x;  \<And>y. P y \<Longrightarrow> x \<ge> y \<rbrakk> \<Longrightarrow> Greatest P = x"
 unfolding Greatest_def
 by (rule the_equality) (blast intro: order.antisym)+
 
 end
 
 lemma ordering_orderI:
   fixes less_eq (infix "\<^bold>\<le>" 50)
     and less (infix "\<^bold><" 50)
   assumes "ordering less_eq less"
   shows "class.order less_eq less"
 proof -
   from assms interpret ordering less_eq less .
   show ?thesis
     by standard (auto intro: antisym trans simp add: refl strict_iff_order)
 qed
 
 lemma order_strictI:
   fixes less (infix "\<^bold><" 50)
     and less_eq (infix "\<^bold>\<le>" 50)
   assumes "\<And>a b. a \<^bold>\<le> b \<longleftrightarrow> a \<^bold>< b \<or> a = b"
     assumes "\<And>a b. a \<^bold>< b \<Longrightarrow> \<not> b \<^bold>< a"
   assumes "\<And>a. \<not> a \<^bold>< a"
   assumes "\<And>a b c. a \<^bold>< b \<Longrightarrow> b \<^bold>< c \<Longrightarrow> a \<^bold>< c"
   shows "class.order less_eq less"
   by (rule ordering_orderI) (rule ordering_strictI, (fact assms)+)
 
 context order
 begin
 
 text \<open>Dual order\<close>
 
 lemma dual_order:
   "class.order (\<ge>) (>)"
   using dual_order.ordering_axioms by (rule ordering_orderI)
 
 end
 
 
 subsection \<open>Linear (total) orders\<close>
 
 class linorder = order +
   assumes linear: "x \<le> y \<or> y \<le> x"
 begin
 
 lemma less_linear: "x < y \<or> x = y \<or> y < x"
 unfolding less_le using less_le linear by blast
 
 lemma le_less_linear: "x \<le> y \<or> y < x"
 by (simp add: le_less less_linear)
 
 lemma le_cases [case_names le ge]:
   "(x \<le> y \<Longrightarrow> P) \<Longrightarrow> (y \<le> x \<Longrightarrow> P) \<Longrightarrow> P"
 using linear by blast
 
 lemma (in linorder) le_cases3:
   "\<lbrakk>\<lbrakk>x \<le> y; y \<le> z\<rbrakk> \<Longrightarrow> P; \<lbrakk>y \<le> x; x \<le> z\<rbrakk> \<Longrightarrow> P; \<lbrakk>x \<le> z; z \<le> y\<rbrakk> \<Longrightarrow> P;
     \<lbrakk>z \<le> y; y \<le> x\<rbrakk> \<Longrightarrow> P; \<lbrakk>y \<le> z; z \<le> x\<rbrakk> \<Longrightarrow> P; \<lbrakk>z \<le> x; x \<le> y\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
 by (blast intro: le_cases)
 
 lemma linorder_cases [case_names less equal greater]:
   "(x < y \<Longrightarrow> P) \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> (y < x \<Longrightarrow> P) \<Longrightarrow> P"
 using less_linear by blast
 
 lemma linorder_wlog[case_names le sym]:
   "(\<And>a b. a \<le> b \<Longrightarrow> P a b) \<Longrightarrow> (\<And>a b. P b a \<Longrightarrow> P a b) \<Longrightarrow> P a b"
   by (cases rule: le_cases[of a b]) blast+
 
 lemma not_less: "\<not> x < y \<longleftrightarrow> y \<le> x"
   unfolding less_le
   using linear by (blast intro: order.antisym)
 
 lemma not_less_iff_gr_or_eq: "\<not>(x < y) \<longleftrightarrow> (x > y \<or> x = y)"
   by (auto simp add:not_less le_less)
 
 lemma not_le: "\<not> x \<le> y \<longleftrightarrow> y < x"
   unfolding less_le
   using linear by (blast intro: order.antisym)
 
 lemma neq_iff: "x \<noteq> y \<longleftrightarrow> x < y \<or> y < x"
 by (cut_tac x = x and y = y in less_linear, auto)
 
 lemma neqE: "x \<noteq> y \<Longrightarrow> (x < y \<Longrightarrow> R) \<Longrightarrow> (y < x \<Longrightarrow> R) \<Longrightarrow> R"
 by (simp add: neq_iff) blast
 
 lemma antisym_conv3: "\<not> y < x \<Longrightarrow> \<not> x < y \<longleftrightarrow> x = y"
 by (blast intro: order.antisym dest: not_less [THEN iffD1])
 
 lemma leI: "\<not> x < y \<Longrightarrow> y \<le> x"
 unfolding not_less .
 
 lemma not_le_imp_less: "\<not> y \<le> x \<Longrightarrow> x < y"
 unfolding not_le .
 
 lemma linorder_less_wlog[case_names less refl sym]:
      "\<lbrakk>\<And>a b. a < b \<Longrightarrow> P a b;  \<And>a. P a a;  \<And>a b. P b a \<Longrightarrow> P a b\<rbrakk> \<Longrightarrow> P a b"
   using antisym_conv3 by blast
 
 text \<open>Dual order\<close>
 
 lemma dual_linorder:
   "class.linorder (\<ge>) (>)"
 by (rule class.linorder.intro, rule dual_order) (unfold_locales, rule linear)
 
 end
 
 
 text \<open>Alternative introduction rule with bias towards strict order\<close>
 
 lemma linorder_strictI:
   fixes less_eq (infix "\<^bold>\<le>" 50)
     and less (infix "\<^bold><" 50)
   assumes "class.order less_eq less"
   assumes trichotomy: "\<And>a b. a \<^bold>< b \<or> a = b \<or> b \<^bold>< a"
   shows "class.linorder less_eq less"
 proof -
   interpret order less_eq less
     by (fact \<open>class.order less_eq less\<close>)
   show ?thesis
   proof
     fix a b
     show "a \<^bold>\<le> b \<or> b \<^bold>\<le> a"
       using trichotomy by (auto simp add: le_less)
   qed
 qed
 
 
 subsection \<open>Reasoning tools setup\<close>
 
 ML \<open>
 structure Logic_Signature : LOGIC_SIGNATURE = struct
   val mk_Trueprop = HOLogic.mk_Trueprop
   val dest_Trueprop = HOLogic.dest_Trueprop
   val Trueprop_conv = HOLogic.Trueprop_conv
   val Not = HOLogic.Not
   val conj = HOLogic.conj
   val disj = HOLogic.disj
   
   val notI = @{thm notI}
   val ccontr = @{thm ccontr}
   val conjI = @{thm conjI}  
   val conjE = @{thm conjE}
   val disjE = @{thm disjE}
 
   val not_not_conv = Conv.rewr_conv @{thm eq_reflection[OF not_not]}
   val de_Morgan_conj_conv = Conv.rewr_conv @{thm eq_reflection[OF de_Morgan_conj]}
   val de_Morgan_disj_conv = Conv.rewr_conv @{thm eq_reflection[OF de_Morgan_disj]}
   val conj_disj_distribL_conv = Conv.rewr_conv @{thm eq_reflection[OF conj_disj_distribL]}
   val conj_disj_distribR_conv = Conv.rewr_conv @{thm eq_reflection[OF conj_disj_distribR]}
 end
 
 structure HOL_Base_Order_Tac = Base_Order_Tac(
   structure Logic_Sig = Logic_Signature;
   (* Exclude types with specialised solvers. *)
   val excluded_types = [HOLogic.natT, HOLogic.intT, HOLogic.realT]
 )
 
 structure HOL_Order_Tac = Order_Tac(structure Base_Tac = HOL_Base_Order_Tac)
 
 fun print_orders ctxt0 =
   let
     val ctxt = Config.put show_sorts true ctxt0
     val orders = HOL_Order_Tac.Data.get (Context.Proof ctxt)
     fun pretty_term t = Pretty.block
       [Pretty.quote (Syntax.pretty_term ctxt t), Pretty.brk 1,
         Pretty.str "::", Pretty.brk 1,
         Pretty.quote (Syntax.pretty_typ ctxt (type_of t)), Pretty.brk 1]
     fun pretty_order ({kind = kind, ops = ops, ...}, _) =
       Pretty.block ([Pretty.str (@{make_string} kind), Pretty.str ":", Pretty.brk 1]
                     @ map pretty_term ops)
   in
     Pretty.writeln (Pretty.big_list "order structures:" (map pretty_order orders))
   end
 
 val _ =
   Outer_Syntax.command \<^command_keyword>\<open>print_orders\<close>
     "print order structures available to transitivity reasoner"
     (Scan.succeed (Toplevel.keep (print_orders o Toplevel.context_of)))
 
 \<close>
 
 method_setup order = \<open>
   Scan.succeed (fn ctxt => SIMPLE_METHOD' (HOL_Order_Tac.tac [] ctxt))
 \<close> "transitivity reasoner"
 
 
 text \<open>Declarations to set up transitivity reasoner of partial and linear orders.\<close>
 
 context order
 begin
 
 lemma nless_le: "(\<not> a < b) \<longleftrightarrow> (\<not> a \<le> b) \<or> a = b"
   using local.dual_order.order_iff_strict by blast
 
 local_setup \<open>
   HOL_Order_Tac.declare_order {
     ops = {eq = @{term \<open>(=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>}, le = @{term \<open>(\<le>)\<close>}, lt = @{term \<open>(<)\<close>}},
     thms = {trans = @{thm order_trans}, refl = @{thm order_refl}, eqD1 = @{thm eq_refl},
             eqD2 = @{thm eq_refl[OF sym]}, antisym = @{thm order_antisym}, contr = @{thm notE}},
     conv_thms = {less_le = @{thm eq_reflection[OF less_le]},
                  nless_le = @{thm eq_reflection[OF nless_le]}}
   }
 \<close>
 
 end
 
 context linorder
 begin
 
 lemma nle_le: "(\<not> a \<le> b) \<longleftrightarrow> b \<le> a \<and> b \<noteq> a"
   using not_le less_le by simp
 
 local_setup \<open>
   HOL_Order_Tac.declare_linorder {
     ops = {eq = @{term \<open>(=) :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>}, le = @{term \<open>(\<le>)\<close>}, lt = @{term \<open>(<)\<close>}},
     thms = {trans = @{thm order_trans}, refl = @{thm order_refl}, eqD1 = @{thm eq_refl},
             eqD2 = @{thm eq_refl[OF sym]}, antisym = @{thm order_antisym}, contr = @{thm notE}},
     conv_thms = {less_le = @{thm eq_reflection[OF less_le]},
                  nless_le = @{thm eq_reflection[OF not_less]},
                  nle_le = @{thm eq_reflection[OF nle_le]}}
   }
 \<close>
 
 end
 
 setup \<open>
   map_theory_simpset (fn ctxt0 => ctxt0 addSolver
     mk_solver "Transitivity" (fn ctxt => HOL_Order_Tac.tac (Simplifier.prems_of ctxt) ctxt))
 \<close>
 
 ML \<open>
 local
   fun prp t thm = Thm.prop_of thm = t;  (* FIXME proper aconv!? *)
 in
 
 fun antisym_le_simproc ctxt ct =
   (case Thm.term_of ct of
     (le as Const (_, T)) $ r $ s =>
      (let
         val prems = Simplifier.prems_of ctxt;
         val less = Const (\<^const_name>\<open>less\<close>, T);
         val t = HOLogic.mk_Trueprop(le $ s $ r);
       in
         (case find_first (prp t) prems of
           NONE =>
             let val t = HOLogic.mk_Trueprop(HOLogic.Not $ (less $ r $ s)) in
               (case find_first (prp t) prems of
                 NONE => NONE
               | SOME thm => SOME(mk_meta_eq(thm RS @{thm antisym_conv1})))
              end
          | SOME thm => SOME (mk_meta_eq (thm RS @{thm order_class.antisym_conv})))
       end handle THM _ => NONE)
   | _ => NONE);
 
 fun antisym_less_simproc ctxt ct =
   (case Thm.term_of ct of
     NotC $ ((less as Const(_,T)) $ r $ s) =>
      (let
        val prems = Simplifier.prems_of ctxt;
        val le = Const (\<^const_name>\<open>less_eq\<close>, T);
        val t = HOLogic.mk_Trueprop(le $ r $ s);
       in
         (case find_first (prp t) prems of
           NONE =>
             let val t = HOLogic.mk_Trueprop (NotC $ (less $ s $ r)) in
               (case find_first (prp t) prems of
                 NONE => NONE
               | SOME thm => SOME (mk_meta_eq(thm RS @{thm linorder_class.antisym_conv3})))
             end
         | SOME thm => SOME (mk_meta_eq (thm RS @{thm antisym_conv2})))
       end handle THM _ => NONE)                           
   | _ => NONE);
 
 end;
 \<close>
 
 simproc_setup antisym_le ("(x::'a::order) \<le> y") = "K antisym_le_simproc"
 simproc_setup antisym_less ("\<not> (x::'a::linorder) < y") = "K antisym_less_simproc"
 
 
 subsection \<open>Bounded quantifiers\<close>
 
 syntax (ASCII)
   "_All_less" :: "[idt, 'a, bool] => bool"    ("(3ALL _<_./ _)"  [0, 0, 10] 10)
   "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3EX _<_./ _)"  [0, 0, 10] 10)
   "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3ALL _<=_./ _)" [0, 0, 10] 10)
   "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3EX _<=_./ _)" [0, 0, 10] 10)
 
   "_All_greater" :: "[idt, 'a, bool] => bool"    ("(3ALL _>_./ _)"  [0, 0, 10] 10)
   "_Ex_greater" :: "[idt, 'a, bool] => bool"    ("(3EX _>_./ _)"  [0, 0, 10] 10)
   "_All_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3ALL _>=_./ _)" [0, 0, 10] 10)
   "_Ex_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3EX _>=_./ _)" [0, 0, 10] 10)
 
   "_All_neq" :: "[idt, 'a, bool] => bool"    ("(3ALL _~=_./ _)"  [0, 0, 10] 10)
   "_Ex_neq" :: "[idt, 'a, bool] => bool"    ("(3EX _~=_./ _)"  [0, 0, 10] 10)
 
 syntax
   "_All_less" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_<_./ _)"  [0, 0, 10] 10)
   "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_<_./ _)"  [0, 0, 10] 10)
   "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<le>_./ _)" [0, 0, 10] 10)
   "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<le>_./ _)" [0, 0, 10] 10)
 
   "_All_greater" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_>_./ _)"  [0, 0, 10] 10)
   "_Ex_greater" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_>_./ _)"  [0, 0, 10] 10)
   "_All_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<ge>_./ _)" [0, 0, 10] 10)
   "_Ex_greater_eq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<ge>_./ _)" [0, 0, 10] 10)
 
   "_All_neq" :: "[idt, 'a, bool] => bool"    ("(3\<forall>_\<noteq>_./ _)"  [0, 0, 10] 10)
   "_Ex_neq" :: "[idt, 'a, bool] => bool"    ("(3\<exists>_\<noteq>_./ _)"  [0, 0, 10] 10)
 
 syntax (input)
   "_All_less" :: "[idt, 'a, bool] => bool"    ("(3! _<_./ _)"  [0, 0, 10] 10)
   "_Ex_less" :: "[idt, 'a, bool] => bool"    ("(3? _<_./ _)"  [0, 0, 10] 10)
   "_All_less_eq" :: "[idt, 'a, bool] => bool"    ("(3! _<=_./ _)" [0, 0, 10] 10)
   "_Ex_less_eq" :: "[idt, 'a, bool] => bool"    ("(3? _<=_./ _)" [0, 0, 10] 10)
   "_All_neq" :: "[idt, 'a, bool] => bool"    ("(3! _~=_./ _)"  [0, 0, 10] 10)
   "_Ex_neq" :: "[idt, 'a, bool] => bool"    ("(3? _~=_./ _)"  [0, 0, 10] 10)
 
 translations
   "\<forall>x<y. P" \<rightharpoonup> "\<forall>x. x < y \<longrightarrow> P"
   "\<exists>x<y. P" \<rightharpoonup> "\<exists>x. x < y \<and> P"
   "\<forall>x\<le>y. P" \<rightharpoonup> "\<forall>x. x \<le> y \<longrightarrow> P"
   "\<exists>x\<le>y. P" \<rightharpoonup> "\<exists>x. x \<le> y \<and> P"
   "\<forall>x>y. P" \<rightharpoonup> "\<forall>x. x > y \<longrightarrow> P"
   "\<exists>x>y. P" \<rightharpoonup> "\<exists>x. x > y \<and> P"
   "\<forall>x\<ge>y. P" \<rightharpoonup> "\<forall>x. x \<ge> y \<longrightarrow> P"
   "\<exists>x\<ge>y. P" \<rightharpoonup> "\<exists>x. x \<ge> y \<and> P"
   "\<forall>x\<noteq>y. P" \<rightharpoonup> "\<forall>x. x \<noteq> y \<longrightarrow> P"
   "\<exists>x\<noteq>y. P" \<rightharpoonup> "\<exists>x. x \<noteq> y \<and> P"
 
 print_translation \<open>
 let
   val All_binder = Mixfix.binder_name \<^const_syntax>\<open>All\<close>;
   val Ex_binder = Mixfix.binder_name \<^const_syntax>\<open>Ex\<close>;
   val impl = \<^const_syntax>\<open>HOL.implies\<close>;
   val conj = \<^const_syntax>\<open>HOL.conj\<close>;
   val less = \<^const_syntax>\<open>less\<close>;
   val less_eq = \<^const_syntax>\<open>less_eq\<close>;
 
   val trans =
    [((All_binder, impl, less),
     (\<^syntax_const>\<open>_All_less\<close>, \<^syntax_const>\<open>_All_greater\<close>)),
     ((All_binder, impl, less_eq),
     (\<^syntax_const>\<open>_All_less_eq\<close>, \<^syntax_const>\<open>_All_greater_eq\<close>)),
     ((Ex_binder, conj, less),
     (\<^syntax_const>\<open>_Ex_less\<close>, \<^syntax_const>\<open>_Ex_greater\<close>)),
     ((Ex_binder, conj, less_eq),
     (\<^syntax_const>\<open>_Ex_less_eq\<close>, \<^syntax_const>\<open>_Ex_greater_eq\<close>))];
 
   fun matches_bound v t =
     (case t of
       Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (v', _) => v = v'
     | _ => false);
   fun contains_var v = Term.exists_subterm (fn Free (x, _) => x = v | _ => false);
   fun mk x c n P = Syntax.const c $ Syntax_Trans.mark_bound_body x $ n $ P;
 
   fun tr' q = (q, fn _ =>
     (fn [Const (\<^syntax_const>\<open>_bound\<close>, _) $ Free (v, T),
         Const (c, _) $ (Const (d, _) $ t $ u) $ P] =>
         (case AList.lookup (=) trans (q, c, d) of
           NONE => raise Match
         | SOME (l, g) =>
             if matches_bound v t andalso not (contains_var v u) then mk (v, T) l u P
             else if matches_bound v u andalso not (contains_var v t) then mk (v, T) g t P
             else raise Match)
       | _ => raise Match));
 in [tr' All_binder, tr' Ex_binder] end
 \<close>
 
 
 subsection \<open>Transitivity reasoning\<close>
 
 context ord
 begin
 
 lemma ord_le_eq_trans: "a \<le> b \<Longrightarrow> b = c \<Longrightarrow> a \<le> c"
   by (rule subst)
 
 lemma ord_eq_le_trans: "a = b \<Longrightarrow> b \<le> c \<Longrightarrow> a \<le> c"
   by (rule ssubst)
 
 lemma ord_less_eq_trans: "a < b \<Longrightarrow> b = c \<Longrightarrow> a < c"
   by (rule subst)
 
 lemma ord_eq_less_trans: "a = b \<Longrightarrow> b < c \<Longrightarrow> a < c"
   by (rule ssubst)
 
 end
 
-lemma order_less_subst2: "(a::'a::order) < b ==> f b < (c::'c::order) ==>
-  (!!x y. x < y ==> f x < f y) ==> f a < c"
+lemma order_less_subst2: "(a::'a::order) < b \<Longrightarrow> f b < (c::'c::order) \<Longrightarrow>
+  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> f a < c"
 proof -
-  assume r: "!!x y. x < y ==> f x < f y"
+  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
   assume "a < b" hence "f a < f b" by (rule r)
   also assume "f b < c"
   finally (less_trans) show ?thesis .
 qed
 
-lemma order_less_subst1: "(a::'a::order) < f b ==> (b::'b::order) < c ==>
-  (!!x y. x < y ==> f x < f y) ==> a < f c"
+lemma order_less_subst1: "(a::'a::order) < f b \<Longrightarrow> (b::'b::order) < c \<Longrightarrow>
+  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> a < f c"
 proof -
-  assume r: "!!x y. x < y ==> f x < f y"
+  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
   assume "a < f b"
   also assume "b < c" hence "f b < f c" by (rule r)
   finally (less_trans) show ?thesis .
 qed
 
-lemma order_le_less_subst2: "(a::'a::order) <= b ==> f b < (c::'c::order) ==>
-  (!!x y. x <= y ==> f x <= f y) ==> f a < c"
+lemma order_le_less_subst2: "(a::'a::order) <= b \<Longrightarrow> f b < (c::'c::order) \<Longrightarrow>
+  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> f a < c"
 proof -
-  assume r: "!!x y. x <= y ==> f x <= f y"
+  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
   assume "a <= b" hence "f a <= f b" by (rule r)
   also assume "f b < c"
   finally (le_less_trans) show ?thesis .
 qed
 
-lemma order_le_less_subst1: "(a::'a::order) <= f b ==> (b::'b::order) < c ==>
-  (!!x y. x < y ==> f x < f y) ==> a < f c"
+lemma order_le_less_subst1: "(a::'a::order) <= f b \<Longrightarrow> (b::'b::order) < c \<Longrightarrow>
+  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> a < f c"
 proof -
-  assume r: "!!x y. x < y ==> f x < f y"
+  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
   assume "a <= f b"
   also assume "b < c" hence "f b < f c" by (rule r)
   finally (le_less_trans) show ?thesis .
 qed
 
-lemma order_less_le_subst2: "(a::'a::order) < b ==> f b <= (c::'c::order) ==>
-  (!!x y. x < y ==> f x < f y) ==> f a < c"
+lemma order_less_le_subst2: "(a::'a::order) < b \<Longrightarrow> f b <= (c::'c::order) \<Longrightarrow>
+  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> f a < c"
 proof -
-  assume r: "!!x y. x < y ==> f x < f y"
+  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
   assume "a < b" hence "f a < f b" by (rule r)
   also assume "f b <= c"
   finally (less_le_trans) show ?thesis .
 qed
 
-lemma order_less_le_subst1: "(a::'a::order) < f b ==> (b::'b::order) <= c ==>
-  (!!x y. x <= y ==> f x <= f y) ==> a < f c"
+lemma order_less_le_subst1: "(a::'a::order) < f b \<Longrightarrow> (b::'b::order) <= c \<Longrightarrow>
+  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> a < f c"
 proof -
-  assume r: "!!x y. x <= y ==> f x <= f y"
+  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
   assume "a < f b"
   also assume "b <= c" hence "f b <= f c" by (rule r)
   finally (less_le_trans) show ?thesis .
 qed
 
-lemma order_subst1: "(a::'a::order) <= f b ==> (b::'b::order) <= c ==>
-  (!!x y. x <= y ==> f x <= f y) ==> a <= f c"
+lemma order_subst1: "(a::'a::order) <= f b \<Longrightarrow> (b::'b::order) <= c \<Longrightarrow>
+  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> a <= f c"
 proof -
-  assume r: "!!x y. x <= y ==> f x <= f y"
+  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
   assume "a <= f b"
   also assume "b <= c" hence "f b <= f c" by (rule r)
   finally (order_trans) show ?thesis .
 qed
 
-lemma order_subst2: "(a::'a::order) <= b ==> f b <= (c::'c::order) ==>
-  (!!x y. x <= y ==> f x <= f y) ==> f a <= c"
+lemma order_subst2: "(a::'a::order) <= b \<Longrightarrow> f b <= (c::'c::order) \<Longrightarrow>
+  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> f a <= c"
 proof -
-  assume r: "!!x y. x <= y ==> f x <= f y"
+  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
   assume "a <= b" hence "f a <= f b" by (rule r)
   also assume "f b <= c"
   finally (order_trans) show ?thesis .
 qed
 
-lemma ord_le_eq_subst: "a <= b ==> f b = c ==>
-  (!!x y. x <= y ==> f x <= f y) ==> f a <= c"
+lemma ord_le_eq_subst: "a <= b \<Longrightarrow> f b = c \<Longrightarrow>
+  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> f a <= c"
 proof -
-  assume r: "!!x y. x <= y ==> f x <= f y"
+  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
   assume "a <= b" hence "f a <= f b" by (rule r)
   also assume "f b = c"
   finally (ord_le_eq_trans) show ?thesis .
 qed
 
-lemma ord_eq_le_subst: "a = f b ==> b <= c ==>
-  (!!x y. x <= y ==> f x <= f y) ==> a <= f c"
+lemma ord_eq_le_subst: "a = f b \<Longrightarrow> b <= c \<Longrightarrow>
+  (!!x y. x <= y \<Longrightarrow> f x <= f y) \<Longrightarrow> a <= f c"
 proof -
-  assume r: "!!x y. x <= y ==> f x <= f y"
+  assume r: "!!x y. x <= y \<Longrightarrow> f x <= f y"
   assume "a = f b"
   also assume "b <= c" hence "f b <= f c" by (rule r)
   finally (ord_eq_le_trans) show ?thesis .
 qed
 
-lemma ord_less_eq_subst: "a < b ==> f b = c ==>
-  (!!x y. x < y ==> f x < f y) ==> f a < c"
+lemma ord_less_eq_subst: "a < b \<Longrightarrow> f b = c \<Longrightarrow>
+  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> f a < c"
 proof -
-  assume r: "!!x y. x < y ==> f x < f y"
+  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
   assume "a < b" hence "f a < f b" by (rule r)
   also assume "f b = c"
   finally (ord_less_eq_trans) show ?thesis .
 qed
 
-lemma ord_eq_less_subst: "a = f b ==> b < c ==>
-  (!!x y. x < y ==> f x < f y) ==> a < f c"
+lemma ord_eq_less_subst: "a = f b \<Longrightarrow> b < c \<Longrightarrow>
+  (!!x y. x < y \<Longrightarrow> f x < f y) \<Longrightarrow> a < f c"
 proof -
-  assume r: "!!x y. x < y ==> f x < f y"
+  assume r: "!!x y. x < y \<Longrightarrow> f x < f y"
   assume "a = f b"
   also assume "b < c" hence "f b < f c" by (rule r)
   finally (ord_eq_less_trans) show ?thesis .
 qed
 
 text \<open>
   Note that this list of rules is in reverse order of priorities.
 \<close>
 
 lemmas [trans] =
   order_less_subst2
   order_less_subst1
   order_le_less_subst2
   order_le_less_subst1
   order_less_le_subst2
   order_less_le_subst1
   order_subst2
   order_subst1
   ord_le_eq_subst
   ord_eq_le_subst
   ord_less_eq_subst
   ord_eq_less_subst
   forw_subst
   back_subst
   rev_mp
   mp
 
 lemmas (in order) [trans] =
   neq_le_trans
   le_neq_trans
 
 lemmas (in preorder) [trans] =
   less_trans
   less_asym'
   le_less_trans
   less_le_trans
   order_trans
 
 lemmas (in order) [trans] =
   order.antisym
 
 lemmas (in ord) [trans] =
   ord_le_eq_trans
   ord_eq_le_trans
   ord_less_eq_trans
   ord_eq_less_trans
 
 lemmas [trans] =
   trans
 
 lemmas order_trans_rules =
   order_less_subst2
   order_less_subst1
   order_le_less_subst2
   order_le_less_subst1
   order_less_le_subst2
   order_less_le_subst1
   order_subst2
   order_subst1
   ord_le_eq_subst
   ord_eq_le_subst
   ord_less_eq_subst
   ord_eq_less_subst
   forw_subst
   back_subst
   rev_mp
   mp
   neq_le_trans
   le_neq_trans
   less_trans
   less_asym'
   le_less_trans
   less_le_trans
   order_trans
   order.antisym
   ord_le_eq_trans
   ord_eq_le_trans
   ord_less_eq_trans
   ord_eq_less_trans
   trans
 
 text \<open>These support proving chains of decreasing inequalities
-    a >= b >= c ... in Isar proofs.\<close>
+    a \<ge> b \<ge> c ... in Isar proofs.\<close>
 
 lemma xt1 [no_atp]:
   "a = b \<Longrightarrow> b > c \<Longrightarrow> a > c"
   "a > b \<Longrightarrow> b = c \<Longrightarrow> a > c"
   "a = b \<Longrightarrow> b \<ge> c \<Longrightarrow> a \<ge> c"
   "a \<ge> b \<Longrightarrow> b = c \<Longrightarrow> a \<ge> c"
   "(x::'a::order) \<ge> y \<Longrightarrow> y \<ge> x \<Longrightarrow> x = y"
   "(x::'a::order) \<ge> y \<Longrightarrow> y \<ge> z \<Longrightarrow> x \<ge> z"
   "(x::'a::order) > y \<Longrightarrow> y \<ge> z \<Longrightarrow> x > z"
   "(x::'a::order) \<ge> y \<Longrightarrow> y > z \<Longrightarrow> x > z"
   "(a::'a::order) > b \<Longrightarrow> b > a \<Longrightarrow> P"
   "(x::'a::order) > y \<Longrightarrow> y > z \<Longrightarrow> x > z"
   "(a::'a::order) \<ge> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> a > b"
   "(a::'a::order) \<noteq> b \<Longrightarrow> a \<ge> b \<Longrightarrow> a > b"
   "a = f b \<Longrightarrow> b > c \<Longrightarrow> (\<And>x y. x > y \<Longrightarrow> f x > f y) \<Longrightarrow> a > f c"
   "a > b \<Longrightarrow> f b = c \<Longrightarrow> (\<And>x y. x > y \<Longrightarrow> f x > f y) \<Longrightarrow> f a > c"
   "a = f b \<Longrightarrow> b \<ge> c \<Longrightarrow> (\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> a \<ge> f c"
   "a \<ge> b \<Longrightarrow> f b = c \<Longrightarrow> (\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> f a \<ge> c"
   by auto
 
 lemma xt2 [no_atp]:
-  "(a::'a::order) >= f b ==> b >= c ==> (!!x y. x >= y ==> f x >= f y) ==> a >= f c"
-by (subgoal_tac "f b >= f c", force, force)
-
-lemma xt3 [no_atp]: "(a::'a::order) >= b ==> (f b::'b::order) >= c ==>
-    (!!x y. x >= y ==> f x >= f y) ==> f a >= c"
-by (subgoal_tac "f a >= f b", force, force)
-
-lemma xt4 [no_atp]: "(a::'a::order) > f b ==> (b::'b::order) >= c ==>
-  (!!x y. x >= y ==> f x >= f y) ==> a > f c"
-by (subgoal_tac "f b >= f c", force, force)
-
-lemma xt5 [no_atp]: "(a::'a::order) > b ==> (f b::'b::order) >= c==>
-    (!!x y. x > y ==> f x > f y) ==> f a > c"
-by (subgoal_tac "f a > f b", force, force)
+  assumes "(a::'a::order) \<ge> f b"
+    and "b \<ge> c"
+    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
+  shows  "a \<ge> f c"
+  using assms by force
 
-lemma xt6 [no_atp]: "(a::'a::order) >= f b ==> b > c ==>
-    (!!x y. x > y ==> f x > f y) ==> a > f c"
-by (subgoal_tac "f b > f c", force, force)
+lemma xt3 [no_atp]:
+ assumes "(a::'a::order) \<ge> b"
+    and "(f b::'b::order) \<ge> c"
+    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
+  shows  "f a \<ge> c"
+  using assms by force
 
-lemma xt7 [no_atp]: "(a::'a::order) >= b ==> (f b::'b::order) > c ==>
-    (!!x y. x >= y ==> f x >= f y) ==> f a > c"
-by (subgoal_tac "f a >= f b", force, force)
+lemma xt4 [no_atp]:
+ assumes "(a::'a::order) > f b"
+    and "(b::'b::order) \<ge> c"
+    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
+  shows  "a > f c"
+  using assms by force
 
-lemma xt8 [no_atp]: "(a::'a::order) > f b ==> (b::'b::order) > c ==>
-    (!!x y. x > y ==> f x > f y) ==> a > f c"
-by (subgoal_tac "f b > f c", force, force)
+lemma xt5 [no_atp]:
+ assumes "(a::'a::order) > b"
+    and "(f b::'b::order) \<ge> c"
+    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
+  shows  "f a > c"
+  using assms by force
 
-lemma xt9 [no_atp]: "(a::'a::order) > b ==> (f b::'b::order) > c ==>
-    (!!x y. x > y ==> f x > f y) ==> f a > c"
-by (subgoal_tac "f a > f b", force, force)
+lemma xt6 [no_atp]:
+ assumes "(a::'a::order) \<ge> f b" 
+    and "b > c"
+    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
+  shows  "a > f c"
+  using assms by force
+
+lemma xt7 [no_atp]:
+ assumes "(a::'a::order) \<ge> b"
+    and "(f b::'b::order) > c"
+    and "\<And>x y. x \<ge> y \<Longrightarrow> f x \<ge> f y"
+  shows  "f a > c"
+  using assms by force
+
+lemma xt8 [no_atp]:
+ assumes "(a::'a::order) > f b"
+    and "(b::'b::order) > c"
+    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
+  shows  "a > f c"
+  using assms by force
+
+lemma xt9 [no_atp]:
+ assumes "(a::'a::order) > b"
+    and "(f b::'b::order) > c"
+    and "\<And>x y. x > y \<Longrightarrow> f x > f y"
+  shows  "f a > c"
+  using assms by force
 
 lemmas xtrans = xt1 xt2 xt3 xt4 xt5 xt6 xt7 xt8 xt9
 
 (*
-  Since "a >= b" abbreviates "b <= a", the abbreviation "..." stands
+  Since "a \<ge> b" abbreviates "b \<le> a", the abbreviation "..." stands
   for the wrong thing in an Isar proof.
 
   The extra transitivity rules can be used as follows:
 
 lemma "(a::'a::order) > z"
 proof -
-  have "a >= b" (is "_ >= ?rhs")
+  have "a \<ge> b" (is "_ \<ge> ?rhs")
     sorry
-  also have "?rhs >= c" (is "_ >= ?rhs")
+  also have "?rhs \<ge> c" (is "_ \<ge> ?rhs")
     sorry
   also (xtrans) have "?rhs = d" (is "_ = ?rhs")
     sorry
-  also (xtrans) have "?rhs >= e" (is "_ >= ?rhs")
+  also (xtrans) have "?rhs \<ge> e" (is "_ \<ge> ?rhs")
     sorry
   also (xtrans) have "?rhs > f" (is "_ > ?rhs")
     sorry
   also (xtrans) have "?rhs > z"
     sorry
   finally (xtrans) show ?thesis .
 qed
 
   Alternatively, one can use "declare xtrans [trans]" and then
   leave out the "(xtrans)" above.
 *)
 
 
 subsection \<open>Monotonicity\<close>
 
 context order
 begin
 
 definition mono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
   "mono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y)"
 
 lemma monoI [intro?]:
   fixes f :: "'a \<Rightarrow> 'b::order"
   shows "(\<And>x y. x \<le> y \<Longrightarrow> f x \<le> f y) \<Longrightarrow> mono f"
   unfolding mono_def by iprover
 
 lemma monoD [dest?]:
   fixes f :: "'a \<Rightarrow> 'b::order"
   shows "mono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
   unfolding mono_def by iprover
 
 lemma monoE:
   fixes f :: "'a \<Rightarrow> 'b::order"
   assumes "mono f"
   assumes "x \<le> y"
   obtains "f x \<le> f y"
 proof
   from assms show "f x \<le> f y" by (simp add: mono_def)
 qed
 
 definition antimono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
   "antimono f \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> f x \<ge> f y)"
 
 lemma antimonoI [intro?]:
   fixes f :: "'a \<Rightarrow> 'b::order"
   shows "(\<And>x y. x \<le> y \<Longrightarrow> f x \<ge> f y) \<Longrightarrow> antimono f"
   unfolding antimono_def by iprover
 
 lemma antimonoD [dest?]:
   fixes f :: "'a \<Rightarrow> 'b::order"
   shows "antimono f \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
   unfolding antimono_def by iprover
 
 lemma antimonoE:
   fixes f :: "'a \<Rightarrow> 'b::order"
   assumes "antimono f"
   assumes "x \<le> y"
   obtains "f x \<ge> f y"
 proof
   from assms show "f x \<ge> f y" by (simp add: antimono_def)
 qed
 
 definition strict_mono :: "('a \<Rightarrow> 'b::order) \<Rightarrow> bool" where
   "strict_mono f \<longleftrightarrow> (\<forall>x y. x < y \<longrightarrow> f x < f y)"
 
 lemma strict_monoI [intro?]:
   assumes "\<And>x y. x < y \<Longrightarrow> f x < f y"
   shows "strict_mono f"
   using assms unfolding strict_mono_def by auto
 
 lemma strict_monoD [dest?]:
   "strict_mono f \<Longrightarrow> x < y \<Longrightarrow> f x < f y"
   unfolding strict_mono_def by auto
 
 lemma strict_mono_mono [dest?]:
   assumes "strict_mono f"
   shows "mono f"
 proof (rule monoI)
   fix x y
   assume "x \<le> y"
   show "f x \<le> f y"
   proof (cases "x = y")
     case True then show ?thesis by simp
   next
     case False with \<open>x \<le> y\<close> have "x < y" by simp
     with assms strict_monoD have "f x < f y" by auto
     then show ?thesis by simp
 
   qed
 qed
 
 end
 
 context linorder
 begin
 
 lemma mono_invE:
   fixes f :: "'a \<Rightarrow> 'b::order"
   assumes "mono f"
   assumes "f x < f y"
   obtains "x \<le> y"
 proof
   show "x \<le> y"
   proof (rule ccontr)
     assume "\<not> x \<le> y"
     then have "y \<le> x" by simp
     with \<open>mono f\<close> obtain "f y \<le> f x" by (rule monoE)
     with \<open>f x < f y\<close> show False by simp
   qed
 qed
 
 lemma mono_strict_invE:
   fixes f :: "'a \<Rightarrow> 'b::order"
   assumes "mono f"
   assumes "f x < f y"
   obtains "x < y"
 proof
   show "x < y"
   proof (rule ccontr)
     assume "\<not> x < y"
     then have "y \<le> x" by simp
     with \<open>mono f\<close> obtain "f y \<le> f x" by (rule monoE)
     with \<open>f x < f y\<close> show False by simp
   qed
 qed
 
 lemma strict_mono_eq:
   assumes "strict_mono f"
   shows "f x = f y \<longleftrightarrow> x = y"
 proof
   assume "f x = f y"
   show "x = y" proof (cases x y rule: linorder_cases)
     case less with assms strict_monoD have "f x < f y" by auto
     with \<open>f x = f y\<close> show ?thesis by simp
   next
     case equal then show ?thesis .
   next
     case greater with assms strict_monoD have "f y < f x" by auto
     with \<open>f x = f y\<close> show ?thesis by simp
   qed
 qed simp
 
 lemma strict_mono_less_eq:
   assumes "strict_mono f"
   shows "f x \<le> f y \<longleftrightarrow> x \<le> y"
 proof
   assume "x \<le> y"
   with assms strict_mono_mono monoD show "f x \<le> f y" by auto
 next
   assume "f x \<le> f y"
   show "x \<le> y" proof (rule ccontr)
     assume "\<not> x \<le> y" then have "y < x" by simp
     with assms strict_monoD have "f y < f x" by auto
     with \<open>f x \<le> f y\<close> show False by simp
   qed
 qed
 
 lemma strict_mono_less:
   assumes "strict_mono f"
   shows "f x < f y \<longleftrightarrow> x < y"
   using assms
     by (auto simp add: less_le Orderings.less_le strict_mono_eq strict_mono_less_eq)
 
 end
 
 
 subsection \<open>min and max -- fundamental\<close>
 
 definition (in ord) min :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "min a b = (if a \<le> b then a else b)"
 
 definition (in ord) max :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
   "max a b = (if a \<le> b then b else a)"
 
 lemma min_absorb1: "x \<le> y \<Longrightarrow> min x y = x"
   by (simp add: min_def)
 
 lemma max_absorb2: "x \<le> y \<Longrightarrow> max x y = y"
   by (simp add: max_def)
 
 lemma min_absorb2: "(y::'a::order) \<le> x \<Longrightarrow> min x y = y"
   by (simp add:min_def)
 
 lemma max_absorb1: "(y::'a::order) \<le> x \<Longrightarrow> max x y = x"
   by (simp add: max_def)
 
 lemma max_min_same [simp]:
   fixes x y :: "'a :: linorder"
   shows "max x (min x y) = x" "max (min x y) x = x" "max (min x y) y = y" "max y (min x y) = y"
 by(auto simp add: max_def min_def)
 
 
 subsection \<open>(Unique) top and bottom elements\<close>
 
 class bot =
   fixes bot :: 'a ("\<bottom>")
 
 class order_bot = order + bot +
   assumes bot_least: "\<bottom> \<le> a"
 begin
 
 sublocale bot: ordering_top greater_eq greater bot
   by standard (fact bot_least)
 
 lemma le_bot:
   "a \<le> \<bottom> \<Longrightarrow> a = \<bottom>"
   by (fact bot.extremum_uniqueI)
 
 lemma bot_unique:
   "a \<le> \<bottom> \<longleftrightarrow> a = \<bottom>"
   by (fact bot.extremum_unique)
 
 lemma not_less_bot:
   "\<not> a < \<bottom>"
   by (fact bot.extremum_strict)
 
 lemma bot_less:
   "a \<noteq> \<bottom> \<longleftrightarrow> \<bottom> < a"
   by (fact bot.not_eq_extremum)
 
 lemma max_bot[simp]: "max bot x = x"
 by(simp add: max_def bot_unique)
 
 lemma max_bot2[simp]: "max x bot = x"
 by(simp add: max_def bot_unique)
 
 lemma min_bot[simp]: "min bot x = bot"
 by(simp add: min_def bot_unique)
 
 lemma min_bot2[simp]: "min x bot = bot"
 by(simp add: min_def bot_unique)
 
 end
 
 class top =
   fixes top :: 'a ("\<top>")
 
 class order_top = order + top +
   assumes top_greatest: "a \<le> \<top>"
 begin
 
 sublocale top: ordering_top less_eq less top
   by standard (fact top_greatest)
 
 lemma top_le:
   "\<top> \<le> a \<Longrightarrow> a = \<top>"
   by (fact top.extremum_uniqueI)
 
 lemma top_unique:
   "\<top> \<le> a \<longleftrightarrow> a = \<top>"
   by (fact top.extremum_unique)
 
 lemma not_top_less:
   "\<not> \<top> < a"
   by (fact top.extremum_strict)
 
 lemma less_top:
   "a \<noteq> \<top> \<longleftrightarrow> a < \<top>"
   by (fact top.not_eq_extremum)
 
 lemma max_top[simp]: "max top x = top"
 by(simp add: max_def top_unique)
 
 lemma max_top2[simp]: "max x top = top"
 by(simp add: max_def top_unique)
 
 lemma min_top[simp]: "min top x = x"
 by(simp add: min_def top_unique)
 
 lemma min_top2[simp]: "min x top = x"
 by(simp add: min_def top_unique)
 
 end
 
 
 subsection \<open>Dense orders\<close>
 
 class dense_order = order +
   assumes dense: "x < y \<Longrightarrow> (\<exists>z. x < z \<and> z < y)"
 
 class dense_linorder = linorder + dense_order
 begin
 
 lemma dense_le:
   fixes y z :: 'a
   assumes "\<And>x. x < y \<Longrightarrow> x \<le> z"
   shows "y \<le> z"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   hence "z < y" by simp
   from dense[OF this]
   obtain x where "x < y" and "z < x" by safe
   moreover have "x \<le> z" using assms[OF \<open>x < y\<close>] .
   ultimately show False by auto
 qed
 
 lemma dense_le_bounded:
   fixes x y z :: 'a
   assumes "x < y"
   assumes *: "\<And>w. \<lbrakk> x < w ; w < y \<rbrakk> \<Longrightarrow> w \<le> z"
   shows "y \<le> z"
 proof (rule dense_le)
   fix w assume "w < y"
   from dense[OF \<open>x < y\<close>] obtain u where "x < u" "u < y" by safe
   from linear[of u w]
   show "w \<le> z"
   proof (rule disjE)
     assume "u \<le> w"
     from less_le_trans[OF \<open>x < u\<close> \<open>u \<le> w\<close>] \<open>w < y\<close>
     show "w \<le> z" by (rule *)
   next
     assume "w \<le> u"
     from \<open>w \<le> u\<close> *[OF \<open>x < u\<close> \<open>u < y\<close>]
     show "w \<le> z" by (rule order_trans)
   qed
 qed
 
 lemma dense_ge:
   fixes y z :: 'a
   assumes "\<And>x. z < x \<Longrightarrow> y \<le> x"
   shows "y \<le> z"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   hence "z < y" by simp
   from dense[OF this]
   obtain x where "x < y" and "z < x" by safe
   moreover have "y \<le> x" using assms[OF \<open>z < x\<close>] .
   ultimately show False by auto
 qed
 
 lemma dense_ge_bounded:
   fixes x y z :: 'a
   assumes "z < x"
   assumes *: "\<And>w. \<lbrakk> z < w ; w < x \<rbrakk> \<Longrightarrow> y \<le> w"
   shows "y \<le> z"
 proof (rule dense_ge)
   fix w assume "z < w"
   from dense[OF \<open>z < x\<close>] obtain u where "z < u" "u < x" by safe
   from linear[of u w]
   show "y \<le> w"
   proof (rule disjE)
     assume "w \<le> u"
     from \<open>z < w\<close> le_less_trans[OF \<open>w \<le> u\<close> \<open>u < x\<close>]
     show "y \<le> w" by (rule *)
   next
     assume "u \<le> w"
     from *[OF \<open>z < u\<close> \<open>u < x\<close>] \<open>u \<le> w\<close>
     show "y \<le> w" by (rule order_trans)
   qed
 qed
 
 end
 
 class no_top = order +
   assumes gt_ex: "\<exists>y. x < y"
 
 class no_bot = order +
   assumes lt_ex: "\<exists>y. y < x"
 
 class unbounded_dense_linorder = dense_linorder + no_top + no_bot
 
 
 subsection \<open>Wellorders\<close>
 
 class wellorder = linorder +
   assumes less_induct [case_names less]: "(\<And>x. (\<And>y. y < x \<Longrightarrow> P y) \<Longrightarrow> P x) \<Longrightarrow> P a"
 begin
 
 lemma wellorder_Least_lemma:
   fixes k :: 'a
   assumes "P k"
   shows LeastI: "P (LEAST x. P x)" and Least_le: "(LEAST x. P x) \<le> k"
 proof -
   have "P (LEAST x. P x) \<and> (LEAST x. P x) \<le> k"
   using assms proof (induct k rule: less_induct)
     case (less x) then have "P x" by simp
     show ?case proof (rule classical)
       assume assm: "\<not> (P (LEAST a. P a) \<and> (LEAST a. P a) \<le> x)"
       have "\<And>y. P y \<Longrightarrow> x \<le> y"
       proof (rule classical)
         fix y
         assume "P y" and "\<not> x \<le> y"
         with less have "P (LEAST a. P a)" and "(LEAST a. P a) \<le> y"
           by (auto simp add: not_le)
         with assm have "x < (LEAST a. P a)" and "(LEAST a. P a) \<le> y"
           by auto
         then show "x \<le> y" by auto
       qed
       with \<open>P x\<close> have Least: "(LEAST a. P a) = x"
         by (rule Least_equality)
       with \<open>P x\<close> show ?thesis by simp
     qed
   qed
   then show "P (LEAST x. P x)" and "(LEAST x. P x) \<le> k" by auto
 qed
 
 \<comment> \<open>The following 3 lemmas are due to Brian Huffman\<close>
 lemma LeastI_ex: "\<exists>x. P x \<Longrightarrow> P (Least P)"
   by (erule exE) (erule LeastI)
 
 lemma LeastI2:
   "P a \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> Q (Least P)"
   by (blast intro: LeastI)
 
 lemma LeastI2_ex:
   "\<exists>a. P a \<Longrightarrow> (\<And>x. P x \<Longrightarrow> Q x) \<Longrightarrow> Q (Least P)"
   by (blast intro: LeastI_ex)
 
 lemma LeastI2_wellorder:
   assumes "P a"
   and "\<And>a. \<lbrakk> P a; \<forall>b. P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
   shows "Q (Least P)"
 proof (rule LeastI2_order)
   show "P (Least P)" using \<open>P a\<close> by (rule LeastI)
 next
   fix y assume "P y" thus "Least P \<le> y" by (rule Least_le)
 next
   fix x assume "P x" "\<forall>y. P y \<longrightarrow> x \<le> y" thus "Q x" by (rule assms(2))
 qed
 
 lemma LeastI2_wellorder_ex:
   assumes "\<exists>x. P x"
   and "\<And>a. \<lbrakk> P a; \<forall>b. P b \<longrightarrow> a \<le> b \<rbrakk> \<Longrightarrow> Q a"
   shows "Q (Least P)"
 using assms by clarify (blast intro!: LeastI2_wellorder)
 
 lemma not_less_Least: "k < (LEAST x. P x) \<Longrightarrow> \<not> P k"
 apply (simp add: not_le [symmetric])
 apply (erule contrapos_nn)
 apply (erule Least_le)
 done
 
 lemma exists_least_iff: "(\<exists>n. P n) \<longleftrightarrow> (\<exists>n. P n \<and> (\<forall>m < n. \<not> P m))" (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs thus ?lhs by blast
 next
   assume H: ?lhs then obtain n where n: "P n" by blast
   let ?x = "Least P"
   { fix m assume m: "m < ?x"
     from not_less_Least[OF m] have "\<not> P m" . }
   with LeastI_ex[OF H] show ?rhs by blast
 qed
 
 end
 
 
 subsection \<open>Order on \<^typ>\<open>bool\<close>\<close>
 
 instantiation bool :: "{order_bot, order_top, linorder}"
 begin
 
 definition
   le_bool_def [simp]: "P \<le> Q \<longleftrightarrow> P \<longrightarrow> Q"
 
 definition
   [simp]: "(P::bool) < Q \<longleftrightarrow> \<not> P \<and> Q"
 
 definition
   [simp]: "\<bottom> \<longleftrightarrow> False"
 
 definition
   [simp]: "\<top> \<longleftrightarrow> True"
 
 instance proof
 qed auto
 
 end
 
 lemma le_boolI: "(P \<Longrightarrow> Q) \<Longrightarrow> P \<le> Q"
   by simp
 
 lemma le_boolI': "P \<longrightarrow> Q \<Longrightarrow> P \<le> Q"
   by simp
 
 lemma le_boolE: "P \<le> Q \<Longrightarrow> P \<Longrightarrow> (Q \<Longrightarrow> R) \<Longrightarrow> R"
   by simp
 
 lemma le_boolD: "P \<le> Q \<Longrightarrow> P \<longrightarrow> Q"
   by simp
 
 lemma bot_boolE: "\<bottom> \<Longrightarrow> P"
   by simp
 
 lemma top_boolI: \<top>
   by simp
 
 lemma [code]:
   "False \<le> b \<longleftrightarrow> True"
   "True \<le> b \<longleftrightarrow> b"
   "False < b \<longleftrightarrow> b"
   "True < b \<longleftrightarrow> False"
   by simp_all
 
 
 subsection \<open>Order on \<^typ>\<open>_ \<Rightarrow> _\<close>\<close>
 
 instantiation "fun" :: (type, ord) ord
 begin
 
 definition
   le_fun_def: "f \<le> g \<longleftrightarrow> (\<forall>x. f x \<le> g x)"
 
 definition
   "(f::'a \<Rightarrow> 'b) < g \<longleftrightarrow> f \<le> g \<and> \<not> (g \<le> f)"
 
 instance ..
 
 end
 
 instance "fun" :: (type, preorder) preorder proof
 qed (auto simp add: le_fun_def less_fun_def
   intro: order_trans order.antisym)
 
 instance "fun" :: (type, order) order proof
 qed (auto simp add: le_fun_def intro: order.antisym)
 
 instantiation "fun" :: (type, bot) bot
 begin
 
 definition
   "\<bottom> = (\<lambda>x. \<bottom>)"
 
 instance ..
 
 end
 
 instantiation "fun" :: (type, order_bot) order_bot
 begin
 
 lemma bot_apply [simp, code]:
   "\<bottom> x = \<bottom>"
   by (simp add: bot_fun_def)
 
 instance proof
 qed (simp add: le_fun_def)
 
 end
 
 instantiation "fun" :: (type, top) top
 begin
 
 definition
   [no_atp]: "\<top> = (\<lambda>x. \<top>)"
 
 instance ..
 
 end
 
 instantiation "fun" :: (type, order_top) order_top
 begin
 
 lemma top_apply [simp, code]:
   "\<top> x = \<top>"
   by (simp add: top_fun_def)
 
 instance proof
 qed (simp add: le_fun_def)
 
 end
 
 lemma le_funI: "(\<And>x. f x \<le> g x) \<Longrightarrow> f \<le> g"
   unfolding le_fun_def by simp
 
 lemma le_funE: "f \<le> g \<Longrightarrow> (f x \<le> g x \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding le_fun_def by simp
 
 lemma le_funD: "f \<le> g \<Longrightarrow> f x \<le> g x"
   by (rule le_funE)
 
 lemma mono_compose: "mono Q \<Longrightarrow> mono (\<lambda>i x. Q i (f x))"
   unfolding mono_def le_fun_def by auto
 
 
 subsection \<open>Order on unary and binary predicates\<close>
 
 lemma predicate1I:
   assumes PQ: "\<And>x. P x \<Longrightarrow> Q x"
   shows "P \<le> Q"
   apply (rule le_funI)
   apply (rule le_boolI)
   apply (rule PQ)
   apply assumption
   done
 
 lemma predicate1D:
   "P \<le> Q \<Longrightarrow> P x \<Longrightarrow> Q x"
   apply (erule le_funE)
   apply (erule le_boolE)
   apply assumption+
   done
 
 lemma rev_predicate1D:
   "P x \<Longrightarrow> P \<le> Q \<Longrightarrow> Q x"
   by (rule predicate1D)
 
 lemma predicate2I:
   assumes PQ: "\<And>x y. P x y \<Longrightarrow> Q x y"
   shows "P \<le> Q"
   apply (rule le_funI)+
   apply (rule le_boolI)
   apply (rule PQ)
   apply assumption
   done
 
 lemma predicate2D:
   "P \<le> Q \<Longrightarrow> P x y \<Longrightarrow> Q x y"
   apply (erule le_funE)+
   apply (erule le_boolE)
   apply assumption+
   done
 
 lemma rev_predicate2D:
   "P x y \<Longrightarrow> P \<le> Q \<Longrightarrow> Q x y"
   by (rule predicate2D)
 
 lemma bot1E [no_atp]: "\<bottom> x \<Longrightarrow> P"
   by (simp add: bot_fun_def)
 
 lemma bot2E: "\<bottom> x y \<Longrightarrow> P"
   by (simp add: bot_fun_def)
 
 lemma top1I: "\<top> x"
   by (simp add: top_fun_def)
 
 lemma top2I: "\<top> x y"
   by (simp add: top_fun_def)
 
 
 subsection \<open>Name duplicates\<close>
 
 lemmas antisym = order.antisym
 lemmas eq_iff = order.eq_iff
 
 lemmas order_eq_refl = preorder_class.eq_refl
 lemmas order_less_irrefl = preorder_class.less_irrefl
 lemmas order_less_imp_le = preorder_class.less_imp_le
 lemmas order_less_not_sym = preorder_class.less_not_sym
 lemmas order_less_asym = preorder_class.less_asym
 lemmas order_less_trans = preorder_class.less_trans
 lemmas order_le_less_trans = preorder_class.le_less_trans
 lemmas order_less_le_trans = preorder_class.less_le_trans
 lemmas order_less_imp_not_less = preorder_class.less_imp_not_less
 lemmas order_less_imp_triv = preorder_class.less_imp_triv
 lemmas order_less_asym' = preorder_class.less_asym'
 
 lemmas order_less_le = order_class.less_le
 lemmas order_le_less = order_class.le_less
 lemmas order_le_imp_less_or_eq = order_class.le_imp_less_or_eq
 lemmas order_less_imp_not_eq = order_class.less_imp_not_eq
 lemmas order_less_imp_not_eq2 = order_class.less_imp_not_eq2
 lemmas order_neq_le_trans = order_class.neq_le_trans
 lemmas order_le_neq_trans = order_class.le_neq_trans
 lemmas order_eq_iff = order_class.order.eq_iff
 lemmas order_antisym_conv = order_class.antisym_conv
 
 lemmas linorder_linear = linorder_class.linear
 lemmas linorder_less_linear = linorder_class.less_linear
 lemmas linorder_le_less_linear = linorder_class.le_less_linear
 lemmas linorder_le_cases = linorder_class.le_cases
 lemmas linorder_not_less = linorder_class.not_less
 lemmas linorder_not_le = linorder_class.not_le
 lemmas linorder_neq_iff = linorder_class.neq_iff
 lemmas linorder_neqE = linorder_class.neqE
 
 end
diff --git a/src/HOL/Partial_Function.thy b/src/HOL/Partial_Function.thy
--- a/src/HOL/Partial_Function.thy
+++ b/src/HOL/Partial_Function.thy
@@ -1,459 +1,466 @@
 (* Title:    HOL/Partial_Function.thy
    Author:   Alexander Krauss, TU Muenchen
 *)
 
 section \<open>Partial Function Definitions\<close>
 
 theory Partial_Function
   imports Complete_Partial_Order Option
   keywords "partial_function" :: thy_defn
 begin
 
 named_theorems partial_function_mono "monotonicity rules for partial function definitions"
 ML_file \<open>Tools/Function/partial_function.ML\<close>
 
 lemma (in ccpo) in_chain_finite:
   assumes "Complete_Partial_Order.chain (\<le>) A" "finite A" "A \<noteq> {}"
   shows "\<Squnion>A \<in> A"
 using assms(2,1,3)
 proof induction
   case empty thus ?case by simp
 next
   case (insert x A)
   note chain = \<open>Complete_Partial_Order.chain (\<le>) (insert x A)\<close>
   show ?case
   proof(cases "A = {}")
     case True thus ?thesis by simp
   next
     case False
     from chain have chain': "Complete_Partial_Order.chain (\<le>) A"
       by(rule chain_subset) blast
     hence "\<Squnion>A \<in> A" using False by(rule insert.IH)
     show ?thesis
     proof(cases "x \<le> \<Squnion>A")
       case True
       have "\<Squnion>(insert x A) \<le> \<Squnion>A" using chain
         by(rule ccpo_Sup_least)(auto simp add: True intro: ccpo_Sup_upper[OF chain'])
       hence "\<Squnion>(insert x A) = \<Squnion>A"
         by(rule order.antisym)(blast intro: ccpo_Sup_upper[OF chain] ccpo_Sup_least[OF chain'])
       with \<open>\<Squnion>A \<in> A\<close> show ?thesis by simp
     next
       case False
       with chainD[OF chain, of x "\<Squnion>A"] \<open>\<Squnion>A \<in> A\<close>
       have "\<Squnion>(insert x A) = x"
         by(auto intro: order.antisym ccpo_Sup_least[OF chain] order_trans[OF ccpo_Sup_upper[OF chain']] ccpo_Sup_upper[OF chain])
       thus ?thesis by simp
     qed
   qed
 qed
 
 lemma (in ccpo) admissible_chfin:
   "(\<forall>S. Complete_Partial_Order.chain (\<le>) S \<longrightarrow> finite S)
   \<Longrightarrow> ccpo.admissible Sup (\<le>) P"
 using in_chain_finite by (blast intro: ccpo.admissibleI)
 
 subsection \<open>Axiomatic setup\<close>
 
 text \<open>This techical locale constains the requirements for function
   definitions with ccpo fixed points.\<close>
 
 definition "fun_ord ord f g \<longleftrightarrow> (\<forall>x. ord (f x) (g x))"
 definition "fun_lub L A = (\<lambda>x. L {y. \<exists>f\<in>A. y = f x})"
 definition "img_ord f ord = (\<lambda>x y. ord (f x) (f y))"
 definition "img_lub f g Lub = (\<lambda>A. g (Lub (f ` A)))"
 
 lemma chain_fun: 
   assumes A: "chain (fun_ord ord) A"
   shows "chain ord {y. \<exists>f\<in>A. y = f a}" (is "chain ord ?C")
 proof (rule chainI)
   fix x y assume "x \<in> ?C" "y \<in> ?C"
   then obtain f g where fg: "f \<in> A" "g \<in> A" 
     and [simp]: "x = f a" "y = g a" by blast
   from chainD[OF A fg]
   show "ord x y \<or> ord y x" unfolding fun_ord_def by auto
 qed
 
 lemma call_mono[partial_function_mono]: "monotone (fun_ord ord) ord (\<lambda>f. f t)"
 by (rule monotoneI) (auto simp: fun_ord_def)
 
 lemma let_mono[partial_function_mono]:
   "(\<And>x. monotone orda ordb (\<lambda>f. b f x))
   \<Longrightarrow> monotone orda ordb (\<lambda>f. Let t (b f))"
 by (simp add: Let_def)
 
 lemma if_mono[partial_function_mono]: "monotone orda ordb F 
 \<Longrightarrow> monotone orda ordb G
 \<Longrightarrow> monotone orda ordb (\<lambda>f. if c then F f else G f)"
 unfolding monotone_def by simp
 
 definition "mk_less R = (\<lambda>x y. R x y \<and> \<not> R y x)"
 
 locale partial_function_definitions = 
   fixes leq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   fixes lub :: "'a set \<Rightarrow> 'a"
   assumes leq_refl: "leq x x"
   assumes leq_trans: "leq x y \<Longrightarrow> leq y z \<Longrightarrow> leq x z"
   assumes leq_antisym: "leq x y \<Longrightarrow> leq y x \<Longrightarrow> x = y"
   assumes lub_upper: "chain leq A \<Longrightarrow> x \<in> A \<Longrightarrow> leq x (lub A)"
   assumes lub_least: "chain leq A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> leq x z) \<Longrightarrow> leq (lub A) z"
 
 lemma partial_function_lift:
   assumes "partial_function_definitions ord lb"
   shows "partial_function_definitions (fun_ord ord) (fun_lub lb)" (is "partial_function_definitions ?ordf ?lubf")
 proof -
   interpret partial_function_definitions ord lb by fact
 
   show ?thesis
   proof
     fix x show "?ordf x x"
       unfolding fun_ord_def by (auto simp: leq_refl)
   next
     fix x y z assume "?ordf x y" "?ordf y z"
     thus "?ordf x z" unfolding fun_ord_def 
       by (force dest: leq_trans)
   next
     fix x y assume "?ordf x y" "?ordf y x"
     thus "x = y" unfolding fun_ord_def
       by (force intro!: dest: leq_antisym)
   next
     fix A f assume f: "f \<in> A" and A: "chain ?ordf A"
     thus "?ordf f (?lubf A)"
       unfolding fun_lub_def fun_ord_def
       by (blast intro: lub_upper chain_fun[OF A] f)
   next
     fix A :: "('b \<Rightarrow> 'a) set" and g :: "'b \<Rightarrow> 'a"
     assume A: "chain ?ordf A" and g: "\<And>f. f \<in> A \<Longrightarrow> ?ordf f g"
     show "?ordf (?lubf A) g" unfolding fun_lub_def fun_ord_def
       by (blast intro: lub_least chain_fun[OF A] dest: g[unfolded fun_ord_def])
    qed
 qed
 
 lemma ccpo: assumes "partial_function_definitions ord lb"
   shows "class.ccpo lb ord (mk_less ord)"
 using assms unfolding partial_function_definitions_def mk_less_def
 by unfold_locales blast+
 
 lemma partial_function_image:
   assumes "partial_function_definitions ord Lub"
   assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
   assumes inv: "\<And>x. f (g x) = x"
   shows "partial_function_definitions (img_ord f ord) (img_lub f g Lub)"
 proof -
   let ?iord = "img_ord f ord"
   let ?ilub = "img_lub f g Lub"
 
   interpret partial_function_definitions ord Lub by fact
   show ?thesis
   proof
     fix A x assume "chain ?iord A" "x \<in> A"
     then have "chain ord (f ` A)" "f x \<in> f ` A"
       by (auto simp: img_ord_def intro: chainI dest: chainD)
     thus "?iord x (?ilub A)"
       unfolding inv img_lub_def img_ord_def by (rule lub_upper)
   next
     fix A x assume "chain ?iord A"
       and 1: "\<And>z. z \<in> A \<Longrightarrow> ?iord z x"
     then have "chain ord (f ` A)"
       by (auto simp: img_ord_def intro: chainI dest: chainD)
     thus "?iord (?ilub A) x"
       unfolding inv img_lub_def img_ord_def
       by (rule lub_least) (auto dest: 1[unfolded img_ord_def])
   qed (auto simp: img_ord_def intro: leq_refl dest: leq_trans leq_antisym inj)
 qed
 
 context partial_function_definitions
 begin
 
 abbreviation "le_fun \<equiv> fun_ord leq"
 abbreviation "lub_fun \<equiv> fun_lub lub"
 abbreviation "fixp_fun \<equiv> ccpo.fixp lub_fun le_fun"
 abbreviation "mono_body \<equiv> monotone le_fun leq"
 abbreviation "admissible \<equiv> ccpo.admissible lub_fun le_fun"
 
 text \<open>Interpret manually, to avoid flooding everything with facts about
   orders\<close>
 
 lemma ccpo: "class.ccpo lub_fun le_fun (mk_less le_fun)"
 apply (rule ccpo)
 apply (rule partial_function_lift)
 apply (rule partial_function_definitions_axioms)
 done
 
 text \<open>The crucial fixed-point theorem\<close>
 
 lemma mono_body_fixp: 
   "(\<And>x. mono_body (\<lambda>f. F f x)) \<Longrightarrow> fixp_fun F = F (fixp_fun F)"
 by (rule ccpo.fixp_unfold[OF ccpo]) (auto simp: monotone_def fun_ord_def)
 
 text \<open>Version with curry/uncurry combinators, to be used by package\<close>
 
 lemma fixp_rule_uc:
   fixes F :: "'c \<Rightarrow> 'c" and
     U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a" and
     C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c"
   assumes mono: "\<And>x. mono_body (\<lambda>f. U (F (C f)) x)"
   assumes eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
   assumes inverse: "\<And>f. C (U f) = f"
   shows "f = F f"
 proof -
   have "f = C (fixp_fun (\<lambda>f. U (F (C f))))" by (simp add: eq)
   also have "... = C (U (F (C (fixp_fun (\<lambda>f. U (F (C f)))))))"
     by (subst mono_body_fixp[of "%f. U (F (C f))", OF mono]) (rule refl)
   also have "... = F (C (fixp_fun (\<lambda>f. U (F (C f)))))" by (rule inverse)
   also have "... = F f" by (simp add: eq)
   finally show "f = F f" .
 qed
 
 text \<open>Fixpoint induction rule\<close>
 
 lemma fixp_induct_uc:
   fixes F :: "'c \<Rightarrow> 'c"
     and U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a"
     and C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c"
     and P :: "('b \<Rightarrow> 'a) \<Rightarrow> bool"
   assumes mono: "\<And>x. mono_body (\<lambda>f. U (F (C f)) x)"
     and eq: "f \<equiv> C (fixp_fun (\<lambda>f. U (F (C f))))"
     and inverse: "\<And>f. U (C f) = f"
     and adm: "ccpo.admissible lub_fun le_fun P"
     and bot: "P (\<lambda>_. lub {})"
     and step: "\<And>f. P (U f) \<Longrightarrow> P (U (F f))"
   shows "P (U f)"
 unfolding eq inverse
-apply (rule ccpo.fixp_induct[OF ccpo adm])
-apply (insert mono, auto simp: monotone_def fun_ord_def bot fun_lub_def)[2]
-apply (rule_tac f5="C x" in step)
-apply (simp add: inverse)
-done
+proof (rule ccpo.fixp_induct[OF ccpo adm])
+  show "monotone le_fun le_fun (\<lambda>f. U (F (C f)))"
+    using mono by (auto simp: monotone_def fun_ord_def)
+next
+  show "P (lub_fun {})"
+    by (auto simp: bot fun_lub_def)
+next
+  fix x
+  assume "P x"
+  then show "P (U (F (C x)))"
+    using step[of "C x"] by (simp add: inverse)
+qed
 
 
 text \<open>Rules for \<^term>\<open>mono_body\<close>:\<close>
 
 lemma const_mono[partial_function_mono]: "monotone ord leq (\<lambda>f. c)"
 by (rule monotoneI) (rule leq_refl)
 
 end
 
 
 subsection \<open>Flat interpretation: tailrec and option\<close>
 
 definition 
   "flat_ord b x y \<longleftrightarrow> x = b \<or> x = y"
 
 definition 
   "flat_lub b A = (if A \<subseteq> {b} then b else (THE x. x \<in> A - {b}))"
 
 lemma flat_interpretation:
   "partial_function_definitions (flat_ord b) (flat_lub b)"
 proof
   fix A x assume 1: "chain (flat_ord b) A" "x \<in> A"
   show "flat_ord b x (flat_lub b A)"
   proof cases
     assume "x = b"
     thus ?thesis by (simp add: flat_ord_def)
   next
     assume "x \<noteq> b"
     with 1 have "A - {b} = {x}"
       by (auto elim: chainE simp: flat_ord_def)
     then have "flat_lub b A = x"
       by (auto simp: flat_lub_def)
     thus ?thesis by (auto simp: flat_ord_def)
   qed
 next
   fix A z assume A: "chain (flat_ord b) A"
     and z: "\<And>x. x \<in> A \<Longrightarrow> flat_ord b x z"
   show "flat_ord b (flat_lub b A) z"
   proof cases
     assume "A \<subseteq> {b}"
     thus ?thesis
       by (auto simp: flat_lub_def flat_ord_def)
   next
     assume nb: "\<not> A \<subseteq> {b}"
     then obtain y where y: "y \<in> A" "y \<noteq> b" by auto
     with A have "A - {b} = {y}"
       by (auto elim: chainE simp: flat_ord_def)
     with nb have "flat_lub b A = y"
       by (auto simp: flat_lub_def)
     with z y show ?thesis by auto    
   qed
 qed (auto simp: flat_ord_def)
 
 lemma flat_ordI: "(x \<noteq> a \<Longrightarrow> x = y) \<Longrightarrow> flat_ord a x y"
 by(auto simp add: flat_ord_def)
 
 lemma flat_ord_antisym: "\<lbrakk> flat_ord a x y; flat_ord a y x \<rbrakk> \<Longrightarrow> x = y"
 by(auto simp add: flat_ord_def)
 
 lemma antisymp_flat_ord: "antisymp (flat_ord a)"
 by(rule antisympI)(auto dest: flat_ord_antisym)
 
 interpretation tailrec:
   partial_function_definitions "flat_ord undefined" "flat_lub undefined"
   rewrites "flat_lub undefined {} \<equiv> undefined"
 by (rule flat_interpretation)(simp add: flat_lub_def)
 
 interpretation option:
   partial_function_definitions "flat_ord None" "flat_lub None"
   rewrites "flat_lub None {} \<equiv> None"
 by (rule flat_interpretation)(simp add: flat_lub_def)
 
 
 abbreviation "tailrec_ord \<equiv> flat_ord undefined"
 abbreviation "mono_tailrec \<equiv> monotone (fun_ord tailrec_ord) tailrec_ord"
 
 lemma tailrec_admissible:
   "ccpo.admissible (fun_lub (flat_lub c)) (fun_ord (flat_ord c))
      (\<lambda>a. \<forall>x. a x \<noteq> c \<longrightarrow> P x (a x))"
 proof(intro ccpo.admissibleI strip)
   fix A x
   assume chain: "Complete_Partial_Order.chain (fun_ord (flat_ord c)) A"
     and P [rule_format]: "\<forall>f\<in>A. \<forall>x. f x \<noteq> c \<longrightarrow> P x (f x)"
     and defined: "fun_lub (flat_lub c) A x \<noteq> c"
   from defined obtain f where f: "f \<in> A" "f x \<noteq> c"
     by(auto simp add: fun_lub_def flat_lub_def split: if_split_asm)
   hence "P x (f x)" by(rule P)
   moreover from chain f have "\<forall>f' \<in> A. f' x = c \<or> f' x = f x"
     by(auto 4 4 simp add: Complete_Partial_Order.chain_def flat_ord_def fun_ord_def)
   hence "fun_lub (flat_lub c) A x = f x"
     using f by(auto simp add: fun_lub_def flat_lub_def)
   ultimately show "P x (fun_lub (flat_lub c) A x)" by simp
 qed
 
 lemma fixp_induct_tailrec:
   fixes F :: "'c \<Rightarrow> 'c" and
     U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a" and
     C :: "('b \<Rightarrow> 'a) \<Rightarrow> 'c" and
     P :: "'b \<Rightarrow> 'a \<Rightarrow> bool" and
     x :: "'b"
   assumes mono: "\<And>x. monotone (fun_ord (flat_ord c)) (flat_ord c) (\<lambda>f. U (F (C f)) x)"
   assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub (flat_lub c)) (fun_ord (flat_ord c)) (\<lambda>f. U (F (C f))))"
   assumes inverse2: "\<And>f. U (C f) = f"
   assumes step: "\<And>f x y. (\<And>x y. U f x = y \<Longrightarrow> y \<noteq> c \<Longrightarrow> P x y) \<Longrightarrow> U (F f) x = y \<Longrightarrow> y \<noteq> c \<Longrightarrow> P x y"
   assumes result: "U f x = y"
   assumes defined: "y \<noteq> c"
   shows "P x y"
 proof -
   have "\<forall>x y. U f x = y \<longrightarrow> y \<noteq> c \<longrightarrow> P x y"
     by(rule partial_function_definitions.fixp_induct_uc[OF flat_interpretation, of _ U F C, OF mono eq inverse2])
       (auto intro: step tailrec_admissible simp add: fun_lub_def flat_lub_def)
   thus ?thesis using result defined by blast
 qed
 
 lemma admissible_image:
   assumes pfun: "partial_function_definitions le lub"
   assumes adm: "ccpo.admissible lub le (P \<circ> g)"
   assumes inj: "\<And>x y. f x = f y \<Longrightarrow> x = y"
   assumes inv: "\<And>x. f (g x) = x"
   shows "ccpo.admissible (img_lub f g lub) (img_ord f le) P"
 proof (rule ccpo.admissibleI)
   fix A assume "chain (img_ord f le) A"
   then have ch': "chain le (f ` A)"
     by (auto simp: img_ord_def intro: chainI dest: chainD)
   assume "A \<noteq> {}"
   assume P_A: "\<forall>x\<in>A. P x"
   have "(P \<circ> g) (lub (f ` A))" using adm ch'
   proof (rule ccpo.admissibleD)
     fix x assume "x \<in> f ` A"
     with P_A show "(P \<circ> g) x" by (auto simp: inj[OF inv])
   qed(simp add: \<open>A \<noteq> {}\<close>)
   thus "P (img_lub f g lub A)" unfolding img_lub_def by simp
 qed
 
 lemma admissible_fun:
   assumes pfun: "partial_function_definitions le lub"
   assumes adm: "\<And>x. ccpo.admissible lub le (Q x)"
   shows "ccpo.admissible  (fun_lub lub) (fun_ord le) (\<lambda>f. \<forall>x. Q x (f x))"
 proof (rule ccpo.admissibleI)
   fix A :: "('b \<Rightarrow> 'a) set"
   assume Q: "\<forall>f\<in>A. \<forall>x. Q x (f x)"
   assume ch: "chain (fun_ord le) A"
   assume "A \<noteq> {}"
   hence non_empty: "\<And>a. {y. \<exists>f\<in>A. y = f a} \<noteq> {}" by auto
   show "\<forall>x. Q x (fun_lub lub A x)"
     unfolding fun_lub_def
     by (rule allI, rule ccpo.admissibleD[OF adm chain_fun[OF ch] non_empty])
       (auto simp: Q)
 qed
 
 
 abbreviation "option_ord \<equiv> flat_ord None"
 abbreviation "mono_option \<equiv> monotone (fun_ord option_ord) option_ord"
 
 lemma bind_mono[partial_function_mono]:
 assumes mf: "mono_option B" and mg: "\<And>y. mono_option (\<lambda>f. C y f)"
 shows "mono_option (\<lambda>f. Option.bind (B f) (\<lambda>y. C y f))"
 proof (rule monotoneI)
   fix f g :: "'a \<Rightarrow> 'b option" assume fg: "fun_ord option_ord f g"
   with mf
   have "option_ord (B f) (B g)" by (rule monotoneD[of _ _ _ f g])
   then have "option_ord (Option.bind (B f) (\<lambda>y. C y f)) (Option.bind (B g) (\<lambda>y. C y f))"
     unfolding flat_ord_def by auto    
   also from mg
   have "\<And>y'. option_ord (C y' f) (C y' g)"
     by (rule monotoneD) (rule fg)
   then have "option_ord (Option.bind (B g) (\<lambda>y'. C y' f)) (Option.bind (B g) (\<lambda>y'. C y' g))"
     unfolding flat_ord_def by (cases "B g") auto
   finally (option.leq_trans)
   show "option_ord (Option.bind (B f) (\<lambda>y. C y f)) (Option.bind (B g) (\<lambda>y'. C y' g))" .
 qed
 
 lemma flat_lub_in_chain:
   assumes ch: "chain (flat_ord b) A "
   assumes lub: "flat_lub b A = a"
   shows "a = b \<or> a \<in> A"
 proof (cases "A \<subseteq> {b}")
   case True
   then have "flat_lub b A = b" unfolding flat_lub_def by simp
   with lub show ?thesis by simp
 next
   case False
   then obtain c where "c \<in> A" and "c \<noteq> b" by auto
   { fix z assume "z \<in> A"
     from chainD[OF ch \<open>c \<in> A\<close> this] have "z = c \<or> z = b"
       unfolding flat_ord_def using \<open>c \<noteq> b\<close> by auto }
   with False have "A - {b} = {c}" by auto
   with False have "flat_lub b A = c" by (auto simp: flat_lub_def)
   with \<open>c \<in> A\<close> lub show ?thesis by simp
 qed
 
 lemma option_admissible: "option.admissible (%(f::'a \<Rightarrow> 'b option).
   (\<forall>x y. f x = Some y \<longrightarrow> P x y))"
 proof (rule ccpo.admissibleI)
   fix A :: "('a \<Rightarrow> 'b option) set"
   assume ch: "chain option.le_fun A"
     and IH: "\<forall>f\<in>A. \<forall>x y. f x = Some y \<longrightarrow> P x y"
   from ch have ch': "\<And>x. chain option_ord {y. \<exists>f\<in>A. y = f x}" by (rule chain_fun)
   show "\<forall>x y. option.lub_fun A x = Some y \<longrightarrow> P x y"
   proof (intro allI impI)
     fix x y assume "option.lub_fun A x = Some y"
     from flat_lub_in_chain[OF ch' this[unfolded fun_lub_def]]
     have "Some y \<in> {y. \<exists>f\<in>A. y = f x}" by simp
     then have "\<exists>f\<in>A. f x = Some y" by auto
     with IH show "P x y" by auto
   qed
 qed
 
 lemma fixp_induct_option:
   fixes F :: "'c \<Rightarrow> 'c" and
     U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a option" and
     C :: "('b \<Rightarrow> 'a option) \<Rightarrow> 'c" and
     P :: "'b \<Rightarrow> 'a \<Rightarrow> bool"
   assumes mono: "\<And>x. mono_option (\<lambda>f. U (F (C f)) x)"
   assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub (flat_lub None)) (fun_ord option_ord) (\<lambda>f. U (F (C f))))"
   assumes inverse2: "\<And>f. U (C f) = f"
   assumes step: "\<And>f x y. (\<And>x y. U f x = Some y \<Longrightarrow> P x y) \<Longrightarrow> U (F f) x = Some y \<Longrightarrow> P x y"
   assumes defined: "U f x = Some y"
   shows "P x y"
   using step defined option.fixp_induct_uc[of U F C, OF mono eq inverse2 option_admissible]
   unfolding fun_lub_def flat_lub_def by(auto 9 2)
 
 declaration \<open>Partial_Function.init "tailrec" \<^term>\<open>tailrec.fixp_fun\<close>
   \<^term>\<open>tailrec.mono_body\<close> @{thm tailrec.fixp_rule_uc} @{thm tailrec.fixp_induct_uc}
   (SOME @{thm fixp_induct_tailrec[where c = undefined]})\<close>
 
 declaration \<open>Partial_Function.init "option" \<^term>\<open>option.fixp_fun\<close>
   \<^term>\<open>option.mono_body\<close> @{thm option.fixp_rule_uc} @{thm option.fixp_induct_uc}
   (SOME @{thm fixp_induct_option})\<close>
 
 hide_const (open) chain
 
 end
diff --git a/src/HOL/Power.thy b/src/HOL/Power.thy
--- a/src/HOL/Power.thy
+++ b/src/HOL/Power.thy
@@ -1,1025 +1,1016 @@
 (*  Title:      HOL/Power.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1997  University of Cambridge
 *)
 
 section \<open>Exponentiation\<close>
 
 theory Power
   imports Num
 begin
 
 subsection \<open>Powers for Arbitrary Monoids\<close>
 
 class power = one + times
 begin
 
 primrec power :: "'a \<Rightarrow> nat \<Rightarrow> 'a"  (infixr "^" 80)
   where
     power_0: "a ^ 0 = 1"
   | power_Suc: "a ^ Suc n = a * a ^ n"
 
 notation (latex output)
   power ("(_\<^bsup>_\<^esup>)" [1000] 1000)
 
 text \<open>Special syntax for squares.\<close>
 abbreviation power2 :: "'a \<Rightarrow> 'a"  ("(_\<^sup>2)" [1000] 999)
   where "x\<^sup>2 \<equiv> x ^ 2"
 
 end
 
 context
   includes lifting_syntax
 begin
 
 lemma power_transfer [transfer_rule]:
   \<open>(R ===> (=) ===> R) (^) (^)\<close>
     if [transfer_rule]: \<open>R 1 1\<close>
       \<open>(R ===> R ===> R) (*) (*)\<close>
     for R :: \<open>'a::power \<Rightarrow> 'b::power \<Rightarrow> bool\<close>
   by (simp only: power_def [abs_def]) transfer_prover
 
 end
 
 context monoid_mult
 begin
 
 subclass power .
 
 lemma power_one [simp]: "1 ^ n = 1"
   by (induct n) simp_all
 
 lemma power_one_right [simp]: "a ^ 1 = a"
   by simp
 
 lemma power_Suc0_right [simp]: "a ^ Suc 0 = a"
   by simp
 
 lemma power_commutes: "a ^ n * a = a * a ^ n"
   by (induct n) (simp_all add: mult.assoc)
 
 lemma power_Suc2: "a ^ Suc n = a ^ n * a"
   by (simp add: power_commutes)
 
 lemma power_add: "a ^ (m + n) = a ^ m * a ^ n"
   by (induct m) (simp_all add: algebra_simps)
 
 lemma power_mult: "a ^ (m * n) = (a ^ m) ^ n"
   by (induct n) (simp_all add: power_add)
 
 lemma power_even_eq: "a ^ (2 * n) = (a ^ n)\<^sup>2"
   by (subst mult.commute) (simp add: power_mult)
 
 lemma power_odd_eq: "a ^ Suc (2*n) = a * (a ^ n)\<^sup>2"
   by (simp add: power_even_eq)
 
 lemma power_numeral_even: "z ^ numeral (Num.Bit0 w) = (let w = z ^ (numeral w) in w * w)"
   by (simp only: numeral_Bit0 power_add Let_def)
 
 lemma power_numeral_odd: "z ^ numeral (Num.Bit1 w) = (let w = z ^ (numeral w) in z * w * w)"
   by (simp only: numeral_Bit1 One_nat_def add_Suc_right add_0_right
       power_Suc power_add Let_def mult.assoc)
 
 lemma power2_eq_square: "a\<^sup>2 = a * a"
   by (simp add: numeral_2_eq_2)
 
 lemma power3_eq_cube: "a ^ 3 = a * a * a"
   by (simp add: numeral_3_eq_3 mult.assoc)
 
 lemma power4_eq_xxxx: "x^4 = x * x * x * x"
   by (simp add: mult.assoc power_numeral_even)
 
 lemma funpow_times_power: "(times x ^^ f x) = times (x ^ f x)"
 proof (induct "f x" arbitrary: f)
   case 0
   then show ?case by (simp add: fun_eq_iff)
 next
   case (Suc n)
   define g where "g x = f x - 1" for x
   with Suc have "n = g x" by simp
   with Suc have "times x ^^ g x = times (x ^ g x)" by simp
   moreover from Suc g_def have "f x = g x + 1" by simp
   ultimately show ?case
     by (simp add: power_add funpow_add fun_eq_iff mult.assoc)
 qed
 
 lemma power_commuting_commutes:
   assumes "x * y = y * x"
   shows "x ^ n * y = y * x ^n"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   have "x ^ Suc n * y = x ^ n * y * x"
     by (subst power_Suc2) (simp add: assms ac_simps)
   also have "\<dots> = y * x ^ Suc n"
     by (simp only: Suc power_Suc2) (simp add: ac_simps)
   finally show ?case .
 qed
 
 lemma power_minus_mult: "0 < n \<Longrightarrow> a ^ (n - 1) * a = a ^ n"
   by (simp add: power_commutes split: nat_diff_split)
 
 lemma left_right_inverse_power:
   assumes "x * y = 1"
   shows   "x ^ n * y ^ n = 1"
 proof (induct n)
   case (Suc n)
   moreover have "x ^ Suc n * y ^ Suc n = x^n * (x * y) * y^n"
     by (simp add: power_Suc2[symmetric] mult.assoc[symmetric])
   ultimately show ?case by (simp add: assms)
 qed simp
 
 end
 
 context comm_monoid_mult
 begin
 
 lemma power_mult_distrib [algebra_simps, algebra_split_simps, field_simps, field_split_simps, divide_simps]:
   "(a * b) ^ n = (a ^ n) * (b ^ n)"
   by (induction n) (simp_all add: ac_simps)
 
 end
 
 text \<open>Extract constant factors from powers.\<close>
 declare power_mult_distrib [where a = "numeral w" for w, simp]
 declare power_mult_distrib [where b = "numeral w" for w, simp]
 
 lemma power_add_numeral [simp]: "a^numeral m * a^numeral n = a^numeral (m + n)"
   for a :: "'a::monoid_mult"
   by (simp add: power_add [symmetric])
 
 lemma power_add_numeral2 [simp]: "a^numeral m * (a^numeral n * b) = a^numeral (m + n) * b"
   for a :: "'a::monoid_mult"
   by (simp add: mult.assoc [symmetric])
 
 lemma power_mult_numeral [simp]: "(a^numeral m)^numeral n = a^numeral (m * n)"
   for a :: "'a::monoid_mult"
   by (simp only: numeral_mult power_mult)
 
 context semiring_numeral
 begin
 
 lemma numeral_sqr: "numeral (Num.sqr k) = numeral k * numeral k"
   by (simp only: sqr_conv_mult numeral_mult)
 
 lemma numeral_pow: "numeral (Num.pow k l) = numeral k ^ numeral l"
   by (induct l)
     (simp_all only: numeral_class.numeral.simps pow.simps
       numeral_sqr numeral_mult power_add power_one_right)
 
 lemma power_numeral [simp]: "numeral k ^ numeral l = numeral (Num.pow k l)"
   by (rule numeral_pow [symmetric])
 
 end
 
 context semiring_1
 begin
 
 lemma of_nat_power [simp]: "of_nat (m ^ n) = of_nat m ^ n"
   by (induct n) simp_all
 
 lemma zero_power: "0 < n \<Longrightarrow> 0 ^ n = 0"
   by (cases n) simp_all
 
 lemma power_zero_numeral [simp]: "0 ^ numeral k = 0"
   by (simp add: numeral_eq_Suc)
 
 lemma zero_power2: "0\<^sup>2 = 0" (* delete? *)
   by (rule power_zero_numeral)
 
 lemma one_power2: "1\<^sup>2 = 1" (* delete? *)
   by (rule power_one)
 
 lemma power_0_Suc [simp]: "0 ^ Suc n = 0"
   by simp
 
 text \<open>It looks plausible as a simprule, but its effect can be strange.\<close>
 lemma power_0_left: "0 ^ n = (if n = 0 then 1 else 0)"
   by (cases n) simp_all
 
 end
 
 context semiring_char_0 begin
 
 lemma numeral_power_eq_of_nat_cancel_iff [simp]:
   "numeral x ^ n = of_nat y \<longleftrightarrow> numeral x ^ n = y"
   using of_nat_eq_iff by fastforce
 
 lemma real_of_nat_eq_numeral_power_cancel_iff [simp]:
   "of_nat y = numeral x ^ n \<longleftrightarrow> y = numeral x ^ n"
   using numeral_power_eq_of_nat_cancel_iff [of x n y] by (metis (mono_tags))
 
 lemma of_nat_eq_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w = of_nat x \<longleftrightarrow> b ^ w = x"
   by (metis of_nat_power of_nat_eq_iff)
 
 lemma of_nat_power_eq_of_nat_cancel_iff[simp]: "of_nat x = (of_nat b) ^ w \<longleftrightarrow> x = b ^ w"
   by (metis of_nat_eq_of_nat_power_cancel_iff)
 
 end
 
 context comm_semiring_1
 begin
 
 text \<open>The divides relation.\<close>
 
 lemma le_imp_power_dvd:
   assumes "m \<le> n"
   shows "a ^ m dvd a ^ n"
 proof
   from assms have "a ^ n = a ^ (m + (n - m))" by simp
   also have "\<dots> = a ^ m * a ^ (n - m)" by (rule power_add)
   finally show "a ^ n = a ^ m * a ^ (n - m)" .
 qed
 
 lemma power_le_dvd: "a ^ n dvd b \<Longrightarrow> m \<le> n \<Longrightarrow> a ^ m dvd b"
   by (rule dvd_trans [OF le_imp_power_dvd])
 
 lemma dvd_power_same: "x dvd y \<Longrightarrow> x ^ n dvd y ^ n"
   by (induct n) (auto simp add: mult_dvd_mono)
 
 lemma dvd_power_le: "x dvd y \<Longrightarrow> m \<ge> n \<Longrightarrow> x ^ n dvd y ^ m"
   by (rule power_le_dvd [OF dvd_power_same])
 
 lemma dvd_power [simp]:
   fixes n :: nat
   assumes "n > 0 \<or> x = 1"
   shows "x dvd (x ^ n)"
   using assms
 proof
   assume "0 < n"
   then have "x ^ n = x ^ Suc (n - 1)" by simp
   then show "x dvd (x ^ n)" by simp
 next
   assume "x = 1"
   then show "x dvd (x ^ n)" by simp
 qed
 
 end
 
 context semiring_1_no_zero_divisors
 begin
 
 subclass power .
 
 lemma power_eq_0_iff [simp]: "a ^ n = 0 \<longleftrightarrow> a = 0 \<and> n > 0"
   by (induct n) auto
 
 lemma power_not_zero: "a \<noteq> 0 \<Longrightarrow> a ^ n \<noteq> 0"
   by (induct n) auto
 
 lemma zero_eq_power2 [simp]: "a\<^sup>2 = 0 \<longleftrightarrow> a = 0"
   unfolding power2_eq_square by simp
 
 end
 
 context ring_1
 begin
 
 lemma power_minus: "(- a) ^ n = (- 1) ^ n * a ^ n"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case (Suc n)
   then show ?case
     by (simp del: power_Suc add: power_Suc2 mult.assoc)
 qed
 
 lemma power_minus': "NO_MATCH 1 x \<Longrightarrow> (-x) ^ n = (-1)^n * x ^ n"
   by (rule power_minus)
 
 lemma power_minus_Bit0: "(- x) ^ numeral (Num.Bit0 k) = x ^ numeral (Num.Bit0 k)"
   by (induct k, simp_all only: numeral_class.numeral.simps power_add
     power_one_right mult_minus_left mult_minus_right minus_minus)
 
 lemma power_minus_Bit1: "(- x) ^ numeral (Num.Bit1 k) = - (x ^ numeral (Num.Bit1 k))"
   by (simp only: eval_nat_numeral(3) power_Suc power_minus_Bit0 mult_minus_left)
 
 lemma power2_minus [simp]: "(- a)\<^sup>2 = a\<^sup>2"
   by (fact power_minus_Bit0)
 
 lemma power_minus1_even [simp]: "(- 1) ^ (2*n) = 1"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case (Suc n)
   then show ?case by (simp add: power_add power2_eq_square)
 qed
 
 lemma power_minus1_odd: "(- 1) ^ Suc (2*n) = -1"
   by simp
 
 lemma power_minus_even [simp]: "(-a) ^ (2*n) = a ^ (2*n)"
   by (simp add: power_minus [of a])
 
 end
 
 context ring_1_no_zero_divisors
 begin
 
 lemma power2_eq_1_iff: "a\<^sup>2 = 1 \<longleftrightarrow> a = 1 \<or> a = - 1"
   using square_eq_1_iff [of a] by (simp add: power2_eq_square)
 
 end
 
 context idom
 begin
 
 lemma power2_eq_iff: "x\<^sup>2 = y\<^sup>2 \<longleftrightarrow> x = y \<or> x = - y"
   unfolding power2_eq_square by (rule square_eq_iff)
 
 end
 
 context semidom_divide
 begin
 
 lemma power_diff:
   "a ^ (m - n) = (a ^ m) div (a ^ n)" if "a \<noteq> 0" and "n \<le> m"
 proof -
   define q where "q = m - n"
   with \<open>n \<le> m\<close> have "m = q + n" by simp
   with \<open>a \<noteq> 0\<close> q_def show ?thesis
     by (simp add: power_add)
 qed
 
 end
 
 context algebraic_semidom
 begin
 
 lemma div_power: "b dvd a \<Longrightarrow> (a div b) ^ n = a ^ n div b ^ n"
   by (induct n) (simp_all add: div_mult_div_if_dvd dvd_power_same)
 
 lemma is_unit_power_iff: "is_unit (a ^ n) \<longleftrightarrow> is_unit a \<or> n = 0"
   by (induct n) (auto simp add: is_unit_mult_iff)
 
 lemma dvd_power_iff:
   assumes "x \<noteq> 0"
   shows   "x ^ m dvd x ^ n \<longleftrightarrow> is_unit x \<or> m \<le> n"
 proof
   assume *: "x ^ m dvd x ^ n"
   {
     assume "m > n"
     note *
     also have "x ^ n = x ^ n * 1" by simp
     also from \<open>m > n\<close> have "m = n + (m - n)" by simp
     also have "x ^ \<dots> = x ^ n * x ^ (m - n)" by (rule power_add)
     finally have "x ^ (m - n) dvd 1"
-      by (subst (asm) dvd_times_left_cancel_iff) (insert assms, simp_all)
+      using assms by (subst (asm) dvd_times_left_cancel_iff) simp_all
     with \<open>m > n\<close> have "is_unit x" by (simp add: is_unit_power_iff)
   }
   thus "is_unit x \<or> m \<le> n" by force
 qed (auto intro: unit_imp_dvd simp: is_unit_power_iff le_imp_power_dvd)
 
 
 end
 
 context normalization_semidom_multiplicative
 begin
 
 lemma normalize_power: "normalize (a ^ n) = normalize a ^ n"
   by (induct n) (simp_all add: normalize_mult)
 
 lemma unit_factor_power: "unit_factor (a ^ n) = unit_factor a ^ n"
   by (induct n) (simp_all add: unit_factor_mult)
 
 end
 
 context division_ring
 begin
 
 text \<open>Perhaps these should be simprules.\<close>
 lemma power_inverse [field_simps, field_split_simps, divide_simps]: "inverse a ^ n = inverse (a ^ n)"
 proof (cases "a = 0")
   case True
   then show ?thesis by (simp add: power_0_left)
 next
   case False
   then have "inverse (a ^ n) = inverse a ^ n"
     by (induct n) (simp_all add: nonzero_inverse_mult_distrib power_commutes)
   then show ?thesis by simp
 qed
 
 lemma power_one_over [field_simps, field_split_simps, divide_simps]: "(1 / a) ^ n = 1 / a ^ n"
   using power_inverse [of a] by (simp add: divide_inverse)
 
 end
 
 context field
 begin
 
 lemma power_divide [field_simps, field_split_simps, divide_simps]: "(a / b) ^ n = a ^ n / b ^ n"
   by (induct n) simp_all
 
 end
 
 
 subsection \<open>Exponentiation on ordered types\<close>
 
 context linordered_semidom
 begin
 
 lemma zero_less_power [simp]: "0 < a \<Longrightarrow> 0 < a ^ n"
   by (induct n) simp_all
 
 lemma zero_le_power [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> a ^ n"
   by (induct n) simp_all
 
 lemma power_mono: "a \<le> b \<Longrightarrow> 0 \<le> a \<Longrightarrow> a ^ n \<le> b ^ n"
   by (induct n) (auto intro: mult_mono order_trans [of 0 a b])
 
 lemma one_le_power [simp]: "1 \<le> a \<Longrightarrow> 1 \<le> a ^ n"
   using power_mono [of 1 a n] by simp
 
 lemma power_le_one: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ n \<le> 1"
   using power_mono [of a 1 n] by simp
 
 lemma power_gt1_lemma:
   assumes gt1: "1 < a"
   shows "1 < a * a ^ n"
 proof -
   from gt1 have "0 \<le> a"
     by (fact order_trans [OF zero_le_one less_imp_le])
   from gt1 have "1 * 1 < a * 1" by simp
   also from gt1 have "\<dots> \<le> a * a ^ n"
     by (simp only: mult_mono \<open>0 \<le> a\<close> one_le_power order_less_imp_le zero_le_one order_refl)
   finally show ?thesis by simp
 qed
 
 lemma power_gt1: "1 < a \<Longrightarrow> 1 < a ^ Suc n"
   by (simp add: power_gt1_lemma)
 
 lemma one_less_power [simp]: "1 < a \<Longrightarrow> 0 < n \<Longrightarrow> 1 < a ^ n"
   by (cases n) (simp_all add: power_gt1_lemma)
 
 lemma power_le_imp_le_exp:
   assumes gt1: "1 < a"
   shows "a ^ m \<le> a ^ n \<Longrightarrow> m \<le> n"
 proof (induct m arbitrary: n)
   case 0
   show ?case by simp
 next
   case (Suc m)
   show ?case
   proof (cases n)
     case 0
     with Suc have "a * a ^ m \<le> 1" by simp
     with gt1 show ?thesis
       by (force simp only: power_gt1_lemma not_less [symmetric])
   next
     case (Suc n)
     with Suc.prems Suc.hyps show ?thesis
       by (force dest: mult_left_le_imp_le simp add: less_trans [OF zero_less_one gt1])
   qed
 qed
 
 lemma of_nat_zero_less_power_iff [simp]: "of_nat x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
   by (induct n) auto
 
 text \<open>Surely we can strengthen this? It holds for \<open>0<a<1\<close> too.\<close>
 lemma power_inject_exp [simp]:
   \<open>a ^ m = a ^ n \<longleftrightarrow> m = n\<close> if \<open>1 < a\<close>
   using that by (force simp add: order_class.order.antisym power_le_imp_le_exp)
 
 text \<open>
   Can relax the first premise to \<^term>\<open>0<a\<close> in the case of the
   natural numbers.
 \<close>
 lemma power_less_imp_less_exp: "1 < a \<Longrightarrow> a ^ m < a ^ n \<Longrightarrow> m < n"
   by (simp add: order_less_le [of m n] less_le [of "a^m" "a^n"] power_le_imp_le_exp)
-
-lemma power_strict_mono [rule_format]: "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<longrightarrow> a ^ n < b ^ n"
-  by (induct n) (auto simp: mult_strict_mono le_less_trans [of 0 a b])
+                               
+lemma power_strict_mono: "a < b \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> a ^ n < b ^ n"
+proof (induct n)
+  case 0
+  then show ?case by simp
+next
+  case (Suc n)
+  then show ?case
+    by (cases "n = 0") (auto simp: mult_strict_mono le_less_trans [of 0 a b])
+qed
 
 lemma power_mono_iff [simp]:
   shows "\<lbrakk>a \<ge> 0; b \<ge> 0; n>0\<rbrakk> \<Longrightarrow> a ^ n \<le> b ^ n \<longleftrightarrow> a \<le> b"
   using power_mono [of a b] power_strict_mono [of b a] not_le by auto
 
 text\<open>Lemma for \<open>power_strict_decreasing\<close>\<close>
 lemma power_Suc_less: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a * a ^ n < a ^ n"
   by (induct n) (auto simp: mult_strict_left_mono)
 
-lemma power_strict_decreasing [rule_format]: "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<longrightarrow> a ^ N < a ^ n"
-proof (induct N)
+lemma power_strict_decreasing: "n < N \<Longrightarrow> 0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ N < a ^ n"
+proof (induction N)
+   case 0
+   then show ?case by simp
+ next
+   case (Suc N)
+   then show ?case
+     using mult_strict_mono[of a 1 "a ^ N" "a ^ n"]
+     by (auto simp add: power_Suc_less less_Suc_eq)
+ qed
+
+text \<open>Proof resembles that of \<open>power_strict_decreasing\<close>.\<close>
+lemma power_decreasing: "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ N \<le> a ^ n"
+proof (induction N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
-    apply (auto simp add: power_Suc_less less_Suc_eq)
-    apply (subgoal_tac "a * a^N < 1 * a^n")
-     apply simp
-    apply (rule mult_strict_mono)
-       apply auto
-    done
-qed
-
-text \<open>Proof resembles that of \<open>power_strict_decreasing\<close>.\<close>
-lemma power_decreasing: "n \<le> N \<Longrightarrow> 0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ N \<le> a ^ n"
-proof (induct N)
-  case 0
-  then show ?case by simp
-next
-  case (Suc N)
-  then show ?case
-    apply (auto simp add: le_Suc_eq)
-    apply (subgoal_tac "a * a^N \<le> 1 * a^n")
-     apply simp
-    apply (rule mult_mono)
-       apply auto
-    done
+    using mult_mono[of a 1 "a^N" "a ^ n"]
+    by (auto simp add: le_Suc_eq)
 qed
 
 lemma power_decreasing_iff [simp]: "\<lbrakk>0 < b; b < 1\<rbrakk> \<Longrightarrow> b ^ m \<le> b ^ n \<longleftrightarrow> n \<le> m"
   using power_strict_decreasing [of m n b]
   by (auto intro: power_decreasing ccontr)
 
 lemma power_strict_decreasing_iff [simp]: "\<lbrakk>0 < b; b < 1\<rbrakk> \<Longrightarrow> b ^ m < b ^ n \<longleftrightarrow> n < m"
   using power_decreasing_iff [of b m n] unfolding le_less
   by (auto dest: power_strict_decreasing le_neq_implies_less)
 
 lemma power_Suc_less_one: "0 < a \<Longrightarrow> a < 1 \<Longrightarrow> a ^ Suc n < 1"
   using power_strict_decreasing [of 0 "Suc n" a] by simp
 
 text \<open>Proof again resembles that of \<open>power_strict_decreasing\<close>.\<close>
 lemma power_increasing: "n \<le> N \<Longrightarrow> 1 \<le> a \<Longrightarrow> a ^ n \<le> a ^ N"
 proof (induct N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
-    apply (auto simp add: le_Suc_eq)
-    apply (subgoal_tac "1 * a^n \<le> a * a^N")
-     apply simp
-    apply (rule mult_mono)
-       apply (auto simp add: order_trans [OF zero_le_one])
-    done
+    using mult_mono[of 1 a "a ^ n" "a ^ N"]
+    by (auto simp add: le_Suc_eq order_trans [OF zero_le_one])
 qed
 
 text \<open>Lemma for \<open>power_strict_increasing\<close>.\<close>
 lemma power_less_power_Suc: "1 < a \<Longrightarrow> a ^ n < a * a ^ n"
   by (induct n) (auto simp: mult_strict_left_mono less_trans [OF zero_less_one])
 
 lemma power_strict_increasing: "n < N \<Longrightarrow> 1 < a \<Longrightarrow> a ^ n < a ^ N"
 proof (induct N)
   case 0
   then show ?case by simp
 next
   case (Suc N)
   then show ?case
-    apply (auto simp add: power_less_power_Suc less_Suc_eq)
-    apply (subgoal_tac "1 * a^n < a * a^N")
-     apply simp
-    apply (rule mult_strict_mono)
-    apply (auto simp add: less_trans [OF zero_less_one] less_imp_le)
-    done
+    using mult_strict_mono[of 1 a "a^n" "a^N"]
+    by (auto simp add: power_less_power_Suc less_Suc_eq less_trans [OF zero_less_one] less_imp_le)
 qed
 
 lemma power_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x \<le> b ^ y \<longleftrightarrow> x \<le> y"
   by (blast intro: power_le_imp_le_exp power_increasing less_imp_le)
 
 lemma power_strict_increasing_iff [simp]: "1 < b \<Longrightarrow> b ^ x < b ^ y \<longleftrightarrow> x < y"
   by (blast intro: power_less_imp_less_exp power_strict_increasing)
 
 lemma power_le_imp_le_base:
   assumes le: "a ^ Suc n \<le> b ^ Suc n"
     and "0 \<le> b"
   shows "a \<le> b"
 proof (rule ccontr)
   assume "\<not> ?thesis"
   then have "b < a" by (simp only: linorder_not_le)
   then have "b ^ Suc n < a ^ Suc n"
     by (simp only: assms(2) power_strict_mono)
   with le show False
     by (simp add: linorder_not_less [symmetric])
 qed
 
 lemma power_less_imp_less_base:
   assumes less: "a ^ n < b ^ n"
   assumes nonneg: "0 \<le> b"
   shows "a < b"
 proof (rule contrapos_pp [OF less])
   assume "\<not> ?thesis"
   then have "b \<le> a" by (simp only: linorder_not_less)
   from this nonneg have "b ^ n \<le> a ^ n" by (rule power_mono)
   then show "\<not> a ^ n < b ^ n" by (simp only: linorder_not_less)
 qed
 
 lemma power_inject_base: "a ^ Suc n = b ^ Suc n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a = b"
   by (blast intro: power_le_imp_le_base order.antisym eq_refl sym)
 
 lemma power_eq_imp_eq_base: "a ^ n = b ^ n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 < n \<Longrightarrow> a = b"
   by (cases n) (simp_all del: power_Suc, rule power_inject_base)
 
 lemma power_eq_iff_eq_base: "0 < n \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> a ^ n = b ^ n \<longleftrightarrow> a = b"
   using power_eq_imp_eq_base [of a n b] by auto
 
 lemma power2_le_imp_le: "x\<^sup>2 \<le> y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x \<le> y"
   unfolding numeral_2_eq_2 by (rule power_le_imp_le_base)
 
 lemma power2_less_imp_less: "x\<^sup>2 < y\<^sup>2 \<Longrightarrow> 0 \<le> y \<Longrightarrow> x < y"
   by (rule power_less_imp_less_base)
 
 lemma power2_eq_imp_eq: "x\<^sup>2 = y\<^sup>2 \<Longrightarrow> 0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> x = y"
   unfolding numeral_2_eq_2 by (erule (2) power_eq_imp_eq_base) simp
 
 lemma power_Suc_le_self: "0 \<le> a \<Longrightarrow> a \<le> 1 \<Longrightarrow> a ^ Suc n \<le> a"
   using power_decreasing [of 1 "Suc n" a] by simp
 
 lemma power2_eq_iff_nonneg [simp]:
   assumes "0 \<le> x" "0 \<le> y"
   shows "(x ^ 2 = y ^ 2) \<longleftrightarrow> x = y"
 using assms power2_eq_imp_eq by blast
 
 lemma of_nat_less_numeral_power_cancel_iff[simp]:
   "of_nat x < numeral i ^ n \<longleftrightarrow> x < numeral i ^ n"
   using of_nat_less_iff[of x "numeral i ^ n", unfolded of_nat_numeral of_nat_power] .
 
 lemma of_nat_le_numeral_power_cancel_iff[simp]:
   "of_nat x \<le> numeral i ^ n \<longleftrightarrow> x \<le> numeral i ^ n"
   using of_nat_le_iff[of x "numeral i ^ n", unfolded of_nat_numeral of_nat_power] .
 
 lemma numeral_power_less_of_nat_cancel_iff[simp]:
   "numeral i ^ n < of_nat x \<longleftrightarrow> numeral i ^ n < x"
   using of_nat_less_iff[of "numeral i ^ n" x, unfolded of_nat_numeral of_nat_power] .
 
 lemma numeral_power_le_of_nat_cancel_iff[simp]:
   "numeral i ^ n \<le> of_nat x \<longleftrightarrow> numeral i ^ n \<le> x"
   using of_nat_le_iff[of "numeral i ^ n" x, unfolded of_nat_numeral of_nat_power] .
 
 lemma of_nat_le_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w \<le> of_nat x \<longleftrightarrow> b ^ w \<le> x"
   by (metis of_nat_le_iff of_nat_power)
 
 lemma of_nat_power_le_of_nat_cancel_iff[simp]: "of_nat x \<le> (of_nat b) ^ w \<longleftrightarrow> x \<le> b ^ w"
   by (metis of_nat_le_iff of_nat_power)
 
 lemma of_nat_less_of_nat_power_cancel_iff[simp]: "(of_nat b) ^ w < of_nat x \<longleftrightarrow> b ^ w < x"
   by (metis of_nat_less_iff of_nat_power)
 
 lemma of_nat_power_less_of_nat_cancel_iff[simp]: "of_nat x < (of_nat b) ^ w \<longleftrightarrow> x < b ^ w"
   by (metis of_nat_less_iff of_nat_power)
 
 end
 
 
 text \<open>Some @{typ nat}-specific lemmas:\<close>
 
 lemma mono_ge2_power_minus_self:
   assumes "k \<ge> 2" shows "mono (\<lambda>m. k ^ m - m)"
 unfolding mono_iff_le_Suc
 proof
   fix n
   have "k ^ n < k ^ Suc n" using power_strict_increasing_iff[of k "n" "Suc n"] assms by linarith
   thus "k ^ n - n \<le> k ^ Suc n - Suc n" by linarith
 qed
 
 lemma self_le_ge2_pow[simp]:
   assumes "k \<ge> 2" shows "m \<le> k ^ m"
 proof (induction m)
   case 0 show ?case by simp
 next
   case (Suc m)
   hence "Suc m \<le> Suc (k ^ m)" by simp
   also have "... \<le> k^m + k^m" using one_le_power[of k m] assms by linarith
   also have "... \<le> k * k^m" by (metis mult_2 mult_le_mono1[OF assms])
   finally show ?case by simp
 qed
 
 lemma diff_le_diff_pow[simp]:
   assumes "k \<ge> 2" shows "m - n \<le> k ^ m - k ^ n"
 proof (cases "n \<le> m")
   case True
   thus ?thesis
     using monoD[OF mono_ge2_power_minus_self[OF assms] True] self_le_ge2_pow[OF assms, of m]
     by (simp add: le_diff_conv le_diff_conv2)
 qed auto
 
 
 context linordered_ring_strict
 begin
 
 lemma sum_squares_eq_zero_iff: "x * x + y * y = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   by (simp add: add_nonneg_eq_0_iff)
 
 lemma sum_squares_le_zero_iff: "x * x + y * y \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   by (simp add: le_less not_sum_squares_lt_zero sum_squares_eq_zero_iff)
 
 lemma sum_squares_gt_zero_iff: "0 < x * x + y * y \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
   by (simp add: not_le [symmetric] sum_squares_le_zero_iff)
 
 end
 
 context linordered_idom
 begin
 
 lemma zero_le_power2 [simp]: "0 \<le> a\<^sup>2"
   by (simp add: power2_eq_square)
 
 lemma zero_less_power2 [simp]: "0 < a\<^sup>2 \<longleftrightarrow> a \<noteq> 0"
   by (force simp add: power2_eq_square zero_less_mult_iff linorder_neq_iff)
 
 lemma power2_less_0 [simp]: "\<not> a\<^sup>2 < 0"
   by (force simp add: power2_eq_square mult_less_0_iff)
 
 lemma power_abs: "\<bar>a ^ n\<bar> = \<bar>a\<bar> ^ n" \<comment> \<open>FIXME simp?\<close>
   by (induct n) (simp_all add: abs_mult)
 
 lemma power_sgn [simp]: "sgn (a ^ n) = sgn a ^ n"
   by (induct n) (simp_all add: sgn_mult)
 
 lemma abs_power_minus [simp]: "\<bar>(- a) ^ n\<bar> = \<bar>a ^ n\<bar>"
   by (simp add: power_abs)
 
 lemma zero_less_power_abs_iff [simp]: "0 < \<bar>a\<bar> ^ n \<longleftrightarrow> a \<noteq> 0 \<or> n = 0"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case Suc
   then show ?case by (auto simp: zero_less_mult_iff)
 qed
 
 lemma zero_le_power_abs [simp]: "0 \<le> \<bar>a\<bar> ^ n"
   by (rule zero_le_power [OF abs_ge_zero])
 
 lemma power2_less_eq_zero_iff [simp]: "a\<^sup>2 \<le> 0 \<longleftrightarrow> a = 0"
   by (simp add: le_less)
 
 lemma abs_power2 [simp]: "\<bar>a\<^sup>2\<bar> = a\<^sup>2"
   by (simp add: power2_eq_square)
 
 lemma power2_abs [simp]: "\<bar>a\<bar>\<^sup>2 = a\<^sup>2"
   by (simp add: power2_eq_square)
 
 lemma odd_power_less_zero: "a < 0 \<Longrightarrow> a ^ Suc (2 * n) < 0"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   have "a ^ Suc (2 * Suc n) = (a*a) * a ^ Suc(2*n)"
     by (simp add: ac_simps power_add power2_eq_square)
   then show ?case
     by (simp del: power_Suc add: Suc mult_less_0_iff mult_neg_neg)
 qed
 
 lemma odd_0_le_power_imp_0_le: "0 \<le> a ^ Suc (2 * n) \<Longrightarrow> 0 \<le> a"
   using odd_power_less_zero [of a n]
   by (force simp add: linorder_not_less [symmetric])
 
 lemma zero_le_even_power'[simp]: "0 \<le> a ^ (2 * n)"
 proof (induct n)
   case 0
   show ?case by simp
 next
   case (Suc n)
   have "a ^ (2 * Suc n) = (a*a) * a ^ (2*n)"
     by (simp add: ac_simps power_add power2_eq_square)
   then show ?case
     by (simp add: Suc zero_le_mult_iff)
 qed
 
 lemma sum_power2_ge_zero: "0 \<le> x\<^sup>2 + y\<^sup>2"
   by (intro add_nonneg_nonneg zero_le_power2)
 
 lemma not_sum_power2_lt_zero: "\<not> x\<^sup>2 + y\<^sup>2 < 0"
   unfolding not_less by (rule sum_power2_ge_zero)
 
 lemma sum_power2_eq_zero_iff: "x\<^sup>2 + y\<^sup>2 = 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   unfolding power2_eq_square by (simp add: add_nonneg_eq_0_iff)
 
 lemma sum_power2_le_zero_iff: "x\<^sup>2 + y\<^sup>2 \<le> 0 \<longleftrightarrow> x = 0 \<and> y = 0"
   by (simp add: le_less sum_power2_eq_zero_iff not_sum_power2_lt_zero)
 
 lemma sum_power2_gt_zero_iff: "0 < x\<^sup>2 + y\<^sup>2 \<longleftrightarrow> x \<noteq> 0 \<or> y \<noteq> 0"
   unfolding not_le [symmetric] by (simp add: sum_power2_le_zero_iff)
 
 lemma abs_le_square_iff: "\<bar>x\<bar> \<le> \<bar>y\<bar> \<longleftrightarrow> x\<^sup>2 \<le> y\<^sup>2"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   then have "\<bar>x\<bar>\<^sup>2 \<le> \<bar>y\<bar>\<^sup>2" by (rule power_mono) simp
   then show ?rhs by simp
 next
   assume ?rhs
   then show ?lhs
     by (auto intro!: power2_le_imp_le [OF _ abs_ge_zero])
 qed
 
 lemma power2_le_iff_abs_le:
   "y \<ge> 0 \<Longrightarrow> x\<^sup>2 \<le> y\<^sup>2 \<longleftrightarrow> \<bar>x\<bar> \<le> y"
   by (metis abs_le_square_iff abs_of_nonneg)
 
 lemma abs_square_le_1:"x\<^sup>2 \<le> 1 \<longleftrightarrow> \<bar>x\<bar> \<le> 1"
   using abs_le_square_iff [of x 1] by simp
 
 lemma abs_square_eq_1: "x\<^sup>2 = 1 \<longleftrightarrow> \<bar>x\<bar> = 1"
   by (auto simp add: abs_if power2_eq_1_iff)
 
 lemma abs_square_less_1: "x\<^sup>2 < 1 \<longleftrightarrow> \<bar>x\<bar> < 1"
   using  abs_square_eq_1 [of x] abs_square_le_1 [of x] by (auto simp add: le_less)
 
 lemma square_le_1:
   assumes "- 1 \<le> x" "x \<le> 1"
   shows "x\<^sup>2 \<le> 1"
     using assms
     by (metis add.inverse_inverse linear mult_le_one neg_equal_0_iff_equal neg_le_iff_le power2_eq_square power_minus_Bit0)
 
 end
 
 
 subsection \<open>Miscellaneous rules\<close>
 
 lemma (in linordered_semidom) self_le_power: "1 \<le> a \<Longrightarrow> 0 < n \<Longrightarrow> a \<le> a ^ n"
   using power_increasing [of 1 n a] power_one_right [of a] by auto
 
 lemma (in power) power_eq_if: "p ^ m = (if m=0 then 1 else p * (p ^ (m - 1)))"
   unfolding One_nat_def by (cases m) simp_all
 
 lemma (in comm_semiring_1) power2_sum: "(x + y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 + 2 * x * y"
   by (simp add: algebra_simps power2_eq_square mult_2_right)
 
 context comm_ring_1
 begin
 
 lemma power2_diff: "(x - y)\<^sup>2 = x\<^sup>2 + y\<^sup>2 - 2 * x * y"
   by (simp add: algebra_simps power2_eq_square mult_2_right)
 
 lemma power2_commute: "(x - y)\<^sup>2 = (y - x)\<^sup>2"
   by (simp add: algebra_simps power2_eq_square)
 
 lemma minus_power_mult_self: "(- a) ^ n * (- a) ^ n = a ^ (2 * n)"
   by (simp add: power_mult_distrib [symmetric])
     (simp add: power2_eq_square [symmetric] power_mult [symmetric])
 
 lemma minus_one_mult_self [simp]: "(- 1) ^ n * (- 1) ^ n = 1"
   using minus_power_mult_self [of 1 n] by simp
 
 lemma left_minus_one_mult_self [simp]: "(- 1) ^ n * ((- 1) ^ n * a) = a"
   by (simp add: mult.assoc [symmetric])
 
 end
 
 text \<open>Simprules for comparisons where common factors can be cancelled.\<close>
 
 lemmas zero_compare_simps =
   add_strict_increasing add_strict_increasing2 add_increasing
   zero_le_mult_iff zero_le_divide_iff
   zero_less_mult_iff zero_less_divide_iff
   mult_le_0_iff divide_le_0_iff
   mult_less_0_iff divide_less_0_iff
   zero_le_power2 power2_less_0
 
 
 subsection \<open>Exponentiation for the Natural Numbers\<close>
 
 lemma nat_one_le_power [simp]: "Suc 0 \<le> i \<Longrightarrow> Suc 0 \<le> i ^ n"
   by (rule one_le_power [of i n, unfolded One_nat_def])
 
 lemma nat_zero_less_power_iff [simp]: "x ^ n > 0 \<longleftrightarrow> x > 0 \<or> n = 0"
   for x :: nat
   by (induct n) auto
 
 lemma nat_power_eq_Suc_0_iff [simp]: "x ^ m = Suc 0 \<longleftrightarrow> m = 0 \<or> x = Suc 0"
   by (induct m) auto
 
 lemma power_Suc_0 [simp]: "Suc 0 ^ n = Suc 0"
   by simp
 
 text \<open>
   Valid for the naturals, but what if \<open>0 < i < 1\<close>? Premises cannot be
   weakened: consider the case where \<open>i = 0\<close>, \<open>m = 1\<close> and \<open>n = 0\<close>.
 \<close>
 
 lemma nat_power_less_imp_less:
   fixes i :: nat
   assumes nonneg: "0 < i"
   assumes less: "i ^ m < i ^ n"
   shows "m < n"
 proof (cases "i = 1")
   case True
   with less power_one [where 'a = nat] show ?thesis by simp
 next
   case False
   with nonneg have "1 < i" by auto
   from power_strict_increasing_iff [OF this] less show ?thesis ..
 qed
 
 lemma power_gt_expt: "n > Suc 0 \<Longrightarrow> n^k > k"
   by (induction k) (auto simp: less_trans_Suc n_less_m_mult_n)
 
 lemma less_exp [simp]:
   \<open>n < 2 ^ n\<close>
   by (simp add: power_gt_expt)
 
 lemma power_dvd_imp_le:
   fixes i :: nat
   assumes "i ^ m dvd i ^ n" "1 < i"
   shows "m \<le> n"
   using assms by (auto intro: power_le_imp_le_exp [OF \<open>1 < i\<close> dvd_imp_le])
 
 lemma dvd_power_iff_le:
   fixes k::nat
   shows "2 \<le> k \<Longrightarrow> ((k ^ m) dvd (k ^ n) \<longleftrightarrow> m \<le> n)"
   using le_imp_power_dvd power_dvd_imp_le by force
 
 lemma power2_nat_le_eq_le: "m\<^sup>2 \<le> n\<^sup>2 \<longleftrightarrow> m \<le> n"
   for m n :: nat
   by (auto intro: power2_le_imp_le power_mono)
 
 lemma power2_nat_le_imp_le:
   fixes m n :: nat
   assumes "m\<^sup>2 \<le> n"
   shows "m \<le> n"
 proof (cases m)
   case 0
   then show ?thesis by simp
 next
   case (Suc k)
   show ?thesis
   proof (rule ccontr)
     assume "\<not> ?thesis"
     then have "n < m" by simp
     with assms Suc show False
       by (simp add: power2_eq_square)
   qed
 qed
 
 lemma ex_power_ivl1: fixes b k :: nat assumes "b \<ge> 2"
 shows "k \<ge> 1 \<Longrightarrow> \<exists>n. b^n \<le> k \<and> k < b^(n+1)" (is "_ \<Longrightarrow> \<exists>n. ?P k n")
 proof(induction k)
   case 0 thus ?case by simp
 next
   case (Suc k)
   show ?case
   proof cases
     assume "k=0"
     hence "?P (Suc k) 0" using assms by simp
     thus ?case ..
   next
     assume "k\<noteq>0"
     with Suc obtain n where IH: "?P k n" by auto
     show ?case
     proof (cases "k = b^(n+1) - 1")
       case True
       hence "?P (Suc k) (n+1)" using assms
         by (simp add: power_less_power_Suc)
       thus ?thesis ..
     next
       case False
       hence "?P (Suc k) n" using IH by auto
       thus ?thesis ..
     qed
   qed
 qed
 
 lemma ex_power_ivl2: fixes b k :: nat assumes "b \<ge> 2" "k \<ge> 2"
   shows "\<exists>n. b^n < k \<and> k \<le> b^(n+1)"
 proof -
   have "1 \<le> k - 1" using assms(2) by arith
   from ex_power_ivl1[OF assms(1) this]
   obtain n where "b ^ n \<le> k - 1 \<and> k - 1 < b ^ (n + 1)" ..
   hence "b^n < k \<and> k \<le> b^(n+1)" using assms by auto
   thus ?thesis ..
 qed
 
 
 subsubsection \<open>Cardinality of the Powerset\<close>
 
 lemma card_UNIV_bool [simp]: "card (UNIV :: bool set) = 2"
   unfolding UNIV_bool by simp
 
 lemma card_Pow: "finite A \<Longrightarrow> card (Pow A) = 2 ^ card A"
 proof (induct rule: finite_induct)
   case empty
   show ?case by simp
 next
   case (insert x A)
   from \<open>x \<notin> A\<close> have disjoint: "Pow A \<inter> insert x ` Pow A = {}" by blast
   from \<open>x \<notin> A\<close> have inj_on: "inj_on (insert x) (Pow A)"
     unfolding inj_on_def by auto
 
   have "card (Pow (insert x A)) = card (Pow A \<union> insert x ` Pow A)"
     by (simp only: Pow_insert)
   also have "\<dots> = card (Pow A) + card (insert x ` Pow A)"
     by (rule card_Un_disjoint) (use \<open>finite A\<close> disjoint in simp_all)
   also from inj_on have "card (insert x ` Pow A) = card (Pow A)"
     by (rule card_image)
   also have "\<dots> + \<dots> = 2 * \<dots>" by (simp add: mult_2)
   also from insert(3) have "\<dots> = 2 ^ Suc (card A)" by simp
   also from insert(1,2) have "Suc (card A) = card (insert x A)"
     by (rule card_insert_disjoint [symmetric])
   finally show ?case .
 qed
 
 
 subsection \<open>Code generator tweak\<close>
 
 code_identifier
   code_module Power \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 end
diff --git a/src/HOL/Presburger.thy b/src/HOL/Presburger.thy
--- a/src/HOL/Presburger.thy
+++ b/src/HOL/Presburger.thy
@@ -1,510 +1,566 @@
 (* Title:      HOL/Presburger.thy
    Author:     Amine Chaieb, TU Muenchen
 *)
 
 section \<open>Decision Procedure for Presburger Arithmetic\<close>
 
 theory Presburger
 imports Groebner_Basis Set_Interval
 keywords "try0" :: diag
 begin
 
 ML_file \<open>Tools/Qelim/qelim.ML\<close>
 ML_file \<open>Tools/Qelim/cooper_procedure.ML\<close>
 
 subsection\<open>The \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Properties\<close>
 
 lemma minf:
   "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk> 
      \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<and> Q x) = (P' x \<and> Q' x)"
   "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x<z. P x = P' x; \<exists>z.\<forall>x<z. Q x = Q' x\<rbrakk> 
      \<Longrightarrow> \<exists>z.\<forall>x<z. (P x \<or> Q x) = (P' x \<or> Q' x)"
   "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x = t) = False"
   "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<noteq> t) = True"
   "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x < t) = True"
   "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<le> t) = True"
   "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x > t) = False"
   "\<exists>(z ::'a::{linorder}).\<forall>x<z.(x \<ge> t) = False"
   "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (d dvd x + s) = (d dvd x + s)"
   "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})<z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
   "\<exists>z.\<forall>x<z. F = F"
-  by ((erule exE, erule exE,rule_tac x="min z za" in exI,simp)+, (rule_tac x="t" in exI,fastforce)+) simp_all
+proof safe
+  fix z1 z2
+  assume "\<forall>x<z1. P x = P' x" and "\<forall>x<z2. Q x = Q' x"
+  then have "\<forall>x < min z1 z2. (P x \<and> Q x) = (P' x \<and> Q' x)"
+    by simp
+  then show "\<exists>z. \<forall>x<z. (P x \<and> Q x) = (P' x \<and> Q' x)"
+    by blast
+next
+  fix z1 z2
+  assume "\<forall>x<z1. P x = P' x" and "\<forall>x<z2. Q x = Q' x"
+  then have "\<forall>x < min z1 z2. (P x \<or> Q x) = (P' x \<or> Q' x)"
+    by simp
+  then show "\<exists>z. \<forall>x<z. (P x \<or> Q x) = (P' x \<or> Q' x)"
+    by blast
+next
+  have "\<forall>x<t. x \<le> t"
+    by fastforce
+  then show "\<exists>z. \<forall>x<z. (x \<le> t) = True"
+    by auto
+next
+  have "\<forall>x<t. \<not> t < x"
+    by fastforce
+  then show "\<exists>z. \<forall>x<z. (t < x) = False"
+    by auto
+next
+  have "\<forall>x<t. \<not> t \<le> x"
+    by fastforce
+  then show "\<exists>z. \<forall>x<z. (t \<le> x) = False"
+    by auto
+qed auto
 
 lemma pinf:
   "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk> 
      \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<and> Q x) = (P' x \<and> Q' x)"
   "\<lbrakk>\<exists>(z ::'a::linorder).\<forall>x>z. P x = P' x; \<exists>z.\<forall>x>z. Q x = Q' x\<rbrakk> 
      \<Longrightarrow> \<exists>z.\<forall>x>z. (P x \<or> Q x) = (P' x \<or> Q' x)"
   "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x = t) = False"
   "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<noteq> t) = True"
   "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x < t) = False"
   "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<le> t) = False"
   "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x > t) = True"
   "\<exists>(z ::'a::{linorder}).\<forall>x>z.(x \<ge> t) = True"
   "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (d dvd x + s) = (d dvd x + s)"
   "\<exists>z.\<forall>(x::'b::{linorder,plus,Rings.dvd})>z. (\<not> d dvd x + s) = (\<not> d dvd x + s)"
   "\<exists>z.\<forall>x>z. F = F"
-  by ((erule exE, erule exE,rule_tac x="max z za" in exI,simp)+,(rule_tac x="t" in exI,fastforce)+) simp_all
+proof safe
+  fix z1 z2
+  assume "\<forall>x>z1. P x = P' x" and "\<forall>x>z2. Q x = Q' x"
+  then have "\<forall>x > max z1 z2. (P x \<and> Q x) = (P' x \<and> Q' x)"
+    by simp
+  then show "\<exists>z. \<forall>x>z. (P x \<and> Q x) = (P' x \<and> Q' x)"
+    by blast
+next
+  fix z1 z2
+  assume "\<forall>x>z1. P x = P' x" and "\<forall>x>z2. Q x = Q' x"
+  then have "\<forall>x > max z1 z2. (P x \<or> Q x) = (P' x \<or> Q' x)"
+    by simp
+  then show "\<exists>z. \<forall>x>z. (P x \<or> Q x) = (P' x \<or> Q' x)"
+    by blast
+next
+  have "\<forall>x>t. \<not> x < t"
+    by fastforce
+  then show "\<exists>z. \<forall>x>z. x < t = False"
+    by blast
+next
+  have "\<forall>x>t. \<not> x \<le> t"
+    by fastforce
+  then show "\<exists>z. \<forall>x>z. x \<le> t = False"
+    by blast
+next
+  have "\<forall>x>t. t \<le> x"
+    by fastforce
+  then show "\<exists>z. \<forall>x>z. t \<le> x = True"
+    by blast
+qed auto
 
 lemma inf_period:
   "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk> 
     \<Longrightarrow> \<forall>x k. (P x \<and> Q x) = (P (x - k*D) \<and> Q (x - k*D))"
   "\<lbrakk>\<forall>x k. P x = P (x - k*D); \<forall>x k. Q x = Q (x - k*D)\<rbrakk> 
     \<Longrightarrow> \<forall>x k. (P x \<or> Q x) = (P (x - k*D) \<or> Q (x - k*D))"
   "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (d dvd x + t) = (d dvd (x - k*D) + t)"
   "(d::'a::{comm_ring,Rings.dvd}) dvd D \<Longrightarrow> \<forall>x k. (\<not>d dvd x + t) = (\<not>d dvd (x - k*D) + t)"
   "\<forall>x k. F = F"
 apply (auto elim!: dvdE simp add: algebra_simps)
 unfolding mult.assoc [symmetric] distrib_right [symmetric] left_diff_distrib [symmetric]
 unfolding dvd_def mult.commute [of d] 
 by auto
 
 subsection\<open>The A and B sets\<close>
 lemma bset:
   "\<lbrakk>\<forall>x.(\<forall>j \<in> {1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
      \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow> 
   \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x - D) \<and> Q (x - D))"
   "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> P x \<longrightarrow> P(x - D) ;
      \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> Q x \<longrightarrow> Q(x - D)\<rbrakk> \<Longrightarrow> 
   \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x - D) \<or> Q (x - D))"
   "\<lbrakk>D>0; t - 1\<in> B\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))"
   "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))"
   "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))"
   "D>0 \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t))"
   "\<lbrakk>D>0 ; t \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t))"
   "\<lbrakk>D>0 ; t - 1 \<in> B\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t))"
   "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t))"
   "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x - D) + t))"
   "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j) \<longrightarrow> F \<longrightarrow> F"
 proof (blast, blast)
   assume dp: "D > 0" and tB: "t - 1\<in> B"
   show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x = t) \<longrightarrow> (x - D = t))" 
     apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t - 1"]) 
     apply algebra using dp tB by simp_all
 next
   assume dp: "D > 0" and tB: "t \<in> B"
   show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x - D \<noteq> t))" 
     apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
     apply algebra
     using dp tB by simp_all
 next
   assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x < t) \<longrightarrow> (x - D < t))" by arith
 next
   assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x - D \<le> t)" by arith
 next
   assume dp: "D > 0" and tB:"t \<in> B"
   {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x > t" and ng: "\<not> (x - D) > t"
     hence "x -t \<le> D" and "1 \<le> x - t" by simp+
       hence "\<exists>j \<in> {1 .. D}. x - t = j" by auto
       hence "\<exists>j \<in> {1 .. D}. x = t + j" by (simp add: algebra_simps)
       with nob tB have "False" by simp}
   thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x > t) \<longrightarrow> (x - D > t)" by blast
 next
   assume dp: "D > 0" and tB:"t - 1\<in> B"
   {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j" and g: "x \<ge> t" and ng: "\<not> (x - D) \<ge> t"
     hence "x - (t - 1) \<le> D" and "1 \<le> x - (t - 1)" by simp+
       hence "\<exists>j \<in> {1 .. D}. x - (t - 1) = j" by auto
       hence "\<exists>j \<in> {1 .. D}. x = (t - 1) + j" by (simp add: algebra_simps)
       with nob tB have "False" by simp}
   thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x - D \<ge> t)" by blast
 next
   assume d: "d dvd D"
   {fix x assume H: "d dvd x + t" with d have "d dvd (x - D) + t" by algebra}
   thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x - D) + t)" by simp
 next
   assume d: "d dvd D"
   {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not> d dvd (x - D) + t"
       by (clarsimp simp add: dvd_def,erule_tac x= "ka + k" in allE,simp add: algebra_simps)}
   thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>B. x \<noteq> b + j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x - D) + t)" by auto
 qed blast
 
 lemma aset:
   "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
      \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow> 
   \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> (P x \<and> Q x) \<longrightarrow> (P(x + D) \<and> Q (x + D))"
   "\<lbrakk>\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> P x \<longrightarrow> P(x + D) ;
      \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> Q x \<longrightarrow> Q(x + D)\<rbrakk> \<Longrightarrow> 
   \<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (P x \<or> Q x) \<longrightarrow> (P(x + D) \<or> Q (x + D))"
   "\<lbrakk>D>0; t + 1\<in> A\<rbrakk> \<Longrightarrow> (\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))"
   "\<lbrakk>D>0 ; t \<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))"
   "\<lbrakk>D>0; t\<in> A\<rbrakk> \<Longrightarrow>(\<forall>(x::int). (\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t))"
   "\<lbrakk>D>0; t + 1 \<in> A\<rbrakk> \<Longrightarrow> (\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t))"
   "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))"
   "D>0 \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t))"
   "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t))"
   "d dvd D \<Longrightarrow>(\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not> d dvd (x + D) + t))"
   "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j) \<longrightarrow> F \<longrightarrow> F"
 proof (blast, blast)
   assume dp: "D > 0" and tA: "t + 1 \<in> A"
   show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x = t) \<longrightarrow> (x + D = t))" 
     apply (rule allI, rule impI,erule ballE[where x="1"],erule ballE[where x="t + 1"])
     using dp tA by simp_all
 next
   assume dp: "D > 0" and tA: "t \<in> A"
   show "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<noteq> t) \<longrightarrow> (x + D \<noteq> t))" 
     apply (rule allI, rule impI,erule ballE[where x="D"],erule ballE[where x="t"])
     using dp tA by simp_all
 next
   assume dp: "D > 0" thus "(\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x > t) \<longrightarrow> (x + D > t))" by arith
 next
   assume dp: "D > 0" thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<ge> t) \<longrightarrow> (x + D \<ge> t)" by arith
 next
   assume dp: "D > 0" and tA:"t \<in> A"
   {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x < t" and ng: "\<not> (x + D) < t"
     hence "t - x \<le> D" and "1 \<le> t - x" by simp+
       hence "\<exists>j \<in> {1 .. D}. t - x = j" by auto
       hence "\<exists>j \<in> {1 .. D}. x = t - j" by (auto simp add: algebra_simps) 
       with nob tA have "False" by simp}
   thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x < t) \<longrightarrow> (x + D < t)" by blast
 next
   assume dp: "D > 0" and tA:"t + 1\<in> A"
   {fix x assume nob: "\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j" and g: "x \<le> t" and ng: "\<not> (x + D) \<le> t"
     hence "(t + 1) - x \<le> D" and "1 \<le> (t + 1) - x" by (simp_all add: algebra_simps)
       hence "\<exists>j \<in> {1 .. D}. (t + 1) - x = j" by auto
       hence "\<exists>j \<in> {1 .. D}. x = (t + 1) - j" by (auto simp add: algebra_simps)
       with nob tA have "False" by simp}
   thus "\<forall>x.(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (x \<le> t) \<longrightarrow> (x + D \<le> t)" by blast
 next
   assume d: "d dvd D"
-  {fix x assume H: "d dvd x + t" with d have "d dvd (x + D) + t"
-      by (clarsimp simp add: dvd_def,rule_tac x= "ka + k" in exI,simp add: algebra_simps)}
+  have "\<And>x. d dvd x + t \<Longrightarrow> d dvd x + D + t"
+  proof -
+    fix x
+    assume H: "d dvd x + t"
+    then obtain ka where "x + t = d * ka"
+      unfolding dvd_def by blast
+    moreover from d obtain k where *:"D = d * k"
+      unfolding dvd_def by blast
+    ultimately have "x + d * k + t = d * (ka + k)"
+      by (simp add: algebra_simps)
+    then show "d dvd (x + D) + t"
+      using * unfolding dvd_def by blast
+  qed
   thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (d dvd x+t) \<longrightarrow> (d dvd (x + D) + t)" by simp
 next
   assume d: "d dvd D"
   {fix x assume H: "\<not>(d dvd x + t)" with d have "\<not>d dvd (x + D) + t"
       by (clarsimp simp add: dvd_def,erule_tac x= "ka - k" in allE,simp add: algebra_simps)}
   thus "\<forall>(x::int).(\<forall>j\<in>{1 .. D}. \<forall>b\<in>A. x \<noteq> b - j)\<longrightarrow> (\<not>d dvd x+t) \<longrightarrow> (\<not>d dvd (x + D) + t)" by auto
 qed blast
 
 subsection\<open>Cooper's Theorem \<open>-\<infinity>\<close> and \<open>+\<infinity>\<close> Version\<close>
 
 subsubsection\<open>First some trivial facts about periodic sets or predicates\<close>
 lemma periodic_finite_ex:
   assumes dpos: "(0::int) < d" and modd: "\<forall>x k. P x = P(x - k*d)"
   shows "(\<exists>x. P x) = (\<exists>j \<in> {1..d}. P j)"
   (is "?LHS = ?RHS")
 proof
   assume ?LHS
   then obtain x where P: "P x" ..
   have "x mod d = x - (x div d)*d" by(simp add:mult_div_mod_eq [symmetric] ac_simps eq_diff_eq)
   hence Pmod: "P x = P(x mod d)" using modd by simp
   show ?RHS
   proof (cases)
     assume "x mod d = 0"
     hence "P 0" using P Pmod by simp
     moreover have "P 0 = P(0 - (-1)*d)" using modd by blast
     ultimately have "P d" by simp
     moreover have "d \<in> {1..d}" using dpos by simp
     ultimately show ?RHS ..
   next
     assume not0: "x mod d \<noteq> 0"
     have "P(x mod d)" using dpos P Pmod by simp
     moreover have "x mod d \<in> {1..d}"
     proof -
       from dpos have "0 \<le> x mod d" by(rule pos_mod_sign)
       moreover from dpos have "x mod d < d" by(rule pos_mod_bound)
       ultimately show ?thesis using not0 by simp
     qed
     ultimately show ?RHS ..
   qed
 qed auto
 
 subsubsection\<open>The \<open>-\<infinity>\<close> Version\<close>
 
 lemma decr_lemma: "0 < (d::int) \<Longrightarrow> x - (\<bar>x - z\<bar> + 1) * d < z"
   by (induct rule: int_gr_induct) (simp_all add: int_distrib)
 
 lemma incr_lemma: "0 < (d::int) \<Longrightarrow> z < x + (\<bar>x - z\<bar> + 1) * d"
   by (induct rule: int_gr_induct) (simp_all add: int_distrib)
 
 lemma decr_mult_lemma:
   assumes dpos: "(0::int) < d" and minus: "\<forall>x. P x \<longrightarrow> P(x - d)" and knneg: "0 <= k"
   shows "\<forall>x. P x \<longrightarrow> P(x - k*d)"
 using knneg
 proof (induct rule:int_ge_induct)
   case base thus ?case by simp
 next
   case (step i)
   {fix x
     have "P x \<longrightarrow> P (x - i * d)" using step.hyps by blast
     also have "\<dots> \<longrightarrow> P(x - (i + 1) * d)" using minus[THEN spec, of "x - i * d"]
       by (simp add: algebra_simps)
     ultimately have "P x \<longrightarrow> P(x - (i + 1) * d)" by blast}
   thus ?case ..
 qed
 
 lemma  minusinfinity:
   assumes dpos: "0 < d" and
     P1eqP1: "\<forall>x k. P1 x = P1(x - k*d)" and ePeqP1: "\<exists>z::int. \<forall>x. x < z \<longrightarrow> (P x = P1 x)"
   shows "(\<exists>x. P1 x) \<longrightarrow> (\<exists>x. P x)"
 proof
   assume eP1: "\<exists>x. P1 x"
   then obtain x where P1: "P1 x" ..
   from ePeqP1 obtain z where P1eqP: "\<forall>x. x < z \<longrightarrow> (P x = P1 x)" ..
   let ?w = "x - (\<bar>x - z\<bar> + 1) * d"
   from dpos have w: "?w < z" by(rule decr_lemma)
   have "P1 x = P1 ?w" using P1eqP1 by blast
   also have "\<dots> = P(?w)" using w P1eqP by blast
   finally have "P ?w" using P1 by blast
   thus "\<exists>x. P x" ..
 qed
 
 lemma cpmi: 
   assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x< z. P x = P' x"
   and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> B. x \<noteq> b+j) \<longrightarrow> P (x) \<longrightarrow> P (x - D)"
   and pd: "\<forall> x k. P' x = P' (x-k*D)"
   shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists>j \<in> {1..D}. \<exists> b \<in> B. P (b+j)))"
          (is "?L = (?R1 \<or> ?R2)")
 proof-
  {assume "?R2" hence "?L"  by blast}
  moreover
  {assume H:"?R1" hence "?L" using minusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
  moreover 
  { fix x
    assume P: "P x" and H: "\<not> ?R2"
    {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>B. P (b + j))" and P: "P y"
      hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. y = b+j)" by auto
      with nb P  have "P (y - D)" by auto }
    hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> B. P(b+j)) \<longrightarrow> P (x) \<longrightarrow> P (x - D)" by blast
    with H P have th: " \<forall>x. P x \<longrightarrow> P (x - D)" by auto
    from p1 obtain z where z: "\<forall>x. x < z \<longrightarrow> (P x = P' x)" by blast
    let ?y = "x - (\<bar>x - z\<bar> + 1)*D"
    have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
    from dp have yz: "?y < z" using decr_lemma[OF dp] by simp   
    from z[rule_format, OF yz] decr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
    with periodic_finite_ex[OF dp pd]
    have "?R1" by blast}
  ultimately show ?thesis by blast
 qed
 
 subsubsection \<open>The \<open>+\<infinity>\<close> Version\<close>
 
 lemma  plusinfinity:
   assumes dpos: "(0::int) < d" and
     P1eqP1: "\<forall>x k. P' x = P'(x - k*d)" and ePeqP1: "\<exists> z. \<forall> x>z. P x = P' x"
   shows "(\<exists> x. P' x) \<longrightarrow> (\<exists> x. P x)"
 proof
   assume eP1: "\<exists>x. P' x"
   then obtain x where P1: "P' x" ..
   from ePeqP1 obtain z where P1eqP: "\<forall>x>z. P x = P' x" ..
   let ?w' = "x + (\<bar>x - z\<bar> + 1) * d"
   let ?w = "x - (- (\<bar>x - z\<bar> + 1)) * d"
   have ww'[simp]: "?w = ?w'" by (simp add: algebra_simps)
   from dpos have w: "?w > z" by(simp only: ww' incr_lemma)
   hence "P' x = P' ?w" using P1eqP1 by blast
   also have "\<dots> = P(?w)" using w P1eqP by blast
   finally have "P ?w" using P1 by blast
   thus "\<exists>x. P x" ..
 qed
 
 lemma incr_mult_lemma:
   assumes dpos: "(0::int) < d" and plus: "\<forall>x::int. P x \<longrightarrow> P(x + d)" and knneg: "0 <= k"
   shows "\<forall>x. P x \<longrightarrow> P(x + k*d)"
 using knneg
 proof (induct rule:int_ge_induct)
   case base thus ?case by simp
 next
   case (step i)
   {fix x
     have "P x \<longrightarrow> P (x + i * d)" using step.hyps by blast
     also have "\<dots> \<longrightarrow> P(x + (i + 1) * d)" using plus[THEN spec, of "x + i * d"]
       by (simp add:int_distrib ac_simps)
     ultimately have "P x \<longrightarrow> P(x + (i + 1) * d)" by blast}
   thus ?case ..
 qed
 
 lemma cppi: 
   assumes dp: "0 < D" and p1:"\<exists>z. \<forall> x> z. P x = P' x"
   and nb:"\<forall>x.(\<forall> j\<in> {1..D}. \<forall>(b::int) \<in> A. x \<noteq> b - j) \<longrightarrow> P (x) \<longrightarrow> P (x + D)"
   and pd: "\<forall> x k. P' x= P' (x-k*D)"
   shows "(\<exists>x. P x) = ((\<exists>j \<in> {1..D} . P' j) \<or> (\<exists> j \<in> {1..D}. \<exists> b\<in> A. P (b - j)))" (is "?L = (?R1 \<or> ?R2)")
 proof-
  {assume "?R2" hence "?L"  by blast}
  moreover
  {assume H:"?R1" hence "?L" using plusinfinity[OF dp pd p1] periodic_finite_ex[OF dp pd] by simp}
  moreover 
  { fix x
    assume P: "P x" and H: "\<not> ?R2"
    {fix y assume "\<not> (\<exists>j\<in>{1..D}. \<exists>b\<in>A. P (b - j))" and P: "P y"
      hence "\<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. y = b - j)" by auto
      with nb P  have "P (y + D)" by auto }
    hence "\<forall>x. \<not>(\<exists>(j::int) \<in> {1..D}. \<exists>(b::int) \<in> A. P(b-j)) \<longrightarrow> P (x) \<longrightarrow> P (x + D)" by blast
    with H P have th: " \<forall>x. P x \<longrightarrow> P (x + D)" by auto
    from p1 obtain z where z: "\<forall>x. x > z \<longrightarrow> (P x = P' x)" by blast
    let ?y = "x + (\<bar>x - z\<bar> + 1)*D"
    have zp: "0 <= (\<bar>x - z\<bar> + 1)" by arith
    from dp have yz: "?y > z" using incr_lemma[OF dp] by simp
    from z[rule_format, OF yz] incr_mult_lemma[OF dp th zp, rule_format, OF P] have th2: " P' ?y" by auto
    with periodic_finite_ex[OF dp pd]
    have "?R1" by blast}
  ultimately show ?thesis by blast
 qed
 
 lemma simp_from_to: "{i..j::int} = (if j < i then {} else insert i {i+1..j})"
 apply(simp add:atLeastAtMost_def atLeast_def atMost_def)
 apply(fastforce)
 done
 
 theorem unity_coeff_ex: "(\<exists>(x::'a::{semiring_0,Rings.dvd}). P (l * x)) \<equiv> (\<exists>x. l dvd (x + 0) \<and> P x)"
-  apply (rule eq_reflection [symmetric])
-  apply (rule iffI)
-  defer
-  apply (erule exE)
-  apply (rule_tac x = "l * x" in exI)
-  apply (simp add: dvd_def)
-  apply (rule_tac x = x in exI, simp)
-  apply (erule exE)
-  apply (erule conjE)
-  apply simp
-  apply (erule dvdE)
-  apply (rule_tac x = k in exI)
-  apply simp
-  done
+  unfolding dvd_def by (rule eq_reflection, rule iffI) auto
 
 lemma zdvd_mono:
   fixes k m t :: int
   assumes "k \<noteq> 0"
   shows "m dvd t \<equiv> k * m dvd k * t" 
   using assms by simp
 
 lemma uminus_dvd_conv:
   fixes d t :: int
   shows "d dvd t \<equiv> - d dvd t" and "d dvd t \<equiv> d dvd - t"
   by simp_all
 
 text \<open>\bigskip Theorems for transforming predicates on nat to predicates on \<open>int\<close>\<close>
 
 lemma zdiff_int_split: "P (int (x - y)) =
   ((y \<le> x \<longrightarrow> P (int x - int y)) \<and> (x < y \<longrightarrow> P 0))"
   by (cases "y \<le> x") (simp_all add: of_nat_diff)
 
 text \<open>
   \medskip Specific instances of congruence rules, to prevent
   simplifier from looping.\<close>
 
 theorem imp_le_cong:
   "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<longrightarrow> P) = (0 \<le> x' \<longrightarrow> P')"
   by simp
 
 theorem conj_le_cong:
   "\<lbrakk>x = x'; 0 \<le> x' \<Longrightarrow> P = P'\<rbrakk> \<Longrightarrow> (0 \<le> (x::int) \<and> P) = (0 \<le> x' \<and> P')"
   by (simp cong: conj_cong)
 
 ML_file \<open>Tools/Qelim/cooper.ML\<close>
 
 method_setup presburger = \<open>
   let
     fun keyword k = Scan.lift (Args.$$$ k -- Args.colon) >> K ()
     fun simple_keyword k = Scan.lift (Args.$$$ k) >> K ()
     val addN = "add"
     val delN = "del"
     val elimN = "elim"
     val any_keyword = keyword addN || keyword delN || simple_keyword elimN
     val thms = Scan.repeats (Scan.unless any_keyword Attrib.multi_thm)
   in
     Scan.optional (simple_keyword elimN >> K false) true --
     Scan.optional (keyword addN |-- thms) [] --
     Scan.optional (keyword delN |-- thms) [] >>
     (fn ((elim, add_ths), del_ths) => fn ctxt =>
       SIMPLE_METHOD' (Cooper.tac elim add_ths del_ths ctxt))
   end
 \<close> "Cooper's algorithm for Presburger arithmetic"
 
 declare mod_eq_0_iff_dvd [presburger]
 declare mod_by_Suc_0 [presburger] 
 declare mod_0 [presburger]
 declare mod_by_1 [presburger]
 declare mod_self [presburger]
 declare div_by_0 [presburger]
 declare mod_by_0 [presburger]
 declare mod_div_trivial [presburger]
 declare mult_div_mod_eq [presburger]
 declare div_mult_mod_eq [presburger]
 declare mod_mult_self1 [presburger]
 declare mod_mult_self2 [presburger]
 declare mod2_Suc_Suc [presburger]
 declare not_mod_2_eq_0_eq_1 [presburger] 
 declare nat_zero_less_power_iff [presburger]
 
 lemma [presburger, algebra]: "m mod 2 = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
 lemma [presburger, algebra]: "m mod 2 = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
 lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = (1::nat) \<longleftrightarrow> \<not> 2 dvd m " by presburger
 lemma [presburger, algebra]: "m mod (Suc (Suc 0)) = Suc 0 \<longleftrightarrow> \<not> 2 dvd m " by presburger
 lemma [presburger, algebra]: "m mod 2 = (1::int) \<longleftrightarrow> \<not> 2 dvd m " by presburger
 
 context semiring_parity
 begin
 
 declare even_mult_iff [presburger]
 
 declare even_power [presburger]
 
 lemma [presburger]:
   "even (a + b) \<longleftrightarrow> even a \<and> even b \<or> odd a \<and> odd b"
   by auto
 
 end
 
 context ring_parity
 begin
 
 declare even_minus [presburger]
 
 end
 
 context linordered_idom
 begin
 
 declare zero_le_power_eq [presburger]
 
 declare zero_less_power_eq [presburger]
 
 declare power_less_zero_eq [presburger]
   
 declare power_le_zero_eq [presburger]
 
 end
 
 declare even_Suc [presburger]
 
 lemma [presburger]:
   "Suc n div Suc (Suc 0) = n div Suc (Suc 0) \<longleftrightarrow> even n"
   by presburger
 
 declare even_diff_nat [presburger]
 
 lemma [presburger]:
   fixes k :: int
   shows "(k + 1) div 2 = k div 2 \<longleftrightarrow> even k"
   by presburger
 
 lemma [presburger]:
   fixes k :: int
   shows "(k + 1) div 2 = k div 2 + 1 \<longleftrightarrow> odd k"
   by presburger
 
 lemma [presburger]:
   "even n \<longleftrightarrow> even (int n)"
   by simp
   
 
 subsection \<open>Nice facts about division by \<^term>\<open>4\<close>\<close>  
 
 lemma even_even_mod_4_iff:
   "even (n::nat) \<longleftrightarrow> even (n mod 4)"
   by presburger
 
 lemma odd_mod_4_div_2:
   "n mod 4 = (3::nat) \<Longrightarrow> odd ((n - Suc 0) div 2)"
   by presburger
 
 lemma even_mod_4_div_2:
   "n mod 4 = Suc 0 \<Longrightarrow> even ((n - Suc 0) div 2)"
   by presburger
 
 
 subsection \<open>Try0\<close>
 
 ML_file \<open>Tools/try0.ML\<close>
 
 end
diff --git a/src/HOL/Product_Type.thy b/src/HOL/Product_Type.thy
--- a/src/HOL/Product_Type.thy
+++ b/src/HOL/Product_Type.thy
@@ -1,1353 +1,1376 @@
 (*  Title:      HOL/Product_Type.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 *)
 
 section \<open>Cartesian products\<close>
 
 theory Product_Type
   imports Typedef Inductive Fun
   keywords "inductive_set" "coinductive_set" :: thy_defn
 begin
 
 subsection \<open>\<^typ>\<open>bool\<close> is a datatype\<close>
 
 free_constructors (discs_sels) case_bool for True | False
   by auto
 
 text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype True False by (auto intro: bool_induct)
 
 setup \<open>Sign.parent_path\<close>
 
 text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "bool"\<close>
 
 lemmas induct = old.bool.induct
 lemmas inducts = old.bool.inducts
 lemmas rec = old.bool.rec
 lemmas simps = bool.distinct bool.case bool.rec
 
 setup \<open>Sign.parent_path\<close>
 
 declare case_split [cases type: bool]
   \<comment> \<open>prefer plain propositional version\<close>
 
 lemma [code]: "HOL.equal False P \<longleftrightarrow> \<not> P"
   and [code]: "HOL.equal True P \<longleftrightarrow> P"
   and [code]: "HOL.equal P False \<longleftrightarrow> \<not> P"
   and [code]: "HOL.equal P True \<longleftrightarrow> P"
   and [code nbe]: "HOL.equal P P \<longleftrightarrow> True"
   by (simp_all add: equal)
 
 lemma If_case_cert:
   assumes "CASE \<equiv> (\<lambda>b. If b f g)"
   shows "(CASE True \<equiv> f) &&& (CASE False \<equiv> g)"
   using assms by simp_all
 
 setup \<open>Code.declare_case_global @{thm If_case_cert}\<close>
 
 code_printing
   constant "HOL.equal :: bool \<Rightarrow> bool \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
 | class_instance "bool" :: "equal" \<rightharpoonup> (Haskell) -
 
 
 subsection \<open>The \<open>unit\<close> type\<close>
 
 typedef unit = "{True}"
   by auto
 
 definition Unity :: unit  ("'(')")
   where "() = Abs_unit True"
 
 lemma unit_eq [no_atp]: "u = ()"
   by (induct u) (simp add: Unity_def)
 
 text \<open>
   Simplification procedure for @{thm [source] unit_eq}.  Cannot use
   this rule directly --- it loops!
 \<close>
 
 simproc_setup unit_eq ("x::unit") = \<open>
   fn _ => fn _ => fn ct =>
     if HOLogic.is_unit (Thm.term_of ct) then NONE
     else SOME (mk_meta_eq @{thm unit_eq})
 \<close>
 
 free_constructors case_unit for "()"
   by auto
 
 text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype "()" by simp
 
 setup \<open>Sign.parent_path\<close>
 
 text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "unit"\<close>
 
 lemmas induct = old.unit.induct
 lemmas inducts = old.unit.inducts
 lemmas rec = old.unit.rec
 lemmas simps = unit.case unit.rec
 
 setup \<open>Sign.parent_path\<close>
 
 lemma unit_all_eq1: "(\<And>x::unit. PROP P x) \<equiv> PROP P ()"
   by simp
 
 lemma unit_all_eq2: "(\<And>x::unit. PROP P) \<equiv> PROP P"
   by (rule triv_forall_equality)
 
 text \<open>
   This rewrite counters the effect of simproc \<open>unit_eq\<close> on @{term
   [source] "\<lambda>u::unit. f u"}, replacing it by @{term [source]
   f} rather than by @{term [source] "\<lambda>u. f ()"}.
 \<close>
 
 lemma unit_abs_eta_conv [simp]: "(\<lambda>u::unit. f ()) = f"
   by (rule ext) simp
 
 lemma UNIV_unit: "UNIV = {()}"
   by auto
 
 instantiation unit :: default
 begin
 
 definition "default = ()"
 
 instance ..
 
 end
 
 instantiation unit :: "{complete_boolean_algebra,complete_linorder,wellorder}"
 begin
 
 definition less_eq_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
   where "(_::unit) \<le> _ \<longleftrightarrow> True"
 
 lemma less_eq_unit [iff]: "u \<le> v" for u v :: unit
   by (simp add: less_eq_unit_def)
 
 definition less_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool"
   where "(_::unit) < _ \<longleftrightarrow> False"
 
 lemma less_unit [iff]: "\<not> u < v" for u v :: unit
   by (simp_all add: less_eq_unit_def less_unit_def)
 
 definition bot_unit :: unit
   where [code_unfold]: "\<bottom> = ()"
 
 definition top_unit :: unit
   where [code_unfold]: "\<top> = ()"
 
 definition inf_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
   where [simp]: "_ \<sqinter> _ = ()"
 
 definition sup_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit"
   where [simp]: "_ \<squnion> _ = ()"
 
 definition Inf_unit :: "unit set \<Rightarrow> unit"
   where [simp]: "\<Sqinter>_ = ()"
 
 definition Sup_unit :: "unit set \<Rightarrow> unit"
   where [simp]: "\<Squnion>_ = ()"
 
 definition uminus_unit :: "unit \<Rightarrow> unit"
   where [simp]: "- _ = ()"
 
 declare less_eq_unit_def [abs_def, code_unfold]
   less_unit_def [abs_def, code_unfold]
   inf_unit_def [abs_def, code_unfold]
   sup_unit_def [abs_def, code_unfold]
   Inf_unit_def [abs_def, code_unfold]
   Sup_unit_def [abs_def, code_unfold]
   uminus_unit_def [abs_def, code_unfold]
 
 instance
   by intro_classes auto
 
 end
 
 lemma [code]: "HOL.equal u v \<longleftrightarrow> True" for u v :: unit
-  unfolding equal unit_eq [of u] unit_eq [of v] by rule+
+  unfolding equal unit_eq [of u] unit_eq [of v] by (rule iffI TrueI refl)+
 
 code_printing
   type_constructor unit \<rightharpoonup>
     (SML) "unit"
     and (OCaml) "unit"
     and (Haskell) "()"
     and (Scala) "Unit"
 | constant Unity \<rightharpoonup>
     (SML) "()"
     and (OCaml) "()"
     and (Haskell) "()"
     and (Scala) "()"
 | class_instance unit :: equal \<rightharpoonup>
     (Haskell) -
 | constant "HOL.equal :: unit \<Rightarrow> unit \<Rightarrow> bool" \<rightharpoonup>
     (Haskell) infix 4 "=="
 
 code_reserved SML
   unit
 
 code_reserved OCaml
   unit
 
 code_reserved Scala
   Unit
 
 
 subsection \<open>The product type\<close>
 
 subsubsection \<open>Type definition\<close>
 
 definition Pair_Rep :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
   where "Pair_Rep a b = (\<lambda>x y. x = a \<and> y = b)"
 
 definition "prod = {f. \<exists>a b. f = Pair_Rep (a::'a) (b::'b)}"
 
 typedef ('a, 'b) prod ("(_ \<times>/ _)" [21, 20] 20) = "prod :: ('a \<Rightarrow> 'b \<Rightarrow> bool) set"
   unfolding prod_def by auto
 
 type_notation (ASCII)
   prod  (infixr "*" 20)
 
 definition Pair :: "'a \<Rightarrow> 'b \<Rightarrow> 'a \<times> 'b"
   where "Pair a b = Abs_prod (Pair_Rep a b)"
 
 lemma prod_cases: "(\<And>a b. P (Pair a b)) \<Longrightarrow> P p"
   by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)
 
 free_constructors case_prod for Pair fst snd
 proof -
   fix P :: bool and p :: "'a \<times> 'b"
   show "(\<And>x1 x2. p = Pair x1 x2 \<Longrightarrow> P) \<Longrightarrow> P"
     by (cases p) (auto simp add: prod_def Pair_def Pair_Rep_def)
 next
   fix a c :: 'a and b d :: 'b
   have "Pair_Rep a b = Pair_Rep c d \<longleftrightarrow> a = c \<and> b = d"
     by (auto simp add: Pair_Rep_def fun_eq_iff)
   moreover have "Pair_Rep a b \<in> prod" and "Pair_Rep c d \<in> prod"
     by (auto simp add: prod_def)
   ultimately show "Pair a b = Pair c d \<longleftrightarrow> a = c \<and> b = d"
     by (simp add: Pair_def Abs_prod_inject)
 qed
 
 text \<open>Avoid name clashes by prefixing the output of \<open>old_rep_datatype\<close> with \<open>old\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "old"\<close>
 
 old_rep_datatype Pair
   by (erule prod_cases) (rule prod.inject)
 
 setup \<open>Sign.parent_path\<close>
 
 text \<open>But erase the prefix for properties that are not generated by \<open>free_constructors\<close>.\<close>
 
 setup \<open>Sign.mandatory_path "prod"\<close>
 
 declare old.prod.inject [iff del]
 
 lemmas induct = old.prod.induct
 lemmas inducts = old.prod.inducts
 lemmas rec = old.prod.rec
 lemmas simps = prod.inject prod.case prod.rec
 
 setup \<open>Sign.parent_path\<close>
 
 declare prod.case [nitpick_simp del]
 declare old.prod.case_cong_weak [cong del]
 declare prod.case_eq_if [mono]
 declare prod.split [no_atp]
 declare prod.split_asm [no_atp]
 
 text \<open>
   @{thm [source] prod.split} could be declared as \<open>[split]\<close>
   done after the Splitter has been speeded up significantly;
   precompute the constants involved and don't do anything unless the
   current goal contains one of those constants.
 \<close>
 
 
 subsubsection \<open>Tuple syntax\<close>
 
 text \<open>
   Patterns -- extends pre-defined type \<^typ>\<open>pttrn\<close> used in
   abstractions.
 \<close>
 
 nonterminal tuple_args and patterns
 syntax
   "_tuple"      :: "'a \<Rightarrow> tuple_args \<Rightarrow> 'a \<times> 'b"        ("(1'(_,/ _'))")
   "_tuple_arg"  :: "'a \<Rightarrow> tuple_args"                   ("_")
   "_tuple_args" :: "'a \<Rightarrow> tuple_args \<Rightarrow> tuple_args"     ("_,/ _")
   "_pattern"    :: "pttrn \<Rightarrow> patterns \<Rightarrow> pttrn"         ("'(_,/ _')")
   ""            :: "pttrn \<Rightarrow> patterns"                  ("_")
   "_patterns"   :: "pttrn \<Rightarrow> patterns \<Rightarrow> patterns"      ("_,/ _")
   "_unit"       :: pttrn                                ("'(')")
 translations
   "(x, y)" \<rightleftharpoons> "CONST Pair x y"
   "_pattern x y" \<rightleftharpoons> "CONST Pair x y"
   "_patterns x y" \<rightleftharpoons> "CONST Pair x y"
   "_tuple x (_tuple_args y z)" \<rightleftharpoons> "_tuple x (_tuple_arg (_tuple y z))"
   "\<lambda>(x, y, zs). b" \<rightleftharpoons> "CONST case_prod (\<lambda>x (y, zs). b)"
   "\<lambda>(x, y). b" \<rightleftharpoons> "CONST case_prod (\<lambda>x y. b)"
   "_abs (CONST Pair x y) t" \<rightharpoonup> "\<lambda>(x, y). t"
   \<comment> \<open>This rule accommodates tuples in \<open>case C \<dots> (x, y) \<dots> \<Rightarrow> \<dots>\<close>:
      The \<open>(x, y)\<close> is parsed as \<open>Pair x y\<close> because it is \<open>logic\<close>,
      not \<open>pttrn\<close>.\<close>
   "\<lambda>(). b" \<rightleftharpoons> "CONST case_unit b"
   "_abs (CONST Unity) t" \<rightharpoonup> "\<lambda>(). t"
 
 text \<open>print \<^term>\<open>case_prod f\<close> as \<^term>\<open>\<lambda>(x, y). f x y\<close> and
   \<^term>\<open>case_prod (\<lambda>x. f x)\<close> as \<^term>\<open>\<lambda>(x, y). f x y\<close>\<close>
 
 typed_print_translation \<open>
   let
     fun case_prod_guess_names_tr' T [Abs (x, _, Abs _)] = raise Match
       | case_prod_guess_names_tr' T [Abs (x, xT, t)] =
           (case (head_of t) of
             Const (\<^const_syntax>\<open>case_prod\<close>, _) => raise Match
           | _ =>
             let
               val (_ :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
               val (y, t') = Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 1 t $ Bound 0);
               val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, xT, t');
             in
               Syntax.const \<^syntax_const>\<open>_abs\<close> $
                 (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $ y) $ t''
             end)
       | case_prod_guess_names_tr' T [t] =
           (case head_of t of
             Const (\<^const_syntax>\<open>case_prod\<close>, _) => raise Match
           | _ =>
             let
               val (xT :: yT :: _) = binder_types (domain_type T) handle Bind => raise Match;
               val (y, t') =
                 Syntax_Trans.atomic_abs_tr' ("y", yT, incr_boundvars 2 t $ Bound 1 $ Bound 0);
               val (x', t'') = Syntax_Trans.atomic_abs_tr' ("x", xT, t');
             in
               Syntax.const \<^syntax_const>\<open>_abs\<close> $
                 (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $ y) $ t''
             end)
       | case_prod_guess_names_tr' _ _ = raise Match;
   in [(\<^const_syntax>\<open>case_prod\<close>, K case_prod_guess_names_tr')] end
 \<close>
 
 text \<open>Reconstruct pattern from (nested) \<^const>\<open>case_prod\<close>s,
   avoiding eta-contraction of body; required for enclosing "let",
   if "let" does not avoid eta-contraction, which has been observed to occur.\<close>
 
 print_translation \<open>
   let
     fun case_prod_tr' [Abs (x, T, t as (Abs abs))] =
           (* case_prod (\<lambda>x y. t) \<Rightarrow> \<lambda>(x, y) t *)
           let
             val (y, t') = Syntax_Trans.atomic_abs_tr' abs;
             val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
           in
             Syntax.const \<^syntax_const>\<open>_abs\<close> $
               (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $ y) $ t''
           end
       | case_prod_tr' [Abs (x, T, (s as Const (\<^const_syntax>\<open>case_prod\<close>, _) $ t))] =
           (* case_prod (\<lambda>x. (case_prod (\<lambda>y z. t))) \<Rightarrow> \<lambda>(x, y, z). t *)
           let
             val Const (\<^syntax_const>\<open>_abs\<close>, _) $
               (Const (\<^syntax_const>\<open>_pattern\<close>, _) $ y $ z) $ t' =
                 case_prod_tr' [t];
             val (x', t'') = Syntax_Trans.atomic_abs_tr' (x, T, t');
           in
             Syntax.const \<^syntax_const>\<open>_abs\<close> $
               (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x' $
                 (Syntax.const \<^syntax_const>\<open>_patterns\<close> $ y $ z)) $ t''
           end
       | case_prod_tr' [Const (\<^const_syntax>\<open>case_prod\<close>, _) $ t] =
           (* case_prod (case_prod (\<lambda>x y z. t)) \<Rightarrow> \<lambda>((x, y), z). t *)
           case_prod_tr' [(case_prod_tr' [t])]
             (* inner case_prod_tr' creates next pattern *)
       | case_prod_tr' [Const (\<^syntax_const>\<open>_abs\<close>, _) $ x_y $ Abs abs] =
           (* case_prod (\<lambda>pttrn z. t) \<Rightarrow> \<lambda>(pttrn, z). t *)
           let val (z, t) = Syntax_Trans.atomic_abs_tr' abs in
             Syntax.const \<^syntax_const>\<open>_abs\<close> $
               (Syntax.const \<^syntax_const>\<open>_pattern\<close> $ x_y $ z) $ t
           end
       | case_prod_tr' _ = raise Match;
   in [(\<^const_syntax>\<open>case_prod\<close>, K case_prod_tr')] end
 \<close>
 
 
 subsubsection \<open>Code generator setup\<close>
 
 code_printing
   type_constructor prod \<rightharpoonup>
     (SML) infix 2 "*"
     and (OCaml) infix 2 "*"
     and (Haskell) "!((_),/ (_))"
     and (Scala) "((_),/ (_))"
 | constant Pair \<rightharpoonup>
     (SML) "!((_),/ (_))"
     and (OCaml) "!((_),/ (_))"
     and (Haskell) "!((_),/ (_))"
     and (Scala) "!((_),/ (_))"
 | class_instance  prod :: equal \<rightharpoonup>
     (Haskell) -
 | constant "HOL.equal :: 'a \<times> 'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" \<rightharpoonup>
     (Haskell) infix 4 "=="
 | constant fst \<rightharpoonup> (Haskell) "fst"
 | constant snd \<rightharpoonup> (Haskell) "snd"
 
 
 subsubsection \<open>Fundamental operations and properties\<close>
 
 lemma Pair_inject: "(a, b) = (a', b') \<Longrightarrow> (a = a' \<Longrightarrow> b = b' \<Longrightarrow> R) \<Longrightarrow> R"
   by simp
 
 lemma surj_pair [simp]: "\<exists>x y. p = (x, y)"
   by (cases p) simp
 
 lemma fst_eqD: "fst (x, y) = a \<Longrightarrow> x = a"
   by simp
 
 lemma snd_eqD: "snd (x, y) = a \<Longrightarrow> y = a"
   by simp
 
 lemma case_prod_unfold [nitpick_unfold]: "case_prod = (\<lambda>c p. c (fst p) (snd p))"
   by (simp add: fun_eq_iff split: prod.split)
 
 lemma case_prod_conv [simp, code]: "(case (a, b) of (c, d) \<Rightarrow> f c d) = f a b"
   by (fact prod.case)
 
 lemmas surjective_pairing = prod.collapse [symmetric]
 
 lemma prod_eq_iff: "s = t \<longleftrightarrow> fst s = fst t \<and> snd s = snd t"
   by (cases s, cases t) simp
 
 lemma prod_eqI [intro?]: "fst p = fst q \<Longrightarrow> snd p = snd q \<Longrightarrow> p = q"
   by (simp add: prod_eq_iff)
 
 lemma case_prodI: "f a b \<Longrightarrow> case (a, b) of (c, d) \<Rightarrow> f c d"
   by (rule prod.case [THEN iffD2])
 
 lemma case_prodD: "(case (a, b) of (c, d) \<Rightarrow> f c d) \<Longrightarrow> f a b"
   by (rule prod.case [THEN iffD1])
 
 lemma case_prod_Pair [simp]: "case_prod Pair = id"
   by (simp add: fun_eq_iff split: prod.split)
 
 lemma case_prod_eta: "(\<lambda>(x, y). f (x, y)) = f"
   \<comment> \<open>Subsumes the old \<open>split_Pair\<close> when \<^term>\<open>f\<close> is the identity function.\<close>
   by (simp add: fun_eq_iff split: prod.split)
 
 (* This looks like a sensible simp-rule but appears to do more harm than good:
 lemma case_prod_const [simp]: "(\<lambda>(_,_). c) = (\<lambda>_. c)"
 by(rule case_prod_eta)
 *)
 
 lemma case_prod_comp: "(case x of (a, b) \<Rightarrow> (f \<circ> g) a b) = f (g (fst x)) (snd x)"
   by (cases x) simp
 
 lemma The_case_prod: "The (case_prod P) = (THE xy. P (fst xy) (snd xy))"
   by (simp add: case_prod_unfold)
 
 lemma cond_case_prod_eta: "(\<And>x y. f x y = g (x, y)) \<Longrightarrow> (\<lambda>(x, y). f x y) = g"
   by (simp add: case_prod_eta)
 
 lemma split_paired_all [no_atp]: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (a, b))"
 proof
   fix a b
   assume "\<And>x. PROP P x"
   then show "PROP P (a, b)" .
 next
   fix x
   assume "\<And>a b. PROP P (a, b)"
   from \<open>PROP P (fst x, snd x)\<close> show "PROP P x" by simp
 qed
 
 text \<open>
   The rule @{thm [source] split_paired_all} does not work with the
   Simplifier because it also affects premises in congrence rules,
   where this can lead to premises of the form \<open>\<And>a b. \<dots> = ?P(a, b)\<close>
   which cannot be solved by reflexivity.
 \<close>
 
 lemmas split_tupled_all = split_paired_all unit_all_eq2
 
 ML \<open>
   (* replace parameters of product type by individual component parameters *)
   local (* filtering with exists_paired_all is an essential optimization *)
     fun exists_paired_all (Const (\<^const_name>\<open>Pure.all\<close>, _) $ Abs (_, T, t)) =
           can HOLogic.dest_prodT T orelse exists_paired_all t
       | exists_paired_all (t $ u) = exists_paired_all t orelse exists_paired_all u
       | exists_paired_all (Abs (_, _, t)) = exists_paired_all t
       | exists_paired_all _ = false;
     val ss =
       simpset_of
        (put_simpset HOL_basic_ss \<^context>
         addsimps [@{thm split_paired_all}, @{thm unit_all_eq2}, @{thm unit_abs_eta_conv}]
         addsimprocs [\<^simproc>\<open>unit_eq\<close>]);
   in
     fun split_all_tac ctxt = SUBGOAL (fn (t, i) =>
       if exists_paired_all t then safe_full_simp_tac (put_simpset ss ctxt) i else no_tac);
 
     fun unsafe_split_all_tac ctxt = SUBGOAL (fn (t, i) =>
       if exists_paired_all t then full_simp_tac (put_simpset ss ctxt) i else no_tac);
 
     fun split_all ctxt th =
       if exists_paired_all (Thm.prop_of th)
       then full_simplify (put_simpset ss ctxt) th else th;
   end;
 \<close>
 
 setup \<open>map_theory_claset (fn ctxt => ctxt addSbefore ("split_all_tac", split_all_tac))\<close>
 
 lemma split_paired_All [simp, no_atp]: "(\<forall>x. P x) \<longleftrightarrow> (\<forall>a b. P (a, b))"
   \<comment> \<open>\<open>[iff]\<close> is not a good idea because it makes \<open>blast\<close> loop\<close>
   by fast
 
 lemma split_paired_Ex [simp, no_atp]: "(\<exists>x. P x) \<longleftrightarrow> (\<exists>a b. P (a, b))"
   by fast
 
 lemma split_paired_The [no_atp]: "(THE x. P x) = (THE (a, b). P (a, b))"
   \<comment> \<open>Can't be added to simpset: loops!\<close>
   by (simp add: case_prod_eta)
 
 text \<open>
   Simplification procedure for @{thm [source] cond_case_prod_eta}.  Using
   @{thm [source] case_prod_eta} as a rewrite rule is not general enough,
   and using @{thm [source] cond_case_prod_eta} directly would render some
   existing proofs very inefficient; similarly for \<open>prod.case_eq_if\<close>.
 \<close>
 
 ML \<open>
 local
   val cond_case_prod_eta_ss =
     simpset_of (put_simpset HOL_basic_ss \<^context> addsimps @{thms cond_case_prod_eta});
   fun Pair_pat k 0 (Bound m) = (m = k)
     | Pair_pat k i (Const (\<^const_name>\<open>Pair\<close>,  _) $ Bound m $ t) =
         i > 0 andalso m = k + i andalso Pair_pat k (i - 1) t
     | Pair_pat _ _ _ = false;
   fun no_args k i (Abs (_, _, t)) = no_args (k + 1) i t
     | no_args k i (t $ u) = no_args k i t andalso no_args k i u
     | no_args k i (Bound m) = m < k orelse m > k + i
     | no_args _ _ _ = true;
   fun split_pat tp i (Abs  (_, _, t)) = if tp 0 i t then SOME (i, t) else NONE
     | split_pat tp i (Const (\<^const_name>\<open>case_prod\<close>, _) $ Abs (_, _, t)) = split_pat tp (i + 1) t
     | split_pat tp i _ = NONE;
   fun metaeq ctxt lhs rhs = mk_meta_eq (Goal.prove ctxt [] []
         (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs)))
         (K (simp_tac (put_simpset cond_case_prod_eta_ss ctxt) 1)));
 
   fun beta_term_pat k i (Abs (_, _, t)) = beta_term_pat (k + 1) i t
     | beta_term_pat k i (t $ u) =
         Pair_pat k i (t $ u) orelse (beta_term_pat k i t andalso beta_term_pat k i u)
     | beta_term_pat k i t = no_args k i t;
   fun eta_term_pat k i (f $ arg) = no_args k i f andalso Pair_pat k i arg
     | eta_term_pat _ _ _ = false;
   fun subst arg k i (Abs (x, T, t)) = Abs (x, T, subst arg (k+1) i t)
     | subst arg k i (t $ u) =
         if Pair_pat k i (t $ u) then incr_boundvars k arg
         else (subst arg k i t $ subst arg k i u)
     | subst arg k i t = t;
 in
   fun beta_proc ctxt (s as Const (\<^const_name>\<open>case_prod\<close>, _) $ Abs (_, _, t) $ arg) =
         (case split_pat beta_term_pat 1 t of
           SOME (i, f) => SOME (metaeq ctxt s (subst arg 0 i f))
         | NONE => NONE)
     | beta_proc _ _ = NONE;
   fun eta_proc ctxt (s as Const (\<^const_name>\<open>case_prod\<close>, _) $ Abs (_, _, t)) =
         (case split_pat eta_term_pat 1 t of
           SOME (_, ft) => SOME (metaeq ctxt s (let val f $ _ = ft in f end))
         | NONE => NONE)
     | eta_proc _ _ = NONE;
 end;
 \<close>
 simproc_setup case_prod_beta ("case_prod f z") =
   \<open>fn _ => fn ctxt => fn ct => beta_proc ctxt (Thm.term_of ct)\<close>
 simproc_setup case_prod_eta ("case_prod f") =
   \<open>fn _ => fn ctxt => fn ct => eta_proc ctxt (Thm.term_of ct)\<close>
 
 lemma case_prod_beta': "(\<lambda>(x,y). f x y) = (\<lambda>x. f (fst x) (snd x))"
   by (auto simp: fun_eq_iff)
 
 text \<open>
   \<^medskip> \<^const>\<open>case_prod\<close> used as a logical connective or set former.
 
   \<^medskip> These rules are for use with \<open>blast\<close>; could instead
   call \<open>simp\<close> using @{thm [source] prod.split} as rewrite.\<close>
 
 lemma case_prodI2:
   "\<And>p. (\<And>a b. p = (a, b) \<Longrightarrow> c a b) \<Longrightarrow> case p of (a, b) \<Rightarrow> c a b"
   by (simp add: split_tupled_all)
 
 lemma case_prodI2':
   "\<And>p. (\<And>a b. (a, b) = p \<Longrightarrow> c a b x) \<Longrightarrow> (case p of (a, b) \<Rightarrow> c a b) x"
   by (simp add: split_tupled_all)
 
 lemma case_prodE [elim!]:
   "(case p of (a, b) \<Rightarrow> c a b) \<Longrightarrow> (\<And>x y. p = (x, y) \<Longrightarrow> c x y \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (induct p) simp
 
 lemma case_prodE' [elim!]:
   "(case p of (a, b) \<Rightarrow> c a b) z \<Longrightarrow> (\<And>x y. p = (x, y) \<Longrightarrow> c x y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (induct p) simp
 
 lemma case_prodE2:
   assumes q: "Q (case z of (a, b) \<Rightarrow> P a b)"
     and r: "\<And>x y. z = (x, y) \<Longrightarrow> Q (P x y) \<Longrightarrow> R"
   shows R
 proof (rule r)
   show "z = (fst z, snd z)" by simp
   then show "Q (P (fst z) (snd z))"
     using q by (simp add: case_prod_unfold)
 qed
 
 lemma case_prodD': "(case (a, b) of (c, d) \<Rightarrow> R c d) c \<Longrightarrow> R a b c"
   by simp
 
 lemma mem_case_prodI: "z \<in> c a b \<Longrightarrow> z \<in> (case (a, b) of (d, e) \<Rightarrow> c d e)"
   by simp
 
 lemma mem_case_prodI2 [intro!]:
   "\<And>p. (\<And>a b. p = (a, b) \<Longrightarrow> z \<in> c a b) \<Longrightarrow> z \<in> (case p of (a, b) \<Rightarrow> c a b)"
   by (simp only: split_tupled_all) simp
 
 declare mem_case_prodI [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 declare case_prodI2' [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 declare case_prodI2 [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 declare case_prodI [intro!] \<comment> \<open>postponed to maintain traditional declaration order!\<close>
 
 lemma mem_case_prodE [elim!]:
   assumes "z \<in> case_prod c p"
   obtains x y where "p = (x, y)" and "z \<in> c x y"
   using assms by (rule case_prodE2)
 
 ML \<open>
 local (* filtering with exists_p_split is an essential optimization *)
   fun exists_p_split (Const (\<^const_name>\<open>case_prod\<close>,_) $ _ $ (Const (\<^const_name>\<open>Pair\<close>,_)$_$_)) = true
     | exists_p_split (t $ u) = exists_p_split t orelse exists_p_split u
     | exists_p_split (Abs (_, _, t)) = exists_p_split t
     | exists_p_split _ = false;
 in
   fun split_conv_tac ctxt = SUBGOAL (fn (t, i) =>
     if exists_p_split t
     then safe_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms case_prod_conv}) i
     else no_tac);
 end;
 \<close>
 
 (* This prevents applications of splitE for already splitted arguments leading
    to quite time-consuming computations (in particular for nested tuples) *)
 setup \<open>map_theory_claset (fn ctxt => ctxt addSbefore ("split_conv_tac", split_conv_tac))\<close>
 
 lemma split_eta_SetCompr [simp, no_atp]: "(\<lambda>u. \<exists>x y. u = (x, y) \<and> P (x, y)) = P"
   by (rule ext) fast
 
 lemma split_eta_SetCompr2 [simp, no_atp]: "(\<lambda>u. \<exists>x y. u = (x, y) \<and> P x y) = case_prod P"
   by (rule ext) fast
 
 lemma split_part [simp]: "(\<lambda>(a,b). P \<and> Q a b) = (\<lambda>ab. P \<and> case_prod Q ab)"
   \<comment> \<open>Allows simplifications of nested splits in case of independent predicates.\<close>
   by (rule ext) blast
 
 (* Do NOT make this a simp rule as it
    a) only helps in special situations
    b) can lead to nontermination in the presence of split_def
 *)
 lemma split_comp_eq:
   fixes f :: "'a \<Rightarrow> 'b \<Rightarrow> 'c"
     and g :: "'d \<Rightarrow> 'a"
   shows "(\<lambda>u. f (g (fst u)) (snd u)) = case_prod (\<lambda>x. f (g x))"
   by (rule ext) auto
 
 lemma pair_imageI [intro]: "(a, b) \<in> A \<Longrightarrow> f a b \<in> (\<lambda>(a, b). f a b) ` A"
   by (rule image_eqI [where x = "(a, b)"]) auto
 
 lemma Collect_const_case_prod[simp]: "{(a,b). P} = (if P then UNIV else {})"
 by auto
 
 lemma The_split_eq [simp]: "(THE (x',y'). x = x' \<and> y = y') = (x, y)"
   by blast
 
 (*
 the following  would be slightly more general,
 but cannot be used as rewrite rule:
 ### Cannot add premise as rewrite rule because it contains (type) unknowns:
 ### ?y = .x
 Goal "[| P y; !!x. P x ==> x = y |] ==> (@(x',y). x = x' & P y) = (x,y)"
 by (rtac some_equality 1)
 by ( Simp_tac 1)
 by (split_all_tac 1)
 by (Asm_full_simp_tac 1)
 qed "The_split_eq";
 *)
 
 lemma case_prod_beta: "case_prod f p = f (fst p) (snd p)"
   by (fact prod.case_eq_if)
 
 lemma prod_cases3 [cases type]:
   obtains (fields) a b c where "y = (a, b, c)"
-  by (cases y, case_tac b) blast
+proof (cases y)
+  case (Pair a b)
+  with that show ?thesis
+    by (cases b) blast
+qed
+
 
 lemma prod_induct3 [case_names fields, induct type]:
   "(\<And>a b c. P (a, b, c)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases4 [cases type]:
   obtains (fields) a b c d where "y = (a, b, c, d)"
-  by (cases y, case_tac c) blast
+proof (cases y)
+  case (fields a b c)
+  with that show ?thesis
+    by (cases c) blast
+qed
 
 lemma prod_induct4 [case_names fields, induct type]:
   "(\<And>a b c d. P (a, b, c, d)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases5 [cases type]:
   obtains (fields) a b c d e where "y = (a, b, c, d, e)"
-  by (cases y, case_tac d) blast
+proof (cases y)
+  case (fields a b c d)
+  with that show ?thesis
+    by (cases d) blast
+qed
 
 lemma prod_induct5 [case_names fields, induct type]:
   "(\<And>a b c d e. P (a, b, c, d, e)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases6 [cases type]:
   obtains (fields) a b c d e f where "y = (a, b, c, d, e, f)"
-  by (cases y, case_tac e) blast
+proof (cases y)
+  case (fields a b c d e)
+  with that show ?thesis
+    by (cases e) blast
+qed
 
 lemma prod_induct6 [case_names fields, induct type]:
   "(\<And>a b c d e f. P (a, b, c, d, e, f)) \<Longrightarrow> P x"
   by (cases x) blast
 
 lemma prod_cases7 [cases type]:
   obtains (fields) a b c d e f g where "y = (a, b, c, d, e, f, g)"
-  by (cases y, case_tac f) blast
+proof (cases y)
+  case (fields a b c d e f)
+  with that show ?thesis
+    by (cases f) blast
+qed
+
 
 lemma prod_induct7 [case_names fields, induct type]:
   "(\<And>a b c d e f g. P (a, b, c, d, e, f, g)) \<Longrightarrow> P x"
   by (cases x) blast
 
 definition internal_case_prod :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c"
   where "internal_case_prod \<equiv> case_prod"
 
 lemma internal_case_prod_conv: "internal_case_prod c (a, b) = c a b"
   by (simp only: internal_case_prod_def case_prod_conv)
 
 ML_file \<open>Tools/split_rule.ML\<close>
 
 hide_const internal_case_prod
 
 
 subsubsection \<open>Derived operations\<close>
 
 definition curry :: "('a \<times> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c"
   where "curry = (\<lambda>c x y. c (x, y))"
 
 lemma curry_conv [simp, code]: "curry f a b = f (a, b)"
   by (simp add: curry_def)
 
 lemma curryI [intro!]: "f (a, b) \<Longrightarrow> curry f a b"
   by (simp add: curry_def)
 
 lemma curryD [dest!]: "curry f a b \<Longrightarrow> f (a, b)"
   by (simp add: curry_def)
 
 lemma curryE: "curry f a b \<Longrightarrow> (f (a, b) \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (simp add: curry_def)
 
 lemma curry_case_prod [simp]: "curry (case_prod f) = f"
   by (simp add: curry_def case_prod_unfold)
 
 lemma case_prod_curry [simp]: "case_prod (curry f) = f"
   by (simp add: curry_def case_prod_unfold)
 
 lemma curry_K: "curry (\<lambda>x. c) = (\<lambda>x y. c)"
   by (simp add: fun_eq_iff)
 
 text \<open>The composition-uncurry combinator.\<close>
 
 definition scomp :: "('a \<Rightarrow> 'b \<times> 'c) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'a \<Rightarrow> 'd"  (infixl "\<circ>\<rightarrow>" 60)
   where "f \<circ>\<rightarrow> g = (\<lambda>x. case_prod g (f x))"
 
 no_notation scomp (infixl "\<circ>\<rightarrow>" 60)
 
 bundle state_combinator_syntax
 begin
 
 notation fcomp (infixl "\<circ>>" 60)
 notation scomp (infixl "\<circ>\<rightarrow>" 60)
 
 end
 
 context
   includes state_combinator_syntax
 begin
 
 lemma scomp_unfold: "(\<circ>\<rightarrow>) = (\<lambda>f g x. g (fst (f x)) (snd (f x)))"
   by (simp add: fun_eq_iff scomp_def case_prod_unfold)
 
 lemma scomp_apply [simp]: "(f \<circ>\<rightarrow> g) x = case_prod g (f x)"
   by (simp add: scomp_unfold case_prod_unfold)
 
 lemma Pair_scomp: "Pair x \<circ>\<rightarrow> f = f x"
   by (simp add: fun_eq_iff)
 
 lemma scomp_Pair: "x \<circ>\<rightarrow> Pair = x"
   by (simp add: fun_eq_iff)
 
 lemma scomp_scomp: "(f \<circ>\<rightarrow> g) \<circ>\<rightarrow> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>\<rightarrow> h)"
   by (simp add: fun_eq_iff scomp_unfold)
 
 lemma scomp_fcomp: "(f \<circ>\<rightarrow> g) \<circ>> h = f \<circ>\<rightarrow> (\<lambda>x. g x \<circ>> h)"
   by (simp add: fun_eq_iff scomp_unfold fcomp_def)
 
 lemma fcomp_scomp: "(f \<circ>> g) \<circ>\<rightarrow> h = f \<circ>> (g \<circ>\<rightarrow> h)"
   by (simp add: fun_eq_iff scomp_unfold)
 
 end
 
 code_printing
   constant scomp \<rightharpoonup> (Eval) infixl 3 "#->"
 
 text \<open>
   \<^term>\<open>map_prod\<close> --- action of the product functor upon functions.
 \<close>
 
 definition map_prod :: "('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'd"
   where "map_prod f g = (\<lambda>(x, y). (f x, g y))"
 
 lemma map_prod_simp [simp, code]: "map_prod f g (a, b) = (f a, g b)"
   by (simp add: map_prod_def)
 
 functor map_prod: map_prod
   by (auto simp add: split_paired_all)
 
 lemma fst_map_prod [simp]: "fst (map_prod f g x) = f (fst x)"
   by (cases x) simp_all
 
 lemma snd_map_prod [simp]: "snd (map_prod f g x) = g (snd x)"
   by (cases x) simp_all
 
 lemma fst_comp_map_prod [simp]: "fst \<circ> map_prod f g = f \<circ> fst"
   by (rule ext) simp_all
 
 lemma snd_comp_map_prod [simp]: "snd \<circ> map_prod f g = g \<circ> snd"
   by (rule ext) simp_all
 
 lemma map_prod_compose: "map_prod (f1 \<circ> f2) (g1 \<circ> g2) = (map_prod f1 g1 \<circ> map_prod f2 g2)"
   by (rule ext) (simp add: map_prod.compositionality comp_def)
 
 lemma map_prod_ident [simp]: "map_prod (\<lambda>x. x) (\<lambda>y. y) = (\<lambda>z. z)"
   by (rule ext) (simp add: map_prod.identity)
 
 lemma map_prod_imageI [intro]: "(a, b) \<in> R \<Longrightarrow> (f a, g b) \<in> map_prod f g ` R"
   by (rule image_eqI) simp_all
 
 lemma prod_fun_imageE [elim!]:
   assumes major: "c \<in> map_prod f g ` R"
     and cases: "\<And>x y. c = (f x, g y) \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> P"
   shows P
-  apply (rule major [THEN imageE])
-  apply (case_tac x)
-  apply (rule cases)
-   apply simp_all
-  done
+proof (rule major [THEN imageE])
+  fix x
+  assume "c = map_prod f g x" "x \<in> R"
+  then show P
+    using cases by (cases x) simp
+qed
 
 definition apfst :: "('a \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c \<times> 'b"
   where "apfst f = map_prod f id"
 
 definition apsnd :: "('b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'a \<times> 'c"
   where "apsnd f = map_prod id f"
 
 lemma apfst_conv [simp, code]: "apfst f (x, y) = (f x, y)"
   by (simp add: apfst_def)
 
 lemma apsnd_conv [simp, code]: "apsnd f (x, y) = (x, f y)"
   by (simp add: apsnd_def)
 
 lemma fst_apfst [simp]: "fst (apfst f x) = f (fst x)"
   by (cases x) simp
 
 lemma fst_comp_apfst [simp]: "fst \<circ> apfst f = f \<circ> fst"
   by (simp add: fun_eq_iff)
 
 lemma fst_apsnd [simp]: "fst (apsnd f x) = fst x"
   by (cases x) simp
 
 lemma fst_comp_apsnd [simp]: "fst \<circ> apsnd f = fst"
   by (simp add: fun_eq_iff)
 
 lemma snd_apfst [simp]: "snd (apfst f x) = snd x"
   by (cases x) simp
 
 lemma snd_comp_apfst [simp]: "snd \<circ> apfst f = snd"
   by (simp add: fun_eq_iff)
 
 lemma snd_apsnd [simp]: "snd (apsnd f x) = f (snd x)"
   by (cases x) simp
 
 lemma snd_comp_apsnd [simp]: "snd \<circ> apsnd f = f \<circ> snd"
   by (simp add: fun_eq_iff)
 
 lemma apfst_compose: "apfst f (apfst g x) = apfst (f \<circ> g) x"
   by (cases x) simp
 
 lemma apsnd_compose: "apsnd f (apsnd g x) = apsnd (f \<circ> g) x"
   by (cases x) simp
 
 lemma apfst_apsnd [simp]: "apfst f (apsnd g x) = (f (fst x), g (snd x))"
   by (cases x) simp
 
 lemma apsnd_apfst [simp]: "apsnd f (apfst g x) = (g (fst x), f (snd x))"
   by (cases x) simp
 
 lemma apfst_id [simp]: "apfst id = id"
   by (simp add: fun_eq_iff)
 
 lemma apsnd_id [simp]: "apsnd id = id"
   by (simp add: fun_eq_iff)
 
 lemma apfst_eq_conv [simp]: "apfst f x = apfst g x \<longleftrightarrow> f (fst x) = g (fst x)"
   by (cases x) simp
 
 lemma apsnd_eq_conv [simp]: "apsnd f x = apsnd g x \<longleftrightarrow> f (snd x) = g (snd x)"
   by (cases x) simp
 
 lemma apsnd_apfst_commute: "apsnd f (apfst g p) = apfst g (apsnd f p)"
   by simp
 
 context
 begin
 
 local_setup \<open>Local_Theory.map_background_naming (Name_Space.mandatory_path "prod")\<close>
 
 definition swap :: "'a \<times> 'b \<Rightarrow> 'b \<times> 'a"
   where "swap p = (snd p, fst p)"
 
 end
 
 lemma swap_simp [simp]: "prod.swap (x, y) = (y, x)"
   by (simp add: prod.swap_def)
 
 lemma swap_swap [simp]: "prod.swap (prod.swap p) = p"
   by (cases p) simp
 
 lemma swap_comp_swap [simp]: "prod.swap \<circ> prod.swap = id"
   by (simp add: fun_eq_iff)
 
 lemma pair_in_swap_image [simp]: "(y, x) \<in> prod.swap ` A \<longleftrightarrow> (x, y) \<in> A"
   by (auto intro!: image_eqI)
 
 lemma inj_swap [simp]: "inj_on prod.swap A"
   by (rule inj_onI) auto
 
 lemma swap_inj_on: "inj_on (\<lambda>(i, j). (j, i)) A"
   by (rule inj_onI) auto
 
 lemma surj_swap [simp]: "surj prod.swap"
   by (rule surjI [of _ prod.swap]) simp
 
 lemma bij_swap [simp]: "bij prod.swap"
   by (simp add: bij_def)
 
 lemma case_swap [simp]: "(case prod.swap p of (y, x) \<Rightarrow> f x y) = (case p of (x, y) \<Rightarrow> f x y)"
   by (cases p) simp
 
 lemma fst_swap [simp]: "fst (prod.swap x) = snd x"
   by (cases x) simp
 
 lemma snd_swap [simp]: "snd (prod.swap x) = fst x"
   by (cases x) simp
 
 text \<open>Disjoint union of a family of sets -- Sigma.\<close>
 
 definition Sigma :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<times> 'b) set"
   where "Sigma A B \<equiv> \<Union>x\<in>A. \<Union>y\<in>B x. {Pair x y}"
 
 abbreviation Times :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"  (infixr "\<times>" 80)
   where "A \<times> B \<equiv> Sigma A (\<lambda>_. B)"
 
 hide_const (open) Times
 
 bundle no_Set_Product_syntax begin
 no_notation Product_Type.Times (infixr "\<times>" 80)
 end
 bundle Set_Product_syntax begin
 notation Product_Type.Times (infixr "\<times>" 80)
 end
 
 syntax
   "_Sigma" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"  ("(3SIGMA _:_./ _)" [0, 0, 10] 10)
 translations
   "SIGMA x:A. B" \<rightleftharpoons> "CONST Sigma A (\<lambda>x. B)"
 
 lemma SigmaI [intro!]: "a \<in> A \<Longrightarrow> b \<in> B a \<Longrightarrow> (a, b) \<in> Sigma A B"
   unfolding Sigma_def by blast
 
 lemma SigmaE [elim!]: "c \<in> Sigma A B \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> B x \<Longrightarrow> c = (x, y) \<Longrightarrow> P) \<Longrightarrow> P"
   \<comment> \<open>The general elimination rule.\<close>
   unfolding Sigma_def by blast
 
 text \<open>
   Elimination of \<^term>\<open>(a, b) \<in> A \<times> B\<close> -- introduces no
   eigenvariables.
 \<close>
 
 lemma SigmaD1: "(a, b) \<in> Sigma A B \<Longrightarrow> a \<in> A"
   by blast
 
 lemma SigmaD2: "(a, b) \<in> Sigma A B \<Longrightarrow> b \<in> B a"
   by blast
 
 lemma SigmaE2: "(a, b) \<in> Sigma A B \<Longrightarrow> (a \<in> A \<Longrightarrow> b \<in> B a \<Longrightarrow> P) \<Longrightarrow> P"
   by blast
 
 lemma Sigma_cong: "A = B \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> C x = D x) \<Longrightarrow> (SIGMA x:A. C x) = (SIGMA x:B. D x)"
   by auto
 
 lemma Sigma_mono: "A \<subseteq> C \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> D x) \<Longrightarrow> Sigma A B \<subseteq> Sigma C D"
   by blast
 
 lemma Sigma_empty1 [simp]: "Sigma {} B = {}"
   by blast
 
 lemma Sigma_empty2 [simp]: "A \<times> {} = {}"
   by blast
 
 lemma UNIV_Times_UNIV [simp]: "UNIV \<times> UNIV = UNIV"
   by auto
 
 lemma Compl_Times_UNIV1 [simp]: "- (UNIV \<times> A) = UNIV \<times> (-A)"
   by auto
 
 lemma Compl_Times_UNIV2 [simp]: "- (A \<times> UNIV) = (-A) \<times> UNIV"
   by auto
 
 lemma mem_Sigma_iff [iff]: "(a, b) \<in> Sigma A B \<longleftrightarrow> a \<in> A \<and> b \<in> B a"
   by blast
 
 lemma mem_Times_iff: "x \<in> A \<times> B \<longleftrightarrow> fst x \<in> A \<and> snd x \<in> B"
   by (induct x) simp
 
 lemma Sigma_empty_iff: "(SIGMA i:I. X i) = {} \<longleftrightarrow> (\<forall>i\<in>I. X i = {})"
   by auto
 
 lemma Times_subset_cancel2: "x \<in> C \<Longrightarrow> A \<times> C \<subseteq> B \<times> C \<longleftrightarrow> A \<subseteq> B"
   by blast
 
 lemma Times_eq_cancel2: "x \<in> C \<Longrightarrow> A \<times> C = B \<times> C \<longleftrightarrow> A = B"
   by (blast elim: equalityE)
 
 lemma Collect_case_prod_Sigma: "{(x, y). P x \<and> Q x y} = (SIGMA x:Collect P. Collect (Q x))"
   by blast
 
 lemma Collect_case_prod [simp]: "{(a, b). P a \<and> Q b} = Collect P \<times> Collect Q "
   by (fact Collect_case_prod_Sigma)
 
 lemma Collect_case_prodD: "x \<in> Collect (case_prod A) \<Longrightarrow> A (fst x) (snd x)"
   by auto
 
 lemma Collect_case_prod_mono: "A \<le> B \<Longrightarrow> Collect (case_prod A) \<subseteq> Collect (case_prod B)"
   by auto (auto elim!: le_funE)
 
 lemma Collect_split_mono_strong:
   "X = fst ` A \<Longrightarrow> Y = snd ` A \<Longrightarrow> \<forall>a\<in>X. \<forall>b \<in> Y. P a b \<longrightarrow> Q a b
     \<Longrightarrow> A \<subseteq> Collect (case_prod P) \<Longrightarrow> A \<subseteq> Collect (case_prod Q)"
   by fastforce
 
 lemma UN_Times_distrib: "(\<Union>(a, b)\<in>A \<times> B. E a \<times> F b) = \<Union>(E ` A) \<times> \<Union>(F ` B)"
   \<comment> \<open>Suggested by Pierre Chartier\<close>
   by blast
 
 lemma split_paired_Ball_Sigma [simp, no_atp]: "(\<forall>z\<in>Sigma A B. P z) \<longleftrightarrow> (\<forall>x\<in>A. \<forall>y\<in>B x. P (x, y))"
   by blast
 
 lemma split_paired_Bex_Sigma [simp, no_atp]: "(\<exists>z\<in>Sigma A B. P z) \<longleftrightarrow> (\<exists>x\<in>A. \<exists>y\<in>B x. P (x, y))"
   by blast
 
 lemma Sigma_Un_distrib1: "Sigma (I \<union> J) C = Sigma I C \<union> Sigma J C"
   by blast
 
 lemma Sigma_Un_distrib2: "(SIGMA i:I. A i \<union> B i) = Sigma I A \<union> Sigma I B"
   by blast
 
 lemma Sigma_Int_distrib1: "Sigma (I \<inter> J) C = Sigma I C \<inter> Sigma J C"
   by blast
 
 lemma Sigma_Int_distrib2: "(SIGMA i:I. A i \<inter> B i) = Sigma I A \<inter> Sigma I B"
   by blast
 
 lemma Sigma_Diff_distrib1: "Sigma (I - J) C = Sigma I C - Sigma J C"
   by blast
 
 lemma Sigma_Diff_distrib2: "(SIGMA i:I. A i - B i) = Sigma I A - Sigma I B"
   by blast
 
 lemma Sigma_Union: "Sigma (\<Union>X) B = (\<Union>A\<in>X. Sigma A B)"
   by blast
 
 lemma Pair_vimage_Sigma: "Pair x -` Sigma A f = (if x \<in> A then f x else {})"
   by auto
 
 text \<open>
   Non-dependent versions are needed to avoid the need for higher-order
   matching, especially when the rules are re-oriented.
 \<close>
 
 lemma Times_Un_distrib1: "(A \<union> B) \<times> C = A \<times> C \<union> B \<times> C "
   by (fact Sigma_Un_distrib1)
 
 lemma Times_Int_distrib1: "(A \<inter> B) \<times> C = A \<times> C \<inter> B \<times> C "
   by (fact Sigma_Int_distrib1)
 
 lemma Times_Diff_distrib1: "(A - B) \<times> C = A \<times> C - B \<times> C "
   by (fact Sigma_Diff_distrib1)
 
 lemma Times_empty [simp]: "A \<times> B = {} \<longleftrightarrow> A = {} \<or> B = {}"
   by auto
 
 lemma times_subset_iff: "A \<times> C \<subseteq> B \<times> D \<longleftrightarrow> A={} \<or> C={} \<or> A \<subseteq> B \<and> C \<subseteq> D"
   by blast
 
 lemma times_eq_iff: "A \<times> B = C \<times> D \<longleftrightarrow> A = C \<and> B = D \<or> (A = {} \<or> B = {}) \<and> (C = {} \<or> D = {})"
   by auto
 
 lemma fst_image_times [simp]: "fst ` (A \<times> B) = (if B = {} then {} else A)"
   by force
 
 lemma snd_image_times [simp]: "snd ` (A \<times> B) = (if A = {} then {} else B)"
   by force
 
 lemma fst_image_Sigma: "fst ` (Sigma A B) = {x \<in> A. B(x) \<noteq> {}}"
   by force
 
 lemma snd_image_Sigma: "snd ` (Sigma A B) = (\<Union> x \<in> A. B x)"
   by force
 
 lemma vimage_fst: "fst -` A = A \<times> UNIV"
   by auto
 
 lemma vimage_snd: "snd -` A = UNIV \<times> A"
   by auto
 
 lemma insert_Times_insert [simp]:
   "insert a A \<times> insert b B = insert (a,b) (A \<times> insert b B \<union> insert a A \<times> B)"
   by blast
 
 lemma vimage_Times: "f -` (A \<times> B) = (fst \<circ> f) -` A \<inter> (snd \<circ> f) -` B"
 proof (rule set_eqI)
   show "x \<in> f -` (A \<times> B) \<longleftrightarrow> x \<in> (fst \<circ> f) -` A \<inter> (snd \<circ> f) -` B" for x
     by (cases "f x") (auto split: prod.split)
 qed
 
 lemma Times_Int_Times: "A \<times> B \<inter> C \<times> D = (A \<inter> C) \<times> (B \<inter> D)"
   by auto
 
 lemma image_paired_Times:
    "(\<lambda>(x,y). (f x, g y)) ` (A \<times> B) = (f ` A) \<times> (g ` B)"
   by auto
 
 lemma product_swap: "prod.swap ` (A \<times> B) = B \<times> A"
   by (auto simp add: set_eq_iff)
 
 lemma swap_product: "(\<lambda>(i, j). (j, i)) ` (A \<times> B) = B \<times> A"
   by (auto simp add: set_eq_iff)
 
 lemma image_split_eq_Sigma: "(\<lambda>x. (f x, g x)) ` A = Sigma (f ` A) (\<lambda>x. g ` (f -` {x} \<inter> A))"
 proof (safe intro!: imageI)
   fix a b
   assume *: "a \<in> A" "b \<in> A" and eq: "f a = f b"
   show "(f b, g a) \<in> (\<lambda>x. (f x, g x)) ` A"
     using * eq[symmetric] by auto
 qed simp_all
 
 lemma subset_fst_snd: "A \<subseteq> (fst ` A \<times> snd ` A)"
   by force
 
 lemma inj_on_apfst [simp]: "inj_on (apfst f) (A \<times> UNIV) \<longleftrightarrow> inj_on f A"
   by (auto simp add: inj_on_def)
 
 lemma inj_apfst [simp]: "inj (apfst f) \<longleftrightarrow> inj f"
   using inj_on_apfst[of f UNIV] by simp
 
 lemma inj_on_apsnd [simp]: "inj_on (apsnd f) (UNIV \<times> A) \<longleftrightarrow> inj_on f A"
   by (auto simp add: inj_on_def)
 
 lemma inj_apsnd [simp]: "inj (apsnd f) \<longleftrightarrow> inj f"
   using inj_on_apsnd[of f UNIV] by simp
 
 context
 begin
 
 qualified definition product :: "'a set \<Rightarrow> 'b set \<Rightarrow> ('a \<times> 'b) set"
   where [code_abbrev]: "product A B = A \<times> B"
 
 lemma member_product: "x \<in> Product_Type.product A B \<longleftrightarrow> x \<in> A \<times> B"
   by (simp add: product_def)
 
 end
 
 text \<open>The following \<^const>\<open>map_prod\<close> lemmas are due to Joachim Breitner:\<close>
 
 lemma map_prod_inj_on:
   assumes "inj_on f A"
     and "inj_on g B"
   shows "inj_on (map_prod f g) (A \<times> B)"
 proof (rule inj_onI)
   fix x :: "'a \<times> 'c"
   fix y :: "'a \<times> 'c"
   assume "x \<in> A \<times> B"
   then have "fst x \<in> A" and "snd x \<in> B" by auto
   assume "y \<in> A \<times> B"
   then have "fst y \<in> A" and "snd y \<in> B" by auto
   assume "map_prod f g x = map_prod f g y"
   then have "fst (map_prod f g x) = fst (map_prod f g y)" by auto
   then have "f (fst x) = f (fst y)" by (cases x, cases y) auto
   with \<open>inj_on f A\<close> and \<open>fst x \<in> A\<close> and \<open>fst y \<in> A\<close> have "fst x = fst y"
     by (auto dest: inj_onD)
   moreover from \<open>map_prod f g x = map_prod f g y\<close>
   have "snd (map_prod f g x) = snd (map_prod f g y)" by auto
   then have "g (snd x) = g (snd y)" by (cases x, cases y) auto
   with \<open>inj_on g B\<close> and \<open>snd x \<in> B\<close> and \<open>snd y \<in> B\<close> have "snd x = snd y"
     by (auto dest: inj_onD)
   ultimately show "x = y" by (rule prod_eqI)
 qed
 
 lemma map_prod_surj:
   fixes f :: "'a \<Rightarrow> 'b"
     and g :: "'c \<Rightarrow> 'd"
   assumes "surj f" and "surj g"
   shows "surj (map_prod f g)"
   unfolding surj_def
 proof
   fix y :: "'b \<times> 'd"
   from \<open>surj f\<close> obtain a where "fst y = f a"
     by (auto elim: surjE)
   moreover
   from \<open>surj g\<close> obtain b where "snd y = g b"
     by (auto elim: surjE)
   ultimately have "(fst y, snd y) = map_prod f g (a,b)"
     by auto
   then show "\<exists>x. y = map_prod f g x"
     by auto
 qed
 
 lemma map_prod_surj_on:
   assumes "f ` A = A'" and "g ` B = B'"
   shows "map_prod f g ` (A \<times> B) = A' \<times> B'"
   unfolding image_def
 proof (rule set_eqI, rule iffI)
   fix x :: "'a \<times> 'c"
   assume "x \<in> {y::'a \<times> 'c. \<exists>x::'b \<times> 'd\<in>A \<times> B. y = map_prod f g x}"
   then obtain y where "y \<in> A \<times> B" and "x = map_prod f g y"
     by blast
   from \<open>image f A = A'\<close> and \<open>y \<in> A \<times> B\<close> have "f (fst y) \<in> A'"
     by auto
   moreover from \<open>image g B = B'\<close> and \<open>y \<in> A \<times> B\<close> have "g (snd y) \<in> B'"
     by auto
   ultimately have "(f (fst y), g (snd y)) \<in> (A' \<times> B')"
     by auto
   with \<open>x = map_prod f g y\<close> show "x \<in> A' \<times> B'"
     by (cases y) auto
 next
   fix x :: "'a \<times> 'c"
   assume "x \<in> A' \<times> B'"
   then have "fst x \<in> A'" and "snd x \<in> B'"
     by auto
   from \<open>image f A = A'\<close> and \<open>fst x \<in> A'\<close> have "fst x \<in> image f A"
     by auto
   then obtain a where "a \<in> A" and "fst x = f a"
     by (rule imageE)
   moreover from \<open>image g B = B'\<close> and \<open>snd x \<in> B'\<close> obtain b where "b \<in> B" and "snd x = g b"
     by auto
   ultimately have "(fst x, snd x) = map_prod f g (a, b)"
     by auto
   moreover from \<open>a \<in> A\<close> and  \<open>b \<in> B\<close> have "(a , b) \<in> A \<times> B"
     by auto
   ultimately have "\<exists>y \<in> A \<times> B. x = map_prod f g y"
     by auto
   then show "x \<in> {x. \<exists>y \<in> A \<times> B. x = map_prod f g y}"
     by auto
 qed
 
 
 subsection \<open>Simproc for rewriting a set comprehension into a pointfree expression\<close>
 
 ML_file \<open>Tools/set_comprehension_pointfree.ML\<close>
 
 setup \<open>
   Code_Preproc.map_pre (fn ctxt => ctxt addsimprocs
     [Simplifier.make_simproc \<^context> "set comprehension"
       {lhss = [\<^term>\<open>Collect P\<close>],
        proc = K Set_Comprehension_Pointfree.code_simproc}])
 \<close>
 
 subsection \<open>Lemmas about disjointness\<close>
 
 lemma disjnt_Times1_iff [simp]: "disjnt (C \<times> A) (C \<times> B) \<longleftrightarrow> C = {} \<or> disjnt A B"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Times2_iff [simp]: "disjnt (A \<times> C) (B \<times> C) \<longleftrightarrow> C = {} \<or> disjnt A B"
   by (auto simp: disjnt_def)
 
 lemma disjnt_Sigma_iff: "disjnt (Sigma A C) (Sigma B C) \<longleftrightarrow> (\<forall>i \<in> A\<inter>B. C i = {}) \<or> disjnt A B"
   by (auto simp: disjnt_def)
 
 
 subsection \<open>Inductively defined sets\<close>
 
 (* simplify {(x1, ..., xn). (x1, ..., xn) : S} to S *)
 simproc_setup Collect_mem ("Collect t") = \<open>
   fn _ => fn ctxt => fn ct =>
     (case Thm.term_of ct of
       S as Const (\<^const_name>\<open>Collect\<close>, Type (\<^type_name>\<open>fun\<close>, [_, T])) $ t =>
         let val (u, _, ps) = HOLogic.strip_ptupleabs t in
           (case u of
             (c as Const (\<^const_name>\<open>Set.member\<close>, _)) $ q $ S' =>
               (case try (HOLogic.strip_ptuple ps) q of
                 NONE => NONE
               | SOME ts =>
                   if not (Term.is_open S') andalso
                     ts = map Bound (length ps downto 0)
                   then
                     let val simp =
                       full_simp_tac (put_simpset HOL_basic_ss ctxt
                         addsimps [@{thm split_paired_all}, @{thm case_prod_conv}]) 1
                     in
                       SOME (Goal.prove ctxt [] []
                         (Const (\<^const_name>\<open>Pure.eq\<close>, T --> T --> propT) $ S $ S')
                         (K (EVERY
                           [resolve_tac ctxt [eq_reflection] 1,
                            resolve_tac ctxt @{thms subset_antisym} 1,
                            resolve_tac ctxt @{thms subsetI} 1,
                            dresolve_tac ctxt @{thms CollectD} 1, simp,
                            resolve_tac ctxt @{thms subsetI} 1,
                            resolve_tac ctxt @{thms CollectI} 1, simp])))
                     end
                   else NONE)
           | _ => NONE)
         end
     | _ => NONE)
 \<close>
 
 ML_file \<open>Tools/inductive_set.ML\<close>
 
 
 subsection \<open>Legacy theorem bindings and duplicates\<close>
 
 lemmas fst_conv = prod.sel(1)
 lemmas snd_conv = prod.sel(2)
 lemmas split_def = case_prod_unfold
 lemmas split_beta' = case_prod_beta'
 lemmas split_beta = prod.case_eq_if
 lemmas split_conv = case_prod_conv
 lemmas split = case_prod_conv
 
 hide_const (open) prod
 
 end
diff --git a/src/HOL/Quotient.thy b/src/HOL/Quotient.thy
--- a/src/HOL/Quotient.thy
+++ b/src/HOL/Quotient.thy
@@ -1,883 +1,883 @@
 (*  Title:      HOL/Quotient.thy
     Author:     Cezary Kaliszyk and Christian Urban
 *)
 
 section \<open>Definition of Quotient Types\<close>
 
 theory Quotient
 imports Lifting
 keywords
   "print_quotmapsQ3" "print_quotientsQ3" "print_quotconsts" :: diag and
   "quotient_type" :: thy_goal_defn and "/" and
   "quotient_definition" :: thy_goal_defn and
   "copy_bnf" :: thy_defn and
   "lift_bnf" :: thy_goal_defn
 begin
 
 text \<open>
   Basic definition for equivalence relations
   that are represented by predicates.
 \<close>
 
 text \<open>Composition of Relations\<close>
 
 abbreviation
   rel_conj :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" (infixr "OOO" 75)
 where
   "r1 OOO r2 \<equiv> r1 OO r2 OO r1"
 
 lemma eq_comp_r:
   shows "((=) OOO R) = R"
   by (auto simp add: fun_eq_iff)
 
 context includes lifting_syntax
 begin
 
 subsection \<open>Quotient Predicate\<close>
 
 definition
   "Quotient3 R Abs Rep \<longleftrightarrow>
      (\<forall>a. Abs (Rep a) = a) \<and> (\<forall>a. R (Rep a) (Rep a)) \<and>
      (\<forall>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s)"
 
 lemma Quotient3I:
   assumes "\<And>a. Abs (Rep a) = a"
     and "\<And>a. R (Rep a) (Rep a)"
     and "\<And>r s. R r s \<longleftrightarrow> R r r \<and> R s s \<and> Abs r = Abs s"
   shows "Quotient3 R Abs Rep"
   using assms unfolding Quotient3_def by blast
 
 context
   fixes R Abs Rep
   assumes a: "Quotient3 R Abs Rep"
 begin
 
 lemma Quotient3_abs_rep:
   "Abs (Rep a) = a"
   using a
   unfolding Quotient3_def
   by simp
 
 lemma Quotient3_rep_reflp:
   "R (Rep a) (Rep a)"
   using a
   unfolding Quotient3_def
   by blast
 
 lemma Quotient3_rel:
   "R r r \<and> R s s \<and> Abs r = Abs s \<longleftrightarrow> R r s" \<comment> \<open>orientation does not loop on rewriting\<close>
   using a
   unfolding Quotient3_def
   by blast
 
 lemma Quotient3_refl1:
   "R r s \<Longrightarrow> R r r"
   using a unfolding Quotient3_def
   by fast
 
 lemma Quotient3_refl2:
   "R r s \<Longrightarrow> R s s"
   using a unfolding Quotient3_def
   by fast
 
 lemma Quotient3_rel_rep:
   "R (Rep a) (Rep b) \<longleftrightarrow> a = b"
   using a
   unfolding Quotient3_def
   by metis
 
 lemma Quotient3_rep_abs:
   "R r r \<Longrightarrow> R (Rep (Abs r)) r"
   using a unfolding Quotient3_def
   by blast
 
 lemma Quotient3_rel_abs:
   "R r s \<Longrightarrow> Abs r = Abs s"
   using a unfolding Quotient3_def
   by blast
 
 lemma Quotient3_symp:
   "symp R"
   using a unfolding Quotient3_def using sympI by metis
 
 lemma Quotient3_transp:
   "transp R"
   using a unfolding Quotient3_def using transpI by (metis (full_types))
 
 lemma Quotient3_part_equivp:
   "part_equivp R"
   by (metis Quotient3_rep_reflp Quotient3_symp Quotient3_transp part_equivpI)
 
 lemma abs_o_rep:
   "Abs \<circ> Rep = id"
   unfolding fun_eq_iff
   by (simp add: Quotient3_abs_rep)
 
 lemma equals_rsp:
   assumes b: "R xa xb" "R ya yb"
   shows "R xa ya = R xb yb"
   using b Quotient3_symp Quotient3_transp
   by (blast elim: sympE transpE)
 
 lemma rep_abs_rsp:
   assumes b: "R x1 x2"
   shows "R x1 (Rep (Abs x2))"
   using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
   by metis
 
 lemma rep_abs_rsp_left:
   assumes b: "R x1 x2"
   shows "R (Rep (Abs x1)) x2"
   using b Quotient3_rel Quotient3_abs_rep Quotient3_rep_reflp
   by metis
 
 end
 
 lemma identity_quotient3:
   "Quotient3 (=) id id"
   unfolding Quotient3_def id_def
   by blast
 
 lemma fun_quotient3:
   assumes q1: "Quotient3 R1 abs1 rep1"
   and     q2: "Quotient3 R2 abs2 rep2"
   shows "Quotient3 (R1 ===> R2) (rep1 ---> abs2) (abs1 ---> rep2)"
 proof -
   have "(rep1 ---> abs2) ((abs1 ---> rep2) a) = a" for a
     using q1 q2 by (simp add: Quotient3_def fun_eq_iff)
   moreover
   have "(R1 ===> R2) ((abs1 ---> rep2) a) ((abs1 ---> rep2) a)" for a
     by (rule rel_funI)
-      (insert q1 q2 Quotient3_rel_abs [of R1 abs1 rep1] Quotient3_rel_rep [of R2 abs2 rep2],
-        simp (no_asm) add: Quotient3_def, simp)
+       (use q1 q2 Quotient3_rel_abs [of R1 abs1 rep1] Quotient3_rel_rep [of R2 abs2 rep2]
+         in \<open>simp (no_asm) add: Quotient3_def, simp\<close>)
   moreover
   have "(R1 ===> R2) r s = ((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
         (rep1 ---> abs2) r  = (rep1 ---> abs2) s)" for r s
   proof -
     have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) r r" unfolding rel_fun_def
       using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
       by (metis (full_types) part_equivp_def)
     moreover have "(R1 ===> R2) r s \<Longrightarrow> (R1 ===> R2) s s" unfolding rel_fun_def
       using Quotient3_part_equivp[OF q1] Quotient3_part_equivp[OF q2]
       by (metis (full_types) part_equivp_def)
     moreover have "(R1 ===> R2) r s \<Longrightarrow> (rep1 ---> abs2) r  = (rep1 ---> abs2) s"
       by (auto simp add: rel_fun_def fun_eq_iff)
         (use q1 q2 in \<open>unfold Quotient3_def, metis\<close>)
     moreover have "((R1 ===> R2) r r \<and> (R1 ===> R2) s s \<and>
         (rep1 ---> abs2) r  = (rep1 ---> abs2) s) \<Longrightarrow> (R1 ===> R2) r s"
       by (auto simp add: rel_fun_def fun_eq_iff)
         (use q1 q2 in \<open>unfold Quotient3_def, metis map_fun_apply\<close>)
     ultimately show ?thesis by blast
   qed
   ultimately show ?thesis by (intro Quotient3I) (assumption+)
 qed
 
 lemma lambda_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   shows "(Rep1 ---> Abs2) (\<lambda>x. Rep2 (f (Abs1 x))) = (\<lambda>x. f x)"
   unfolding fun_eq_iff
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
   by simp
 
 lemma lambda_prs1:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   shows "(Rep1 ---> Abs2) (\<lambda>x. (Abs1 ---> Rep2) f x) = (\<lambda>x. f x)"
   unfolding fun_eq_iff
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
   by simp
 
 text\<open>
   In the following theorem R1 can be instantiated with anything,
   but we know some of the types of the Rep and Abs functions;
   so by solving Quotient assumptions we can get a unique R1 that
   will be provable; which is why we need to use \<open>apply_rsp\<close> and
   not the primed version\<close>
 
 lemma apply_rspQ3:
   fixes f g::"'a \<Rightarrow> 'c"
   assumes q: "Quotient3 R1 Abs1 Rep1"
   and     a: "(R1 ===> R2) f g" "R1 x y"
   shows "R2 (f x) (g y)"
   using a by (auto elim: rel_funE)
 
 lemma apply_rspQ3'':
   assumes "Quotient3 R Abs Rep"
   and "(R ===> S) f f"
   shows "S (f (Rep x)) (f (Rep x))"
 proof -
   from assms(1) have "R (Rep x) (Rep x)" by (rule Quotient3_rep_reflp)
   then show ?thesis using assms(2) by (auto intro: apply_rsp')
 qed
 
 subsection \<open>lemmas for regularisation of ball and bex\<close>
 
 lemma ball_reg_eqv:
   fixes P :: "'a \<Rightarrow> bool"
   assumes a: "equivp R"
   shows "Ball (Respects R) P = (All P)"
   using a
   unfolding equivp_def
   by (auto simp add: in_respects)
 
 lemma bex_reg_eqv:
   fixes P :: "'a \<Rightarrow> bool"
   assumes a: "equivp R"
   shows "Bex (Respects R) P = (Ex P)"
   using a
   unfolding equivp_def
   by (auto simp add: in_respects)
 
 lemma ball_reg_right:
   assumes a: "\<And>x. x \<in> R \<Longrightarrow> P x \<longrightarrow> Q x"
   shows "All P \<longrightarrow> Ball R Q"
   using a by fast
 
 lemma bex_reg_left:
   assumes a: "\<And>x. x \<in> R \<Longrightarrow> Q x \<longrightarrow> P x"
   shows "Bex R Q \<longrightarrow> Ex P"
   using a by fast
 
 lemma ball_reg_left:
   assumes a: "equivp R"
   shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ball (Respects R) Q \<longrightarrow> All P"
   using a by (metis equivp_reflp in_respects)
 
 lemma bex_reg_right:
   assumes a: "equivp R"
   shows "(\<And>x. (Q x \<longrightarrow> P x)) \<Longrightarrow> Ex Q \<longrightarrow> Bex (Respects R) P"
   using a by (metis equivp_reflp in_respects)
 
 lemma ball_reg_eqv_range:
   fixes P::"'a \<Rightarrow> bool"
   and x::"'a"
   assumes a: "equivp R2"
   shows "(Ball (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = All (\<lambda>f. P (f x)))"
 proof (intro allI iffI)
   fix f
   assume "\<forall>f \<in> Respects (R1 ===> R2). P (f x)"
   moreover have "(\<lambda>y. f x) \<in> Respects (R1 ===> R2)"
     using a equivp_reflp_symp_transp[of "R2"]
     by(auto simp add: in_respects rel_fun_def elim: equivpE reflpE)
   ultimately show "P (f x)"
     by auto
 qed auto
 
 lemma bex_reg_eqv_range:
   assumes a: "equivp R2"
   shows   "(Bex (Respects (R1 ===> R2)) (\<lambda>f. P (f x)) = Ex (\<lambda>f. P (f x)))"
 proof -
   { fix f
     assume "P (f x)"
     have "(\<lambda>y. f x) \<in> Respects (R1 ===> R2)"
       using a equivp_reflp_symp_transp[of "R2"]
       by (auto simp add: Respects_def in_respects rel_fun_def elim: equivpE reflpE) }
   then show ?thesis
     by auto
 qed
 
 (* Next four lemmas are unused *)
 lemma all_reg:
   assumes a: "\<forall>x :: 'a. (P x \<longrightarrow> Q x)"
   and     b: "All P"
   shows "All Q"
   using a b by fast
 
 lemma ex_reg:
   assumes a: "\<forall>x :: 'a. (P x \<longrightarrow> Q x)"
   and     b: "Ex P"
   shows "Ex Q"
   using a b by fast
 
 lemma ball_reg:
   assumes a: "\<forall>x :: 'a. (x \<in> R \<longrightarrow> P x \<longrightarrow> Q x)"
   and     b: "Ball R P"
   shows "Ball R Q"
   using a b by fast
 
 lemma bex_reg:
   assumes a: "\<forall>x :: 'a. (x \<in> R \<longrightarrow> P x \<longrightarrow> Q x)"
   and     b: "Bex R P"
   shows "Bex R Q"
   using a b by fast
 
 
 lemma ball_all_comm:
   assumes "\<And>y. (\<forall>x\<in>P. A x y) \<longrightarrow> (\<forall>x. B x y)"
   shows "(\<forall>x\<in>P. \<forall>y. A x y) \<longrightarrow> (\<forall>x. \<forall>y. B x y)"
   using assms by auto
 
 lemma bex_ex_comm:
   assumes "(\<exists>y. \<exists>x. A x y) \<longrightarrow> (\<exists>y. \<exists>x\<in>P. B x y)"
   shows "(\<exists>x. \<exists>y. A x y) \<longrightarrow> (\<exists>x\<in>P. \<exists>y. B x y)"
   using assms by auto
 
 subsection \<open>Bounded abstraction\<close>
 
 definition
   Babs :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b"
 where
   "x \<in> p \<Longrightarrow> Babs p m x = m x"
 
 lemma babs_rsp:
   assumes q: "Quotient3 R1 Abs1 Rep1"
-  and     a: "(R1 ===> R2) f g"
-  shows      "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
-proof (clarsimp simp add: Babs_def in_respects rel_fun_def)
+      and a: "(R1 ===> R2) f g"
+    shows "(R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)"
+proof
   fix x y
   assume "R1 x y"
   then have "x \<in> Respects R1 \<and> y \<in> Respects R1"
     unfolding in_respects rel_fun_def using Quotient3_rel[OF q]by metis
   then show "R2 (Babs (Respects R1) f x) (Babs (Respects R1) g y)"
   using \<open>R1 x y\<close> a by (simp add: Babs_def rel_fun_def)
 qed
 
 lemma babs_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
 shows "((Rep1 ---> Abs2) (Babs (Respects R1) ((Abs1 ---> Rep2) f))) = f"
 proof -
   { fix x
     have "Rep1 x \<in> Respects R1"
       by (simp add: in_respects Quotient3_rel_rep[OF q1])
     then have "Abs2 (Babs (Respects R1) ((Abs1 ---> Rep2) f) (Rep1 x)) = f x" 
       by (simp add: Babs_def Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2])
   }
   then show ?thesis
     by force
 qed
 
 lemma babs_simp:
   assumes q: "Quotient3 R1 Abs Rep"
   shows "((R1 ===> R2) (Babs (Respects R1) f) (Babs (Respects R1) g)) = ((R1 ===> R2) f g)"
          (is "?lhs = ?rhs")
 proof
   assume ?lhs
   then show ?rhs
     unfolding rel_fun_def by (metis Babs_def in_respects  Quotient3_rel[OF q])
 qed (simp add: babs_rsp[OF q])
 
 text \<open>If a user proves that a particular functional relation
    is an equivalence, this may be useful in regularising\<close>
 lemma babs_reg_eqv:
   shows "equivp R \<Longrightarrow> Babs (Respects R) P = P"
   by (simp add: fun_eq_iff Babs_def in_respects equivp_reflp)
 
 
 (* 3 lemmas needed for proving repabs_inj *)
 lemma ball_rsp:
   assumes a: "(R ===> (=)) f g"
   shows "Ball (Respects R) f = Ball (Respects R) g"
   using a by (auto simp add: Ball_def in_respects elim: rel_funE)
 
 lemma bex_rsp:
   assumes a: "(R ===> (=)) f g"
   shows "(Bex (Respects R) f = Bex (Respects R) g)"
   using a by (auto simp add: Bex_def in_respects elim: rel_funE)
 
 lemma bex1_rsp:
   assumes a: "(R ===> (=)) f g"
   shows "Ex1 (\<lambda>x. x \<in> Respects R \<and> f x) = Ex1 (\<lambda>x. x \<in> Respects R \<and> g x)"
   using a by (auto elim: rel_funE simp add: Ex1_def in_respects)
 
 text \<open>Two lemmas needed for cleaning of quantifiers\<close>
 
 lemma all_prs:
   assumes a: "Quotient3 R absf repf"
   shows "Ball (Respects R) ((absf ---> id) f) = All f"
   using a unfolding Quotient3_def Ball_def in_respects id_apply comp_def map_fun_def
   by metis
 
 lemma ex_prs:
   assumes a: "Quotient3 R absf repf"
   shows "Bex (Respects R) ((absf ---> id) f) = Ex f"
   using a unfolding Quotient3_def Bex_def in_respects id_apply comp_def map_fun_def
   by metis
 
 subsection \<open>\<open>Bex1_rel\<close> quantifier\<close>
 
 definition
   Bex1_rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
 where
   "Bex1_rel R P \<longleftrightarrow> (\<exists>x \<in> Respects R. P x) \<and> (\<forall>x \<in> Respects R. \<forall>y \<in> Respects R. ((P x \<and> P y) \<longrightarrow> (R x y)))"
 
 lemma bex1_rel_aux:
   "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R x\<rbrakk> \<Longrightarrow> Bex1_rel R y"
   unfolding Bex1_rel_def
   by (metis in_respects)
 
 lemma bex1_rel_aux2:
   "\<lbrakk>\<forall>xa ya. R xa ya \<longrightarrow> x xa = y ya; Bex1_rel R y\<rbrakk> \<Longrightarrow> Bex1_rel R x"
   unfolding Bex1_rel_def
   by (metis in_respects)
 
 lemma bex1_rel_rsp:
   assumes a: "Quotient3 R absf repf"
   shows "((R ===> (=)) ===> (=)) (Bex1_rel R) (Bex1_rel R)"
   unfolding rel_fun_def by (metis bex1_rel_aux bex1_rel_aux2)
 
 lemma ex1_prs:
   assumes "Quotient3 R absf repf"
   shows "((absf ---> id) ---> id) (Bex1_rel R) f = Ex1 f"
          (is "?lhs = ?rhs")
   using assms
   apply (auto simp add: Bex1_rel_def Respects_def)
   by (metis (full_types) Quotient3_def)+
 
 lemma bex1_bexeq_reg:
   shows "(\<exists>!x\<in>Respects R. P x) \<longrightarrow> (Bex1_rel R (\<lambda>x. P x))"
   by (auto simp add: Ex1_def Bex1_rel_def Bex_def Ball_def in_respects)
 
 lemma bex1_bexeq_reg_eqv:
   assumes a: "equivp R"
   shows "(\<exists>!x. P x) \<longrightarrow> Bex1_rel R P"
   using equivp_reflp[OF a]
   by (metis (full_types) Bex1_rel_def in_respects)
 
 subsection \<open>Various respects and preserve lemmas\<close>
 
 lemma quot_rel_rsp:
   assumes a: "Quotient3 R Abs Rep"
   shows "(R ===> R ===> (=)) R R"
   apply(rule rel_funI)+
   by (meson assms equals_rsp)
 
 lemma o_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   and     q3: "Quotient3 R3 Abs3 Rep3"
   shows "((Abs2 ---> Rep3) ---> (Abs1 ---> Rep2) ---> (Rep1 ---> Abs3)) (\<circ>) = (\<circ>)"
   and   "(id ---> (Abs1 ---> id) ---> Rep1 ---> id) (\<circ>) = (\<circ>)"
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2] Quotient3_abs_rep[OF q3]
   by (simp_all add: fun_eq_iff)
 
 lemma o_rsp:
   "((R2 ===> R3) ===> (R1 ===> R2) ===> (R1 ===> R3)) (\<circ>) (\<circ>)"
   "((=) ===> (R1 ===> (=)) ===> R1 ===> (=)) (\<circ>) (\<circ>)"
   by (force elim: rel_funE)+
 
 lemma cond_prs:
   assumes a: "Quotient3 R absf repf"
   shows "absf (if a then repf b else repf c) = (if a then b else c)"
   using a unfolding Quotient3_def by auto
 
 lemma if_prs:
   assumes q: "Quotient3 R Abs Rep"
   shows "(id ---> Rep ---> Rep ---> Abs) If = If"
   using Quotient3_abs_rep[OF q]
   by (auto simp add: fun_eq_iff)
 
 lemma if_rsp:
   assumes q: "Quotient3 R Abs Rep"
   shows "((=) ===> R ===> R ===> R) If If"
   by force
 
 lemma let_prs:
   assumes q1: "Quotient3 R1 Abs1 Rep1"
   and     q2: "Quotient3 R2 Abs2 Rep2"
   shows "(Rep2 ---> (Abs2 ---> Rep1) ---> Abs1) Let = Let"
   using Quotient3_abs_rep[OF q1] Quotient3_abs_rep[OF q2]
   by (auto simp add: fun_eq_iff)
 
 lemma let_rsp:
   shows "(R1 ===> (R1 ===> R2) ===> R2) Let Let"
   by (force elim: rel_funE)
 
 lemma id_rsp:
   shows "(R ===> R) id id"
   by auto
 
 lemma id_prs:
   assumes a: "Quotient3 R Abs Rep"
   shows "(Rep ---> Abs) id = id"
   by (simp add: fun_eq_iff Quotient3_abs_rep [OF a])
 
 end
 
 locale quot_type =
   fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   and   Abs :: "'a set \<Rightarrow> 'b"
   and   Rep :: "'b \<Rightarrow> 'a set"
   assumes equivp: "part_equivp R"
   and     rep_prop: "\<And>y. \<exists>x. R x x \<and> Rep y = Collect (R x)"
   and     rep_inverse: "\<And>x. Abs (Rep x) = x"
   and     abs_inverse: "\<And>c. (\<exists>x. ((R x x) \<and> (c = Collect (R x)))) \<Longrightarrow> (Rep (Abs c)) = c"
   and     rep_inject: "\<And>x y. (Rep x = Rep y) = (x = y)"
 begin
 
 definition
   abs :: "'a \<Rightarrow> 'b"
 where
   "abs x = Abs (Collect (R x))"
 
 definition
   rep :: "'b \<Rightarrow> 'a"
 where
   "rep a = (SOME x. x \<in> Rep a)"
 
 lemma some_collect:
   assumes "R r r"
   shows "R (SOME x. x \<in> Collect (R r)) = R r"
   apply simp
   by (metis assms exE_some equivp[simplified part_equivp_def])
 
 lemma Quotient:
   shows "Quotient3 R abs rep"
   unfolding Quotient3_def abs_def rep_def
   proof (intro conjI allI)
     fix a r s
     show x: "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)" proof -
       obtain x where r: "R x x" and rep: "Rep a = Collect (R x)" using rep_prop[of a] by auto
       have "R (SOME x. x \<in> Rep a) x"  using r rep some_collect by metis
       then have "R x (SOME x. x \<in> Rep a)" using part_equivp_symp[OF equivp] by fast
       then show "R (SOME x. x \<in> Rep a) (SOME x. x \<in> Rep a)"
         using part_equivp_transp[OF equivp] by (metis \<open>R (SOME x. x \<in> Rep a) x\<close>)
     qed
     have "Collect (R (SOME x. x \<in> Rep a)) = (Rep a)" by (metis some_collect rep_prop)
     then show "Abs (Collect (R (SOME x. x \<in> Rep a))) = a" using rep_inverse by auto
     have "R r r \<Longrightarrow> R s s \<Longrightarrow> Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s"
     proof -
       assume "R r r" and "R s s"
       then have "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> Collect (R r) = Collect (R s)"
         by (metis abs_inverse)
       also have "Collect (R r) = Collect (R s) \<longleftrightarrow> (\<lambda>A x. x \<in> A) (Collect (R r)) = (\<lambda>A x. x \<in> A) (Collect (R s))"
-        by rule simp_all
+        by (rule iffI) simp_all
       finally show "Abs (Collect (R r)) = Abs (Collect (R s)) \<longleftrightarrow> R r = R s" by simp
     qed
     then show "R r s \<longleftrightarrow> R r r \<and> R s s \<and> (Abs (Collect (R r)) = Abs (Collect (R s)))"
       using equivp[simplified part_equivp_def] by metis
     qed
 
 end
 
 subsection \<open>Quotient composition\<close>
 
 lemma OOO_quotient3:
   fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
   fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
   fixes R2' :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   fixes R2 :: "'b \<Rightarrow> 'b \<Rightarrow> bool"
   assumes R1: "Quotient3 R1 Abs1 Rep1"
   assumes R2: "Quotient3 R2 Abs2 Rep2"
   assumes Abs1: "\<And>x y. R2' x y \<Longrightarrow> R1 x x \<Longrightarrow> R1 y y \<Longrightarrow> R2 (Abs1 x) (Abs1 y)"
   assumes Rep1: "\<And>x y. R2 x y \<Longrightarrow> R2' (Rep1 x) (Rep1 y)"
   shows "Quotient3 (R1 OO R2' OO R1) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
 proof -
   have *: "(R1 OOO R2') r r \<and> (R1 OOO R2') s s \<and> (Abs2 \<circ> Abs1) r = (Abs2 \<circ> Abs1) s
            \<longleftrightarrow> (R1 OOO R2') r s" for r s
   proof (intro iffI conjI; clarify) 
     show "(R1 OOO R2') r s"
       if r: "R1 r a" "R2' a b" "R1 b r" and eq: "(Abs2 \<circ> Abs1) r = (Abs2 \<circ> Abs1) s" 
         and s: "R1 s c" "R2' c d" "R1 d s" for a b c d
     proof -
       have "R1 r (Rep1 (Abs1 r))"
         using r Quotient3_refl1 R1 rep_abs_rsp by fastforce
       moreover have "R2' (Rep1 (Abs1 r)) (Rep1 (Abs1 s))"
         using that
         apply simp
         apply (metis (full_types) Rep1 Abs1 Quotient3_rel R2 Quotient3_refl1 [OF R1] Quotient3_refl2 [OF R1] Quotient3_rel_abs [OF R1])
         done
       moreover have "R1 (Rep1 (Abs1 s)) s"
         by (metis s Quotient3_rel R1 rep_abs_rsp_left)
       ultimately show ?thesis
         by (metis relcomppI)
     qed
   next
     fix x y
     assume xy: "R1 r x" "R2' x y" "R1 y s"
     then have "R2 (Abs1 x) (Abs1 y)"
       by (iprover dest: Abs1 elim: Quotient3_refl1 [OF R1] Quotient3_refl2 [OF R1])
     then have "R2' (Rep1 (Abs1 x)) (Rep1 (Abs1 x))" "R2' (Rep1 (Abs1 y)) (Rep1 (Abs1 y))"
       by (simp_all add: Quotient3_refl1 [OF R2] Quotient3_refl2 [OF R2] Rep1)
     with \<open>R1 r x\<close> \<open>R1 y s\<close> show "(R1 OOO R2') r r" "(R1 OOO R2') s s"
       by (metis (full_types) Quotient3_def R1 relcompp.relcompI)+
     show "(Abs2 \<circ> Abs1) r = (Abs2 \<circ> Abs1) s"
       using xy by simp (metis (full_types) Abs1 Quotient3_rel R1 R2)
   qed
   show ?thesis
     apply (rule Quotient3I)
     using * apply (simp_all add: o_def Quotient3_abs_rep [OF R2] Quotient3_abs_rep [OF R1])
     apply (metis Quotient3_rep_reflp R1 R2 Rep1 relcompp.relcompI)
     done
 qed
 
 lemma OOO_eq_quotient3:
   fixes R1 :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   fixes Abs1 :: "'a \<Rightarrow> 'b" and Rep1 :: "'b \<Rightarrow> 'a"
   fixes Abs2 :: "'b \<Rightarrow> 'c" and Rep2 :: "'c \<Rightarrow> 'b"
   assumes R1: "Quotient3 R1 Abs1 Rep1"
   assumes R2: "Quotient3 (=) Abs2 Rep2"
   shows "Quotient3 (R1 OOO (=)) (Abs2 \<circ> Abs1) (Rep1 \<circ> Rep2)"
 using assms
 by (rule OOO_quotient3) auto
 
 subsection \<open>Quotient3 to Quotient\<close>
 
 lemma Quotient3_to_Quotient:
 assumes "Quotient3 R Abs Rep"
 and "T \<equiv> \<lambda>x y. R x x \<and> Abs x = y"
 shows "Quotient R Abs Rep T"
 using assms unfolding Quotient3_def by (intro QuotientI) blast+
 
 lemma Quotient3_to_Quotient_equivp:
 assumes q: "Quotient3 R Abs Rep"
 and T_def: "T \<equiv> \<lambda>x y. Abs x = y"
 and eR: "equivp R"
 shows "Quotient R Abs Rep T"
 proof (intro QuotientI)
   fix a
   show "Abs (Rep a) = a" using q by(rule Quotient3_abs_rep)
 next
   fix a
   show "R (Rep a) (Rep a)" using q by(rule Quotient3_rep_reflp)
 next
   fix r s
   show "R r s = (R r r \<and> R s s \<and> Abs r = Abs s)" using q by(rule Quotient3_rel[symmetric])
 next
   show "T = (\<lambda>x y. R x x \<and> Abs x = y)" using T_def equivp_reflp[OF eR] by simp
 qed
 
 subsection \<open>ML setup\<close>
 
 text \<open>Auxiliary data for the quotient package\<close>
 
 named_theorems quot_equiv "equivalence relation theorems"
   and quot_respect "respectfulness theorems"
   and quot_preserve "preservation theorems"
   and id_simps "identity simp rules for maps"
   and quot_thm "quotient theorems"
 ML_file \<open>Tools/Quotient/quotient_info.ML\<close>
 
 declare [[mapQ3 "fun" = (rel_fun, fun_quotient3)]]
 
 lemmas [quot_thm] = fun_quotient3
 lemmas [quot_respect] = quot_rel_rsp if_rsp o_rsp let_rsp id_rsp
 lemmas [quot_preserve] = if_prs o_prs let_prs id_prs
 lemmas [quot_equiv] = identity_equivp
 
 
 text \<open>Lemmas about simplifying id's.\<close>
 lemmas [id_simps] =
   id_def[symmetric]
   map_fun_id
   id_apply
   id_o
   o_id
   eq_comp_r
   vimage_id
 
 text \<open>Translation functions for the lifting process.\<close>
 ML_file \<open>Tools/Quotient/quotient_term.ML\<close>
 
 
 text \<open>Definitions of the quotient types.\<close>
 ML_file \<open>Tools/Quotient/quotient_type.ML\<close>
 
 
 text \<open>Definitions for quotient constants.\<close>
 ML_file \<open>Tools/Quotient/quotient_def.ML\<close>
 
 
 text \<open>
   An auxiliary constant for recording some information
   about the lifted theorem in a tactic.
 \<close>
 definition
   Quot_True :: "'a \<Rightarrow> bool"
 where
   "Quot_True x \<longleftrightarrow> True"
 
 lemma
   shows QT_all: "Quot_True (All P) \<Longrightarrow> Quot_True P"
   and   QT_ex:  "Quot_True (Ex P) \<Longrightarrow> Quot_True P"
   and   QT_ex1: "Quot_True (Ex1 P) \<Longrightarrow> Quot_True P"
   and   QT_lam: "Quot_True (\<lambda>x. P x) \<Longrightarrow> (\<And>x. Quot_True (P x))"
   and   QT_ext: "(\<And>x. Quot_True (a x) \<Longrightarrow> f x = g x) \<Longrightarrow> (Quot_True a \<Longrightarrow> f = g)"
   by (simp_all add: Quot_True_def ext)
 
 lemma QT_imp: "Quot_True a \<equiv> Quot_True b"
   by (simp add: Quot_True_def)
 
 context includes lifting_syntax
 begin
 
 text \<open>Tactics for proving the lifted theorems\<close>
 ML_file \<open>Tools/Quotient/quotient_tacs.ML\<close>
 
 end
 
 subsection \<open>Methods / Interface\<close>
 
 method_setup lifting =
   \<open>Attrib.thms >> (fn thms => fn ctxt =>
        SIMPLE_METHOD' (Quotient_Tacs.lift_tac ctxt [] thms))\<close>
   \<open>lift theorems to quotient types\<close>
 
 method_setup lifting_setup =
   \<open>Attrib.thm >> (fn thm => fn ctxt =>
        SIMPLE_METHOD' (Quotient_Tacs.lift_procedure_tac ctxt [] thm))\<close>
   \<open>set up the three goals for the quotient lifting procedure\<close>
 
 method_setup descending =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_tac ctxt []))\<close>
   \<open>decend theorems to the raw level\<close>
 
 method_setup descending_setup =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.descend_procedure_tac ctxt []))\<close>
   \<open>set up the three goals for the decending theorems\<close>
 
 method_setup partiality_descending =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_tac ctxt []))\<close>
   \<open>decend theorems to the raw level\<close>
 
 method_setup partiality_descending_setup =
   \<open>Scan.succeed (fn ctxt =>
        SIMPLE_METHOD' (Quotient_Tacs.partiality_descend_procedure_tac ctxt []))\<close>
   \<open>set up the three goals for the decending theorems\<close>
 
 method_setup regularize =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.regularize_tac ctxt))\<close>
   \<open>prove the regularization goals from the quotient lifting procedure\<close>
 
 method_setup injection =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.all_injection_tac ctxt))\<close>
   \<open>prove the rep/abs injection goals from the quotient lifting procedure\<close>
 
 method_setup cleaning =
   \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Quotient_Tacs.clean_tac ctxt))\<close>
   \<open>prove the cleaning goals from the quotient lifting procedure\<close>
 
 attribute_setup quot_lifted =
   \<open>Scan.succeed Quotient_Tacs.lifted_attrib\<close>
   \<open>lift theorems to quotient types\<close>
 
 no_notation
   rel_conj (infixr "OOO" 75)
 
 section \<open>Lifting of BNFs\<close>
 
 lemma sum_insert_Inl_unit: "x \<in> A \<Longrightarrow> (\<And>y. x = Inr y \<Longrightarrow> Inr y \<in> B) \<Longrightarrow> x \<in> insert (Inl ()) B"
   by (cases x) (simp_all)
 
 lemma lift_sum_unit_vimage_commute:
   "insert (Inl ()) (Inr ` f -` A) = map_sum id f -` insert (Inl ()) (Inr ` A)"
   by (auto simp: map_sum_def split: sum.splits)
 
 lemma insert_Inl_int_map_sum_unit: "insert (Inl ()) A \<inter> range (map_sum id f) \<noteq> {}"
   by (auto simp: map_sum_def split: sum.splits)
 
 lemma image_map_sum_unit_subset:
   "A \<subseteq> insert (Inl ()) (Inr ` B) \<Longrightarrow> map_sum id f ` A \<subseteq> insert (Inl ()) (Inr ` f ` B)"
   by auto
 
 lemma subset_lift_sum_unitD: "A \<subseteq> insert (Inl ()) (Inr ` B) \<Longrightarrow> Inr x \<in> A \<Longrightarrow> x \<in> B"
   unfolding insert_def by auto
 
 lemma UNIV_sum_unit_conv: "insert (Inl ()) (range Inr) = UNIV"
   unfolding UNIV_sum UNIV_unit image_insert image_empty Un_insert_left sup_bot.left_neutral..
 
 lemma subset_vimage_image_subset: "A \<subseteq> f -` B \<Longrightarrow> f ` A \<subseteq> B"
   by auto
 
 lemma relcompp_mem_Grp_neq_bot:
   "A \<inter> range f \<noteq> {} \<Longrightarrow> (\<lambda>x y. x \<in> A \<and> y \<in> A) OO (Grp UNIV f)\<inverse>\<inverse> \<noteq> bot"
   unfolding Grp_def relcompp_apply fun_eq_iff by blast
 
 lemma comp_projr_Inr: "projr \<circ> Inr = id"
   by auto
 
 lemma in_rel_sum_in_image_projr:
   "B \<subseteq> {(x,y). rel_sum ((=) :: unit \<Rightarrow> unit \<Rightarrow> bool) A x y} \<Longrightarrow>
    Inr ` C = fst ` B \<Longrightarrow> snd ` B = Inr ` D \<Longrightarrow> map_prod projr projr ` B \<subseteq> {(x,y). A x y}"
   by (force simp: projr_def image_iff dest!: spec[of _ "Inl ()"]  split: sum.splits)
 
 lemma subset_rel_sumI: "B \<subseteq> {(x,y). A x y} \<Longrightarrow> rel_sum ((=) :: unit => unit => bool) A
     (if x \<in> B then Inr (fst x) else Inl ())
     (if x \<in> B then Inr (snd x) else Inl ())"
   by auto
 
 lemma relcompp_eq_Grp_neq_bot: "(=) OO (Grp UNIV f)\<inverse>\<inverse> \<noteq> bot"
   unfolding Grp_def relcompp_apply fun_eq_iff by blast
 
 lemma rel_fun_rel_OO1: "(rel_fun Q (rel_fun R (=))) A B \<Longrightarrow> conversep Q OO A OO R \<le> B"
   by (auto simp: rel_fun_def)
 
 lemma rel_fun_rel_OO2: "(rel_fun Q (rel_fun R (=))) A B \<Longrightarrow> Q OO B OO conversep R \<le> A"
   by (auto simp: rel_fun_def)
 
 lemma rel_sum_eq2_nonempty: "rel_sum (=) A OO rel_sum (=) B \<noteq> bot"
   by (auto simp: fun_eq_iff relcompp_apply intro!: exI[of _ "Inl _"])
 
 lemma rel_sum_eq3_nonempty: "rel_sum (=) A OO (rel_sum (=) B OO rel_sum (=) C) \<noteq> bot"
   by (auto simp: fun_eq_iff relcompp_apply intro!: exI[of _ "Inl _"])
 
 lemma hypsubst: "A = B \<Longrightarrow> x \<in> B \<Longrightarrow> (x \<in> A \<Longrightarrow> P) \<Longrightarrow> P" by simp
 
 lemma Quotient_crel_quotient: "Quotient R Abs Rep T \<Longrightarrow> equivp R \<Longrightarrow> T \<equiv> (\<lambda>x y. Abs x = y)"
   by (drule Quotient_cr_rel) (auto simp: fun_eq_iff equivp_reflp intro!: eq_reflection)
 
 lemma Quotient_crel_typedef: "Quotient (eq_onp P) Abs Rep T \<Longrightarrow> T \<equiv> (\<lambda>x y. x = Rep y)"
   unfolding Quotient_def
   by (auto 0 4 simp: fun_eq_iff eq_onp_def intro: sym intro!: eq_reflection)
 
 lemma Quotient_crel_typecopy: "Quotient (=) Abs Rep T \<Longrightarrow> T \<equiv> (\<lambda>x y. x = Rep y)"
   by (subst (asm) eq_onp_True[symmetric]) (rule Quotient_crel_typedef)
 
 lemma equivp_add_relconj:
   assumes equiv: "equivp R" "equivp R'" and le: "S OO T OO U \<le> R OO STU OO R'"
   shows "R OO S OO T OO U OO R' \<le> R OO STU OO R'"
 proof -
   have trans: "R OO R \<le> R" "R' OO R' \<le> R'"
     using equiv unfolding equivp_reflp_symp_transp transp_relcompp by blast+
   have "R OO S OO T OO U OO R' = R OO (S OO T OO U) OO R'"
     unfolding relcompp_assoc ..
   also have "\<dots> \<le> R OO (R OO STU OO R') OO R'"
     by (intro le relcompp_mono order_refl)
   also have "\<dots> \<le> (R OO R) OO STU OO (R' OO R')"
     unfolding relcompp_assoc ..
   also have "\<dots> \<le> R OO STU OO R'"
     by (intro trans relcompp_mono order_refl)
   finally show ?thesis .
 qed
 
 lemma Grp_conversep_eq_onp: "((BNF_Def.Grp UNIV f)\<inverse>\<inverse> OO BNF_Def.Grp UNIV f) = eq_onp (\<lambda>x. x \<in> range f)"
   by (auto simp: fun_eq_iff Grp_def eq_onp_def image_iff)
 
 lemma Grp_conversep_nonempty: "(BNF_Def.Grp UNIV f)\<inverse>\<inverse> OO BNF_Def.Grp UNIV f \<noteq> bot"
   by (auto simp: fun_eq_iff Grp_def)
 
 lemma relcomppI2: "r a b \<Longrightarrow> s b c \<Longrightarrow> t c d \<Longrightarrow> (r OO s OO t) a d"
   by (auto)
 
 lemma rel_conj_eq_onp: "equivp R \<Longrightarrow> rel_conj R (eq_onp P) \<le> R"
   by (auto simp: eq_onp_def transp_def equivp_def)
 
 lemma Quotient_Quotient3: "Quotient R Abs Rep T \<Longrightarrow> Quotient3 R Abs Rep"
   unfolding Quotient_def Quotient3_def by blast
 
 lemma Quotient_reflp_imp_equivp: "Quotient R Abs Rep T \<Longrightarrow> reflp R \<Longrightarrow> equivp R"
   using Quotient_symp Quotient_transp equivpI by blast
 
 lemma Quotient_eq_onp_typedef:
   "Quotient (eq_onp P) Abs Rep cr \<Longrightarrow> type_definition Rep Abs {x. P x}"
   unfolding Quotient_def eq_onp_def
   by unfold_locales auto
 
 lemma Quotient_eq_onp_type_copy:
   "Quotient (=) Abs Rep cr \<Longrightarrow> type_definition Rep Abs UNIV"
   unfolding Quotient_def eq_onp_def
   by unfold_locales auto
 
 ML_file "Tools/BNF/bnf_lift.ML"
 
 hide_fact
   sum_insert_Inl_unit lift_sum_unit_vimage_commute insert_Inl_int_map_sum_unit
   image_map_sum_unit_subset subset_lift_sum_unitD UNIV_sum_unit_conv subset_vimage_image_subset
   relcompp_mem_Grp_neq_bot comp_projr_Inr in_rel_sum_in_image_projr subset_rel_sumI
   relcompp_eq_Grp_neq_bot rel_fun_rel_OO1 rel_fun_rel_OO2 rel_sum_eq2_nonempty rel_sum_eq3_nonempty
   hypsubst equivp_add_relconj Grp_conversep_eq_onp Grp_conversep_nonempty relcomppI2 rel_conj_eq_onp
   Quotient_reflp_imp_equivp Quotient_Quotient3
 
 end
diff --git a/src/HOL/Relation.thy b/src/HOL/Relation.thy
--- a/src/HOL/Relation.thy
+++ b/src/HOL/Relation.thy
@@ -1,1336 +1,1343 @@
 (*  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_on :: "'a set \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "reflp_on A R \<longleftrightarrow> (\<forall>x\<in>A. R x x)"
 
 abbreviation reflp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "reflp \<equiv> reflp_on UNIV"
 
 lemma reflp_def[no_atp]: "reflp R \<longleftrightarrow> (\<forall>x. R x x)"
   by (simp add: reflp_on_def)
 
 text \<open>@{thm [source] reflp_def} is for backward compatibility.\<close>
 
 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 reflp_onI:
   "(\<And>x y. x \<in> A \<Longrightarrow> R x x) \<Longrightarrow> reflp_on A R"
   by (simp add: reflp_on_def)
 
 lemma reflpI[intro?]: "(\<And>x. R x x) \<Longrightarrow> reflp R"
   by (rule reflp_onI)
 
 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 reflp_onD:
   "reflp_on A R \<Longrightarrow> x \<in> A \<Longrightarrow> R x x"
   by (simp add: reflp_on_def)
 
 lemma reflpD[dest?]: "reflp R \<Longrightarrow> R x x"
   by (simp add: reflp_onD)
 
 lemma reflpE:
   assumes "reflp r"
   obtains "r x x"
   using assms by (auto dest: refl_onD simp add: reflp_def)
 
 lemma reflp_on_subset: "reflp_on A R \<Longrightarrow> B \<subseteq> A \<Longrightarrow> reflp_on B R"
   by (auto intro: reflp_onI dest: reflp_onD)
 
 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_on_inf: "reflp_on A R \<Longrightarrow> reflp_on B S \<Longrightarrow> reflp_on (A \<inter> B) (R \<sqinter> S)"
   by (auto intro: reflp_onI dest: reflp_onD)
 
 lemma reflp_inf: "reflp r \<Longrightarrow> reflp s \<Longrightarrow> reflp (r \<sqinter> s)"
   by (rule reflp_on_inf[of UNIV _ UNIV, unfolded Int_absorb])
 
 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_on_sup: "reflp_on A R \<Longrightarrow> reflp_on B S \<Longrightarrow> reflp_on (A \<union> B) (R \<squnion> S)"
   by (auto intro: reflp_onI dest: reflp_onD)
 
 lemma reflp_sup: "reflp r \<Longrightarrow> reflp s \<Longrightarrow> reflp (r \<squnion> s)"
   by (rule reflp_on_sup[of UNIV _ UNIV, unfolded Un_absorb])
 
 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 reflp_on_Inf: "\<forall>x\<in>S. reflp_on (A x) (R x) \<Longrightarrow> reflp_on (\<Inter>(A ` S)) (\<Sqinter>(R ` S))"
   by (auto intro: reflp_onI dest: reflp_onD)
 
 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 reflp_on_Sup: "\<forall>x\<in>S. reflp_on (A x) (R x) \<Longrightarrow> reflp_on (\<Union>(A ` S)) (\<Squnion>(R ` S))"
   by (auto intro: reflp_onI dest: reflp_onD)
 
 lemma refl_on_empty [simp]: "refl_on {} {}"
   by (simp add: refl_on_def)
 
 lemma reflp_on_empty [simp]: "reflp_on {} R"
   by (auto intro: reflp_onI)
 
 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_on_mono:
   "reflp_on A R \<Longrightarrow> (\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> R x y \<Longrightarrow> Q x y) \<Longrightarrow> reflp_on A Q"
   by (auto intro: reflp_onI dest: reflp_onD)
 
 lemma reflp_mono: "reflp R \<Longrightarrow> (\<And>x y. R x y \<Longrightarrow> Q x y) \<Longrightarrow> reflp Q"
   by (rule reflp_on_mono[of UNIV R Q]) simp_all
 
 
 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)
 
 lemma (in preorder) irreflp_less[simp]: "irreflp (<)"
   by (simp add: irreflpI)
 
 lemma (in preorder) irreflp_greater[simp]: "irreflp (>)"
   by (simp add: irreflpI)
 
 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 asympD: "asymp R \<Longrightarrow> R x y \<Longrightarrow> \<not> R y x"
   by (rule asymD[to_pred])
 
 lemma asym_iff: "asym R \<longleftrightarrow> (\<forall>x y. (x,y) \<in> R \<longrightarrow> (y,x) \<notin> R)"
   by (blast intro: asymI dest: asymD)
 
 lemma (in preorder) asymp_less[simp]: "asymp (<)"
   by (auto intro: asympI dual_order.asym)
 
 lemma (in preorder) asymp_greater[simp]: "asymp (>)"
   by (auto intro: asympI dual_order.asym)
 
 
 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"
 
 definition totalp_on where
   "totalp_on A R \<longleftrightarrow> (\<forall>x \<in> A. \<forall>y \<in> A. x \<noteq> y \<longrightarrow> R x y \<or> R y x)"
 
 abbreviation totalp where
   "totalp \<equiv> totalp_on UNIV"
 
 lemma totalp_on_refl_on_eq[pred_set_conv]: "totalp_on A (\<lambda>x y. (x, y) \<in> r) \<longleftrightarrow> total_on A r"
   by (simp add: totalp_on_def total_on_def)
 
 lemma totalp_onI:
   "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> R x y \<or> R y x) \<Longrightarrow> totalp_on A R"
   by (simp add: totalp_on_def)
 
 lemma totalpI: "(\<And>x y. x \<noteq> y \<Longrightarrow> R x y \<or> R y x) \<Longrightarrow> totalp R"
   by (rule totalp_onI)
 
 lemma totalp_onD:
   "totalp_on A R \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<noteq> y \<Longrightarrow> R x y \<or> R y x"
   by (simp add: totalp_on_def)
 
 lemma totalpD: "totalp R \<Longrightarrow> x \<noteq> y \<Longrightarrow> R x y \<or> R y x"
   by (simp add: totalp_onD)
 
 lemma total_on_subset: "total_on A r \<Longrightarrow> B \<subseteq> A \<Longrightarrow> total_on B r"
   by (auto simp: total_on_def)
 
 lemma totalp_on_subset: "totalp_on A R \<Longrightarrow> B \<subseteq> A \<Longrightarrow> totalp_on B R"
   by (auto intro: totalp_onI dest: totalp_onD)
 
 lemma total_on_empty [simp]: "total_on {} r"
   by (simp add: total_on_def)
 
 lemma totalp_on_empty [simp]: "totalp_on {} R"
   by (auto intro: totalp_onI)
 
 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_INT_eq:
+  assumes "single_valued (r\<inverse>)"
+    and "A \<noteq> {}"
+  shows "r `` (\<Inter>(B ` A)) = (\<Inter>x\<in>A. r `` B x)"
+proof(rule equalityI, rule Image_INT_subset)
+  show "(\<Inter>x\<in>A. r `` B x) \<subseteq> r `` \<Inter> (B ` A)"
+  proof
+    fix x
+    assume "x \<in> (\<Inter>x\<in>A. r `` B x)"
+    then show "x \<in> r `` \<Inter> (B ` A)"
+      using assms unfolding single_valued_def by simp blast
+  qed
+qed
 
 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"
 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/Rings.thy b/src/HOL/Rings.thy
--- a/src/HOL/Rings.thy
+++ b/src/HOL/Rings.thy
@@ -1,2753 +1,2755 @@
 (*  Title:      HOL/Rings.thy
     Author:     Gertrud Bauer
     Author:     Steven Obua
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Markus Wenzel
     Author:     Jeremy Avigad
 *)
 
 section \<open>Rings\<close>
 
 theory Rings
   imports Groups Set Fun
 begin
 
 subsection \<open>Semirings and rings\<close>
 
 class semiring = ab_semigroup_add + semigroup_mult +
   assumes distrib_right [algebra_simps, algebra_split_simps]: "(a + b) * c = a * c + b * c"
   assumes distrib_left [algebra_simps, algebra_split_simps]: "a * (b + c) = a * b + a * c"
 begin
 
 text \<open>For the \<open>combine_numerals\<close> simproc\<close>
 lemma combine_common_factor: "a * e + (b * e + c) = (a + b) * e + c"
   by (simp add: distrib_right ac_simps)
 
 end
 
 class mult_zero = times + zero +
   assumes mult_zero_left [simp]: "0 * a = 0"
   assumes mult_zero_right [simp]: "a * 0 = 0"
 begin
 
 lemma mult_not_zero: "a * b \<noteq> 0 \<Longrightarrow> a \<noteq> 0 \<and> b \<noteq> 0"
   by auto
 
 end
 
 class semiring_0 = semiring + comm_monoid_add + mult_zero
 
 class semiring_0_cancel = semiring + cancel_comm_monoid_add
 begin
 
 subclass semiring_0
 proof
   fix a :: 'a
   have "0 * a + 0 * a = 0 * a + 0"
     by (simp add: distrib_right [symmetric])
   then show "0 * a = 0"
     by (simp only: add_left_cancel)
   have "a * 0 + a * 0 = a * 0 + 0"
     by (simp add: distrib_left [symmetric])
   then show "a * 0 = 0"
     by (simp only: add_left_cancel)
 qed
 
 end
 
 class comm_semiring = ab_semigroup_add + ab_semigroup_mult +
   assumes distrib: "(a + b) * c = a * c + b * c"
 begin
 
 subclass semiring
 proof
   fix a b c :: 'a
   show "(a + b) * c = a * c + b * c"
     by (simp add: distrib)
   have "a * (b + c) = (b + c) * a"
     by (simp add: ac_simps)
   also have "\<dots> = b * a + c * a"
     by (simp only: distrib)
   also have "\<dots> = a * b + a * c"
     by (simp add: ac_simps)
   finally show "a * (b + c) = a * b + a * c"
     by blast
 qed
 
 end
 
 class comm_semiring_0 = comm_semiring + comm_monoid_add + mult_zero
 begin
 
 subclass semiring_0 ..
 
 end
 
 class comm_semiring_0_cancel = comm_semiring + cancel_comm_monoid_add
 begin
 
 subclass semiring_0_cancel ..
 
 subclass comm_semiring_0 ..
 
 end
 
 class zero_neq_one = zero + one +
   assumes zero_neq_one [simp]: "0 \<noteq> 1"
 begin
 
 lemma one_neq_zero [simp]: "1 \<noteq> 0"
   by (rule not_sym) (rule zero_neq_one)
 
 definition of_bool :: "bool \<Rightarrow> 'a"
   where "of_bool p = (if p then 1 else 0)"
 
 lemma of_bool_eq [simp, code]:
   "of_bool False = 0"
   "of_bool True = 1"
   by (simp_all add: of_bool_def)
 
 lemma of_bool_eq_iff: "of_bool p = of_bool q \<longleftrightarrow> p = q"
   by (simp add: of_bool_def)
 
 lemma split_of_bool [split]: "P (of_bool p) \<longleftrightarrow> (p \<longrightarrow> P 1) \<and> (\<not> p \<longrightarrow> P 0)"
   by (cases p) simp_all
 
 lemma split_of_bool_asm: "P (of_bool p) \<longleftrightarrow> \<not> (p \<and> \<not> P 1 \<or> \<not> p \<and> \<not> P 0)"
   by (cases p) simp_all
 
 lemma of_bool_eq_0_iff [simp]:
   \<open>of_bool P = 0 \<longleftrightarrow> \<not> P\<close>
   by simp
 
 lemma of_bool_eq_1_iff [simp]:
   \<open>of_bool P = 1 \<longleftrightarrow> P\<close>
   by simp
 
 end
 
 class semiring_1 = zero_neq_one + semiring_0 + monoid_mult
 begin
 
 lemma of_bool_conj:
   "of_bool (P \<and> Q) = of_bool P * of_bool Q"
   by auto
 
 end
 
 lemma lambda_zero: "(\<lambda>h::'a::mult_zero. 0) = (*) 0"
   by auto
 
 lemma lambda_one: "(\<lambda>x::'a::monoid_mult. x) = (*) 1"
   by auto
 
 subsection \<open>Abstract divisibility\<close>
 
 class dvd = times
 begin
 
 definition dvd :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "dvd" 50)
   where "b dvd a \<longleftrightarrow> (\<exists>k. a = b * k)"
 
 lemma dvdI [intro?]: "a = b * k \<Longrightarrow> b dvd a"
   unfolding dvd_def ..
 
 lemma dvdE [elim]: "b dvd a \<Longrightarrow> (\<And>k. a = b * k \<Longrightarrow> P) \<Longrightarrow> P"
   unfolding dvd_def by blast
 
 end
 
 context comm_monoid_mult
 begin
 
 subclass dvd .
 
 lemma dvd_refl [simp]: "a dvd a"
 proof
   show "a = a * 1" by simp
 qed
 
 lemma dvd_trans [trans]:
   assumes "a dvd b" and "b dvd c"
   shows "a dvd c"
 proof -
   from assms obtain v where "b = a * v"
     by auto
   moreover from assms obtain w where "c = b * w"
     by auto
   ultimately have "c = a * (v * w)"
     by (simp add: mult.assoc)
   then show ?thesis ..
 qed
 
 lemma subset_divisors_dvd: "{c. c dvd a} \<subseteq> {c. c dvd b} \<longleftrightarrow> a dvd b"
   by (auto simp add: subset_iff intro: dvd_trans)
 
 lemma strict_subset_divisors_dvd: "{c. c dvd a} \<subset> {c. c dvd b} \<longleftrightarrow> a dvd b \<and> \<not> b dvd a"
   by (auto simp add: subset_iff intro: dvd_trans)
 
 lemma one_dvd [simp]: "1 dvd a"
   by (auto intro: dvdI)
 
 lemma dvd_mult [simp]: "a dvd (b * c)" if "a dvd c"
-  using that by rule (auto intro: mult.left_commute dvdI)
+  using that by (auto intro: mult.left_commute dvdI)
 
 lemma dvd_mult2 [simp]: "a dvd (b * c)" if "a dvd b"
   using that dvd_mult [of a b c] by (simp add: ac_simps)
 
 lemma dvd_triv_right [simp]: "a dvd b * a"
   by (rule dvd_mult) (rule dvd_refl)
 
 lemma dvd_triv_left [simp]: "a dvd a * b"
   by (rule dvd_mult2) (rule dvd_refl)
 
 lemma mult_dvd_mono:
   assumes "a dvd b"
     and "c dvd d"
   shows "a * c dvd b * d"
 proof -
   from \<open>a dvd b\<close> obtain b' where "b = a * b'" ..
   moreover from \<open>c dvd d\<close> obtain d' where "d = c * d'" ..
   ultimately have "b * d = (a * c) * (b' * d')"
     by (simp add: ac_simps)
   then show ?thesis ..
 qed
 
 lemma dvd_mult_left: "a * b dvd c \<Longrightarrow> a dvd c"
   by (simp add: dvd_def mult.assoc) blast
 
 lemma dvd_mult_right: "a * b dvd c \<Longrightarrow> b dvd c"
   using dvd_mult_left [of b a c] by (simp add: ac_simps)
 
 end
 
 class comm_semiring_1 = zero_neq_one + comm_semiring_0 + comm_monoid_mult
 begin
 
 subclass semiring_1 ..
 
 lemma dvd_0_left_iff [simp]: "0 dvd a \<longleftrightarrow> a = 0"
   by auto
 
 lemma dvd_0_right [iff]: "a dvd 0"
 proof
   show "0 = a * 0" by simp
 qed
 
 lemma dvd_0_left: "0 dvd a \<Longrightarrow> a = 0"
   by simp
 
 lemma dvd_add [simp]:
   assumes "a dvd b" and "a dvd c"
   shows "a dvd (b + c)"
 proof -
   from \<open>a dvd b\<close> obtain b' where "b = a * b'" ..
   moreover from \<open>a dvd c\<close> obtain c' where "c = a * c'" ..
   ultimately have "b + c = a * (b' + c')"
     by (simp add: distrib_left)
   then show ?thesis ..
 qed
 
 end
 
 class semiring_1_cancel = semiring + cancel_comm_monoid_add
   + zero_neq_one + monoid_mult
 begin
 
 subclass semiring_0_cancel ..
 
 subclass semiring_1 ..
 
 end
 
 class comm_semiring_1_cancel =
   comm_semiring + cancel_comm_monoid_add + zero_neq_one + comm_monoid_mult +
   assumes right_diff_distrib' [algebra_simps, algebra_split_simps]:
     "a * (b - c) = a * b - a * c"
 begin
 
 subclass semiring_1_cancel ..
 subclass comm_semiring_0_cancel ..
 subclass comm_semiring_1 ..
 
 lemma left_diff_distrib' [algebra_simps, algebra_split_simps]:
   "(b - c) * a = b * a - c * a"
   by (simp add: algebra_simps)
 
 lemma dvd_add_times_triv_left_iff [simp]: "a dvd c * a + b \<longleftrightarrow> a dvd b"
 proof -
   have "a dvd a * c + b \<longleftrightarrow> a dvd b" (is "?P \<longleftrightarrow> ?Q")
   proof
     assume ?Q
     then show ?P by simp
   next
     assume ?P
     then obtain d where "a * c + b = a * d" ..
     then have "a * c + b - a * c = a * d - a * c" by simp
     then have "b = a * d - a * c" by simp
     then have "b = a * (d - c)" by (simp add: algebra_simps)
     then show ?Q ..
   qed
   then show "a dvd c * a + b \<longleftrightarrow> a dvd b" by (simp add: ac_simps)
 qed
 
 lemma dvd_add_times_triv_right_iff [simp]: "a dvd b + c * a \<longleftrightarrow> a dvd b"
   using dvd_add_times_triv_left_iff [of a c b] by (simp add: ac_simps)
 
 lemma dvd_add_triv_left_iff [simp]: "a dvd a + b \<longleftrightarrow> a dvd b"
   using dvd_add_times_triv_left_iff [of a 1 b] by simp
 
 lemma dvd_add_triv_right_iff [simp]: "a dvd b + a \<longleftrightarrow> a dvd b"
   using dvd_add_times_triv_right_iff [of a b 1] by simp
 
 lemma dvd_add_right_iff:
   assumes "a dvd b"
   shows "a dvd b + c \<longleftrightarrow> a dvd c" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   then obtain d where "b + c = a * d" ..
   moreover from \<open>a dvd b\<close> obtain e where "b = a * e" ..
   ultimately have "a * e + c = a * d" by simp
   then have "a * e + c - a * e = a * d - a * e" by simp
   then have "c = a * d - a * e" by simp
   then have "c = a * (d - e)" by (simp add: algebra_simps)
   then show ?Q ..
 next
   assume ?Q
   with assms show ?P by simp
 qed
 
 lemma dvd_add_left_iff: "a dvd c \<Longrightarrow> a dvd b + c \<longleftrightarrow> a dvd b"
   using dvd_add_right_iff [of a c b] by (simp add: ac_simps)
 
 end
 
 class ring = semiring + ab_group_add
 begin
 
 subclass semiring_0_cancel ..
 
 text \<open>Distribution rules\<close>
 
 lemma minus_mult_left: "- (a * b) = - a * b"
   by (rule minus_unique) (simp add: distrib_right [symmetric])
 
 lemma minus_mult_right: "- (a * b) = a * - b"
   by (rule minus_unique) (simp add: distrib_left [symmetric])
 
 text \<open>Extract signs from products\<close>
 lemmas mult_minus_left [simp] = minus_mult_left [symmetric]
 lemmas mult_minus_right [simp] = minus_mult_right [symmetric]
 
 lemma minus_mult_minus [simp]: "- a * - b = a * b"
   by simp
 
 lemma minus_mult_commute: "- a * b = a * - b"
   by simp
 
 lemma right_diff_distrib [algebra_simps, algebra_split_simps]:
   "a * (b - c) = a * b - a * c"
   using distrib_left [of a b "-c "] by simp
 
 lemma left_diff_distrib [algebra_simps, algebra_split_simps]:
   "(a - b) * c = a * c - b * c"
   using distrib_right [of a "- b" c] by simp
 
 lemmas ring_distribs = distrib_left distrib_right left_diff_distrib right_diff_distrib
 
 lemma eq_add_iff1: "a * e + c = b * e + d \<longleftrightarrow> (a - b) * e + c = d"
   by (simp add: algebra_simps)
 
 lemma eq_add_iff2: "a * e + c = b * e + d \<longleftrightarrow> c = (b - a) * e + d"
   by (simp add: algebra_simps)
 
 end
 
 lemmas ring_distribs = distrib_left distrib_right left_diff_distrib right_diff_distrib
 
 class comm_ring = comm_semiring + ab_group_add
 begin
 
 subclass ring ..
 subclass comm_semiring_0_cancel ..
 
 lemma square_diff_square_factored: "x * x - y * y = (x + y) * (x - y)"
   by (simp add: algebra_simps)
 
 end
 
 class ring_1 = ring + zero_neq_one + monoid_mult
 begin
 
 subclass semiring_1_cancel ..
 
 lemma of_bool_not_iff [simp]:
   \<open>of_bool (\<not> P) = 1 - of_bool P\<close>
   by simp
 
 lemma square_diff_one_factored: "x * x - 1 = (x + 1) * (x - 1)"
   by (simp add: algebra_simps)
 
 end
 
 class comm_ring_1 = comm_ring + zero_neq_one + comm_monoid_mult
 begin
 
 subclass ring_1 ..
 subclass comm_semiring_1_cancel
   by standard (simp add: algebra_simps)
 
 lemma dvd_minus_iff [simp]: "x dvd - y \<longleftrightarrow> x dvd y"
 proof
   assume "x dvd - y"
   then have "x dvd - 1 * - y" by (rule dvd_mult)
   then show "x dvd y" by simp
 next
   assume "x dvd y"
   then have "x dvd - 1 * y" by (rule dvd_mult)
   then show "x dvd - y" by simp
 qed
 
 lemma minus_dvd_iff [simp]: "- x dvd y \<longleftrightarrow> x dvd y"
 proof
   assume "- x dvd y"
   then obtain k where "y = - x * k" ..
   then have "y = x * - k" by simp
   then show "x dvd y" ..
 next
   assume "x dvd y"
   then obtain k where "y = x * k" ..
   then have "y = - x * - k" by simp
   then show "- x dvd y" ..
 qed
 
 lemma dvd_diff [simp]: "x dvd y \<Longrightarrow> x dvd z \<Longrightarrow> x dvd (y - z)"
   using dvd_add [of x y "- z"] by simp
 
 end
 
 
 subsection \<open>Towards integral domains\<close>
 
 class semiring_no_zero_divisors = semiring_0 +
   assumes no_zero_divisors: "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> a * b \<noteq> 0"
 begin
 
 lemma divisors_zero:
   assumes "a * b = 0"
   shows "a = 0 \<or> b = 0"
 proof (rule classical)
   assume "\<not> ?thesis"
   then have "a \<noteq> 0" and "b \<noteq> 0" by auto
   with no_zero_divisors have "a * b \<noteq> 0" by blast
   with assms show ?thesis by simp
 qed
 
 lemma mult_eq_0_iff [simp]: "a * b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
 proof (cases "a = 0 \<or> b = 0")
   case False
   then have "a \<noteq> 0" and "b \<noteq> 0" by auto
     then show ?thesis using no_zero_divisors by simp
 next
   case True
   then show ?thesis by auto
 qed
 
 end
 
 class semiring_1_no_zero_divisors = semiring_1 + semiring_no_zero_divisors
 
 class semiring_no_zero_divisors_cancel = semiring_no_zero_divisors +
   assumes mult_cancel_right [simp]: "a * c = b * c \<longleftrightarrow> c = 0 \<or> a = b"
     and mult_cancel_left [simp]: "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b"
 begin
 
 lemma mult_left_cancel: "c \<noteq> 0 \<Longrightarrow> c * a = c * b \<longleftrightarrow> a = b"
   by simp
 
 lemma mult_right_cancel: "c \<noteq> 0 \<Longrightarrow> a * c = b * c \<longleftrightarrow> a = b"
   by simp
 
 end
 
 class ring_no_zero_divisors = ring + semiring_no_zero_divisors
 begin
 
 subclass semiring_no_zero_divisors_cancel
 proof
   fix a b c
   have "a * c = b * c \<longleftrightarrow> (a - b) * c = 0"
     by (simp add: algebra_simps)
   also have "\<dots> \<longleftrightarrow> c = 0 \<or> a = b"
     by auto
   finally show "a * c = b * c \<longleftrightarrow> c = 0 \<or> a = b" .
   have "c * a = c * b \<longleftrightarrow> c * (a - b) = 0"
     by (simp add: algebra_simps)
   also have "\<dots> \<longleftrightarrow> c = 0 \<or> a = b"
     by auto
   finally show "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b" .
 qed
 
 end
 
 class ring_1_no_zero_divisors = ring_1 + ring_no_zero_divisors
 begin
 
 subclass semiring_1_no_zero_divisors ..
 
 lemma square_eq_1_iff: "x * x = 1 \<longleftrightarrow> x = 1 \<or> x = - 1"
 proof -
   have "(x - 1) * (x + 1) = x * x - 1"
     by (simp add: algebra_simps)
   then have "x * x = 1 \<longleftrightarrow> (x - 1) * (x + 1) = 0"
     by simp
   then show ?thesis
     by (simp add: eq_neg_iff_add_eq_0)
 qed
 
 lemma mult_cancel_right1 [simp]: "c = b * c \<longleftrightarrow> c = 0 \<or> b = 1"
   using mult_cancel_right [of 1 c b] by auto
 
 lemma mult_cancel_right2 [simp]: "a * c = c \<longleftrightarrow> c = 0 \<or> a = 1"
   using mult_cancel_right [of a c 1] by simp
 
 lemma mult_cancel_left1 [simp]: "c = c * b \<longleftrightarrow> c = 0 \<or> b = 1"
   using mult_cancel_left [of c 1 b] by force
 
 lemma mult_cancel_left2 [simp]: "c * a = c \<longleftrightarrow> c = 0 \<or> a = 1"
   using mult_cancel_left [of c a 1] by simp
 
 end
 
 class semidom = comm_semiring_1_cancel + semiring_no_zero_divisors
 begin
 
 subclass semiring_1_no_zero_divisors ..
 
 end
 
 class idom = comm_ring_1 + semiring_no_zero_divisors
 begin
 
 subclass semidom ..
 
 subclass ring_1_no_zero_divisors ..
 
 lemma dvd_mult_cancel_right [simp]:
   "a * c dvd b * c \<longleftrightarrow> c = 0 \<or> a dvd b"
 proof -
   have "a * c dvd b * c \<longleftrightarrow> (\<exists>k. b * c = (a * k) * c)"
     by (auto simp add: ac_simps)
   also have "(\<exists>k. b * c = (a * k) * c) \<longleftrightarrow> c = 0 \<or> a dvd b"
     by auto
   finally show ?thesis .
 qed
 
 lemma dvd_mult_cancel_left [simp]:
   "c * a dvd c * b \<longleftrightarrow> c = 0 \<or> a dvd b"
   using dvd_mult_cancel_right [of a c b] by (simp add: ac_simps)
 
 lemma square_eq_iff: "a * a = b * b \<longleftrightarrow> a = b \<or> a = - b"
 proof
   assume "a * a = b * b"
   then have "(a - b) * (a + b) = 0"
     by (simp add: algebra_simps)
   then show "a = b \<or> a = - b"
     by (simp add: eq_neg_iff_add_eq_0)
 next
   assume "a = b \<or> a = - b"
   then show "a * a = b * b" by auto
 qed
 
 end
 
 class idom_abs_sgn = idom + abs + sgn +
   assumes sgn_mult_abs: "sgn a * \<bar>a\<bar> = a"
     and sgn_sgn [simp]: "sgn (sgn a) = sgn a"
     and abs_abs [simp]: "\<bar>\<bar>a\<bar>\<bar> = \<bar>a\<bar>"
     and abs_0 [simp]: "\<bar>0\<bar> = 0"
     and sgn_0 [simp]: "sgn 0 = 0"
     and sgn_1 [simp]: "sgn 1 = 1"
     and sgn_minus_1: "sgn (- 1) = - 1"
     and sgn_mult: "sgn (a * b) = sgn a * sgn b"
 begin
 
 lemma sgn_eq_0_iff:
   "sgn a = 0 \<longleftrightarrow> a = 0"
 proof -
   { assume "sgn a = 0"
     then have "sgn a * \<bar>a\<bar> = 0"
       by simp
     then have "a = 0"
       by (simp add: sgn_mult_abs)
   } then show ?thesis
     by auto
 qed
 
 lemma abs_eq_0_iff:
   "\<bar>a\<bar> = 0 \<longleftrightarrow> a = 0"
 proof -
   { assume "\<bar>a\<bar> = 0"
     then have "sgn a * \<bar>a\<bar> = 0"
       by simp
     then have "a = 0"
       by (simp add: sgn_mult_abs)
   } then show ?thesis
     by auto
 qed
 
 lemma abs_mult_sgn:
   "\<bar>a\<bar> * sgn a = a"
   using sgn_mult_abs [of a] by (simp add: ac_simps)
 
 lemma abs_1 [simp]:
   "\<bar>1\<bar> = 1"
   using sgn_mult_abs [of 1] by simp
 
 lemma sgn_abs [simp]:
   "\<bar>sgn a\<bar> = of_bool (a \<noteq> 0)"
   using sgn_mult_abs [of "sgn a"] mult_cancel_left [of "sgn a" "\<bar>sgn a\<bar>" 1]
   by (auto simp add: sgn_eq_0_iff)
 
 lemma abs_sgn [simp]:
   "sgn \<bar>a\<bar> = of_bool (a \<noteq> 0)"
   using sgn_mult_abs [of "\<bar>a\<bar>"] mult_cancel_right [of "sgn \<bar>a\<bar>" "\<bar>a\<bar>" 1]
   by (auto simp add: abs_eq_0_iff)
 
 lemma abs_mult:
   "\<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
 proof (cases "a = 0 \<or> b = 0")
   case True
   then show ?thesis
     by auto
 next
   case False
   then have *: "sgn (a * b) \<noteq> 0"
     by (simp add: sgn_eq_0_iff)
   from abs_mult_sgn [of "a * b"] abs_mult_sgn [of a] abs_mult_sgn [of b]
   have "\<bar>a * b\<bar> * sgn (a * b) = \<bar>a\<bar> * sgn a * \<bar>b\<bar> * sgn b"
     by (simp add: ac_simps)
   then have "\<bar>a * b\<bar> * sgn (a * b) = \<bar>a\<bar> * \<bar>b\<bar> * sgn (a * b)"
     by (simp add: sgn_mult ac_simps)
   with * show ?thesis
     by simp
 qed
 
 lemma sgn_minus [simp]:
   "sgn (- a) = - sgn a"
 proof -
   from sgn_minus_1 have "sgn (- 1 * a) = - 1 * sgn a"
     by (simp only: sgn_mult)
   then show ?thesis
     by simp
 qed
 
 lemma abs_minus [simp]:
   "\<bar>- a\<bar> = \<bar>a\<bar>"
 proof -
   have [simp]: "\<bar>- 1\<bar> = 1"
     using sgn_mult_abs [of "- 1"] by simp
   then have "\<bar>- 1 * a\<bar> = 1 * \<bar>a\<bar>"
     by (simp only: abs_mult)
   then show ?thesis
     by simp
 qed
 
 end
 
 
 subsection \<open>(Partial) Division\<close>
 
 class divide =
   fixes divide :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "div" 70)
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>divide\<close>, SOME \<^typ>\<open>'a \<Rightarrow> 'a \<Rightarrow> 'a\<close>)\<close>
 
 context semiring
 begin
 
 lemma [field_simps, field_split_simps]:
   shows distrib_left_NO_MATCH: "NO_MATCH (x div y) a \<Longrightarrow> a * (b + c) = a * b + a * c"
     and distrib_right_NO_MATCH: "NO_MATCH (x div y) c \<Longrightarrow> (a + b) * c = a * c + b * c"
   by (rule distrib_left distrib_right)+
 
 end
 
 context ring
 begin
 
 lemma [field_simps, field_split_simps]:
   shows left_diff_distrib_NO_MATCH: "NO_MATCH (x div y) c \<Longrightarrow> (a - b) * c = a * c - b * c"
     and right_diff_distrib_NO_MATCH: "NO_MATCH (x div y) a \<Longrightarrow> a * (b - c) = a * b - a * c"
   by (rule left_diff_distrib right_diff_distrib)+
 
 end
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>divide\<close>, SOME \<^typ>\<open>'a::divide \<Rightarrow> 'a \<Rightarrow> 'a\<close>)\<close>
 
 text \<open>Algebraic classes with division\<close>
   
 class semidom_divide = semidom + divide +
   assumes nonzero_mult_div_cancel_right [simp]: "b \<noteq> 0 \<Longrightarrow> (a * b) div b = a"
   assumes div_by_0 [simp]: "a div 0 = 0"
 begin
 
 lemma nonzero_mult_div_cancel_left [simp]: "a \<noteq> 0 \<Longrightarrow> (a * b) div a = b"
   using nonzero_mult_div_cancel_right [of a b] by (simp add: ac_simps)
 
 subclass semiring_no_zero_divisors_cancel
 proof
   show *: "a * c = b * c \<longleftrightarrow> c = 0 \<or> a = b" for a b c
   proof (cases "c = 0")
     case True
     then show ?thesis by simp
   next
     case False
     have "a = b" if "a * c = b * c"
     proof -
       from that have "a * c div c = b * c div c"
         by simp
       with False show ?thesis
         by simp
     qed
     then show ?thesis by auto
   qed
   show "c * a = c * b \<longleftrightarrow> c = 0 \<or> a = b" for a b c
     using * [of a c b] by (simp add: ac_simps)
 qed
 
 lemma div_self [simp]: "a \<noteq> 0 \<Longrightarrow> a div a = 1"
   using nonzero_mult_div_cancel_left [of a 1] by simp
 
 lemma div_0 [simp]: "0 div a = 0"
 proof (cases "a = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "a * 0 div a = 0"
     by (rule nonzero_mult_div_cancel_left)
   then show ?thesis by simp
 qed
 
 lemma div_by_1 [simp]: "a div 1 = a"
   using nonzero_mult_div_cancel_left [of 1 a] by simp
 
 lemma dvd_div_eq_0_iff:
   assumes "b dvd a"
   shows "a div b = 0 \<longleftrightarrow> a = 0"
   using assms by (elim dvdE, cases "b = 0") simp_all  
 
 lemma dvd_div_eq_cancel:
   "a div c = b div c \<Longrightarrow> c dvd a \<Longrightarrow> c dvd b \<Longrightarrow> a = b"
   by (elim dvdE, cases "c = 0") simp_all
 
 lemma dvd_div_eq_iff:
   "c dvd a \<Longrightarrow> c dvd b \<Longrightarrow> a div c = b div c \<longleftrightarrow> a = b"
   by (elim dvdE, cases "c = 0") simp_all
 
 lemma inj_on_mult:
   "inj_on ((*) a) A" if "a \<noteq> 0"
 proof (rule inj_onI)
   fix b c
   assume "a * b = a * c"
   then have "a * b div a = a * c div a"
     by (simp only:)
   with that show "b = c"
     by simp
 qed
 
 end
 
 class idom_divide = idom + semidom_divide
 begin
 
 lemma dvd_neg_div:
   assumes "b dvd a"
   shows "- a div b = - (a div b)"
 proof (cases "b = 0")
   case True
   then show ?thesis by simp
 next
   case False
   from assms obtain c where "a = b * c" ..
   then have "- a div b = (b * - c) div b"
     by simp
   from False also have "\<dots> = - c"
     by (rule nonzero_mult_div_cancel_left)  
   with False \<open>a = b * c\<close> show ?thesis
     by simp
 qed
 
 lemma dvd_div_neg:
   assumes "b dvd a"
   shows "a div - b = - (a div b)"
 proof (cases "b = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "- b \<noteq> 0"
     by simp
   from assms obtain c where "a = b * c" ..
   then have "a div - b = (- b * - c) div - b"
     by simp
   from \<open>- b \<noteq> 0\<close> also have "\<dots> = - c"
     by (rule nonzero_mult_div_cancel_left)  
   with False \<open>a = b * c\<close> show ?thesis
     by simp
 qed
 
 end
 
 class algebraic_semidom = semidom_divide
 begin
 
 text \<open>
   Class \<^class>\<open>algebraic_semidom\<close> enriches a integral domain
   by notions from algebra, like units in a ring.
   It is a separate class to avoid spoiling fields with notions
   which are degenerated there.
 \<close>
 
 lemma dvd_times_left_cancel_iff [simp]:
   assumes "a \<noteq> 0"
   shows "a * b dvd a * c \<longleftrightarrow> b dvd c"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   then obtain d where "a * c = a * b * d" ..
   with assms have "c = b * d" by (simp add: ac_simps)
   then show ?rhs ..
 next
   assume ?rhs
   then obtain d where "c = b * d" ..
   then have "a * c = a * b * d" by (simp add: ac_simps)
   then show ?lhs ..
 qed
 
 lemma dvd_times_right_cancel_iff [simp]:
   assumes "a \<noteq> 0"
   shows "b * a dvd c * a \<longleftrightarrow> b dvd c"
   using dvd_times_left_cancel_iff [of a b c] assms by (simp add: ac_simps)
 
 lemma div_dvd_iff_mult:
   assumes "b \<noteq> 0" and "b dvd a"
   shows "a div b dvd c \<longleftrightarrow> a dvd c * b"
 proof -
   from \<open>b dvd a\<close> obtain d where "a = b * d" ..
   with \<open>b \<noteq> 0\<close> show ?thesis by (simp add: ac_simps)
 qed
 
 lemma dvd_div_iff_mult:
   assumes "c \<noteq> 0" and "c dvd b"
   shows "a dvd b div c \<longleftrightarrow> a * c dvd b"
 proof -
   from \<open>c dvd b\<close> obtain d where "b = c * d" ..
   with \<open>c \<noteq> 0\<close> show ?thesis by (simp add: mult.commute [of a])
 qed
 
 lemma div_dvd_div [simp]:
   assumes "a dvd b" and "a dvd c"
   shows "b div a dvd c div a \<longleftrightarrow> b dvd c"
 proof (cases "a = 0")
   case True
   with assms show ?thesis by simp
 next
   case False
   moreover from assms obtain k l where "b = a * k" and "c = a * l"
     by blast
   ultimately show ?thesis by simp
 qed
 
 lemma div_add [simp]:
   assumes "c dvd a" and "c dvd b"
   shows "(a + b) div c = a div c + b div c"
 proof (cases "c = 0")
   case True
   then show ?thesis by simp
 next
   case False
   moreover from assms obtain k l where "a = c * k" and "b = c * l"
     by blast
   moreover have "c * k + c * l = c * (k + l)"
     by (simp add: algebra_simps)
   ultimately show ?thesis
     by simp
 qed
 
 lemma div_mult_div_if_dvd:
   assumes "b dvd a" and "d dvd c"
   shows "(a div b) * (c div d) = (a * c) div (b * d)"
 proof (cases "b = 0 \<or> c = 0")
   case True
   with assms show ?thesis by auto
 next
   case False
   moreover from assms obtain k l where "a = b * k" and "c = d * l"
     by blast
   moreover have "b * k * (d * l) div (b * d) = (b * d) * (k * l) div (b * d)"
     by (simp add: ac_simps)
   ultimately show ?thesis by simp
 qed
 
 lemma dvd_div_eq_mult:
   assumes "a \<noteq> 0" and "a dvd b"
   shows "b div a = c \<longleftrightarrow> b = c * a"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs by (simp add: assms)
 next
   assume ?lhs
   then have "b div a * a = c * a" by simp
   moreover from assms have "b div a * a = b"
     by (auto simp add: ac_simps)
   ultimately show ?rhs by simp
 qed
 
 lemma dvd_div_mult_self [simp]: "a dvd b \<Longrightarrow> b div a * a = b"
   by (cases "a = 0") (auto simp add: ac_simps)
 
 lemma dvd_mult_div_cancel [simp]: "a dvd b \<Longrightarrow> a * (b div a) = b"
   using dvd_div_mult_self [of a b] by (simp add: ac_simps)
 
 lemma div_mult_swap:
   assumes "c dvd b"
   shows "a * (b div c) = (a * b) div c"
 proof (cases "c = 0")
   case True
   then show ?thesis by simp
 next
   case False
   from assms obtain d where "b = c * d" ..
   moreover from False have "a * divide (d * c) c = ((a * d) * c) div c"
     by simp
   ultimately show ?thesis by (simp add: ac_simps)
 qed
 
 lemma dvd_div_mult: "c dvd b \<Longrightarrow> b div c * a = (b * a) div c"
   using div_mult_swap [of c b a] by (simp add: ac_simps)
 
 lemma dvd_div_mult2_eq:
   assumes "b * c dvd a"
   shows "a div (b * c) = a div b div c"
 proof -
   from assms obtain k where "a = b * c * k" ..
   then show ?thesis
     by (cases "b = 0 \<or> c = 0") (auto, simp add: ac_simps)
 qed
 
 lemma dvd_div_div_eq_mult:
   assumes "a \<noteq> 0" "c \<noteq> 0" and "a dvd b" "c dvd d"
   shows "b div a = d div c \<longleftrightarrow> b * c = a * d"
     (is "?lhs \<longleftrightarrow> ?rhs")
 proof -
   from assms have "a * c \<noteq> 0" by simp
   then have "?lhs \<longleftrightarrow> b div a * (a * c) = d div c * (a * c)"
     by simp
   also have "\<dots> \<longleftrightarrow> (a * (b div a)) * c = (c * (d div c)) * a"
     by (simp add: ac_simps)
   also have "\<dots> \<longleftrightarrow> (a * b div a) * c = (c * d div c) * a"
     using assms by (simp add: div_mult_swap)
   also have "\<dots> \<longleftrightarrow> ?rhs"
     using assms by (simp add: ac_simps)
   finally show ?thesis .
 qed
 
 lemma dvd_mult_imp_div:
   assumes "a * c dvd b"
   shows "a dvd b div c"
 proof (cases "c = 0")
   case True then show ?thesis by simp
 next
   case False
   from \<open>a * c dvd b\<close> obtain d where "b = a * c * d" ..
   with False show ?thesis
     by (simp add: mult.commute [of a] mult.assoc)
 qed
 
 lemma div_div_eq_right:
   assumes "c dvd b" "b dvd a"
   shows   "a div (b div c) = a div b * c"
 proof (cases "c = 0 \<or> b = 0")
   case True
   then show ?thesis
     by auto
 next
   case False
   from assms obtain r s where "b = c * r" and "a = c * r * s"
     by blast
   moreover with False have "r \<noteq> 0"
     by auto
   ultimately show ?thesis using False
     by simp (simp add: mult.commute [of _ r] mult.assoc mult.commute [of c])
 qed
 
 lemma div_div_div_same:
   assumes "d dvd b" "b dvd a"
   shows   "(a div d) div (b div d) = a div b"
 proof (cases "b = 0 \<or> d = 0")
   case True
   with assms show ?thesis
     by auto
 next
   case False
   from assms obtain r s
     where "a = d * r * s" and "b = d * r"
     by blast
   with False show ?thesis
     by simp (simp add: ac_simps)
 qed
 
 
 text \<open>Units: invertible elements in a ring\<close>
 
 abbreviation is_unit :: "'a \<Rightarrow> bool"
   where "is_unit a \<equiv> a dvd 1"
 
 lemma not_is_unit_0 [simp]: "\<not> is_unit 0"
   by simp
 
 lemma unit_imp_dvd [dest]: "is_unit b \<Longrightarrow> b dvd a"
   by (rule dvd_trans [of _ 1]) simp_all
 
 lemma unit_dvdE:
   assumes "is_unit a"
   obtains c where "a \<noteq> 0" and "b = a * c"
 proof -
   from assms have "a dvd b" by auto
   then obtain c where "b = a * c" ..
   moreover from assms have "a \<noteq> 0" by auto
   ultimately show thesis using that by blast
 qed
 
 lemma dvd_unit_imp_unit: "a dvd b \<Longrightarrow> is_unit b \<Longrightarrow> is_unit a"
   by (rule dvd_trans)
 
 lemma unit_div_1_unit [simp, intro]:
   assumes "is_unit a"
   shows "is_unit (1 div a)"
 proof -
   from assms have "1 = 1 div a * a" by simp
   then show "is_unit (1 div a)" by (rule dvdI)
 qed
 
 lemma is_unitE [elim?]:
   assumes "is_unit a"
   obtains b where "a \<noteq> 0" and "b \<noteq> 0"
     and "is_unit b" and "1 div a = b" and "1 div b = a"
     and "a * b = 1" and "c div a = c * b"
 proof (rule that)
   define b where "b = 1 div a"
   then show "1 div a = b" by simp
   from assms b_def show "is_unit b" by simp
   with assms show "a \<noteq> 0" and "b \<noteq> 0" by auto
   from assms b_def show "a * b = 1" by simp
   then have "1 = a * b" ..
   with b_def \<open>b \<noteq> 0\<close> show "1 div b = a" by simp
   from assms have "a dvd c" ..
   then obtain d where "c = a * d" ..
   with \<open>a \<noteq> 0\<close> \<open>a * b = 1\<close> show "c div a = c * b"
     by (simp add: mult.assoc mult.left_commute [of a])
 qed
 
 lemma unit_prod [intro]: "is_unit a \<Longrightarrow> is_unit b \<Longrightarrow> is_unit (a * b)"
   by (subst mult_1_left [of 1, symmetric]) (rule mult_dvd_mono)
 
 lemma is_unit_mult_iff: "is_unit (a * b) \<longleftrightarrow> is_unit a \<and> is_unit b"
   by (auto dest: dvd_mult_left dvd_mult_right)
 
 lemma unit_div [intro]: "is_unit a \<Longrightarrow> is_unit b \<Longrightarrow> is_unit (a div b)"
   by (erule is_unitE [of b a]) (simp add: ac_simps unit_prod)
 
 lemma mult_unit_dvd_iff:
   assumes "is_unit b"
   shows "a * b dvd c \<longleftrightarrow> a dvd c"
 proof
   assume "a * b dvd c"
   with assms show "a dvd c"
     by (simp add: dvd_mult_left)
 next
   assume "a dvd c"
   then obtain k where "c = a * k" ..
   with assms have "c = (a * b) * (1 div b * k)"
     by (simp add: mult_ac)
   then show "a * b dvd c" by (rule dvdI)
 qed
 
 lemma mult_unit_dvd_iff': "is_unit a \<Longrightarrow> (a * b) dvd c \<longleftrightarrow> b dvd c"
   using mult_unit_dvd_iff [of a b c] by (simp add: ac_simps)
 
 lemma dvd_mult_unit_iff:
   assumes "is_unit b"
   shows "a dvd c * b \<longleftrightarrow> a dvd c"
 proof
   assume "a dvd c * b"
   with assms have "c * b dvd c * (b * (1 div b))"
     by (subst mult_assoc [symmetric]) simp
   also from assms have "b * (1 div b) = 1"
     by (rule is_unitE) simp
   finally have "c * b dvd c" by simp
   with \<open>a dvd c * b\<close> show "a dvd c" by (rule dvd_trans)
 next
   assume "a dvd c"
   then show "a dvd c * b" by simp
 qed
 
 lemma dvd_mult_unit_iff': "is_unit b \<Longrightarrow> a dvd b * c \<longleftrightarrow> a dvd c"
   using dvd_mult_unit_iff [of b a c] by (simp add: ac_simps)
 
 lemma div_unit_dvd_iff: "is_unit b \<Longrightarrow> a div b dvd c \<longleftrightarrow> a dvd c"
   by (erule is_unitE [of _ a]) (auto simp add: mult_unit_dvd_iff)
 
 lemma dvd_div_unit_iff: "is_unit b \<Longrightarrow> a dvd c div b \<longleftrightarrow> a dvd c"
   by (erule is_unitE [of _ c]) (simp add: dvd_mult_unit_iff)
 
 lemmas unit_dvd_iff = mult_unit_dvd_iff mult_unit_dvd_iff'
   dvd_mult_unit_iff dvd_mult_unit_iff' 
   div_unit_dvd_iff dvd_div_unit_iff (* FIXME consider named_theorems *)
 
 lemma unit_mult_div_div [simp]: "is_unit a \<Longrightarrow> b * (1 div a) = b div a"
   by (erule is_unitE [of _ b]) simp
 
 lemma unit_div_mult_self [simp]: "is_unit a \<Longrightarrow> b div a * a = b"
   by (rule dvd_div_mult_self) auto
 
 lemma unit_div_1_div_1 [simp]: "is_unit a \<Longrightarrow> 1 div (1 div a) = a"
   by (erule is_unitE) simp
 
 lemma unit_div_mult_swap: "is_unit c \<Longrightarrow> a * (b div c) = (a * b) div c"
   by (erule unit_dvdE [of _ b]) (simp add: mult.left_commute [of _ c])
 
 lemma unit_div_commute: "is_unit b \<Longrightarrow> (a div b) * c = (a * c) div b"
   using unit_div_mult_swap [of b c a] by (simp add: ac_simps)
 
 lemma unit_eq_div1: "is_unit b \<Longrightarrow> a div b = c \<longleftrightarrow> a = c * b"
   by (auto elim: is_unitE)
 
 lemma unit_eq_div2: "is_unit b \<Longrightarrow> a = c div b \<longleftrightarrow> a * b = c"
   using unit_eq_div1 [of b c a] by auto
 
 lemma unit_mult_left_cancel: "is_unit a \<Longrightarrow> a * b = a * c \<longleftrightarrow> b = c"
   using mult_cancel_left [of a b c] by auto
 
 lemma unit_mult_right_cancel: "is_unit a \<Longrightarrow> b * a = c * a \<longleftrightarrow> b = c"
   using unit_mult_left_cancel [of a b c] by (auto simp add: ac_simps)
 
 lemma unit_div_cancel:
   assumes "is_unit a"
   shows "b div a = c div a \<longleftrightarrow> b = c"
 proof -
   from assms have "is_unit (1 div a)" by simp
   then have "b * (1 div a) = c * (1 div a) \<longleftrightarrow> b = c"
     by (rule unit_mult_right_cancel)
   with assms show ?thesis by simp
 qed
 
 lemma is_unit_div_mult2_eq:
   assumes "is_unit b" and "is_unit c"
   shows "a div (b * c) = a div b div c"
 proof -
   from assms have "is_unit (b * c)"
     by (simp add: unit_prod)
   then have "b * c dvd a"
     by (rule unit_imp_dvd)
   then show ?thesis
     by (rule dvd_div_mult2_eq)
 qed
 
 lemma is_unit_div_mult_cancel_left:
   assumes "a \<noteq> 0" and "is_unit b"
   shows "a div (a * b) = 1 div b"
 proof -
   from assms have "a div (a * b) = a div a div b"
     by (simp add: mult_unit_dvd_iff dvd_div_mult2_eq)
   with assms show ?thesis by simp
 qed
 
 lemma is_unit_div_mult_cancel_right:
   assumes "a \<noteq> 0" and "is_unit b"
   shows "a div (b * a) = 1 div b"
   using assms is_unit_div_mult_cancel_left [of a b] by (simp add: ac_simps)
 
 lemma unit_div_eq_0_iff:
   assumes "is_unit b"
   shows "a div b = 0 \<longleftrightarrow> a = 0"
-  by (rule dvd_div_eq_0_iff) (insert assms, auto)  
+  using assms by (simp add: dvd_div_eq_0_iff unit_imp_dvd)
 
 lemma div_mult_unit2:
   "is_unit c \<Longrightarrow> b dvd a \<Longrightarrow> a div (b * c) = a div b div c"
   by (rule dvd_div_mult2_eq) (simp_all add: mult_unit_dvd_iff)
 
 
 text \<open>Coprimality\<close>
 
 definition coprime :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   where "coprime a b \<longleftrightarrow> (\<forall>c. c dvd a \<longrightarrow> c dvd b \<longrightarrow> is_unit c)"
 
 lemma coprimeI:
   assumes "\<And>c. c dvd a \<Longrightarrow> c dvd b \<Longrightarrow> is_unit c"
   shows "coprime a b"
   using assms by (auto simp: coprime_def)
 
 lemma not_coprimeI:
   assumes "c dvd a" and "c dvd b" and "\<not> is_unit c"
   shows "\<not> coprime a b"
   using assms by (auto simp: coprime_def)
 
 lemma coprime_common_divisor:
   "is_unit c" if "coprime a b" and "c dvd a" and "c dvd b"
   using that by (auto simp: coprime_def)
 
 lemma not_coprimeE:
   assumes "\<not> coprime a b"
   obtains c where "c dvd a" and "c dvd b" and "\<not> is_unit c"
   using assms by (auto simp: coprime_def)
 
 lemma coprime_imp_coprime:
   "coprime a b" if "coprime c d"
     and "\<And>e. \<not> is_unit e \<Longrightarrow> e dvd a \<Longrightarrow> e dvd b \<Longrightarrow> e dvd c"
     and "\<And>e. \<not> is_unit e \<Longrightarrow> e dvd a \<Longrightarrow> e dvd b \<Longrightarrow> e dvd d"
 proof (rule coprimeI)
   fix e
   assume "e dvd a" and "e dvd b"
   with that have "e dvd c" and "e dvd d"
     by (auto intro: dvd_trans)
   with \<open>coprime c d\<close> show "is_unit e"
     by (rule coprime_common_divisor)
 qed
 
 lemma coprime_divisors:
   "coprime a b" if "a dvd c" "b dvd d" and "coprime c d"
 using \<open>coprime c d\<close> proof (rule coprime_imp_coprime)
   fix e
   assume "e dvd a" then show "e dvd c"
     using \<open>a dvd c\<close> by (rule dvd_trans)
   assume "e dvd b" then show "e dvd d"
     using \<open>b dvd d\<close> by (rule dvd_trans)
 qed
 
 lemma coprime_self [simp]:
   "coprime a a \<longleftrightarrow> is_unit a" (is "?P \<longleftrightarrow> ?Q")
 proof
   assume ?P
   then show ?Q
     by (rule coprime_common_divisor) simp_all
 next
   assume ?Q
   show ?P
     by (rule coprimeI) (erule dvd_unit_imp_unit, rule \<open>?Q\<close>)
 qed
 
 lemma coprime_commute [ac_simps]:
   "coprime b a \<longleftrightarrow> coprime a b"
   unfolding coprime_def by auto
 
 lemma is_unit_left_imp_coprime:
   "coprime a b" if "is_unit a"
 proof (rule coprimeI)
   fix c
   assume "c dvd a"
   with that show "is_unit c"
     by (auto intro: dvd_unit_imp_unit)
 qed
 
 lemma is_unit_right_imp_coprime:
   "coprime a b" if "is_unit b"
   using that is_unit_left_imp_coprime [of b a] by (simp add: ac_simps)
 
 lemma coprime_1_left [simp]:
   "coprime 1 a"
   by (rule coprimeI)
 
 lemma coprime_1_right [simp]:
   "coprime a 1"
   by (rule coprimeI)
 
 lemma coprime_0_left_iff [simp]:
   "coprime 0 a \<longleftrightarrow> is_unit a"
   by (auto intro: coprimeI dvd_unit_imp_unit coprime_common_divisor [of 0 a a])
 
 lemma coprime_0_right_iff [simp]:
   "coprime a 0 \<longleftrightarrow> is_unit a"
   using coprime_0_left_iff [of a] by (simp add: ac_simps)
 
 lemma coprime_mult_self_left_iff [simp]:
   "coprime (c * a) (c * b) \<longleftrightarrow> is_unit c \<and> coprime a b"
   by (auto intro: coprime_common_divisor)
     (rule coprimeI, auto intro: coprime_common_divisor simp add: dvd_mult_unit_iff')+
 
 lemma coprime_mult_self_right_iff [simp]:
   "coprime (a * c) (b * c) \<longleftrightarrow> is_unit c \<and> coprime a b"
   using coprime_mult_self_left_iff [of c a b] by (simp add: ac_simps)
 
 lemma coprime_absorb_left:
   assumes "x dvd y"
   shows   "coprime x y \<longleftrightarrow> is_unit x"
   using assms coprime_common_divisor is_unit_left_imp_coprime by auto
 
 lemma coprime_absorb_right:
   assumes "y dvd x"
   shows   "coprime x y \<longleftrightarrow> is_unit y"
   using assms coprime_common_divisor is_unit_right_imp_coprime by auto
 
 end
 
 class unit_factor =
   fixes unit_factor :: "'a \<Rightarrow> 'a"
 
 class semidom_divide_unit_factor = semidom_divide + unit_factor +
   assumes unit_factor_0 [simp]: "unit_factor 0 = 0"
     and is_unit_unit_factor: "a dvd 1 \<Longrightarrow> unit_factor a = a"
     and unit_factor_is_unit: "a \<noteq> 0 \<Longrightarrow> unit_factor a dvd 1"
     and unit_factor_mult_unit_left: "a dvd 1 \<Longrightarrow> unit_factor (a * b) = a * unit_factor b"
   \<comment> \<open>This fine-grained hierarchy will later on allow lean normalization of polynomials\<close>
 begin
 
 lemma unit_factor_mult_unit_right: "a dvd 1 \<Longrightarrow> unit_factor (b * a) = unit_factor b * a"
   using unit_factor_mult_unit_left[of a b] by (simp add: mult_ac)
 
 lemmas [simp] = unit_factor_mult_unit_left unit_factor_mult_unit_right
 
 end
 
 class normalization_semidom = algebraic_semidom + semidom_divide_unit_factor +
   fixes normalize :: "'a \<Rightarrow> 'a"
   assumes unit_factor_mult_normalize [simp]: "unit_factor a * normalize a = a"
     and normalize_0 [simp]: "normalize 0 = 0"
 begin
 
 text \<open>
   Class \<^class>\<open>normalization_semidom\<close> cultivates the idea that each integral
   domain can be split into equivalence classes whose representants are
   associated, i.e. divide each other. \<^const>\<open>normalize\<close> specifies a canonical
   representant for each equivalence class. The rationale behind this is that
   it is easier to reason about equality than equivalences, hence we prefer to
   think about equality of normalized values rather than associated elements.
 \<close>
 
 declare unit_factor_is_unit [iff]
   
 lemma unit_factor_dvd [simp]: "a \<noteq> 0 \<Longrightarrow> unit_factor a dvd b"
   by (rule unit_imp_dvd) simp
 
 lemma unit_factor_self [simp]: "unit_factor a dvd a"
   by (cases "a = 0") simp_all
 
 lemma normalize_mult_unit_factor [simp]: "normalize a * unit_factor a = a"
   using unit_factor_mult_normalize [of a] by (simp add: ac_simps)
 
 lemma normalize_eq_0_iff [simp]: "normalize a = 0 \<longleftrightarrow> a = 0"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   moreover have "unit_factor a * normalize a = a" by simp
   ultimately show ?rhs by simp
 next
   assume ?rhs
   then show ?lhs by simp
 qed
 
 lemma unit_factor_eq_0_iff [simp]: "unit_factor a = 0 \<longleftrightarrow> a = 0"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   moreover have "unit_factor a * normalize a = a" by simp
   ultimately show ?rhs by simp
 next
   assume ?rhs
   then show ?lhs by simp
 qed
 
 lemma div_unit_factor [simp]: "a div unit_factor a = normalize a"
 proof (cases "a = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "unit_factor a \<noteq> 0"
     by simp
   with nonzero_mult_div_cancel_left
   have "unit_factor a * normalize a div unit_factor a = normalize a"
     by blast
   then show ?thesis by simp
 qed
 
 lemma normalize_div [simp]: "normalize a div a = 1 div unit_factor a"
 proof (cases "a = 0")
   case True
   then show ?thesis by simp
 next
   case False
   have "normalize a div a = normalize a div (unit_factor a * normalize a)"
     by simp
   also have "\<dots> = 1 div unit_factor a"
     using False by (subst is_unit_div_mult_cancel_right) simp_all
   finally show ?thesis .
 qed
 
 lemma is_unit_normalize:
   assumes "is_unit a"
   shows "normalize a = 1"
 proof -
   from assms have "unit_factor a = a"
     by (rule is_unit_unit_factor)
   moreover from assms have "a \<noteq> 0"
     by auto
   moreover have "normalize a = a div unit_factor a"
     by simp
   ultimately show ?thesis
     by simp
 qed
 
 lemma unit_factor_1 [simp]: "unit_factor 1 = 1"
   by (rule is_unit_unit_factor) simp
 
 lemma normalize_1 [simp]: "normalize 1 = 1"
   by (rule is_unit_normalize) simp
 
 lemma normalize_1_iff: "normalize a = 1 \<longleftrightarrow> is_unit a"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs by (rule is_unit_normalize)
 next
   assume ?lhs
   then have "unit_factor a * normalize a = unit_factor a * 1"
     by simp
   then have "unit_factor a = a"
     by simp
   moreover
   from \<open>?lhs\<close> have "a \<noteq> 0" by auto
   then have "is_unit (unit_factor a)" by simp
   ultimately show ?rhs by simp
 qed
 
 lemma div_normalize [simp]: "a div normalize a = unit_factor a"
 proof (cases "a = 0")
   case True
   then show ?thesis by simp
 next
   case False
   then have "normalize a \<noteq> 0" by simp
   with nonzero_mult_div_cancel_right
   have "unit_factor a * normalize a div normalize a = unit_factor a" by blast
   then show ?thesis by simp
 qed
 
 lemma mult_one_div_unit_factor [simp]: "a * (1 div unit_factor b) = a div unit_factor b"
   by (cases "b = 0") simp_all
 
 lemma inv_unit_factor_eq_0_iff [simp]:
   "1 div unit_factor a = 0 \<longleftrightarrow> a = 0"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?lhs
   then have "a * (1 div unit_factor a) = a * 0"
     by simp
   then show ?rhs
     by simp
 next
   assume ?rhs
   then show ?lhs by simp
 qed
 
 lemma unit_factor_idem [simp]: "unit_factor (unit_factor a) = unit_factor a"
   by (cases "a = 0") (auto intro: is_unit_unit_factor)
 
 lemma normalize_unit_factor [simp]: "a \<noteq> 0 \<Longrightarrow> normalize (unit_factor a) = 1"
   by (rule is_unit_normalize) simp
 
 lemma normalize_mult_unit_left [simp]:
   assumes "a dvd 1"
   shows   "normalize (a * b) = normalize b"
 proof (cases "b = 0")
   case False
   have "a * unit_factor b * normalize (a * b) = unit_factor (a * b) * normalize (a * b)"
     using assms by (subst unit_factor_mult_unit_left) auto
   also have "\<dots> = a * b" by simp
   also have "b = unit_factor b * normalize b" by simp
   hence "a * b = a * unit_factor b * normalize b"
     by (simp only: mult_ac)
   finally show ?thesis
     using assms False by auto
 qed auto
 
 lemma normalize_mult_unit_right [simp]:
   assumes "b dvd 1"
   shows   "normalize (a * b) = normalize a"
   using assms by (subst mult.commute) auto
 
 lemma normalize_idem [simp]: "normalize (normalize a) = normalize a"
 proof (cases "a = 0")
   case False
   have "normalize a = normalize (unit_factor a * normalize a)"
     by simp
   also from False have "\<dots> = normalize (normalize a)"
     by (subst normalize_mult_unit_left) auto
   finally show ?thesis ..
 qed auto
 
 lemma unit_factor_normalize [simp]:
   assumes "a \<noteq> 0"
   shows "unit_factor (normalize a) = 1"
 proof -
   from assms have *: "normalize a \<noteq> 0"
     by simp
   have "unit_factor (normalize a) * normalize (normalize a) = normalize a"
     by (simp only: unit_factor_mult_normalize)
   then have "unit_factor (normalize a) * normalize a = normalize a"
     by simp
   with * have "unit_factor (normalize a) * normalize a div normalize a = normalize a div normalize a"
     by simp
   with * show ?thesis
     by simp
 qed
 
 lemma normalize_dvd_iff [simp]: "normalize a dvd b \<longleftrightarrow> a dvd b"
 proof -
   have "normalize a dvd b \<longleftrightarrow> unit_factor a * normalize a dvd b"
     using mult_unit_dvd_iff [of "unit_factor a" "normalize a" b]
       by (cases "a = 0") simp_all
   then show ?thesis by simp
 qed
 
 lemma dvd_normalize_iff [simp]: "a dvd normalize b \<longleftrightarrow> a dvd b"
 proof -
   have "a dvd normalize  b \<longleftrightarrow> a dvd normalize b * unit_factor b"
     using dvd_mult_unit_iff [of "unit_factor b" a "normalize b"]
       by (cases "b = 0") simp_all
   then show ?thesis by simp
 qed
 
 lemma normalize_idem_imp_unit_factor_eq:
   assumes "normalize a = a"
   shows "unit_factor a = of_bool (a \<noteq> 0)"
 proof (cases "a = 0")
   case True
   then show ?thesis
     by simp
 next
   case False
   then show ?thesis
     using assms unit_factor_normalize [of a] by simp
 qed
 
 lemma normalize_idem_imp_is_unit_iff:
   assumes "normalize a = a"
   shows "is_unit a \<longleftrightarrow> a = 1"
   using assms by (cases "a = 0") (auto dest: is_unit_normalize)
 
 lemma coprime_normalize_left_iff [simp]:
   "coprime (normalize a) b \<longleftrightarrow> coprime a b"
-  by (rule; rule coprimeI) (auto intro: coprime_common_divisor)
+  by (rule iffI; rule coprimeI) (auto intro: coprime_common_divisor)
 
 lemma coprime_normalize_right_iff [simp]:
   "coprime a (normalize b) \<longleftrightarrow> coprime a b"
   using coprime_normalize_left_iff [of b a] by (simp add: ac_simps)
 
 text \<open>
   We avoid an explicit definition of associated elements but prefer explicit
   normalisation instead. In theory we could define an abbreviation like \<^prop>\<open>associated a b \<longleftrightarrow> normalize a = normalize b\<close> but this is counterproductive
   without suggestive infix syntax, which we do not want to sacrifice for this
   purpose here.
 \<close>
 
 lemma associatedI:
   assumes "a dvd b" and "b dvd a"
   shows "normalize a = normalize b"
 proof (cases "a = 0 \<or> b = 0")
   case True
   with assms show ?thesis by auto
 next
   case False
   from \<open>a dvd b\<close> obtain c where b: "b = a * c" ..
   moreover from \<open>b dvd a\<close> obtain d where a: "a = b * d" ..
   ultimately have "b * 1 = b * (c * d)"
     by (simp add: ac_simps)
   with False have "1 = c * d"
     unfolding mult_cancel_left by simp
   then have "is_unit c" and "is_unit d"
     by auto
   with a b show ?thesis
     by (simp add: is_unit_normalize)
 qed
 
 lemma associatedD1: "normalize a = normalize b \<Longrightarrow> a dvd b"
   using dvd_normalize_iff [of _ b, symmetric] normalize_dvd_iff [of a _, symmetric]
   by simp
 
 lemma associatedD2: "normalize a = normalize b \<Longrightarrow> b dvd a"
   using dvd_normalize_iff [of _ a, symmetric] normalize_dvd_iff [of b _, symmetric]
   by simp
 
 lemma associated_unit: "normalize a = normalize b \<Longrightarrow> is_unit a \<Longrightarrow> is_unit b"
   using dvd_unit_imp_unit by (auto dest!: associatedD1 associatedD2)
 
 lemma associated_iff_dvd: "normalize a = normalize b \<longleftrightarrow> a dvd b \<and> b dvd a"
   (is "?lhs \<longleftrightarrow> ?rhs")
 proof
   assume ?rhs
   then show ?lhs by (auto intro!: associatedI)
 next
   assume ?lhs
   then have "unit_factor a * normalize a = unit_factor a * normalize b"
     by simp
   then have *: "normalize b * unit_factor a = a"
     by (simp add: ac_simps)
   show ?rhs
   proof (cases "a = 0 \<or> b = 0")
     case True
     with \<open>?lhs\<close> show ?thesis by auto
   next
     case False
     then have "b dvd normalize b * unit_factor a" and "normalize b * unit_factor a dvd b"
       by (simp_all add: mult_unit_dvd_iff dvd_mult_unit_iff)
     with * show ?thesis by simp
   qed
 qed
 
 lemma associated_eqI:
   assumes "a dvd b" and "b dvd a"
   assumes "normalize a = a" and "normalize b = b"
   shows "a = b"
 proof -
   from assms have "normalize a = normalize b"
     unfolding associated_iff_dvd by simp
   with \<open>normalize a = a\<close> have "a = normalize b"
     by simp
   with \<open>normalize b = b\<close> show "a = b"
     by simp
 qed
 
 lemma normalize_unit_factor_eqI:
   assumes "normalize a = normalize b"
     and "unit_factor a = unit_factor b"
   shows "a = b"
 proof -
   from assms have "unit_factor a * normalize a = unit_factor b * normalize b"
     by simp
   then show ?thesis
     by simp
 qed
 
 lemma normalize_mult_normalize_left [simp]: "normalize (normalize a * b) = normalize (a * b)"
   by (rule associated_eqI) (auto intro!: mult_dvd_mono)
 
 lemma normalize_mult_normalize_right [simp]: "normalize (a * normalize b) = normalize (a * b)"
   by (rule associated_eqI) (auto intro!: mult_dvd_mono)
 
 end
 
 
 class normalization_semidom_multiplicative = normalization_semidom +
   assumes unit_factor_mult: "unit_factor (a * b) = unit_factor a * unit_factor b"
 begin
 
 lemma normalize_mult: "normalize (a * b) = normalize a * normalize b"
 proof (cases "a = 0 \<or> b = 0")
   case True
   then show ?thesis by auto
 next
   case False
   have "unit_factor (a * b) * normalize (a * b) = a * b"
     by (rule unit_factor_mult_normalize)
   then have "normalize (a * b) = a * b div unit_factor (a * b)"
     by simp
   also have "\<dots> = a * b div unit_factor (b * a)"
     by (simp add: ac_simps)
   also have "\<dots> = a * b div unit_factor b div unit_factor a"
     using False by (simp add: unit_factor_mult is_unit_div_mult2_eq [symmetric])
   also have "\<dots> = a * (b div unit_factor b) div unit_factor a"
     using False by (subst unit_div_mult_swap) simp_all
   also have "\<dots> = normalize a * normalize b"
     using False
     by (simp add: mult.commute [of a] mult.commute [of "normalize a"] unit_div_mult_swap [symmetric])
   finally show ?thesis .
 qed
 
 lemma dvd_unit_factor_div:
   assumes "b dvd a"
   shows "unit_factor (a div b) = unit_factor a div unit_factor b"
 proof -
   from assms have "a = a div b * b"
     by simp
   then have "unit_factor a = unit_factor (a div b * b)"
     by simp
   then show ?thesis
     by (cases "b = 0") (simp_all add: unit_factor_mult)
 qed
 
 lemma dvd_normalize_div:
   assumes "b dvd a"
   shows "normalize (a div b) = normalize a div normalize b"
 proof -
   from assms have "a = a div b * b"
     by simp
   then have "normalize a = normalize (a div b * b)"
     by simp
   then show ?thesis
     by (cases "b = 0") (simp_all add: normalize_mult)
 qed
 
 end
 
 
 
 
 text \<open>Syntactic division remainder operator\<close>
 
 class modulo = dvd + divide +
   fixes modulo :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"  (infixl "mod" 70)
 
 text \<open>Arbitrary quotient and remainder partitions\<close>
 
 class semiring_modulo = comm_semiring_1_cancel + divide + modulo +
   assumes div_mult_mod_eq: "a div b * b + a mod b = a"
 begin
 
 lemma mod_div_decomp:
   fixes a b
   obtains q r where "q = a div b" and "r = a mod b"
     and "a = q * b + r"
 proof -
   from div_mult_mod_eq have "a = a div b * b + a mod b" by simp
   moreover have "a div b = a div b" ..
   moreover have "a mod b = a mod b" ..
   note that ultimately show thesis by blast
 qed
 
 lemma mult_div_mod_eq: "b * (a div b) + a mod b = a"
   using div_mult_mod_eq [of a b] by (simp add: ac_simps)
 
 lemma mod_div_mult_eq: "a mod b + a div b * b = a"
   using div_mult_mod_eq [of a b] by (simp add: ac_simps)
 
 lemma mod_mult_div_eq: "a mod b + b * (a div b) = a"
   using div_mult_mod_eq [of a b] by (simp add: ac_simps)
 
 lemma minus_div_mult_eq_mod: "a - a div b * b = a mod b"
   by (rule add_implies_diff [symmetric]) (fact mod_div_mult_eq)
 
 lemma minus_mult_div_eq_mod: "a - b * (a div b) = a mod b"
   by (rule add_implies_diff [symmetric]) (fact mod_mult_div_eq)
 
 lemma minus_mod_eq_div_mult: "a - a mod b = a div b * b"
   by (rule add_implies_diff [symmetric]) (fact div_mult_mod_eq)
 
 lemma minus_mod_eq_mult_div: "a - a mod b = b * (a div b)"
   by (rule add_implies_diff [symmetric]) (fact mult_div_mod_eq)
 
 lemma mod_0_imp_dvd [dest!]:
   "b dvd a" if "a mod b = 0"
 proof -
   have "b dvd (a div b) * b" by simp
   also have "(a div b) * b = a"
     using div_mult_mod_eq [of a b] by (simp add: that)
   finally show ?thesis .
 qed
 
 lemma [nitpick_unfold]:
   "a mod b = a - a div b * b"
   by (fact minus_div_mult_eq_mod [symmetric])
 
 end
 
 
 subsection \<open>Quotient and remainder in integral domains\<close>
 
 class semidom_modulo = algebraic_semidom + semiring_modulo
 begin
 
 lemma mod_0 [simp]: "0 mod a = 0"
   using div_mult_mod_eq [of 0 a] by simp
 
 lemma mod_by_0 [simp]: "a mod 0 = a"
   using div_mult_mod_eq [of a 0] by simp
 
 lemma mod_by_1 [simp]:
   "a mod 1 = 0"
 proof -
   from div_mult_mod_eq [of a one] div_by_1 have "a + a mod 1 = a" by simp
   then have "a + a mod 1 = a + 0" by simp
   then show ?thesis by (rule add_left_imp_eq)
 qed
 
 lemma mod_self [simp]:
   "a mod a = 0"
   using div_mult_mod_eq [of a a] by simp
 
 lemma dvd_imp_mod_0 [simp]:
   "b mod a = 0" if "a dvd b"
   using that minus_div_mult_eq_mod [of b a] by simp
 
 lemma mod_eq_0_iff_dvd:
   "a mod b = 0 \<longleftrightarrow> b dvd a"
   by (auto intro: mod_0_imp_dvd)
 
 lemma dvd_eq_mod_eq_0 [nitpick_unfold, code]:
   "a dvd b \<longleftrightarrow> b mod a = 0"
   by (simp add: mod_eq_0_iff_dvd)
 
 lemma dvd_mod_iff: 
   assumes "c dvd b"
   shows "c dvd a mod b \<longleftrightarrow> c dvd a"
 proof -
   from assms have "(c dvd a mod b) \<longleftrightarrow> (c dvd ((a div b) * b + a mod b))" 
     by (simp add: dvd_add_right_iff)
   also have "(a div b) * b + a mod b = a"
     using div_mult_mod_eq [of a b] by simp
   finally show ?thesis .
 qed
 
 lemma dvd_mod_imp_dvd:
   assumes "c dvd a mod b" and "c dvd b"
   shows "c dvd a"
   using assms dvd_mod_iff [of c b a] by simp
 
 lemma dvd_minus_mod [simp]:
   "b dvd a - a mod b"
   by (simp add: minus_mod_eq_div_mult)
 
 lemma cancel_div_mod_rules:
   "((a div b) * b + a mod b) + c = a + c"
   "(b * (a div b) + a mod b) + c = a + c"
   by (simp_all add: div_mult_mod_eq mult_div_mod_eq)
 
 end
 
 class idom_modulo = idom + semidom_modulo
 begin
 
 subclass idom_divide ..
 
 lemma div_diff [simp]:
   "c dvd a \<Longrightarrow> c dvd b \<Longrightarrow> (a - b) div c = a div c - b div c"
   using div_add [of _  _ "- b"] by (simp add: dvd_neg_div)
 
 end
 
 
 subsection \<open>Interlude: basic tool support for algebraic and arithmetic calculations\<close>
 
 named_theorems arith "arith facts -- only ground formulas"
 ML_file \<open>Tools/arith_data.ML\<close>
 
 ML_file \<open>~~/src/Provers/Arith/cancel_div_mod.ML\<close>
 
 ML \<open>
 structure Cancel_Div_Mod_Ring = Cancel_Div_Mod
 (
   val div_name = \<^const_name>\<open>divide\<close>;
   val mod_name = \<^const_name>\<open>modulo\<close>;
   val mk_binop = HOLogic.mk_binop;
   val mk_sum = Arith_Data.mk_sum;
   val dest_sum = Arith_Data.dest_sum;
 
   val div_mod_eqs = map mk_meta_eq @{thms cancel_div_mod_rules};
 
   val prove_eq_sums = Arith_Data.prove_conv2 all_tac (Arith_Data.simp_all_tac
     @{thms diff_conv_add_uminus add_0_left add_0_right ac_simps})
 )
 \<close>
 
 simproc_setup cancel_div_mod_int ("(a::'a::semidom_modulo) + b") =
   \<open>K Cancel_Div_Mod_Ring.proc\<close>
 
 
 subsection \<open>Ordered semirings and rings\<close>
 
 text \<open>
   The theory of partially ordered rings is taken from the books:
     \<^item> \<^emph>\<open>Lattice Theory\<close> by Garret Birkhoff, American Mathematical Society, 1979
     \<^item> \<^emph>\<open>Partially Ordered Algebraic Systems\<close>, Pergamon Press, 1963
 
   Most of the used notions can also be looked up in
     \<^item> \<^url>\<open>http://www.mathworld.com\<close> by Eric Weisstein et. al.
     \<^item> \<^emph>\<open>Algebra I\<close> by van der Waerden, Springer
 \<close>
 
 class ordered_semiring = semiring + ordered_comm_monoid_add +
   assumes mult_left_mono: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> c * a \<le> c * b"
   assumes mult_right_mono: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> a * c \<le> b * c"
 begin
 
 lemma mult_mono: "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> a * c \<le> b * d"
   apply (erule (1) mult_right_mono [THEN order_trans])
   apply (erule (1) mult_left_mono)
   done
 
 lemma mult_mono': "a \<le> b \<Longrightarrow> c \<le> d \<Longrightarrow> 0 \<le> a \<Longrightarrow> 0 \<le> c \<Longrightarrow> a * c \<le> b * d"
   by (rule mult_mono) (fast intro: order_trans)+
 
 end
 
 lemma mono_mult:
   fixes a :: "'a::ordered_semiring" 
   shows "a \<ge> 0 \<Longrightarrow> mono ((*) a)"
   by (simp add: mono_def mult_left_mono)
 
 class ordered_semiring_0 = semiring_0 + ordered_semiring
 begin
 
 lemma mult_nonneg_nonneg [simp]: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> a * b"
   using mult_left_mono [of 0 b a] by simp
 
 lemma mult_nonneg_nonpos: "0 \<le> a \<Longrightarrow> b \<le> 0 \<Longrightarrow> a * b \<le> 0"
   using mult_left_mono [of b 0 a] by simp
 
 lemma mult_nonpos_nonneg: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> a * b \<le> 0"
   using mult_right_mono [of a 0 b] by simp
 
 text \<open>Legacy -- use @{thm [source] mult_nonpos_nonneg}.\<close>
 lemma mult_nonneg_nonpos2: "0 \<le> a \<Longrightarrow> b \<le> 0 \<Longrightarrow> b * a \<le> 0"
   by (drule mult_right_mono [of b 0]) auto
 
 lemma split_mult_neg_le: "(0 \<le> a \<and> b \<le> 0) \<or> (a \<le> 0 \<and> 0 \<le> b) \<Longrightarrow> a * b \<le> 0"
   by (auto simp add: mult_nonneg_nonpos mult_nonneg_nonpos2)
 
 end
 
 class ordered_cancel_semiring = ordered_semiring + cancel_comm_monoid_add
 begin
 
 subclass semiring_0_cancel ..
 
 subclass ordered_semiring_0 ..
 
 end
 
 class linordered_semiring = ordered_semiring + linordered_cancel_ab_semigroup_add
 begin
 
 subclass ordered_cancel_semiring ..
 
 subclass ordered_cancel_comm_monoid_add ..
 
 subclass ordered_ab_semigroup_monoid_add_imp_le ..
 
 lemma mult_left_less_imp_less: "c * a < c * b \<Longrightarrow> 0 \<le> c \<Longrightarrow> a < b"
   by (force simp add: mult_left_mono not_le [symmetric])
 
 lemma mult_right_less_imp_less: "a * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> a < b"
   by (force simp add: mult_right_mono not_le [symmetric])
 
 end
 
 class zero_less_one = order + zero + one +
   assumes zero_less_one [simp]: "0 < 1"
 begin
 
 subclass zero_neq_one
   by standard (simp add: less_imp_neq)
 
 lemma zero_le_one [simp]:
   \<open>0 \<le> 1\<close> by (rule less_imp_le) simp
 
 end
 
 class linordered_semiring_1 = linordered_semiring + semiring_1 + zero_less_one
 begin
 
 lemma convex_bound_le:
   assumes "x \<le> a" "y \<le> a" "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "u * x + v * y \<le> a"
 proof-
   from assms have "u * x + v * y \<le> u * a + v * a"
     by (simp add: add_mono mult_left_mono)
   with assms show ?thesis
     unfolding distrib_right[symmetric] by simp
 qed
 
 end
 
 class linordered_semiring_strict = semiring + comm_monoid_add + linordered_cancel_ab_semigroup_add +
   assumes mult_strict_left_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
   assumes mult_strict_right_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> a * c < b * c"
 begin
 
 subclass semiring_0_cancel ..
 
 subclass linordered_semiring
 proof
   fix a b c :: 'a
   assume *: "a \<le> b" "0 \<le> c"
   then show "c * a \<le> c * b"
     unfolding le_less
     using mult_strict_left_mono by (cases "c = 0") auto
   from * show "a * c \<le> b * c"
     unfolding le_less
     using mult_strict_right_mono by (cases "c = 0") auto
 qed
 
 lemma mult_left_le_imp_le: "c * a \<le> c * b \<Longrightarrow> 0 < c \<Longrightarrow> a \<le> b"
   by (auto simp add: mult_strict_left_mono _not_less [symmetric])
 
 lemma mult_right_le_imp_le: "a * c \<le> b * c \<Longrightarrow> 0 < c \<Longrightarrow> a \<le> b"
   by (auto simp add: mult_strict_right_mono not_less [symmetric])
 
 lemma mult_pos_pos[simp]: "0 < a \<Longrightarrow> 0 < b \<Longrightarrow> 0 < a * b"
   using mult_strict_left_mono [of 0 b a] by simp
 
 lemma mult_pos_neg: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> a * b < 0"
   using mult_strict_left_mono [of b 0 a] by simp
 
 lemma mult_neg_pos: "a < 0 \<Longrightarrow> 0 < b \<Longrightarrow> a * b < 0"
   using mult_strict_right_mono [of a 0 b] by simp
 
 text \<open>Legacy -- use @{thm [source] mult_neg_pos}.\<close>
 lemma mult_pos_neg2: "0 < a \<Longrightarrow> b < 0 \<Longrightarrow> b * a < 0"
   by (drule mult_strict_right_mono [of b 0]) auto
 
 lemma zero_less_mult_pos: 
   assumes "0 < a * b" "0 < a" shows "0 < b"
 proof (cases "b \<le> 0")
   case True
   then show ?thesis
     using assms by (auto simp: le_less dest: less_not_sym mult_pos_neg [of a b])
 qed (auto simp add: le_less not_less)
 
 
 lemma zero_less_mult_pos2: 
   assumes "0 < b * a" "0 < a" shows "0 < b"
 proof (cases "b \<le> 0")
   case True
   then show ?thesis
     using assms by (auto simp: le_less dest: less_not_sym mult_pos_neg2 [of a b])
 qed (auto simp add: le_less not_less)
 
 text \<open>Strict monotonicity in both arguments\<close>
 lemma mult_strict_mono:
   assumes "a < b" "c < d" "0 < b" "0 \<le> c"
   shows "a * c < b * d"
 proof (cases "c = 0")
   case True
   with assms show ?thesis
     by simp
 next
   case False
   with assms have "a*c < b*c"
     by (simp add: mult_strict_right_mono [OF \<open>a < b\<close>])
   also have "\<dots> < b*d"
     by (simp add: assms mult_strict_left_mono)
   finally show ?thesis .
 qed
 
 text \<open>This weaker variant has more natural premises\<close>
 lemma mult_strict_mono':
   assumes "a < b" and "c < d" and "0 \<le> a" and "0 \<le> c"
   shows "a * c < b * d"
-  by (rule mult_strict_mono) (insert assms, auto)
+  using assms by (auto simp add: mult_strict_mono)
 
 lemma mult_less_le_imp_less:
   assumes "a < b" and "c \<le> d" and "0 \<le> a" and "0 < c"
   shows "a * c < b * d"
 proof -
   have "a * c < b * c"
     by (simp add: assms mult_strict_right_mono)
   also have "... \<le> b * d"
     by (intro mult_left_mono) (use assms in auto)
   finally show ?thesis .
 qed
 
 lemma mult_le_less_imp_less:
   assumes "a \<le> b" and "c < d" and "0 < a" and "0 \<le> c"
   shows "a * c < b * d"
 proof -
   have "a * c \<le> b * c"
     by (simp add: assms mult_right_mono)
   also have "... < b * d"
     by (intro mult_strict_left_mono) (use assms in auto)
   finally show ?thesis .
 qed
 
 end
 
 class linordered_semiring_1_strict = linordered_semiring_strict + semiring_1 + zero_less_one
 begin
 
 subclass linordered_semiring_1 ..
 
 lemma convex_bound_lt:
   assumes "x < a" "y < a" "0 \<le> u" "0 \<le> v" "u + v = 1"
   shows "u * x + v * y < a"
 proof -
   from assms have "u * x + v * y < u * a + v * a"
     by (cases "u = 0") (auto intro!: add_less_le_mono mult_strict_left_mono mult_left_mono)
   with assms show ?thesis
     unfolding distrib_right[symmetric] by simp
 qed
 
 end
 
 class ordered_comm_semiring = comm_semiring_0 + ordered_ab_semigroup_add +
   assumes comm_mult_left_mono: "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow> c * a \<le> c * b"
 begin
 
 subclass ordered_semiring
 proof
   fix a b c :: 'a
   assume "a \<le> b" "0 \<le> c"
   then show "c * a \<le> c * b" by (rule comm_mult_left_mono)
   then show "a * c \<le> b * c" by (simp only: mult.commute)
 qed
 
 end
 
 class ordered_cancel_comm_semiring = ordered_comm_semiring + cancel_comm_monoid_add
 begin
 
 subclass comm_semiring_0_cancel ..
 subclass ordered_comm_semiring ..
 subclass ordered_cancel_semiring ..
 
 end
 
 class linordered_comm_semiring_strict = comm_semiring_0 + linordered_cancel_ab_semigroup_add +
   assumes comm_mult_strict_left_mono: "a < b \<Longrightarrow> 0 < c \<Longrightarrow> c * a < c * b"
 begin
 
 subclass linordered_semiring_strict
 proof
   fix a b c :: 'a
   assume "a < b" "0 < c"
   then show "c * a < c * b"
     by (rule comm_mult_strict_left_mono)
   then show "a * c < b * c"
     by (simp only: mult.commute)
 qed
 
 subclass ordered_cancel_comm_semiring
 proof
   fix a b c :: 'a
   assume "a \<le> b" "0 \<le> c"
   then show "c * a \<le> c * b"
     unfolding le_less
     using mult_strict_left_mono by (cases "c = 0") auto
 qed
 
 end
 
 class ordered_ring = ring + ordered_cancel_semiring
 begin
 
 subclass ordered_ab_group_add ..
 
 lemma less_add_iff1: "a * e + c < b * e + d \<longleftrightarrow> (a - b) * e + c < d"
   by (simp add: algebra_simps)
 
 lemma less_add_iff2: "a * e + c < b * e + d \<longleftrightarrow> c < (b - a) * e + d"
   by (simp add: algebra_simps)
 
 lemma le_add_iff1: "a * e + c \<le> b * e + d \<longleftrightarrow> (a - b) * e + c \<le> d"
   by (simp add: algebra_simps)
 
 lemma le_add_iff2: "a * e + c \<le> b * e + d \<longleftrightarrow> c \<le> (b - a) * e + d"
   by (simp add: algebra_simps)
 
 lemma mult_left_mono_neg: "b \<le> a \<Longrightarrow> c \<le> 0 \<Longrightarrow> c * a \<le> c * b"
   by (auto dest: mult_left_mono [of _ _ "- c"])
 
 lemma mult_right_mono_neg: "b \<le> a \<Longrightarrow> c \<le> 0 \<Longrightarrow> a * c \<le> b * c"
   by (auto dest: mult_right_mono [of _ _ "- c"])
 
 lemma mult_nonpos_nonpos: "a \<le> 0 \<Longrightarrow> b \<le> 0 \<Longrightarrow> 0 \<le> a * b"
   using mult_right_mono_neg [of a 0 b] by simp
 
 lemma split_mult_pos_le: "(0 \<le> a \<and> 0 \<le> b) \<or> (a \<le> 0 \<and> b \<le> 0) \<Longrightarrow> 0 \<le> a * b"
   by (auto simp add: mult_nonpos_nonpos)
 
 end
 
 class abs_if = minus + uminus + ord + zero + abs +
   assumes abs_if: "\<bar>a\<bar> = (if a < 0 then - a else a)"
 
 class linordered_ring = ring + linordered_semiring + linordered_ab_group_add + abs_if
 begin
 
 subclass ordered_ring ..
 
 subclass ordered_ab_group_add_abs
 proof
   fix a b
   show "\<bar>a + b\<bar> \<le> \<bar>a\<bar> + \<bar>b\<bar>"
     by (auto simp add: abs_if not_le not_less algebra_simps
         simp del: add.commute dest: add_neg_neg add_nonneg_nonneg)
 qed (auto simp: abs_if)
 
 lemma zero_le_square [simp]: "0 \<le> a * a"
   using linear [of 0 a] by (auto simp add: mult_nonpos_nonpos)
 
 lemma not_square_less_zero [simp]: "\<not> (a * a < 0)"
   by (simp add: not_less)
 
 proposition abs_eq_iff: "\<bar>x\<bar> = \<bar>y\<bar> \<longleftrightarrow> x = y \<or> x = -y"
   by (auto simp add: abs_if split: if_split_asm)
 
 lemma abs_eq_iff':
   "\<bar>a\<bar> = b \<longleftrightarrow> b \<ge> 0 \<and> (a = b \<or> a = - b)"
   by (cases "a \<ge> 0") auto
 
 lemma eq_abs_iff':
   "a = \<bar>b\<bar> \<longleftrightarrow> a \<ge> 0 \<and> (b = a \<or> b = - a)"
   using abs_eq_iff' [of b a] by auto
 
 lemma sum_squares_ge_zero: "0 \<le> x * x + y * y"
   by (intro add_nonneg_nonneg zero_le_square)
 
 lemma not_sum_squares_lt_zero: "\<not> x * x + y * y < 0"
   by (simp add: not_less sum_squares_ge_zero)
 
 end
 
 class linordered_ring_strict = ring + linordered_semiring_strict
   + ordered_ab_group_add + abs_if
 begin
 
 subclass linordered_ring ..
 
 lemma mult_strict_left_mono_neg: "b < a \<Longrightarrow> c < 0 \<Longrightarrow> c * a < c * b"
   using mult_strict_left_mono [of b a "- c"] by simp
 
 lemma mult_strict_right_mono_neg: "b < a \<Longrightarrow> c < 0 \<Longrightarrow> a * c < b * c"
   using mult_strict_right_mono [of b a "- c"] by simp
 
 lemma mult_neg_neg: "a < 0 \<Longrightarrow> b < 0 \<Longrightarrow> 0 < a * b"
   using mult_strict_right_mono_neg [of a 0 b] by simp
 
 subclass ring_no_zero_divisors
 proof
   fix a b
   assume "a \<noteq> 0"
   then have a: "a < 0 \<or> 0 < a" by (simp add: neq_iff)
   assume "b \<noteq> 0"
   then have b: "b < 0 \<or> 0 < b" by (simp add: neq_iff)
   have "a * b < 0 \<or> 0 < a * b"
   proof (cases "a < 0")
     case True
     show ?thesis
     proof (cases "b < 0")
       case True
       with \<open>a < 0\<close> show ?thesis by (auto dest: mult_neg_neg)
     next
       case False
       with b have "0 < b" by auto
       with \<open>a < 0\<close> show ?thesis by (auto dest: mult_strict_right_mono)
     qed
   next
     case False
     with a have "0 < a" by auto
     show ?thesis
     proof (cases "b < 0")
       case True
       with \<open>0 < a\<close> show ?thesis
         by (auto dest: mult_strict_right_mono_neg)
     next
       case False
       with b have "0 < b" by auto
       with \<open>0 < a\<close> show ?thesis by auto
     qed
   qed
   then show "a * b \<noteq> 0"
     by (simp add: neq_iff)
 qed
 
 lemma zero_less_mult_iff [algebra_split_simps, field_split_simps]:
   "0 < a * b \<longleftrightarrow> 0 < a \<and> 0 < b \<or> a < 0 \<and> b < 0"
   by (cases a 0 b 0 rule: linorder_cases[case_product linorder_cases])
      (auto simp add: mult_neg_neg not_less le_less dest: zero_less_mult_pos zero_less_mult_pos2)
 
 lemma zero_le_mult_iff [algebra_split_simps, field_split_simps]:
   "0 \<le> a * b \<longleftrightarrow> 0 \<le> a \<and> 0 \<le> b \<or> a \<le> 0 \<and> b \<le> 0"
   by (auto simp add: eq_commute [of 0] le_less not_less zero_less_mult_iff)
 
 lemma mult_less_0_iff [algebra_split_simps, field_split_simps]:
   "a * b < 0 \<longleftrightarrow> 0 < a \<and> b < 0 \<or> a < 0 \<and> 0 < b"
   using zero_less_mult_iff [of "- a" b] by auto
 
 lemma mult_le_0_iff [algebra_split_simps, field_split_simps]:
   "a * b \<le> 0 \<longleftrightarrow> 0 \<le> a \<and> b \<le> 0 \<or> a \<le> 0 \<and> 0 \<le> b"
   using zero_le_mult_iff [of "- a" b] by auto
 
 text \<open>
   Cancellation laws for \<^term>\<open>c * a < c * b\<close> and \<^term>\<open>a * c < b * c\<close>,
   also with the relations \<open>\<le>\<close> and equality.
 \<close>
 
 text \<open>
   These ``disjunction'' versions produce two cases when the comparison is
   an assumption, but effectively four when the comparison is a goal.
 \<close>
 
 lemma mult_less_cancel_right_disj: "a * c < b * c \<longleftrightarrow> 0 < c \<and> a < b \<or> c < 0 \<and> b < a"
 proof (cases "c = 0")
   case False
   show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
   proof
     assume ?lhs
     then have "c < 0 \<Longrightarrow> b < a" "c > 0 \<Longrightarrow> b > a"
       by (auto simp flip: not_le intro: mult_right_mono mult_right_mono_neg)
     with False show ?rhs 
       by (auto simp add: neq_iff)
   next
     assume ?rhs
     with False show ?lhs 
       by (auto simp add: mult_strict_right_mono mult_strict_right_mono_neg)
   qed
 qed auto
 
 lemma mult_less_cancel_left_disj: "c * a < c * b \<longleftrightarrow> 0 < c \<and> a < b \<or> c < 0 \<and> b < a"
 proof (cases "c = 0")
   case False
   show ?thesis (is "?lhs \<longleftrightarrow> ?rhs")
   proof
     assume ?lhs
     then have "c < 0 \<Longrightarrow> b < a" "c > 0 \<Longrightarrow> b > a"
       by (auto simp flip: not_le intro: mult_left_mono mult_left_mono_neg)
     with False show ?rhs 
       by (auto simp add: neq_iff)
   next
     assume ?rhs
     with False show ?lhs 
       by (auto simp add: mult_strict_left_mono mult_strict_left_mono_neg)
   qed
 qed auto
 
 text \<open>
   The ``conjunction of implication'' lemmas produce two cases when the
   comparison is a goal, but give four when the comparison is an assumption.
 \<close>
 
 lemma mult_less_cancel_right: "a * c < b * c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < b) \<and> (c \<le> 0 \<longrightarrow> b < a)"
   using mult_less_cancel_right_disj [of a c b] by auto
 
 lemma mult_less_cancel_left: "c * a < c * b \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < b) \<and> (c \<le> 0 \<longrightarrow> b < a)"
   using mult_less_cancel_left_disj [of c a b] by auto
 
 lemma mult_le_cancel_right: "a * c \<le> b * c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
   by (simp add: not_less [symmetric] mult_less_cancel_right_disj)
 
 lemma mult_le_cancel_left: "c * a \<le> c * b \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> a)"
   by (simp add: not_less [symmetric] mult_less_cancel_left_disj)
 
 lemma mult_le_cancel_left_pos: "0 < c \<Longrightarrow> c * a \<le> c * b \<longleftrightarrow> a \<le> b"
   by (auto simp: mult_le_cancel_left)
 
 lemma mult_le_cancel_left_neg: "c < 0 \<Longrightarrow> c * a \<le> c * b \<longleftrightarrow> b \<le> a"
   by (auto simp: mult_le_cancel_left)
 
 lemma mult_less_cancel_left_pos: "0 < c \<Longrightarrow> c * a < c * b \<longleftrightarrow> a < b"
   by (auto simp: mult_less_cancel_left)
 
 lemma mult_less_cancel_left_neg: "c < 0 \<Longrightarrow> c * a < c * b \<longleftrightarrow> b < a"
   by (auto simp: mult_less_cancel_left)
 
 end
 
 lemmas mult_sign_intros =
   mult_nonneg_nonneg mult_nonneg_nonpos
   mult_nonpos_nonneg mult_nonpos_nonpos
   mult_pos_pos mult_pos_neg
   mult_neg_pos mult_neg_neg
 
 class ordered_comm_ring = comm_ring + ordered_comm_semiring
 begin
 
 subclass ordered_ring ..
 subclass ordered_cancel_comm_semiring ..
 
 end
 
 class linordered_nonzero_semiring = ordered_comm_semiring + monoid_mult + linorder + zero_less_one +
   assumes add_mono1: "a < b \<Longrightarrow> a + 1 < b + 1"
 begin
 
 subclass zero_neq_one
-  by standard (insert zero_less_one, blast)
+  by standard
 
 subclass comm_semiring_1
   by standard (rule mult_1_left)
 
 lemma zero_le_one [simp]: "0 \<le> 1"
   by (rule zero_less_one [THEN less_imp_le])
 
 lemma not_one_le_zero [simp]: "\<not> 1 \<le> 0"
   by (simp add: not_le)
 
 lemma not_one_less_zero [simp]: "\<not> 1 < 0"
   by (simp add: not_less)
 
 lemma of_bool_less_eq_iff [simp]:
   \<open>of_bool P \<le> of_bool Q \<longleftrightarrow> (P \<longrightarrow> Q)\<close>
   by auto
 
 lemma of_bool_less_iff [simp]:
   \<open>of_bool P < of_bool Q \<longleftrightarrow> \<not> P \<and> Q\<close>
   by auto
 
 lemma mult_left_le: "c \<le> 1 \<Longrightarrow> 0 \<le> a \<Longrightarrow> a * c \<le> a"
   using mult_left_mono[of c 1 a] by simp
 
 lemma mult_le_one: "a \<le> 1 \<Longrightarrow> 0 \<le> b \<Longrightarrow> b \<le> 1 \<Longrightarrow> a * b \<le> 1"
   using mult_mono[of a 1 b 1] by simp
 
 lemma zero_less_two: "0 < 1 + 1"
   using add_pos_pos[OF zero_less_one zero_less_one] .
 
 end
 
 class linordered_semidom = semidom + linordered_comm_semiring_strict + zero_less_one +
   assumes le_add_diff_inverse2 [simp]: "b \<le> a \<Longrightarrow> a - b + b = a"
 begin
 
 subclass linordered_nonzero_semiring 
 proof
   show "a + 1 < b + 1" if "a < b" for a b
-  proof (rule ccontr, simp add: not_less)
-    assume "b \<le> a"
-    with that show False
+  proof (rule ccontr)
+    assume "\<not> a + 1 < b + 1"
+    moreover with that have "a + 1 < b + 1"
       by simp
+    ultimately show False
+      by contradiction
   qed
 qed
 
 lemma zero_less_eq_of_bool [simp]:
   \<open>0 \<le> of_bool P\<close>
   by simp
 
 lemma zero_less_of_bool_iff [simp]:
   \<open>0 < of_bool P \<longleftrightarrow> P\<close>
   by simp
 
 lemma of_bool_less_eq_one [simp]:
   \<open>of_bool P \<le> 1\<close>
   by simp
 
 lemma of_bool_less_one_iff [simp]:
   \<open>of_bool P < 1 \<longleftrightarrow> \<not> P\<close>
   by simp
 
 lemma of_bool_or_iff [simp]:
   \<open>of_bool (P \<or> Q) = max (of_bool P) (of_bool Q)\<close>
   by (simp add: max_def)
 
 text \<open>Addition is the inverse of subtraction.\<close>
 
 lemma le_add_diff_inverse [simp]: "b \<le> a \<Longrightarrow> b + (a - b) = a"
   by (frule le_add_diff_inverse2) (simp add: add.commute)
 
 lemma add_diff_inverse: "\<not> a < b \<Longrightarrow> b + (a - b) = a"
   by simp
 
 lemma add_le_imp_le_diff: 
   assumes "i + k \<le> n" shows "i \<le> n - k"
 proof -
   have "n - (i + k) + i + k = n"
     by (simp add: assms add.assoc)
   with assms add_implies_diff have "i + k \<le> n - k + k"
     by fastforce
   then show ?thesis
     by simp
 qed
 
 lemma add_le_add_imp_diff_le:
   assumes 1: "i + k \<le> n"
     and 2: "n \<le> j + k"
   shows "i + k \<le> n \<Longrightarrow> n \<le> j + k \<Longrightarrow> n - k \<le> j"
 proof -
   have "n - (i + k) + i + k = n"
     using 1 by (simp add: add.assoc)
   moreover have "n - k = n - k - i + i"
     using 1 by (simp add: add_le_imp_le_diff)
   ultimately show ?thesis
     using 2 add_le_imp_le_diff [of "n-k" k "j + k"]
     by (simp add: add.commute diff_diff_add)
 qed
 
 lemma less_1_mult: "1 < m \<Longrightarrow> 1 < n \<Longrightarrow> 1 < m * n"
   using mult_strict_mono [of 1 m 1 n] by (simp add: less_trans [OF zero_less_one])
 
 end
 
 class linordered_idom = comm_ring_1 + linordered_comm_semiring_strict +
   ordered_ab_group_add + abs_if + sgn +
   assumes sgn_if: "sgn x = (if x = 0 then 0 else if 0 < x then 1 else - 1)"
 begin
 
 subclass linordered_ring_strict ..
 
 subclass linordered_semiring_1_strict
 proof
   have "0 \<le> 1 * 1"
     by (fact zero_le_square)
   then show "0 < 1" 
     by (simp add: le_less)
 qed
 
 subclass ordered_comm_ring ..
 subclass idom ..
 
 subclass linordered_semidom
   by standard simp
 
 subclass idom_abs_sgn
   by standard
     (auto simp add: sgn_if abs_if zero_less_mult_iff)
 
 lemma abs_bool_eq [simp]:
   \<open>\<bar>of_bool P\<bar> = of_bool P\<close>
   by simp
 
 lemma linorder_neqE_linordered_idom:
   assumes "x \<noteq> y"
   obtains "x < y" | "y < x"
   using assms by (rule neqE)
 
 text \<open>These cancellation simp rules also produce two cases when the comparison is a goal.\<close>
 
 lemma mult_le_cancel_right1: "c \<le> b * c \<longleftrightarrow> (0 < c \<longrightarrow> 1 \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> 1)"
   using mult_le_cancel_right [of 1 c b] by simp
 
 lemma mult_le_cancel_right2: "a * c \<le> c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> 1) \<and> (c < 0 \<longrightarrow> 1 \<le> a)"
   using mult_le_cancel_right [of a c 1] by simp
 
 lemma mult_le_cancel_left1: "c \<le> c * b \<longleftrightarrow> (0 < c \<longrightarrow> 1 \<le> b) \<and> (c < 0 \<longrightarrow> b \<le> 1)"
   using mult_le_cancel_left [of c 1 b] by simp
 
 lemma mult_le_cancel_left2: "c * a \<le> c \<longleftrightarrow> (0 < c \<longrightarrow> a \<le> 1) \<and> (c < 0 \<longrightarrow> 1 \<le> a)"
   using mult_le_cancel_left [of c a 1] by simp
 
 lemma mult_less_cancel_right1: "c < b * c \<longleftrightarrow> (0 \<le> c \<longrightarrow> 1 < b) \<and> (c \<le> 0 \<longrightarrow> b < 1)"
   using mult_less_cancel_right [of 1 c b] by simp
 
 lemma mult_less_cancel_right2: "a * c < c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < 1) \<and> (c \<le> 0 \<longrightarrow> 1 < a)"
   using mult_less_cancel_right [of a c 1] by simp
 
 lemma mult_less_cancel_left1: "c < c * b \<longleftrightarrow> (0 \<le> c \<longrightarrow> 1 < b) \<and> (c \<le> 0 \<longrightarrow> b < 1)"
   using mult_less_cancel_left [of c 1 b] by simp
 
 lemma mult_less_cancel_left2: "c * a < c \<longleftrightarrow> (0 \<le> c \<longrightarrow> a < 1) \<and> (c \<le> 0 \<longrightarrow> 1 < a)"
   using mult_less_cancel_left [of c a 1] by simp
 
 lemma sgn_0_0: "sgn a = 0 \<longleftrightarrow> a = 0"
   by (fact sgn_eq_0_iff)
 
 lemma sgn_1_pos: "sgn a = 1 \<longleftrightarrow> a > 0"
   unfolding sgn_if by simp
 
 lemma sgn_1_neg: "sgn a = - 1 \<longleftrightarrow> a < 0"
   unfolding sgn_if by auto
 
 lemma sgn_pos [simp]: "0 < a \<Longrightarrow> sgn a = 1"
   by (simp only: sgn_1_pos)
 
 lemma sgn_neg [simp]: "a < 0 \<Longrightarrow> sgn a = - 1"
   by (simp only: sgn_1_neg)
 
 lemma abs_sgn: "\<bar>k\<bar> = k * sgn k"
   unfolding sgn_if abs_if by auto
 
 lemma sgn_greater [simp]: "0 < sgn a \<longleftrightarrow> 0 < a"
   unfolding sgn_if by auto
 
 lemma sgn_less [simp]: "sgn a < 0 \<longleftrightarrow> a < 0"
   unfolding sgn_if by auto
 
 lemma abs_sgn_eq_1 [simp]:
   "a \<noteq> 0 \<Longrightarrow> \<bar>sgn a\<bar> = 1"
   by simp
 
 lemma abs_sgn_eq: "\<bar>sgn a\<bar> = (if a = 0 then 0 else 1)"
   by (simp add: sgn_if)
 
 lemma sgn_mult_self_eq [simp]:
   "sgn a * sgn a = of_bool (a \<noteq> 0)"
   by (cases "a > 0") simp_all
 
 lemma abs_mult_self_eq [simp]:
   "\<bar>a\<bar> * \<bar>a\<bar> = a * a"
   by (cases "a > 0") simp_all
 
 lemma same_sgn_sgn_add:
   "sgn (a + b) = sgn a" if "sgn b = sgn a"
 proof (cases a 0 rule: linorder_cases)
   case equal
   with that show ?thesis
     by simp
 next
   case less
   with that have "b < 0"
     by (simp add: sgn_1_neg)
   with \<open>a < 0\<close> have "a + b < 0"
     by (rule add_neg_neg)
   with \<open>a < 0\<close> show ?thesis
     by simp
 next
   case greater
   with that have "b > 0"
     by (simp add: sgn_1_pos)
   with \<open>a > 0\<close> have "a + b > 0"
     by (rule add_pos_pos)
   with \<open>a > 0\<close> show ?thesis
     by simp
 qed
 
 lemma same_sgn_abs_add:
   "\<bar>a + b\<bar> = \<bar>a\<bar> + \<bar>b\<bar>" if "sgn b = sgn a"
 proof -
   have "a + b = sgn a * \<bar>a\<bar> + sgn b * \<bar>b\<bar>"
     by (simp add: sgn_mult_abs)
   also have "\<dots> = sgn a * (\<bar>a\<bar> + \<bar>b\<bar>)"
     using that by (simp add: algebra_simps)
   finally show ?thesis
     by (auto simp add: abs_mult)
 qed
 
 lemma sgn_not_eq_imp:
   "sgn a = - sgn b" if "sgn b \<noteq> sgn a" and "sgn a \<noteq> 0" and "sgn b \<noteq> 0"
   using that by (cases "a < 0") (auto simp add: sgn_0_0 sgn_1_pos sgn_1_neg)
 
 lemma abs_dvd_iff [simp]: "\<bar>m\<bar> dvd k \<longleftrightarrow> m dvd k"
   by (simp add: abs_if)
 
 lemma dvd_abs_iff [simp]: "m dvd \<bar>k\<bar> \<longleftrightarrow> m dvd k"
   by (simp add: abs_if)
 
 lemma dvd_if_abs_eq: "\<bar>l\<bar> = \<bar>k\<bar> \<Longrightarrow> l dvd k"
   by (subst abs_dvd_iff [symmetric]) simp
 
 text \<open>
   The following lemmas can be proven in more general structures, but
   are dangerous as simp rules in absence of @{thm neg_equal_zero},
   @{thm neg_less_pos}, @{thm neg_less_eq_nonneg}.
 \<close>
 
 lemma equation_minus_iff_1 [simp, no_atp]: "1 = - a \<longleftrightarrow> a = - 1"
   by (fact equation_minus_iff)
 
 lemma minus_equation_iff_1 [simp, no_atp]: "- a = 1 \<longleftrightarrow> a = - 1"
   by (subst minus_equation_iff, auto)
 
 lemma le_minus_iff_1 [simp, no_atp]: "1 \<le> - b \<longleftrightarrow> b \<le> - 1"
   by (fact le_minus_iff)
 
 lemma minus_le_iff_1 [simp, no_atp]: "- a \<le> 1 \<longleftrightarrow> - 1 \<le> a"
   by (fact minus_le_iff)
 
 lemma less_minus_iff_1 [simp, no_atp]: "1 < - b \<longleftrightarrow> b < - 1"
   by (fact less_minus_iff)
 
 lemma minus_less_iff_1 [simp, no_atp]: "- a < 1 \<longleftrightarrow> - 1 < a"
   by (fact minus_less_iff)
 
 lemma add_less_zeroD:
   shows "x+y < 0 \<Longrightarrow> x<0 \<or> y<0"
   by (auto simp: not_less intro: le_less_trans [of _ "x+y"])
 
 end
 
 text \<open>Reasoning about inequalities with division\<close>
 
 context linordered_semidom
 begin
 
 lemma less_add_one: "a < a + 1"
 proof -
   have "a + 0 < a + 1"
     by (blast intro: zero_less_one add_strict_left_mono)
   then show ?thesis by simp
 qed
 
 end
 
 context linordered_idom
 begin
 
 lemma mult_right_le_one_le: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> y \<le> 1 \<Longrightarrow> x * y \<le> x"
   by (rule mult_left_le)
 
 lemma mult_left_le_one_le: "0 \<le> x \<Longrightarrow> 0 \<le> y \<Longrightarrow> y \<le> 1 \<Longrightarrow> y * x \<le> x"
   by (auto simp add: mult_le_cancel_right2)
 
 end
 
 text \<open>Absolute Value\<close>
 
 context linordered_idom
 begin
 
 lemma mult_sgn_abs: "sgn x * \<bar>x\<bar> = x"
   by (fact sgn_mult_abs)
 
 lemma abs_one: "\<bar>1\<bar> = 1"
   by (fact abs_1)
 
 end
 
 class ordered_ring_abs = ordered_ring + ordered_ab_group_add_abs +
   assumes abs_eq_mult:
     "(0 \<le> a \<or> a \<le> 0) \<and> (0 \<le> b \<or> b \<le> 0) \<Longrightarrow> \<bar>a * b\<bar> = \<bar>a\<bar> * \<bar>b\<bar>"
 
 context linordered_idom
 begin
 
 subclass ordered_ring_abs
   by standard (auto simp: abs_if not_less mult_less_0_iff)
 
 lemma abs_mult_self: "\<bar>a\<bar> * \<bar>a\<bar> = a * a"
   by (fact abs_mult_self_eq)
 
 lemma abs_mult_less:
   assumes ac: "\<bar>a\<bar> < c"
     and bd: "\<bar>b\<bar> < d"
   shows "\<bar>a\<bar> * \<bar>b\<bar> < c * d"
 proof -
   from ac have "0 < c"
     by (blast intro: le_less_trans abs_ge_zero)
   with bd show ?thesis by (simp add: ac mult_strict_mono)
 qed
 
 lemma abs_less_iff: "\<bar>a\<bar> < b \<longleftrightarrow> a < b \<and> - a < b"
   by (simp add: less_le abs_le_iff) (auto simp add: abs_if)
 
 lemma abs_mult_pos: "0 \<le> x \<Longrightarrow> \<bar>y\<bar> * x = \<bar>y * x\<bar>"
   by (simp add: abs_mult)
 
 lemma abs_mult_pos': "0 \<le> x \<Longrightarrow> x * \<bar>y\<bar> = \<bar>x * y\<bar>"
   by (simp add: abs_mult)
 
 lemma abs_diff_less_iff: "\<bar>x - a\<bar> < r \<longleftrightarrow> a - r < x \<and> x < a + r"
   by (auto simp add: diff_less_eq ac_simps abs_less_iff)
 
 lemma abs_diff_le_iff: "\<bar>x - a\<bar> \<le> r \<longleftrightarrow> a - r \<le> x \<and> x \<le> a + r"
   by (auto simp add: diff_le_eq ac_simps abs_le_iff)
 
 lemma abs_add_one_gt_zero: "0 < 1 + \<bar>x\<bar>"
   by (auto simp: abs_if not_less intro: zero_less_one add_strict_increasing less_trans)
 
 end
 
 
 subsection \<open>Dioids\<close>
 
 text \<open>
   Dioids are the alternative extensions of semirings, a semiring can
   either be a ring or a dioid but never both.
 \<close>
 
 class dioid = semiring_1 + canonically_ordered_monoid_add
 begin
 
 subclass ordered_semiring
   by standard (auto simp: le_iff_add distrib_left distrib_right)
 
 end
 
 
 hide_fact (open) comm_mult_left_mono comm_mult_strict_left_mono distrib
 
 code_identifier
   code_module Rings \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith
 
 end
diff --git a/src/HOL/Set_Interval.thy b/src/HOL/Set_Interval.thy
--- a/src/HOL/Set_Interval.thy
+++ b/src/HOL/Set_Interval.thy
@@ -1,2563 +1,2615 @@
 (*  Title:      HOL/Set_Interval.thy
     Author:     Tobias Nipkow, Clemens Ballarin, Jeremy Avigad
 
 lessThan, greaterThan, atLeast, atMost and two-sided intervals
 
 Modern convention: Ixy stands for an interval where x and y
 describe the lower and upper bound and x,y : {c,o,i}
 where c = closed, o = open, i = infinite.
 Examples: Ico = {_ ..< _} and Ici = {_ ..}
 *)
 
 section \<open>Set intervals\<close>
 
 theory Set_Interval
 imports Divides
 begin
 
 (* Belongs in Finite_Set but 2 is not available there *)
 lemma card_2_iff: "card S = 2 \<longleftrightarrow> (\<exists>x y. S = {x,y} \<and> x \<noteq> y)"
   by (auto simp: card_Suc_eq numeral_eq_Suc)
 
 lemma card_2_iff': "card S = 2 \<longleftrightarrow> (\<exists>x\<in>S. \<exists>y\<in>S. x \<noteq> y \<and> (\<forall>z\<in>S. z = x \<or> z = y))"
   by (auto simp: card_Suc_eq numeral_eq_Suc)
 
 lemma card_3_iff: "card S = 3 \<longleftrightarrow> (\<exists>x y z. S = {x,y,z} \<and> x \<noteq> y \<and> y \<noteq> z \<and> x \<noteq> z)"
   by (fastforce simp: card_Suc_eq numeral_eq_Suc)
 
 context ord
 begin
 
 definition
   lessThan    :: "'a => 'a set" ("(1{..<_})") where
   "{..<u} == {x. x < u}"
 
 definition
   atMost      :: "'a => 'a set" ("(1{.._})") where
   "{..u} == {x. x \<le> u}"
 
 definition
   greaterThan :: "'a => 'a set" ("(1{_<..})") where
   "{l<..} == {x. l<x}"
 
 definition
   atLeast     :: "'a => 'a set" ("(1{_..})") where
   "{l..} == {x. l\<le>x}"
 
 definition
   greaterThanLessThan :: "'a => 'a => 'a set"  ("(1{_<..<_})") where
   "{l<..<u} == {l<..} Int {..<u}"
 
 definition
   atLeastLessThan :: "'a => 'a => 'a set"      ("(1{_..<_})") where
   "{l..<u} == {l..} Int {..<u}"
 
 definition
   greaterThanAtMost :: "'a => 'a => 'a set"    ("(1{_<.._})") where
   "{l<..u} == {l<..} Int {..u}"
 
 definition
   atLeastAtMost :: "'a => 'a => 'a set"        ("(1{_.._})") where
   "{l..u} == {l..} Int {..u}"
 
 end
 
 
 text\<open>A note of warning when using \<^term>\<open>{..<n}\<close> on type \<^typ>\<open>nat\<close>: it is equivalent to \<^term>\<open>{0::nat..<n}\<close> but some lemmas involving
 \<^term>\<open>{m..<n}\<close> may not exist in \<^term>\<open>{..<n}\<close>-form as well.\<close>
 
 syntax (ASCII)
   "_UNION_le"   :: "'a => 'a => 'b set => 'b set"       ("(3UN _<=_./ _)" [0, 0, 10] 10)
   "_UNION_less" :: "'a => 'a => 'b set => 'b set"       ("(3UN _<_./ _)" [0, 0, 10] 10)
   "_INTER_le"   :: "'a => 'a => 'b set => 'b set"       ("(3INT _<=_./ _)" [0, 0, 10] 10)
   "_INTER_less" :: "'a => 'a => 'b set => 'b set"       ("(3INT _<_./ _)" [0, 0, 10] 10)
 
 syntax (latex output)
   "_UNION_le"   :: "'a \<Rightarrow> 'a => 'b set => 'b set"       ("(3\<Union>(\<open>unbreakable\<close>_ \<le> _)/ _)" [0, 0, 10] 10)
   "_UNION_less" :: "'a \<Rightarrow> 'a => 'b set => 'b set"       ("(3\<Union>(\<open>unbreakable\<close>_ < _)/ _)" [0, 0, 10] 10)
   "_INTER_le"   :: "'a \<Rightarrow> 'a => 'b set => 'b set"       ("(3\<Inter>(\<open>unbreakable\<close>_ \<le> _)/ _)" [0, 0, 10] 10)
   "_INTER_less" :: "'a \<Rightarrow> 'a => 'b set => 'b set"       ("(3\<Inter>(\<open>unbreakable\<close>_ < _)/ _)" [0, 0, 10] 10)
 
 syntax
   "_UNION_le"   :: "'a => 'a => 'b set => 'b set"       ("(3\<Union>_\<le>_./ _)" [0, 0, 10] 10)
   "_UNION_less" :: "'a => 'a => 'b set => 'b set"       ("(3\<Union>_<_./ _)" [0, 0, 10] 10)
   "_INTER_le"   :: "'a => 'a => 'b set => 'b set"       ("(3\<Inter>_\<le>_./ _)" [0, 0, 10] 10)
   "_INTER_less" :: "'a => 'a => 'b set => 'b set"       ("(3\<Inter>_<_./ _)" [0, 0, 10] 10)
 
 translations
   "\<Union>i\<le>n. A" \<rightleftharpoons> "\<Union>i\<in>{..n}. A"
   "\<Union>i<n. A" \<rightleftharpoons> "\<Union>i\<in>{..<n}. A"
   "\<Inter>i\<le>n. A" \<rightleftharpoons> "\<Inter>i\<in>{..n}. A"
   "\<Inter>i<n. A" \<rightleftharpoons> "\<Inter>i\<in>{..<n}. A"
 
 
 subsection \<open>Various equivalences\<close>
 
 lemma (in ord) lessThan_iff [iff]: "(i \<in> lessThan k) = (i<k)"
 by (simp add: lessThan_def)
 
 lemma Compl_lessThan [simp]:
     "!!k:: 'a::linorder. -lessThan k = atLeast k"
   by (auto simp add: lessThan_def atLeast_def)
 
 lemma single_Diff_lessThan [simp]: "!!k:: 'a::preorder. {k} - lessThan k = {k}"
   by auto
 
 lemma (in ord) greaterThan_iff [iff]: "(i \<in> greaterThan k) = (k<i)"
   by (simp add: greaterThan_def)
 
 lemma Compl_greaterThan [simp]:
     "!!k:: 'a::linorder. -greaterThan k = atMost k"
   by (auto simp add: greaterThan_def atMost_def)
 
 lemma Compl_atMost [simp]: "!!k:: 'a::linorder. -atMost k = greaterThan k"
   by (metis Compl_greaterThan double_complement)
 
 lemma (in ord) atLeast_iff [iff]: "(i \<in> atLeast k) = (k<=i)"
   by (simp add: atLeast_def)
 
 lemma Compl_atLeast [simp]: "!!k:: 'a::linorder. -atLeast k = lessThan k"
   by (auto simp add: lessThan_def atLeast_def)
 
 lemma (in ord) atMost_iff [iff]: "(i \<in> atMost k) = (i<=k)"
 by (simp add: atMost_def)
 
 lemma atMost_Int_atLeast: "!!n:: 'a::order. atMost n Int atLeast n = {n}"
 by (blast intro: order_antisym)
 
 lemma (in linorder) lessThan_Int_lessThan: "{ a <..} \<inter> { b <..} = { max a b <..}"
   by auto
 
 lemma (in linorder) greaterThan_Int_greaterThan: "{..< a} \<inter> {..< b} = {..< min a b}"
   by auto
 
 subsection \<open>Logical Equivalences for Set Inclusion and Equality\<close>
 
 lemma atLeast_empty_triv [simp]: "{{}..} = UNIV"
   by auto
 
 lemma atMost_UNIV_triv [simp]: "{..UNIV} = UNIV"
   by auto
 
 lemma atLeast_subset_iff [iff]:
   "(atLeast x \<subseteq> atLeast y) = (y \<le> (x::'a::preorder))"
   by (blast intro: order_trans)
 
 lemma atLeast_eq_iff [iff]:
   "(atLeast x = atLeast y) = (x = (y::'a::order))"
   by (blast intro: order_antisym order_trans)
 
 lemma greaterThan_subset_iff [iff]:
   "(greaterThan x \<subseteq> greaterThan y) = (y \<le> (x::'a::linorder))"
   unfolding greaterThan_def by (auto simp: linorder_not_less [symmetric])
 
 lemma greaterThan_eq_iff [iff]:
      "(greaterThan x = greaterThan y) = (x = (y::'a::linorder))"
   by (auto simp: elim!: equalityE)
 
 lemma atMost_subset_iff [iff]: "(atMost x \<subseteq> atMost y) = (x \<le> (y::'a::preorder))"
   by (blast intro: order_trans)
 
 lemma atMost_eq_iff [iff]: "(atMost x = atMost y) = (x = (y::'a::order))"
   by (blast intro: order_antisym order_trans)
 
 lemma lessThan_subset_iff [iff]:
      "(lessThan x \<subseteq> lessThan y) = (x \<le> (y::'a::linorder))"
   unfolding lessThan_def by (auto simp: linorder_not_less [symmetric])
 
 lemma lessThan_eq_iff [iff]:
      "(lessThan x = lessThan y) = (x = (y::'a::linorder))"
   by (auto simp: elim!: equalityE)
 
 lemma lessThan_strict_subset_iff:
   fixes m n :: "'a::linorder"
   shows "{..<m} < {..<n} \<longleftrightarrow> m < n"
   by (metis leD lessThan_subset_iff linorder_linear not_less_iff_gr_or_eq psubset_eq)
 
 lemma (in linorder) Ici_subset_Ioi_iff: "{a ..} \<subseteq> {b <..} \<longleftrightarrow> b < a"
   by auto
 
 lemma (in linorder) Iic_subset_Iio_iff: "{.. a} \<subseteq> {..< b} \<longleftrightarrow> a < b"
   by auto
 
 lemma (in preorder) Ioi_le_Ico: "{a <..} \<subseteq> {a ..}"
   by (auto intro: less_imp_le)
 
 subsection \<open>Two-sided intervals\<close>
 
 context ord
 begin
 
 lemma greaterThanLessThan_iff [simp]: "(i \<in> {l<..<u}) = (l < i \<and> i < u)"
   by (simp add: greaterThanLessThan_def)
 
 lemma atLeastLessThan_iff [simp]: "(i \<in> {l..<u}) = (l \<le> i \<and> i < u)"
   by (simp add: atLeastLessThan_def)
 
 lemma greaterThanAtMost_iff [simp]: "(i \<in> {l<..u}) = (l < i \<and> i \<le> u)"
   by (simp add: greaterThanAtMost_def)
 
 lemma atLeastAtMost_iff [simp]: "(i \<in> {l..u}) = (l \<le> i \<and> i \<le> u)"
   by (simp add: atLeastAtMost_def)
 
 text \<open>The above four lemmas could be declared as iffs. Unfortunately this
 breaks many proofs. Since it only helps blast, it is better to leave them
 alone.\<close>
 
 lemma greaterThanLessThan_eq: "{ a <..< b} = { a <..} \<inter> {..< b }"
   by auto
 
 lemma (in order) atLeastLessThan_eq_atLeastAtMost_diff:
   "{a..<b} = {a..b} - {b}"
   by (auto simp add: atLeastLessThan_def atLeastAtMost_def)
 
 lemma (in order) greaterThanAtMost_eq_atLeastAtMost_diff:
   "{a<..b} = {a..b} - {a}"
   by (auto simp add: greaterThanAtMost_def atLeastAtMost_def)
 
 end
 
 subsubsection\<open>Emptyness, singletons, subset\<close>
 
 context preorder
 begin
 
 lemma atLeastatMost_empty_iff[simp]:
   "{a..b} = {} \<longleftrightarrow> (\<not> a \<le> b)"
   by auto (blast intro: order_trans)
 
 lemma atLeastatMost_empty_iff2[simp]:
   "{} = {a..b} \<longleftrightarrow> (\<not> a \<le> b)"
   by auto (blast intro: order_trans)
 
 lemma atLeastLessThan_empty_iff[simp]:
   "{a..<b} = {} \<longleftrightarrow> (\<not> a < b)"
   by auto (blast intro: le_less_trans)
 
 lemma atLeastLessThan_empty_iff2[simp]:
   "{} = {a..<b} \<longleftrightarrow> (\<not> a < b)"
   by auto (blast intro: le_less_trans)
 
 lemma greaterThanAtMost_empty_iff[simp]: "{k<..l} = {} \<longleftrightarrow> \<not> k < l"
   by auto (blast intro: less_le_trans)
 
 lemma greaterThanAtMost_empty_iff2[simp]: "{} = {k<..l} \<longleftrightarrow> \<not> k < l"
   by auto (blast intro: less_le_trans)
 
 lemma atLeastatMost_subset_iff[simp]:
   "{a..b} \<le> {c..d} \<longleftrightarrow> (\<not> a \<le> b) \<or> c \<le> a \<and> b \<le> d"
   unfolding atLeastAtMost_def atLeast_def atMost_def
   by (blast intro: order_trans)
 
 lemma atLeastatMost_psubset_iff:
   "{a..b} < {c..d} \<longleftrightarrow>
    ((\<not> a \<le> b) \<or> c \<le> a \<and> b \<le> d \<and> (c < a \<or> b < d)) \<and> c \<le> d"
   by(simp add: psubset_eq set_eq_iff less_le_not_le)(blast intro: order_trans)
 
 lemma atLeastAtMost_subseteq_atLeastLessThan_iff:
   "{a..b} \<subseteq> {c ..< d} \<longleftrightarrow> (a \<le> b \<longrightarrow> c \<le> a \<and> b < d)" 
   by auto (blast intro: local.order_trans local.le_less_trans elim: )+
 
 lemma Icc_subset_Ici_iff[simp]:
   "{l..h} \<subseteq> {l'..} = (\<not> l\<le>h \<or> l\<ge>l')"
   by(auto simp: subset_eq intro: order_trans)
 
 lemma Icc_subset_Iic_iff[simp]:
   "{l..h} \<subseteq> {..h'} = (\<not> l\<le>h \<or> h\<le>h')"
   by(auto simp: subset_eq intro: order_trans)
 
 lemma not_Ici_eq_empty[simp]: "{l..} \<noteq> {}"
   by(auto simp: set_eq_iff)
 
 lemma not_Iic_eq_empty[simp]: "{..h} \<noteq> {}"
   by(auto simp: set_eq_iff)
 
 lemmas not_empty_eq_Ici_eq_empty[simp] = not_Ici_eq_empty[symmetric]
 lemmas not_empty_eq_Iic_eq_empty[simp] = not_Iic_eq_empty[symmetric]
 
 end
 
 context order
 begin
 
 lemma atLeastatMost_empty[simp]:
   "b < a \<Longrightarrow> {a..b} = {}"
   by(auto simp: atLeastAtMost_def atLeast_def atMost_def)
 
 lemma atLeastLessThan_empty[simp]:
   "b \<le> a \<Longrightarrow> {a..<b} = {}"
   by(auto simp: atLeastLessThan_def)
 
 lemma greaterThanAtMost_empty[simp]: "l \<le> k ==> {k<..l} = {}"
   by(auto simp:greaterThanAtMost_def greaterThan_def atMost_def)
 
 lemma greaterThanLessThan_empty[simp]:"l \<le> k ==> {k<..<l} = {}"
   by(auto simp:greaterThanLessThan_def greaterThan_def lessThan_def)
 
 lemma atLeastAtMost_singleton [simp]: "{a..a} = {a}"
   by (auto simp add: atLeastAtMost_def atMost_def atLeast_def)
 
 lemma atLeastAtMost_singleton': "a = b \<Longrightarrow> {a .. b} = {a}" by simp
 
 lemma Icc_eq_Icc[simp]:
   "{l..h} = {l'..h'} = (l=l' \<and> h=h' \<or> \<not> l\<le>h \<and> \<not> l'\<le>h')"
   by (simp add: order_class.order.eq_iff) (auto intro: order_trans)
 
 lemma (in linorder) Ico_eq_Ico:
   "{l..<h} = {l'..<h'} = (l=l' \<and> h=h' \<or> \<not> l<h \<and> \<not> l'<h')"
   by (metis atLeastLessThan_empty_iff2 nle_le not_less ord.atLeastLessThan_iff)
 
 lemma atLeastAtMost_singleton_iff[simp]:
   "{a .. b} = {c} \<longleftrightarrow> a = b \<and> b = c"
 proof
   assume "{a..b} = {c}"
   hence *: "\<not> (\<not> a \<le> b)" unfolding atLeastatMost_empty_iff[symmetric] by simp
   with \<open>{a..b} = {c}\<close> have "c \<le> a \<and> b \<le> c" by auto
   with * show "a = b \<and> b = c" by auto
 qed simp
 
 end
 
 context no_top
 begin
 
 (* also holds for no_bot but no_top should suffice *)
 lemma not_UNIV_le_Icc[simp]: "\<not> UNIV \<subseteq> {l..h}"
 using gt_ex[of h] by(auto simp: subset_eq less_le_not_le)
 
 lemma not_UNIV_le_Iic[simp]: "\<not> UNIV \<subseteq> {..h}"
 using gt_ex[of h] by(auto simp: subset_eq less_le_not_le)
 
 lemma not_Ici_le_Icc[simp]: "\<not> {l..} \<subseteq> {l'..h'}"
 using gt_ex[of h']
 by(auto simp: subset_eq less_le)(blast dest:antisym_conv intro: order_trans)
 
 lemma not_Ici_le_Iic[simp]: "\<not> {l..} \<subseteq> {..h'}"
 using gt_ex[of h']
 by(auto simp: subset_eq less_le)(blast dest:antisym_conv intro: order_trans)
 
 end
 
 context no_bot
 begin
 
 lemma not_UNIV_le_Ici[simp]: "\<not> UNIV \<subseteq> {l..}"
 using lt_ex[of l] by(auto simp: subset_eq less_le_not_le)
 
 lemma not_Iic_le_Icc[simp]: "\<not> {..h} \<subseteq> {l'..h'}"
 using lt_ex[of l']
 by(auto simp: subset_eq less_le)(blast dest:antisym_conv intro: order_trans)
 
 lemma not_Iic_le_Ici[simp]: "\<not> {..h} \<subseteq> {l'..}"
 using lt_ex[of l']
 by(auto simp: subset_eq less_le)(blast dest:antisym_conv intro: order_trans)
 
 end
 
 
 context no_top
 begin
 
 (* also holds for no_bot but no_top should suffice *)
 lemma not_UNIV_eq_Icc[simp]: "\<not> UNIV = {l'..h'}"
 using gt_ex[of h'] by(auto simp: set_eq_iff  less_le_not_le)
 
 lemmas not_Icc_eq_UNIV[simp] = not_UNIV_eq_Icc[symmetric]
 
 lemma not_UNIV_eq_Iic[simp]: "\<not> UNIV = {..h'}"
 using gt_ex[of h'] by(auto simp: set_eq_iff  less_le_not_le)
 
 lemmas not_Iic_eq_UNIV[simp] = not_UNIV_eq_Iic[symmetric]
 
 lemma not_Icc_eq_Ici[simp]: "\<not> {l..h} = {l'..}"
 unfolding atLeastAtMost_def using not_Ici_le_Iic[of l'] by blast
 
 lemmas not_Ici_eq_Icc[simp] = not_Icc_eq_Ici[symmetric]
 
 (* also holds for no_bot but no_top should suffice *)
 lemma not_Iic_eq_Ici[simp]: "\<not> {..h} = {l'..}"
 using not_Ici_le_Iic[of l' h] by blast
 
 lemmas not_Ici_eq_Iic[simp] = not_Iic_eq_Ici[symmetric]
 
 end
 
 context no_bot
 begin
 
 lemma not_UNIV_eq_Ici[simp]: "\<not> UNIV = {l'..}"
 using lt_ex[of l'] by(auto simp: set_eq_iff  less_le_not_le)
 
 lemmas not_Ici_eq_UNIV[simp] = not_UNIV_eq_Ici[symmetric]
 
 lemma not_Icc_eq_Iic[simp]: "\<not> {l..h} = {..h'}"
 unfolding atLeastAtMost_def using not_Iic_le_Ici[of h'] by blast
 
 lemmas not_Iic_eq_Icc[simp] = not_Icc_eq_Iic[symmetric]
 
 end
 
 
 context dense_linorder
 begin
 
 lemma greaterThanLessThan_empty_iff[simp]:
   "{ a <..< b } = {} \<longleftrightarrow> b \<le> a"
   using dense[of a b] by (cases "a < b") auto
 
 lemma greaterThanLessThan_empty_iff2[simp]:
   "{} = { a <..< b } \<longleftrightarrow> b \<le> a"
   using dense[of a b] by (cases "a < b") auto
 
 lemma atLeastLessThan_subseteq_atLeastAtMost_iff:
   "{a ..< b} \<subseteq> { c .. d } \<longleftrightarrow> (a < b \<longrightarrow> c \<le> a \<and> b \<le> d)"
   using dense[of "max a d" "b"]
   by (force simp: subset_eq Ball_def not_less[symmetric])
 
 lemma greaterThanAtMost_subseteq_atLeastAtMost_iff:
   "{a <.. b} \<subseteq> { c .. d } \<longleftrightarrow> (a < b \<longrightarrow> c \<le> a \<and> b \<le> d)"
   using dense[of "a" "min c b"]
   by (force simp: subset_eq Ball_def not_less[symmetric])
 
 lemma greaterThanLessThan_subseteq_atLeastAtMost_iff:
   "{a <..< b} \<subseteq> { c .. d } \<longleftrightarrow> (a < b \<longrightarrow> c \<le> a \<and> b \<le> d)"
   using dense[of "a" "min c b"] dense[of "max a d" "b"]
   by (force simp: subset_eq Ball_def not_less[symmetric])
 
 lemma greaterThanLessThan_subseteq_greaterThanLessThan:
   "{a <..< b} \<subseteq> {c <..< d} \<longleftrightarrow> (a < b \<longrightarrow> a \<ge> c \<and> b \<le> d)"
   using dense[of "a" "min c b"] dense[of "max a d" "b"]
   by (force simp: subset_eq Ball_def not_less[symmetric])
 
 lemma greaterThanAtMost_subseteq_atLeastLessThan_iff:
   "{a <.. b} \<subseteq> { c ..< d } \<longleftrightarrow> (a < b \<longrightarrow> c \<le> a \<and> b < d)"
   using dense[of "a" "min c b"]
   by (force simp: subset_eq Ball_def not_less[symmetric])
 
 lemma greaterThanLessThan_subseteq_atLeastLessThan_iff:
   "{a <..< b} \<subseteq> { c ..< d } \<longleftrightarrow> (a < b \<longrightarrow> c \<le> a \<and> b \<le> d)"
   using dense[of "a" "min c b"] dense[of "max a d" "b"]
   by (force simp: subset_eq Ball_def not_less[symmetric])
 
 lemma greaterThanLessThan_subseteq_greaterThanAtMost_iff:
   "{a <..< b} \<subseteq> { c <.. d } \<longleftrightarrow> (a < b \<longrightarrow> c \<le> a \<and> b \<le> d)"
   using dense[of "a" "min c b"] dense[of "max a d" "b"]
   by (force simp: subset_eq Ball_def not_less[symmetric])
 
 end
 
 context no_top
 begin
 
 lemma greaterThan_non_empty[simp]: "{x <..} \<noteq> {}"
   using gt_ex[of x] by auto
 
 end
 
 context no_bot
 begin
 
 lemma lessThan_non_empty[simp]: "{..< x} \<noteq> {}"
   using lt_ex[of x] by auto
 
 end
 
 lemma (in linorder) atLeastLessThan_subset_iff:
   "{a..<b} \<subseteq> {c..<d} \<Longrightarrow> b \<le> a \<or> c\<le>a \<and> b\<le>d"
-  apply (auto simp:subset_eq Ball_def not_le)
-  apply(frule_tac x=a in spec)
-  apply(erule_tac x=d in allE)
-  apply auto
-  done
+proof (cases "a < b")
+  case True
+  assume assm: "{a..<b} \<subseteq> {c..<d}"
+  then have 1: "c \<le> a \<and> a \<le> d"
+    using True by (auto simp add: subset_eq Ball_def)
+  then have 2: "b \<le> d"
+    using assm by (auto simp add: subset_eq)
+  from 1 2 show ?thesis
+    by simp
+qed (auto)
 
 lemma atLeastLessThan_inj:
   fixes a b c d :: "'a::linorder"
   assumes eq: "{a ..< b} = {c ..< d}" and "a < b" "c < d"
   shows "a = c" "b = d"
 using assms by (metis atLeastLessThan_subset_iff eq less_le_not_le antisym_conv2 subset_refl)+
 
 lemma atLeastLessThan_eq_iff:
   fixes a b c d :: "'a::linorder"
   assumes "a < b" "c < d"
   shows "{a ..< b} = {c ..< d} \<longleftrightarrow> a = c \<and> b = d"
   using atLeastLessThan_inj assms by auto
 
 lemma (in linorder) Ioc_inj: 
   \<open>{a <.. b} = {c <.. d} \<longleftrightarrow> (b \<le> a \<and> d \<le> c) \<or> a = c \<and> b = d\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof
   assume ?Q
   then show ?P
     by auto
 next
   assume ?P
   then have \<open>a < x \<and> x \<le> b \<longleftrightarrow> c < x \<and> x \<le> d\<close> for x
     by (simp add: set_eq_iff)
   from this [of a] this [of b] this [of c] this [of d] show ?Q
     by auto
 qed
 
 lemma (in order) Iio_Int_singleton: "{..<k} \<inter> {x} = (if x < k then {x} else {})"
   by auto
 
 lemma (in linorder) Ioc_subset_iff: "{a<..b} \<subseteq> {c<..d} \<longleftrightarrow> (b \<le> a \<or> c \<le> a \<and> b \<le> d)"
   by (auto simp: subset_eq Ball_def) (metis less_le not_less)
 
 lemma (in order_bot) atLeast_eq_UNIV_iff: "{x..} = UNIV \<longleftrightarrow> x = bot"
 by (auto simp: set_eq_iff intro: le_bot)
 
 lemma (in order_top) atMost_eq_UNIV_iff: "{..x} = UNIV \<longleftrightarrow> x = top"
 by (auto simp: set_eq_iff intro: top_le)
 
 lemma (in bounded_lattice) atLeastAtMost_eq_UNIV_iff:
   "{x..y} = UNIV \<longleftrightarrow> (x = bot \<and> y = top)"
 by (auto simp: set_eq_iff intro: top_le le_bot)
 
 lemma Iio_eq_empty_iff: "{..< n::'a::{linorder, order_bot}} = {} \<longleftrightarrow> n = bot"
   by (auto simp: set_eq_iff not_less le_bot)
 
 lemma lessThan_empty_iff: "{..< n::nat} = {} \<longleftrightarrow> n = 0"
   by (simp add: Iio_eq_empty_iff bot_nat_def)
 
 lemma mono_image_least:
   assumes f_mono: "mono f" and f_img: "f ` {m ..< n} = {m' ..< n'}" "m < n"
   shows "f m = m'"
 proof -
   from f_img have "{m' ..< n'} \<noteq> {}"
     by (metis atLeastLessThan_empty_iff image_is_empty)
   with f_img have "m' \<in> f ` {m ..< n}" by auto
   then obtain k where "f k = m'" "m \<le> k" by auto
   moreover have "m' \<le> f m" using f_img by auto
   ultimately show "f m = m'"
     using f_mono by (auto elim: monoE[where x=m and y=k])
 qed
 
 
 subsection \<open>Infinite intervals\<close>
 
 context dense_linorder
 begin
 
 lemma infinite_Ioo:
   assumes "a < b"
   shows "\<not> finite {a<..<b}"
 proof
   assume fin: "finite {a<..<b}"
   moreover have ne: "{a<..<b} \<noteq> {}"
     using \<open>a < b\<close> by auto
   ultimately have "a < Max {a <..< b}" "Max {a <..< b} < b"
     using Max_in[of "{a <..< b}"] by auto
   then obtain x where "Max {a <..< b} < x" "x < b"
     using dense[of "Max {a<..<b}" b] by auto
   then have "x \<in> {a <..< b}"
     using \<open>a < Max {a <..< b}\<close> by auto
   then have "x \<le> Max {a <..< b}"
     using fin by auto
   with \<open>Max {a <..< b} < x\<close> show False by auto
 qed
 
 lemma infinite_Icc: "a < b \<Longrightarrow> \<not> finite {a .. b}"
   using greaterThanLessThan_subseteq_atLeastAtMost_iff[of a b a b] infinite_Ioo[of a b]
   by (auto dest: finite_subset)
 
 lemma infinite_Ico: "a < b \<Longrightarrow> \<not> finite {a ..< b}"
   using greaterThanLessThan_subseteq_atLeastLessThan_iff[of a b a b] infinite_Ioo[of a b]
   by (auto dest: finite_subset)
 
 lemma infinite_Ioc: "a < b \<Longrightarrow> \<not> finite {a <.. b}"
   using greaterThanLessThan_subseteq_greaterThanAtMost_iff[of a b a b] infinite_Ioo[of a b]
   by (auto dest: finite_subset)
 
 lemma infinite_Ioo_iff [simp]: "infinite {a<..<b} \<longleftrightarrow> a < b"
   using not_less_iff_gr_or_eq by (fastforce simp: infinite_Ioo)
 
 lemma infinite_Icc_iff [simp]: "infinite {a .. b} \<longleftrightarrow> a < b"
   using not_less_iff_gr_or_eq by (fastforce simp: infinite_Icc)
 
 lemma infinite_Ico_iff [simp]: "infinite {a..<b} \<longleftrightarrow> a < b"
   using not_less_iff_gr_or_eq by (fastforce simp: infinite_Ico)
 
 lemma infinite_Ioc_iff [simp]: "infinite {a<..b} \<longleftrightarrow> a < b"
   using not_less_iff_gr_or_eq by (fastforce simp: infinite_Ioc)
 
 end
 
 lemma infinite_Iio: "\<not> finite {..< a :: 'a :: {no_bot, linorder}}"
 proof
   assume "finite {..< a}"
   then have *: "\<And>x. x < a \<Longrightarrow> Min {..< a} \<le> x"
     by auto
   obtain x where "x < a"
     using lt_ex by auto
 
   obtain y where "y < Min {..< a}"
     using lt_ex by auto
   also have "Min {..< a} \<le> x"
     using \<open>x < a\<close> by fact
   also note \<open>x < a\<close>
   finally have "Min {..< a} \<le> y"
     by fact
   with \<open>y < Min {..< a}\<close> show False by auto
 qed
 
 lemma infinite_Iic: "\<not> finite {.. a :: 'a :: {no_bot, linorder}}"
   using infinite_Iio[of a] finite_subset[of "{..< a}" "{.. a}"]
   by (auto simp: subset_eq less_imp_le)
 
 lemma infinite_Ioi: "\<not> finite {a :: 'a :: {no_top, linorder} <..}"
 proof
   assume "finite {a <..}"
   then have *: "\<And>x. a < x \<Longrightarrow> x \<le> Max {a <..}"
     by auto
 
   obtain y where "Max {a <..} < y"
     using gt_ex by auto
 
   obtain x where x: "a < x"
     using gt_ex by auto
   also from x have "x \<le> Max {a <..}"
     by fact
   also note \<open>Max {a <..} < y\<close>
   finally have "y \<le> Max { a <..}"
     by fact
   with \<open>Max {a <..} < y\<close> show False by auto
 qed
 
 lemma infinite_Ici: "\<not> finite {a :: 'a :: {no_top, linorder} ..}"
   using infinite_Ioi[of a] finite_subset[of "{a <..}" "{a ..}"]
   by (auto simp: subset_eq less_imp_le)
 
 subsubsection \<open>Intersection\<close>
 
 context linorder
 begin
 
 lemma Int_atLeastAtMost[simp]: "{a..b} Int {c..d} = {max a c .. min b d}"
 by auto
 
 lemma Int_atLeastAtMostR1[simp]: "{..b} Int {c..d} = {c .. min b d}"
 by auto
 
 lemma Int_atLeastAtMostR2[simp]: "{a..} Int {c..d} = {max a c .. d}"
 by auto
 
 lemma Int_atLeastAtMostL1[simp]: "{a..b} Int {..d} = {a .. min b d}"
 by auto
 
 lemma Int_atLeastAtMostL2[simp]: "{a..b} Int {c..} = {max a c .. b}"
 by auto
 
 lemma Int_atLeastLessThan[simp]: "{a..<b} Int {c..<d} = {max a c ..< min b d}"
 by auto
 
 lemma Int_greaterThanAtMost[simp]: "{a<..b} Int {c<..d} = {max a c <.. min b d}"
 by auto
 
 lemma Int_greaterThanLessThan[simp]: "{a<..<b} Int {c<..<d} = {max a c <..< min b d}"
 by auto
 
 lemma Int_atMost[simp]: "{..a} \<inter> {..b} = {.. min a b}"
   by (auto simp: min_def)
 
 lemma Ioc_disjoint: "{a<..b} \<inter> {c<..d} = {} \<longleftrightarrow> b \<le> a \<or> d \<le> c \<or> b \<le> c \<or> d \<le> a"
   by auto
 
 end
 
 context complete_lattice
 begin
 
 lemma
   shows Sup_atLeast[simp]: "Sup {x ..} = top"
     and Sup_greaterThanAtLeast[simp]: "x < top \<Longrightarrow> Sup {x <..} = top"
     and Sup_atMost[simp]: "Sup {.. y} = y"
     and Sup_atLeastAtMost[simp]: "x \<le> y \<Longrightarrow> Sup { x .. y} = y"
     and Sup_greaterThanAtMost[simp]: "x < y \<Longrightarrow> Sup { x <.. y} = y"
   by (auto intro!: Sup_eqI)
 
 lemma
   shows Inf_atMost[simp]: "Inf {.. x} = bot"
     and Inf_atMostLessThan[simp]: "top < x \<Longrightarrow> Inf {..< x} = bot"
     and Inf_atLeast[simp]: "Inf {x ..} = x"
     and Inf_atLeastAtMost[simp]: "x \<le> y \<Longrightarrow> Inf { x .. y} = x"
     and Inf_atLeastLessThan[simp]: "x < y \<Longrightarrow> Inf { x ..< y} = x"
   by (auto intro!: Inf_eqI)
 
 end
 
 lemma
   fixes x y :: "'a :: {complete_lattice, dense_linorder}"
   shows Sup_lessThan[simp]: "Sup {..< y} = y"
     and Sup_atLeastLessThan[simp]: "x < y \<Longrightarrow> Sup { x ..< y} = y"
     and Sup_greaterThanLessThan[simp]: "x < y \<Longrightarrow> Sup { x <..< y} = y"
     and Inf_greaterThan[simp]: "Inf {x <..} = x"
     and Inf_greaterThanAtMost[simp]: "x < y \<Longrightarrow> Inf { x <.. y} = x"
     and Inf_greaterThanLessThan[simp]: "x < y \<Longrightarrow> Inf { x <..< y} = x"
   by (auto intro!: Inf_eqI Sup_eqI intro: dense_le dense_le_bounded dense_ge dense_ge_bounded)
 
 subsection \<open>Intervals of natural numbers\<close>
 
 subsubsection \<open>The Constant \<^term>\<open>lessThan\<close>\<close>
 
 lemma lessThan_0 [simp]: "lessThan (0::nat) = {}"
 by (simp add: lessThan_def)
 
 lemma lessThan_Suc: "lessThan (Suc k) = insert k (lessThan k)"
 by (simp add: lessThan_def less_Suc_eq, blast)
 
 text \<open>The following proof is convenient in induction proofs where
 new elements get indices at the beginning. So it is used to transform
 \<^term>\<open>{..<Suc n}\<close> to \<^term>\<open>0::nat\<close> and \<^term>\<open>{..< n}\<close>.\<close>
 
 lemma zero_notin_Suc_image [simp]: "0 \<notin> Suc ` A"
   by auto
 
 lemma lessThan_Suc_eq_insert_0: "{..<Suc n} = insert 0 (Suc ` {..<n})"
   by (auto simp: image_iff less_Suc_eq_0_disj)
 
 lemma lessThan_Suc_atMost: "lessThan (Suc k) = atMost k"
 by (simp add: lessThan_def atMost_def less_Suc_eq_le)
 
 lemma atMost_Suc_eq_insert_0: "{.. Suc n} = insert 0 (Suc ` {.. n})"
   unfolding lessThan_Suc_atMost[symmetric] lessThan_Suc_eq_insert_0[of "Suc n"] ..
 
 lemma UN_lessThan_UNIV: "(\<Union>m::nat. lessThan m) = UNIV"
 by blast
 
 subsubsection \<open>The Constant \<^term>\<open>greaterThan\<close>\<close>
 
 lemma greaterThan_0: "greaterThan 0 = range Suc"
   unfolding greaterThan_def
   by (blast dest: gr0_conv_Suc [THEN iffD1])
 
 lemma greaterThan_Suc: "greaterThan (Suc k) = greaterThan k - {Suc k}"
   unfolding greaterThan_def
   by (auto elim: linorder_neqE)
 
 lemma INT_greaterThan_UNIV: "(\<Inter>m::nat. greaterThan m) = {}"
   by blast
 
 subsubsection \<open>The Constant \<^term>\<open>atLeast\<close>\<close>
 
 lemma atLeast_0 [simp]: "atLeast (0::nat) = UNIV"
 by (unfold atLeast_def UNIV_def, simp)
 
 lemma atLeast_Suc: "atLeast (Suc k) = atLeast k - {k}"
   unfolding atLeast_def by (auto simp: order_le_less Suc_le_eq)
 
 lemma atLeast_Suc_greaterThan: "atLeast (Suc k) = greaterThan k"
   by (auto simp add: greaterThan_def atLeast_def less_Suc_eq_le)
 
 lemma UN_atLeast_UNIV: "(\<Union>m::nat. atLeast m) = UNIV"
   by blast
 
 subsubsection \<open>The Constant \<^term>\<open>atMost\<close>\<close>
 
 lemma atMost_0 [simp]: "atMost (0::nat) = {0}"
   by (simp add: atMost_def)
 
 lemma atMost_Suc: "atMost (Suc k) = insert (Suc k) (atMost k)"
   unfolding atMost_def by (auto simp add: less_Suc_eq order_le_less)
 
 lemma UN_atMost_UNIV: "(\<Union>m::nat. atMost m) = UNIV"
   by blast
 
 subsubsection \<open>The Constant \<^term>\<open>atLeastLessThan\<close>\<close>
 
 text\<open>The orientation of the following 2 rules is tricky. The lhs is
 defined in terms of the rhs.  Hence the chosen orientation makes sense
 in this theory --- the reverse orientation complicates proofs (eg
 nontermination). But outside, when the definition of the lhs is rarely
 used, the opposite orientation seems preferable because it reduces a
 specific concept to a more general one.\<close>
 
 lemma atLeast0LessThan [code_abbrev]: "{0::nat..<n} = {..<n}"
   by(simp add:lessThan_def atLeastLessThan_def)
 
 lemma atLeast0AtMost [code_abbrev]: "{0..n::nat} = {..n}"
   by(simp add:atMost_def atLeastAtMost_def)
 
 lemma lessThan_atLeast0: "{..<n} = {0::nat..<n}"
   by (simp add: atLeast0LessThan)
 
 lemma atMost_atLeast0: "{..n} = {0::nat..n}"
   by (simp add: atLeast0AtMost)
 
 lemma atLeastLessThan0: "{m..<0::nat} = {}"
   by (simp add: atLeastLessThan_def)
 
 lemma atLeast0_lessThan_Suc: "{0..<Suc n} = insert n {0..<n}"
   by (simp add: atLeast0LessThan lessThan_Suc)
 
 lemma atLeast0_lessThan_Suc_eq_insert_0: "{0..<Suc n} = insert 0 (Suc ` {0..<n})"
   by (simp add: atLeast0LessThan lessThan_Suc_eq_insert_0)
 
 
 subsubsection \<open>The Constant \<^term>\<open>atLeastAtMost\<close>\<close>
 
 lemma Icc_eq_insert_lb_nat: "m \<le> n \<Longrightarrow> {m..n} = insert m {Suc m..n}"
 by auto
 
 lemma atLeast0_atMost_Suc:
   "{0..Suc n} = insert (Suc n) {0..n}"
   by (simp add: atLeast0AtMost atMost_Suc)
 
 lemma atLeast0_atMost_Suc_eq_insert_0:
   "{0..Suc n} = insert 0 (Suc ` {0..n})"
   by (simp add: atLeast0AtMost atMost_Suc_eq_insert_0)
 
 
 subsubsection \<open>Intervals of nats with \<^term>\<open>Suc\<close>\<close>
 
 text\<open>Not a simprule because the RHS is too messy.\<close>
 lemma atLeastLessThanSuc:
     "{m..<Suc n} = (if m \<le> n then insert n {m..<n} else {})"
 by (auto simp add: atLeastLessThan_def)
 
 lemma atLeastLessThan_singleton [simp]: "{m..<Suc m} = {m}"
 by (auto simp add: atLeastLessThan_def)
 
 lemma atLeastLessThanSuc_atLeastAtMost: "{l..<Suc u} = {l..u}"
   by (simp add: lessThan_Suc_atMost atLeastAtMost_def atLeastLessThan_def)
 
 lemma atLeastSucAtMost_greaterThanAtMost: "{Suc l..u} = {l<..u}"
   by (simp add: atLeast_Suc_greaterThan atLeastAtMost_def
       greaterThanAtMost_def)
 
 lemma atLeastSucLessThan_greaterThanLessThan: "{Suc l..<u} = {l<..<u}"
   by (simp add: atLeast_Suc_greaterThan atLeastLessThan_def
     greaterThanLessThan_def)
 
 lemma atLeastAtMostSuc_conv: "m \<le> Suc n \<Longrightarrow> {m..Suc n} = insert (Suc n) {m..n}"
   by auto
 
 lemma atLeastAtMost_insertL: "m \<le> n \<Longrightarrow> insert m {Suc m..n} = {m ..n}"
   by auto
 
 text \<open>The analogous result is useful on \<^typ>\<open>int\<close>:\<close>
 (* here, because we don't have an own int section *)
 lemma atLeastAtMostPlus1_int_conv:
   "m \<le> 1+n \<Longrightarrow> {m..1+n} = insert (1+n) {m..n::int}"
   by (auto intro: set_eqI)
 
 lemma atLeastLessThan_add_Un: "i \<le> j \<Longrightarrow> {i..<j+k} = {i..<j} \<union> {j..<j+k::nat}"
   by (induct k) (simp_all add: atLeastLessThanSuc)
 
 
 subsubsection \<open>Intervals and numerals\<close>
 
 lemma lessThan_nat_numeral:  \<comment> \<open>Evaluation for specific numerals\<close>
   "lessThan (numeral k :: nat) = insert (pred_numeral k) (lessThan (pred_numeral k))"
   by (simp add: numeral_eq_Suc lessThan_Suc)
 
 lemma atMost_nat_numeral:  \<comment> \<open>Evaluation for specific numerals\<close>
   "atMost (numeral k :: nat) = insert (numeral k) (atMost (pred_numeral k))"
   by (simp add: numeral_eq_Suc atMost_Suc)
 
 lemma atLeastLessThan_nat_numeral:  \<comment> \<open>Evaluation for specific numerals\<close>
   "atLeastLessThan m (numeral k :: nat) =
      (if m \<le> (pred_numeral k) then insert (pred_numeral k) (atLeastLessThan m (pred_numeral k))
                  else {})"
   by (simp add: numeral_eq_Suc atLeastLessThanSuc)
 
 
 subsubsection \<open>Image\<close>
 
 context linordered_semidom
 begin
 
 lemma image_add_atLeast[simp]: "plus k ` {i..} = {k + i..}"
 proof -
   have "n = k + (n - k)" if "i + k \<le> n" for n
   proof -
     have "n = (n - (k + i)) + (k + i)" using that
       by (metis add_commute le_add_diff_inverse)
     then show "n = k + (n - k)"
       by (metis local.add_diff_cancel_left' add_assoc add_commute)
   qed
   then show ?thesis
     by (fastforce simp: add_le_imp_le_diff add.commute)
 qed
 
 lemma image_add_atLeastAtMost [simp]:
   "plus k ` {i..j} = {i + k..j + k}" (is "?A = ?B")
 proof
   show "?A \<subseteq> ?B"
     by (auto simp add: ac_simps)
 next
   show "?B \<subseteq> ?A"
   proof
     fix n
     assume "n \<in> ?B"
     then have "i \<le> n - k"
       by (simp add: add_le_imp_le_diff)
     have "n = n - k + k"
     proof -
       from \<open>n \<in> ?B\<close> have "n = n - (i + k) + (i + k)"
         by simp
       also have "\<dots> = n - k - i + i + k"
         by (simp add: algebra_simps)
       also have "\<dots> = n - k + k"
         using \<open>i \<le> n - k\<close> by simp
       finally show ?thesis .
     qed
     moreover have "n - k \<in> {i..j}"
       using \<open>n \<in> ?B\<close>
       by (auto simp: add_le_imp_le_diff add_le_add_imp_diff_le)
     ultimately show "n \<in> ?A"
       by (simp add: ac_simps) 
   qed
 qed
 
 lemma image_add_atLeastAtMost' [simp]:
   "(\<lambda>n. n + k) ` {i..j} = {i + k..j + k}"
   by (simp add: add.commute [of _ k])
 
 lemma image_add_atLeastLessThan [simp]:
   "plus k ` {i..<j} = {i + k..<j + k}"
   by (simp add: image_set_diff atLeastLessThan_eq_atLeastAtMost_diff ac_simps)
 
 lemma image_add_atLeastLessThan' [simp]:
   "(\<lambda>n. n + k) ` {i..<j} = {i + k..<j + k}"
   by (simp add: add.commute [of _ k])
 
 lemma image_add_greaterThanAtMost[simp]: "(+) c ` {a<..b} = {c + a<..c + b}"
   by (simp add: image_set_diff greaterThanAtMost_eq_atLeastAtMost_diff ac_simps)
 
 end
 
 context ordered_ab_group_add
 begin
 
 lemma
   fixes x :: 'a
   shows image_uminus_greaterThan[simp]: "uminus ` {x<..} = {..<-x}"
   and image_uminus_atLeast[simp]: "uminus ` {x..} = {..-x}"
 proof safe
   fix y assume "y < -x"
   hence *:  "x < -y" using neg_less_iff_less[of "-y" x] by simp
   have "- (-y) \<in> uminus ` {x<..}"
     by (rule imageI) (simp add: *)
   thus "y \<in> uminus ` {x<..}" by simp
 next
   fix y assume "y \<le> -x"
   have "- (-y) \<in> uminus ` {x..}"
-    by (rule imageI) (insert \<open>y \<le> -x\<close>[THEN le_imp_neg_le], simp)
+    by (rule imageI) (use \<open>y \<le> -x\<close>[THEN le_imp_neg_le] in \<open>simp\<close>)
   thus "y \<in> uminus ` {x..}" by simp
 qed simp_all
 
 lemma
   fixes x :: 'a
   shows image_uminus_lessThan[simp]: "uminus ` {..<x} = {-x<..}"
   and image_uminus_atMost[simp]: "uminus ` {..x} = {-x..}"
 proof -
   have "uminus ` {..<x} = uminus ` uminus ` {-x<..}"
     and "uminus ` {..x} = uminus ` uminus ` {-x..}" by simp_all
   thus "uminus ` {..<x} = {-x<..}" and "uminus ` {..x} = {-x..}"
     by (simp_all add: image_image
         del: image_uminus_greaterThan image_uminus_atLeast)
 qed
 
 lemma
   fixes x :: 'a
   shows image_uminus_atLeastAtMost[simp]: "uminus ` {x..y} = {-y..-x}"
   and image_uminus_greaterThanAtMost[simp]: "uminus ` {x<..y} = {-y..<-x}"
   and image_uminus_atLeastLessThan[simp]: "uminus ` {x..<y} = {-y<..-x}"
   and image_uminus_greaterThanLessThan[simp]: "uminus ` {x<..<y} = {-y<..<-x}"
   by (simp_all add: atLeastAtMost_def greaterThanAtMost_def atLeastLessThan_def
       greaterThanLessThan_def image_Int[OF inj_uminus] Int_commute)
 
 lemma image_add_atMost[simp]: "(+) c ` {..a} = {..c + a}"
   by (auto intro!: image_eqI[where x="x - c" for x] simp: algebra_simps)
 
 end
 
 lemma image_Suc_atLeastAtMost [simp]:
   "Suc ` {i..j} = {Suc i..Suc j}"
   using image_add_atLeastAtMost [of 1 i j]
     by (simp only: plus_1_eq_Suc) simp
 
 lemma image_Suc_atLeastLessThan [simp]:
   "Suc ` {i..<j} = {Suc i..<Suc j}"
   using image_add_atLeastLessThan [of 1 i j]
     by (simp only: plus_1_eq_Suc) simp
 
 corollary image_Suc_atMost:
   "Suc ` {..n} = {1..Suc n}"
   by (simp add: atMost_atLeast0 atLeastLessThanSuc_atLeastAtMost)
 
 corollary image_Suc_lessThan:
   "Suc ` {..<n} = {1..n}"
   by (simp add: lessThan_atLeast0 atLeastLessThanSuc_atLeastAtMost)
 
 lemma image_diff_atLeastAtMost [simp]:
   fixes d::"'a::linordered_idom" shows "((-) d ` {a..b}) = {d-b..d-a}"
-  apply auto
-  apply (rule_tac x="d-x" in rev_image_eqI, auto)
-  done
+proof
+  show "{d - b..d - a} \<subseteq> (-) d ` {a..b}"
+  proof
+    fix x
+    assume "x \<in> {d - b..d - a}"
+    then have "d - x \<in> {a..b}" and "x = d - (d - x)"
+      by auto
+    then show "x \<in> (-) d ` {a..b}"
+      by (rule rev_image_eqI)
+  qed
+qed(auto)
 
 lemma image_diff_atLeastLessThan [simp]:
   fixes a b c::"'a::linordered_idom"
   shows "(-) c ` {a..<b} = {c - b<..c - a}"
 proof -
   have "(-) c ` {a..<b} = (+) c ` uminus ` {a ..<b}"
     unfolding image_image by simp
   also have "\<dots> = {c - b<..c - a}" by simp
   finally show ?thesis by simp
 qed
 
 lemma image_minus_const_greaterThanAtMost[simp]:
   fixes a b c::"'a::linordered_idom"
   shows "(-) c ` {a<..b} = {c - b..<c - a}"
 proof -
   have "(-) c ` {a<..b} = (+) c ` uminus ` {a<..b}"
     unfolding image_image by simp
   also have "\<dots> = {c - b..<c - a}" by simp
   finally show ?thesis by simp
 qed
 
 lemma image_minus_const_atLeast[simp]:
   fixes a c::"'a::linordered_idom"
   shows "(-) c ` {a..} = {..c - a}"
 proof -
   have "(-) c ` {a..} = (+) c ` uminus ` {a ..}"
     unfolding image_image by simp
   also have "\<dots> = {..c - a}" by simp
   finally show ?thesis by simp
 qed
 
 lemma image_minus_const_AtMost[simp]:
   fixes b c::"'a::linordered_idom"
   shows "(-) c ` {..b} = {c - b..}"
 proof -
   have "(-) c ` {..b} = (+) c ` uminus ` {..b}"
     unfolding image_image by simp
   also have "\<dots> = {c - b..}" by simp
   finally show ?thesis by simp
 qed
 
 lemma image_minus_const_atLeastAtMost' [simp]:
   "(\<lambda>t. t-d)`{a..b} = {a-d..b-d}" for d::"'a::linordered_idom"
   by (metis (no_types, lifting) diff_conv_add_uminus image_add_atLeastAtMost' image_cong)
 
 context linordered_field
 begin
 
 lemma image_mult_atLeastAtMost [simp]:
   "((*) d ` {a..b}) = {d*a..d*b}" if "d>0"
   using that
   by (auto simp: field_simps mult_le_cancel_right intro: rev_image_eqI [where x="x/d" for x])
 
 lemma image_divide_atLeastAtMost [simp]:
   "((\<lambda>c. c / d) ` {a..b}) = {a/d..b/d}" if "d>0"
 proof -
   from that have "inverse d > 0"
     by simp
   with image_mult_atLeastAtMost [of "inverse d" a b]
   have "(*) (inverse d) ` {a..b} = {inverse d * a..inverse d * b}"
     by blast
   moreover have "(*) (inverse d) = (\<lambda>c. c / d)"
     by (simp add: fun_eq_iff field_simps)
   ultimately show ?thesis
     by simp
 qed
 
 lemma image_mult_atLeastAtMost_if:
   "(*) c ` {x .. y} =
     (if c > 0 then {c * x .. c * y} else if x \<le> y then {c * y .. c * x} else {})"
 proof (cases "c = 0 \<or> x > y")
   case True
   then show ?thesis
     by auto
 next
   case False
   then have "x \<le> y"
     by auto
   from False consider "c < 0"| "c > 0"
     by (auto simp add: neq_iff)
   then show ?thesis
   proof cases
     case 1
     have "(*) c ` {x..y} = {c * y..c * x}"
     proof (rule set_eqI)
       fix d
       from 1 have "inj (\<lambda>z. z / c)"
         by (auto intro: injI)
       then have "d \<in> (*) c ` {x..y} \<longleftrightarrow> d / c \<in> (\<lambda>z. z div c) ` (*) c ` {x..y}"
         by (subst inj_image_mem_iff) simp_all
       also have "\<dots> \<longleftrightarrow> d / c \<in> {x..y}"
         using 1 by (simp add: image_image)
       also have "\<dots> \<longleftrightarrow> d \<in> {c * y..c * x}"
         by (auto simp add: field_simps 1)
       finally show "d \<in> (*) c ` {x..y} \<longleftrightarrow> d \<in> {c * y..c * x}" .
     qed
     with \<open>x \<le> y\<close> show ?thesis
       by auto
   qed (simp add: mult_left_mono_neg)
 qed
 
 lemma image_mult_atLeastAtMost_if':
   "(\<lambda>x. x * c) ` {x..y} =
     (if x \<le> y then if c > 0 then {x * c .. y * c} else {y * c .. x * c} else {})"
   using image_mult_atLeastAtMost_if [of c x y] by (auto simp add: ac_simps)
 
 lemma image_affinity_atLeastAtMost:
   "((\<lambda>x. m * x + c) ` {a..b}) = (if {a..b} = {} then {}
             else if 0 \<le> m then {m * a + c .. m * b + c}
             else {m * b + c .. m * a + c})"
 proof -
   have *: "(\<lambda>x. m * x + c) = ((\<lambda>x. x + c) \<circ> (*) m)"
     by (simp add: fun_eq_iff)
   show ?thesis by (simp only: * image_comp [symmetric] image_mult_atLeastAtMost_if)
     (auto simp add: mult_le_cancel_left)
 qed
 
 lemma image_affinity_atLeastAtMost_diff:
   "((\<lambda>x. m*x - c) ` {a..b}) = (if {a..b}={} then {}
             else if 0 \<le> m then {m*a - c .. m*b - c}
             else {m*b - c .. m*a - c})"
   using image_affinity_atLeastAtMost [of m "-c" a b]
   by simp
 
 lemma image_affinity_atLeastAtMost_div:
   "((\<lambda>x. x/m + c) ` {a..b}) = (if {a..b}={} then {}
             else if 0 \<le> m then {a/m + c .. b/m + c}
             else {b/m + c .. a/m + c})"
   using image_affinity_atLeastAtMost [of "inverse m" c a b]
   by (simp add: field_class.field_divide_inverse algebra_simps inverse_eq_divide)
 
 lemma image_affinity_atLeastAtMost_div_diff:
   "((\<lambda>x. x/m - c) ` {a..b}) = (if {a..b}={} then {}
             else if 0 \<le> m then {a/m - c .. b/m - c}
             else {b/m - c .. a/m - c})"
   using image_affinity_atLeastAtMost_diff [of "inverse m" c a b]
   by (simp add: field_class.field_divide_inverse algebra_simps inverse_eq_divide)
 
 end
 
 lemma atLeast1_lessThan_eq_remove0:
   "{Suc 0..<n} = {..<n} - {0}"
   by auto
 
 lemma atLeast1_atMost_eq_remove0:
   "{Suc 0..n} = {..n} - {0}"
   by auto
 
 lemma image_add_int_atLeastLessThan:
     "(\<lambda>x. x + (l::int)) ` {0..<u-l} = {l..<u}"
-  apply (auto simp add: image_def)
-  apply (rule_tac x = "x - l" in bexI)
-  apply auto
-  done
+  by safe auto
 
 lemma image_minus_const_atLeastLessThan_nat:
   fixes c :: nat
   shows "(\<lambda>i. i - c) ` {x ..< y} =
       (if c < y then {x - c ..< y - c} else if x < y then {0} else {})"
     (is "_ = ?right")
 proof safe
   fix a assume a: "a \<in> ?right"
   show "a \<in> (\<lambda>i. i - c) ` {x ..< y}"
   proof cases
     assume "c < y" with a show ?thesis
       by (auto intro!: image_eqI[of _ _ "a + c"])
   next
     assume "\<not> c < y" with a show ?thesis
       by (auto intro!: image_eqI[of _ _ x] split: if_split_asm)
   qed
 qed auto
 
 lemma image_int_atLeastLessThan:
   "int ` {a..<b} = {int a..<int b}"
   by (auto intro!: image_eqI [where x = "nat x" for x])
 
 lemma image_int_atLeastAtMost:
   "int ` {a..b} = {int a..int b}"
   by (auto intro!: image_eqI [where x = "nat x" for x])
 
 
 subsubsection \<open>Finiteness\<close>
 
 lemma finite_lessThan [iff]: fixes k :: nat shows "finite {..<k}"
   by (induct k) (simp_all add: lessThan_Suc)
 
 lemma finite_atMost [iff]: fixes k :: nat shows "finite {..k}"
   by (induct k) (simp_all add: atMost_Suc)
 
 lemma finite_greaterThanLessThan [iff]:
   fixes l :: nat shows "finite {l<..<u}"
   by (simp add: greaterThanLessThan_def)
 
 lemma finite_atLeastLessThan [iff]:
   fixes l :: nat shows "finite {l..<u}"
   by (simp add: atLeastLessThan_def)
 
 lemma finite_greaterThanAtMost [iff]:
   fixes l :: nat shows "finite {l<..u}"
   by (simp add: greaterThanAtMost_def)
 
 lemma finite_atLeastAtMost [iff]:
   fixes l :: nat shows "finite {l..u}"
   by (simp add: atLeastAtMost_def)
 
 text \<open>A bounded set of natural numbers is finite.\<close>
 lemma bounded_nat_set_is_finite: "(\<forall>i\<in>N. i < (n::nat)) \<Longrightarrow> finite N"
   by (rule finite_subset [OF _ finite_lessThan]) auto
 
 text \<open>A set of natural numbers is finite iff it is bounded.\<close>
 lemma finite_nat_set_iff_bounded:
   "finite(N::nat set) = (\<exists>m. \<forall>n\<in>N. n<m)" (is "?F = ?B")
 proof
   assume f:?F  show ?B
     using Max_ge[OF \<open>?F\<close>, simplified less_Suc_eq_le[symmetric]] by blast
 next
   assume ?B show ?F using \<open>?B\<close> by(blast intro:bounded_nat_set_is_finite)
 qed
 
 lemma finite_nat_set_iff_bounded_le: "finite(N::nat set) = (\<exists>m. \<forall>n\<in>N. n\<le>m)"
   unfolding finite_nat_set_iff_bounded
   by (blast dest:less_imp_le_nat le_imp_less_Suc)
 
 lemma finite_less_ub:
-     "!!f::nat=>nat. (!!n. n \<le> f n) ==> finite {n. f n \<le> u}"
-by (rule_tac B="{..u}" in finite_subset, auto intro: order_trans)
+     "\<And>f::nat\<Rightarrow>nat. (!!n. n \<le> f n) \<Longrightarrow> finite {n. f n \<le> u}"
+  by (rule finite_subset[of _ "{..u}"])
+    (auto intro: order_trans)
 
 lemma bounded_Max_nat:
   fixes P :: "nat \<Rightarrow> bool"
   assumes x: "P x" and M: "\<And>x. P x \<Longrightarrow> x \<le> M"
   obtains m where "P m" "\<And>x. P x \<Longrightarrow> x \<le> m"
 proof -
   have "finite {x. P x}"
     using M finite_nat_set_iff_bounded_le by auto
   then have "Max {x. P x} \<in> {x. P x}"
     using Max_in x by auto
   then show ?thesis
     by (simp add: \<open>finite {x. P x}\<close> that)
 qed
 
 
 text\<open>Any subset of an interval of natural numbers the size of the
 subset is exactly that interval.\<close>
 
 lemma subset_card_intvl_is_intvl:
   assumes "A \<subseteq> {k..<k + card A}"
   shows "A = {k..<k + card A}"
 proof (cases "finite A")
   case True
   from this and assms show ?thesis
   proof (induct A rule: finite_linorder_max_induct)
     case empty thus ?case by auto
   next
     case (insert b A)
     hence *: "b \<notin> A" by auto
     with insert have "A \<le> {k..<k + card A}" and "b = k + card A"
       by fastforce+
     with insert * show ?case by auto
   qed
 next
   case False
   with assms show ?thesis by simp
 qed
 
 
 subsubsection \<open>Proving Inclusions and Equalities between Unions\<close>
 
 lemma UN_le_eq_Un0:
   "(\<Union>i\<le>n::nat. M i) = (\<Union>i\<in>{1..n}. M i) \<union> M 0" (is "?A = ?B")
 proof
   show "?A \<subseteq> ?B"
   proof
     fix x assume "x \<in> ?A"
     then obtain i where i: "i\<le>n" "x \<in> M i" by auto
     show "x \<in> ?B"
     proof(cases i)
       case 0 with i show ?thesis by simp
     next
       case (Suc j) with i show ?thesis by auto
     qed
   qed
 next
   show "?B \<subseteq> ?A" by fastforce
 qed
 
 lemma UN_le_add_shift:
   "(\<Union>i\<le>n::nat. M(i+k)) = (\<Union>i\<in>{k..n+k}. M i)" (is "?A = ?B")
 proof
   show "?A \<subseteq> ?B" by fastforce
 next
   show "?B \<subseteq> ?A"
   proof
     fix x assume "x \<in> ?B"
     then obtain i where i: "i \<in> {k..n+k}" "x \<in> M(i)" by auto
     hence "i-k\<le>n \<and> x \<in> M((i-k)+k)" by auto
     thus "x \<in> ?A" by blast
   qed
 qed
 
 lemma UN_le_add_shift_strict:
   "(\<Union>i<n::nat. M(i+k)) = (\<Union>i\<in>{k..<n+k}. M i)" (is "?A = ?B")
 proof
   show "?B \<subseteq> ?A"
   proof
     fix x assume "x \<in> ?B"
     then obtain i where i: "i \<in> {k..<n+k}" "x \<in> M(i)" by auto
     then have "i - k < n \<and> x \<in> M((i-k) + k)" by auto
     then show "x \<in> ?A" using UN_le_add_shift by blast
   qed
 qed (fastforce)
 
 lemma UN_UN_finite_eq: "(\<Union>n::nat. \<Union>i\<in>{0..<n}. A i) = (\<Union>n. A n)"
   by (auto simp add: atLeast0LessThan)
 
 lemma UN_finite_subset:
   "(\<And>n::nat. (\<Union>i\<in>{0..<n}. A i) \<subseteq> C) \<Longrightarrow> (\<Union>n. A n) \<subseteq> C"
   by (subst UN_UN_finite_eq [symmetric]) blast
 
 lemma UN_finite2_subset:
   assumes "\<And>n::nat. (\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>i\<in>{0..<n + k}. B i)"
   shows "(\<Union>n. A n) \<subseteq> (\<Union>n. B n)"
-proof (rule UN_finite_subset, rule)
+proof (rule UN_finite_subset, rule subsetI)
   fix n and a
   from assms have "(\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>i\<in>{0..<n + k}. B i)" .
   moreover assume "a \<in> (\<Union>i\<in>{0..<n}. A i)"
   ultimately have "a \<in> (\<Union>i\<in>{0..<n + k}. B i)" by blast
   then show "a \<in> (\<Union>i. B i)" by (auto simp add: UN_UN_finite_eq)
 qed
 
 lemma UN_finite2_eq:
-  "(\<And>n::nat. (\<Union>i\<in>{0..<n}. A i) = (\<Union>i\<in>{0..<n + k}. B i)) \<Longrightarrow>
-    (\<Union>n. A n) = (\<Union>n. B n)"
-  apply (rule subset_antisym [OF UN_finite_subset UN_finite2_subset])
-   apply auto
-  apply (force simp add: atLeastLessThan_add_Un [of 0])+
-  done
+  assumes "(\<And>n::nat. (\<Union>i\<in>{0..<n}. A i) = (\<Union>i\<in>{0..<n + k}. B i))"
+  shows "(\<Union>n. A n) = (\<Union>n. B n)"
+proof (rule subset_antisym [OF UN_finite_subset UN_finite2_subset])
+  fix n
+  show "\<Union> (A ` {0..<n}) \<subseteq> (\<Union>n. B n)"
+    using assms by auto
+next
+  fix n
+  show "\<Union> (B ` {0..<n}) \<subseteq> \<Union> (A ` {0..<n + k})"
+    using assms by (force simp add: atLeastLessThan_add_Un [of 0])+
+qed
 
 
 subsubsection \<open>Cardinality\<close>
 
 lemma card_lessThan [simp]: "card {..<u} = u"
   by (induct u, simp_all add: lessThan_Suc)
 
 lemma card_atMost [simp]: "card {..u} = Suc u"
   by (simp add: lessThan_Suc_atMost [THEN sym])
 
 lemma card_atLeastLessThan [simp]: "card {l..<u} = u - l"
 proof -
-  have "{l..<u} = (\<lambda>x. x + l) ` {..<u-l}"
-    apply (auto simp add: image_def atLeastLessThan_def lessThan_def)
-    apply (rule_tac x = "x - l" in exI)
-    apply arith
-    done
+  have "(\<lambda>x. x + l) ` {..<u - l} \<subseteq> {l..<u}"
+    by auto
+  moreover have "{l..<u} \<subseteq> (\<lambda>x. x + l) ` {..<u-l}"
+  proof
+    fix x
+    assume *: "x \<in> {l..<u}"
+    then have "x - l \<in> {..< u -l}"
+      by auto
+    then have "(x - l) + l \<in> (\<lambda>x. x + l) ` {..< u -l}"
+      by auto
+    then show "x \<in> (\<lambda>x. x + l) ` {..<u - l}"
+      using * by auto
+  qed
+  ultimately have "{l..<u} = (\<lambda>x. x + l) ` {..<u-l}"
+    by auto
   then have "card {l..<u} = card {..<u-l}"
     by (simp add: card_image inj_on_def)
   then show ?thesis
     by simp
 qed
 
 lemma card_atLeastAtMost [simp]: "card {l..u} = Suc u - l"
   by (subst atLeastLessThanSuc_atLeastAtMost [THEN sym], simp)
 
 lemma card_greaterThanAtMost [simp]: "card {l<..u} = u - l"
   by (subst atLeastSucAtMost_greaterThanAtMost [THEN sym], simp)
 
 lemma card_greaterThanLessThan [simp]: "card {l<..<u} = u - Suc l"
   by (subst atLeastSucLessThan_greaterThanLessThan [THEN sym], simp)
 
 lemma subset_eq_atLeast0_lessThan_finite:
   fixes n :: nat
   assumes "N \<subseteq> {0..<n}"
   shows "finite N"
   using assms finite_atLeastLessThan by (rule finite_subset)
 
 lemma subset_eq_atLeast0_atMost_finite:
   fixes n :: nat
   assumes "N \<subseteq> {0..n}"
   shows "finite N"
   using assms finite_atLeastAtMost by (rule finite_subset)
 
 lemma ex_bij_betw_nat_finite:
   "finite M \<Longrightarrow> \<exists>h. bij_betw h {0..<card M} M"
   apply(drule finite_imp_nat_seg_image_inj_on)
   apply(auto simp:atLeast0LessThan[symmetric] lessThan_def[symmetric] card_image bij_betw_def)
   done
 
 lemma ex_bij_betw_finite_nat:
   "finite M \<Longrightarrow> \<exists>h. bij_betw h M {0..<card M}"
   by (blast dest: ex_bij_betw_nat_finite bij_betw_inv)
 
 lemma finite_same_card_bij:
   "finite A \<Longrightarrow> finite B \<Longrightarrow> card A = card B \<Longrightarrow> \<exists>h. bij_betw h A B"
   apply(drule ex_bij_betw_finite_nat)
   apply(drule ex_bij_betw_nat_finite)
   apply(auto intro!:bij_betw_trans)
   done
 
 lemma ex_bij_betw_nat_finite_1:
   "finite M \<Longrightarrow> \<exists>h. bij_betw h {1 .. card M} M"
   by (rule finite_same_card_bij) auto
 
 lemma bij_betw_iff_card:
   assumes "finite A" "finite B"
   shows "(\<exists>f. bij_betw f A B) \<longleftrightarrow> (card A = card B)"
 proof
   assume "card A = card B"
   moreover obtain f where "bij_betw f A {0 ..< card A}"
     using assms ex_bij_betw_finite_nat by blast
   moreover obtain g where "bij_betw g {0 ..< card B} B"
     using assms ex_bij_betw_nat_finite by blast
   ultimately have "bij_betw (g \<circ> f) A B"
     by (auto simp: bij_betw_trans)
   thus "(\<exists>f. bij_betw f A B)" by blast
 qed (auto simp: bij_betw_same_card)
 
 lemma subset_eq_atLeast0_lessThan_card:
   fixes n :: nat
   assumes "N \<subseteq> {0..<n}"
   shows "card N \<le> n"
 proof -
   from assms finite_lessThan have "card N \<le> card {0..<n}"
     using card_mono by blast
   then show ?thesis by simp
 qed
 
 text \<open>Relational version of @{thm [source] card_inj_on_le}:\<close>
 lemma card_le_if_inj_on_rel:
 assumes "finite B"
   "\<And>a. a \<in> A \<Longrightarrow> \<exists>b. b\<in>B \<and> r a b"
   "\<And>a1 a2 b. \<lbrakk> a1 \<in> A;  a2 \<in> A;  b \<in> B;  r a1 b;  r a2 b \<rbrakk> \<Longrightarrow> a1 = a2"
 shows "card A \<le> card B"
 proof -
   let ?P = "\<lambda>a b. b \<in> B \<and> r a b"
   let ?f = "\<lambda>a. SOME b. ?P a b"
   have 1: "?f ` A \<subseteq> B"  by (auto intro: someI2_ex[OF assms(2)])
   have "inj_on ?f A"
-  proof (auto simp: inj_on_def)
+    unfolding inj_on_def
+  proof safe
     fix a1 a2 assume asms: "a1 \<in> A" "a2 \<in> A" "?f a1 = ?f a2"
     have 0: "?f a1 \<in> B" using "1" \<open>a1 \<in> A\<close> by blast
     have 1: "r a1 (?f a1)" using someI_ex[OF assms(2)[OF \<open>a1 \<in> A\<close>]] by blast
     have 2: "r a2 (?f a1)" using someI_ex[OF assms(2)[OF \<open>a2 \<in> A\<close>]] asms(3) by auto
     show "a1 = a2" using assms(3)[OF asms(1,2) 0 1 2] .
   qed
   with 1 show ?thesis using card_inj_on_le[of ?f A B] assms(1) by simp
 qed
 
 lemma inj_on_funpow_least: \<^marker>\<open>contributor \<open>Lars Noschinski\<close>\<close>
   \<open>inj_on (\<lambda>k. (f ^^ k) s) {0..<n}\<close>
   if \<open>(f ^^ n) s = s\<close> \<open>\<And>m. 0 < m \<Longrightarrow> m < n \<Longrightarrow> (f ^^ m) s \<noteq> s\<close>
 proof -
   { fix k l assume A: "k < n" "l < n" "k \<noteq> l" "(f ^^ k) s = (f ^^ l) s"
     define k' l' where "k' = min k l" and "l' = max k l"
     with A have A': "k' < l'" "(f ^^ k') s = (f ^^ l') s" "l' < n"
       by (auto simp: min_def max_def)
 
     have "s = (f ^^ ((n - l') + l')) s" using that \<open>l' < n\<close> by simp
     also have "\<dots> = (f ^^ (n - l')) ((f ^^ l') s)" by (simp add: funpow_add)
     also have "(f ^^ l') s = (f ^^ k') s" by (simp add: A')
     also have "(f ^^ (n - l')) \<dots> = (f ^^ (n - l' + k')) s" by (simp add: funpow_add)
     finally have "(f ^^ (n - l' + k')) s = s" by simp
     moreover have "n - l' + k' < n" "0 < n - l' + k'"using A' by linarith+
     ultimately have False using that(2) by auto
   }
   then show ?thesis by (intro inj_onI) auto
 qed
 
 
 subsection \<open>Intervals of integers\<close>
 
 lemma atLeastLessThanPlusOne_atLeastAtMost_int: "{l..<u+1} = {l..(u::int)}"
   by (auto simp add: atLeastAtMost_def atLeastLessThan_def)
 
 lemma atLeastPlusOneAtMost_greaterThanAtMost_int: "{l+1..u} = {l<..(u::int)}"
   by (auto simp add: atLeastAtMost_def greaterThanAtMost_def)
 
 lemma atLeastPlusOneLessThan_greaterThanLessThan_int:
     "{l+1..<u} = {l<..<u::int}"
   by (auto simp add: atLeastLessThan_def greaterThanLessThan_def)
 
 subsubsection \<open>Finiteness\<close>
 
-lemma image_atLeastZeroLessThan_int: "0 \<le> u ==>
-    {(0::int)..<u} = int ` {..<nat u}"
+lemma image_atLeastZeroLessThan_int:
+  assumes "0 \<le> u"
+  shows "{(0::int)..<u} = int ` {..<nat u}"
   unfolding image_def lessThan_def
-  apply auto
-  apply (rule_tac x = "nat x" in exI)
-  apply (auto simp add: zless_nat_eq_int_zless [THEN sym])
-  done
+proof
+  show "{0..<u} \<subseteq> {y. \<exists>x\<in>{x. x < nat u}. y = int x}"
+  proof
+    fix x
+    assume "x \<in> {0..<u}"
+    then have "x = int (nat x)" and  "nat x < nat u"
+      by (auto simp add: zless_nat_eq_int_zless [THEN sym])
+    then have "\<exists>xa<nat u. x = int xa"
+      using exI[of _ "(nat x)"] by simp
+    then show "x \<in> {y. \<exists>x\<in>{x. x < nat u}. y = int x}"
+      by simp
+  qed
+qed (auto)
+
 
 lemma finite_atLeastZeroLessThan_int: "finite {(0::int)..<u}"
 proof (cases "0 \<le> u")
   case True
   then show ?thesis
     by (auto simp: image_atLeastZeroLessThan_int)
 qed auto
 
 lemma finite_atLeastLessThan_int [iff]: "finite {l..<u::int}"
   by (simp only: image_add_int_atLeastLessThan [symmetric, of l] finite_imageI finite_atLeastZeroLessThan_int)
 
 lemma finite_atLeastAtMost_int [iff]: "finite {l..(u::int)}"
   by (subst atLeastLessThanPlusOne_atLeastAtMost_int [THEN sym], simp)
 
 lemma finite_greaterThanAtMost_int [iff]: "finite {l<..(u::int)}"
   by (subst atLeastPlusOneAtMost_greaterThanAtMost_int [THEN sym], simp)
 
 lemma finite_greaterThanLessThan_int [iff]: "finite {l<..<u::int}"
   by (subst atLeastPlusOneLessThan_greaterThanLessThan_int [THEN sym], simp)
 
 
 subsubsection \<open>Cardinality\<close>
 
 lemma card_atLeastZeroLessThan_int: "card {(0::int)..<u} = nat u"
 proof (cases "0 \<le> u")
   case True
   then show ?thesis
     by (auto simp: image_atLeastZeroLessThan_int card_image inj_on_def)    
 qed auto
 
 lemma card_atLeastLessThan_int [simp]: "card {l..<u} = nat (u - l)"
 proof -
   have "card {l..<u} = card {0..<u-l}"
     apply (subst image_add_int_atLeastLessThan [symmetric])
     apply (rule card_image)
     apply (simp add: inj_on_def)
     done
   then show ?thesis
     by (simp add: card_atLeastZeroLessThan_int)
 qed
 
 lemma card_atLeastAtMost_int [simp]: "card {l..u} = nat (u - l + 1)"
   apply (subst atLeastLessThanPlusOne_atLeastAtMost_int [THEN sym])
   apply (auto simp add: algebra_simps)
   done
 
 lemma card_greaterThanAtMost_int [simp]: "card {l<..u} = nat (u - l)"
   by (subst atLeastPlusOneAtMost_greaterThanAtMost_int [THEN sym], simp)
 
 lemma card_greaterThanLessThan_int [simp]: "card {l<..<u} = nat (u - (l + 1))"
   by (subst atLeastPlusOneLessThan_greaterThanLessThan_int [THEN sym], simp)
 
 lemma finite_M_bounded_by_nat: "finite {k. P k \<and> k < (i::nat)}"
 proof -
   have "{k. P k \<and> k < i} \<subseteq> {..<i}" by auto
   with finite_lessThan[of "i"] show ?thesis by (simp add: finite_subset)
 qed
 
 lemma card_less:
   assumes zero_in_M: "0 \<in> M"
   shows "card {k \<in> M. k < Suc i} \<noteq> 0"
 proof -
   from zero_in_M have "{k \<in> M. k < Suc i} \<noteq> {}" by auto
   with finite_M_bounded_by_nat show ?thesis by (auto simp add: card_eq_0_iff)
 qed
 
 lemma card_less_Suc2: 
   assumes "0 \<notin> M" shows "card {k. Suc k \<in> M \<and> k < i} = card {k \<in> M. k < Suc i}"
 proof -
   have *: "\<lbrakk>j \<in> M; j < Suc i\<rbrakk> \<Longrightarrow> j - Suc 0 < i \<and> Suc (j - Suc 0) \<in> M \<and> Suc 0 \<le> j" for j
     by (cases j) (use assms in auto)
   show ?thesis
   proof (rule card_bij_eq)
     show "inj_on Suc {k. Suc k \<in> M \<and> k < i}"
       by force
     show "inj_on (\<lambda>x. x - Suc 0) {k \<in> M. k < Suc i}"
       by (rule inj_on_diff_nat) (use * in blast)
   qed (use * in auto)
 qed
 
 lemma card_less_Suc:
   assumes "0 \<in> M"
     shows "Suc (card {k. Suc k \<in> M \<and> k < i}) = card {k \<in> M. k < Suc i}"
 proof -
   have "Suc (card {k. Suc k \<in> M \<and> k < i}) = Suc (card {k. Suc k \<in> M - {0} \<and> k < i})"
     by simp
   also have "\<dots> = Suc (card {k \<in> M - {0}. k < Suc i})"
     apply (subst card_less_Suc2)
     using assms by auto
   also have "\<dots> = Suc (card ({k \<in> M. k < Suc i} - {0}))"
     by (force intro: arg_cong [where f=card])
   also have "\<dots> = card (insert 0 ({k \<in> M. k < Suc i} - {0}))"
     by (simp add: card.insert_remove)
   also have "... = card {k \<in> M. k < Suc i}"
     using assms
     by (force simp add: intro: arg_cong [where f=card])
   finally show ?thesis.
 qed
 
 lemma card_le_Suc_Max: "finite S \<Longrightarrow> card S \<le> Suc (Max S)"
 proof (rule classical)
   assume "finite S" and "\<not> Suc (Max S) \<ge> card S"
   then have "Suc (Max S) < card S"
     by simp
   with \<open>finite S\<close> have "S \<subseteq> {0..Max S}"
     by auto
   hence "card S \<le> card {0..Max S}"
     by (intro card_mono; auto)
   thus "card S \<le> Suc (Max S)"
     by simp
 qed
 
 subsection \<open>Lemmas useful with the summation operator sum\<close>
 
 text \<open>For examples, see Algebra/poly/UnivPoly2.thy\<close>
 
 subsubsection \<open>Disjoint Unions\<close>
 
 text \<open>Singletons and open intervals\<close>
 
 lemma ivl_disj_un_singleton:
   "{l::'a::linorder} Un {l<..} = {l..}"
   "{..<u} Un {u::'a::linorder} = {..u}"
   "(l::'a::linorder) < u ==> {l} Un {l<..<u} = {l..<u}"
   "(l::'a::linorder) < u ==> {l<..<u} Un {u} = {l<..u}"
   "(l::'a::linorder) \<le> u ==> {l} Un {l<..u} = {l..u}"
   "(l::'a::linorder) \<le> u ==> {l..<u} Un {u} = {l..u}"
 by auto
 
 text \<open>One- and two-sided intervals\<close>
 
 lemma ivl_disj_un_one:
   "(l::'a::linorder) < u ==> {..l} Un {l<..<u} = {..<u}"
   "(l::'a::linorder) \<le> u ==> {..<l} Un {l..<u} = {..<u}"
   "(l::'a::linorder) \<le> u ==> {..l} Un {l<..u} = {..u}"
   "(l::'a::linorder) \<le> u ==> {..<l} Un {l..u} = {..u}"
   "(l::'a::linorder) \<le> u ==> {l<..u} Un {u<..} = {l<..}"
   "(l::'a::linorder) < u ==> {l<..<u} Un {u..} = {l<..}"
   "(l::'a::linorder) \<le> u ==> {l..u} Un {u<..} = {l..}"
   "(l::'a::linorder) \<le> u ==> {l..<u} Un {u..} = {l..}"
 by auto
 
 text \<open>Two- and two-sided intervals\<close>
 
 lemma ivl_disj_un_two:
   "[| (l::'a::linorder) < m; m \<le> u |] ==> {l<..<m} Un {m..<u} = {l<..<u}"
   "[| (l::'a::linorder) \<le> m; m < u |] ==> {l<..m} Un {m<..<u} = {l<..<u}"
   "[| (l::'a::linorder) \<le> m; m \<le> u |] ==> {l..<m} Un {m..<u} = {l..<u}"
   "[| (l::'a::linorder) \<le> m; m < u |] ==> {l..m} Un {m<..<u} = {l..<u}"
   "[| (l::'a::linorder) < m; m \<le> u |] ==> {l<..<m} Un {m..u} = {l<..u}"
   "[| (l::'a::linorder) \<le> m; m \<le> u |] ==> {l<..m} Un {m<..u} = {l<..u}"
   "[| (l::'a::linorder) \<le> m; m \<le> u |] ==> {l..<m} Un {m..u} = {l..u}"
   "[| (l::'a::linorder) \<le> m; m \<le> u |] ==> {l..m} Un {m<..u} = {l..u}"
 by auto
 
 lemma ivl_disj_un_two_touch:
   "[| (l::'a::linorder) < m; m < u |] ==> {l<..m} Un {m..<u} = {l<..<u}"
   "[| (l::'a::linorder) \<le> m; m < u |] ==> {l..m} Un {m..<u} = {l..<u}"
   "[| (l::'a::linorder) < m; m \<le> u |] ==> {l<..m} Un {m..u} = {l<..u}"
   "[| (l::'a::linorder) \<le> m; m \<le> u |] ==> {l..m} Un {m..u} = {l..u}"
 by auto
 
 lemmas ivl_disj_un = ivl_disj_un_singleton ivl_disj_un_one ivl_disj_un_two ivl_disj_un_two_touch
 
 subsubsection \<open>Disjoint Intersections\<close>
 
 text \<open>One- and two-sided intervals\<close>
 
 lemma ivl_disj_int_one:
   "{..l::'a::order} Int {l<..<u} = {}"
   "{..<l} Int {l..<u} = {}"
   "{..l} Int {l<..u} = {}"
   "{..<l} Int {l..u} = {}"
   "{l<..u} Int {u<..} = {}"
   "{l<..<u} Int {u..} = {}"
   "{l..u} Int {u<..} = {}"
   "{l..<u} Int {u..} = {}"
   by auto
 
 text \<open>Two- and two-sided intervals\<close>
 
 lemma ivl_disj_int_two:
   "{l::'a::order<..<m} Int {m..<u} = {}"
   "{l<..m} Int {m<..<u} = {}"
   "{l..<m} Int {m..<u} = {}"
   "{l..m} Int {m<..<u} = {}"
   "{l<..<m} Int {m..u} = {}"
   "{l<..m} Int {m<..u} = {}"
   "{l..<m} Int {m..u} = {}"
   "{l..m} Int {m<..u} = {}"
   by auto
 
 lemmas ivl_disj_int = ivl_disj_int_one ivl_disj_int_two
 
 subsubsection \<open>Some Differences\<close>
 
 lemma ivl_diff[simp]:
  "i \<le> n \<Longrightarrow> {i..<m} - {i..<n} = {n..<(m::'a::linorder)}"
 by(auto)
 
 lemma (in linorder) lessThan_minus_lessThan [simp]:
   "{..< n} - {..< m} = {m ..< n}"
   by auto
 
 lemma (in linorder) atLeastAtMost_diff_ends:
   "{a..b} - {a, b} = {a<..<b}"
   by auto
 
 
 subsubsection \<open>Some Subset Conditions\<close>
 
 lemma ivl_subset [simp]: "({i..<j} \<subseteq> {m..<n}) = (j \<le> i \<or> m \<le> i \<and> j \<le> (n::'a::linorder))"
   using linorder_class.le_less_linear[of i n]
-  apply (auto simp: linorder_not_le)
-   apply (force intro: leI)+
-  done
+  by safe (force intro: leI)+
 
 
 subsection \<open>Generic big monoid operation over intervals\<close>
 
 context semiring_char_0
 begin
 
 lemma inj_on_of_nat [simp]:
   "inj_on of_nat N"
-  by rule simp
+  by (rule inj_onI) simp
 
 lemma bij_betw_of_nat [simp]:
   "bij_betw of_nat N A \<longleftrightarrow> of_nat ` N = A"
   by (simp add: bij_betw_def)
 
 lemma Nats_infinite: "infinite (\<nat> :: 'a set)"
   by (metis Nats_def finite_imageD infinite_UNIV_char_0 inj_on_of_nat)
 
 end
 
 context comm_monoid_set
 begin
 
 lemma atLeastLessThan_reindex:
   "F g {h m..<h n} = F (g \<circ> h) {m..<n}"
   if "bij_betw h {m..<n} {h m..<h n}" for m n ::nat
 proof -
   from that have "inj_on h {m..<n}" and "h ` {m..<n} = {h m..<h n}"
     by (simp_all add: bij_betw_def)
   then show ?thesis
     using reindex [of h "{m..<n}" g] by simp
 qed
 
 lemma atLeastAtMost_reindex:
   "F g {h m..h n} = F (g \<circ> h) {m..n}"
   if "bij_betw h {m..n} {h m..h n}" for m n ::nat
 proof -
   from that have "inj_on h {m..n}" and "h ` {m..n} = {h m..h n}"
     by (simp_all add: bij_betw_def)
   then show ?thesis
     using reindex [of h "{m..n}" g] by simp
 qed
 
 lemma atLeastLessThan_shift_bounds:
   "F g {m + k..<n + k} = F (g \<circ> plus k) {m..<n}"
   for m n k :: nat
   using atLeastLessThan_reindex [of "plus k" m n g]
   by (simp add: ac_simps)
 
 lemma atLeastAtMost_shift_bounds:
   "F g {m + k..n + k} = F (g \<circ> plus k) {m..n}"
   for m n k :: nat
   using atLeastAtMost_reindex [of "plus k" m n g]
   by (simp add: ac_simps)
 
 lemma atLeast_Suc_lessThan_Suc_shift:
   "F g {Suc m..<Suc n} = F (g \<circ> Suc) {m..<n}"
   using atLeastLessThan_shift_bounds [of _ _ 1]
   by (simp add: plus_1_eq_Suc)
 
 lemma atLeast_Suc_atMost_Suc_shift:
   "F g {Suc m..Suc n} = F (g \<circ> Suc) {m..n}"
   using atLeastAtMost_shift_bounds [of _ _ 1]
   by (simp add: plus_1_eq_Suc)
 
 lemma atLeast_atMost_pred_shift:
   "F (g \<circ> (\<lambda>n. n - Suc 0)) {Suc m..Suc n} = F g {m..n}"
   unfolding atLeast_Suc_atMost_Suc_shift by simp
 
 lemma atLeast_lessThan_pred_shift:
   "F (g \<circ> (\<lambda>n. n - Suc 0)) {Suc m..<Suc n} = F g {m..<n}"
   unfolding atLeast_Suc_lessThan_Suc_shift by simp
 
 lemma atLeast_int_lessThan_int_shift:
   "F g {int m..<int n} = F (g \<circ> int) {m..<n}"
   by (rule atLeastLessThan_reindex)
     (simp add: image_int_atLeastLessThan)
 
 lemma atLeast_int_atMost_int_shift:
   "F g {int m..int n} = F (g \<circ> int) {m..n}"
   by (rule atLeastAtMost_reindex)
     (simp add: image_int_atLeastAtMost)
 
 lemma atLeast0_lessThan_Suc:
   "F g {0..<Suc n} = F g {0..<n} \<^bold>* g n"
   by (simp add: atLeast0_lessThan_Suc ac_simps)
 
 lemma atLeast0_atMost_Suc:
   "F g {0..Suc n} = F g {0..n} \<^bold>* g (Suc n)"
   by (simp add: atLeast0_atMost_Suc ac_simps)
 
 lemma atLeast0_lessThan_Suc_shift:
   "F g {0..<Suc n} = g 0 \<^bold>* F (g \<circ> Suc) {0..<n}"
   by (simp add: atLeast0_lessThan_Suc_eq_insert_0 atLeast_Suc_lessThan_Suc_shift)
 
 lemma atLeast0_atMost_Suc_shift:
   "F g {0..Suc n} = g 0 \<^bold>* F (g \<circ> Suc) {0..n}"
   by (simp add: atLeast0_atMost_Suc_eq_insert_0 atLeast_Suc_atMost_Suc_shift)
 
 lemma atLeast_Suc_lessThan:
   "F g {m..<n} = g m \<^bold>* F g {Suc m..<n}" if "m < n"
 proof -
   from that have "{m..<n} = insert m {Suc m..<n}"
     by auto
   then show ?thesis by simp
 qed
 
 lemma atLeast_Suc_atMost:
   "F g {m..n} = g m \<^bold>* F g {Suc m..n}" if "m \<le> n"
 proof -
   from that have "{m..n} = insert m {Suc m..n}"
     by auto
   then show ?thesis by simp
 qed
 
 lemma ivl_cong:
   "a = c \<Longrightarrow> b = d \<Longrightarrow> (\<And>x. c \<le> x \<Longrightarrow> x < d \<Longrightarrow> g x = h x)
     \<Longrightarrow> F g {a..<b} = F h {c..<d}"
   by (rule cong) simp_all
 
 lemma atLeastLessThan_shift_0:
   fixes m n p :: nat
   shows "F g {m..<n} = F (g \<circ> plus m) {0..<n - m}"
   using atLeastLessThan_shift_bounds [of g 0 m "n - m"]
   by (cases "m \<le> n") simp_all
 
 lemma atLeastAtMost_shift_0:
   fixes m n p :: nat
   assumes "m \<le> n"
   shows "F g {m..n} = F (g \<circ> plus m) {0..n - m}"
   using assms atLeastAtMost_shift_bounds [of g 0 m "n - m"] by simp
 
 lemma atLeastLessThan_concat:
   fixes m n p :: nat
   shows "m \<le> n \<Longrightarrow> n \<le> p \<Longrightarrow> F g {m..<n} \<^bold>* F g {n..<p} = F g {m..<p}"
   by (simp add: union_disjoint [symmetric] ivl_disj_un)
 
 lemma atLeastLessThan_rev:
   "F g {n..<m} = F (\<lambda>i. g (m + n - Suc i)) {n..<m}"
   by (rule reindex_bij_witness [where i="\<lambda>i. m + n - Suc i" and j="\<lambda>i. m + n - Suc i"], auto)
 
 lemma atLeastAtMost_rev:
   fixes n m :: nat
   shows "F g {n..m} = F (\<lambda>i. g (m + n - i)) {n..m}"
   by (rule reindex_bij_witness [where i="\<lambda>i. m + n - i" and j="\<lambda>i. m + n - i"]) auto
 
 lemma atLeastLessThan_rev_at_least_Suc_atMost:
   "F g {n..<m} = F (\<lambda>i. g (m + n - i)) {Suc n..m}"
   unfolding atLeastLessThan_rev [of g n m]
   by (cases m) (simp_all add: atLeast_Suc_atMost_Suc_shift atLeastLessThanSuc_atLeastAtMost)
 
 end
 
 
 subsection \<open>Summation indexed over intervals\<close>
 
 syntax (ASCII)
   "_from_to_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(SUM _ = _.._./ _)" [0,0,0,10] 10)
   "_from_upto_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(SUM _ = _..<_./ _)" [0,0,0,10] 10)
   "_upt_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(SUM _<_./ _)" [0,0,10] 10)
   "_upto_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(SUM _<=_./ _)" [0,0,10] 10)
 
 syntax (latex_sum output)
   "_from_to_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\sum_{\<close>_ = _\<^latex>\<open>}^{\<close>_\<^latex>\<open>}$\<close> _)" [0,0,0,10] 10)
   "_from_upto_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\sum_{\<close>_ = _\<^latex>\<open>}^{<\<close>_\<^latex>\<open>}$\<close> _)" [0,0,0,10] 10)
   "_upt_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\sum_{\<close>_ < _\<^latex>\<open>}$\<close> _)" [0,0,10] 10)
   "_upto_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\sum_{\<close>_ \<le> _\<^latex>\<open>}$\<close> _)" [0,0,10] 10)
 
 syntax
   "_from_to_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sum>_ = _.._./ _)" [0,0,0,10] 10)
   "_from_upto_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sum>_ = _..<_./ _)" [0,0,0,10] 10)
   "_upt_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sum>_<_./ _)" [0,0,10] 10)
   "_upto_sum" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sum>_\<le>_./ _)" [0,0,10] 10)
 
 translations
   "\<Sum>x=a..b. t" == "CONST sum (\<lambda>x. t) {a..b}"
   "\<Sum>x=a..<b. t" == "CONST sum (\<lambda>x. t) {a..<b}"
   "\<Sum>i\<le>n. t" == "CONST sum (\<lambda>i. t) {..n}"
   "\<Sum>i<n. t" == "CONST sum (\<lambda>i. t) {..<n}"
 
 text\<open>The above introduces some pretty alternative syntaxes for
 summation over intervals:
 \begin{center}
 \begin{tabular}{lll}
 Old & New & \LaTeX\\
 @{term[source]"\<Sum>x\<in>{a..b}. e"} & \<^term>\<open>\<Sum>x=a..b. e\<close> & @{term[mode=latex_sum]"\<Sum>x=a..b. e"}\\
 @{term[source]"\<Sum>x\<in>{a..<b}. e"} & \<^term>\<open>\<Sum>x=a..<b. e\<close> & @{term[mode=latex_sum]"\<Sum>x=a..<b. e"}\\
 @{term[source]"\<Sum>x\<in>{..b}. e"} & \<^term>\<open>\<Sum>x\<le>b. e\<close> & @{term[mode=latex_sum]"\<Sum>x\<le>b. e"}\\
 @{term[source]"\<Sum>x\<in>{..<b}. e"} & \<^term>\<open>\<Sum>x<b. e\<close> & @{term[mode=latex_sum]"\<Sum>x<b. e"}
 \end{tabular}
 \end{center}
 The left column shows the term before introduction of the new syntax,
 the middle column shows the new (default) syntax, and the right column
 shows a special syntax. The latter is only meaningful for latex output
 and has to be activated explicitly by setting the print mode to
 \<open>latex_sum\<close> (e.g.\ via \<open>mode = latex_sum\<close> in
 antiquotations). It is not the default \LaTeX\ output because it only
 works well with italic-style formulae, not tt-style.
 
 Note that for uniformity on \<^typ>\<open>nat\<close> it is better to use
 \<^term>\<open>\<Sum>x::nat=0..<n. e\<close> rather than \<open>\<Sum>x<n. e\<close>: \<open>sum\<close> may
 not provide all lemmas available for \<^term>\<open>{m..<n}\<close> also in the
 special form for \<^term>\<open>{..<n}\<close>.\<close>
 
 text\<open>This congruence rule should be used for sums over intervals as
 the standard theorem @{text[source]sum.cong} does not work well
 with the simplifier who adds the unsimplified premise \<^term>\<open>x\<in>B\<close> to
 the context.\<close>
 
 context comm_monoid_set
 begin
 
 lemma zero_middle:
   assumes "1 \<le> p" "k \<le> p"
   shows "F (\<lambda>j. if j < k then g j else if j = k then \<^bold>1 else h (j - Suc 0)) {..p}
        = F (\<lambda>j. if j < k then g j else h j) {..p - Suc 0}"  (is "?lhs = ?rhs")
 proof -
   have [simp]: "{..p - Suc 0} \<inter> {j. j < k} = {..<k}" "{..p - Suc 0} \<inter> - {j. j < k} = {k..p - Suc 0}"
     using assms by auto
   have "?lhs = F g {..<k} \<^bold>* F (\<lambda>j. if j = k then \<^bold>1 else h (j - Suc 0)) {k..p}"
     using union_disjoint [of "{..<k}" "{k..p}"] assms
     by (simp add: ivl_disj_int_one ivl_disj_un_one)
   also have "\<dots> = F g {..<k} \<^bold>* F (\<lambda>j.  h (j - Suc 0)) {Suc k..p}"
     by (simp add: atLeast_Suc_atMost [of k p] assms)
   also have "\<dots> = F g {..<k} \<^bold>* F h {k .. p - Suc 0}"
     using reindex [of Suc "{k..p - Suc 0}"] assms by simp
   also have "\<dots> = ?rhs"
     by (simp add: If_cases)
   finally show ?thesis .
 qed
 
 lemma atMost_Suc [simp]:
   "F g {..Suc n} = F g {..n} \<^bold>* g (Suc n)"
   by (simp add: atMost_Suc ac_simps)
 
 lemma lessThan_Suc [simp]:
   "F g {..<Suc n} = F g {..<n} \<^bold>* g n"
   by (simp add: lessThan_Suc ac_simps)
 
 lemma cl_ivl_Suc [simp]:
   "F g {m..Suc n} = (if Suc n < m then \<^bold>1 else F g {m..n} \<^bold>* g(Suc n))"
   by (auto simp: ac_simps atLeastAtMostSuc_conv)
 
 lemma op_ivl_Suc [simp]:
   "F g {m..<Suc n} = (if n < m then \<^bold>1 else F g {m..<n} \<^bold>* g(n))"
   by (auto simp: ac_simps atLeastLessThanSuc)
 
 lemma head:
   fixes n :: nat
   assumes mn: "m \<le> n"
   shows "F g {m..n} = g m \<^bold>* F g {m<..n}" (is "?lhs = ?rhs")
 proof -
   from mn
   have "{m..n} = {m} \<union> {m<..n}"
     by (auto intro: ivl_disj_un_singleton)
   hence "?lhs = F g ({m} \<union> {m<..n})"
     by (simp add: atLeast0LessThan)
   also have "\<dots> = ?rhs" by simp
   finally show ?thesis .
 qed
 
 lemma last_plus: 
   fixes n::nat  shows "m \<le> n \<Longrightarrow> F g {m..n} = g n \<^bold>* F g {m..<n}"
   by (cases n) (auto simp: atLeastLessThanSuc_atLeastAtMost commute)
 
 lemma head_if:
   fixes n :: nat
   shows "F g {m..n} = (if n < m then \<^bold>1 else  F g {m..<n} \<^bold>* g(n))"
   by (simp add: commute last_plus)
 
 lemma ub_add_nat: 
   assumes "(m::nat) \<le> n + 1"
   shows "F g {m..n + p} = F g {m..n} \<^bold>* F g {n + 1..n + p}"
 proof-
   have "{m .. n+p} = {m..n} \<union> {n+1..n+p}" using \<open>m \<le> n+1\<close> by auto
   thus ?thesis by (auto simp: ivl_disj_int union_disjoint atLeastSucAtMost_greaterThanAtMost)
 qed
 
 lemma nat_group: 
   fixes k::nat shows "F (\<lambda>m. F g {m * k ..< m*k + k}) {..<n} = F g {..< n * k}"
 proof (cases k)
   case (Suc l)
   then have "k > 0"
     by auto
   then show ?thesis
     by (induct n) (simp_all add: atLeastLessThan_concat add.commute atLeast0LessThan[symmetric])
 qed auto   
 
 lemma triangle_reindex:
   fixes n :: nat
   shows "F (\<lambda>(i,j). g i j) {(i,j). i+j < n} = F (\<lambda>k. F (\<lambda>i. g i (k - i)) {..k}) {..<n}"
   apply (simp add: Sigma)
   apply (rule reindex_bij_witness[where j="\<lambda>(i, j). (i+j, i)" and i="\<lambda>(k, i). (i, k - i)"])
   apply auto
   done
 
 lemma triangle_reindex_eq:
   fixes n :: nat
   shows "F (\<lambda>(i,j). g i j) {(i,j). i+j \<le> n} = F (\<lambda>k. F (\<lambda>i. g i (k - i)) {..k}) {..n}"
 using triangle_reindex [of g "Suc n"]
 by (simp only: Nat.less_Suc_eq_le lessThan_Suc_atMost)
 
 lemma nat_diff_reindex: "F (\<lambda>i. g (n - Suc i)) {..<n} = F g {..<n}"
   by (rule reindex_bij_witness[where i="\<lambda>i. n - Suc i" and j="\<lambda>i. n - Suc i"]) auto
 
 lemma shift_bounds_nat_ivl:
   "F g {m+k..<n+k} = F (\<lambda>i. g(i + k)){m..<n::nat}"
 by (induct "n", auto simp: atLeastLessThanSuc)
 
 lemma shift_bounds_cl_nat_ivl:
   "F g {m+k..n+k} = F (\<lambda>i. g(i + k)){m..n::nat}"
   by (rule reindex_bij_witness[where i="\<lambda>i. i + k" and j="\<lambda>i. i - k"]) auto
 
 corollary shift_bounds_cl_Suc_ivl:
   "F g {Suc m..Suc n} = F (\<lambda>i. g(Suc i)){m..n}"
 by (simp add: shift_bounds_cl_nat_ivl[where k="Suc 0", simplified])
 
 corollary Suc_reindex_ivl: "m \<le> n \<Longrightarrow> F g {m..n} \<^bold>* g (Suc n) = g m \<^bold>* F (\<lambda>i. g (Suc i)) {m..n}"
   by (simp add: assoc atLeast_Suc_atMost flip: shift_bounds_cl_Suc_ivl)
 
 corollary shift_bounds_Suc_ivl:
   "F g {Suc m..<Suc n} = F (\<lambda>i. g(Suc i)){m..<n}"
 by (simp add: shift_bounds_nat_ivl[where k="Suc 0", simplified])
 
 lemma atMost_Suc_shift:
   shows "F g {..Suc n} = g 0 \<^bold>* F (\<lambda>i. g (Suc i)) {..n}"
 proof (induct n)
   case 0 show ?case by simp
 next
   case (Suc n) note IH = this
   have "F g {..Suc (Suc n)} = F g {..Suc n} \<^bold>* g (Suc (Suc n))"
     by (rule atMost_Suc)
   also have "F g {..Suc n}  = g 0 \<^bold>* F (\<lambda>i. g (Suc i)) {..n}"
     by (rule IH)
   also have "g 0 \<^bold>* F (\<lambda>i. g (Suc i)) {..n} \<^bold>* g (Suc (Suc n)) =
              g 0 \<^bold>* (F (\<lambda>i. g (Suc i)) {..n} \<^bold>* g (Suc (Suc n)))"
     by (rule assoc)
   also have "F (\<lambda>i. g (Suc i)) {..n} \<^bold>* g (Suc (Suc n)) = F (\<lambda>i. g (Suc i)) {..Suc n}"
     by (rule atMost_Suc [symmetric])
   finally show ?case .
 qed
 
 lemma lessThan_Suc_shift:
   "F g {..<Suc n} = g 0 \<^bold>* F (\<lambda>i. g (Suc i)) {..<n}"
   by (induction n) (simp_all add: ac_simps)
 
 lemma atMost_shift:
   "F g {..n} = g 0 \<^bold>* F (\<lambda>i. g (Suc i)) {..<n}"
   by (metis atLeast0AtMost atLeast0LessThan atLeastLessThanSuc_atLeastAtMost 
        atLeastSucAtMost_greaterThanAtMost le0 head shift_bounds_Suc_ivl)
 
 lemma nested_swap:
      "F (\<lambda>i. F (\<lambda>j. a i j) {0..<i}) {0..n} = F (\<lambda>j. F (\<lambda>i. a i j) {Suc j..n}) {0..<n}"
   by (induction n) (auto simp: distrib)
 
 lemma nested_swap':
      "F (\<lambda>i. F (\<lambda>j. a i j) {..<i}) {..n} = F (\<lambda>j. F (\<lambda>i. a i j) {Suc j..n}) {..<n}"
   by (induction n) (auto simp: distrib)
 
 lemma atLeast1_atMost_eq:
   "F g {Suc 0..n} = F (\<lambda>k. g (Suc k)) {..<n}"
 proof -
   have "F g {Suc 0..n} = F g (Suc ` {..<n})"
     by (simp add: image_Suc_lessThan)
   also have "\<dots> = F (\<lambda>k. g (Suc k)) {..<n}"
     by (simp add: reindex)
   finally show ?thesis .
 qed
 
 lemma atLeastLessThan_Suc: "a \<le> b \<Longrightarrow> F g {a..<Suc b} = F g {a..<b} \<^bold>* g b"
   by (simp add: atLeastLessThanSuc commute)
 
 lemma nat_ivl_Suc':
   assumes "m \<le> Suc n"
   shows   "F g {m..Suc n} = g (Suc n) \<^bold>* F g {m..n}"
 proof -
   from assms have "{m..Suc n} = insert (Suc n) {m..n}" by auto
   also have "F g \<dots> = g (Suc n) \<^bold>* F g {m..n}" by simp
   finally show ?thesis .
 qed
 
 lemma in_pairs: "F g {2*m..Suc(2*n)} = F (\<lambda>i. g(2*i) \<^bold>* g(Suc(2*i))) {m..n}"
 proof (induction n)
   case 0
   show ?case
     by (cases "m=0") auto
 next
   case (Suc n)
   then show ?case
     by (auto simp: assoc split: if_split_asm)
 qed
 
 lemma in_pairs_0: "F g {..Suc(2*n)} = F (\<lambda>i. g(2*i) \<^bold>* g(Suc(2*i))) {..n}"
   using in_pairs [of _ 0 n] by (simp add: atLeast0AtMost)
 
 end
 
 lemma card_sum_le_nat_sum: "\<Sum> {0..<card S} \<le> \<Sum> S"
 proof (cases "finite S")
   case True
   then show ?thesis
   proof (induction "card S" arbitrary: S)
     case (Suc x)
     then have "Max S \<ge> x" using card_le_Suc_Max by fastforce
     let ?S' = "S - {Max S}"
     from Suc have "Max S \<in> S" by (auto intro: Max_in)
     hence cards: "card S = Suc (card ?S')"
       using \<open>finite S\<close> by (intro card.remove; auto)
     hence "\<Sum> {0..<card ?S'} \<le> \<Sum> ?S'"
       using Suc by (intro Suc; auto)
 
     hence "\<Sum> {0..<card ?S'} + x \<le> \<Sum> ?S' + Max S"
       using \<open>Max S \<ge> x\<close> by simp
     also have "... = \<Sum> S"
       using sum.remove[OF \<open>finite S\<close> \<open>Max S \<in> S\<close>, where g="\<lambda>x. x"]
       by simp
     finally show ?case
       using cards Suc by auto
   qed simp
 qed simp
 
 lemma sum_natinterval_diff:
   fixes f:: "nat \<Rightarrow> ('a::ab_group_add)"
   shows  "sum (\<lambda>k. f k - f(k + 1)) {(m::nat) .. n} =
           (if m \<le> n then f m - f(n + 1) else 0)"
 by (induct n, auto simp add: algebra_simps not_le le_Suc_eq)
 
 lemma sum_diff_nat_ivl:
   fixes f :: "nat \<Rightarrow> 'a::ab_group_add"
   shows "\<lbrakk> m \<le> n; n \<le> p \<rbrakk> \<Longrightarrow> sum f {m..<p} - sum f {m..<n} = sum f {n..<p}"
   using sum.atLeastLessThan_concat [of m n p f,symmetric]
   by (simp add: ac_simps)
 
 lemma sum_diff_distrib: "\<forall>x. Q x \<le> P x  \<Longrightarrow> (\<Sum>x<n. P x) - (\<Sum>x<n. Q x) = (\<Sum>x<n. P x - Q x :: nat)"
   by (subst sum_subtractf_nat) auto
 
 
 subsubsection \<open>Shifting bounds\<close>
 
 context comm_monoid_add
 begin
 
 context
   fixes f :: "nat \<Rightarrow> 'a"
   assumes "f 0 = 0"
 begin
 
 lemma sum_shift_lb_Suc0_0_upt:
   "sum f {Suc 0..<k} = sum f {0..<k}"
 proof (cases k)
   case 0
   then show ?thesis
     by simp
 next
   case (Suc k)
   moreover have "{0..<Suc k} = insert 0 {Suc 0..<Suc k}"
     by auto
   ultimately show ?thesis
     using \<open>f 0 = 0\<close> by simp
 qed
 
 lemma sum_shift_lb_Suc0_0: "sum f {Suc 0..k} = sum f {0..k}"
 proof (cases k)
   case 0
   with \<open>f 0 = 0\<close> show ?thesis
     by simp
 next
   case (Suc k)
   moreover have "{0..Suc k} = insert 0 {Suc 0..Suc k}"
     by auto
   ultimately show ?thesis
     using \<open>f 0 = 0\<close> by simp
 qed
 
 end
 
 end
 
 lemma sum_Suc_diff:
   fixes f :: "nat \<Rightarrow> 'a::ab_group_add"
   assumes "m \<le> Suc n"
   shows "(\<Sum>i = m..n. f(Suc i) - f i) = f (Suc n) - f m"
 using assms by (induct n) (auto simp: le_Suc_eq)
 
 lemma sum_Suc_diff':
   fixes f :: "nat \<Rightarrow> 'a::ab_group_add"
   assumes "m \<le> n"
   shows "(\<Sum>i = m..<n. f (Suc i) - f i) = f n - f m"
 using assms by (induct n) (auto simp: le_Suc_eq)
 
 
 subsubsection \<open>Telescoping\<close>
 
 lemma sum_telescope:
   fixes f::"nat \<Rightarrow> 'a::ab_group_add"
   shows "sum (\<lambda>i. f i - f (Suc i)) {.. i} = f 0 - f (Suc i)"
   by (induct i) simp_all
 
 lemma sum_telescope'':
   assumes "m \<le> n"
   shows   "(\<Sum>k\<in>{Suc m..n}. f k - f (k - 1)) = f n - (f m :: 'a :: ab_group_add)"
   by (rule dec_induct[OF assms]) (simp_all add: algebra_simps)
 
 lemma sum_lessThan_telescope:
   "(\<Sum>n<m. f (Suc n) - f n :: 'a :: ab_group_add) = f m - f 0"
   by (induction m) (simp_all add: algebra_simps)
 
 lemma sum_lessThan_telescope':
   "(\<Sum>n<m. f n - f (Suc n) :: 'a :: ab_group_add) = f 0 - f m"
   by (induction m) (simp_all add: algebra_simps)
 
 
 subsubsection \<open>The formula for geometric sums\<close>
 
 lemma sum_power2: "(\<Sum>i=0..<k. (2::nat)^i) = 2^k-1"
   by (induction k) (auto simp: mult_2)
 
 lemma geometric_sum:
   assumes "x \<noteq> 1"
   shows "(\<Sum>i<n. x ^ i) = (x ^ n - 1) / (x - 1::'a::field)"
 proof -
   from assms obtain y where "y = x - 1" and "y \<noteq> 0" by simp_all
   moreover have "(\<Sum>i<n. (y + 1) ^ i) = ((y + 1) ^ n - 1) / y"
     by (induct n) (simp_all add: field_simps \<open>y \<noteq> 0\<close>)
   ultimately show ?thesis by simp
 qed
 
 lemma diff_power_eq_sum:
   fixes y :: "'a::{comm_ring,monoid_mult}"
   shows
     "x ^ (Suc n) - y ^ (Suc n) =
       (x - y) * (\<Sum>p<Suc n. (x ^ p) * y ^ (n - p))"
 proof (induct n)
   case (Suc n)
   have "x ^ Suc (Suc n) - y ^ Suc (Suc n) = x * (x * x^n) - y * (y * y ^ n)"
     by simp
   also have "... = y * (x ^ (Suc n) - y ^ (Suc n)) + (x - y) * (x * x^n)"
     by (simp add: algebra_simps)
   also have "... = y * ((x - y) * (\<Sum>p<Suc n. (x ^ p) * y ^ (n - p))) + (x - y) * (x * x^n)"
     by (simp only: Suc)
   also have "... = (x - y) * (y * (\<Sum>p<Suc n. (x ^ p) * y ^ (n - p))) + (x - y) * (x * x^n)"
     by (simp only: mult.left_commute)
   also have "... = (x - y) * (\<Sum>p<Suc (Suc n). x ^ p * y ^ (Suc n - p))"
     by (simp add: field_simps Suc_diff_le sum_distrib_right sum_distrib_left)
   finally show ?case .
 qed simp
 
 corollary power_diff_sumr2: \<comment> \<open>\<open>COMPLEX_POLYFUN\<close> in HOL Light\<close>
   fixes x :: "'a::{comm_ring,monoid_mult}"
   shows "x^n - y^n = (x - y) * (\<Sum>i<n. y^(n - Suc i) * x^i)"
 using diff_power_eq_sum[of x "n - 1" y]
 by (cases "n = 0") (simp_all add: field_simps)
 
 lemma power_diff_1_eq:
   fixes x :: "'a::{comm_ring,monoid_mult}"
   shows "x^n - 1 = (x - 1) * (\<Sum>i<n. (x^i))"
 using diff_power_eq_sum [of x _ 1]
   by (cases n) auto
 
 lemma one_diff_power_eq':
   fixes x :: "'a::{comm_ring,monoid_mult}"
   shows "1 - x^n = (1 - x) * (\<Sum>i<n. x^(n - Suc i))"
 using diff_power_eq_sum [of 1 _ x]
   by (cases n) auto
 
 lemma one_diff_power_eq:
   fixes x :: "'a::{comm_ring,monoid_mult}"
   shows "1 - x^n = (1 - x) * (\<Sum>i<n. x^i)"
 by (metis one_diff_power_eq' sum.nat_diff_reindex)
 
 lemma sum_gp_basic:
   fixes x :: "'a::{comm_ring,monoid_mult}"
   shows "(1 - x) * (\<Sum>i\<le>n. x^i) = 1 - x^Suc n"
   by (simp only: one_diff_power_eq lessThan_Suc_atMost)
 
 lemma sum_power_shift:
   fixes x :: "'a::{comm_ring,monoid_mult}"
   assumes "m \<le> n"
   shows "(\<Sum>i=m..n. x^i) = x^m * (\<Sum>i\<le>n-m. x^i)"
 proof -
   have "(\<Sum>i=m..n. x^i) = x^m * (\<Sum>i=m..n. x^(i-m))"
     by (simp add: sum_distrib_left power_add [symmetric])
   also have "(\<Sum>i=m..n. x^(i-m)) = (\<Sum>i\<le>n-m. x^i)"
     using \<open>m \<le> n\<close> by (intro sum.reindex_bij_witness[where j="\<lambda>i. i - m" and i="\<lambda>i. i + m"]) auto
   finally show ?thesis .
 qed
 
 lemma sum_gp_multiplied:
   fixes x :: "'a::{comm_ring,monoid_mult}"
   assumes "m \<le> n"
   shows "(1 - x) * (\<Sum>i=m..n. x^i) = x^m - x^Suc n"
 proof -
   have  "(1 - x) * (\<Sum>i=m..n. x^i) = x^m * (1 - x) * (\<Sum>i\<le>n-m. x^i)"
     by (metis mult.assoc mult.commute assms sum_power_shift)
   also have "... =x^m * (1 - x^Suc(n-m))"
     by (metis mult.assoc sum_gp_basic)
   also have "... = x^m - x^Suc n"
     using assms
     by (simp add: algebra_simps) (metis le_add_diff_inverse power_add)
   finally show ?thesis .
 qed
 
 lemma sum_gp:
   fixes x :: "'a::{comm_ring,division_ring}"
   shows   "(\<Sum>i=m..n. x^i) =
                (if n < m then 0
                 else if x = 1 then of_nat((n + 1) - m)
                 else (x^m - x^Suc n) / (1 - x))"
-using sum_gp_multiplied [of m n x] apply auto
-by (metis eq_iff_diff_eq_0 mult.commute nonzero_divide_eq_eq)
+proof (cases "n < m")
+  case False
+  assume *: "\<not> n < m"
+  then show ?thesis
+  proof (cases "x = 1")
+    case False
+    assume "x \<noteq> 1"
+    then have not_zero: "1 - x \<noteq> 0"
+      by auto
+    have "(1 - x) * (\<Sum>i=m..n. x^i) = x ^ m - x * x ^ n"
+      using sum_gp_multiplied [of m n x] * by auto
+    then have "(\<Sum>i=m..n. x^i) = (x ^ m - x * x ^ n) / (1 - x) "
+      using nonzero_divide_eq_eq mult.commute not_zero
+      by metis
+    then show ?thesis
+      by auto
+  qed (auto)
+qed (auto)
 
 
 subsubsection\<open>Geometric progressions\<close>
 
 lemma sum_gp0:
   fixes x :: "'a::{comm_ring,division_ring}"
   shows "(\<Sum>i\<le>n. x^i) = (if x = 1 then of_nat(n + 1) else (1 - x^Suc n) / (1 - x))"
   using sum_gp_basic[of x n]
   by (simp add: mult.commute field_split_simps)
 
 lemma sum_power_add:
   fixes x :: "'a::{comm_ring,monoid_mult}"
   shows "(\<Sum>i\<in>I. x^(m+i)) = x^m * (\<Sum>i\<in>I. x^i)"
   by (simp add: sum_distrib_left power_add)
 
 lemma sum_gp_offset:
   fixes x :: "'a::{comm_ring,division_ring}"
   shows   "(\<Sum>i=m..m+n. x^i) =
        (if x = 1 then of_nat n + 1 else x^m * (1 - x^Suc n) / (1 - x))"
   using sum_gp [of x m "m+n"]
   by (auto simp: power_add algebra_simps)
 
 lemma sum_gp_strict:
   fixes x :: "'a::{comm_ring,division_ring}"
   shows "(\<Sum>i<n. x^i) = (if x = 1 then of_nat n else (1 - x^n) / (1 - x))"
   by (induct n) (auto simp: algebra_simps field_split_simps)
 
 
 subsubsection \<open>The formulae for arithmetic sums\<close>
 
 context comm_semiring_1
 begin
 
 lemma double_gauss_sum:
   "2 * (\<Sum>i = 0..n. of_nat i) = of_nat n * (of_nat n + 1)"
   by (induct n) (simp_all add: sum.atLeast0_atMost_Suc algebra_simps left_add_twice)
 
 lemma double_gauss_sum_from_Suc_0:
   "2 * (\<Sum>i = Suc 0..n. of_nat i) = of_nat n * (of_nat n + 1)"
 proof -
   have "sum of_nat {Suc 0..n} = sum of_nat (insert 0 {Suc 0..n})"
     by simp
   also have "\<dots> = sum of_nat {0..n}"
     by (cases n) (simp_all add: atLeast0_atMost_Suc_eq_insert_0)
   finally show ?thesis
     by (simp add: double_gauss_sum)
 qed
 
 lemma double_arith_series:
   "2 * (\<Sum>i = 0..n. a + of_nat i * d) = (of_nat n + 1) * (2 * a + of_nat n * d)"
 proof -
   have "(\<Sum>i = 0..n. a + of_nat i * d) = ((\<Sum>i = 0..n. a) + (\<Sum>i = 0..n. of_nat i * d))"
     by (rule sum.distrib)
   also have "\<dots> = (of_nat (Suc n) * a + d * (\<Sum>i = 0..n. of_nat i))"
     by (simp add: sum_distrib_left algebra_simps)
   finally show ?thesis
     by (simp add: algebra_simps double_gauss_sum left_add_twice)
 qed
 
 end
 
 context unique_euclidean_semiring_with_nat
 begin
 
 lemma gauss_sum:
   "(\<Sum>i = 0..n. of_nat i) = of_nat n * (of_nat n + 1) div 2"
   using double_gauss_sum [of n, symmetric] by simp
 
 lemma gauss_sum_from_Suc_0:
   "(\<Sum>i = Suc 0..n. of_nat i) = of_nat n * (of_nat n + 1) div 2"
   using double_gauss_sum_from_Suc_0 [of n, symmetric] by simp
 
 lemma arith_series:
   "(\<Sum>i = 0..n. a + of_nat i * d) = (of_nat n + 1) * (2 * a + of_nat n * d) div 2"
   using double_arith_series [of a d n, symmetric] by simp
 
 end
 
 lemma gauss_sum_nat:
   "\<Sum>{0..n} = (n * Suc n) div 2"
   using gauss_sum [of n, where ?'a = nat] by simp
 
 lemma arith_series_nat:
   "(\<Sum>i = 0..n. a + i * d) = Suc n * (2 * a + n * d) div 2"
   using arith_series [of a d n] by simp
 
 lemma Sum_Icc_int:
   "\<Sum>{m..n} = (n * (n + 1) - m * (m - 1)) div 2"
   if "m \<le> n" for m n :: int
 using that proof (induct i \<equiv> "nat (n - m)" arbitrary: m n)
   case 0
   then have "m = n"
     by arith
   then show ?case
     by (simp add: algebra_simps mult_2 [symmetric])
 next
   case (Suc i)
   have 0: "i = nat((n-1) - m)" "m \<le> n-1" using Suc(2,3) by arith+
   have "\<Sum> {m..n} = \<Sum> {m..1+(n-1)}" by simp
   also have "\<dots> = \<Sum> {m..n-1} + n" using \<open>m \<le> n\<close>
     by(subst atLeastAtMostPlus1_int_conv) simp_all
   also have "\<dots> = ((n-1)*(n-1+1) - m*(m-1)) div 2 + n"
     by(simp add: Suc(1)[OF 0])
   also have "\<dots> = ((n-1)*(n-1+1) - m*(m-1) + 2*n) div 2" by simp
   also have "\<dots> = (n*(n+1) - m*(m-1)) div 2"
     by (simp add: algebra_simps mult_2_right)
   finally show ?case .
 qed
 
 lemma Sum_Icc_nat:
   "\<Sum>{m..n} = (n * (n + 1) - m * (m - 1)) div 2" for m n :: nat
 proof (cases "m \<le> n")
   case True
   then have *: "m * (m - 1) \<le> n * (n + 1)"
     by (meson diff_le_self order_trans le_add1 mult_le_mono)
   have "int (\<Sum>{m..n}) = (\<Sum>{int m..int n})"
     by (simp add: sum.atLeast_int_atMost_int_shift)
   also have "\<dots> = (int n * (int n + 1) - int m * (int m - 1)) div 2"
     using \<open>m \<le> n\<close> by (simp add: Sum_Icc_int)
   also have "\<dots> = int ((n * (n + 1) - m * (m - 1)) div 2)"
     using le_square * by (simp add: algebra_simps of_nat_div of_nat_diff)
   finally show ?thesis
     by (simp only: of_nat_eq_iff)
 next
   case False
   then show ?thesis
     by (auto dest: less_imp_Suc_add simp add: not_le algebra_simps)
 qed
 
 lemma Sum_Ico_nat: 
   "\<Sum>{m..<n} = (n * (n - 1) - m * (m - 1)) div 2" for m n :: nat
   by (cases n) (simp_all add: atLeastLessThanSuc_atLeastAtMost Sum_Icc_nat)
 
 
 subsubsection \<open>Division remainder\<close>
 
 lemma range_mod:
   fixes n :: nat
   assumes "n > 0"
   shows "range (\<lambda>m. m mod n) = {0..<n}" (is "?A = ?B")
 proof (rule set_eqI)
   fix m
   show "m \<in> ?A \<longleftrightarrow> m \<in> ?B"
   proof
     assume "m \<in> ?A"
     with assms show "m \<in> ?B"
       by auto
   next
     assume "m \<in> ?B"
     moreover have "m mod n \<in> ?A"
       by (rule rangeI)
     ultimately show "m \<in> ?A"
       by simp
   qed
 qed
 
 
 subsection \<open>Products indexed over intervals\<close>
 
 syntax (ASCII)
   "_from_to_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(PROD _ = _.._./ _)" [0,0,0,10] 10)
   "_from_upto_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(PROD _ = _..<_./ _)" [0,0,0,10] 10)
   "_upt_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(PROD _<_./ _)" [0,0,10] 10)
   "_upto_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(PROD _<=_./ _)" [0,0,10] 10)
 
 syntax (latex_prod output)
   "_from_to_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\prod_{\<close>_ = _\<^latex>\<open>}^{\<close>_\<^latex>\<open>}$\<close> _)" [0,0,0,10] 10)
   "_from_upto_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\prod_{\<close>_ = _\<^latex>\<open>}^{<\<close>_\<^latex>\<open>}$\<close> _)" [0,0,0,10] 10)
   "_upt_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\prod_{\<close>_ < _\<^latex>\<open>}$\<close> _)" [0,0,10] 10)
   "_upto_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"
  ("(3\<^latex>\<open>$\\prod_{\<close>_ \<le> _\<^latex>\<open>}$\<close> _)" [0,0,10] 10)
 
 syntax
   "_from_to_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Prod>_ = _.._./ _)" [0,0,0,10] 10)
   "_from_upto_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Prod>_ = _..<_./ _)" [0,0,0,10] 10)
   "_upt_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Prod>_<_./ _)" [0,0,10] 10)
   "_upto_prod" :: "idt \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Prod>_\<le>_./ _)" [0,0,10] 10)
 
 translations
   "\<Prod>x=a..b. t" \<rightleftharpoons> "CONST prod (\<lambda>x. t) {a..b}"
   "\<Prod>x=a..<b. t" \<rightleftharpoons> "CONST prod (\<lambda>x. t) {a..<b}"
   "\<Prod>i\<le>n. t" \<rightleftharpoons> "CONST prod (\<lambda>i. t) {..n}"
   "\<Prod>i<n. t" \<rightleftharpoons> "CONST prod (\<lambda>i. t) {..<n}"
 
 lemma prod_int_plus_eq: "prod int {i..i+j} =  \<Prod>{int i..int (i+j)}"
   by (induct j) (auto simp add: atLeastAtMostSuc_conv atLeastAtMostPlus1_int_conv)
 
 lemma prod_int_eq: "prod int {i..j} =  \<Prod>{int i..int j}"
 proof (cases "i \<le> j")
   case True
   then show ?thesis
     by (metis le_iff_add prod_int_plus_eq)
 next
   case False
   then show ?thesis
     by auto
 qed
 
 subsection \<open>Efficient folding over intervals\<close>
 
 function fold_atLeastAtMost_nat where
   [simp del]: "fold_atLeastAtMost_nat f a (b::nat) acc =
                  (if a > b then acc else fold_atLeastAtMost_nat f (a+1) b (f a acc))"
 by pat_completeness auto
 termination by (relation "measure (\<lambda>(_,a,b,_). Suc b - a)") auto
 
 lemma fold_atLeastAtMost_nat:
   assumes "comp_fun_commute f"
   shows   "fold_atLeastAtMost_nat f a b acc = Finite_Set.fold f acc {a..b}"
 using assms
 proof (induction f a b acc rule: fold_atLeastAtMost_nat.induct, goal_cases)
   case (1 f a b acc)
   interpret comp_fun_commute f by fact
   show ?case
   proof (cases "a > b")
     case True
     thus ?thesis by (subst fold_atLeastAtMost_nat.simps) auto
   next
     case False
     with 1 show ?thesis
       by (subst fold_atLeastAtMost_nat.simps)
          (auto simp: atLeastAtMost_insertL[symmetric] fold_fun_left_comm)
   qed
 qed
 
 lemma sum_atLeastAtMost_code:
   "sum f {a..b} = fold_atLeastAtMost_nat (\<lambda>a acc. f a + acc) a b 0"
 proof -
   have "comp_fun_commute (\<lambda>a. (+) (f a))"
     by unfold_locales (auto simp: o_def add_ac)
   thus ?thesis
     by (simp add: sum.eq_fold fold_atLeastAtMost_nat o_def)
 qed
 
 lemma prod_atLeastAtMost_code:
   "prod f {a..b} = fold_atLeastAtMost_nat (\<lambda>a acc. f a * acc) a b 1"
 proof -
   have "comp_fun_commute (\<lambda>a. (*) (f a))"
     by unfold_locales (auto simp: o_def mult_ac)
   thus ?thesis
     by (simp add: prod.eq_fold fold_atLeastAtMost_nat o_def)
 qed
 
 (* TODO: Add support for folding over more kinds of intervals here *)
 
 end
diff --git a/src/HOL/Transfer.thy b/src/HOL/Transfer.thy
--- a/src/HOL/Transfer.thy
+++ b/src/HOL/Transfer.thy
@@ -1,692 +1,697 @@
 (*  Title:      HOL/Transfer.thy
     Author:     Brian Huffman, TU Muenchen
     Author:     Ondrej Kuncar, TU Muenchen
 *)
 
 section \<open>Generic theorem transfer using relations\<close>
 
 theory Transfer
 imports Basic_BNF_LFPs Hilbert_Choice Metis
 begin
 
 subsection \<open>Relator for function space\<close>
 
 bundle lifting_syntax
 begin
   notation rel_fun  (infixr "===>" 55)
   notation map_fun  (infixr "--->" 55)
 end
 
 context includes lifting_syntax
 begin
 
 lemma rel_funD2:
   assumes "rel_fun A B f g" and "A x x"
   shows "B (f x) (g x)"
   using assms by (rule rel_funD)
 
 lemma rel_funE:
   assumes "rel_fun A B f g" and "A x y"
   obtains "B (f x) (g y)"
   using assms by (simp add: rel_fun_def)
 
 lemmas rel_fun_eq = fun.rel_eq
 
 lemma rel_fun_eq_rel:
 shows "rel_fun (=) R = (\<lambda>f g. \<forall>x. R (f x) (g x))"
   by (simp add: rel_fun_def)
 
 
 subsection \<open>Transfer method\<close>
 
 text \<open>Explicit tag for relation membership allows for
   backward proof methods.\<close>
 
 definition Rel :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
   where "Rel r \<equiv> r"
 
 text \<open>Handling of equality relations\<close>
 
 definition is_equality :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "is_equality R \<longleftrightarrow> R = (=)"
 
 lemma is_equality_eq: "is_equality (=)"
   unfolding is_equality_def by simp
 
 text \<open>Reverse implication for monotonicity rules\<close>
 
 definition rev_implies where
   "rev_implies x y \<longleftrightarrow> (y \<longrightarrow> x)"
 
 text \<open>Handling of meta-logic connectives\<close>
 
 definition transfer_forall where
   "transfer_forall \<equiv> All"
 
 definition transfer_implies where
   "transfer_implies \<equiv> (\<longrightarrow>)"
 
 definition transfer_bforall :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
   where "transfer_bforall \<equiv> (\<lambda>P Q. \<forall>x. P x \<longrightarrow> Q x)"
 
 lemma transfer_forall_eq: "(\<And>x. P x) \<equiv> Trueprop (transfer_forall (\<lambda>x. P x))"
   unfolding atomize_all transfer_forall_def ..
 
 lemma transfer_implies_eq: "(A \<Longrightarrow> B) \<equiv> Trueprop (transfer_implies A B)"
   unfolding atomize_imp transfer_implies_def ..
 
 lemma transfer_bforall_unfold:
   "Trueprop (transfer_bforall P (\<lambda>x. Q x)) \<equiv> (\<And>x. P x \<Longrightarrow> Q x)"
   unfolding transfer_bforall_def atomize_imp atomize_all ..
 
 lemma transfer_start: "\<lbrakk>P; Rel (=) P Q\<rbrakk> \<Longrightarrow> Q"
   unfolding Rel_def by simp
 
 lemma transfer_start': "\<lbrakk>P; Rel (\<longrightarrow>) P Q\<rbrakk> \<Longrightarrow> Q"
   unfolding Rel_def by simp
 
 lemma transfer_prover_start: "\<lbrakk>x = x'; Rel R x' y\<rbrakk> \<Longrightarrow> Rel R x y"
   by simp
 
 lemma untransfer_start: "\<lbrakk>Q; Rel (=) P Q\<rbrakk> \<Longrightarrow> P"
   unfolding Rel_def by simp
 
 lemma Rel_eq_refl: "Rel (=) x x"
   unfolding Rel_def ..
 
 lemma Rel_app:
   assumes "Rel (A ===> B) f g" and "Rel A x y"
   shows "Rel B (f x) (g y)"
   using assms unfolding Rel_def rel_fun_def by fast
 
 lemma Rel_abs:
   assumes "\<And>x y. Rel A x y \<Longrightarrow> Rel B (f x) (g y)"
   shows "Rel (A ===> B) (\<lambda>x. f x) (\<lambda>y. g y)"
   using assms unfolding Rel_def rel_fun_def by fast
 
 subsection \<open>Predicates on relations, i.e. ``class constraints''\<close>
 
 definition left_total :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
   where "left_total R \<longleftrightarrow> (\<forall>x. \<exists>y. R x y)"
 
 definition left_unique :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
   where "left_unique R \<longleftrightarrow> (\<forall>x y z. R x z \<longrightarrow> R y z \<longrightarrow> x = y)"
 
 definition right_total :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
   where "right_total R \<longleftrightarrow> (\<forall>y. \<exists>x. R x y)"
 
 definition right_unique :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
   where "right_unique R \<longleftrightarrow> (\<forall>x y z. R x y \<longrightarrow> R x z \<longrightarrow> y = z)"
 
 definition bi_total :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
   where "bi_total R \<longleftrightarrow> (\<forall>x. \<exists>y. R x y) \<and> (\<forall>y. \<exists>x. R x y)"
 
 definition bi_unique :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool"
   where "bi_unique R \<longleftrightarrow>
     (\<forall>x y z. R x y \<longrightarrow> R x z \<longrightarrow> y = z) \<and>
     (\<forall>x y z. R x z \<longrightarrow> R y z \<longrightarrow> x = y)"
 
 lemma left_unique_iff: "left_unique R \<longleftrightarrow> (\<forall>z. \<exists>\<^sub>\<le>\<^sub>1x. R x z)"
   unfolding Uniq_def left_unique_def by force
 
 lemma left_uniqueI: "(\<And>x y z. \<lbrakk> A x z; A y z \<rbrakk> \<Longrightarrow> x = y) \<Longrightarrow> left_unique A"
 unfolding left_unique_def by blast
 
 lemma left_uniqueD: "\<lbrakk> left_unique A; A x z; A y z \<rbrakk> \<Longrightarrow> x = y"
 unfolding left_unique_def by blast
 
 lemma left_totalI:
   "(\<And>x. \<exists>y. R x y) \<Longrightarrow> left_total R"
 unfolding left_total_def by blast
 
 lemma left_totalE:
   assumes "left_total R"
   obtains "(\<And>x. \<exists>y. R x y)"
 using assms unfolding left_total_def by blast
 
 lemma bi_uniqueDr: "\<lbrakk> bi_unique A; A x y; A x z \<rbrakk> \<Longrightarrow> y = z"
   by(simp add: bi_unique_def)
 
 lemma bi_uniqueDl: "\<lbrakk> bi_unique A; A x y; A z y \<rbrakk> \<Longrightarrow> x = z"
   by(simp add: bi_unique_def)
 
 lemma bi_unique_iff: "bi_unique R \<longleftrightarrow> (\<forall>z. \<exists>\<^sub>\<le>\<^sub>1x. R x z) \<and> (\<forall>z. \<exists>\<^sub>\<le>\<^sub>1x. R z x)"
   unfolding Uniq_def bi_unique_def by force
 
 lemma right_unique_iff: "right_unique R \<longleftrightarrow> (\<forall>z. \<exists>\<^sub>\<le>\<^sub>1x. R z x)"
   unfolding Uniq_def right_unique_def by force
 
 lemma right_uniqueI: "(\<And>x y z. \<lbrakk> A x y; A x z \<rbrakk> \<Longrightarrow> y = z) \<Longrightarrow> right_unique A"
 unfolding right_unique_def by fast
 
 lemma right_uniqueD: "\<lbrakk> right_unique A; A x y; A x z \<rbrakk> \<Longrightarrow> y = z"
 unfolding right_unique_def by fast
 
 lemma right_totalI: "(\<And>y. \<exists>x. A x y) \<Longrightarrow> right_total A"
 by(simp add: right_total_def)
 
 lemma right_totalE:
   assumes "right_total A"
   obtains x where "A x y"
 using assms by(auto simp add: right_total_def)
 
 lemma right_total_alt_def2:
   "right_total R \<longleftrightarrow> ((R ===> (\<longrightarrow>)) ===> (\<longrightarrow>)) All All" (is "?lhs = ?rhs")
 proof
   assume ?lhs then show ?rhs
     unfolding right_total_def rel_fun_def by blast
 next
   assume \<section>: ?rhs
   show ?lhs
     using \<section> [unfolded rel_fun_def, rule_format, of "\<lambda>x. True" "\<lambda>y. \<exists>x. R x y"]
     unfolding right_total_def by blast
 qed
 
 lemma right_unique_alt_def2:
   "right_unique R \<longleftrightarrow> (R ===> R ===> (\<longrightarrow>)) (=) (=)"
   unfolding right_unique_def rel_fun_def by auto
 
 lemma bi_total_alt_def2:
   "bi_total R \<longleftrightarrow> ((R ===> (=)) ===> (=)) All All" (is "?lhs = ?rhs")
 proof
   assume ?lhs then show ?rhs
     unfolding bi_total_def rel_fun_def by blast
 next
   assume \<section>: ?rhs
   show ?lhs
     using \<section> [unfolded rel_fun_def, rule_format, of "\<lambda>x. \<exists>y. R x y" "\<lambda>y. True"]
     using \<section> [unfolded rel_fun_def, rule_format, of "\<lambda>x. True" "\<lambda>y. \<exists>x. R x y"]
     by (auto simp: bi_total_def)
 qed
 
 lemma bi_unique_alt_def2:
   "bi_unique R \<longleftrightarrow> (R ===> R ===> (=)) (=) (=)"
   unfolding bi_unique_def rel_fun_def by auto
 
 lemma [simp]:
   shows left_unique_conversep: "left_unique A\<inverse>\<inverse> \<longleftrightarrow> right_unique A"
     and right_unique_conversep: "right_unique A\<inverse>\<inverse> \<longleftrightarrow> left_unique A"
   by(auto simp add: left_unique_def right_unique_def)
 
 lemma [simp]:
   shows left_total_conversep: "left_total A\<inverse>\<inverse> \<longleftrightarrow> right_total A"
     and right_total_conversep: "right_total A\<inverse>\<inverse> \<longleftrightarrow> left_total A"
   by(simp_all add: left_total_def right_total_def)
 
 lemma bi_unique_conversep [simp]: "bi_unique R\<inverse>\<inverse> = bi_unique R"
   by(auto simp add: bi_unique_def)
 
 lemma bi_total_conversep [simp]: "bi_total R\<inverse>\<inverse> = bi_total R"
   by(auto simp add: bi_total_def)
 
 lemma right_unique_alt_def: "right_unique R = (conversep R OO R \<le> (=))" unfolding right_unique_def by blast
 lemma left_unique_alt_def: "left_unique R = (R OO (conversep R) \<le> (=))" unfolding left_unique_def by blast
 
 lemma right_total_alt_def: "right_total R = (conversep R OO R \<ge> (=))" unfolding right_total_def by blast
 lemma left_total_alt_def: "left_total R = (R OO conversep R \<ge> (=))" unfolding left_total_def by blast
 
 lemma bi_total_alt_def: "bi_total A = (left_total A \<and> right_total A)"
 unfolding left_total_def right_total_def bi_total_def by blast
 
 lemma bi_unique_alt_def: "bi_unique A = (left_unique A \<and> right_unique A)"
 unfolding left_unique_def right_unique_def bi_unique_def by blast
 
 lemma bi_totalI: "left_total R \<Longrightarrow> right_total R \<Longrightarrow> bi_total R"
 unfolding bi_total_alt_def ..
 
 lemma bi_uniqueI: "left_unique R \<Longrightarrow> right_unique R \<Longrightarrow> bi_unique R"
 unfolding bi_unique_alt_def ..
 
 end
 
 
 lemma is_equality_lemma: "(\<And>R. is_equality R \<Longrightarrow> PROP (P R)) \<equiv> PROP (P (=))"
   unfolding is_equality_def
 proof (rule equal_intr_rule)
   show "(\<And>R. R = (=) \<Longrightarrow> PROP P R) \<Longrightarrow> PROP P (=)"
     apply (drule meta_spec)
     apply (erule meta_mp [OF _ refl])
     done
 qed simp
 
 lemma Domainp_lemma: "(\<And>R. Domainp T = R \<Longrightarrow> PROP (P R)) \<equiv> PROP (P (Domainp T))"
 proof (rule equal_intr_rule)
   show "(\<And>R. Domainp T = R \<Longrightarrow> PROP P R) \<Longrightarrow> PROP P (Domainp T)"
     apply (drule meta_spec)
     apply (erule meta_mp [OF _ refl])
     done
 qed simp
 
 ML_file \<open>Tools/Transfer/transfer.ML\<close>
 declare refl [transfer_rule]
 
 hide_const (open) Rel
 
 context includes lifting_syntax
 begin
 
 text \<open>Handling of domains\<close>
 
 lemma Domainp_iff: "Domainp T x \<longleftrightarrow> (\<exists>y. T x y)"
   by auto
 
 lemma Domainp_refl[transfer_domain_rule]:
   "Domainp T = Domainp T" ..
 
 lemma Domain_eq_top[transfer_domain_rule]: "Domainp (=) = top" by auto
 
 lemma Domainp_pred_fun_eq[relator_domain]:
   assumes "left_unique T"
   shows "Domainp (T ===> S) = pred_fun (Domainp T) (Domainp S)"   (is "?lhs = ?rhs")
 proof (intro ext iffI)
   fix x
   assume "?lhs x"
   then show "?rhs x"
     using assms unfolding rel_fun_def pred_fun_def by blast
 next
   fix x
   assume "?rhs x"
   then have "\<exists>g. \<forall>y xa. T xa y \<longrightarrow> S (x xa) (g y)"
     using assms unfolding Domainp_iff left_unique_def  pred_fun_def
     by (intro choice) blast
   then show "?lhs x"
     by blast
 qed
 
 text \<open>Properties are preserved by relation composition.\<close>
 
 lemma OO_def: "R OO S = (\<lambda>x z. \<exists>y. R x y \<and> S y z)"
   by auto
 
 lemma bi_total_OO: "\<lbrakk>bi_total A; bi_total B\<rbrakk> \<Longrightarrow> bi_total (A OO B)"
   unfolding bi_total_def OO_def by fast
 
 lemma bi_unique_OO: "\<lbrakk>bi_unique A; bi_unique B\<rbrakk> \<Longrightarrow> bi_unique (A OO B)"
   unfolding bi_unique_def OO_def by blast
 
 lemma right_total_OO:
   "\<lbrakk>right_total A; right_total B\<rbrakk> \<Longrightarrow> right_total (A OO B)"
   unfolding right_total_def OO_def by fast
 
 lemma right_unique_OO:
   "\<lbrakk>right_unique A; right_unique B\<rbrakk> \<Longrightarrow> right_unique (A OO B)"
   unfolding right_unique_def OO_def by fast
 
 lemma left_total_OO: "left_total R \<Longrightarrow> left_total S \<Longrightarrow> left_total (R OO S)"
   unfolding left_total_def OO_def by fast
 
 lemma left_unique_OO: "left_unique R \<Longrightarrow> left_unique S \<Longrightarrow> left_unique (R OO S)"
   unfolding left_unique_def OO_def by blast
 
 
 subsection \<open>Properties of relators\<close>
 
 lemma left_total_eq[transfer_rule]: "left_total (=)"
   unfolding left_total_def by blast
 
 lemma left_unique_eq[transfer_rule]: "left_unique (=)"
   unfolding left_unique_def by blast
 
 lemma right_total_eq [transfer_rule]: "right_total (=)"
   unfolding right_total_def by simp
 
 lemma right_unique_eq [transfer_rule]: "right_unique (=)"
   unfolding right_unique_def by simp
 
 lemma bi_total_eq[transfer_rule]: "bi_total (=)"
   unfolding bi_total_def by simp
 
 lemma bi_unique_eq[transfer_rule]: "bi_unique (=)"
   unfolding bi_unique_def by simp
 
 lemma left_total_fun[transfer_rule]:
   assumes "left_unique A" "left_total B"
   shows "left_total (A ===> B)"
   unfolding left_total_def 
 proof
   fix f
   show "Ex ((A ===> B) f)"
     unfolding rel_fun_def
   proof (intro exI strip)
     fix x y
     assume A: "A x y"
     have "(THE x. A x y) = x"
       using A assms by (simp add: left_unique_def the_equality)
     then show "B (f x) (SOME z. B (f (THE x. A x y)) z)"
       using assms by (force simp: left_total_def intro: someI_ex)
   qed
 qed
 
 lemma left_unique_fun[transfer_rule]:
   "\<lbrakk>left_total A; left_unique B\<rbrakk> \<Longrightarrow> left_unique (A ===> B)"
   unfolding left_total_def left_unique_def rel_fun_def
   by (clarify, rule ext, fast)
 
 lemma right_total_fun [transfer_rule]:
   assumes "right_unique A" "right_total B"
   shows "right_total (A ===> B)"
   unfolding right_total_def 
 proof
   fix g
   show "\<exists>x. (A ===> B) x g"
     unfolding rel_fun_def
   proof (intro exI strip)
     fix x y
     assume A: "A x y"
     have "(THE y. A x y) = y"
       using A assms by (simp add: right_unique_def the_equality)
     then show "B (SOME z. B z (g (THE y. A x y))) (g y)"
       using assms by (force simp: right_total_def intro: someI_ex)
   qed
 qed
 
 lemma right_unique_fun [transfer_rule]:
   "\<lbrakk>right_total A; right_unique B\<rbrakk> \<Longrightarrow> right_unique (A ===> B)"
   unfolding right_total_def right_unique_def rel_fun_def
   by (clarify, rule ext, fast)
 
 lemma bi_total_fun[transfer_rule]:
   "\<lbrakk>bi_unique A; bi_total B\<rbrakk> \<Longrightarrow> bi_total (A ===> B)"
   unfolding bi_unique_alt_def bi_total_alt_def
   by (blast intro: right_total_fun left_total_fun)
 
 lemma bi_unique_fun[transfer_rule]:
   "\<lbrakk>bi_total A; bi_unique B\<rbrakk> \<Longrightarrow> bi_unique (A ===> B)"
   unfolding bi_unique_alt_def bi_total_alt_def
   by (blast intro: right_unique_fun left_unique_fun)
 
 end
 
 lemma if_conn:
   "(if P \<and> Q then t else e) = (if P then if Q then t else e else e)"
   "(if P \<or> Q then t else e) = (if P then t else if Q then t else e)"
   "(if P \<longrightarrow> Q then t else e) = (if P then if Q then t else e else t)"
   "(if \<not> P then t else e) = (if P then e else t)"
 by auto
 
 ML_file \<open>Tools/Transfer/transfer_bnf.ML\<close>
 ML_file \<open>Tools/BNF/bnf_fp_rec_sugar_transfer.ML\<close>
 
 declare pred_fun_def [simp]
 declare rel_fun_eq [relator_eq]
 
 (* Delete the automated generated rule from the bnf command;
   we have a more general rule (Domainp_pred_fun_eq) that subsumes it. *)
 declare fun.Domainp_rel[relator_domain del]
 
 subsection \<open>Transfer rules\<close>
 
 context includes lifting_syntax
 begin
 
 lemma Domainp_forall_transfer [transfer_rule]:
   assumes "right_total A"
   shows "((A ===> (=)) ===> (=))
     (transfer_bforall (Domainp A)) transfer_forall"
   using assms unfolding right_total_def
   unfolding transfer_forall_def transfer_bforall_def rel_fun_def Domainp_iff
   by fast
 
 text \<open>Transfer rules using implication instead of equality on booleans.\<close>
 
 lemma transfer_forall_transfer [transfer_rule]:
   "bi_total A \<Longrightarrow> ((A ===> (=)) ===> (=)) transfer_forall transfer_forall"
   "right_total A \<Longrightarrow> ((A ===> (=)) ===> implies) transfer_forall transfer_forall"
   "right_total A \<Longrightarrow> ((A ===> implies) ===> implies) transfer_forall transfer_forall"
   "bi_total A \<Longrightarrow> ((A ===> (=)) ===> rev_implies) transfer_forall transfer_forall"
   "bi_total A \<Longrightarrow> ((A ===> rev_implies) ===> rev_implies) transfer_forall transfer_forall"
   unfolding transfer_forall_def rev_implies_def rel_fun_def right_total_def bi_total_def
   by fast+
 
 lemma transfer_implies_transfer [transfer_rule]:
   "((=)        ===> (=)        ===> (=)       ) transfer_implies transfer_implies"
   "(rev_implies ===> implies     ===> implies    ) transfer_implies transfer_implies"
   "(rev_implies ===> (=)        ===> implies    ) transfer_implies transfer_implies"
   "((=)        ===> implies     ===> implies    ) transfer_implies transfer_implies"
   "((=)        ===> (=)        ===> implies    ) transfer_implies transfer_implies"
   "(implies     ===> rev_implies ===> rev_implies) transfer_implies transfer_implies"
   "(implies     ===> (=)        ===> rev_implies) transfer_implies transfer_implies"
   "((=)        ===> rev_implies ===> rev_implies) transfer_implies transfer_implies"
   "((=)        ===> (=)        ===> rev_implies) transfer_implies transfer_implies"
   unfolding transfer_implies_def rev_implies_def rel_fun_def by auto
 
 lemma eq_imp_transfer [transfer_rule]:
   "right_unique A \<Longrightarrow> (A ===> A ===> (\<longrightarrow>)) (=) (=)"
   unfolding right_unique_alt_def2 .
 
 text \<open>Transfer rules using equality.\<close>
 
 lemma left_unique_transfer [transfer_rule]:
   assumes "right_total A"
   assumes "right_total B"
   assumes "bi_unique A"
   shows "((A ===> B ===> (=)) ===> implies) left_unique left_unique"
   using assms unfolding left_unique_def right_total_def bi_unique_def rel_fun_def
   by metis
 
 lemma eq_transfer [transfer_rule]:
   assumes "bi_unique A"
   shows "(A ===> A ===> (=)) (=) (=)"
   using assms unfolding bi_unique_def rel_fun_def by auto
 
 lemma right_total_Ex_transfer[transfer_rule]:
   assumes "right_total A"
   shows "((A ===> (=)) ===> (=)) (Bex (Collect (Domainp A))) Ex"
   using assms unfolding right_total_def Bex_def rel_fun_def Domainp_iff
   by fast
 
 lemma right_total_All_transfer[transfer_rule]:
   assumes "right_total A"
   shows "((A ===> (=)) ===> (=)) (Ball (Collect (Domainp A))) All"
   using assms unfolding right_total_def Ball_def rel_fun_def Domainp_iff
   by fast
 
 context
   includes lifting_syntax
 begin
 
 lemma right_total_fun_eq_transfer:
   assumes [transfer_rule]: "right_total A" "bi_unique B"
   shows "((A ===> B) ===> (A ===> B) ===> (=)) (\<lambda>f g. \<forall>x\<in>Collect(Domainp A). f x = g x) (=)"
   unfolding fun_eq_iff
   by transfer_prover
 
 end
 
 lemma All_transfer [transfer_rule]:
   assumes "bi_total A"
   shows "((A ===> (=)) ===> (=)) All All"
   using assms unfolding bi_total_def rel_fun_def by fast
 
 lemma Ex_transfer [transfer_rule]:
   assumes "bi_total A"
   shows "((A ===> (=)) ===> (=)) Ex Ex"
   using assms unfolding bi_total_def rel_fun_def by fast
 
 lemma Ex1_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "bi_total A"
   shows "((A ===> (=)) ===> (=)) Ex1 Ex1"
 unfolding Ex1_def by transfer_prover
 
 declare If_transfer [transfer_rule]
 
 lemma Let_transfer [transfer_rule]: "(A ===> (A ===> B) ===> B) Let Let"
   unfolding rel_fun_def by simp
 
 declare id_transfer [transfer_rule]
 
 declare comp_transfer [transfer_rule]
 
 lemma curry_transfer [transfer_rule]:
   "((rel_prod A B ===> C) ===> A ===> B ===> C) curry curry"
   unfolding curry_def by transfer_prover
 
 lemma fun_upd_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "((A ===> B) ===> A ===> B ===> A ===> B) fun_upd fun_upd"
   unfolding fun_upd_def  by transfer_prover
 
 lemma case_nat_transfer [transfer_rule]:
   "(A ===> ((=) ===> A) ===> (=) ===> A) case_nat case_nat"
   unfolding rel_fun_def by (simp split: nat.split)
 
 lemma rec_nat_transfer [transfer_rule]:
   "(A ===> ((=) ===> A ===> A) ===> (=) ===> A) rec_nat rec_nat"
-  unfolding rel_fun_def by (clarsimp, rename_tac n, induct_tac n, simp_all)
+  unfolding rel_fun_def
+  apply safe
+  subgoal for _ _ _ _ _ n
+    by (induction n) simp_all
+  done
+
 
 lemma funpow_transfer [transfer_rule]:
   "((=) ===> (A ===> A) ===> (A ===> A)) compow compow"
   unfolding funpow_def by transfer_prover
 
 lemma mono_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_total A"
   assumes [transfer_rule]: "(A ===> A ===> (=)) (\<le>) (\<le>)"
   assumes [transfer_rule]: "(B ===> B ===> (=)) (\<le>) (\<le>)"
   shows "((A ===> B) ===> (=)) mono mono"
 unfolding mono_def by transfer_prover
 
 lemma right_total_relcompp_transfer[transfer_rule]:
   assumes [transfer_rule]: "right_total B"
   shows "((A ===> B ===> (=)) ===> (B ===> C ===> (=)) ===> A ===> C ===> (=))
     (\<lambda>R S x z. \<exists>y\<in>Collect (Domainp B). R x y \<and> S y z) (OO)"
 unfolding OO_def by transfer_prover
 
 lemma relcompp_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_total B"
   shows "((A ===> B ===> (=)) ===> (B ===> C ===> (=)) ===> A ===> C ===> (=)) (OO) (OO)"
 unfolding OO_def by transfer_prover
 
 lemma right_total_Domainp_transfer[transfer_rule]:
   assumes [transfer_rule]: "right_total B"
   shows "((A ===> B ===> (=)) ===> A ===> (=)) (\<lambda>T x. \<exists>y\<in>Collect(Domainp B). T x y) Domainp"
 apply(subst(2) Domainp_iff[abs_def]) by transfer_prover
 
 lemma Domainp_transfer[transfer_rule]:
   assumes [transfer_rule]: "bi_total B"
   shows "((A ===> B ===> (=)) ===> A ===> (=)) Domainp Domainp"
 unfolding Domainp_iff by transfer_prover
 
 lemma reflp_transfer[transfer_rule]:
   "bi_total A \<Longrightarrow> ((A ===> A ===> (=)) ===> (=)) reflp reflp"
   "right_total A \<Longrightarrow> ((A ===> A ===> implies) ===> implies) reflp reflp"
   "right_total A \<Longrightarrow> ((A ===> A ===> (=)) ===> implies) reflp reflp"
   "bi_total A \<Longrightarrow> ((A ===> A ===> rev_implies) ===> rev_implies) reflp reflp"
   "bi_total A \<Longrightarrow> ((A ===> A ===> (=)) ===> rev_implies) reflp reflp"
 unfolding reflp_def rev_implies_def bi_total_def right_total_def rel_fun_def
 by fast+
 
 lemma right_unique_transfer [transfer_rule]:
   "\<lbrakk> right_total A; right_total B; bi_unique B \<rbrakk>
   \<Longrightarrow> ((A ===> B ===> (=)) ===> implies) right_unique right_unique"
 unfolding right_unique_def right_total_def bi_unique_def rel_fun_def
 by metis
 
 lemma left_total_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A" "bi_total B"
   shows "((A ===> B ===> (=)) ===> (=)) left_total left_total"
 unfolding left_total_def by transfer_prover
 
 lemma right_total_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A" "bi_total B"
   shows "((A ===> B ===> (=)) ===> (=)) right_total right_total"
 unfolding right_total_def by transfer_prover
 
 lemma left_unique_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A" "bi_total A" "bi_total B"
   shows "((A ===> B ===> (=)) ===> (=)) left_unique left_unique"
 unfolding left_unique_def by transfer_prover
 
 lemma prod_pred_parametric [transfer_rule]:
   "((A ===> (=)) ===> (B ===> (=)) ===> rel_prod A B ===> (=)) pred_prod pred_prod"
 unfolding prod.pred_set Basic_BNFs.fsts_def Basic_BNFs.snds_def fstsp.simps sndsp.simps 
 by simp transfer_prover
 
 lemma apfst_parametric [transfer_rule]:
   "((A ===> B) ===> rel_prod A C ===> rel_prod B C) apfst apfst"
 unfolding apfst_def by transfer_prover
 
 lemma rel_fun_eq_eq_onp: "((=) ===> eq_onp P) = eq_onp (\<lambda>f. \<forall>x. P(f x))"
 unfolding eq_onp_def rel_fun_def by auto
 
 lemma rel_fun_eq_onp_rel:
   shows "((eq_onp R) ===> S) = (\<lambda>f g. \<forall>x. R x \<longrightarrow> S (f x) (g x))"
 by (auto simp add: eq_onp_def rel_fun_def)
 
 lemma eq_onp_transfer [transfer_rule]:
   assumes [transfer_rule]: "bi_unique A"
   shows "((A ===> (=)) ===> A ===> A ===> (=)) eq_onp eq_onp"
 unfolding eq_onp_def by transfer_prover
 
 lemma rtranclp_parametric [transfer_rule]:
   assumes "bi_unique A" "bi_total A"
   shows "((A ===> A ===> (=)) ===> A ===> A ===> (=)) rtranclp rtranclp"
 proof(rule rel_funI iffI)+
   fix R :: "'a \<Rightarrow> 'a \<Rightarrow> bool" and R' x y x' y'
   assume R: "(A ===> A ===> (=)) R R'" and "A x x'"
   {
     assume "R\<^sup>*\<^sup>* x y" "A y y'"
     thus "R'\<^sup>*\<^sup>* x' y'"
     proof(induction arbitrary: y')
       case base
       with \<open>bi_unique A\<close> \<open>A x x'\<close> have "x' = y'" by(rule bi_uniqueDr)
       thus ?case by simp
     next
       case (step y z z')
       from \<open>bi_total A\<close> obtain y' where "A y y'" unfolding bi_total_def by blast
       hence "R'\<^sup>*\<^sup>* x' y'" by(rule step.IH)
       moreover from R \<open>A y y'\<close> \<open>A z z'\<close> \<open>R y z\<close>
       have "R' y' z'" by(auto dest: rel_funD)
       ultimately show ?case ..
     qed
   next
     assume "R'\<^sup>*\<^sup>* x' y'" "A y y'"
     thus "R\<^sup>*\<^sup>* x y"
     proof(induction arbitrary: y)
       case base
       with \<open>bi_unique A\<close> \<open>A x x'\<close> have "x = y" by(rule bi_uniqueDl)
       thus ?case by simp
     next
       case (step y' z' z)
       from \<open>bi_total A\<close> obtain y where "A y y'" unfolding bi_total_def by blast
       hence "R\<^sup>*\<^sup>* x y" by(rule step.IH)
       moreover from R \<open>A y y'\<close> \<open>A z z'\<close> \<open>R' y' z'\<close>
       have "R y z" by(auto dest: rel_funD)
       ultimately show ?case ..
     qed
   }
 qed
 
 lemma right_unique_parametric [transfer_rule]:
   assumes [transfer_rule]: "bi_total A" "bi_unique B" "bi_total B"
   shows "((A ===> B ===> (=)) ===> (=)) right_unique right_unique"
   unfolding right_unique_def by transfer_prover
 
 lemma map_fun_parametric [transfer_rule]:
   "((A ===> B) ===> (C ===> D) ===> (B ===> C) ===> A ===> D) map_fun map_fun"
   unfolding map_fun_def by transfer_prover
 
 end
 
 
 subsection \<open>\<^const>\<open>of_bool\<close> and \<^const>\<open>of_nat\<close>\<close>
 
 context
   includes lifting_syntax
 begin
 
 lemma transfer_rule_of_bool:
   \<open>((\<longleftrightarrow>) ===> (\<cong>)) of_bool of_bool\<close>
     if [transfer_rule]: \<open>0 \<cong> 0\<close> \<open>1 \<cong> 1\<close>
     for R :: \<open>'a::zero_neq_one \<Rightarrow> 'b::zero_neq_one \<Rightarrow> bool\<close>  (infix \<open>\<cong>\<close> 50)
   unfolding of_bool_def by transfer_prover
 
 lemma transfer_rule_of_nat:
   "((=) ===> (\<cong>)) of_nat of_nat"
     if [transfer_rule]: \<open>0 \<cong> 0\<close> \<open>1 \<cong> 1\<close>
     \<open>((\<cong>) ===> (\<cong>) ===> (\<cong>)) (+) (+)\<close>
   for R :: \<open>'a::semiring_1 \<Rightarrow> 'b::semiring_1 \<Rightarrow> bool\<close>  (infix \<open>\<cong>\<close> 50)
   unfolding of_nat_def by transfer_prover
 
 end
 
 end
diff --git a/src/HOL/Transitive_Closure.thy b/src/HOL/Transitive_Closure.thy
--- a/src/HOL/Transitive_Closure.thy
+++ b/src/HOL/Transitive_Closure.thy
@@ -1,1362 +1,1363 @@
 (*  Title:      HOL/Transitive_Closure.thy
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Copyright   1992  University of Cambridge
 *)
 
 section \<open>Reflexive and Transitive closure of a relation\<close>
 
 theory Transitive_Closure
   imports Relation
   abbrevs "^*" = "\<^sup>*" "\<^sup>*\<^sup>*"
     and "^+" = "\<^sup>+" "\<^sup>+\<^sup>+"
     and "^=" = "\<^sup>=" "\<^sup>=\<^sup>="
 begin
 
 ML_file \<open>~~/src/Provers/trancl.ML\<close>
 
 text \<open>
   \<open>rtrancl\<close> is reflexive/transitive closure,
   \<open>trancl\<close> is transitive closure,
   \<open>reflcl\<close> is reflexive closure.
 
   These postfix operators have \<^emph>\<open>maximum priority\<close>, forcing their
   operands to be atomic.
 \<close>
 
 context notes [[inductive_internals]]
 begin
 
 inductive_set rtrancl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"  ("(_\<^sup>*)" [1000] 999)
   for r :: "('a \<times> 'a) set"
   where
     rtrancl_refl [intro!, Pure.intro!, simp]: "(a, a) \<in> r\<^sup>*"
   | rtrancl_into_rtrancl [Pure.intro]: "(a, b) \<in> r\<^sup>* \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> (a, c) \<in> r\<^sup>*"
 
 inductive_set trancl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"  ("(_\<^sup>+)" [1000] 999)
   for r :: "('a \<times> 'a) set"
   where
     r_into_trancl [intro, Pure.intro]: "(a, b) \<in> r \<Longrightarrow> (a, b) \<in> r\<^sup>+"
   | trancl_into_trancl [Pure.intro]: "(a, b) \<in> r\<^sup>+ \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> (a, c) \<in> r\<^sup>+"
 
 notation
   rtranclp  ("(_\<^sup>*\<^sup>*)" [1000] 1000) and
   tranclp  ("(_\<^sup>+\<^sup>+)" [1000] 1000)
 
 declare
   rtrancl_def [nitpick_unfold del]
   rtranclp_def [nitpick_unfold del]
   trancl_def [nitpick_unfold del]
   tranclp_def [nitpick_unfold del]
 
 end
 
 abbreviation reflcl :: "('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"  ("(_\<^sup>=)" [1000] 999)
   where "r\<^sup>= \<equiv> r \<union> Id"
 
 abbreviation reflclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  ("(_\<^sup>=\<^sup>=)" [1000] 1000)
   where "r\<^sup>=\<^sup>= \<equiv> sup r (=)"
 
 notation (ASCII)
   rtrancl  ("(_^*)" [1000] 999) and
   trancl  ("(_^+)" [1000] 999) and
   reflcl  ("(_^=)" [1000] 999) and
   rtranclp  ("(_^**)" [1000] 1000) and
   tranclp  ("(_^++)" [1000] 1000) and
   reflclp  ("(_^==)" [1000] 1000)
 
 
 subsection \<open>Reflexive closure\<close>
 
 lemma refl_reflcl[simp]: "refl (r\<^sup>=)"
   by (simp add: refl_on_def)
 
 lemma antisym_reflcl[simp]: "antisym (r\<^sup>=) = antisym r"
   by (simp add: antisym_def)
 
 lemma trans_reflclI[simp]: "trans r \<Longrightarrow> trans (r\<^sup>=)"
   unfolding trans_def by blast
 
 lemma reflclp_idemp [simp]: "(P\<^sup>=\<^sup>=)\<^sup>=\<^sup>= = P\<^sup>=\<^sup>="
   by blast
 
 
 subsection \<open>Reflexive-transitive closure\<close>
 
 lemma reflcl_set_eq [pred_set_conv]: "(sup (\<lambda>x y. (x, y) \<in> r) (=)) = (\<lambda>x y. (x, y) \<in> r \<union> Id)"
   by (auto simp: fun_eq_iff)
 
 lemma r_into_rtrancl [intro]: "\<And>p. p \<in> r \<Longrightarrow> p \<in> r\<^sup>*"
   \<comment> \<open>\<open>rtrancl\<close> of \<open>r\<close> contains \<open>r\<close>\<close>
   by (simp add: split_tupled_all rtrancl_refl [THEN rtrancl_into_rtrancl])
 
 lemma r_into_rtranclp [intro]: "r x y \<Longrightarrow> r\<^sup>*\<^sup>* x y"
   \<comment> \<open>\<open>rtrancl\<close> of \<open>r\<close> contains \<open>r\<close>\<close>
   by (erule rtranclp.rtrancl_refl [THEN rtranclp.rtrancl_into_rtrancl])
 
 lemma rtranclp_mono: "r \<le> s \<Longrightarrow> r\<^sup>*\<^sup>* \<le> s\<^sup>*\<^sup>*"
   \<comment> \<open>monotonicity of \<open>rtrancl\<close>\<close>
 proof (rule predicate2I)
   show "s\<^sup>*\<^sup>* x y" if "r \<le> s" "r\<^sup>*\<^sup>* x y" for x y
     using \<open>r\<^sup>*\<^sup>* x y\<close> \<open>r \<le> s\<close>
     by (induction rule: rtranclp.induct) (blast intro: rtranclp.rtrancl_into_rtrancl)+
 qed
 
 lemma mono_rtranclp[mono]: "(\<And>a b. x a b \<longrightarrow> y a b) \<Longrightarrow> x\<^sup>*\<^sup>* a b \<longrightarrow> y\<^sup>*\<^sup>* a b"
    using rtranclp_mono[of x y] by auto
 
 lemmas rtrancl_mono = rtranclp_mono [to_set]
 
 theorem rtranclp_induct [consumes 1, case_names base step, induct set: rtranclp]:
   assumes a: "r\<^sup>*\<^sup>* a b"
     and cases: "P a" "\<And>y z. r\<^sup>*\<^sup>* a y \<Longrightarrow> r y z \<Longrightarrow> P y \<Longrightarrow> P z"
   shows "P b"
   using a by (induct x\<equiv>a b) (rule cases)+
 
 lemmas rtrancl_induct [induct set: rtrancl] = rtranclp_induct [to_set]
 
 lemmas rtranclp_induct2 =
   rtranclp_induct[of _ "(ax,ay)" "(bx,by)", split_rule, consumes 1, case_names refl step]
 
 lemmas rtrancl_induct2 =
   rtrancl_induct[of "(ax,ay)" "(bx,by)", split_format (complete), consumes 1, case_names refl step]
 
 lemma refl_rtrancl: "refl (r\<^sup>*)"
   unfolding refl_on_def by fast
 
 text \<open>Transitivity of transitive closure.\<close>
 lemma trans_rtrancl: "trans (r\<^sup>*)"
 proof (rule transI)
   fix x y z
   assume "(x, y) \<in> r\<^sup>*"
   assume "(y, z) \<in> r\<^sup>*"
   then show "(x, z) \<in> r\<^sup>*"
   proof induct
     case base
     show "(x, y) \<in> r\<^sup>*" by fact
   next
     case (step u v)
     from \<open>(x, u) \<in> r\<^sup>*\<close> and \<open>(u, v) \<in> r\<close>
     show "(x, v) \<in> r\<^sup>*" ..
   qed
 qed
 
 lemmas rtrancl_trans = trans_rtrancl [THEN transD]
 
 lemma rtranclp_trans:
   assumes "r\<^sup>*\<^sup>* x y"
     and "r\<^sup>*\<^sup>* y z"
   shows "r\<^sup>*\<^sup>* x z"
   using assms(2,1) by induct iprover+
 
 lemma rtranclE [cases set: rtrancl]:
   fixes a b :: 'a
   assumes major: "(a, b) \<in> r\<^sup>*"
   obtains
     (base) "a = b"
   | (step) y where "(a, y) \<in> r\<^sup>*" and "(y, b) \<in> r"
   \<comment> \<open>elimination of \<open>rtrancl\<close> -- by induction on a special formula\<close>
 proof -
   have "a = b \<or> (\<exists>y. (a, y) \<in> r\<^sup>* \<and> (y, b) \<in> r)"
     by (rule major [THEN rtrancl_induct]) blast+
   then show ?thesis
     by (auto intro: base step)
 qed
 
 lemma rtrancl_Int_subset: "Id \<subseteq> s \<Longrightarrow> (r\<^sup>* \<inter> s) O r \<subseteq> s \<Longrightarrow> r\<^sup>* \<subseteq> s"
   by (fastforce elim: rtrancl_induct)
 
 lemma converse_rtranclp_into_rtranclp: "r a b \<Longrightarrow> r\<^sup>*\<^sup>* b c \<Longrightarrow> r\<^sup>*\<^sup>* a c"
   by (rule rtranclp_trans) iprover+
 
 lemmas converse_rtrancl_into_rtrancl = converse_rtranclp_into_rtranclp [to_set]
 
 text \<open>\<^medskip> More \<^term>\<open>r\<^sup>*\<close> equations and inclusions.\<close>
 
 lemma rtranclp_idemp [simp]: "(r\<^sup>*\<^sup>*)\<^sup>*\<^sup>* = r\<^sup>*\<^sup>*"
 proof -
   have "r\<^sup>*\<^sup>*\<^sup>*\<^sup>* x y \<Longrightarrow> r\<^sup>*\<^sup>* x y" for x y
     by (induction rule: rtranclp_induct) (blast intro: rtranclp_trans)+
   then show ?thesis
     by (auto intro!: order_antisym)
 qed
 
 lemmas rtrancl_idemp [simp] = rtranclp_idemp [to_set]
 
 lemma rtrancl_idemp_self_comp [simp]: "R\<^sup>* O R\<^sup>* = R\<^sup>*"
   by (force intro: rtrancl_trans)
 
 lemma rtrancl_subset_rtrancl: "r \<subseteq> s\<^sup>* \<Longrightarrow> r\<^sup>* \<subseteq> s\<^sup>*"
   by (drule rtrancl_mono, simp)
 
 lemma rtranclp_subset: "R \<le> S \<Longrightarrow> S \<le> R\<^sup>*\<^sup>* \<Longrightarrow> S\<^sup>*\<^sup>* = R\<^sup>*\<^sup>*"
   by (fastforce dest: rtranclp_mono)
 
 lemmas rtrancl_subset = rtranclp_subset [to_set]
 
 lemma rtranclp_sup_rtranclp: "(sup (R\<^sup>*\<^sup>*) (S\<^sup>*\<^sup>*))\<^sup>*\<^sup>* = (sup R S)\<^sup>*\<^sup>*"
   by (blast intro!: rtranclp_subset intro: rtranclp_mono [THEN predicate2D])
 
 lemmas rtrancl_Un_rtrancl = rtranclp_sup_rtranclp [to_set]
 
 lemma rtranclp_reflclp [simp]: "(R\<^sup>=\<^sup>=)\<^sup>*\<^sup>* = R\<^sup>*\<^sup>*"
   by (blast intro!: rtranclp_subset)
 
 lemmas rtrancl_reflcl [simp] = rtranclp_reflclp [to_set]
 
 lemma rtrancl_r_diff_Id: "(r - Id)\<^sup>* = r\<^sup>*"
   by (rule rtrancl_subset [symmetric]) auto
 
 lemma rtranclp_r_diff_Id: "(inf r (\<noteq>))\<^sup>*\<^sup>* = r\<^sup>*\<^sup>*"
   by (rule rtranclp_subset [symmetric]) auto
 
 theorem rtranclp_converseD:
   assumes "(r\<inverse>\<inverse>)\<^sup>*\<^sup>* x y"
   shows "r\<^sup>*\<^sup>* y x"
   using assms by induct (iprover intro: rtranclp_trans dest!: conversepD)+
 
 lemmas rtrancl_converseD = rtranclp_converseD [to_set]
 
 theorem rtranclp_converseI:
   assumes "r\<^sup>*\<^sup>* y x"
   shows "(r\<inverse>\<inverse>)\<^sup>*\<^sup>* x y"
   using assms by induct (iprover intro: rtranclp_trans conversepI)+
 
 lemmas rtrancl_converseI = rtranclp_converseI [to_set]
 
 lemma rtrancl_converse: "(r\<inverse>)\<^sup>* = (r\<^sup>*)\<inverse>"
   by (fast dest!: rtrancl_converseD intro!: rtrancl_converseI)
 
 lemma sym_rtrancl: "sym r \<Longrightarrow> sym (r\<^sup>*)"
   by (simp only: sym_conv_converse_eq rtrancl_converse [symmetric])
 
 theorem converse_rtranclp_induct [consumes 1, case_names base step]:
   assumes major: "r\<^sup>*\<^sup>* a b"
     and cases: "P b" "\<And>y z. r y z \<Longrightarrow> r\<^sup>*\<^sup>* z b \<Longrightarrow> P z \<Longrightarrow> P y"
   shows "P a"
   using rtranclp_converseI [OF major]
   by induct (iprover intro: cases dest!: conversepD rtranclp_converseD)+
 
 lemmas converse_rtrancl_induct = converse_rtranclp_induct [to_set]
 
 lemmas converse_rtranclp_induct2 =
   converse_rtranclp_induct [of _ "(ax, ay)" "(bx, by)", split_rule, consumes 1, case_names refl step]
 
 lemmas converse_rtrancl_induct2 =
   converse_rtrancl_induct [of "(ax, ay)" "(bx, by)", split_format (complete),
     consumes 1, case_names refl step]
 
 lemma converse_rtranclpE [consumes 1, case_names base step]:
   assumes major: "r\<^sup>*\<^sup>* x z"
     and cases: "x = z \<Longrightarrow> P" "\<And>y. r x y \<Longrightarrow> r\<^sup>*\<^sup>* y z \<Longrightarrow> P"
   shows P
 proof -
   have "x = z \<or> (\<exists>y. r x y \<and> r\<^sup>*\<^sup>* y z)"
-    by (rule_tac major [THEN converse_rtranclp_induct]) iprover+
+    by (rule major [THEN converse_rtranclp_induct]) iprover+
   then show ?thesis
     by (auto intro: cases)
 qed
 
 lemmas converse_rtranclE = converse_rtranclpE [to_set]
 
 lemmas converse_rtranclpE2 = converse_rtranclpE [of _ "(xa,xb)" "(za,zb)", split_rule]
 
 lemmas converse_rtranclE2 = converse_rtranclE [of "(xa,xb)" "(za,zb)", split_rule]
 
 lemma r_comp_rtrancl_eq: "r O r\<^sup>* = r\<^sup>* O r"
   by (blast elim: rtranclE converse_rtranclE
       intro: rtrancl_into_rtrancl converse_rtrancl_into_rtrancl)
 
 lemma rtrancl_unfold: "r\<^sup>* = Id \<union> r\<^sup>* O r"
   by (auto intro: rtrancl_into_rtrancl elim: rtranclE)
 
 lemma rtrancl_Un_separatorE:
   "(a, b) \<in> (P \<union> Q)\<^sup>* \<Longrightarrow> \<forall>x y. (a, x) \<in> P\<^sup>* \<longrightarrow> (x, y) \<in> Q \<longrightarrow> x = y \<Longrightarrow> (a, b) \<in> P\<^sup>*"
 proof (induct rule: rtrancl.induct)
   case rtrancl_refl
   then show ?case by blast
 next
   case rtrancl_into_rtrancl
   then show ?case by (blast intro: rtrancl_trans)
 qed
 
 lemma rtrancl_Un_separator_converseE:
   "(a, b) \<in> (P \<union> Q)\<^sup>* \<Longrightarrow> \<forall>x y. (x, b) \<in> P\<^sup>* \<longrightarrow> (y, x) \<in> Q \<longrightarrow> y = x \<Longrightarrow> (a, b) \<in> P\<^sup>*"
 proof (induct rule: converse_rtrancl_induct)
   case base
   then show ?case by blast
 next
   case step
   then show ?case by (blast intro: rtrancl_trans)
 qed
 
 lemma Image_closed_trancl:
   assumes "r `` X \<subseteq> X"
   shows "r\<^sup>* `` X = X"
 proof -
   from assms have **: "{y. \<exists>x\<in>X. (x, y) \<in> r} \<subseteq> X"
     by auto
   have "x \<in> X" if 1: "(y, x) \<in> r\<^sup>*" and 2: "y \<in> X" for x y
   proof -
     from 1 show "x \<in> X"
     proof induct
       case base
       show ?case by (fact 2)
     next
       case step
       with ** show ?case by auto
     qed
   qed
   then show ?thesis by auto
 qed
 
 
 subsection \<open>Transitive closure\<close>
 
 lemma totalp_on_tranclp: "totalp_on A R \<Longrightarrow> totalp_on A (tranclp R)"
   by (auto intro: totalp_onI dest: totalp_onD)
 
 lemma total_on_trancl: "total_on A r \<Longrightarrow> total_on A (trancl r)"
   by (rule totalp_on_tranclp[to_set])
 
 lemma trancl_mono:
   assumes "p \<in> r\<^sup>+" "r \<subseteq> s"
   shows "p \<in> s\<^sup>+"
 proof -
   have "\<lbrakk>(a, b) \<in> r\<^sup>+; r \<subseteq> s\<rbrakk> \<Longrightarrow> (a, b) \<in> s\<^sup>+" for a b
     by (induction rule: trancl.induct) (iprover dest: subsetD)+
   with assms show ?thesis
     by (cases p) force
 qed
 
 lemma r_into_trancl': "\<And>p. p \<in> r \<Longrightarrow> p \<in> r\<^sup>+"
   by (simp only: split_tupled_all) (erule r_into_trancl)
 
 text \<open>\<^medskip> Conversions between \<open>trancl\<close> and \<open>rtrancl\<close>.\<close>
 
 lemma tranclp_into_rtranclp: "r\<^sup>+\<^sup>+ a b \<Longrightarrow> r\<^sup>*\<^sup>* a b"
   by (erule tranclp.induct) iprover+
 
 lemmas trancl_into_rtrancl = tranclp_into_rtranclp [to_set]
 
 lemma rtranclp_into_tranclp1:
   assumes "r\<^sup>*\<^sup>* a b"
   shows "r b c \<Longrightarrow> r\<^sup>+\<^sup>+ a c"
   using assms by (induct arbitrary: c) iprover+
 
 lemmas rtrancl_into_trancl1 = rtranclp_into_tranclp1 [to_set]
 
 lemma rtranclp_into_tranclp2:
   assumes "r a b" "r\<^sup>*\<^sup>* b c" shows "r\<^sup>+\<^sup>+ a c"
   \<comment> \<open>intro rule from \<open>r\<close> and \<open>rtrancl\<close>\<close>
   using \<open>r\<^sup>*\<^sup>* b c\<close>
 proof (cases rule: rtranclp.cases)
   case rtrancl_refl
   with assms show ?thesis
     by iprover
 next
   case rtrancl_into_rtrancl
   with assms show ?thesis
     by (auto intro: rtranclp_trans [THEN rtranclp_into_tranclp1])
 qed
 
 lemmas rtrancl_into_trancl2 = rtranclp_into_tranclp2 [to_set]
 
 text \<open>Nice induction rule for \<open>trancl\<close>\<close>
 lemma tranclp_induct [consumes 1, case_names base step, induct pred: tranclp]:
   assumes a: "r\<^sup>+\<^sup>+ a b"
     and cases: "\<And>y. r a y \<Longrightarrow> P y" "\<And>y z. r\<^sup>+\<^sup>+ a y \<Longrightarrow> r y z \<Longrightarrow> P y \<Longrightarrow> P z"
   shows "P b"
   using a by (induct x\<equiv>a b) (iprover intro: cases)+
 
 lemmas trancl_induct [induct set: trancl] = tranclp_induct [to_set]
 
 lemmas tranclp_induct2 =
   tranclp_induct [of _ "(ax, ay)" "(bx, by)", split_rule, consumes 1, case_names base step]
 
 lemmas trancl_induct2 =
   trancl_induct [of "(ax, ay)" "(bx, by)", split_format (complete),
     consumes 1, case_names base step]
 
 lemma tranclp_trans_induct:
   assumes major: "r\<^sup>+\<^sup>+ x y"
     and cases: "\<And>x y. r x y \<Longrightarrow> P x y" "\<And>x y z. r\<^sup>+\<^sup>+ x y \<Longrightarrow> P x y \<Longrightarrow> r\<^sup>+\<^sup>+ y z \<Longrightarrow> P y z \<Longrightarrow> P x z"
   shows "P x y"
   \<comment> \<open>Another induction rule for trancl, incorporating transitivity\<close>
   by (iprover intro: major [THEN tranclp_induct] cases)
 
 lemmas trancl_trans_induct = tranclp_trans_induct [to_set]
 
 lemma tranclE [cases set: trancl]:
   assumes "(a, b) \<in> r\<^sup>+"
   obtains
     (base) "(a, b) \<in> r"
   | (step) c where "(a, c) \<in> r\<^sup>+" and "(c, b) \<in> r"
   using assms by cases simp_all
 
 lemma trancl_Int_subset: "r \<subseteq> s \<Longrightarrow> (r\<^sup>+ \<inter> s) O r \<subseteq> s \<Longrightarrow> r\<^sup>+ \<subseteq> s"
   by (fastforce simp add: elim: trancl_induct)
 
 lemma trancl_unfold: "r\<^sup>+ = r \<union> r\<^sup>+ O r"
   by (auto intro: trancl_into_trancl elim: tranclE)
 
 text \<open>Transitivity of \<^term>\<open>r\<^sup>+\<close>\<close>
 lemma trans_trancl [simp]: "trans (r\<^sup>+)"
 proof (rule transI)
   fix x y z
   assume "(x, y) \<in> r\<^sup>+"
   assume "(y, z) \<in> r\<^sup>+"
   then show "(x, z) \<in> r\<^sup>+"
   proof induct
     case (base u)
     from \<open>(x, y) \<in> r\<^sup>+\<close> and \<open>(y, u) \<in> r\<close>
     show "(x, u) \<in> r\<^sup>+" ..
   next
     case (step u v)
     from \<open>(x, u) \<in> r\<^sup>+\<close> and \<open>(u, v) \<in> r\<close>
     show "(x, v) \<in> r\<^sup>+" ..
   qed
 qed
 
 lemmas trancl_trans = trans_trancl [THEN transD]
 
 lemma tranclp_trans:
   assumes "r\<^sup>+\<^sup>+ x y"
     and "r\<^sup>+\<^sup>+ y z"
   shows "r\<^sup>+\<^sup>+ x z"
   using assms(2,1) by induct iprover+
 
 lemma trancl_id [simp]: "trans r \<Longrightarrow> r\<^sup>+ = r"
   unfolding trans_def by (fastforce simp add: elim: trancl_induct)
 
 lemma rtranclp_tranclp_tranclp:
   assumes "r\<^sup>*\<^sup>* x y"
   shows "\<And>z. r\<^sup>+\<^sup>+ y z \<Longrightarrow> r\<^sup>+\<^sup>+ x z"
   using assms by induct (iprover intro: tranclp_trans)+
 
 lemmas rtrancl_trancl_trancl = rtranclp_tranclp_tranclp [to_set]
 
 lemma tranclp_into_tranclp2: "r a b \<Longrightarrow> r\<^sup>+\<^sup>+ b c \<Longrightarrow> r\<^sup>+\<^sup>+ a c"
   by (erule tranclp_trans [OF tranclp.r_into_trancl])
 
 lemmas trancl_into_trancl2 = tranclp_into_tranclp2 [to_set]
 
 lemma tranclp_converseI:
   assumes "(r\<^sup>+\<^sup>+)\<inverse>\<inverse> x y" shows "(r\<inverse>\<inverse>)\<^sup>+\<^sup>+ x y"
   using conversepD [OF assms]
 proof (induction rule: tranclp_induct)
   case (base y)
   then show ?case 
     by (iprover intro: conversepI)
 next
   case (step y z)
   then show ?case
     by (iprover intro: conversepI tranclp_trans)
 qed
 
 lemmas trancl_converseI = tranclp_converseI [to_set]
 
 lemma tranclp_converseD:
   assumes "(r\<inverse>\<inverse>)\<^sup>+\<^sup>+ x y" shows "(r\<^sup>+\<^sup>+)\<inverse>\<inverse> x y"
 proof -
   have "r\<^sup>+\<^sup>+ y x"
     using assms
     by (induction rule: tranclp_induct) (iprover dest: conversepD intro: tranclp_trans)+
   then show ?thesis
     by (rule conversepI)
 qed
 
 lemmas trancl_converseD = tranclp_converseD [to_set]
 
 lemma tranclp_converse: "(r\<inverse>\<inverse>)\<^sup>+\<^sup>+ = (r\<^sup>+\<^sup>+)\<inverse>\<inverse>"
   by (fastforce simp add: fun_eq_iff intro!: tranclp_converseI dest!: tranclp_converseD)
 
 lemmas trancl_converse = tranclp_converse [to_set]
 
 lemma sym_trancl: "sym r \<Longrightarrow> sym (r\<^sup>+)"
   by (simp only: sym_conv_converse_eq trancl_converse [symmetric])
 
 lemma converse_tranclp_induct [consumes 1, case_names base step]:
   assumes major: "r\<^sup>+\<^sup>+ a b"
     and cases: "\<And>y. r y b \<Longrightarrow> P y" "\<And>y z. r y z \<Longrightarrow> r\<^sup>+\<^sup>+ z b \<Longrightarrow> P z \<Longrightarrow> P y"
   shows "P a"
 proof -
   have "r\<inverse>\<inverse>\<^sup>+\<^sup>+ b a"
     by (intro tranclp_converseI conversepI major)
   then show ?thesis
     by (induction rule: tranclp_induct) (blast intro: cases dest: tranclp_converseD)+
 qed
 
 lemmas converse_trancl_induct = converse_tranclp_induct [to_set]
 
 lemma tranclpD: "R\<^sup>+\<^sup>+ x y \<Longrightarrow> \<exists>z. R x z \<and> R\<^sup>*\<^sup>* z y"
 proof (induction rule: converse_tranclp_induct)
   case (step u v)
   then show ?case
     by (blast intro: rtranclp_trans)
 qed auto
 
 lemmas tranclD = tranclpD [to_set]
 
 lemma converse_tranclpE:
   assumes major: "tranclp r x z"
     and base: "r x z \<Longrightarrow> P"
     and step: "\<And>y. r x y \<Longrightarrow> tranclp r y z \<Longrightarrow> P"
   shows P
 proof -
   from tranclpD [OF major] obtain y where "r x y" and "rtranclp r y z"
     by iprover
   from this(2) show P
   proof (cases rule: rtranclp.cases)
     case rtrancl_refl
     with \<open>r x y\<close> base show P
       by iprover
   next
     case rtrancl_into_rtrancl
     then have "tranclp r y z"
       by (iprover intro: rtranclp_into_tranclp1)
     with \<open>r x y\<close> step show P
       by iprover
   qed
 qed
 
 lemmas converse_tranclE = converse_tranclpE [to_set]
 
 lemma tranclD2: "(x, y) \<in> R\<^sup>+ \<Longrightarrow> \<exists>z. (x, z) \<in> R\<^sup>* \<and> (z, y) \<in> R"
   by (blast elim: tranclE intro: trancl_into_rtrancl)
 
 lemma irrefl_tranclI: "r\<inverse> \<inter> r\<^sup>* = {} \<Longrightarrow> (x, x) \<notin> r\<^sup>+"
   by (blast elim: tranclE dest: trancl_into_rtrancl)
 
 lemma irrefl_trancl_rD: "\<forall>x. (x, x) \<notin> r\<^sup>+ \<Longrightarrow> (x, y) \<in> r \<Longrightarrow> x \<noteq> y"
   by (blast dest: r_into_trancl)
 
 lemma trancl_subset_Sigma_aux: "(a, b) \<in> r\<^sup>* \<Longrightarrow> r \<subseteq> A \<times> A \<Longrightarrow> a = b \<or> a \<in> A"
   by (induct rule: rtrancl_induct) auto
 
 lemma trancl_subset_Sigma:
   assumes "r \<subseteq> A \<times> A" shows "r\<^sup>+ \<subseteq> A \<times> A"
 proof (rule trancl_Int_subset [OF assms])
   show "(r\<^sup>+ \<inter> A \<times> A) O r \<subseteq> A \<times> A"
     using assms by auto
 qed
 
 lemma reflclp_tranclp [simp]: "(r\<^sup>+\<^sup>+)\<^sup>=\<^sup>= = r\<^sup>*\<^sup>*"
   by (fast elim: rtranclp.cases tranclp_into_rtranclp dest: rtranclp_into_tranclp1)
 
 lemmas reflcl_trancl [simp] = reflclp_tranclp [to_set]
 
 lemma trancl_reflcl [simp]: "(r\<^sup>=)\<^sup>+ = r\<^sup>*"
 proof -
   have "(a, b) \<in> (r\<^sup>=)\<^sup>+ \<Longrightarrow> (a, b) \<in> r\<^sup>*" for a b
     by (force dest: trancl_into_rtrancl)
   moreover have "(a, b) \<in> (r\<^sup>=)\<^sup>+" if "(a, b) \<in> r\<^sup>*" for a b
     using that
   proof (cases a b rule: rtranclE)
     case step
     show ?thesis
       by (rule rtrancl_into_trancl1) (use step in auto)
   qed auto
   ultimately show ?thesis
     by auto
 qed
 
 lemma rtrancl_trancl_reflcl [code]: "r\<^sup>* = (r\<^sup>+)\<^sup>="
   by simp
 
 lemma trancl_empty [simp]: "{}\<^sup>+ = {}"
   by (auto elim: trancl_induct)
 
 lemma rtrancl_empty [simp]: "{}\<^sup>* = Id"
   by (rule subst [OF reflcl_trancl]) simp
 
 lemma rtranclpD: "R\<^sup>*\<^sup>* a b \<Longrightarrow> a = b \<or> a \<noteq> b \<and> R\<^sup>+\<^sup>+ a b"
   by (force simp: reflclp_tranclp [symmetric] simp del: reflclp_tranclp)
 
 lemmas rtranclD = rtranclpD [to_set]
 
 lemma rtrancl_eq_or_trancl: "(x,y) \<in> R\<^sup>* \<longleftrightarrow> x = y \<or> x \<noteq> y \<and> (x, y) \<in> R\<^sup>+"
   by (fast elim: trancl_into_rtrancl dest: rtranclD)
 
 lemma trancl_unfold_right: "r\<^sup>+ = r\<^sup>* O r"
   by (auto dest: tranclD2 intro: rtrancl_into_trancl1)
 
 lemma trancl_unfold_left: "r\<^sup>+ = r O r\<^sup>*"
   by (auto dest: tranclD intro: rtrancl_into_trancl2)
 
 lemma trancl_insert: "(insert (y, x) r)\<^sup>+ = r\<^sup>+ \<union> {(a, b). (a, y) \<in> r\<^sup>* \<and> (x, b) \<in> r\<^sup>*}"
   \<comment> \<open>primitive recursion for \<open>trancl\<close> over finite relations\<close>
 proof -
   have "\<And>a b. (a, b) \<in> (insert (y, x) r)\<^sup>+ \<Longrightarrow>
            (a, b) \<in> r\<^sup>+ \<union> {(a, b). (a, y) \<in> r\<^sup>* \<and> (x, b) \<in> r\<^sup>*}"
     by (erule trancl_induct) (blast intro: rtrancl_into_trancl1 trancl_into_rtrancl trancl_trans)+
   moreover have "r\<^sup>+ \<union> {(a, b). (a, y) \<in> r\<^sup>* \<and> (x, b) \<in> r\<^sup>*}  \<subseteq> (insert (y, x) r)\<^sup>+"
     by (blast intro: trancl_mono rtrancl_mono [THEN [2] rev_subsetD]
                      rtrancl_trancl_trancl rtrancl_into_trancl2)
   ultimately show ?thesis
     by auto
 qed
 
 lemma trancl_insert2:
   "(insert (a, b) r)\<^sup>+ = r\<^sup>+ \<union> {(x, y). ((x, a) \<in> r\<^sup>+ \<or> x = a) \<and> ((b, y) \<in> r\<^sup>+ \<or> y = b)}"
   by (auto simp: trancl_insert rtrancl_eq_or_trancl)
 
 lemma rtrancl_insert: "(insert (a,b) r)\<^sup>* = r\<^sup>* \<union> {(x, y). (x, a) \<in> r\<^sup>* \<and> (b, y) \<in> r\<^sup>*}"
   using trancl_insert[of a b r]
   by (simp add: rtrancl_trancl_reflcl del: reflcl_trancl) blast
 
 
 text \<open>Simplifying nested closures\<close>
 
 lemma rtrancl_trancl_absorb[simp]: "(R\<^sup>*)\<^sup>+ = R\<^sup>*"
   by (simp add: trans_rtrancl)
 
 lemma trancl_rtrancl_absorb[simp]: "(R\<^sup>+)\<^sup>* = R\<^sup>*"
   by (subst reflcl_trancl[symmetric]) simp
 
 lemma rtrancl_reflcl_absorb[simp]: "(R\<^sup>*)\<^sup>= = R\<^sup>*"
   by auto
 
 
 text \<open>\<open>Domain\<close> and \<open>Range\<close>\<close>
 
 lemma Domain_rtrancl [simp]: "Domain (R\<^sup>*) = UNIV"
   by blast
 
 lemma Range_rtrancl [simp]: "Range (R\<^sup>*) = UNIV"
   by blast
 
 lemma rtrancl_Un_subset: "(R\<^sup>* \<union> S\<^sup>*) \<subseteq> (R \<union> S)\<^sup>*"
   by (rule rtrancl_Un_rtrancl [THEN subst]) fast
 
 lemma in_rtrancl_UnI: "x \<in> R\<^sup>* \<or> x \<in> S\<^sup>* \<Longrightarrow> x \<in> (R \<union> S)\<^sup>*"
   by (blast intro: subsetD [OF rtrancl_Un_subset])
 
 lemma trancl_domain [simp]: "Domain (r\<^sup>+) = Domain r"
   by (unfold Domain_unfold) (blast dest: tranclD)
 
 lemma trancl_range [simp]: "Range (r\<^sup>+) = Range r"
   unfolding Domain_converse [symmetric] by (simp add: trancl_converse [symmetric])
 
 lemma Not_Domain_rtrancl:
   assumes "x \<notin> Domain R" shows "(x, y) \<in> R\<^sup>* \<longleftrightarrow> x = y"
 proof -
 have "(x, y) \<in> R\<^sup>* \<Longrightarrow> x = y"
   by (erule rtrancl_induct) (use assms in auto)
   then show ?thesis
     by auto
 qed
 
 lemma trancl_subset_Field2: "r\<^sup>+ \<subseteq> Field r \<times> Field r"
   by (rule trancl_Int_subset) (auto simp: Field_def)
 
 lemma finite_trancl[simp]: "finite (r\<^sup>+) = finite r"
 proof
   show "finite (r\<^sup>+) \<Longrightarrow> finite r"
     by (blast intro: r_into_trancl' finite_subset)
   show "finite r \<Longrightarrow> finite (r\<^sup>+)"
     by (auto simp: finite_Field trancl_subset_Field2 [THEN finite_subset])
 qed
 
 lemma finite_rtrancl_Image[simp]: assumes "finite R" "finite A" shows "finite (R\<^sup>* `` A)"
 proof (rule ccontr)
   assume "infinite (R\<^sup>* `` A)"
   with assms show False
     by(simp add: rtrancl_trancl_reflcl Un_Image del: reflcl_trancl)
 qed
 
 text \<open>More about converse \<open>rtrancl\<close> and \<open>trancl\<close>, should
   be merged with main body.\<close>
 
 lemma single_valued_confluent:
   assumes "single_valued r" and xy: "(x, y) \<in> r\<^sup>*" and xz: "(x, z) \<in> r\<^sup>*"
   shows "(y, z) \<in> r\<^sup>* \<or> (z, y) \<in> r\<^sup>*"
   using xy
 proof (induction rule: rtrancl_induct)
   case base
   show ?case
     by (simp add: assms)
 next
   case (step y z)
   with xz \<open>single_valued r\<close> show ?case
     by (auto elim: converse_rtranclE dest: single_valuedD intro: rtrancl_trans)
 qed
 
 lemma r_r_into_trancl: "(a, b) \<in> R \<Longrightarrow> (b, c) \<in> R \<Longrightarrow> (a, c) \<in> R\<^sup>+"
   by (fast intro: trancl_trans)
 
 lemma trancl_into_trancl: "(a, b) \<in> r\<^sup>+ \<Longrightarrow> (b, c) \<in> r \<Longrightarrow> (a, c) \<in> r\<^sup>+"
   by (induct rule: trancl_induct) (fast intro: r_r_into_trancl trancl_trans)+
 
 lemma tranclp_rtranclp_tranclp:
   assumes "r\<^sup>+\<^sup>+ a b" "r\<^sup>*\<^sup>* b c" shows "r\<^sup>+\<^sup>+ a c"
 proof -
   obtain z where "r a z" "r\<^sup>*\<^sup>* z c"
     using assms by (iprover dest: tranclpD rtranclp_trans)
   then show ?thesis
     by (blast dest: rtranclp_into_tranclp2)
 qed
 
 lemma rtranclp_conversep: "r\<inverse>\<inverse>\<^sup>*\<^sup>* = r\<^sup>*\<^sup>*\<inverse>\<inverse>"
   by(auto simp add: fun_eq_iff intro: rtranclp_converseI rtranclp_converseD)
 
 lemmas symp_rtranclp = sym_rtrancl[to_pred]
 
 lemmas symp_conv_conversep_eq = sym_conv_converse_eq[to_pred]
 
 lemmas rtranclp_tranclp_absorb [simp] = rtrancl_trancl_absorb[to_pred]
 lemmas tranclp_rtranclp_absorb [simp] = trancl_rtrancl_absorb[to_pred]
 lemmas rtranclp_reflclp_absorb [simp] = rtrancl_reflcl_absorb[to_pred]
 
 lemmas trancl_rtrancl_trancl = tranclp_rtranclp_tranclp [to_set]
 
 lemmas transitive_closure_trans [trans] =
   r_r_into_trancl trancl_trans rtrancl_trans
   trancl.trancl_into_trancl trancl_into_trancl2
   rtrancl.rtrancl_into_rtrancl converse_rtrancl_into_rtrancl
   rtrancl_trancl_trancl trancl_rtrancl_trancl
 
 lemmas transitive_closurep_trans' [trans] =
   tranclp_trans rtranclp_trans
   tranclp.trancl_into_trancl tranclp_into_tranclp2
   rtranclp.rtrancl_into_rtrancl converse_rtranclp_into_rtranclp
   rtranclp_tranclp_tranclp tranclp_rtranclp_tranclp
 
 declare trancl_into_rtrancl [elim]
 
 subsection \<open>Symmetric closure\<close>
 
 definition symclp :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
 where "symclp r x y \<longleftrightarrow> r x y \<or> r y x"
 
 lemma symclpI [simp, intro?]:
   shows symclpI1: "r x y \<Longrightarrow> symclp r x y"
     and symclpI2: "r y x \<Longrightarrow> symclp r x y"
   by(simp_all add: symclp_def)
 
 lemma symclpE [consumes 1, cases pred]:
   assumes "symclp r x y"
   obtains (base) "r x y" | (sym) "r y x"
   using assms by(auto simp add: symclp_def)
 
 lemma symclp_pointfree: "symclp r = sup r r\<inverse>\<inverse>"
   by(auto simp add: symclp_def fun_eq_iff)
 
 lemma symclp_greater: "r \<le> symclp r"
   by(simp add: symclp_pointfree)
 
 lemma symclp_conversep [simp]: "symclp r\<inverse>\<inverse> = symclp r"
   by(simp add: symclp_pointfree sup.commute)
 
 lemma symp_symclp [simp]: "symp (symclp r)"
   by(auto simp add: symp_def elim: symclpE intro: symclpI)
 
 lemma symp_symclp_eq: "symp r \<Longrightarrow> symclp r = r"
   by(simp add: symclp_pointfree symp_conv_conversep_eq)
 
 lemma symp_rtranclp_symclp [simp]: "symp (symclp r)\<^sup>*\<^sup>*"
   by(simp add: symp_rtranclp)
 
 lemma rtranclp_symclp_sym [sym]: "(symclp r)\<^sup>*\<^sup>* x y \<Longrightarrow> (symclp r)\<^sup>*\<^sup>* y x"
   by(rule sympD[OF symp_rtranclp_symclp])
 
 lemma symclp_idem [simp]: "symclp (symclp r) = symclp r"
   by(simp add: symclp_pointfree sup_commute converse_join)
 
 lemma reflp_rtranclp [simp]: "reflp R\<^sup>*\<^sup>*"
   using refl_rtrancl[to_pred, of R] reflp_refl_eq[of "{(x, y). R\<^sup>*\<^sup>* x y}"] by simp
 
 subsection \<open>The power operation on relations\<close>
 
 text \<open>\<open>R ^^ n = R O \<dots> O R\<close>, the n-fold composition of \<open>R\<close>\<close>
 
 overloading
   relpow \<equiv> "compow :: nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   relpowp \<equiv> "compow :: nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
 begin
 
 primrec relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   where
     "relpow 0 R = Id"
   | "relpow (Suc n) R = (R ^^ n) O R"
 
 primrec relpowp :: "nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
   where
     "relpowp 0 R = HOL.eq"
   | "relpowp (Suc n) R = (R ^^ n) OO R"
 
 end
 
 lemma relpowp_relpow_eq [pred_set_conv]:
   "(\<lambda>x y. (x, y) \<in> R) ^^ n = (\<lambda>x y. (x, y) \<in> R ^^ n)" for R :: "'a rel"
   by (induct n) (simp_all add: relcompp_relcomp_eq)
 
 text \<open>For code generation:\<close>
 
 definition relpow :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   where relpow_code_def [code_abbrev]: "relpow = compow"
 
 definition relpowp :: "nat \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
   where relpowp_code_def [code_abbrev]: "relpowp = compow"
 
 lemma [code]:
   "relpow (Suc n) R = (relpow n R) O R"
   "relpow 0 R = Id"
   by (simp_all add: relpow_code_def)
 
 lemma [code]:
   "relpowp (Suc n) R = (R ^^ n) OO R"
   "relpowp 0 R = HOL.eq"
   by (simp_all add: relpowp_code_def)
 
 hide_const (open) relpow
 hide_const (open) relpowp
 
 lemma relpow_1 [simp]: "R ^^ 1 = R"
   for R :: "('a \<times> 'a) set"
   by simp
 
 lemma relpowp_1 [simp]: "P ^^ 1 = P"
   for P :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
   by (fact relpow_1 [to_pred])
 
 lemma relpow_0_I: "(x, x) \<in> R ^^ 0"
   by simp
 
 lemma relpowp_0_I: "(P ^^ 0) x x"
   by (fact relpow_0_I [to_pred])
 
 lemma relpow_Suc_I: "(x, y) \<in>  R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
   by auto
 
 lemma relpowp_Suc_I: "(P ^^ n) x y \<Longrightarrow> P y z \<Longrightarrow> (P ^^ Suc n) x z"
   by (fact relpow_Suc_I [to_pred])
 
 lemma relpow_Suc_I2: "(x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> (x, z) \<in> R ^^ Suc n"
   by (induct n arbitrary: z) (simp, fastforce)
 
 lemma relpowp_Suc_I2: "P x y \<Longrightarrow> (P ^^ n) y z \<Longrightarrow> (P ^^ Suc n) x z"
   by (fact relpow_Suc_I2 [to_pred])
 
 lemma relpow_0_E: "(x, y) \<in> R ^^ 0 \<Longrightarrow> (x = y \<Longrightarrow> P) \<Longrightarrow> P"
   by simp
 
 lemma relpowp_0_E: "(P ^^ 0) x y \<Longrightarrow> (x = y \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_0_E [to_pred])
 
 lemma relpow_Suc_E: "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R ^^ n \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
   by auto
 
 lemma relpowp_Suc_E: "(P ^^ Suc n) x z \<Longrightarrow> (\<And>y. (P ^^ n) x y \<Longrightarrow> P y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_Suc_E [to_pred])
 
 lemma relpow_E:
   "(x, z) \<in>  R ^^ n \<Longrightarrow>
     (n = 0 \<Longrightarrow> x = z \<Longrightarrow> P) \<Longrightarrow>
     (\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in>  R ^^ m \<Longrightarrow> (y, z) \<in> R \<Longrightarrow> P) \<Longrightarrow> P"
   by (cases n) auto
 
 lemma relpowp_E:
   "(P ^^ n) x z \<Longrightarrow>
     (n = 0 \<Longrightarrow> x = z \<Longrightarrow> Q) \<Longrightarrow>
     (\<And>y m. n = Suc m \<Longrightarrow> (P ^^ m) x y \<Longrightarrow> P y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_E [to_pred])
 
 lemma relpow_Suc_D2: "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<exists>y. (x, y) \<in> R \<and> (y, z) \<in> R ^^ n)"
   by (induct n arbitrary: x z)
     (blast intro: relpow_0_I relpow_Suc_I elim: relpow_0_E relpow_Suc_E)+
 
 lemma relpowp_Suc_D2: "(P ^^ Suc n) x z \<Longrightarrow> \<exists>y. P x y \<and> (P ^^ n) y z"
   by (fact relpow_Suc_D2 [to_pred])
 
 lemma relpow_Suc_E2: "(x, z) \<in> R ^^ Suc n \<Longrightarrow> (\<And>y. (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ n \<Longrightarrow> P) \<Longrightarrow> P"
   by (blast dest: relpow_Suc_D2)
 
 lemma relpowp_Suc_E2: "(P ^^ Suc n) x z \<Longrightarrow> (\<And>y. P x y \<Longrightarrow> (P ^^ n) y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_Suc_E2 [to_pred])
 
 lemma relpow_Suc_D2': "\<forall>x y z. (x, y) \<in> R ^^ n \<and> (y, z) \<in> R \<longrightarrow> (\<exists>w. (x, w) \<in> R \<and> (w, z) \<in> R ^^ n)"
   by (induct n) (simp_all, blast)
 
 lemma relpowp_Suc_D2': "\<forall>x y z. (P ^^ n) x y \<and> P y z \<longrightarrow> (\<exists>w. P x w \<and> (P ^^ n) w z)"
   by (fact relpow_Suc_D2' [to_pred])
 
 lemma relpow_E2:
   assumes "(x, z) \<in> R ^^ n" "n = 0 \<Longrightarrow> x = z \<Longrightarrow> P"
           "\<And>y m. n = Suc m \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (y, z) \<in> R ^^ m \<Longrightarrow> P"
       shows "P"
 proof (cases n)
   case 0
   with assms show ?thesis
     by simp
 next
   case (Suc m)
   with assms relpow_Suc_D2' [of m R] show ?thesis
     by force
 qed
 
 lemma relpowp_E2:
   "(P ^^ n) x z \<Longrightarrow>
     (n = 0 \<Longrightarrow> x = z \<Longrightarrow> Q) \<Longrightarrow>
     (\<And>y m. n = Suc m \<Longrightarrow> P x y \<Longrightarrow> (P ^^ m) y z \<Longrightarrow> Q) \<Longrightarrow> Q"
   by (fact relpow_E2 [to_pred])
 
 lemma relpow_add: "R ^^ (m + n) = R^^m O R^^n"
   by (induct n) auto
 
 lemma relpowp_add: "P ^^ (m + n) = P ^^ m OO P ^^ n"
   by (fact relpow_add [to_pred])
 
 lemma relpow_commute: "R O R ^^ n = R ^^ n O R"
   by (induct n) (simp_all add: O_assoc [symmetric])
 
 lemma relpowp_commute: "P OO P ^^ n = P ^^ n OO P"
   by (fact relpow_commute [to_pred])
 
 lemma relpow_empty: "0 < n \<Longrightarrow> ({} :: ('a \<times> 'a) set) ^^ n = {}"
   by (cases n) auto
 
 lemma relpowp_bot: "0 < n \<Longrightarrow> (\<bottom> :: 'a \<Rightarrow> 'a \<Rightarrow> bool) ^^ n = \<bottom>"
   by (fact relpow_empty [to_pred])
 
 lemma rtrancl_imp_UN_relpow:
   assumes "p \<in> R\<^sup>*"
   shows "p \<in> (\<Union>n. R ^^ n)"
 proof (cases p)
   case (Pair x y)
   with assms have "(x, y) \<in> R\<^sup>*" by simp
   then have "(x, y) \<in> (\<Union>n. R ^^ n)"
   proof induct
     case base
     show ?case by (blast intro: relpow_0_I)
   next
     case step
     then show ?case by (blast intro: relpow_Suc_I)
   qed
   with Pair show ?thesis by simp
 qed
 
 lemma rtranclp_imp_Sup_relpowp:
   assumes "(P\<^sup>*\<^sup>*) x y"
   shows "(\<Squnion>n. P ^^ n) x y"
   using assms and rtrancl_imp_UN_relpow [of "(x, y)", to_pred] by simp
 
 lemma relpow_imp_rtrancl:
   assumes "p \<in> R ^^ n"
   shows "p \<in> R\<^sup>*"
 proof (cases p)
   case (Pair x y)
   with assms have "(x, y) \<in> R ^^ n" by simp
   then have "(x, y) \<in> R\<^sup>*"
   proof (induct n arbitrary: x y)
     case 0
     then show ?case by simp
   next
     case Suc
     then show ?case
       by (blast elim: relpow_Suc_E intro: rtrancl_into_rtrancl)
   qed
   with Pair show ?thesis by simp
 qed
 
 lemma relpowp_imp_rtranclp: "(P ^^ n) x y \<Longrightarrow> (P\<^sup>*\<^sup>*) x y"
   using relpow_imp_rtrancl [of "(x, y)", to_pred] by simp
 
 lemma rtrancl_is_UN_relpow: "R\<^sup>* = (\<Union>n. R ^^ n)"
   by (blast intro: rtrancl_imp_UN_relpow relpow_imp_rtrancl)
 
 lemma rtranclp_is_Sup_relpowp: "P\<^sup>*\<^sup>* = (\<Squnion>n. P ^^ n)"
   using rtrancl_is_UN_relpow [to_pred, of P] by auto
 
 lemma rtrancl_power: "p \<in> R\<^sup>* \<longleftrightarrow> (\<exists>n. p \<in> R ^^ n)"
   by (simp add: rtrancl_is_UN_relpow)
 
 lemma rtranclp_power: "(P\<^sup>*\<^sup>*) x y \<longleftrightarrow> (\<exists>n. (P ^^ n) x y)"
   by (simp add: rtranclp_is_Sup_relpowp)
 
 lemma trancl_power: "p \<in> R\<^sup>+ \<longleftrightarrow> (\<exists>n > 0. p \<in> R ^^ n)"
 proof -
   have "(a, b) \<in> R\<^sup>+ \<longleftrightarrow> (\<exists>n>0. (a, b) \<in> R ^^ n)" for a b
   proof safe
     show "(a, b) \<in> R\<^sup>+ \<Longrightarrow> \<exists>n>0. (a, b) \<in> R ^^ n"
       by (fastforce simp: rtrancl_is_UN_relpow relcomp_unfold dest: tranclD2)
     show "(a, b) \<in> R\<^sup>+" if "n > 0" "(a, b) \<in> R ^^ n" for n
     proof (cases n)
       case (Suc m)
       with that show ?thesis
         by (auto simp: dest: relpow_imp_rtrancl rtrancl_into_trancl1)
     qed (use that in auto)
   qed
   then show ?thesis
     by (cases p) auto
 qed
 
 lemma tranclp_power: "(P\<^sup>+\<^sup>+) x y \<longleftrightarrow> (\<exists>n > 0. (P ^^ n) x y)"
   using trancl_power [to_pred, of P "(x, y)"] by simp
 
 lemma rtrancl_imp_relpow: "p \<in> R\<^sup>* \<Longrightarrow> \<exists>n. p \<in> R ^^ n"
   by (auto dest: rtrancl_imp_UN_relpow)
 
 lemma rtranclp_imp_relpowp: "(P\<^sup>*\<^sup>*) x y \<Longrightarrow> \<exists>n. (P ^^ n) x y"
   by (auto dest: rtranclp_imp_Sup_relpowp)
 
 text \<open>By Sternagel/Thiemann:\<close>
 lemma relpow_fun_conv: "(a, b) \<in> R ^^ n \<longleftrightarrow> (\<exists>f. f 0 = a \<and> f n = b \<and> (\<forall>i<n. (f i, f (Suc i)) \<in> R))"
 proof (induct n arbitrary: b)
   case 0
   show ?case by auto
 next
   case (Suc n)
   show ?case
-  proof (simp add: relcomp_unfold Suc)
-    show "(\<exists>y. (\<exists>f. f 0 = a \<and> f n = y \<and> (\<forall>i<n. (f i,f(Suc i)) \<in> R)) \<and> (y,b) \<in> R) \<longleftrightarrow>
+  proof -
+    have "(\<exists>y. (\<exists>f. f 0 = a \<and> f n = y \<and> (\<forall>i<n. (f i,f(Suc i)) \<in> R)) \<and> (y,b) \<in> R) \<longleftrightarrow>
       (\<exists>f. f 0 = a \<and> f(Suc n) = b \<and> (\<forall>i<Suc n. (f i, f (Suc i)) \<in> R))"
-    (is "?l = ?r")
+      (is "?l \<longleftrightarrow> ?r")
     proof
       assume ?l
       then obtain c f
         where 1: "f 0 = a"  "f n = c"  "\<And>i. i < n \<Longrightarrow> (f i, f (Suc i)) \<in> R"  "(c,b) \<in> R"
         by auto
       let ?g = "\<lambda> m. if m = Suc n then b else f m"
       show ?r by (rule exI[of _ ?g]) (simp add: 1)
     next
       assume ?r
       then obtain f where 1: "f 0 = a"  "b = f (Suc n)"  "\<And>i. i < Suc n \<Longrightarrow> (f i, f (Suc i)) \<in> R"
         by auto
-      show ?l by (rule exI[of _ "f n"], rule conjI, rule exI[of _ f], insert 1, auto)
+      show ?l by (rule exI[of _ "f n"], rule conjI, rule exI[of _ f], auto simp add: 1)
     qed
+    then show ?thesis by (simp add: relcomp_unfold Suc)
   qed
 qed
 
 lemma relpowp_fun_conv: "(P ^^ n) x y \<longleftrightarrow> (\<exists>f. f 0 = x \<and> f n = y \<and> (\<forall>i<n. P (f i) (f (Suc i))))"
   by (fact relpow_fun_conv [to_pred])
 
 lemma relpow_finite_bounded1:
   fixes R :: "('a \<times> 'a) set"
   assumes "finite R" and "k > 0"
   shows "R^^k \<subseteq> (\<Union>n\<in>{n. 0 < n \<and> n \<le> card R}. R^^n)"
     (is "_ \<subseteq> ?r")
 proof -
   have "(a, b) \<in> R^^(Suc k) \<Longrightarrow> \<exists>n. 0 < n \<and> n \<le> card R \<and> (a, b) \<in> R^^n" for a b k
   proof (induct k arbitrary: b)
     case 0
     then have "R \<noteq> {}" by auto
     with card_0_eq[OF \<open>finite R\<close>] have "card R \<ge> Suc 0" by auto
     then show ?case using 0 by force
   next
     case (Suc k)
     then obtain a' where "(a, a') \<in> R^^(Suc k)" and "(a', b) \<in> R"
       by auto
     from Suc(1)[OF \<open>(a, a') \<in> R^^(Suc k)\<close>] obtain n where "n \<le> card R" and "(a, a') \<in> R ^^ n"
       by auto
     have "(a, b) \<in> R^^(Suc n)"
       using \<open>(a, a') \<in> R^^n\<close> and \<open>(a', b)\<in> R\<close> by auto
     from \<open>n \<le> card R\<close> consider "n < card R" | "n = card R" by force
     then show ?case
     proof cases
       case 1
       then show ?thesis
         using \<open>(a, b) \<in> R^^(Suc n)\<close> Suc_leI[OF \<open>n < card R\<close>] by blast
     next
       case 2
       from \<open>(a, b) \<in> R ^^ (Suc n)\<close> [unfolded relpow_fun_conv]
       obtain f where "f 0 = a" and "f (Suc n) = b"
         and steps: "\<And>i. i \<le> n \<Longrightarrow> (f i, f (Suc i)) \<in> R" by auto
       let ?p = "\<lambda>i. (f i, f(Suc i))"
       let ?N = "{i. i \<le> n}"
       have "?p ` ?N \<subseteq> R"
         using steps by auto
       from card_mono[OF assms(1) this] have "card (?p ` ?N) \<le> card R" .
       also have "\<dots> < card ?N"
         using \<open>n = card R\<close> by simp
       finally have "\<not> inj_on ?p ?N"
         by (rule pigeonhole)
       then obtain i j where i: "i \<le> n" and j: "j \<le> n" and ij: "i \<noteq> j" and pij: "?p i = ?p j"
         by (auto simp: inj_on_def)
       let ?i = "min i j"
       let ?j = "max i j"
       have i: "?i \<le> n" and j: "?j \<le> n" and pij: "?p ?i = ?p ?j" and ij: "?i < ?j"
         using i j ij pij unfolding min_def max_def by auto
       from i j pij ij obtain i j where i: "i \<le> n" and j: "j \<le> n" and ij: "i < j"
         and pij: "?p i = ?p j"
         by blast
       let ?g = "\<lambda>l. if l \<le> i then f l else f (l + (j - i))"
       let ?n = "Suc (n - (j - i))"
       have abl: "(a, b) \<in> R ^^ ?n"
         unfolding relpow_fun_conv
       proof (rule exI[of _ ?g], intro conjI impI allI)
         show "?g ?n = b"
           using \<open>f(Suc n) = b\<close> j ij by auto
       next
         fix k
         assume "k < ?n"
         show "(?g k, ?g (Suc k)) \<in> R"
         proof (cases "k < i")
           case True
           with i have "k \<le> n"
             by auto
           from steps[OF this] show ?thesis
             using True by simp
         next
           case False
           then have "i \<le> k" by auto
           show ?thesis
           proof (cases "k = i")
             case True
             then show ?thesis
               using ij pij steps[OF i] by simp
           next
             case False
             with \<open>i \<le> k\<close> have "i < k" by auto
             then have small: "k + (j - i) \<le> n"
               using \<open>k<?n\<close> by arith
             show ?thesis
               using steps[OF small] \<open>i<k\<close> by auto
           qed
         qed
       qed (simp add: \<open>f 0 = a\<close>)
       moreover have "?n \<le> n"
         using i j ij by arith
       ultimately show ?thesis
         using \<open>n = card R\<close> by blast
     qed
   qed
   then show ?thesis
     using gr0_implies_Suc[OF \<open>k > 0\<close>] by auto
 qed
 
 lemma relpow_finite_bounded:
   fixes R :: "('a \<times> 'a) set"
   assumes "finite R"
   shows "R^^k \<subseteq> (\<Union>n\<in>{n. n \<le> card R}. R^^n)"
 proof (cases k)
   case (Suc k')
   then show ?thesis
     using relpow_finite_bounded1[OF assms, of k] by auto
 qed force
 
 lemma rtrancl_finite_eq_relpow: "finite R \<Longrightarrow> R\<^sup>* = (\<Union>n\<in>{n. n \<le> card R}. R^^n)"
   by (fastforce simp: rtrancl_power dest: relpow_finite_bounded)
 
 lemma trancl_finite_eq_relpow:
   assumes "finite R" shows "R\<^sup>+ = (\<Union>n\<in>{n. 0 < n \<and> n \<le> card R}. R^^n)"
 proof -
   have "\<And>a b n. \<lbrakk>0 < n; (a, b) \<in> R ^^ n\<rbrakk> \<Longrightarrow> \<exists>x>0. x \<le> card R \<and> (a, b) \<in> R ^^ x"
     using assms by (auto dest: relpow_finite_bounded1)
   then show ?thesis
     by (auto simp: trancl_power)
 qed
 
 lemma finite_relcomp[simp,intro]:
   assumes "finite R" and "finite S"
   shows "finite (R O S)"
 proof-
   have "R O S = (\<Union>(x, y)\<in>R. \<Union>(u, v)\<in>S. if u = y then {(x, v)} else {})"
     by (force simp: split_def image_constant_conv split: if_splits)
   then show ?thesis
     using assms by clarsimp
 qed
 
 lemma finite_relpow [simp, intro]:
   fixes R :: "('a \<times> 'a) set"
   assumes "finite R"
   shows "n > 0 \<Longrightarrow> finite (R^^n)"
 proof (induct n)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   then show ?case by (cases n) (use assms in simp_all)
 qed
 
 lemma single_valued_relpow:
   fixes R :: "('a \<times> 'a) set"
   shows "single_valued R \<Longrightarrow> single_valued (R ^^ n)"
 proof (induct n arbitrary: R)
   case 0
   then show ?case by simp
 next
   case (Suc n)
   show ?case
     by (rule single_valuedI)
       (use Suc in \<open>fast dest: single_valuedD elim: relpow_Suc_E\<close>)
 qed
 
 
 subsection \<open>Bounded transitive closure\<close>
 
 definition ntrancl :: "nat \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set"
   where "ntrancl n R = (\<Union>i\<in>{i. 0 < i \<and> i \<le> Suc n}. R ^^ i)"
 
 lemma ntrancl_Zero [simp, code]: "ntrancl 0 R = R"
 proof
   show "R \<subseteq> ntrancl 0 R"
     unfolding ntrancl_def by fastforce
   have "0 < i \<and> i \<le> Suc 0 \<longleftrightarrow> i = 1" for i
     by auto
   then show "ntrancl 0 R \<le> R"
     unfolding ntrancl_def by auto
 qed
 
 lemma ntrancl_Suc [simp]: "ntrancl (Suc n) R = ntrancl n R O (Id \<union> R)"
 proof
   have "(a, b) \<in> ntrancl n R O (Id \<union> R)" if "(a, b) \<in> ntrancl (Suc n) R" for a b
   proof -
     from that obtain i where "0 < i" "i \<le> Suc (Suc n)" "(a, b) \<in> R ^^ i"
       unfolding ntrancl_def by auto
     show ?thesis
     proof (cases "i = 1")
       case True
       with \<open>(a, b) \<in> R ^^ i\<close> show ?thesis
         by (auto simp: ntrancl_def)
     next
       case False
       with \<open>0 < i\<close> obtain j where j: "i = Suc j" "0 < j"
         by (cases i) auto
       with \<open>(a, b) \<in> R ^^ i\<close> obtain c where c1: "(a, c) \<in> R ^^ j" and c2: "(c, b) \<in> R"
         by auto
       from c1 j \<open>i \<le> Suc (Suc n)\<close> have "(a, c) \<in> ntrancl n R"
         by (fastforce simp: ntrancl_def)
       with c2 show ?thesis by fastforce
     qed
   qed
   then show "ntrancl (Suc n) R \<subseteq> ntrancl n R O (Id \<union> R)"
     by auto
   show "ntrancl n R O (Id \<union> R) \<subseteq> ntrancl (Suc n) R"
     by (fastforce simp: ntrancl_def)
 qed
 
 lemma [code]: "ntrancl (Suc n) r = (let r' = ntrancl n r in r' \<union> r' O r)"
   by (auto simp: Let_def)
 
 lemma finite_trancl_ntranl: "finite R \<Longrightarrow> trancl R = ntrancl (card R - 1) R"
   by (cases "card R") (auto simp: trancl_finite_eq_relpow relpow_empty ntrancl_def)
 
 
 subsection \<open>Acyclic relations\<close>
 
 definition acyclic :: "('a \<times> 'a) set \<Rightarrow> bool"
   where "acyclic r \<longleftrightarrow> (\<forall>x. (x,x) \<notin> r\<^sup>+)"
 
 abbreviation acyclicP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "acyclicP r \<equiv> acyclic {(x, y). r x y}"
 
 lemma acyclic_irrefl [code]: "acyclic r \<longleftrightarrow> irrefl (r\<^sup>+)"
   by (simp add: acyclic_def irrefl_def)
 
 lemma acyclicI: "\<forall>x. (x, x) \<notin> r\<^sup>+ \<Longrightarrow> acyclic r"
   by (simp add: acyclic_def)
 
 lemma (in preorder) acyclicI_order:
   assumes *: "\<And>a b. (a, b) \<in> r \<Longrightarrow> f b < f a"
   shows "acyclic r"
 proof -
   have "f b < f a" if "(a, b) \<in> r\<^sup>+" for a b
     using that by induct (auto intro: * less_trans)
   then show ?thesis
     by (auto intro!: acyclicI)
 qed
 
 lemma acyclic_insert [iff]: "acyclic (insert (y, x) r) \<longleftrightarrow> acyclic r \<and> (x, y) \<notin> r\<^sup>*"
   by (simp add: acyclic_def trancl_insert) (blast intro: rtrancl_trans)
 
 lemma acyclic_converse [iff]: "acyclic (r\<inverse>) \<longleftrightarrow> acyclic r"
   by (simp add: acyclic_def trancl_converse)
 
 lemmas acyclicP_converse [iff] = acyclic_converse [to_pred]
 
 lemma acyclic_impl_antisym_rtrancl: "acyclic r \<Longrightarrow> antisym (r\<^sup>*)"
   by (simp add: acyclic_def antisym_def)
     (blast elim: rtranclE intro: rtrancl_into_trancl1 rtrancl_trancl_trancl)
 
 (* Other direction:
 acyclic = no loops
 antisym = only self loops
 Goalw [acyclic_def,antisym_def] "antisym( r\<^sup>* ) \<Longrightarrow> acyclic(r - Id)
 \<Longrightarrow> antisym( r\<^sup>* ) = acyclic(r - Id)";
 *)
 
 lemma acyclic_subset: "acyclic s \<Longrightarrow> r \<subseteq> s \<Longrightarrow> acyclic r"
   unfolding acyclic_def by (blast intro: trancl_mono)
 
 
 subsection \<open>Setup of transitivity reasoner\<close>
 
 ML \<open>
 structure Trancl_Tac = Trancl_Tac
 (
   val r_into_trancl = @{thm trancl.r_into_trancl};
   val trancl_trans  = @{thm trancl_trans};
   val rtrancl_refl = @{thm rtrancl.rtrancl_refl};
   val r_into_rtrancl = @{thm r_into_rtrancl};
   val trancl_into_rtrancl = @{thm trancl_into_rtrancl};
   val rtrancl_trancl_trancl = @{thm rtrancl_trancl_trancl};
   val trancl_rtrancl_trancl = @{thm trancl_rtrancl_trancl};
   val rtrancl_trans = @{thm rtrancl_trans};
 
   fun decomp \<^Const_>\<open>Trueprop for t\<close> =
         let
           fun dec \<^Const_>\<open>Set.member _ for \<^Const_>\<open>Pair _ _ for a b\<close> rel\<close> =
               let
                 fun decr \<^Const_>\<open>rtrancl _ for r\<close> = (r,"r*")
                   | decr \<^Const_>\<open>trancl _ for r\<close> = (r,"r+")
                   | decr r = (r,"r");
                 val (rel,r) = decr (Envir.beta_eta_contract rel);
               in SOME (a,b,rel,r) end
           | dec _ =  NONE
         in dec t end
     | decomp _ = NONE;
 );
 
 structure Tranclp_Tac = Trancl_Tac
 (
   val r_into_trancl = @{thm tranclp.r_into_trancl};
   val trancl_trans  = @{thm tranclp_trans};
   val rtrancl_refl = @{thm rtranclp.rtrancl_refl};
   val r_into_rtrancl = @{thm r_into_rtranclp};
   val trancl_into_rtrancl = @{thm tranclp_into_rtranclp};
   val rtrancl_trancl_trancl = @{thm rtranclp_tranclp_tranclp};
   val trancl_rtrancl_trancl = @{thm tranclp_rtranclp_tranclp};
   val rtrancl_trans = @{thm rtranclp_trans};
 
   fun decomp \<^Const_>\<open>Trueprop for t\<close> =
         let
           fun dec (rel $ a $ b) =
             let
               fun decr \<^Const_>\<open>rtranclp _ for r\<close> = (r,"r*")
                 | decr \<^Const_>\<open>tranclp _ for r\<close> = (r,"r+")
                 | decr r = (r,"r");
               val (rel,r) = decr rel;
             in SOME (a, b, rel, r) end
           | dec _ =  NONE
         in dec t end
     | decomp _ = NONE;
 );
 \<close>
 
 setup \<open>
   map_theory_simpset (fn ctxt => ctxt
     addSolver (mk_solver "Trancl" Trancl_Tac.trancl_tac)
     addSolver (mk_solver "Rtrancl" Trancl_Tac.rtrancl_tac)
     addSolver (mk_solver "Tranclp" Tranclp_Tac.trancl_tac)
     addSolver (mk_solver "Rtranclp" Tranclp_Tac.rtrancl_tac))
 \<close>
 
 lemma transp_rtranclp [simp]: "transp R\<^sup>*\<^sup>*"
   by(auto simp add: transp_def)
 
 text \<open>Optional methods.\<close>
 
 method_setup trancl =
   \<open>Scan.succeed (SIMPLE_METHOD' o Trancl_Tac.trancl_tac)\<close>
   \<open>simple transitivity reasoner\<close>
 method_setup rtrancl =
   \<open>Scan.succeed (SIMPLE_METHOD' o Trancl_Tac.rtrancl_tac)\<close>
   \<open>simple transitivity reasoner\<close>
 method_setup tranclp =
   \<open>Scan.succeed (SIMPLE_METHOD' o Tranclp_Tac.trancl_tac)\<close>
   \<open>simple transitivity reasoner (predicate version)\<close>
 method_setup rtranclp =
   \<open>Scan.succeed (SIMPLE_METHOD' o Tranclp_Tac.rtrancl_tac)\<close>
   \<open>simple transitivity reasoner (predicate version)\<close>
 
 end
diff --git a/src/HOL/Wellfounded.thy b/src/HOL/Wellfounded.thy
--- a/src/HOL/Wellfounded.thy
+++ b/src/HOL/Wellfounded.thy
@@ -1,981 +1,992 @@
 (*  Title:      HOL/Wellfounded.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Konrad Slind
     Author:     Alexander Krauss
     Author:     Andrei Popescu, TU Muenchen
 *)
 
 section \<open>Well-founded Recursion\<close>
 
 theory Wellfounded
   imports Transitive_Closure
 begin
 
 subsection \<open>Basic Definitions\<close>
 
 definition wf :: "('a \<times> 'a) set \<Rightarrow> bool"
   where "wf r \<longleftrightarrow> (\<forall>P. (\<forall>x. (\<forall>y. (y, x) \<in> r \<longrightarrow> P y) \<longrightarrow> P x) \<longrightarrow> (\<forall>x. P x))"
 
 definition wfP :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool"
   where "wfP r \<longleftrightarrow> wf {(x, y). r x y}"
 
 lemma wfP_wf_eq [pred_set_conv]: "wfP (\<lambda>x y. (x, y) \<in> r) = wf r"
   by (simp add: wfP_def)
 
 lemma wfUNIVI: "(\<And>P x. (\<forall>x. (\<forall>y. (y, x) \<in> r \<longrightarrow> P y) \<longrightarrow> P x) \<Longrightarrow> P x) \<Longrightarrow> wf r"
   unfolding wf_def by blast
 
 lemmas wfPUNIVI = wfUNIVI [to_pred]
 
 text \<open>Restriction to domain \<open>A\<close> and range \<open>B\<close>.
   If \<open>r\<close> is well-founded over their intersection, then \<open>wf r\<close>.\<close>
 lemma wfI:
   assumes "r \<subseteq> A \<times> B"
     and "\<And>x P. \<lbrakk>\<forall>x. (\<forall>y. (y, x) \<in> r \<longrightarrow> P y) \<longrightarrow> P x;  x \<in> A; x \<in> B\<rbrakk> \<Longrightarrow> P x"
   shows "wf r"
   using assms unfolding wf_def by blast
 
 lemma wf_induct:
   assumes "wf r"
     and "\<And>x. \<forall>y. (y, x) \<in> r \<longrightarrow> P y \<Longrightarrow> P x"
   shows "P a"
   using assms unfolding wf_def by blast
 
 lemmas wfP_induct = wf_induct [to_pred]
 
 lemmas wf_induct_rule = wf_induct [rule_format, consumes 1, case_names less, induct set: wf]
 
 lemmas wfP_induct_rule = wf_induct_rule [to_pred, induct set: wfP]
 
 lemma wf_not_sym: "wf r \<Longrightarrow> (a, x) \<in> r \<Longrightarrow> (x, a) \<notin> r"
   by (induct a arbitrary: x set: wf) blast
 
 lemma wf_asym:
   assumes "wf r" "(a, x) \<in> r"
   obtains "(x, a) \<notin> r"
   by (drule wf_not_sym[OF assms])
 
 lemma wf_imp_asym: "wf r \<Longrightarrow> asym r"
   by (auto intro: asymI elim: wf_asym)
 
 lemma wfP_imp_asymp: "wfP r \<Longrightarrow> asymp r"
   by (rule wf_imp_asym[to_pred])
 
 lemma wf_not_refl [simp]: "wf r \<Longrightarrow> (a, a) \<notin> r"
   by (blast elim: wf_asym)
 
 lemma wf_irrefl:
   assumes "wf r"
   obtains "(a, a) \<notin> r"
   by (drule wf_not_refl[OF assms])
 
 lemma wf_imp_irrefl:
   assumes "wf r" shows "irrefl r" 
   using wf_irrefl [OF assms] by (auto simp add: irrefl_def)
 
 lemma wfP_imp_irreflp: "wfP r \<Longrightarrow> irreflp r"
   by (rule wf_imp_irrefl[to_pred])
 
 lemma wf_wellorderI:
   assumes wf: "wf {(x::'a::ord, y). x < y}"
     and lin: "OFCLASS('a::ord, linorder_class)"
   shows "OFCLASS('a::ord, wellorder_class)"
   apply (rule wellorder_class.intro [OF lin])
   apply (simp add: wellorder_class.intro class.wellorder_axioms.intro wf_induct_rule [OF wf])
   done
 
 lemma (in wellorder) wf: "wf {(x, y). x < y}"
   unfolding wf_def by (blast intro: less_induct)
 
 lemma (in wellorder) wfP_less[simp]: "wfP (<)"
   by (simp add: wf wfP_def)
 
 
 subsection \<open>Basic Results\<close>
 
 text \<open>Point-free characterization of well-foundedness\<close>
 
 lemma wfE_pf:
   assumes wf: "wf R"
     and a: "A \<subseteq> R `` A"
   shows "A = {}"
 proof -
   from wf have "x \<notin> A" for x
   proof induct
     fix x assume "\<And>y. (y, x) \<in> R \<Longrightarrow> y \<notin> A"
     then have "x \<notin> R `` A" by blast
     with a show "x \<notin> A" by blast
   qed
   then show ?thesis by auto
 qed
 
 lemma wfI_pf:
   assumes a: "\<And>A. A \<subseteq> R `` A \<Longrightarrow> A = {}"
   shows "wf R"
 proof (rule wfUNIVI)
   fix P :: "'a \<Rightarrow> bool" and x
   let ?A = "{x. \<not> P x}"
   assume "\<forall>x. (\<forall>y. (y, x) \<in> R \<longrightarrow> P y) \<longrightarrow> P x"
   then have "?A \<subseteq> R `` ?A" by blast
   with a show "P x" by blast
 qed
 
 
 subsubsection \<open>Minimal-element characterization of well-foundedness\<close>
 
 lemma wfE_min:
   assumes wf: "wf R" and Q: "x \<in> Q"
   obtains z where "z \<in> Q" "\<And>y. (y, z) \<in> R \<Longrightarrow> y \<notin> Q"
   using Q wfE_pf[OF wf, of Q] by blast
 
 lemma wfE_min':
   "wf R \<Longrightarrow> Q \<noteq> {} \<Longrightarrow> (\<And>z. z \<in> Q \<Longrightarrow> (\<And>y. (y, z) \<in> R \<Longrightarrow> y \<notin> Q) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
   using wfE_min[of R _ Q] by blast
 
 lemma wfI_min:
   assumes a: "\<And>x Q. x \<in> Q \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> R \<longrightarrow> y \<notin> Q"
   shows "wf R"
 proof (rule wfI_pf)
   fix A
   assume b: "A \<subseteq> R `` A"
   have False if "x \<in> A" for x
     using a[OF that] b by blast
   then show "A = {}" by blast
 qed
 
 lemma wf_eq_minimal: "wf r \<longleftrightarrow> (\<forall>Q x. x \<in> Q \<longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q))"
   apply (rule iffI)
    apply (blast intro:  elim!: wfE_min)
   by (rule wfI_min) auto
 
 lemmas wfP_eq_minimal = wf_eq_minimal [to_pred]
 
 
 subsubsection \<open>Well-foundedness of transitive closure\<close>
 
 lemma wf_trancl:
   assumes "wf r"
   shows "wf (r\<^sup>+)"
 proof -
   have "P x" if induct_step: "\<And>x. (\<And>y. (y, x) \<in> r\<^sup>+ \<Longrightarrow> P y) \<Longrightarrow> P x" for P x
   proof (rule induct_step)
     show "P y" if "(y, x) \<in> r\<^sup>+" for y
       using \<open>wf r\<close> and that
     proof (induct x arbitrary: y)
       case (less x)
       note hyp = \<open>\<And>x' y'. (x', x) \<in> r \<Longrightarrow> (y', x') \<in> r\<^sup>+ \<Longrightarrow> P y'\<close>
       from \<open>(y, x) \<in> r\<^sup>+\<close> show "P y"
       proof cases
         case base
         show "P y"
         proof (rule induct_step)
           fix y'
           assume "(y', y) \<in> r\<^sup>+"
           with \<open>(y, x) \<in> r\<close> show "P y'"
             by (rule hyp [of y y'])
         qed
       next
         case step
         then obtain x' where "(x', x) \<in> r" and "(y, x') \<in> r\<^sup>+"
           by simp
         then show "P y" by (rule hyp [of x' y])
       qed
     qed
   qed
   then show ?thesis unfolding wf_def by blast
 qed
 
 lemmas wfP_trancl = wf_trancl [to_pred]
 
 lemma wf_converse_trancl: "wf (r\<inverse>) \<Longrightarrow> wf ((r\<^sup>+)\<inverse>)"
   apply (subst trancl_converse [symmetric])
   apply (erule wf_trancl)
   done
 
 text \<open>Well-foundedness of subsets\<close>
 
 lemma wf_subset: "wf r \<Longrightarrow> p \<subseteq> r \<Longrightarrow> wf p"
   by (simp add: wf_eq_minimal) fast
 
 lemmas wfP_subset = wf_subset [to_pred]
 
 text \<open>Well-foundedness of the empty relation\<close>
 
 lemma wf_empty [iff]: "wf {}"
   by (simp add: wf_def)
 
 lemma wfP_empty [iff]: "wfP (\<lambda>x y. False)"
 proof -
   have "wfP bot"
     by (fact wf_empty[to_pred bot_empty_eq2])
   then show ?thesis
     by (simp add: bot_fun_def)
 qed
 
 lemma wf_Int1: "wf r \<Longrightarrow> wf (r \<inter> r')"
   by (erule wf_subset) (rule Int_lower1)
 
 lemma wf_Int2: "wf r \<Longrightarrow> wf (r' \<inter> r)"
   by (erule wf_subset) (rule Int_lower2)
 
 text \<open>Exponentiation.\<close>
 lemma wf_exp:
   assumes "wf (R ^^ n)"
   shows "wf R"
 proof (rule wfI_pf)
   fix A assume "A \<subseteq> R `` A"
   then have "A \<subseteq> (R ^^ n) `` A"
     by (induct n) force+
   with \<open>wf (R ^^ n)\<close> show "A = {}"
     by (rule wfE_pf)
 qed
 
 text \<open>Well-foundedness of \<open>insert\<close>.\<close>
 lemma wf_insert [iff]: "wf (insert (y,x) r) \<longleftrightarrow> wf r \<and> (x,y) \<notin> r\<^sup>*" (is "?lhs = ?rhs")
 proof
   assume ?lhs then show ?rhs
     by (blast elim: wf_trancl [THEN wf_irrefl]
         intro: rtrancl_into_trancl1 wf_subset rtrancl_mono [THEN subsetD])
 next
   assume R: ?rhs
   then have R': "Q \<noteq> {} \<Longrightarrow> (\<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q)" for Q
     by (auto simp: wf_eq_minimal)
   show ?lhs
     unfolding wf_eq_minimal
   proof clarify
     fix Q :: "'a set" and q
     assume "q \<in> Q"
     then obtain a where "a \<in> Q" and a: "\<And>y. (y, a) \<in> r \<Longrightarrow> y \<notin> Q"
       using R by (auto simp: wf_eq_minimal)
     show "\<exists>z\<in>Q. \<forall>y'. (y', z) \<in> insert (y, x) r \<longrightarrow> y' \<notin> Q"
     proof (cases "a=x")
       case True
       show ?thesis
       proof (cases "y \<in> Q")
         case True
         then obtain z where "z \<in> Q" "(z, y) \<in> r\<^sup>*"
                             "\<And>z'. (z', z) \<in> r \<longrightarrow> z' \<in> Q \<longrightarrow> (z', y) \<notin> r\<^sup>*"
           using R' [of "{z \<in> Q. (z,y) \<in> r\<^sup>*}"] by auto
-        with R show ?thesis
-          by (rule_tac x="z" in bexI) (blast intro: rtrancl_trans)
+        then have "\<forall>y'. (y', z) \<in> insert (y, x) r \<longrightarrow> y' \<notin> Q"
+          using R by(blast intro: rtrancl_trans)+
+        then show ?thesis
+          by (rule bexI) fact
       next
         case False
         then show ?thesis
           using a \<open>a \<in> Q\<close> by blast
       qed
     next
       case False
       with a \<open>a \<in> Q\<close> show ?thesis
         by blast
     qed
   qed
 qed
 
 
 subsubsection \<open>Well-foundedness of image\<close>
 
 lemma wf_map_prod_image_Dom_Ran:
   fixes r:: "('a \<times> 'a) set"
     and f:: "'a \<Rightarrow> 'b"
   assumes wf_r: "wf r"
     and inj: "\<And> a a'. a \<in> Domain r \<Longrightarrow> a' \<in> Range r \<Longrightarrow> f a = f a' \<Longrightarrow> a = a'"
   shows "wf (map_prod f f ` r)"
 proof (unfold wf_eq_minimal, clarify)
   fix B :: "'b set" and b::"'b"
   assume "b \<in> B"
   define A where "A = f -` B \<inter> Domain r"
   show "\<exists>z\<in>B. \<forall>y. (y, z) \<in> map_prod f f ` r \<longrightarrow> y \<notin> B"
   proof (cases "A = {}")
     case False
     then obtain a0 where "a0 \<in> A" and "\<forall>a. (a, a0) \<in> r \<longrightarrow> a \<notin> A"
       using wfE_min[OF wf_r] by auto
     thus ?thesis
       using inj unfolding A_def
       by (intro bexI[of _ "f a0"]) auto
-  qed (insert \<open>b \<in> B\<close>, unfold A_def, auto)
+  qed (use \<open>b \<in> B\<close> in  \<open>unfold A_def, auto\<close>)
 qed
 
 lemma wf_map_prod_image: "wf r \<Longrightarrow> inj f \<Longrightarrow> wf (map_prod f f ` r)"
 by(rule wf_map_prod_image_Dom_Ran) (auto dest: inj_onD)
 
 
 subsection \<open>Well-Foundedness Results for Unions\<close>
 
 lemma wf_union_compatible:
   assumes "wf R" "wf S"
   assumes "R O S \<subseteq> R"
   shows "wf (R \<union> S)"
 proof (rule wfI_min)
   fix x :: 'a and Q
   let ?Q' = "{x \<in> Q. \<forall>y. (y, x) \<in> R \<longrightarrow> y \<notin> Q}"
   assume "x \<in> Q"
   obtain a where "a \<in> ?Q'"
     by (rule wfE_min [OF \<open>wf R\<close> \<open>x \<in> Q\<close>]) blast
   with \<open>wf S\<close> obtain z where "z \<in> ?Q'" and zmin: "\<And>y. (y, z) \<in> S \<Longrightarrow> y \<notin> ?Q'"
     by (erule wfE_min)
   have "y \<notin> Q" if "(y, z) \<in> S" for y
   proof
     from that have "y \<notin> ?Q'" by (rule zmin)
     assume "y \<in> Q"
     with \<open>y \<notin> ?Q'\<close> obtain w where "(w, y) \<in> R" and "w \<in> Q" by auto
     from \<open>(w, y) \<in> R\<close> \<open>(y, z) \<in> S\<close> have "(w, z) \<in> R O S" by (rule relcompI)
     with \<open>R O S \<subseteq> R\<close> have "(w, z) \<in> R" ..
     with \<open>z \<in> ?Q'\<close> have "w \<notin> Q" by blast
     with \<open>w \<in> Q\<close> show False by contradiction
   qed
   with \<open>z \<in> ?Q'\<close> show "\<exists>z\<in>Q. \<forall>y. (y, z) \<in> R \<union> S \<longrightarrow> y \<notin> Q" by blast
 qed
 
 
 text \<open>Well-foundedness of indexed union with disjoint domains and ranges.\<close>
 
 lemma wf_UN:
   assumes r: "\<And>i. i \<in> I \<Longrightarrow> wf (r i)"
     and disj: "\<And>i j. \<lbrakk>i \<in> I; j \<in> I; r i \<noteq> r j\<rbrakk> \<Longrightarrow> Domain (r i) \<inter> Range (r j) = {}"
   shows "wf (\<Union>i\<in>I. r i)"
   unfolding wf_eq_minimal
 proof clarify
   fix A and a :: "'b"
   assume "a \<in> A"
   show "\<exists>z\<in>A. \<forall>y. (y, z) \<in> \<Union>(r ` I) \<longrightarrow> y \<notin> A"
   proof (cases "\<exists>i\<in>I. \<exists>a\<in>A. \<exists>b\<in>A. (b, a) \<in> r i")
     case True
     then obtain i b c where ibc: "i \<in> I" "b \<in> A" "c \<in> A" "(c,b) \<in> r i"
       by blast
     have ri: "\<And>Q. Q \<noteq> {} \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> r i \<longrightarrow> y \<notin> Q"
       using r [OF \<open>i \<in> I\<close>] unfolding wf_eq_minimal by auto
     show ?thesis
       using ri [of "{a. a \<in> A \<and> (\<exists>b\<in>A. (b, a) \<in> r i) }"] ibc disj
       by blast
   next
     case False
     with \<open>a \<in> A\<close> show ?thesis
       by blast
   qed
 qed
 
 lemma wfP_SUP:
   "\<forall>i. wfP (r i) \<Longrightarrow> \<forall>i j. r i \<noteq> r j \<longrightarrow> inf (Domainp (r i)) (Rangep (r j)) = bot \<Longrightarrow>
     wfP (\<Squnion>(range r))"
   by (rule wf_UN[to_pred]) simp_all
 
 lemma wf_Union:
   assumes "\<forall>r\<in>R. wf r"
     and "\<forall>r\<in>R. \<forall>s\<in>R. r \<noteq> s \<longrightarrow> Domain r \<inter> Range s = {}"
   shows "wf (\<Union>R)"
   using assms wf_UN[of R "\<lambda>i. i"] by simp
 
 text \<open>
   Intuition: We find an \<open>R \<union> S\<close>-min element of a nonempty subset \<open>A\<close> by case distinction.
   \<^enum> There is a step \<open>a \<midarrow>R\<rightarrow> b\<close> with \<open>a, b \<in> A\<close>.
     Pick an \<open>R\<close>-min element \<open>z\<close> of the (nonempty) set \<open>{a\<in>A | \<exists>b\<in>A. a \<midarrow>R\<rightarrow> b}\<close>.
     By definition, there is \<open>z' \<in> A\<close> s.t. \<open>z \<midarrow>R\<rightarrow> z'\<close>. Because \<open>z\<close> is \<open>R\<close>-min in the
     subset, \<open>z'\<close> must be \<open>R\<close>-min in \<open>A\<close>. Because \<open>z'\<close> has an \<open>R\<close>-predecessor, it cannot
     have an \<open>S\<close>-successor and is thus \<open>S\<close>-min in \<open>A\<close> as well.
   \<^enum> There is no such step.
     Pick an \<open>S\<close>-min element of \<open>A\<close>. In this case it must be an \<open>R\<close>-min
     element of \<open>A\<close> as well.
 \<close>
 lemma wf_Un: "wf r \<Longrightarrow> wf s \<Longrightarrow> Domain r \<inter> Range s = {} \<Longrightarrow> wf (r \<union> s)"
   using wf_union_compatible[of s r]
   by (auto simp: Un_ac)
 
 lemma wf_union_merge: "wf (R \<union> S) = wf (R O R \<union> S O R \<union> S)"
   (is "wf ?A = wf ?B")
 proof
   assume "wf ?A"
   with wf_trancl have wfT: "wf (?A\<^sup>+)" .
   moreover have "?B \<subseteq> ?A\<^sup>+"
     by (subst trancl_unfold, subst trancl_unfold) blast
   ultimately show "wf ?B" by (rule wf_subset)
 next
   assume "wf ?B"
   show "wf ?A"
   proof (rule wfI_min)
     fix Q :: "'a set" and x
     assume "x \<in> Q"
     with \<open>wf ?B\<close> obtain z where "z \<in> Q" and "\<And>y. (y, z) \<in> ?B \<Longrightarrow> y \<notin> Q"
       by (erule wfE_min)
     then have 1: "\<And>y. (y, z) \<in> R O R \<Longrightarrow> y \<notin> Q"
       and 2: "\<And>y. (y, z) \<in> S O R \<Longrightarrow> y \<notin> Q"
       and 3: "\<And>y. (y, z) \<in> S \<Longrightarrow> y \<notin> Q"
       by auto
     show "\<exists>z\<in>Q. \<forall>y. (y, z) \<in> ?A \<longrightarrow> y \<notin> Q"
     proof (cases "\<forall>y. (y, z) \<in> R \<longrightarrow> y \<notin> Q")
       case True
       with \<open>z \<in> Q\<close> 3 show ?thesis by blast
     next
       case False
       then obtain z' where "z'\<in>Q" "(z', z) \<in> R" by blast
       have "\<forall>y. (y, z') \<in> ?A \<longrightarrow> y \<notin> Q"
       proof (intro allI impI)
         fix y assume "(y, z') \<in> ?A"
         then show "y \<notin> Q"
         proof
           assume "(y, z') \<in> R"
           then have "(y, z) \<in> R O R" using \<open>(z', z) \<in> R\<close> ..
           with 1 show "y \<notin> Q" .
         next
           assume "(y, z') \<in> S"
           then have "(y, z) \<in> S O R" using  \<open>(z', z) \<in> R\<close> ..
           with 2 show "y \<notin> Q" .
         qed
       qed
       with \<open>z' \<in> Q\<close> show ?thesis ..
     qed
   qed
 qed
 
 lemma wf_comp_self: "wf R \<longleftrightarrow> wf (R O R)"  \<comment> \<open>special case\<close>
   by (rule wf_union_merge [where S = "{}", simplified])
 
 
 subsection \<open>Well-Foundedness of Composition\<close>
 
 text \<open>Bachmair and Dershowitz 1986, Lemma 2. [Provided by Tjark Weber]\<close>
 
 lemma qc_wf_relto_iff:
   assumes "R O S \<subseteq> (R \<union> S)\<^sup>* O R" \<comment> \<open>R quasi-commutes over S\<close>
   shows "wf (S\<^sup>* O R O S\<^sup>*) \<longleftrightarrow> wf R"
     (is "wf ?S \<longleftrightarrow> _")
 proof
   show "wf R" if "wf ?S"
   proof -
     have "R \<subseteq> ?S" by auto
     with wf_subset [of ?S] that show "wf R"
       by auto
   qed
 next
   show "wf ?S" if "wf R"
   proof (rule wfI_pf)
     fix A
     assume A: "A \<subseteq> ?S `` A"
     let ?X = "(R \<union> S)\<^sup>* `` A"
     have *: "R O (R \<union> S)\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R"
     proof -
       have "(x, z) \<in> (R \<union> S)\<^sup>* O R" if "(y, z) \<in> (R \<union> S)\<^sup>*" and "(x, y) \<in> R" for x y z
         using that
       proof (induct y z)
         case rtrancl_refl
         then show ?case by auto
       next
         case (rtrancl_into_rtrancl a b c)
         then have "(x, c) \<in> ((R \<union> S)\<^sup>* O (R \<union> S)\<^sup>*) O R"
           using assms by blast
         then show ?case by simp
       qed
       then show ?thesis by auto
     qed
     then have "R O S\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R"
       using rtrancl_Un_subset by blast
     then have "?S \<subseteq> (R \<union> S)\<^sup>* O (R \<union> S)\<^sup>* O R"
       by (simp add: relcomp_mono rtrancl_mono)
     also have "\<dots> = (R \<union> S)\<^sup>* O R"
       by (simp add: O_assoc[symmetric])
     finally have "?S O (R \<union> S)\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R O (R \<union> S)\<^sup>*"
       by (simp add: O_assoc[symmetric] relcomp_mono)
     also have "\<dots> \<subseteq> (R \<union> S)\<^sup>* O (R \<union> S)\<^sup>* O R"
       using * by (simp add: relcomp_mono)
     finally have "?S O (R \<union> S)\<^sup>* \<subseteq> (R \<union> S)\<^sup>* O R"
       by (simp add: O_assoc[symmetric])
     then have "(?S O (R \<union> S)\<^sup>*) `` A \<subseteq> ((R \<union> S)\<^sup>* O R) `` A"
       by (simp add: Image_mono)
     moreover have "?X \<subseteq> (?S O (R \<union> S)\<^sup>*) `` A"
       using A by (auto simp: relcomp_Image)
     ultimately have "?X \<subseteq> R `` ?X"
       by (auto simp: relcomp_Image)
     then have "?X = {}"
       using \<open>wf R\<close> by (simp add: wfE_pf)
     moreover have "A \<subseteq> ?X" by auto
     ultimately show "A = {}" by simp
   qed
 qed
 
 corollary wf_relcomp_compatible:
   assumes "wf R" and "R O S \<subseteq> S O R"
   shows "wf (S O R)"
 proof -
   have "R O S \<subseteq> (R \<union> S)\<^sup>* O R"
     using assms by blast
   then have "wf (S\<^sup>* O R O S\<^sup>*)"
     by (simp add: assms qc_wf_relto_iff)
   then show ?thesis
     by (rule Wellfounded.wf_subset) blast
 qed
 
 
 subsection \<open>Acyclic relations\<close>
 
 lemma wf_acyclic: "wf r \<Longrightarrow> acyclic r"
   by (simp add: acyclic_def) (blast elim: wf_trancl [THEN wf_irrefl])
 
 lemmas wfP_acyclicP = wf_acyclic [to_pred]
 
 
 subsubsection \<open>Wellfoundedness of finite acyclic relations\<close>
 
 lemma finite_acyclic_wf:
   assumes "finite r" "acyclic r" shows "wf r"
   using assms
 proof (induction r rule: finite_induct)
   case (insert x r)
   then show ?case
     by (cases x) simp
 qed simp
 
 lemma finite_acyclic_wf_converse: "finite r \<Longrightarrow> acyclic r \<Longrightarrow> wf (r\<inverse>)"
   apply (erule finite_converse [THEN iffD2, THEN finite_acyclic_wf])
   apply (erule acyclic_converse [THEN iffD2])
   done
 
 text \<open>
   Observe that the converse of an irreflexive, transitive,
   and finite relation is again well-founded. Thus, we may
   employ it for well-founded induction.
 \<close>
 lemma wf_converse:
   assumes "irrefl r" and "trans r" and "finite r"
   shows "wf (r\<inverse>)"
 proof -
   have "acyclic r"
     using \<open>irrefl r\<close> and \<open>trans r\<close>
     by (simp add: irrefl_def acyclic_irrefl)
   with \<open>finite r\<close> show ?thesis
     by (rule finite_acyclic_wf_converse)
 qed
 
 lemma wf_iff_acyclic_if_finite: "finite r \<Longrightarrow> wf r = acyclic r"
   by (blast intro: finite_acyclic_wf wf_acyclic)
 
 
 subsection \<open>\<^typ>\<open>nat\<close> is well-founded\<close>
 
 lemma less_nat_rel: "(<) = (\<lambda>m n. n = Suc m)\<^sup>+\<^sup>+"
 proof (rule ext, rule ext, rule iffI)
   fix n m :: nat
   show "(\<lambda>m n. n = Suc m)\<^sup>+\<^sup>+ m n" if "m < n"
     using that
   proof (induct n)
     case 0
     then show ?case by auto
   next
     case (Suc n)
     then show ?case
       by (auto simp add: less_Suc_eq_le le_less intro: tranclp.trancl_into_trancl)
   qed
   show "m < n" if "(\<lambda>m n. n = Suc m)\<^sup>+\<^sup>+ m n"
     using that by (induct n) (simp_all add: less_Suc_eq_le reflexive le_less)
 qed
 
 definition pred_nat :: "(nat \<times> nat) set"
   where "pred_nat = {(m, n). n = Suc m}"
 
 definition less_than :: "(nat \<times> nat) set"
   where "less_than = pred_nat\<^sup>+"
 
 lemma less_eq: "(m, n) \<in> pred_nat\<^sup>+ \<longleftrightarrow> m < n"
   unfolding less_nat_rel pred_nat_def trancl_def by simp
 
 lemma pred_nat_trancl_eq_le: "(m, n) \<in> pred_nat\<^sup>* \<longleftrightarrow> m \<le> n"
   unfolding less_eq rtrancl_eq_or_trancl by auto
 
 lemma wf_pred_nat: "wf pred_nat"
-  apply (unfold wf_def pred_nat_def)
-  apply clarify
-  apply (induct_tac x)
-   apply blast+
-  done
+  unfolding wf_def
+proof clarify
+  fix P x
+  assume "\<forall>x'. (\<forall>y. (y, x') \<in> pred_nat \<longrightarrow> P y) \<longrightarrow> P x'"
+  then show "P x"
+    unfolding pred_nat_def by (induction x) blast+
+qed
 
 lemma wf_less_than [iff]: "wf less_than"
   by (simp add: less_than_def wf_pred_nat [THEN wf_trancl])
 
 lemma trans_less_than [iff]: "trans less_than"
   by (simp add: less_than_def)
 
 lemma less_than_iff [iff]: "((x,y) \<in> less_than) = (x<y)"
   by (simp add: less_than_def less_eq)
 
 lemma irrefl_less_than: "irrefl less_than"
   using irrefl_def by blast
 
 lemma asym_less_than: "asym less_than"
   by (simp add: asym.simps irrefl_less_than)
 
 lemma total_less_than: "total less_than" and total_on_less_than [simp]: "total_on A less_than"
   using total_on_def by force+
 
 lemma wf_less: "wf {(x, y::nat). x < y}"
   by (rule Wellfounded.wellorder_class.wf)
 
 
 subsection \<open>Accessible Part\<close>
 
 text \<open>
   Inductive definition of the accessible part \<open>acc r\<close> of a
   relation; see also @{cite "paulin-tlca"}.
 \<close>
 
 inductive_set acc :: "('a \<times> 'a) set \<Rightarrow> 'a set" for r :: "('a \<times> 'a) set"
   where accI: "(\<And>y. (y, x) \<in> r \<Longrightarrow> y \<in> acc r) \<Longrightarrow> x \<in> acc r"
 
 abbreviation termip :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool"
   where "termip r \<equiv> accp (r\<inverse>\<inverse>)"
 
 abbreviation termi :: "('a \<times> 'a) set \<Rightarrow> 'a set"
   where "termi r \<equiv> acc (r\<inverse>)"
 
 lemmas accpI = accp.accI
 
 lemma accp_eq_acc [code]: "accp r = (\<lambda>x. x \<in> Wellfounded.acc {(x, y). r x y})"
   by (simp add: acc_def)
 
 
 text \<open>Induction rules\<close>
 
 theorem accp_induct:
   assumes major: "accp r a"
   assumes hyp: "\<And>x. accp r x \<Longrightarrow> \<forall>y. r y x \<longrightarrow> P y \<Longrightarrow> P x"
   shows "P a"
   apply (rule major [THEN accp.induct])
   apply (rule hyp)
    apply (rule accp.accI)
    apply auto
   done
 
 lemmas accp_induct_rule = accp_induct [rule_format, induct set: accp]
 
 theorem accp_downward: "accp r b \<Longrightarrow> r a b \<Longrightarrow> accp r a"
   by (cases rule: accp.cases)
 
 lemma not_accp_down:
   assumes na: "\<not> accp R x"
   obtains z where "R z x" and "\<not> accp R z"
 proof -
   assume a: "\<And>z. R z x \<Longrightarrow> \<not> accp R z \<Longrightarrow> thesis"
   show thesis
   proof (cases "\<forall>z. R z x \<longrightarrow> accp R z")
     case True
     then have "\<And>z. R z x \<Longrightarrow> accp R z" by auto
     then have "accp R x" by (rule accp.accI)
     with na show thesis ..
   next
     case False then obtain z where "R z x" and "\<not> accp R z"
       by auto
     with a show thesis .
   qed
 qed
 
 lemma accp_downwards_aux: "r\<^sup>*\<^sup>* b a \<Longrightarrow> accp r a \<longrightarrow> accp r b"
   by (erule rtranclp_induct) (blast dest: accp_downward)+
 
 theorem accp_downwards: "accp r a \<Longrightarrow> r\<^sup>*\<^sup>* b a \<Longrightarrow> accp r b"
   by (blast dest: accp_downwards_aux)
 
 theorem accp_wfPI: "\<forall>x. accp r x \<Longrightarrow> wfP r"
-  apply (rule wfPUNIVI)
-  apply (rule_tac P = P in accp_induct)
-   apply blast+
-  done
+proof (rule wfPUNIVI)
+  fix P x
+  assume "\<forall>x. accp r x" "\<forall>x. (\<forall>y. r y x \<longrightarrow> P y) \<longrightarrow> P x"
+  then show "P x"
+    using accp_induct[where P = P] by blast
+qed
 
 theorem accp_wfPD: "wfP r \<Longrightarrow> accp r x"
   apply (erule wfP_induct_rule)
   apply (rule accp.accI)
   apply blast
   done
 
 theorem wfP_accp_iff: "wfP r = (\<forall>x. accp r x)"
   by (blast intro: accp_wfPI dest: accp_wfPD)
 
 
 text \<open>Smaller relations have bigger accessible parts:\<close>
 
 lemma accp_subset:
   assumes "R1 \<le> R2"
   shows "accp R2 \<le> accp R1"
 proof (rule predicate1I)
   fix x
   assume "accp R2 x"
   then show "accp R1 x"
   proof (induct x)
     fix x
     assume "\<And>y. R2 y x \<Longrightarrow> accp R1 y"
     with assms show "accp R1 x"
       by (blast intro: accp.accI)
   qed
 qed
 
 
 text \<open>This is a generalized induction theorem that works on
   subsets of the accessible part.\<close>
 
 lemma accp_subset_induct:
   assumes subset: "D \<le> accp R"
     and dcl: "\<And>x z. D x \<Longrightarrow> R z x \<Longrightarrow> D z"
     and "D x"
     and istep: "\<And>x. D x \<Longrightarrow> (\<And>z. R z x \<Longrightarrow> P z) \<Longrightarrow> P x"
   shows "P x"
 proof -
   from subset and \<open>D x\<close>
   have "accp R x" ..
   then show "P x" using \<open>D x\<close>
   proof (induct x)
     fix x
     assume "D x" and "\<And>y. R y x \<Longrightarrow> D y \<Longrightarrow> P y"
     with dcl and istep show "P x" by blast
   qed
 qed
 
 
 text \<open>Set versions of the above theorems\<close>
 
 lemmas acc_induct = accp_induct [to_set]
 lemmas acc_induct_rule = acc_induct [rule_format, induct set: acc]
 lemmas acc_downward = accp_downward [to_set]
 lemmas not_acc_down = not_accp_down [to_set]
 lemmas acc_downwards_aux = accp_downwards_aux [to_set]
 lemmas acc_downwards = accp_downwards [to_set]
 lemmas acc_wfI = accp_wfPI [to_set]
 lemmas acc_wfD = accp_wfPD [to_set]
 lemmas wf_acc_iff = wfP_accp_iff [to_set]
 lemmas acc_subset = accp_subset [to_set]
 lemmas acc_subset_induct = accp_subset_induct [to_set]
 
 
 subsection \<open>Tools for building wellfounded relations\<close>
 
 text \<open>Inverse Image\<close>
 
 lemma wf_inv_image [simp,intro!]: 
   fixes f :: "'a \<Rightarrow> 'b"
   assumes "wf r"
   shows "wf (inv_image r f)"
-proof (clarsimp simp: inv_image_def wf_eq_minimal)
-  fix P and x::'a
-  assume "x \<in> P"
-  then obtain w where w: "w \<in> {w. \<exists>x::'a. x \<in> P \<and> f x = w}"
-    by auto
-  have *: "\<And>Q u. u \<in> Q \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q"
-    using assms by (auto simp add: wf_eq_minimal)
-  show "\<exists>z\<in>P. \<forall>y. (f y, f z) \<in> r \<longrightarrow> y \<notin> P"
-    using * [OF w] by auto
+proof -
+  have "\<And>x P. x \<in> P \<Longrightarrow> \<exists>z\<in>P. \<forall>y. (f y, f z) \<in> r \<longrightarrow> y \<notin> P"
+  proof -
+    fix P and x::'a
+    assume "x \<in> P"
+    then obtain w where w: "w \<in> {w. \<exists>x::'a. x \<in> P \<and> f x = w}"
+      by auto
+    have *: "\<And>Q u. u \<in> Q \<Longrightarrow> \<exists>z\<in>Q. \<forall>y. (y, z) \<in> r \<longrightarrow> y \<notin> Q"
+      using assms by (auto simp add: wf_eq_minimal)
+    show "\<exists>z\<in>P. \<forall>y. (f y, f z) \<in> r \<longrightarrow> y \<notin> P"
+      using * [OF w] by auto
+  qed
+  then show ?thesis
+    by (clarsimp simp: inv_image_def wf_eq_minimal)
 qed
 
 text \<open>Measure functions into \<^typ>\<open>nat\<close>\<close>
 
 definition measure :: "('a \<Rightarrow> nat) \<Rightarrow> ('a \<times> 'a) set"
   where "measure = inv_image less_than"
 
 lemma in_measure[simp, code_unfold]: "(x, y) \<in> measure f \<longleftrightarrow> f x < f y"
   by (simp add:measure_def)
 
 lemma wf_measure [iff]: "wf (measure f)"
   unfolding measure_def by (rule wf_less_than [THEN wf_inv_image])
 
 lemma wf_if_measure: "(\<And>x. P x \<Longrightarrow> f(g x) < f x) \<Longrightarrow> wf {(y,x). P x \<and> y = g x}"
   for f :: "'a \<Rightarrow> nat"
   using wf_measure[of f] unfolding measure_def inv_image_def less_than_def less_eq
   by (rule wf_subset) auto
 
 
 subsubsection \<open>Lexicographic combinations\<close>
 
 definition lex_prod :: "('a \<times>'a) set \<Rightarrow> ('b \<times> 'b) set \<Rightarrow> (('a \<times> 'b) \<times> ('a \<times> 'b)) set"
     (infixr "<*lex*>" 80)
     where "ra <*lex*> rb = {((a, b), (a', b')). (a, a') \<in> ra \<or> a = a' \<and> (b, b') \<in> rb}"
 
 lemma in_lex_prod[simp]: "((a, b), (a', b')) \<in> r <*lex*> s \<longleftrightarrow> (a, a') \<in> r \<or> a = a' \<and> (b, b') \<in> s"
   by (auto simp:lex_prod_def)
 
 lemma wf_lex_prod [intro!]:
   assumes "wf ra" "wf rb"
   shows "wf (ra <*lex*> rb)"
 proof (rule wfI)
   fix z :: "'a \<times> 'b" and P
   assume * [rule_format]: "\<forall>u. (\<forall>v. (v, u) \<in> ra <*lex*> rb \<longrightarrow> P v) \<longrightarrow> P u"
   obtain x y where zeq: "z = (x,y)"
     by fastforce
   have "P(x,y)" using \<open>wf ra\<close>
   proof (induction x arbitrary: y rule: wf_induct_rule)
     case (less x)
     note lessx = less
     show ?case using \<open>wf rb\<close> less
     proof (induction y rule: wf_induct_rule)
       case (less y)
       show ?case
         by (force intro: * less.IH lessx)
     qed
   qed
   then show "P z"
     by (simp add: zeq)
 qed auto
 
 text \<open>\<open><*lex*>\<close> preserves transitivity\<close>
 lemma trans_lex_prod [simp,intro!]: "trans R1 \<Longrightarrow> trans R2 \<Longrightarrow> trans (R1 <*lex*> R2)"
   unfolding trans_def lex_prod_def by blast
 
 lemma total_on_lex_prod [simp]: "total_on A r \<Longrightarrow> total_on B s \<Longrightarrow> total_on (A \<times> B) (r <*lex*> s)"
   by (auto simp: total_on_def)
 
 lemma asym_lex_prod: "\<lbrakk>asym R; asym S\<rbrakk> \<Longrightarrow> asym (R <*lex*> S)"
   by (auto simp add: asym_iff lex_prod_def)
 
 lemma total_lex_prod [simp]: "total r \<Longrightarrow> total s \<Longrightarrow> total (r <*lex*> s)"
   by (auto simp: total_on_def)
 
 text \<open>lexicographic combinations with measure functions\<close>
 
 definition mlex_prod :: "('a \<Rightarrow> nat) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set" (infixr "<*mlex*>" 80)
   where "f <*mlex*> R = inv_image (less_than <*lex*> R) (\<lambda>x. (f x, x))"
 
 lemma
   wf_mlex: "wf R \<Longrightarrow> wf (f <*mlex*> R)" and
   mlex_less: "f x < f y \<Longrightarrow> (x, y) \<in> f <*mlex*> R" and
   mlex_leq: "f x \<le> f y \<Longrightarrow> (x, y) \<in> R \<Longrightarrow> (x, y) \<in> f <*mlex*> R" and
   mlex_iff: "(x, y) \<in> f <*mlex*> R \<longleftrightarrow> f x < f y \<or> f x = f y \<and> (x, y) \<in> R"
   by (auto simp: mlex_prod_def)
 
 text \<open>Proper subset relation on finite sets.\<close>
 definition finite_psubset :: "('a set \<times> 'a set) set"
   where "finite_psubset = {(A, B). A \<subset> B \<and> finite B}"
 
 lemma wf_finite_psubset[simp]: "wf finite_psubset"
   apply (unfold finite_psubset_def)
   apply (rule wf_measure [THEN wf_subset])
   apply (simp add: measure_def inv_image_def less_than_def less_eq)
   apply (fast elim!: psubset_card_mono)
   done
 
 lemma trans_finite_psubset: "trans finite_psubset"
   by (auto simp: finite_psubset_def less_le trans_def)
 
 lemma in_finite_psubset[simp]: "(A, B) \<in> finite_psubset \<longleftrightarrow> A \<subset> B \<and> finite B"
   unfolding finite_psubset_def by auto
 
 text \<open>max- and min-extension of order to finite sets\<close>
 
 inductive_set max_ext :: "('a \<times> 'a) set \<Rightarrow> ('a set \<times> 'a set) set"
   for R :: "('a \<times> 'a) set"
   where max_extI[intro]:
     "finite X \<Longrightarrow> finite Y \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> (\<And>x. x \<in> X \<Longrightarrow> \<exists>y\<in>Y. (x, y) \<in> R) \<Longrightarrow> (X, Y) \<in> max_ext R"
 
 lemma max_ext_wf:
   assumes wf: "wf r"
   shows "wf (max_ext r)"
 proof (rule acc_wfI, intro allI)
   show "M \<in> acc (max_ext r)" (is "_ \<in> ?W") for M
   proof (induct M rule: infinite_finite_induct)
     case empty
     show ?case
       by (rule accI) (auto elim: max_ext.cases)
   next
     case (insert a M)
     from wf \<open>M \<in> ?W\<close> \<open>finite M\<close> show "insert a M \<in> ?W"
     proof (induct arbitrary: M)
       fix M a
       assume "M \<in> ?W"
       assume [intro]: "finite M"
       assume hyp: "\<And>b M. (b, a) \<in> r \<Longrightarrow> M \<in> ?W \<Longrightarrow> finite M \<Longrightarrow> insert b M \<in> ?W"
       have add_less: "M \<in> ?W \<Longrightarrow> (\<And>y. y \<in> N \<Longrightarrow> (y, a) \<in> r) \<Longrightarrow> N \<union> M \<in> ?W"
         if "finite N" "finite M" for N M :: "'a set"
         using that by (induct N arbitrary: M) (auto simp: hyp)
       show "insert a M \<in> ?W"
       proof (rule accI)
         fix N
         assume Nless: "(N, insert a M) \<in> max_ext r"
         then have *: "\<And>x. x \<in> N \<Longrightarrow> (x, a) \<in> r \<or> (\<exists>y \<in> M. (x, y) \<in> r)"
           by (auto elim!: max_ext.cases)
 
         let ?N1 = "{n \<in> N. (n, a) \<in> r}"
         let ?N2 = "{n \<in> N. (n, a) \<notin> r}"
         have N: "?N1 \<union> ?N2 = N" by (rule set_eqI) auto
         from Nless have "finite N" by (auto elim: max_ext.cases)
         then have finites: "finite ?N1" "finite ?N2" by auto
 
         have "?N2 \<in> ?W"
         proof (cases "M = {}")
           case [simp]: True
           have Mw: "{} \<in> ?W" by (rule accI) (auto elim: max_ext.cases)
           from * have "?N2 = {}" by auto
           with Mw show "?N2 \<in> ?W" by (simp only:)
         next
           case False
           from * finites have N2: "(?N2, M) \<in> max_ext r"
-            by (rule_tac max_extI[OF _ _ \<open>M \<noteq> {}\<close>]) auto
+            using max_extI[OF _ _ \<open>M \<noteq> {}\<close>, where ?X = ?N2] by auto
           with \<open>M \<in> ?W\<close> show "?N2 \<in> ?W" by (rule acc_downward)
         qed
         with finites have "?N1 \<union> ?N2 \<in> ?W"
           by (rule add_less) simp
         then show "N \<in> ?W" by (simp only: N)
       qed
     qed
   next
     case infinite
     show ?case
       by (rule accI) (auto elim: max_ext.cases simp: infinite)
   qed
 qed
 
 lemma max_ext_additive: "(A, B) \<in> max_ext R \<Longrightarrow> (C, D) \<in> max_ext R \<Longrightarrow> (A \<union> C, B \<union> D) \<in> max_ext R"
   by (force elim!: max_ext.cases)
 
 definition min_ext :: "('a \<times> 'a) set \<Rightarrow> ('a set \<times> 'a set) set"
   where "min_ext r = {(X, Y) | X Y. X \<noteq> {} \<and> (\<forall>y \<in> Y. (\<exists>x \<in> X. (x, y) \<in> r))}"
 
 lemma min_ext_wf:
   assumes "wf r"
   shows "wf (min_ext r)"
 proof (rule wfI_min)
   show "\<exists>m \<in> Q. (\<forall>n. (n, m) \<in> min_ext r \<longrightarrow> n \<notin> Q)" if nonempty: "x \<in> Q"
     for Q :: "'a set set" and x
   proof (cases "Q = {{}}")
     case True
     then show ?thesis by (simp add: min_ext_def)
   next
     case False
     with nonempty obtain e x where "x \<in> Q" "e \<in> x" by force
     then have eU: "e \<in> \<Union>Q" by auto
     with \<open>wf r\<close>
     obtain z where z: "z \<in> \<Union>Q" "\<And>y. (y, z) \<in> r \<Longrightarrow> y \<notin> \<Union>Q"
       by (erule wfE_min)
     from z obtain m where "m \<in> Q" "z \<in> m" by auto
     from \<open>m \<in> Q\<close> show ?thesis
     proof (intro rev_bexI allI impI)
       fix n
       assume smaller: "(n, m) \<in> min_ext r"
       with \<open>z \<in> m\<close> obtain y where "y \<in> n" "(y, z) \<in> r"
         by (auto simp: min_ext_def)
       with z(2) show "n \<notin> Q" by auto
     qed
   qed
 qed
 
 
 subsubsection \<open>Bounded increase must terminate\<close>
 
 lemma wf_bounded_measure:
   fixes ub :: "'a \<Rightarrow> nat"
     and f :: "'a \<Rightarrow> nat"
   assumes "\<And>a b. (b, a) \<in> r \<Longrightarrow> ub b \<le> ub a \<and> ub a \<ge> f b \<and> f b > f a"
   shows "wf r"
   by (rule wf_subset[OF wf_measure[of "\<lambda>a. ub a - f a"]]) (auto dest: assms)
 
 lemma wf_bounded_set:
   fixes ub :: "'a \<Rightarrow> 'b set"
     and f :: "'a \<Rightarrow> 'b set"
   assumes "\<And>a b. (b,a) \<in> r \<Longrightarrow> finite (ub a) \<and> ub b \<subseteq> ub a \<and> ub a \<supseteq> f b \<and> f b \<supset> f a"
   shows "wf r"
   apply (rule wf_bounded_measure[of r "\<lambda>a. card (ub a)" "\<lambda>a. card (f a)"])
   apply (drule assms)
   apply (blast intro: card_mono finite_subset psubset_card_mono dest: psubset_eq[THEN iffD2])
   done
 
 lemma finite_subset_wf:
   assumes "finite A"
   shows "wf {(X, Y). X \<subset> Y \<and> Y \<subseteq> A}"
   by (rule wf_subset[OF wf_finite_psubset[unfolded finite_psubset_def]])
     (auto intro: finite_subset[OF _ assms])
 
 hide_const (open) acc accp
 
 end
diff --git a/src/HOL/Wfrec.thy b/src/HOL/Wfrec.thy
--- a/src/HOL/Wfrec.thy
+++ b/src/HOL/Wfrec.thy
@@ -1,115 +1,120 @@
 (*  Title:      HOL/Wfrec.thy
     Author:     Tobias Nipkow
     Author:     Lawrence C Paulson
     Author:     Konrad Slind
 *)
 
 section \<open>Well-Founded Recursion Combinator\<close>
 
 theory Wfrec
   imports Wellfounded
 begin
 
 inductive wfrec_rel :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool" for R F
   where wfrecI: "(\<And>z. (z, x) \<in> R \<Longrightarrow> wfrec_rel R F z (g z)) \<Longrightarrow> wfrec_rel R F x (F g x)"
 
 definition cut :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'b"
   where "cut f R x = (\<lambda>y. if (y, x) \<in> R then f y else undefined)"
 
 definition adm_wf :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)) \<Rightarrow> bool"
   where "adm_wf R F \<longleftrightarrow> (\<forall>f g x. (\<forall>z. (z, x) \<in> R \<longrightarrow> f z = g z) \<longrightarrow> F f x = F g x)"
 
 definition wfrec :: "('a \<times> 'a) set \<Rightarrow> (('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)) \<Rightarrow> ('a \<Rightarrow> 'b)"
   where "wfrec R F = (\<lambda>x. THE y. wfrec_rel R (\<lambda>f x. F (cut f R x) x) x y)"
 
 lemma cuts_eq: "(cut f R x = cut g R x) \<longleftrightarrow> (\<forall>y. (y, x) \<in> R \<longrightarrow> f y = g y)"
   by (simp add: fun_eq_iff cut_def)
 
 lemma cut_apply: "(x, a) \<in> R \<Longrightarrow> cut f R a x = f x"
   by (simp add: cut_def)
 
 text \<open>
   Inductive characterization of \<open>wfrec\<close> combinator; for details see:
   John Harrison, "Inductive definitions: automation and application".
 \<close>
 
 lemma theI_unique: "\<exists>!x. P x \<Longrightarrow> P x \<longleftrightarrow> x = The P"
   by (auto intro: the_equality[symmetric] theI)
 
 lemma wfrec_unique:
   assumes "adm_wf R F" "wf R"
   shows "\<exists>!y. wfrec_rel R F x y"
   using \<open>wf R\<close>
 proof induct
   define f where "f y = (THE z. wfrec_rel R F y z)" for y
   case (less x)
   then have "\<And>y z. (y, x) \<in> R \<Longrightarrow> wfrec_rel R F y z \<longleftrightarrow> z = f y"
     unfolding f_def by (rule theI_unique)
   with \<open>adm_wf R F\<close> show ?case
     by (subst wfrec_rel.simps) (auto simp: adm_wf_def)
 qed
 
 lemma adm_lemma: "adm_wf R (\<lambda>f x. F (cut f R x) x)"
   by (auto simp: adm_wf_def intro!: arg_cong[where f="\<lambda>x. F x y" for y] cuts_eq[THEN iffD2])
 
 lemma wfrec: "wf R \<Longrightarrow> wfrec R F a = F (cut (wfrec R F) R a) a"
   apply (simp add: wfrec_def)
   apply (rule adm_lemma [THEN wfrec_unique, THEN the1_equality])
    apply assumption
   apply (rule wfrec_rel.wfrecI)
   apply (erule adm_lemma [THEN wfrec_unique, THEN theI'])
   done
 
 
 text \<open>This form avoids giant explosions in proofs.  NOTE USE OF \<open>\<equiv>\<close>.\<close>
 lemma def_wfrec: "f \<equiv> wfrec R F \<Longrightarrow> wf R \<Longrightarrow> f a = F (cut f R a) a"
   by (auto intro: wfrec)
 
 
 subsubsection \<open>Well-founded recursion via genuine fixpoints\<close>
 
 lemma wfrec_fixpoint:
   assumes wf: "wf R"
     and adm: "adm_wf R F"
   shows "wfrec R F = F (wfrec R F)"
 proof (rule ext)
   fix x
   have "wfrec R F x = F (cut (wfrec R F) R x) x"
     using wfrec[of R F] wf by simp
   also
   have "\<And>y. (y, x) \<in> R \<Longrightarrow> cut (wfrec R F) R x y = wfrec R F y"
     by (auto simp add: cut_apply)
   then have "F (cut (wfrec R F) R x) x = F (wfrec R F) x"
     using adm adm_wf_def[of R F] by auto
   finally show "wfrec R F x = F (wfrec R F) x" .
 qed
 
 lemma wfrec_def_adm: "f \<equiv> wfrec R F \<Longrightarrow> wf R \<Longrightarrow> adm_wf R F \<Longrightarrow> f = F f"
   using wfrec_fixpoint by simp
 
 
 subsection \<open>Wellfoundedness of \<open>same_fst\<close>\<close>
 
 definition same_fst :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b \<times> 'b) set) \<Rightarrow> (('a \<times> 'b) \<times> ('a \<times> 'b)) set"
   where "same_fst P R = {((x', y'), (x, y)) . x' = x \<and> P x \<and> (y',y) \<in> R x}"
    \<comment> \<open>For \<^const>\<open>wfrec\<close> declarations where the first n parameters
        stay unchanged in the recursive call.\<close>
 
 lemma same_fstI [intro!]: "P x \<Longrightarrow> (y', y) \<in> R x \<Longrightarrow> ((x, y'), (x, y)) \<in> same_fst P R"
   by (simp add: same_fst_def)
 
 lemma wf_same_fst:
   assumes "\<And>x. P x \<Longrightarrow> wf (R x)"
   shows "wf (same_fst P R)"
-proof (clarsimp simp add: wf_def same_fst_def)
-  fix Q a b
-  assume *: "\<forall>a b. (\<forall>x. P a \<and> (x,b) \<in> R a \<longrightarrow> Q (a,x)) \<longrightarrow> Q (a,b)"
-  show "Q(a,b)"
-  proof (cases "wf (R a)")
-    case True
-    then show ?thesis
-      by (induction b rule: wf_induct_rule) (use * in blast)
-  qed (use * assms in blast)
+proof -
+  have "\<And>a b Q. \<forall>a b. (\<forall>x. P a \<and> (x, b) \<in> R a \<longrightarrow> Q (a, x)) \<longrightarrow> Q (a, b) \<Longrightarrow> Q (a, b)"
+  proof -
+    fix Q a b
+    assume *: "\<forall>a b. (\<forall>x. P a \<and> (x,b) \<in> R a \<longrightarrow> Q (a,x)) \<longrightarrow> Q (a,b)"
+    show "Q(a,b)"
+    proof (cases "wf (R a)")
+      case True
+      then show ?thesis
+        by (induction b rule: wf_induct_rule) (use * in blast)
+    qed (use * assms in blast)
+  qed
+  then show ?thesis
+    by (clarsimp simp add: wf_def same_fst_def)
 qed
 
 end